[commit: ghc] wip/T14626: WIP: Simon's tentative patch for #14677 (3fdf567)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T14626
Link       : http://ghc.haskell.org/trac/ghc/changeset/3fdf567a48958eefdb690d7d0cd81a3bf876483f/ghc

>---------------------------------------------------------------

commit 3fdf567a48958eefdb690d7d0cd81a3bf876483f
Author: Gabor Greif <ggreif at gmail.com>
Date:   Tue Jan 16 18:34:36 2018 +0100

    WIP: Simon's tentative patch for #14677


>---------------------------------------------------------------

3fdf567a48958eefdb690d7d0cd81a3bf876483f
 compiler/codeGen/StgCmmClosure.hs |  8 ++++++++
 compiler/coreSyn/CoreOpt.hs       | 20 +++++++++++++++++++-
 compiler/prelude/PrelRules.hs     |  5 ++---
 3 files changed, 29 insertions(+), 4 deletions(-)

diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index e319548..31fc592 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -68,6 +68,8 @@ module StgCmmClosure (
 
 import GhcPrelude
 
+import CoreSyn( isValueUnfolding, maybeUnfoldingTemplate )
+import CoreOpt( exprIsSatConApp_maybe )
 import StgSyn
 import CoreSyn (isEvaldUnfolding, Unfolding(..))
 import SMRep
@@ -327,6 +329,11 @@ mkLFImported id
                 -- We assume that the constructor is evaluated so that
                 -- the id really does point directly to the constructor
 
+  | isValueUnfolding unf
+  , Just expr <- maybeUnfoldingTemplate unf
+  , Just con <- exprIsSatConApp_maybe expr
+  = LFCon con
+
   | arity > 0
   = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")
 
@@ -334,6 +341,7 @@ mkLFImported id
   = mkLFArgument id -- Not sure of exact arity
   where
     arity = idFunRepArity id
+    unf   = realIdUnfolding id
 
 -------------
 mkLFStringLit :: LambdaFormInfo
diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index 4240647..83b6a65 100644
--- a/compiler/coreSyn/CoreOpt.hs
+++ b/compiler/coreSyn/CoreOpt.hs
@@ -12,7 +12,8 @@ module CoreOpt (
         joinPointBinding_maybe, joinPointBindings_maybe,
 
         -- ** Predicates on expressions
-        exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,
+        exprIsConApp_maybe, exprIsLiteral_maybe,
+        exprIsLambda_maybe, exprIsSatConApp_maybe,
 
         -- ** Coercions and casts
         pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo
@@ -831,6 +832,23 @@ exprIsConApp_maybe (in_scope, id_unf) expr
     extend (Right s)       v e = Right (extendSubst s v e)
 
 
+exprIsSatConApp_maybe :: CoreExpr -> Maybe DataCon
+-- Returns (Just dc) for a saturated application of dc
+-- Simpler than exprIsConApp_maybe
+exprIsSatConApp_maybe e = go 0 e
+  where
+    go :: Arity -> CoreExpr -> Maybe DataCon
+    go n_val_args (Var v)
+       | Just dc <- isDataConWorkId_maybe v
+       , dataConRepArity dc == n_val_args
+       = Just dc
+    go n_val_args (App f a)
+       | isTypeArg a = go n_val_args       f
+       | otherwise   = go (n_val_args + 1) f
+    go n_val_args (Cast e _) = go n_val_args e
+    go n_val_args (Tick _ e) = go n_val_args e
+    go _ _ = Nothing
+
 -- See Note [exprIsConApp_maybe on literal strings]
 dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
                       -> Maybe (DataCon, [Type], [CoreExpr])
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index db79589..384a580 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -33,7 +33,7 @@ import CoreSyn
 import MkCore
 import Id
 import Literal
-import CoreOpt     ( exprIsLiteral_maybe )
+import CoreOpt     ( exprIsLiteral_maybe, exprIsSatConApp_maybe )
 import PrimOp      ( PrimOp(..), tagToEnumKey )
 import TysWiredIn
 import TysPrim
@@ -916,8 +916,7 @@ dataToTagRule = a `mplus` b
     b = do
       dflags <- getDynFlags
       [_, val_arg] <- getArgs
-      in_scope <- getInScopeEnv
-      (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
+      dc <- liftMaybe $ exprIsSatConApp_maybe val_arg
       ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
       return $ mkIntVal dflags (toInteger (dataConTagZ dc))