Commit b2950e03 authored by Sebastian Graf's avatar Sebastian Graf

Implement late lambda lift

Summary:
This implements a selective lambda-lifting pass late in the STG
pipeline.

Lambda lifting has the effect of avoiding closure allocation at the cost
of having to make former free vars available at call sites, possibly
enlarging closures surrounding call sites in turn.

We identify beneficial cases by means of an analysis that estimates
closure growth.

There's a Wiki page at
https://ghc.haskell.org/trac/ghc/wiki/LateLamLift.

Reviewers: simonpj, bgamari, simonmar

Reviewed By: simonpj

Subscribers: rwbarton, carter

GHC Trac Issues: #9476

Differential Revision: https://phabricator.haskell.org/D5224
parent 7856676b
......@@ -10,7 +10,7 @@
module Demand (
StrDmd, UseDmd(..), Count,
Demand, CleanDemand, getStrDmd, getUseDmd,
Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd,
mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,
toCleanDmd,
absDmd, topDmd, botDmd, seqDmd,
......@@ -48,9 +48,9 @@ module Demand (
deferAfterIO,
postProcessUnsat, postProcessDmdType,
splitProdDmd_maybe, peelCallDmd, mkCallDmd, mkWorkerDemand,
dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,
argOneShots, argsOneShots, saturatedByOneShots,
splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd,
mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig,
dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots,
trimToType, TypeShape(..),
useCount, isUsedOnce, reuseEnv,
......@@ -787,7 +787,7 @@ botDmd = JD { sd = strBot, ud = useBot }
seqDmd :: Demand
seqDmd = JD { sd = Str VanStr HeadStr, ud = Use One UHead }
oneifyDmd :: Demand -> Demand
oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u)
oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a }
oneifyDmd jd = jd
......@@ -796,7 +796,7 @@ isTopDmd :: Demand -> Bool
isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True
isTopDmd _ = False
isAbsDmd :: Demand -> Bool
isAbsDmd :: JointDmd (Str s) (Use u) -> Bool
isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr
isAbsDmd _ = False -- for a bottom demand
......@@ -804,7 +804,7 @@ isSeqDmd :: Demand -> Bool
isSeqDmd (JD {sd = Str VanStr HeadStr, ud = Use _ UHead}) = True
isSeqDmd _ = False
isUsedOnce :: Demand -> Bool
isUsedOnce :: JointDmd (Str s) (Use u) -> Bool
isUsedOnce (JD { ud = a }) = case useCount a of
One -> True
Many -> False
......@@ -817,7 +817,7 @@ seqDemandList :: [Demand] -> ()
seqDemandList [] = ()
seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
isStrictDmd :: Demand -> Bool
isStrictDmd :: JointDmd (Str s) (Use u) -> Bool
-- See Note [Strict demands]
isStrictDmd (JD {ud = Abs}) = False
isStrictDmd (JD {sd = Lazy}) = False
......
......@@ -897,9 +897,10 @@ zapStableUnfolding id
{-
Note [transferPolyIdInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~
This transfer is used in two places:
This transfer is used in three places:
FloatOut (long-distance let-floating)
SimplUtils.abstractFloats (short-distance let-floating)
StgLiftLams (selectively lambda-lift local functions to top-level)
Consider the short-distance let-floating:
......
......@@ -45,7 +45,7 @@ import Module
import Outputable
import Stream
import BasicTypes
import VarSet ( isEmptyVarSet )
import VarSet ( isEmptyDVarSet )
import OrdList
import MkGraph
......@@ -156,7 +156,7 @@ cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
-- see Note [Post-unarisation invariants] in UnariseStg
cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)
= ASSERT(isEmptyVarSet fvs) -- There should be no free variables
= ASSERT(isEmptyDVarSet fvs) -- There should be no free variables
cgTopRhsClosure dflags rec bndr cc upd_flag args body
......
......@@ -44,7 +44,7 @@ import Name
import Module
import ListSetOps
import Util
import UniqSet ( nonDetEltsUniqSet )
import VarSet
import BasicTypes
import Outputable
import FastString
......@@ -209,10 +209,7 @@ cgRhs id (StgRhsCon cc con args)
{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}
cgRhs id (StgRhsClosure fvs cc upd_flag args body)
= do dflags <- getDynFlags
mkRhsClosure dflags id cc (nonVoidIds (nonDetEltsUniqSet fvs)) upd_flag args body
-- It's OK to use nonDetEltsUniqSet here because we're not aiming for
-- bit-for-bit determinism.
-- See Note [Unique Determinism and code generation]
mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body
------------------------------------------------------------------------
-- Non-constructor right hand sides
......
......@@ -81,8 +81,8 @@ cgExpr (StgTick t e) = cgTick t >> cgExpr e
cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
emitReturn [CmmLit cmm_lit]
cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr }
cgExpr (StgLetNoEscape binds expr) =
cgExpr (StgLet _ binds expr) = do { cgBind binds; cgExpr expr }
cgExpr (StgLetNoEscape _ binds expr) =
do { u <- newUnique
; let join_id = mkBlockId u
; cgLneBinds join_id binds
......
......@@ -433,6 +433,11 @@ Library
SimplStg
StgStats
StgCse
StgLiftLams
StgLiftLams.Analysis
StgLiftLams.LiftM
StgLiftLams.Transformation
StgSubst
UnariseStg
RepType
Rules
......
......@@ -465,6 +465,7 @@ data GeneralFlag
| Opt_StaticArgumentTransformation
| Opt_CSE
| Opt_StgCSE
| Opt_StgLiftLams
| Opt_LiberateCase
| Opt_SpecConstr
| Opt_SpecConstrKeen
......@@ -672,6 +673,7 @@ optimisationFlags = EnumSet.fromList
, Opt_StaticArgumentTransformation
, Opt_CSE
, Opt_StgCSE
, Opt_StgLiftLams
, Opt_LiberateCase
, Opt_SpecConstr
, Opt_SpecConstrKeen
......@@ -903,6 +905,13 @@ data DynFlags = DynFlags {
floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating
-- See CoreMonad.FloatOutSwitches
liftLamsRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a
-- recursive function.
liftLamsNonRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a
-- non-recursive function.
liftLamsKnown :: Bool, -- ^ Lambda lift even when this turns a known call
-- into an unknown call.
cmmProcAlignment :: Maybe Int, -- ^ Align Cmm functions at this boundary or use default.
historySize :: Int, -- ^ Simplification history size
......@@ -1865,6 +1874,9 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) =
specConstrRecursive = 3,
liberateCaseThreshold = Just 2000,
floatLamArgs = Just 0, -- Default: float only if no fvs
liftLamsRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64
liftLamsNonRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64
liftLamsKnown = False, -- Default: don't turn known calls into unknown ones
cmmProcAlignment = Nothing,
historySize = 20,
......@@ -3522,6 +3534,18 @@ dynamic_flags_deps = [
(intSuffix (\n d -> d { floatLamArgs = Just n }))
, make_ord_flag defFlag "ffloat-all-lams"
(noArg (\d -> d { floatLamArgs = Nothing }))
, make_ord_flag defFlag "fstg-lift-lams-rec-args"
(intSuffix (\n d -> d { liftLamsRecArgs = Just n }))
, make_ord_flag defFlag "fstg-lift-lams-rec-args-any"
(noArg (\d -> d { liftLamsRecArgs = Nothing }))
, make_ord_flag defFlag "fstg-lift-lams-non-rec-args"
(intSuffix (\n d -> d { liftLamsRecArgs = Just n }))
, make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any"
(noArg (\d -> d { liftLamsRecArgs = Nothing }))
, make_ord_flag defFlag "fstg-lift-lams-known"
(noArg (\d -> d { liftLamsKnown = True }))
, make_ord_flag defFlag "fno-stg-lift-lams-known"
(noArg (\d -> d { liftLamsKnown = False }))
, make_ord_flag defFlag "fproc-alignment"
(intSuffix (\n d -> d { cmmProcAlignment = Just n }))
, make_ord_flag defFlag "fblock-layout-weights"
......@@ -4016,6 +4040,7 @@ fFlagsDeps = [
flagSpec "cmm-sink" Opt_CmmSink,
flagSpec "cse" Opt_CSE,
flagSpec "stg-cse" Opt_StgCSE,
flagSpec "stg-lift-lams" Opt_StgLiftLams,
flagSpec "cpr-anal" Opt_CprAnal,
flagSpec "defer-type-errors" Opt_DeferTypeErrors,
flagSpec "defer-typed-holes" Opt_DeferTypedHoles,
......@@ -4546,6 +4571,7 @@ optLevelFlags -- see Note [Documenting optimisation flags]
, ([1,2], Opt_CmmSink)
, ([1,2], Opt_CSE)
, ([1,2], Opt_StgCSE)
, ([2], Opt_StgLiftLams)
, ([1,2], Opt_EnableRewriteRules) -- Off for -O0; see Note [Scoping for Builtin rules]
-- in PrelRules
, ([1,2], Opt_FloatIn)
......
......@@ -5,6 +5,7 @@
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module SimplStg ( stg2stg ) where
......@@ -18,12 +19,25 @@ import StgLint ( lintStgTopBindings )
import StgStats ( showStgStats )
import UnariseStg ( unarise )
import StgCse ( stgCse )
import StgLiftLams ( stgLiftLams )
import DynFlags
import ErrUtils
import UniqSupply ( mkSplitUniqSupply )
import UniqSupply
import Outputable
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State.Strict
newtype StgM a = StgM { _unStgM :: StateT UniqSupply IO a }
deriving (Functor, Applicative, Monad, MonadIO)
instance MonadUnique StgM where
getUniqueSupplyM = StgM (state splitUniqSupply)
getUniqueM = StgM (state takeUniqFromSupply)
runStgM :: UniqSupply -> StgM a -> IO a
runStgM us (StgM m) = evalStateT m us
stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
-> [StgTopBinding] -- input...
......@@ -33,46 +47,56 @@ stg2stg dflags binds
= do { showPass dflags "Stg2Stg"
; us <- mkSplitUniqSupply 'g'
-- Do the main business!
; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
(pprStgTopBindings binds)
-- Do the main business!
; binds' <- runStgM us $
foldM do_stg_pass binds (getStgToDo dflags)
; stg_linter False "Pre-unarise" binds
; let un_binds = unarise us binds
; stg_linter True "Unarise" un_binds
-- Important that unarisation comes first
-- See Note [StgCse after unarisation] in StgCse
; dump_when Opt_D_dump_stg "STG syntax:" binds'
; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
(pprStgTopBindings un_binds)
; foldM do_stg_pass un_binds (getStgToDo dflags)
}
; return binds'
}
where
stg_linter unarised
| gopt Opt_DoStgLinting dflags = lintStgTopBindings dflags unarised
stg_linter what
| gopt Opt_DoStgLinting dflags = lintStgTopBindings dflags what
| otherwise = \ _whodunnit _binds -> return ()
-------------------------------------------
do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
do_stg_pass binds to_do
= case to_do of
D_stg_stats ->
trace (showStgStats binds) (return binds)
StgDoNothing ->
return binds
StgStats ->
trace (showStgStats binds) (return binds)
StgCSE ->
{-# SCC "StgCse" #-}
let
binds' = stgCse binds
in
end_pass "StgCse" binds'
StgCSE -> do
let binds' = {-# SCC "StgCse" #-} stgCse binds
end_pass "StgCse" binds'
StgLiftLams -> do
us <- getUniqueSupplyM
let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds
end_pass "StgLiftLams" binds'
StgUnarise -> do
dump_when Opt_D_dump_stg "Pre unarise:" binds
us <- getUniqueSupplyM
liftIO (stg_linter False "Pre-unarise" binds)
let binds' = unarise us binds
liftIO (stg_linter True "Unarise" binds')
return binds'
dump_when flag header binds
= liftIO (dumpIfSet_dyn dflags flag header (pprStgTopBindings binds))
end_pass what binds2
= do -- report verbosely, if required
dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
(pprStgTopBindings binds2)
stg_linter True what binds2
return binds2
= liftIO $ do -- report verbosely, if required
dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
(vcat (map ppr binds2))
stg_linter False what binds2
return binds2
-- -----------------------------------------------------------------------------
-- StgToDo: abstraction of stg-to-stg passes to run.
......@@ -80,12 +104,31 @@ stg2stg dflags binds
-- | Optional Stg-to-Stg passes.
data StgToDo
= StgCSE
| D_stg_stats
-- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc.
-- ^ Common subexpression elimination
| StgLiftLams
-- ^ Lambda lifting closure variables, trading stack/register allocation for
-- heap allocation
| StgStats
| StgUnarise
-- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders
| StgDoNothing
-- ^ Useful for building up 'getStgToDo'
deriving Eq
-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
getStgToDo :: DynFlags -> [StgToDo]
getStgToDo dflags
= [ StgCSE | gopt Opt_StgCSE dflags] ++
[ D_stg_stats | stg_stats ]
where
stg_stats = gopt Opt_StgStats dflags
getStgToDo dflags =
filter (/= StgDoNothing)
[ mandatory StgUnarise
-- Important that unarisation comes first
-- See Note [StgCse after unarisation] in StgCse
, optional Opt_StgCSE StgCSE
, optional Opt_StgLiftLams StgLiftLams
, optional Opt_StgStats StgStats
] where
optional opt = runWhen (gopt opt dflags)
mandatory = id
runWhen :: Bool -> StgToDo -> StgToDo
runWhen True todo = todo
runWhen _ _ = StgDoNothing
......@@ -331,14 +331,14 @@ stgCseExpr env (StgConApp dataCon args tys)
-- The binding might be removed due to CSE (we do not want trivial bindings on
-- the STG level), so use the smart constructor `mkStgLet` to remove the binding
-- if empty.
stgCseExpr env (StgLet binds body)
stgCseExpr env (StgLet ext binds body)
= let (binds', env') = stgCseBind env binds
body' = stgCseExpr env' body
in mkStgLet StgLet binds' body'
stgCseExpr env (StgLetNoEscape binds body)
in mkStgLet (StgLet ext) binds' body'
stgCseExpr env (StgLetNoEscape ext binds body)
= let (binds', env') = stgCseBind env binds
body' = stgCseExpr env' body
in mkStgLet StgLetNoEscape binds' body'
in mkStgLet (StgLetNoEscape ext) binds' body'
-- Case alternatives
-- Extend the CSE environment
......
-- | Implements a selective lambda lifter, running late in the optimisation
-- pipeline.
--
-- The transformation itself is implemented in "StgLiftLams.Transformation".
-- If you are interested in the cost model that is employed to decide whether
-- to lift a binding or not, look at "StgLiftLams.Analysis".
-- "StgLiftLams.LiftM" contains the transformation monad that hides away some
-- plumbing of the transformation.
module StgLiftLams (
-- * Late lambda lifting in STG
-- $note
Transformation.stgLiftLams
) where
import qualified StgLiftLams.Transformation as Transformation
-- Note [Late lambda lifting in STG]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- $note
-- See also the <https://ghc.haskell.org/trac/ghc/wiki/LateLamLift wiki page>
-- and Trac #9476.
--
-- The basic idea behind lambda lifting is to turn locally defined functions
-- into top-level functions. Free variables are then passed as additional
-- arguments at *call sites* instead of having a closure allocated for them at
-- *definition site*. Example:
--
-- @
-- let x = ...; y = ... in
-- let f = {x y} \a -> a + x + y in
-- let g = {f x} \b -> f b + x in
-- g 5
-- @
--
-- Lambda lifting @f@ would
--
-- 1. Turn @f@'s free variables into formal parameters
-- 2. Update @f@'s call site within @g@ to @f x y b@
-- 3. Update @g@'s closure: Add @y@ as an additional free variable, while
-- removing @f@, because @f@ no longer allocates and can be floated to
-- top-level.
-- 4. Actually float the binding of @f@ to top-level, eliminating the @let@
-- in the process.
--
-- This results in the following program (with free var annotations):
--
-- @
-- f x y a = a + x + y;
-- let x = ...; y = ... in
-- let g = {x y} \b -> f x y b + x in
-- g 5
-- @
--
-- This optimisation is all about lifting only when it is beneficial to do so.
-- The above seems like a worthwhile lift, judging from heap allocation:
-- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while
-- not changing the size of @g@'s closure.
--
-- You can probably sense that there's some kind of cost model at play here.
-- And you are right! But we also employ a couple of other heuristics for the
-- lifting decision which are outlined in "StgLiftLams.Analysis#when".
--
-- The transformation is done in "StgLiftLams.Transformation", which calls out
-- to 'StgLiftLams.Analysis.goodToLift' for its lifting decision.
-- It relies on "StgLiftLams.LiftM", which abstracts some subtle STG invariants
-- into a monadic substrate.
--
-- Suffice to say: We trade heap allocation for stack allocation.
-- The additional arguments have to passed on the stack (or in registers,
-- depending on architecture) every time we call the function to save a single
-- heap allocation when entering the let binding. Nofib suggests a mean
-- improvement of about 1% for this pass, so it seems like a worthwhile thing to
-- do. Compile-times went up by 0.6%, so all in all a very modest change.
--
-- For a concrete example, look at @spectral/atom@. There's a call to 'zipWith'
-- that is ultimately compiled to something like this
-- (module desugaring/lowering to actual STG):
--
-- @
-- propagate dt = ...;
-- runExperiment ... =
-- let xs = ... in
-- let ys = ... in
-- let go = {dt go} \xs ys -> case (xs, ys) of
-- ([], []) -> []
-- (x:xs', y:ys') -> propagate dt x y : go xs' ys'
-- in go xs ys
-- @
--
-- This will lambda lift @go@ to top-level, speeding up the resulting program
-- by roughly one percent:
--
-- @
-- propagate dt = ...;
-- go dt xs ys = case (xs, ys) of
-- ([], []) -> []
-- (x:xs', y:ys') -> propagate dt x y : go dt xs' ys'
-- runExperiment ... =
-- let xs = ... in
-- let ys = ... in
-- in go dt xs ys
-- @
This diff is collapsed.
This diff is collapsed.
{-# LANGUAGE CPP #-}
-- | (Mostly) textbook instance of the lambda lifting transformation,
-- selecting which bindings to lambda lift by consulting 'goodToLift'.
module StgLiftLams.Transformation (stgLiftLams) where
#include "HsVersions.h"
import GhcPrelude
import BasicTypes
import DynFlags
import Id
import IdInfo
import StgFVs ( annBindingFreeVars )
import StgLiftLams.Analysis
import StgLiftLams.LiftM
import StgSyn
import Outputable
import UniqSupply
import Util
import VarSet
import Control.Monad ( when )
import Data.Maybe ( isNothing )
-- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift').
stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ())
liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()
liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do
addTopStringLit bndr' lit
rest
liftTopLvl (StgTopLifted bind) rest = do
let is_rec = isRec $ fst $ decomposeStgBinding bind
when is_rec startBindingGroup
let bind_w_fvs = annBindingFreeVars bind
withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do
-- We signal lifting of a binding through returning Nothing.
-- Should never happen for a top-level binding, though, since we are already
-- at top-level.
case mb_bind' of
Nothing -> pprPanic "StgLiftLams" (text "Lifted top-level binding")
Just bind' -> addLiftedBinding bind'
when is_rec endBindingGroup
rest
withLiftedBind
:: TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe OutStgBinding -> LiftM a)
-> LiftM a
withLiftedBind top_lvl bind scope k
| isTopLevel top_lvl
= withCaffyness (is_caffy pairs) go
| otherwise
= go
where
(rec, pairs) = decomposeStgBinding bind
is_caffy = any (mayHaveCafRefs . idCafInfo . binderInfoBndr . fst)
go = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec))
withLiftedBindPairs
:: TopLevelFlag
-> RecFlag
-> [(BinderInfo, LlStgRhs)]
-> Skeleton
-> (Maybe [(Id, OutStgRhs)] -> LiftM a)
-> LiftM a
withLiftedBindPairs top rec pairs scope k = do
let (infos, rhss) = unzip pairs
let bndrs = map binderInfoBndr infos
expander <- liftedIdsExpander
dflags <- getDynFlags
case goodToLift dflags top rec expander pairs scope of
-- @abs_ids@ is the set of all variables that need to become parameters.
Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do
-- Within this block, all binders in @bndrs@ will be noted as lifted, so
-- that the return value of @liftedIdsExpander@ in this context will also
-- expand the bindings in @bndrs@ to their free variables.
-- Now we can recurse into the RHSs and see if we can lift any further
-- bindings. We pass the set of expanded free variables (thus OutIds) on
-- to @liftRhs@ so that it can add them as parameter binders.
when (isRec rec) startBindingGroup
rhss' <- traverse (liftRhs (Just abs_ids)) rhss
let pairs' = zip bndrs' rhss'
addLiftedBinding (mkStgBinding rec pairs')
when (isRec rec) endBindingGroup
k Nothing
Nothing -> withSubstBndrs bndrs $ \bndrs' -> do
-- Don't lift the current binding, but possibly some bindings in their
-- RHSs.
rhss' <- traverse (liftRhs Nothing) rhss
let pairs' = zip bndrs' rhss'
k (Just pairs')
liftRhs
:: Maybe (DIdSet)
-- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@
-- as lambda binders, discarding all free vars.
-> LlStgRhs
-> LiftM OutStgRhs
liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args)
= ASSERT2 ( isNothing mb_former_fvs, text "Should never lift a constructor" $$ ppr rhs)
StgRhsCon ccs con <$> traverse liftArgs args
liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do
-- This RHS wasn't lifted.
withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
StgRhsClosure noExtSilent ccs upd bndrs' <$> liftExpr body
liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do
-- This RHS was lifted. Insert extra binders for @former_fvs@.
withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do
let bndrs'' = dVarSetElems former_fvs ++ bndrs'
StgRhsClosure noExtSilent ccs upd bndrs'' <$> liftExpr body
liftArgs :: InStgArg -> LiftM OutStgArg
liftArgs a@(StgLitArg _) = pure a
liftArgs (StgVarArg occ) = do
ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )
StgVarArg <$> substOcc occ
liftExpr :: LlStgExpr -> LiftM OutStgExpr
liftExpr (StgLit lit) = pure (StgLit lit)
liftExpr (StgTick t e) = StgTick t <$> liftExpr e
liftExpr (StgApp f args) = do
f' <- substOcc f
args' <- traverse liftArgs args
fvs' <- formerFreeVars f
let top_lvl_args = map StgVarArg fvs' ++ args'
pure (StgApp f' top_lvl_args)
liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys
liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty
liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")
liftExpr (StgCase scrut info ty alts) = do
scrut' <- liftExpr scrut
withSubstBndr (binderInfoBndr info) $ \bndr' -> do
alts' <- traverse liftAlt alts
pure (StgCase scrut' bndr' ty alts')
liftExpr (StgLet scope bind body)
= withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do
body' <- liftExpr body
case mb_bind' of
Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats
Just bind' -> pure (StgLet noExtSilent bind' body')
liftExpr (StgLetNoEscape scope bind body)
= withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do
body' <- liftExpr body
case mb_bind' of
Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs")
Just bind' -> pure (StgLetNoEscape noExtSilent bind' body')
liftAlt :: LlStgAlt -> LiftM OutStgAlt
liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
(,,) con bndrs' <$> liftExpr rhs
......@@ -153,12 +153,12 @@ statExpr (StgConApp _ _ _)= countOne ConstructorApps
statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
statExpr (StgTick _ e) = statExpr e
statExpr (StgLetNoEscape binds body)
statExpr (StgLetNoEscape _ binds body)
= statBinding False{-not top-level-} binds `combineSE`
statExpr body `combineSE`
countOne LetNoEscapes
statExpr (StgLet binds body)
statExpr (StgLet _ binds body)
= statBinding False{-not top-level-} binds `combineSE`
statExpr body
......
......@@ -353,11 +353,11 @@ unariseExpr rho (StgCase scrut bndr alt_ty alts)
-- bndr may have a unboxed sum/tuple type but it will be
-- dead after unarise (checked in StgLint)
unariseExpr rho (StgLet bind e)
= StgLet <$> unariseBinding rho bind <*> unariseExpr rho e
unariseExpr rho (StgLet ext bind e)
= StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e
unariseExpr rho (StgLetNoEscape bind e)
= StgLetNoEscape <$> unariseBinding rho bind <*> unariseExpr rho e
unariseExpr rho (StgLetNoEscape ext bind e)
= StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e
unariseExpr rho (StgTick tick e)
= StgTick tick <$> unariseExpr rho e
......
......@@ -631,8 +631,8 @@ coreToStgLet bind body = do
-- Compute the new let-expression
let
new_let | isJoinBind bind = StgLetNoEscape bind2 body2
| otherwise = StgLet bind2 body2
new_let | isJoinBind bind = StgLetNoEscape noExtSilent bind2 body2
| otherwise = StgLet noExtSilent bind2 body2
return new_let
where
......
-- | Free variable analysis on STG terms.
module StgFVs (
annTopBindingsFreeVars
annTopBindingsFreeVars,
annBindingFreeVars
) where
import GhcPrelude
......@@ -26,13 +27,17 @@ addLocals :: [Id] -> Env -> Env
addLocals bndrs env
= env { locals = extendVarSetList (locals env) bndrs }