Rollback INLINE patches

[ghc-hetmet.git] / compiler / coreSyn / CorePrep.lhs

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 4d94261..5fa5002 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -35,6 +35,7 @@ import DynFlags
 import Util
 import Outputable
 import MonadUtils
+import FastString
 \end{code}
 
 -- ---------------------------------------------------------------------------
@@ -177,7 +178,7 @@ addFloat :: Floats -> FloatingBind -> Floats
 addFloat (Floats ok_to_spec floats) new_float
   = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
   where
-    check (FloatLet _)               = OkToSpec
+    check (FloatLet _) = OkToSpec
     check (FloatCase _ _ ok_for_spec) 
        | ok_for_spec  =  IfUnboxedOk
        | otherwise    =  NotOkToSpec
@@ -323,7 +324,8 @@ corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
           -> UniqSM (Floats, CoreArg)
 corePrepArg env arg dem = do
     (floats, arg') <- corePrepExprFloat env arg
-    if exprIsTrivial arg'
+    if exprIsTrivial arg' && allLazy NotTopLevel NonRecursive floats
+       -- Note [Floating unlifted arguments]
      then return (floats, arg')
      else do v <- newVar (exprType arg')
              (floats', v') <- mkLocalNonRec v dem floats arg'
@@ -340,7 +342,23 @@ exprIsTrivial (Note _ e)               = exprIsTrivial e
 exprIsTrivial (Cast e _)               = exprIsTrivial e
 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 exprIsTrivial _                        = False
+\end{code}
+
+Note [Floating unlifted arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider    C (let v* = expensive in v)
+
+where the "*" indicates "will be demanded".  Usually v will have been
+inlined by now, but let's suppose it hasn't (see Trac #2756).  Then we
+do *not* want to get
+
+     let v* = expensive in C v
 
+because that has different strictness.  Hence the use of 'allLazy'.
+(NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
+
+
+\begin{code}
 -- ---------------------------------------------------------------------------
 -- Dealing with expressions
 -- ---------------------------------------------------------------------------
@@ -602,11 +620,11 @@ mkLocalNonRec bndr dem floats rhs
 
   | isStrict dem 
        -- It's a strict let so we definitely float all the bindings
- = let         -- Don't make a case for a value binding,
+  = let                -- Don't make a case for a value binding,
                -- even if it's strict.  Otherwise we get
                --      case (\x -> e) of ...!
        float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
-             | otherwise       = FloatCase bndr rhs (exprOkForSpeculation rhs)
+             | otherwise     = FloatCase bndr rhs (exprOkForSpeculation rhs)
     in
     return (addFloat floats float, evald_bndr)
 
@@ -633,7 +651,7 @@ mkBinds (Floats _ binds) body
 etaExpandRhs :: CoreBndr -> CoreExpr -> UniqSM CoreExpr
 etaExpandRhs bndr rhs = do
        -- Eta expand to match the arity claimed by the binder
-       -- Remember, after CorePrep we must not change arity
+       -- Remember, CorePrep must not change arity
        --
        -- Eta expansion might not have happened already, 
        -- because it is done by the simplifier only when 
@@ -662,7 +680,12 @@ etaExpandRhs bndr rhs = do
        --              f = /\a -> \y -> let s = h 3 in g s y
        --
     us <- getUniquesM
-    return (etaExpand arity us rhs (idType bndr))
+    let eta_rhs = etaExpand arity us rhs (idType bndr)
+
+    ASSERT2( manifestArity eta_rhs == arity, (ppr bndr <+> ppr arity <+> ppr (exprArity rhs)) 
+                                             $$ ppr rhs $$ ppr eta_rhs )
+       -- Assertion checks that eta expansion was successful
+      return eta_rhs
   where
        -- For a GlobalId, take the Arity from the Id.
        -- It was set in CoreTidy and must not change
@@ -840,5 +863,5 @@ newVar :: Type -> UniqSM Id
 newVar ty
  = seqType ty `seq` do
      uniq <- getUniqueM
-     return (mkSysLocal FSLIT("sat") uniq ty)
+     return (mkSysLocal (fsLit "sat") uniq ty)
 \end{code}