{-# 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 :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [InStgTopBinding]
stgLiftLams DynFlags
dflags UniqSupply
us = DynFlags -> UniqSupply -> LiftM () -> [InStgTopBinding]
runLiftM DynFlags
dflags UniqSupply
us (LiftM () -> [InStgTopBinding])
-> ([InStgTopBinding] -> LiftM ())
-> [InStgTopBinding]
-> [InStgTopBinding]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InStgTopBinding -> LiftM () -> LiftM ())
-> LiftM () -> [InStgTopBinding] -> LiftM ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr InStgTopBinding -> LiftM () -> LiftM ()
liftTopLvl (() -> LiftM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()
liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()
liftTopLvl (StgTopStringLit Id
bndr ByteString
lit) LiftM ()
rest = Id -> (Id -> LiftM ()) -> LiftM ()
forall a. Id -> (Id -> LiftM a) -> LiftM a
withSubstBndr Id
bndr ((Id -> LiftM ()) -> LiftM ()) -> (Id -> LiftM ()) -> LiftM ()
forall a b. (a -> b) -> a -> b
$ \Id
bndr' -> do
  Id -> ByteString -> LiftM ()
addTopStringLit Id
bndr' ByteString
lit
  LiftM ()
rest
liftTopLvl (StgTopLifted GenStgBinding 'Vanilla
bind) LiftM ()
rest = do
  let is_rec :: Bool
is_rec = RecFlag -> Bool
isRec (RecFlag -> Bool) -> RecFlag -> Bool
forall a b. (a -> b) -> a -> b
$ (RecFlag, [(Id, GenStgRhs 'Vanilla)]) -> RecFlag
forall a b. (a, b) -> a
fst ((RecFlag, [(Id, GenStgRhs 'Vanilla)]) -> RecFlag)
-> (RecFlag, [(Id, GenStgRhs 'Vanilla)]) -> RecFlag
forall a b. (a -> b) -> a -> b
$ GenStgBinding 'Vanilla
-> (RecFlag, [(BinderP 'Vanilla, GenStgRhs 'Vanilla)])
forall (pass :: StgPass).
GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])
decomposeStgBinding GenStgBinding 'Vanilla
bind
  Bool -> LiftM () -> LiftM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_rec LiftM ()
startBindingGroup
  let bind_w_fvs :: CgStgBinding
bind_w_fvs = GenStgBinding 'Vanilla -> CgStgBinding
annBindingFreeVars GenStgBinding 'Vanilla
bind
  TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM ())
-> LiftM ()
forall a.
TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
-> LiftM a
withLiftedBind TopLevelFlag
TopLevel (CgStgBinding -> LlStgBinding
tagSkeletonTopBind CgStgBinding
bind_w_fvs) Skeleton
NilSk ((Maybe (GenStgBinding 'Vanilla) -> LiftM ()) -> LiftM ())
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM ()) -> LiftM ()
forall a b. (a -> b) -> a -> b
$ \Maybe (GenStgBinding 'Vanilla)
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 Maybe (GenStgBinding 'Vanilla)
mb_bind' of
      Maybe (GenStgBinding 'Vanilla)
Nothing -> String -> SDoc -> LiftM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"StgLiftLams" (String -> SDoc
text String
"Lifted top-level binding")
      Just GenStgBinding 'Vanilla
bind' -> GenStgBinding 'Vanilla -> LiftM ()
addLiftedBinding GenStgBinding 'Vanilla
bind'
    Bool -> LiftM () -> LiftM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_rec LiftM ()
endBindingGroup
    LiftM ()
rest

withLiftedBind
  :: TopLevelFlag
  -> LlStgBinding
  -> Skeleton
  -> (Maybe OutStgBinding -> LiftM a)
  -> LiftM a
withLiftedBind :: TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
-> LiftM a
withLiftedBind TopLevelFlag
top_lvl LlStgBinding
bind Skeleton
scope Maybe (GenStgBinding 'Vanilla) -> LiftM a
k
  | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
  = Bool -> LiftM a -> LiftM a
forall a. Bool -> LiftM a -> LiftM a
withCaffyness ([(BinderInfo, GenStgRhs 'LiftLams)] -> Bool
forall b. [(BinderInfo, b)] -> Bool
is_caffy [(BinderInfo, GenStgRhs 'LiftLams)]
pairs) LiftM a
go
  | Bool
otherwise
  = LiftM a
go
  where
    (RecFlag
rec, [(BinderInfo, GenStgRhs 'LiftLams)]
pairs) = LlStgBinding
-> (RecFlag, [(BinderP 'LiftLams, GenStgRhs 'LiftLams)])
forall (pass :: StgPass).
GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])
decomposeStgBinding LlStgBinding
bind
    is_caffy :: [(BinderInfo, b)] -> Bool
is_caffy = ((BinderInfo, b) -> Bool) -> [(BinderInfo, b)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CafInfo -> Bool
mayHaveCafRefs (CafInfo -> Bool)
-> ((BinderInfo, b) -> CafInfo) -> (BinderInfo, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> CafInfo
idCafInfo (Id -> CafInfo)
-> ((BinderInfo, b) -> Id) -> (BinderInfo, b) -> CafInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinderInfo -> Id
binderInfoBndr (BinderInfo -> Id)
-> ((BinderInfo, b) -> BinderInfo) -> (BinderInfo, b) -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BinderInfo, b) -> BinderInfo
forall a b. (a, b) -> a
fst)
    go :: LiftM a
go = TopLevelFlag
-> RecFlag
-> [(BinderInfo, GenStgRhs 'LiftLams)]
-> Skeleton
-> (Maybe [(Id, GenStgRhs 'Vanilla)] -> LiftM a)
-> LiftM a
forall a.
TopLevelFlag
-> RecFlag
-> [(BinderInfo, GenStgRhs 'LiftLams)]
-> Skeleton
-> (Maybe [(Id, GenStgRhs 'Vanilla)] -> LiftM a)
-> LiftM a
withLiftedBindPairs TopLevelFlag
top_lvl RecFlag
rec [(BinderInfo, GenStgRhs 'LiftLams)]
pairs Skeleton
scope (Maybe (GenStgBinding 'Vanilla) -> LiftM a
k (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
-> (Maybe [(Id, GenStgRhs 'Vanilla)]
    -> Maybe (GenStgBinding 'Vanilla))
-> Maybe [(Id, GenStgRhs 'Vanilla)]
-> LiftM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Id, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla)
-> Maybe [(Id, GenStgRhs 'Vanilla)]
-> Maybe (GenStgBinding 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RecFlag
-> [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
-> GenStgBinding 'Vanilla
forall (pass :: StgPass).
RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
mkStgBinding RecFlag
rec))

withLiftedBindPairs
  :: TopLevelFlag
  -> RecFlag
  -> [(BinderInfo, LlStgRhs)]
  -> Skeleton
  -> (Maybe [(Id, OutStgRhs)] -> LiftM a)
  -> LiftM a
withLiftedBindPairs :: TopLevelFlag
-> RecFlag
-> [(BinderInfo, GenStgRhs 'LiftLams)]
-> Skeleton
-> (Maybe [(Id, GenStgRhs 'Vanilla)] -> LiftM a)
-> LiftM a
withLiftedBindPairs TopLevelFlag
top RecFlag
rec [(BinderInfo, GenStgRhs 'LiftLams)]
pairs Skeleton
scope Maybe [(Id, GenStgRhs 'Vanilla)] -> LiftM a
k = do
  let ([BinderInfo]
infos, [GenStgRhs 'LiftLams]
rhss) = [(BinderInfo, GenStgRhs 'LiftLams)]
-> ([BinderInfo], [GenStgRhs 'LiftLams])
forall a b. [(a, b)] -> ([a], [b])
unzip [(BinderInfo, GenStgRhs 'LiftLams)]
pairs
  let bndrs :: [Id]
bndrs = (BinderInfo -> Id) -> [BinderInfo] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map BinderInfo -> Id
binderInfoBndr [BinderInfo]
infos
  DIdSet -> DIdSet
expander <- LiftM (DIdSet -> DIdSet)
liftedIdsExpander
  DynFlags
dflags <- LiftM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  case DynFlags
-> TopLevelFlag
-> RecFlag
-> (DIdSet -> DIdSet)
-> [(BinderInfo, GenStgRhs 'LiftLams)]
-> Skeleton
-> Maybe DIdSet
goodToLift DynFlags
dflags TopLevelFlag
top RecFlag
rec DIdSet -> DIdSet
expander [(BinderInfo, GenStgRhs 'LiftLams)]
pairs Skeleton
scope of
    -- @abs_ids@ is the set of all variables that need to become parameters.
    Just DIdSet
abs_ids -> DIdSet -> [Id] -> ([Id] -> LiftM a) -> LiftM a
forall (f :: * -> *) a.
Traversable f =>
DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a
withLiftedBndrs DIdSet
abs_ids [Id]
bndrs (([Id] -> LiftM a) -> LiftM a) -> ([Id] -> LiftM a) -> LiftM a
forall a b. (a -> b) -> a -> b
$ \[Id]
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.
      Bool -> LiftM () -> LiftM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RecFlag -> Bool
isRec RecFlag
rec) LiftM ()
startBindingGroup
      [GenStgRhs 'Vanilla]
rhss' <- (GenStgRhs 'LiftLams -> LiftM (GenStgRhs 'Vanilla))
-> [GenStgRhs 'LiftLams] -> LiftM [GenStgRhs 'Vanilla]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Maybe DIdSet -> GenStgRhs 'LiftLams -> LiftM (GenStgRhs 'Vanilla)
liftRhs (DIdSet -> Maybe DIdSet
forall a. a -> Maybe a
Just DIdSet
abs_ids)) [GenStgRhs 'LiftLams]
rhss
      let pairs' :: [(Id, GenStgRhs 'Vanilla)]
pairs' = [Id] -> [GenStgRhs 'Vanilla] -> [(Id, GenStgRhs 'Vanilla)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs' [GenStgRhs 'Vanilla]
rhss'
      GenStgBinding 'Vanilla -> LiftM ()
addLiftedBinding (RecFlag
-> [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
-> GenStgBinding 'Vanilla
forall (pass :: StgPass).
RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
mkStgBinding RecFlag
rec [(Id, GenStgRhs 'Vanilla)]
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
pairs')
      Bool -> LiftM () -> LiftM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RecFlag -> Bool
isRec RecFlag
rec) LiftM ()
endBindingGroup
      Maybe [(Id, GenStgRhs 'Vanilla)] -> LiftM a
k Maybe [(Id, GenStgRhs 'Vanilla)]
forall a. Maybe a
Nothing
    Maybe DIdSet
Nothing -> [Id] -> ([Id] -> LiftM a) -> LiftM a
forall (f :: * -> *) a.
Traversable f =>
f Id -> (f Id -> LiftM a) -> LiftM a
withSubstBndrs [Id]
bndrs (([Id] -> LiftM a) -> LiftM a) -> ([Id] -> LiftM a) -> LiftM a
forall a b. (a -> b) -> a -> b
$ \[Id]
bndrs' -> do
      -- Don't lift the current binding, but possibly some bindings in their
      -- RHSs.
      [GenStgRhs 'Vanilla]
rhss' <- (GenStgRhs 'LiftLams -> LiftM (GenStgRhs 'Vanilla))
-> [GenStgRhs 'LiftLams] -> LiftM [GenStgRhs 'Vanilla]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Maybe DIdSet -> GenStgRhs 'LiftLams -> LiftM (GenStgRhs 'Vanilla)
liftRhs Maybe DIdSet
forall a. Maybe a
Nothing) [GenStgRhs 'LiftLams]
rhss
      let pairs' :: [(Id, GenStgRhs 'Vanilla)]
pairs' = [Id] -> [GenStgRhs 'Vanilla] -> [(Id, GenStgRhs 'Vanilla)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs' [GenStgRhs 'Vanilla]
rhss'
      Maybe [(Id, GenStgRhs 'Vanilla)] -> LiftM a
k ([(Id, GenStgRhs 'Vanilla)] -> Maybe [(Id, GenStgRhs 'Vanilla)]
forall a. a -> Maybe a
Just [(Id, GenStgRhs 'Vanilla)]
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 :: Maybe DIdSet -> GenStgRhs 'LiftLams -> LiftM (GenStgRhs 'Vanilla)
liftRhs Maybe DIdSet
mb_former_fvs rhs :: GenStgRhs 'LiftLams
rhs@(StgRhsCon CostCentreStack
ccs DataCon
con [StgArg]
args)
  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ ppr rhs)
    CostCentreStack -> DataCon -> [StgArg] -> GenStgRhs 'Vanilla
forall (pass :: StgPass).
CostCentreStack -> DataCon -> [StgArg] -> GenStgRhs pass
StgRhsCon CostCentreStack
ccs DataCon
con ([StgArg] -> GenStgRhs 'Vanilla)
-> LiftM [StgArg] -> LiftM (GenStgRhs 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> LiftM StgArg) -> [StgArg] -> LiftM [StgArg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse StgArg -> LiftM StgArg
liftArgs [StgArg]
args
liftRhs Maybe DIdSet
Nothing (StgRhsClosure XRhsClosure 'LiftLams
_ CostCentreStack
ccs UpdateFlag
upd [BinderP 'LiftLams]
infos GenStgExpr 'LiftLams
body) = do
  -- This RHS wasn't lifted.
  [Id]
-> ([Id] -> LiftM (GenStgRhs 'Vanilla))
-> LiftM (GenStgRhs 'Vanilla)
forall (f :: * -> *) a.
Traversable f =>
f Id -> (f Id -> LiftM a) -> LiftM a
withSubstBndrs ((BinderInfo -> Id) -> [BinderInfo] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map BinderInfo -> Id
binderInfoBndr [BinderP 'LiftLams]
[BinderInfo]
infos) (([Id] -> LiftM (GenStgRhs 'Vanilla))
 -> LiftM (GenStgRhs 'Vanilla))
-> ([Id] -> LiftM (GenStgRhs 'Vanilla))
-> LiftM (GenStgRhs 'Vanilla)
forall a b. (a -> b) -> a -> b
$ \[Id]
bndrs' ->
    XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent CostCentreStack
ccs UpdateFlag
upd [Id]
[BinderP 'Vanilla]
bndrs' (GenStgExpr 'Vanilla -> GenStgRhs 'Vanilla)
-> LiftM (GenStgExpr 'Vanilla) -> LiftM (GenStgRhs 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
body
liftRhs (Just DIdSet
former_fvs) (StgRhsClosure XRhsClosure 'LiftLams
_ CostCentreStack
ccs UpdateFlag
upd [BinderP 'LiftLams]
infos GenStgExpr 'LiftLams
body) = do
  -- This RHS was lifted. Insert extra binders for @former_fvs@.
  [Id]
-> ([Id] -> LiftM (GenStgRhs 'Vanilla))
-> LiftM (GenStgRhs 'Vanilla)
forall (f :: * -> *) a.
Traversable f =>
f Id -> (f Id -> LiftM a) -> LiftM a
withSubstBndrs ((BinderInfo -> Id) -> [BinderInfo] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map BinderInfo -> Id
binderInfoBndr [BinderP 'LiftLams]
[BinderInfo]
infos) (([Id] -> LiftM (GenStgRhs 'Vanilla))
 -> LiftM (GenStgRhs 'Vanilla))
-> ([Id] -> LiftM (GenStgRhs 'Vanilla))
-> LiftM (GenStgRhs 'Vanilla)
forall a b. (a -> b) -> a -> b
$ \[Id]
bndrs' -> do
    let bndrs'' :: [Id]
bndrs'' = DIdSet -> [Id]
dVarSetElems DIdSet
former_fvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
bndrs'
    XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent CostCentreStack
ccs UpdateFlag
upd [Id]
[BinderP 'Vanilla]
bndrs'' (GenStgExpr 'Vanilla -> GenStgRhs 'Vanilla)
-> LiftM (GenStgExpr 'Vanilla) -> LiftM (GenStgRhs 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
body

liftArgs :: InStgArg -> LiftM OutStgArg
liftArgs :: StgArg -> LiftM StgArg
liftArgs a :: StgArg
a@(StgLitArg Literal
_) = StgArg -> LiftM StgArg
forall (f :: * -> *) a. Applicative f => a -> f a
pure StgArg
a
liftArgs (StgVarArg Id
occ) = do
  ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )
  Id -> StgArg
StgVarArg (Id -> StgArg) -> LiftM Id -> LiftM StgArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> LiftM Id
substOcc Id
occ

liftExpr :: LlStgExpr -> LiftM OutStgExpr
liftExpr :: GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr (StgLit Literal
lit) = GenStgExpr 'Vanilla -> LiftM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Literal -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
lit)
liftExpr (StgTick Tickish Id
t GenStgExpr 'LiftLams
e) = Tickish Id -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
Tickish Id -> GenStgExpr pass -> GenStgExpr pass
StgTick Tickish Id
t (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> LiftM (GenStgExpr 'Vanilla) -> LiftM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
e
liftExpr (StgApp Id
f [StgArg]
args) = do
  Id
f' <- Id -> LiftM Id
substOcc Id
f
  [StgArg]
args' <- (StgArg -> LiftM StgArg) -> [StgArg] -> LiftM [StgArg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse StgArg -> LiftM StgArg
liftArgs [StgArg]
args
  [Id]
fvs' <- Id -> LiftM [Id]
formerFreeVars Id
f
  let top_lvl_args :: [StgArg]
top_lvl_args = (Id -> StgArg) -> [Id] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> StgArg
StgVarArg [Id]
fvs' [StgArg] -> [StgArg] -> [StgArg]
forall a. [a] -> [a] -> [a]
++ [StgArg]
args'
  GenStgExpr 'Vanilla -> LiftM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f' [StgArg]
top_lvl_args)
liftExpr (StgConApp DataCon
con [StgArg]
args [Type]
tys) = DataCon -> [StgArg] -> [Type] -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
DataCon -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
con ([StgArg] -> [Type] -> GenStgExpr 'Vanilla)
-> LiftM [StgArg] -> LiftM ([Type] -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> LiftM StgArg) -> [StgArg] -> LiftM [StgArg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse StgArg -> LiftM StgArg
liftArgs [StgArg]
args LiftM ([Type] -> GenStgExpr 'Vanilla)
-> LiftM [Type] -> LiftM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> LiftM [Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
tys
liftExpr (StgOpApp StgOp
op [StgArg]
args Type
ty) = StgOp -> [StgArg] -> Type -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp StgOp
op ([StgArg] -> Type -> GenStgExpr 'Vanilla)
-> LiftM [StgArg] -> LiftM (Type -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> LiftM StgArg) -> [StgArg] -> LiftM [StgArg]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse StgArg -> LiftM StgArg
liftArgs [StgArg]
args LiftM (Type -> GenStgExpr 'Vanilla)
-> LiftM Type -> LiftM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> LiftM Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
liftExpr (StgLam NonEmpty (BinderP 'LiftLams)
_ GenStgExpr 'Vanilla
_) = String -> SDoc -> LiftM (GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"stgLiftLams" (String -> SDoc
text String
"StgLam")
liftExpr (StgCase GenStgExpr 'LiftLams
scrut BinderP 'LiftLams
info AltType
ty [GenStgAlt 'LiftLams]
alts) = do
  GenStgExpr 'Vanilla
scrut' <- GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
scrut
  Id
-> (Id -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla)
forall a. Id -> (Id -> LiftM a) -> LiftM a
withSubstBndr (BinderInfo -> Id
binderInfoBndr BinderP 'LiftLams
BinderInfo
info) ((Id -> LiftM (GenStgExpr 'Vanilla))
 -> LiftM (GenStgExpr 'Vanilla))
-> (Id -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ \Id
bndr' -> do
    [(AltCon, [Id], GenStgExpr 'Vanilla)]
alts' <- ((AltCon, [BinderInfo], GenStgExpr 'LiftLams)
 -> LiftM (AltCon, [Id], GenStgExpr 'Vanilla))
-> [(AltCon, [BinderInfo], GenStgExpr 'LiftLams)]
-> LiftM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse GenStgAlt 'LiftLams -> LiftM OutStgAlt
(AltCon, [BinderInfo], GenStgExpr 'LiftLams)
-> LiftM (AltCon, [Id], GenStgExpr 'Vanilla)
liftAlt [GenStgAlt 'LiftLams]
[(AltCon, [BinderInfo], GenStgExpr 'LiftLams)]
alts
    GenStgExpr 'Vanilla -> LiftM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenStgExpr 'Vanilla
-> BinderP 'Vanilla
-> AltType
-> [OutStgAlt]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase GenStgExpr 'Vanilla
scrut' Id
BinderP 'Vanilla
bndr' AltType
ty [(AltCon, [Id], GenStgExpr 'Vanilla)]
[OutStgAlt]
alts')
liftExpr (StgLet XLet 'LiftLams
scope LlStgBinding
bind GenStgExpr 'LiftLams
body)
  = TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla)
forall a.
TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
-> LiftM a
withLiftedBind TopLevelFlag
NotTopLevel LlStgBinding
bind XLet 'LiftLams
Skeleton
scope ((Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
 -> LiftM (GenStgExpr 'Vanilla))
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ \Maybe (GenStgBinding 'Vanilla)
mb_bind' -> do
      GenStgExpr 'Vanilla
body' <- GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
body
      case Maybe (GenStgBinding 'Vanilla)
mb_bind' of
        Maybe (GenStgBinding 'Vanilla)
Nothing -> GenStgExpr 'Vanilla -> LiftM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
body' -- withLiftedBindPairs decided to lift it and already added floats
        Just GenStgBinding 'Vanilla
bind' -> GenStgExpr 'Vanilla -> LiftM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bind' GenStgExpr 'Vanilla
body')
liftExpr (StgLetNoEscape XLetNoEscape 'LiftLams
scope LlStgBinding
bind GenStgExpr 'LiftLams
body)
  = TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla)
forall a.
TopLevelFlag
-> LlStgBinding
-> Skeleton
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM a)
-> LiftM a
withLiftedBind TopLevelFlag
NotTopLevel LlStgBinding
bind XLetNoEscape 'LiftLams
Skeleton
scope ((Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
 -> LiftM (GenStgExpr 'Vanilla))
-> (Maybe (GenStgBinding 'Vanilla) -> LiftM (GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ \Maybe (GenStgBinding 'Vanilla)
mb_bind' -> do
      GenStgExpr 'Vanilla
body' <- GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
body
      case Maybe (GenStgBinding 'Vanilla)
mb_bind' of
        Maybe (GenStgBinding 'Vanilla)
Nothing -> String -> SDoc -> LiftM (GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"stgLiftLams" (String -> SDoc
text String
"Should never decide to lift LNEs")
        Just GenStgBinding 'Vanilla
bind' -> GenStgExpr 'Vanilla -> LiftM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XLetNoEscape 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bind' GenStgExpr 'Vanilla
body')

liftAlt :: LlStgAlt -> LiftM OutStgAlt
liftAlt :: GenStgAlt 'LiftLams -> LiftM OutStgAlt
liftAlt (AltCon
con, [BinderP 'LiftLams]
infos, GenStgExpr 'LiftLams
rhs) = [Id]
-> ([Id] -> LiftM (AltCon, [Id], GenStgExpr 'Vanilla))
-> LiftM (AltCon, [Id], GenStgExpr 'Vanilla)
forall (f :: * -> *) a.
Traversable f =>
f Id -> (f Id -> LiftM a) -> LiftM a
withSubstBndrs ((BinderInfo -> Id) -> [BinderInfo] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map BinderInfo -> Id
binderInfoBndr [BinderP 'LiftLams]
[BinderInfo]
infos) (([Id] -> LiftM (AltCon, [Id], GenStgExpr 'Vanilla))
 -> LiftM (AltCon, [Id], GenStgExpr 'Vanilla))
-> ([Id] -> LiftM (AltCon, [Id], GenStgExpr 'Vanilla))
-> LiftM (AltCon, [Id], GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ \[Id]
bndrs' ->
  (,,) AltCon
con [Id]
bndrs' (GenStgExpr 'Vanilla -> (AltCon, [Id], GenStgExpr 'Vanilla))
-> LiftM (GenStgExpr 'Vanilla)
-> LiftM (AltCon, [Id], GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'LiftLams -> LiftM (GenStgExpr 'Vanilla)
liftExpr GenStgExpr 'LiftLams
rhs