[commit: ghc] supercompiler: Don't float out of binders that may be marked SUPERINLINABLE when converting from GHC core to preserve lexical structure (15638a4)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/15638a4381e33af35f9375ad5b57d22c52fe4d01

>---------------------------------------------------------------

commit 15638a4381e33af35f9375ad5b57d22c52fe4d01
Author: Max Bolingbroke <[email protected]>
Date:   Fri Oct 19 16:24:12 2012 +0100

    Don't float out of binders that may be marked SUPERINLINABLE when converting from GHC core to preserve lexical structure

>---------------------------------------------------------------

 compiler/supercompile/Supercompile/GHC.hs |    7 ++++---
 1 files changed, 4 insertions(+), 3 deletions(-)

diff --git a/compiler/supercompile/Supercompile/GHC.hs b/compiler/supercompile/Supercompile/GHC.hs
index 24e5e97..0c00864 100644
--- a/compiler/supercompile/Supercompile/GHC.hs
+++ b/compiler/supercompile/Supercompile/GHC.hs
@@ -147,6 +147,7 @@ conAppToTerm dc es
     fromType_maybe (Type ty) = Just ty
     fromType_maybe _         = Nothing
 
+-- NB: this function must not float stuff out of bindings, so that later SUPERINLINABLE propagation will work properly
 coreExprToTerm :: CoreExpr -> ParseM S.Term
 coreExprToTerm init_e = {-# SCC "coreExprToTerm" #-} term init_e
   where
@@ -168,9 +169,9 @@ coreExprToTerm init_e = {-# SCC "coreExprToTerm" #-} term init_e
     term (App e_fun e_arg)         = join $ liftM2 appE (term e_fun) (fmap ((,) e_arg) $ maybeUnLiftedTerm (exprType e_arg) e_arg)
     term (Lam x e) | isTyVar x     = fmap (S.value . S.TyLambda x) (bindFloats (term e))
                    | otherwise     = fmap (S.value . S.Lambda x) (bindFloats (term e))
-    term (Let (NonRec x e1) e2)    = liftM2 (S.let_ x) (maybeUnLiftedTerm (idType x) e1) (bindFloats (term e2))
-    term (Let (Rec xes) e)         = bindFloatsWith (liftM2 (,) (mapM (secondM term) xes) (term e))
-    term (Case e x ty alts)        = liftM2 (\e alts -> S.case_ e x ty alts) (term e) (mapM alt alts)
+    term (Let (NonRec x e1) e2)    = liftM2 (S.let_ x) (bindFloats (term e1)) (bindFloats (term e2))
+    term (Let (Rec xes) e)         = bindFloatsWith (liftM2 (,) (mapM (secondM (bindFloats . term)) xes) (term e))
+    term (Case e x ty alts)        = liftM2 (\e alts -> S.case_ e x ty alts) (bindFloats (term e)) (mapM alt alts)
     term (Cast e co)               = fmap (flip S.cast co) (term e)
     term (Tick _ e)                = term e -- FIXME: record ticks
     term (Type ty)                 = pprPanic "termToCoreExpr" (ppr ty)