[commit: ghc] wip/T14677: WIP: triggering CI for Simon's patch (1fb37f5)

[git at git.haskell.org]

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

On branch  : wip/T14677
Link       : http://ghc.haskell.org/trac/ghc/changeset/1fb37f5249833b6f5a101f754e4e02f101f76e02/ghc

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

commit 1fb37f5249833b6f5a101f754e4e02f101f76e02
Author: Gabor Greif <ggreif at gmail.com>
Date:   Wed Jan 17 14:47:00 2018 +0100

    WIP: triggering CI for Simon's patch


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

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

diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 65e7cf7..b220b12 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 SMRep
 import Cmm
@@ -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 f4fc94d..9066217 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
@@ -837,6 +838,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 cd04074..d8d047a 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
@@ -42,7 +42,6 @@ import TyCon       ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
                    , tyConFamilySize )
 import DataCon     ( dataConTagZ, dataConTyCon, dataConWorkId )
 import CoreUtils   ( cheapEqExpr, exprIsHNF, exprType )
-import CoreUnfold  ( exprIsConApp_maybe )
 import Type
 import OccName     ( occNameFS )
 import PrelNames
@@ -789,9 +788,6 @@ removeOp32 = do
 getArgs :: RuleM [CoreExpr]
 getArgs = RuleM $ \_ _ args -> Just args
 
-getInScopeEnv :: RuleM InScopeEnv
-getInScopeEnv = RuleM $ \_ iu _ -> Just iu
-
 -- return the n-th argument of this rule, if it is a literal
 -- argument indices start from 0
 getLiteral :: Int -> RuleM Literal
@@ -1037,8 +1033,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))