Make {-# UNPACK #-} work for type/data family invocations
[ghc.git] / compiler / simplCore / Simplify.lhs
index df30142..c8e8956 100644 (file)
@@ -23,7 +23,7 @@ import Name             ( mkSystemVarName, isExternalName )
 import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
 import OptCoercion      ( optCoercion )
 import FamInstEnv       ( topNormaliseType )
-import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )
+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness, isMarkedStrict )
 import CoreMonad        ( Tick(..), SimplifierMode(..) )
 import CoreSyn
 import Demand           ( isStrictDmd, StrictSig(..), dmdTypeDepth )
@@ -33,7 +33,7 @@ import CoreUtils
 import qualified CoreSubst
 import CoreArity
 import Rules            ( lookupRule, getRules )
-import BasicTypes       ( isMarkedStrict, Arity )
+import BasicTypes       ( Arity )
 import TysPrim          ( realWorldStatePrimTy )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils       ( foldlM, mapAccumLM, liftIO )
@@ -291,12 +291,12 @@ simplRecOrTopPair :: SimplEnv
                   -> SimplM SimplEnv    -- Returns an env that includes the binding
 
 simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
-  | preInlineUnconditionally env top_lvl old_bndr rhs   -- Check for unconditional inline
-  = do  { tick (PreInlineUnconditionally old_bndr)
-        ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
-
-  | otherwise
-  = simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
+  = do dflags <- getDynFlags
+       -- Check for unconditional inline
+       if preInlineUnconditionally dflags env top_lvl old_bndr rhs
+           then do tick (PreInlineUnconditionally old_bndr)
+                   return (extendIdSubst env old_bndr (mkContEx env rhs))
+           else simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
 \end{code}
 
 
@@ -1333,21 +1333,24 @@ simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
         ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
 
 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
-  | preInlineUnconditionally env NotTopLevel bndr rhs
-  = do  { tick (PreInlineUnconditionally bndr)
-        ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
-          simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
-
-  | isStrictId bndr              -- Includes coercions
-  = do  { simplExprF (rhs_se `setFloats` env) rhs
-                     (StrictBind bndr bndrs body env cont) }
-
-  | otherwise
-  = ASSERT( not (isTyVar bndr) )
-    do  { (env1, bndr1) <- simplNonRecBndr env bndr
-        ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
-        ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
-        ; simplLam env3 bndrs body cont }
+  = do dflags <- getDynFlags
+       case () of
+         _
+          | preInlineUnconditionally dflags env NotTopLevel bndr rhs ->
+            do  { tick (PreInlineUnconditionally bndr)
+                ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
+                  simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
+
+          | isStrictId bndr ->           -- Includes coercions
+            do  { simplExprF (rhs_se `setFloats` env) rhs
+                             (StrictBind bndr bndrs body env cont) }
+
+          | otherwise ->
+            ASSERT( not (isTyVar bndr) )
+            do  { (env1, bndr1) <- simplNonRecBndr env bndr
+                ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
+                ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
+                ; simplLam env3 bndrs body cont }
 \end{code}
 
 %************************************************************************
@@ -1582,7 +1585,7 @@ tryRules env rules fn args call_cont
       | otherwise
       = return ()
 
-    log_rule dflags dflag hdr details = liftIO . dumpSDoc dflags dflag "" $
+    log_rule dflags flag hdr details = liftIO . dumpSDoc dflags flag "" $
       sep [text hdr, nest 4 details]
 
 \end{code}
@@ -1793,7 +1796,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
           --                            ppr scrut]) $
           tick (CaseElim case_bndr)
         ; env' <- simplNonRecX env case_bndr scrut
-          -- If case_bndr is deads, simplNonRecX will discard
+          -- If case_bndr is dead, simplNonRecX will discard
         ; simplExprF env' rhs cont }
   where
     elim_lifted   -- See Note [Case elimination: lifted case]