X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=db8bebc7980b41c6929f4ad6a75f86fd9808658a;hb=85f8276b368d39c93e137fa7b0a8a96ab3c6b389;hp=4d942611e3966df68b7a6ae02aa56c97156c7679;hpb=b5751b8e46401a9c193756c6ea8adf48df3ca516;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 4d94261..db8bebc 100644
--- 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}
 
 -- ---------------------------------------------------------------------------
@@ -60,8 +61,9 @@ The goal of this pass is to prepare for code generation.
     [I'm experimenting with leaving 'ok-for-speculation' 
      rhss in let-form right up to this point.]
 
-4.  Ensure that lambdas only occur as the RHS of a binding
+4.  Ensure that *value* lambdas only occur as the RHS of a binding
     (The code generator can't deal with anything else.)
+    Type lambdas are ok, however, because the code gen discards them.
 
 5.  [Not any more; nuked Jun 2002] Do the seq/par munging.
 
@@ -158,6 +160,7 @@ mkDataConWorkers data_tycons
 
 data FloatingBind = FloatLet CoreBind
 		  | FloatCase Id CoreExpr Bool
+		        -- Invariant: the expression is not a lambda
 			-- The bool indicates "ok-for-speculation"
 
 data Floats = Floats OkToSpec (OrdList FloatingBind)
@@ -177,7 +180,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 +326,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 +344,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
 -- ---------------------------------------------------------------------------
@@ -382,12 +402,6 @@ corePrepExprFloat env (Note n@(SCC _) expr) = do
     (floats, expr2) <- deLamFloat expr1
     return (floats, Note n expr2)
 
-corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
-  | Just (TickBox {}) <- isTickBoxOp_maybe id = do
-    expr1 <- corePrepAnExpr env expr
-    (floats, expr2) <- deLamFloat expr1
-    return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
-
 corePrepExprFloat env (Note other_note expr) = do
     (floats, expr') <- corePrepExprFloat env expr
     return (floats, Note other_note expr')
@@ -403,6 +417,12 @@ corePrepExprFloat env expr@(Lam _ _) = do
   where
     (bndrs,body) = collectBinders expr
 
+corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
+  | Just (TickBox {}) <- isTickBoxOp_maybe id = do
+    expr1 <- corePrepAnExpr env expr
+    (floats, expr2) <- deLamFloat expr1
+    return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
+
 corePrepExprFloat env (Case scrut bndr ty alts) = do
     (floats1, scrut1) <- corePrepExprFloat env scrut
     (floats2, scrut2) <- deLamFloat scrut1
@@ -602,11 +622,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)
 
@@ -621,19 +641,24 @@ mkLocalNonRec bndr dem floats rhs
 
 
 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
+-- Lambdas are not allowed as the body of a 'let'
 mkBinds (Floats _ binds) body 
   | isNilOL binds = return body
-  | otherwise	  = do body' <- deLam body
-                        -- Lambdas are not allowed as the body of a 'let'
-                       return (foldrOL mk_bind body' binds)
+  | otherwise	  = do { body' <- deLam body
+                       ; return (wrapBinds binds body') }
+
+wrapBinds :: OrdList FloatingBind -> CoreExpr -> CoreExpr
+wrapBinds binds body
+  = foldrOL mk_bind body binds
   where
     mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
     mk_bind (FloatLet bind)        body = Let bind 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 +687,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
@@ -680,8 +710,8 @@ deLam :: CoreExpr -> UniqSM CoreExpr
 -- and returns one that definitely isn't:
 --	(\x.e) ==>  let f = \x.e in f
 deLam expr = do
-    (floats, expr) <- deLamFloat expr
-    mkBinds floats expr
+    (Floats _ binds, expr) <- deLamFloat expr
+    return (wrapBinds binds expr)
 
 
 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
@@ -840,5 +870,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}