From 1407258585a5d65f90b82516f83b5cadb3101541 Mon Sep 17 00:00:00 2001
From: Gabor Greif <ggreif@gmail.com>
Date: Wed, 17 Jan 2018 14:47:00 +0100
Subject: WIP: triggering CI for Simon's patch

---
 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 b021fe070d..c051c91812 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 2027928e3f..816c5e25e3 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
@@ -812,6 +813,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 d0ad6c5dd1..a1f0b0b635 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
@@ -41,7 +41,6 @@ import TyCon       ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
                    , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons )
 import DataCon     ( DataCon, dataConTagZ, dataConTyCon, dataConWorkId )
 import CoreUtils   ( cheapEqExpr, exprIsHNF, exprType )
-import CoreUnfold  ( exprIsConApp_maybe )
 import Type
 import OccName     ( occNameFS )
 import PrelNames
@@ -745,9 +744,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
@@ -1006,8 +1002,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))
 
-- 
cgit v1.2.1