Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/15638a4381e33af35f9375ad5b57d22c52fe4d01 >--------------------------------------------------------------- commit 15638a4381e33af35f9375ad5b57d22c52fe4d01 Author: Max Bolingbroke <batterseapo...@hotmail.com> 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) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
