diff options
| -rw-r--r-- | compiler/coreSyn/CoreLint.hs | 1 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
| -rw-r--r-- | compiler/simplCore/AnfiseCore.hs | 90 | ||||
| -rw-r--r-- | compiler/simplCore/CoreMonad.hs | 2 | ||||
| -rw-r--r-- | compiler/simplCore/SimplCore.hs | 16 |
5 files changed, 109 insertions, 1 deletions
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index c39fb641df..cdf729b9b6 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -265,6 +265,7 @@ coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoAnfise = Just Opt_D_verbose_core2core coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index b7b6f69d88..c9ab1c22e4 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -400,6 +400,7 @@ Library OccurAnal SAT SetLevels + AnfiseCore SimplCore SimplEnv SimplMonad diff --git a/compiler/simplCore/AnfiseCore.hs b/compiler/simplCore/AnfiseCore.hs new file mode 100644 index 0000000000..ef4cfb5404 --- /dev/null +++ b/compiler/simplCore/AnfiseCore.hs @@ -0,0 +1,90 @@ +-- | Convert Core into A-normal form (ANF). +module AnfiseCore ( anfiseProgram ) where + +import BasicTypes +import Type +import Id +import VarEnv +import CoreUtils +import CoreSyn +import FastString +import Unique + +import Data.Bifunctor +import Data.Either +import Control.Monad.Trans.State + +anfiseProgram :: CoreProgram -> CoreProgram +anfiseProgram top_binds = map goTopLvl top_binds + where + goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e) + goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs) + + in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds top_binds + + go :: InScopeSet -> CoreExpr -> CoreExpr + go _ e@(Var{}) = e + go _ e@(Lit {}) = e + go _ e@(Type {}) = e + go _ e@(Coercion {}) = e + + go in_scope e@(App e1 e2) + | Var f_id <- f + , isJoinId f_id + = dont_bind + | otherwise + = let bound_args :: [Either CoreExpr (Id, CoreExpr)] + bound_args = evalState (mapM bind_arg args) in_scope + where + bind_arg :: CoreExpr -> State InScopeSet (Either CoreExpr (Id, CoreExpr)) + bind_arg arg + | not should_bind = return $ Left arg + | otherwise = do + bndr <- mkAnfId ty + nowInScope bndr + return $ Right (bndr, arg) + where + ty = exprType arg + should_bind = isValArg arg && not (isUnliftedType ty) && not (exprIsTrivial arg) + binds = map (uncurry NonRec) (rights bound_args) + to_arg = either id (Var . fst) + in mkLets binds $ mkApps f (map to_arg bound_args) + where + (f, args) = collectArgs e + dont_bind = App (go in_scope e1) (go in_scope e2) + go in_scope (Lam v e') = Lam v (go in_scope' e') + where in_scope' = in_scope `extendInScopeSet` v + go in_scope (Case scrut bndr ty alts) + = Case (go in_scope scrut) bndr ty (map (goAlt in_scope') alts) + where in_scope' = in_scope `extendInScopeSet` bndr + go in_scope (Cast e' c) = Cast (go in_scope e') c + go in_scope (Tick t e') = Tick t (go in_scope e') + go in_scope (Let bind body) = goBind in_scope bind (go in_scope' body) + where in_scope' = in_scope `extendInScopeSetList` bindersOf bind + + goAlt :: InScopeSet -> CoreAlt -> CoreAlt + goAlt in_scope (dc, pats, rhs) = (dc, pats, go in_scope' rhs) + where in_scope' = in_scope `extendInScopeSetList` pats + + goBind :: InScopeSet -> CoreBind -> (CoreExpr -> CoreExpr) + goBind in_scope (NonRec v rhs) = Let (NonRec v (go in_scope rhs)) + goBind in_scope (Rec pairs) = Let (Rec pairs') + where pairs' = map (second (go in_scope')) pairs + in_scope' = in_scope `extendInScopeSetList` bindersOf (Rec pairs) + +nowInScope :: Id -> State InScopeSet () +nowInScope id = modify (`extendInScopeSet` id) + +mkAnfId :: Type -> State InScopeSet Id +mkAnfId ty = do + in_scope <- get + return $ uniqAway in_scope id_tmpl + where + id_tmpl = mkSysLocal (fsLit "anf") initExitJoinUnique ty + `setIdOccInfo` occ_info + occ_info = + OneOcc { occ_in_lam = insideLam + , occ_one_br = oneBranch + , occ_int_cxt = False + , occ_tail = NoTailCallInfo + } diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 46d81dfb8b..d64f89d2b8 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -115,6 +115,7 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoPrintCore | CoreDoStaticArgs | CoreDoCallArity + | CoreDoAnfise | CoreDoExitify | CoreDoStrictness | CoreDoWorkerWrapper @@ -143,6 +144,7 @@ instance Outputable CoreToDo where ppr CoreLiberateCase = text "Liberate case" ppr CoreDoStaticArgs = text "Static argument" ppr CoreDoCallArity = text "Called arity analysis" + ppr CoreDoAnfise = text "ANFisation" ppr CoreDoExitify = text "Exitification transformation" ppr CoreDoStrictness = text "Demand analysis" ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 70d5e0f250..6ebc92e699 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -43,6 +43,7 @@ import Specialise ( specProgram) import SpecConstr ( specConstrProgram) import DmdAnal ( dmdAnalProgram ) import CallArity ( callArityAnalProgram ) +import AnfiseCore ( anfiseProgram ) import Exitify ( exitifyProgram ) import WorkWrap ( wwTopBinds ) import Vectorise ( vectorise ) @@ -186,7 +187,7 @@ getCoreToDo dflags -- inlined. I found that spectral/hartel/genfft lost some useful -- strictness in the function sumcode' if augment is not inlined -- before strictness analysis runs - simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter + simpl_phases = CoreDoPasses [ CoreDoPasses [ anfise, simpl_phase phase ["main"] max_iter ] | phase <- [phases, phases-1 .. 1] ] @@ -212,6 +213,16 @@ getCoreToDo dflags [simpl_phase 0 ["post-worker-wrapper"] max_iter] )) + anfise = CoreDoPasses + [ CoreDoAnfise + , CoreDoFloatOutwards FloatOutSwitches { floatOutLambdas = Just 0 + , floatOutConstants = True + , floatOutOverSatApps = True + , floatToTopLevelOnly = False + } + , CoreCSE + ] + -- Static forms are moved to the top level with the FloatOut pass. -- See Note [Grand plan for static forms] in StaticPtrTable. static_ptrs_float_outwards = @@ -482,6 +493,9 @@ doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} doCorePass CoreDoCallArity = {-# SCC "CallArity" #-} doPassD callArityAnalProgram +doCorePass CoreDoAnfise = {-# SCC "ANFise" #-} + doPass anfiseProgram + doCorePass CoreDoExitify = {-# SCC "Exitify" #-} doPass exitifyProgram |