summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGabor Greif <ggreif@gmail.com>2018-01-17 14:47:00 +0100
committerGabor Greif <ggreif@gmail.com>2018-05-23 17:55:46 +0200
commit1407258585a5d65f90b82516f83b5cadb3101541 (patch)
treeac95a72f78f41c3d375ec85caa40f36296372fd4
parenta32c8f7514c8192fa064537fb93d5a5c224991a0 (diff)
downloadhaskell-1407258585a5d65f90b82516f83b5cadb3101541.tar.gz
WIP: triggering CI for Simon's patch
-rw-r--r--compiler/codeGen/StgCmmClosure.hs8
-rw-r--r--compiler/coreSyn/CoreOpt.hs20
-rw-r--r--compiler/prelude/PrelRules.hs9
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))