{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.StgToJS.Expr
( genExpr
, genEntryType
, loadLiveFun
, genStaticRefsRhs
, genStaticRefs
, genBody
)
where
import GHC.Prelude
import GHC.JS.JStg.Syntax
import GHC.JS.JStg.Monad
import GHC.JS.Transform
import GHC.JS.Make
import GHC.JS.Ident
import GHC.StgToJS.Apply
import GHC.StgToJS.Arg
import GHC.StgToJS.Closure
import GHC.StgToJS.DataCon
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.FFI
import GHC.StgToJS.Heap
import GHC.StgToJS.Ids
import GHC.StgToJS.Literal
import GHC.StgToJS.Monad
import GHC.StgToJS.Prim
import GHC.StgToJS.Profiling
import GHC.StgToJS.Regs
import GHC.StgToJS.Stack
import GHC.StgToJS.Symbols
import GHC.StgToJS.Types
import GHC.StgToJS.Utils
import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8)
import GHC.Types.CostCentre
import GHC.Types.Tickish
import GHC.Types.Var.Set
import GHC.Types.Id
import GHC.Types.Unique.FM
import GHC.Types.RepType
import GHC.Types.Literal
import GHC.Stg.Syntax
import GHC.Stg.Utils
import GHC.Builtin.PrimOps
import GHC.Builtin.Names
import GHC.Core hiding (Var)
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Opt.Arity (isOneShotBndr)
import GHC.Core.Type hiding (typeSize)
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)
import qualified Control.Monad.Trans.State.Strict as State
import GHC.Data.FastString
import qualified GHC.Types.Unique.Map as UM
import qualified GHC.Data.List.SetOps as ListSetOps
import Data.Monoid
import Data.Maybe
import Data.Function
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Map as M
import Control.Monad
import Control.Arrow ((&&&))
genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr :: HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
stg = case CgStgExpr
stg of
StgApp Id
f [StgArg]
args -> HasDebugCallStack =>
ExprCtx -> Id -> [StgArg] -> G (JStgStat, ExprResult)
ExprCtx -> Id -> [StgArg] -> G (JStgStat, ExprResult)
genApp ExprCtx
ctx Id
f [StgArg]
args
StgLit Literal
l -> do
ls <- HasDebugCallStack => Literal -> G [JStgExpr]
Literal -> G [JStgExpr]
genLit Literal
l
let r = ExprCtx -> [JStgExpr] -> JStgStat
assignToExprCtx ExprCtx
ctx [JStgExpr]
ls
pure (r,ExprInline)
StgConApp DataCon
con ConstructorNumber
_n [StgArg]
args [[PrimRep]]
_ -> do
as <- (StgArg -> G [JStgExpr]) -> [StgArg] -> G [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg [StgArg]
args
c <- genCon ctx con as
return (c, ExprInline)
StgOpApp (StgFCallOp ForeignCall
f Type
_) [StgArg]
args Type
t
-> HasDebugCallStack =>
ExprCtx
-> ForeignCall
-> Type
-> [JStgExpr]
-> [StgArg]
-> G (JStgStat, ExprResult)
ExprCtx
-> ForeignCall
-> Type
-> [JStgExpr]
-> [StgArg]
-> G (JStgStat, ExprResult)
genForeignCall ExprCtx
ctx ForeignCall
f Type
t ((TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr ([TypedExpr] -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [StgArg]
args
StgOpApp (StgPrimOp PrimOp
op) [StgArg]
args Type
t
-> ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStgStat, ExprResult)
genPrimOp ExprCtx
ctx PrimOp
op [StgArg]
args Type
t
StgOpApp (StgPrimCallOp PrimCall
c) [StgArg]
args Type
t
-> ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStgStat, ExprResult)
genPrimCall ExprCtx
ctx PrimCall
c [StgArg]
args Type
t
StgCase CgStgExpr
e BinderP 'CodeGen
b AltType
at [GenStgAlt 'CodeGen]
alts
-> HasDebugCallStack =>
ExprCtx
-> Id
-> CgStgExpr
-> AltType
-> [GenStgAlt 'CodeGen]
-> LiveVars
-> G (JStgStat, ExprResult)
ExprCtx
-> Id
-> CgStgExpr
-> AltType
-> [GenStgAlt 'CodeGen]
-> LiveVars
-> G (JStgStat, ExprResult)
genCase ExprCtx
ctx Id
BinderP 'CodeGen
b CgStgExpr
e AltType
at [GenStgAlt 'CodeGen]
alts (LiveVars -> LiveVars
liveVars (LiveVars -> LiveVars) -> LiveVars -> LiveVars
forall a b. (a -> b) -> a -> b
$ Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
False CgStgExpr
stg)
StgLet XLet 'CodeGen
_ GenStgBinding 'CodeGen
b CgStgExpr
e -> do
(b',ctx') <- HasDebugCallStack =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStgStat, ExprCtx)
ExprCtx -> GenStgBinding 'CodeGen -> G (JStgStat, ExprCtx)
genBind ExprCtx
ctx GenStgBinding 'CodeGen
b
(s,r) <- genExpr ctx' e
return (b' <> s, r)
StgLetNoEscape XLetNoEscape 'CodeGen
_ GenStgBinding 'CodeGen
b CgStgExpr
e -> do
(b', ctx') <- HasDebugCallStack =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStgStat, ExprCtx)
ExprCtx -> GenStgBinding 'CodeGen -> G (JStgStat, ExprCtx)
genBindLne ExprCtx
ctx GenStgBinding 'CodeGen
b
(s, r) <- genExpr ctx' e
return (b' <> s, r)
StgTick (ProfNote CostCentre
cc Bool
count Bool
scope) CgStgExpr
e -> do
setSCCstats <- G JStgStat -> G JStgStat
forall m. Monoid m => G m -> G m
ifProfilingM (G JStgStat -> G JStgStat) -> G JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ CostCentre -> Bool -> Bool -> G JStgStat
setCC CostCentre
cc Bool
count Bool
scope
(stats, result) <- genExpr ctx e
return (setSCCstats <> stats, result)
StgTick (SourceNote RealSrcSpan
span LexicalFastString
_sname) CgStgExpr
e
-> HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr (RealSrcSpan -> ExprCtx -> ExprCtx
ctxSetSrcSpan RealSrcSpan
span ExprCtx
ctx) CgStgExpr
e
StgTick GenTickish 'TickishPassStg
_m CgStgExpr
e
-> HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
e
genBind :: HasDebugCallStack
=> ExprCtx
-> CgStgBinding
-> G (JStgStat, ExprCtx)
genBind :: HasDebugCallStack =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStgStat, ExprCtx)
genBind ExprCtx
ctx GenStgBinding 'CodeGen
bndr =
case GenStgBinding 'CodeGen
bndr of
StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
r -> do
j <- Id -> GenStgRhs 'CodeGen -> G (Maybe JStgStat)
assign Id
BinderP 'CodeGen
b GenStgRhs 'CodeGen
r G (Maybe JStgStat) -> (Maybe JStgStat -> G JStgStat) -> G JStgStat
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just JStgStat
ja -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
ja
Maybe JStgStat
Nothing -> Maybe JStgStat -> [(Id, GenStgRhs 'CodeGen)] -> G JStgStat
allocCls Maybe JStgStat
forall a. Maybe a
Nothing [(Id
BinderP 'CodeGen
b,GenStgRhs 'CodeGen
r)]
return (j, ctx)
StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs -> do
jas <- ((Id, GenStgRhs 'CodeGen) -> G (Maybe JStgStat))
-> [(Id, GenStgRhs 'CodeGen)]
-> StateT GenState IO [Maybe JStgStat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Id -> GenStgRhs 'CodeGen -> G (Maybe JStgStat))
-> (Id, GenStgRhs 'CodeGen) -> G (Maybe JStgStat)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> GenStgRhs 'CodeGen -> G (Maybe JStgStat)
assign) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
let m = if [Maybe JStgStat] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe JStgStat]
jas then Maybe JStgStat
forall a. Maybe a
Nothing else JStgStat -> Maybe JStgStat
forall a. a -> Maybe a
Just ([JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$ [Maybe JStgStat] -> [JStgStat]
forall a. [Maybe a] -> [a]
catMaybes [Maybe JStgStat]
jas)
j <- allocCls m . map snd . filter (isNothing . fst) $ zip jas bs
return (j, ctx)
where
ctx' :: ExprCtx
ctx' = ExprCtx -> ExprCtx
ctxClearLneFrame ExprCtx
ctx
assign :: Id -> CgStgRhs -> G (Maybe JStgStat)
assign :: Id -> GenStgRhs 'CodeGen -> G (Maybe JStgStat)
assign Id
b (StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ccs UpdateFlag
_upd [] CgStgExpr
expr Type
_typ)
| let strip :: GenStgExpr p -> GenStgExpr p
strip = ([GenTickish 'TickishPassStg], GenStgExpr p) -> GenStgExpr p
forall a b. (a, b) -> b
snd (([GenTickish 'TickishPassStg], GenStgExpr p) -> GenStgExpr p)
-> (GenStgExpr p -> ([GenTickish 'TickishPassStg], GenStgExpr p))
-> GenStgExpr p
-> GenStgExpr p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenTickish 'TickishPassStg -> Bool)
-> GenStgExpr p -> ([GenTickish 'TickishPassStg], GenStgExpr p)
forall (p :: StgPass).
(GenTickish 'TickishPassStg -> Bool)
-> GenStgExpr p -> ([GenTickish 'TickishPassStg], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not (Bool -> Bool)
-> (GenTickish 'TickishPassStg -> Bool)
-> GenTickish 'TickishPassStg
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTickish 'TickishPassStg -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode)
, StgCase (StgApp Id
scrutinee []) BinderP 'CodeGen
_ (AlgAlt TyCon
_) [GenStgAlt (DataAlt DataCon
_) [BinderP 'CodeGen]
params CgStgExpr
sel_expr] <- CgStgExpr -> CgStgExpr
forall {p :: StgPass}. GenStgExpr p -> GenStgExpr p
strip CgStgExpr
expr
, StgApp Id
selectee [] <- CgStgExpr -> CgStgExpr
forall {p :: StgPass}. GenStgExpr p -> GenStgExpr p
strip CgStgExpr
sel_expr
, let params_w_offsets :: [(Id, Int)]
params_w_offsets = [Id] -> [Int] -> [(Id, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
[BinderP 'CodeGen]
params ((Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
L.scanl' Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
1 ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Id -> Int) -> [Id] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Int
typeSize (Type -> Int) -> (Id -> Type) -> Id -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [Id]
[BinderP 'CodeGen]
params)
, let total_size :: Int
total_size = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Id -> Int) -> [Id] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Int
typeSize (Type -> Int) -> (Id -> Type) -> Id -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [Id]
[BinderP 'CodeGen]
params)
, Just Int
the_offset <- [(Id, Int)] -> Id -> Maybe Int
forall a b. Eq a => Assoc a b -> a -> Maybe b
ListSetOps.assocMaybe [(Id, Int)]
params_w_offsets Id
selectee
, Int
the_offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
16
= do
let the_fv :: Id
the_fv = Id
scrutinee
let sel_tag :: String
sel_tag | Int
the_offset Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = if Int
total_size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 then String
"2a"
else String
"2b"
| Bool
otherwise = Int -> String
forall a. Show a => a -> String
show Int
the_offset
tgts <- Id -> G [Ident]
identsForId Id
b
the_fvjs <- varsForId the_fv
case (tgts, the_fvjs) of
([Ident
tgt], [JStgExpr
the_fvj]) -> Maybe JStgStat -> G (Maybe JStgStat)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe JStgStat -> G (Maybe JStgStat))
-> Maybe JStgStat -> G (Maybe JStgStat)
forall a b. (a -> b) -> a -> b
$ JStgStat -> Maybe JStgStat
forall a. a -> Maybe a
Just
(Ident
tgt Ident -> JStgExpr -> JStgStat
||= JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr (FastString -> JStgExpr
global (FastString
hdCSelStr FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> String -> FastString
mkFastString String
sel_tag)) [JStgExpr
the_fvj])
([Ident], [JStgExpr])
_ -> String -> G (Maybe JStgStat)
forall a. HasCallStack => String -> a
panic String
"genBind.assign: invalid size"
assign Id
b (StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
_ccs UpdateFlag
_upd [] CgStgExpr
expr Type
_typ)
| CgStgExpr -> Bool
isInlineExpr CgStgExpr
expr = do
d <- Id -> G JStgStat
declVarsForId Id
b
tgt <- varsForId b
let ctx' = ExprCtx
ctx { ctxTarget = assocIdExprs b tgt }
(j, _) <- genExpr ctx' expr
return (Just (d <> j))
assign Id
_b StgRhsCon{} = Maybe JStgStat -> G (Maybe JStgStat)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JStgStat
forall a. Maybe a
Nothing
assign Id
b GenStgRhs 'CodeGen
r = HasDebugCallStack => ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
genEntry ExprCtx
ctx' Id
b GenStgRhs 'CodeGen
r G () -> G (Maybe JStgStat) -> G (Maybe JStgStat)
forall a b.
StateT GenState IO a
-> StateT GenState IO b -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe JStgStat -> G (Maybe JStgStat)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JStgStat
forall a. Maybe a
Nothing
genBindLne :: HasDebugCallStack
=> ExprCtx
-> CgStgBinding
-> G (JStgStat, ExprCtx)
genBindLne :: HasDebugCallStack =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStgStat, ExprCtx)
genBindLne ExprCtx
ctx GenStgBinding 'CodeGen
bndr = do
vis <- ((Id, Int, Bool) -> (Id, Int)) -> [(Id, Int, Bool)] -> [(Id, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
x,Int
y,Bool
_) -> (Id
x,Int
y)) ([(Id, Int, Bool)] -> [(Id, Int)])
-> StateT GenState IO [(Id, Int, Bool)]
-> StateT GenState IO [(Id, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Int -> [Id] -> StateT GenState IO [(Id, Int, Bool)]
HasDebugCallStack =>
Int -> [Id] -> StateT GenState IO [(Id, Int, Bool)]
optimizeFree Int
oldFrameSize ([Id]
newLvs[Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++((Id, GenStgRhs 'CodeGen) -> Id)
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, GenStgRhs 'CodeGen) -> Id
forall a b. (a, b) -> a
fst [(Id, GenStgRhs 'CodeGen)]
updBinds)
declUpds <- mconcat <$> mapM (fmap (||= null_) . identForId . fst) updBinds
let ctx' = [(Id, Int)] -> [Id] -> ExprCtx -> ExprCtx
ctxUpdateLneFrame [(Id, Int)]
vis [Id]
bound ExprCtx
ctx
mapM_ (uncurry $ genEntryLne ctx') binds
return (declUpds, ctx')
where
oldFrameSize :: Int
oldFrameSize = ExprCtx -> Int
ctxLneFrameSize ExprCtx
ctx
isOldLv :: Id -> Bool
isOldLv Id
i = ExprCtx -> Id -> Bool
ctxIsLneBinding ExprCtx
ctx Id
i Bool -> Bool -> Bool
||
ExprCtx -> Id -> Bool
ctxIsLneLiveVar ExprCtx
ctx Id
i
live :: LiveVars
live = LiveVars -> LiveVars
liveVars (LiveVars -> LiveVars) -> LiveVars -> LiveVars
forall a b. (a -> b) -> a -> b
$ [Id] -> LiveVars
mkDVarSet ([Id] -> LiveVars) -> [Id] -> LiveVars
forall a b. (a -> b) -> a -> b
$ GenStgBinding 'CodeGen -> [Id]
stgLneLive' GenStgBinding 'CodeGen
bndr
newLvs :: [Id]
newLvs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Bool
isOldLv) (LiveVars -> [Id]
dVarSetElems LiveVars
live)
binds :: [(Id, GenStgRhs 'CodeGen)]
binds = case GenStgBinding 'CodeGen
bndr of
StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
e -> [(Id
BinderP 'CodeGen
b,GenStgRhs 'CodeGen
e)]
StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs -> [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
bound :: [Id]
bound = ((Id, GenStgRhs 'CodeGen) -> Id)
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, GenStgRhs 'CodeGen) -> Id
forall a b. (a, b) -> a
fst [(Id, GenStgRhs 'CodeGen)]
binds
([(Id, GenStgRhs 'CodeGen)]
updBinds, [(Id, GenStgRhs 'CodeGen)]
_nonUpdBinds) = ((Id, GenStgRhs 'CodeGen) -> Bool)
-> [(Id, GenStgRhs 'CodeGen)]
-> ([(Id, GenStgRhs 'CodeGen)], [(Id, GenStgRhs 'CodeGen)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (GenStgRhs 'CodeGen -> Bool
isUpdatableRhs (GenStgRhs 'CodeGen -> Bool)
-> ((Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen)
-> (Id, GenStgRhs 'CodeGen)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen
forall a b. (a, b) -> b
snd) [(Id, GenStgRhs 'CodeGen)]
binds
genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G ()
genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
genEntryLne ExprCtx
ctx Id
i rhs :: GenStgRhs 'CodeGen
rhs@(StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
_cc UpdateFlag
update [BinderP 'CodeGen]
args CgStgExpr
body Type
typ) =
G () -> G ()
forall a. G a -> G a
resetSlots (G () -> G ()) -> G () -> G ()
forall a b. (a -> b) -> a -> b
$ do
let payloadSize :: Int
payloadSize = ExprCtx -> Int
ctxLneFrameSize ExprCtx
ctx
vars :: [(Id, Int)]
vars = ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx
myOffset :: Int
myOffset =
Int -> ((Int, (Id, Int)) -> Int) -> Maybe (Int, (Id, Int)) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Int
forall a. HasCallStack => String -> a
panic String
"genEntryLne: updatable binder not found in let-no-escape frame")
((Int
payloadSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-) (Int -> Int)
-> ((Int, (Id, Int)) -> Int) -> (Int, (Id, Int)) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (Id, Int)) -> Int
forall a b. (a, b) -> a
fst)
(((Int, (Id, Int)) -> Bool)
-> [(Int, (Id, Int))] -> Maybe (Int, (Id, Int))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==Id
i) (Id -> Bool)
-> ((Int, (Id, Int)) -> Id) -> (Int, (Id, Int)) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Int) -> Id
forall a b. (a, b) -> a
fst ((Id, Int) -> Id)
-> ((Int, (Id, Int)) -> (Id, Int)) -> (Int, (Id, Int)) -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (Id, Int)) -> (Id, Int)
forall a b. (a, b) -> b
snd) ([Int] -> [(Id, Int)] -> [(Int, (Id, Int))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Id, Int)]
vars))
mk_bh :: G JStgStat
mk_bh :: G JStgStat
mk_bh | UpdateFlag -> Bool
isUpdatable UpdateFlag
update =
do x <- StateT GenState IO Ident
freshIdent
return $ mconcat
[ x ||= ApplExpr hdBlackHoleLNE [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)]
, IfStat (Var x) (ReturnStat (Var x)) mempty
]
| Bool
otherwise = JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty
blk_hl <- G JStgStat
mk_bh
locals <- popLneFrame True payloadSize ctx
body <- genBody ctx R1 args body typ
ei@(identFS -> eii) <- identForEntryId i
sr <- genStaticRefsRhs rhs
let f = JStgStat
blk_hl JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
locals JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> JStgStat
body
emitClosureInfo $ ClosureInfo
{ ciVar = ei
, ciRegs = CIRegs 0 $ concatMap idJSRep args
, ciName = eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))
, ciLayout = fixedLayout . reverse $ map (stackSlotType . fst) (ctxLneFrameVars ctx)
, ciType = CIStackFrame
, ciStatic = sr
}
emitToplevel (FuncStat ei [] f)
genEntryLne ExprCtx
ctx Id
i (StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mu [GenTickish 'TickishPassStg]
_ticks [StgArg]
args Type
_typ) = G () -> G ()
forall a. G a -> G a
resetSlots (G () -> G ()) -> G () -> G ()
forall a b. (a -> b) -> a -> b
$ do
let payloadSize :: Int
payloadSize = ExprCtx -> Int
ctxLneFrameSize ExprCtx
ctx
ei <- Id -> StateT GenState IO Ident
identForEntryId Id
i
ii <- freshIdent
p <- popLneFrame True payloadSize ctx
args' <- concatMapM genArg args
ac <- allocCon ii con cc args'
emitToplevel (FuncStat ei [] (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack]))
genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G ()
genEntry :: HasDebugCallStack => ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
genEntry ExprCtx
_ Id
_i StgRhsCon {} = () -> G ()
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
genEntry ExprCtx
ctx Id
i rhs :: GenStgRhs 'CodeGen
rhs@(StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
cc UpdateFlag
upd_flag [BinderP 'CodeGen]
args CgStgExpr
body Type
typ) = G () -> G ()
forall a. G a -> G a
resetSlots (G () -> G ()) -> G () -> G ()
forall a b. (a -> b) -> a -> b
$ do
let live :: [Id]
live = GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr GenStgRhs 'CodeGen
rhs
ll <- [Id] -> G JStgStat
loadLiveFun [Id]
live
llv <- verifyRuntimeReps live
upd <- genUpdFrame upd_flag i
let entryCtx = [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget [] (ExprCtx -> ExprCtx
ctxClearLneFrame ExprCtx
ctx)
body <- genBody entryCtx R2 args body typ
et <- genEntryType args
setcc <- ifProfiling $
if et == CIThunk
then enterCostCentreThunk
else enterCostCentreFun cc
sr <- genStaticRefsRhs rhs
ei <- identForEntryId i
emitClosureInfo $ ClosureInfo
{ ciVar = ei
, ciRegs = CIRegs 0 $ PtrV : concatMap idJSRep args
, ciName = identFS ei <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))
, ciLayout = fixedLayout $ map (unaryTypeJSRep . idType) live
, ciType = et
, ciStatic = sr
}
emitToplevel (FuncStat ei [] (mconcat [ll, llv, upd, setcc, body]))
genEntryType :: HasDebugCallStack => [Id] -> G CIType
genEntryType :: HasDebugCallStack => [Id] -> G CIType
genEntryType [] = CIType -> G CIType
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CIType
CIThunk
genEntryType [Id]
args = do
args' <- (Id -> G [JStgExpr]) -> [Id] -> StateT GenState IO [[JStgExpr]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => Id -> G [JStgExpr]
Id -> G [JStgExpr]
genIdArg [Id]
args
return $ CIFun (length args) (length $ concat args')
genBody :: HasDebugCallStack
=> ExprCtx
-> StgReg
-> [Id]
-> CgStgExpr
-> Type
-> G JStgStat
genBody :: HasDebugCallStack =>
ExprCtx -> StgReg -> [Id] -> CgStgExpr -> Type -> G JStgStat
genBody ExprCtx
ctx StgReg
startReg [Id]
args CgStgExpr
e Type
typ = do
la <- do
args' <- (Id -> G [Ident]) -> [Id] -> G [Ident]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => Id -> G [Ident]
Id -> G [Ident]
genIdArgI [Id]
args
return (declAssignAll args' (fmap toJExpr [startReg..]))
lav <- verifyRuntimeReps args
let res_vars = HasDebugCallStack => Type -> [(PrimRep, Int)]
Type -> [(PrimRep, Int)]
resultSize Type
typ
let go_var [JStgExpr]
regs = \case
[] -> []
((PrimRep
rep,Int
size):[(PrimRep, Int)]
rs) ->
let !([JStgExpr]
regs0,[JStgExpr]
regs1) = Int -> [JStgExpr] -> ([JStgExpr], [JStgExpr])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
size [JStgExpr]
regs
!ts :: [TypedExpr]
ts = [JStgExpr] -> [(PrimRep, Int)] -> [TypedExpr]
go_var [JStgExpr]
regs1 [(PrimRep, Int)]
rs
in PrimRep -> [JStgExpr] -> TypedExpr
TypedExpr PrimRep
rep [JStgExpr]
regs0 TypedExpr -> [TypedExpr] -> [TypedExpr]
forall a. a -> [a] -> [a]
: [TypedExpr]
ts
let tgt = [JStgExpr] -> [(PrimRep, Int)] -> [TypedExpr]
go_var [JStgExpr]
jsRegsFromR1 [(PrimRep, Int)]
res_vars
let !ctx' = ExprCtx
ctx { ctxTarget = tgt }
(e, _r) <- genExpr ctx' e
return $ la <> lav <> e <> returnStack
resultSize :: HasDebugCallStack => Type -> [(PrimRep, Int)]
resultSize :: HasDebugCallStack => Type -> [(PrimRep, Int)]
resultSize Type
ty = [(PrimRep, Int)]
result
where
result :: [(PrimRep, Int)]
result = [PrimRep]
result_reps [PrimRep] -> [Int] -> [(PrimRep, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int]
result_slots
result_slots :: [Int]
result_slots = (PrimRep -> Int) -> [PrimRep] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SlotCount -> Int
slotCount (SlotCount -> Int) -> (PrimRep -> SlotCount) -> PrimRep -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimRep -> SlotCount
primRepSize) [PrimRep]
result_reps
result_reps :: [PrimRep]
result_reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty
verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStgStat
verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStgStat
verifyRuntimeReps [Id]
xs = do
runtime_assert <- StgToJSConfig -> Bool
csRuntimeAssert (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
if not runtime_assert
then pure mempty
else mconcat <$> mapM verifyRuntimeRep xs
where
verifyRuntimeRep :: Id -> G JStgStat
verifyRuntimeRep Id
i = do
i' <- Id -> G [JStgExpr]
varsForId Id
i
pure $ go i' (idJSRep i)
go :: [JStgExpr] -> [JSRep] -> JStgStat
go [JStgExpr]
js (JSRep
VoidV:[JSRep]
vs) = [JStgExpr] -> [JSRep] -> JStgStat
go [JStgExpr]
js [JSRep]
vs
go (JStgExpr
j1:JStgExpr
j2:[JStgExpr]
js) (JSRep
LongV:[JSRep]
vs) = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_long" [JStgExpr
j1,JStgExpr
j2] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgExpr] -> [JSRep] -> JStgStat
go [JStgExpr]
js [JSRep]
vs
go (JStgExpr
j1:JStgExpr
j2:[JStgExpr]
js) (JSRep
AddrV:[JSRep]
vs) = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_addr" [JStgExpr
j1,JStgExpr
j2] JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgExpr] -> [JSRep] -> JStgStat
go [JStgExpr]
js [JSRep]
vs
go (JStgExpr
j:[JStgExpr]
js) (JSRep
v:[JSRep]
vs) = JStgExpr -> JSRep -> JStgStat
ver JStgExpr
j JSRep
v JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgExpr] -> [JSRep] -> JStgStat
go [JStgExpr]
js [JSRep]
vs
go [] [] = JStgStat
forall a. Monoid a => a
mempty
go [JStgExpr]
_ [JSRep]
_ = String -> SDoc -> JStgStat
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"verifyRuntimeReps: inconsistent sizes" ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
xs)
ver :: JStgExpr -> JSRep -> JStgStat
ver JStgExpr
j JSRep
PtrV = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_heapobj" [JStgExpr
j]
ver JStgExpr
j JSRep
IntV = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_int" [JStgExpr
j]
ver JStgExpr
j JSRep
DoubleV = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_double" [JStgExpr
j]
ver JStgExpr
j JSRep
ArrV = FastString -> [JStgExpr] -> JStgStat
v FastString
"h$verify_rep_arr" [JStgExpr
j]
ver JStgExpr
_ JSRep
_ = JStgStat
forall a. Monoid a => a
mempty
v :: FastString -> [JStgExpr] -> JStgStat
v FastString
f [JStgExpr]
as = JStgExpr -> [JStgExpr] -> JStgStat
ApplStat (FastString -> JStgExpr
global FastString
f) [JStgExpr]
as
loadLiveFun :: [Id] -> G JStgStat
loadLiveFun :: [Id] -> G JStgStat
loadLiveFun [Id]
l = do
l' <- [[Ident]] -> [Ident]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Ident]] -> [Ident]) -> StateT GenState IO [[Ident]] -> G [Ident]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> G [Ident]) -> [Id] -> StateT GenState IO [[Ident]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Id -> G [Ident]
identsForId [Id]
l
case l' of
[] -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
forall a. Monoid a => a
mempty
[Ident
v] -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
v Ident -> JStgExpr -> JStgStat
||= JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_)
[Ident
v1,Ident
v2] -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
[ Ident
v1 Ident -> JStgExpr -> JStgStat
||= JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_
, Ident
v2 Ident -> JStgExpr -> JStgStat
||= JStgExpr
r1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField2_
]
(Ident
v:[Ident]
vs) -> do
d <- StateT GenState IO Ident
freshIdent
let l'' = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> ([Ident] -> [JStgStat]) -> [Ident] -> JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Ident -> JStgStat) -> [Int] -> [Ident] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (JStgExpr -> Int -> Ident -> JStgStat
loadLiveVar (JStgExpr -> Int -> Ident -> JStgStat)
-> JStgExpr -> Int -> Ident -> JStgStat
forall a b. (a -> b) -> a -> b
$ Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
d) [(Int
1::Int)..] ([Ident] -> JStgStat) -> [Ident] -> JStgStat
forall a b. (a -> b) -> a -> b
$ [Ident]
vs
return $ mconcat
[ v ||= r1 .^ closureField1_
, d ||= r1 .^ closureField2_
, l''
]
where
loadLiveVar :: JStgExpr -> Int -> Ident -> JStgStat
loadLiveVar JStgExpr
d Int
n Ident
v = let ident :: Ident
ident = FastString -> Ident
name (Int -> FastString
dataFieldName Int
n)
in Ident
v Ident -> JStgExpr -> JStgStat
||= JStgExpr -> Ident -> JStgExpr
SelExpr JStgExpr
d Ident
ident
popLneFrame :: Bool -> Int -> ExprCtx -> G JStgStat
popLneFrame :: Bool -> Int -> ExprCtx -> G JStgStat
popLneFrame Bool
inEntry Int
size ExprCtx
ctx = do
let ctx' :: ExprCtx
ctx' = ExprCtx -> Int -> ExprCtx
ctxLneShrinkStack ExprCtx
ctx Int
size
let gen_id_slot :: (Id, Int) -> StateT GenState IO (Ident, StackSlot)
gen_id_slot (Id
i,Int
n) = do
ids <- Id -> G [Ident]
identsForId Id
i
let !id_n = [Ident]
ids [Ident] -> Int -> Ident
forall a. HasCallStack => [a] -> Int -> a
!! (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
pure (id_n, SlotId i n)
is <- ((Id, Int) -> StateT GenState IO (Ident, StackSlot))
-> [(Id, Int)] -> StateT GenState IO [(Ident, StackSlot)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id, Int) -> StateT GenState IO (Ident, StackSlot)
gen_id_slot (ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx')
let skip = if Bool
inEntry then Int
1 else Int
0
popSkipI skip is
genUpdFrame :: UpdateFlag -> Id -> G JStgStat
genUpdFrame :: UpdateFlag -> Id -> G JStgStat
genUpdFrame UpdateFlag
u Id
i
| UpdateFlag -> Bool
isReEntrant UpdateFlag
u = JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty
| Id -> Bool
isOneShotBndr Id
i = G JStgStat
maybeBh
| UpdateFlag -> Bool
isUpdatable UpdateFlag
u = G JStgStat
updateThunk
| Bool
otherwise = G JStgStat
maybeBh
where
isReEntrant :: UpdateFlag -> Bool
isReEntrant UpdateFlag
ReEntrant = Bool
True
isReEntrant UpdateFlag
_ = Bool
False
maybeBh :: G JStgStat
maybeBh = do
settings <- StateT GenState IO StgToJSConfig
getSettings
assertRtsStat (return $ bhSingleEntry settings)
bhSingleEntry :: StgToJSConfig -> JStgStat
bhSingleEntry :: StgToJSConfig -> JStgStat
bhSingleEntry StgToJSConfig
_settings = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
[ JStgExpr -> JStgExpr
closureInfo JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdBlackHoleTrap
, JStgExpr -> JStgExpr
closureField1 JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
undefined_
, JStgExpr -> JStgExpr
closureField2 JStgExpr
r1 JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
undefined_
]
genStaticRefsRhs :: CgStgRhs -> G CIStatic
genStaticRefsRhs :: GenStgRhs 'CodeGen -> G CIStatic
genStaticRefsRhs GenStgRhs 'CodeGen
lv = LiveVars -> G CIStatic
genStaticRefs (GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
lv)
genStaticRefs :: LiveVars -> G CIStatic
genStaticRefs :: LiveVars -> G CIStatic
genStaticRefs LiveVars
lv
| LiveVars -> Bool
isEmptyDVarSet LiveVars
sv = CIStatic -> G CIStatic
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FastString] -> CIStatic
CIStaticRefs [])
| Bool
otherwise = do
unfloated <- (GenState -> UniqFM Id CgStgExpr)
-> StateT GenState IO (UniqFM Id CgStgExpr)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> UniqFM Id CgStgExpr
gsUnfloated
let xs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Id
x -> Bool -> Bool
not (Id -> UniqFM Id CgStgExpr -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
elemUFM Id
x UniqFM Id CgStgExpr
unfloated Bool -> Bool -> Bool
||
Type -> Bool
definitelyUnliftedType (Id -> Type
idType Id
x)))
(LiveVars -> [Id]
dVarSetElems LiveVars
sv)
CIStaticRefs . catMaybes <$> mapM getStaticRef xs
where
sv :: LiveVars
sv = LiveVars -> LiveVars
liveStatic LiveVars
lv
getStaticRef :: Id -> G (Maybe FastString)
getStaticRef :: Id -> StateT GenState IO (Maybe FastString)
getStaticRef = ([Ident] -> Maybe FastString)
-> G [Ident] -> StateT GenState IO (Maybe FastString)
forall a b.
(a -> b) -> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Ident -> FastString) -> Maybe Ident -> Maybe FastString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ident -> FastString
identFS (Maybe Ident -> Maybe FastString)
-> ([Ident] -> Maybe Ident) -> [Ident] -> Maybe FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> Maybe Ident
forall a. [a] -> Maybe a
listToMaybe) (G [Ident] -> StateT GenState IO (Maybe FastString))
-> (Id -> G [Ident]) -> Id -> StateT GenState IO (Maybe FastString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> G [Ident]
identsForId
optimizeFree
:: HasDebugCallStack
=> Int
-> [Id]
-> G [(Id,Int,Bool)]
optimizeFree :: HasDebugCallStack =>
Int -> [Id] -> StateT GenState IO [(Id, Int, Bool)]
optimizeFree Int
offset [Id]
ids = do
let
idSize :: Id -> Int
idSize :: Id -> Int
idSize Id
i = Type -> Int
typeSize (Type -> Int) -> Type -> Int
forall a b. (a -> b) -> a -> b
$ Id -> Type
idType Id
i
ids' :: [(Id, Int)]
ids' = (Id -> [(Id, Int)]) -> [Id] -> [(Id, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Id
i -> (Int -> (Id, Int)) -> [Int] -> [(Id, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Id
i,) [Int
1..Id -> Int
idSize Id
i]) [Id]
ids
l :: Int
l = [(Id, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, Int)]
ids'
slots <- Int -> [StackSlot] -> [StackSlot]
forall a. Int -> [a] -> [a]
drop Int
offset ([StackSlot] -> [StackSlot])
-> ([StackSlot] -> [StackSlot]) -> [StackSlot] -> [StackSlot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [StackSlot] -> [StackSlot]
forall a. Int -> [a] -> [a]
take Int
l ([StackSlot] -> [StackSlot])
-> ([StackSlot] -> [StackSlot]) -> [StackSlot] -> [StackSlot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([StackSlot] -> [StackSlot] -> [StackSlot]
forall a. [a] -> [a] -> [a]
++StackSlot -> [StackSlot]
forall a. a -> [a]
repeat StackSlot
SlotUnknown) ([StackSlot] -> [StackSlot])
-> StateT GenState IO [StackSlot] -> StateT GenState IO [StackSlot]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO [StackSlot]
getSlots
let slm = [(StackSlot, Int)] -> Map StackSlot Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([StackSlot] -> [Int] -> [(StackSlot, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [StackSlot]
slots [Int
0..])
(remaining, fixed) = partitionWith (\inp :: (Id, Int)
inp@(Id
i,Int
n) -> Either (Id, Int) (Id, Int, Int, Bool)
-> (Int -> Either (Id, Int) (Id, Int, Int, Bool))
-> Maybe Int
-> Either (Id, Int) (Id, Int, Int, Bool)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Id, Int) -> Either (Id, Int) (Id, Int, Int, Bool)
forall a b. a -> Either a b
Left (Id, Int)
inp)
(\Int
j -> (Id, Int, Int, Bool) -> Either (Id, Int) (Id, Int, Int, Bool)
forall a b. b -> Either a b
Right (Id
i,Int
n,Int
j,Bool
True))
(StackSlot -> Map StackSlot Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Id -> Int -> StackSlot
SlotId Id
i Int
n) Map StackSlot Int
slm))
ids'
takenSlots = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
S.fromList (((Id, Int, Int, Bool) -> Int) -> [(Id, Int, Int, Bool)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Id
_,Int
_,Int
x,Bool
_) -> Int
x) [(Id, Int, Int, Bool)]
fixed)
freeSlots = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Int
takenSlots) [Int
0..Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
remaining' = ((Id, Int) -> Int -> (Id, Int, Int, Bool))
-> [(Id, Int)] -> [Int] -> [(Id, Int, Int, Bool)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Id
i,Int
n) Int
j -> (Id
i,Int
n,Int
j,Bool
False)) [(Id, Int)]
remaining [Int]
freeSlots
allSlots = ((Id, Int, Int, Bool) -> (Id, Int, Int, Bool) -> Ordering)
-> [(Id, Int, Int, Bool)] -> [(Id, Int, Int, Bool)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Id, Int, Int, Bool) -> Int)
-> (Id, Int, Int, Bool)
-> (Id, Int, Int, Bool)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` \(Id
_,Int
_,Int
x,Bool
_) -> Int
x) ([(Id, Int, Int, Bool)]
fixed [(Id, Int, Int, Bool)]
-> [(Id, Int, Int, Bool)] -> [(Id, Int, Int, Bool)]
forall a. [a] -> [a] -> [a]
++ [(Id, Int, Int, Bool)]
remaining')
return $ map (\(Id
i,Int
n,Int
_,Bool
b) -> (Id
i,Int
n,Bool
b)) allSlots
allocCls :: Maybe JStgStat -> [(Id, CgStgRhs)] -> G JStgStat
allocCls :: Maybe JStgStat -> [(Id, GenStgRhs 'CodeGen)] -> G JStgStat
allocCls Maybe JStgStat
dynMiddle [(Id, GenStgRhs 'CodeGen)]
xs = do
(stat, dyn) <- ((Id, GenStgRhs 'CodeGen)
-> StateT
GenState
IO
(Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack)))
-> [(Id, GenStgRhs 'CodeGen)]
-> StateT
GenState
IO
([JStgStat], [(Ident, JStgExpr, [JStgExpr], CostCentreStack)])
forall (m :: * -> *) a b c.
Monad m =>
(a -> m (Either b c)) -> [a] -> m ([b], [c])
partitionWithM (Id, GenStgRhs 'CodeGen)
-> StateT
GenState
IO
(Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
toCl [(Id, GenStgRhs 'CodeGen)]
xs
ac <- allocDynAll False dynMiddle dyn
pure (mconcat stat <> ac)
where
toCl :: (Id, CgStgRhs)
-> G (Either JStgStat (Ident,JStgExpr,[JStgExpr],CostCentreStack))
toCl :: (Id, GenStgRhs 'CodeGen)
-> StateT
GenState
IO
(Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
toCl (Id
i, StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mui [GenTickish 'TickishPassStg]
_ticjs [StgArg
a] Type
_typ) | DataCon -> Bool
isUnboxableCon DataCon
con = do
ii <- Id -> StateT GenState IO Ident
identForId Id
i
ac <- allocCon ii con cc =<< genArg a
pure (Left (decl ii <> ac))
toCl (Id
i, StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mu [GenTickish 'TickishPassStg]
_ticks [StgArg]
ar Type
_typ) =
(Ident, JStgExpr, [JStgExpr], CostCentreStack)
-> Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack)
forall a b. b -> Either a b
Right ((Ident, JStgExpr, [JStgExpr], CostCentreStack)
-> Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT
GenState IO (Ident, JStgExpr, [JStgExpr], CostCentreStack)
-> StateT
GenState
IO
(Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,) (Ident
-> JStgExpr
-> [JStgExpr]
-> CostCentreStack
-> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO Ident
-> StateT
GenState
IO
(JStgExpr
-> [JStgExpr]
-> CostCentreStack
-> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i
StateT
GenState
IO
(JStgExpr
-> [JStgExpr]
-> CostCentreStack
-> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO JStgExpr
-> StateT
GenState
IO
([JStgExpr]
-> CostCentreStack
-> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DataCon -> StateT GenState IO JStgExpr
varForDataConWorker DataCon
con
StateT
GenState
IO
([JStgExpr]
-> CostCentreStack
-> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> G [JStgExpr]
-> StateT
GenState
IO
(CostCentreStack -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (StgArg -> G [JStgExpr]) -> [StgArg] -> G [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg [StgArg]
ar
StateT
GenState
IO
(CostCentreStack -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO CostCentreStack
-> StateT
GenState IO (Ident, JStgExpr, [JStgExpr], CostCentreStack)
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CostCentreStack -> StateT GenState IO CostCentreStack
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CostCentreStack
cc)
toCl (Id
i, cl :: GenStgRhs 'CodeGen
cl@(StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
cc UpdateFlag
_upd_flag [BinderP 'CodeGen]
_args CgStgExpr
_body Type
_typ)) =
let live :: [Id]
live = GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr GenStgRhs 'CodeGen
cl
in (Ident, JStgExpr, [JStgExpr], CostCentreStack)
-> Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack)
forall a b. b -> Either a b
Right ((Ident, JStgExpr, [JStgExpr], CostCentreStack)
-> Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT
GenState IO (Ident, JStgExpr, [JStgExpr], CostCentreStack)
-> StateT
GenState
IO
(Either JStgStat (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,) (Ident
-> JStgExpr
-> [JStgExpr]
-> CostCentreStack
-> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO Ident
-> StateT
GenState
IO
(JStgExpr
-> [JStgExpr]
-> CostCentreStack
-> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i
StateT
GenState
IO
(JStgExpr
-> [JStgExpr]
-> CostCentreStack
-> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO JStgExpr
-> StateT
GenState
IO
([JStgExpr]
-> CostCentreStack
-> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Id -> StateT GenState IO JStgExpr
varForEntryId Id
i
StateT
GenState
IO
([JStgExpr]
-> CostCentreStack
-> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> G [JStgExpr]
-> StateT
GenState
IO
(CostCentreStack -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Id -> G [JStgExpr]) -> [Id] -> G [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM Id -> G [JStgExpr]
varsForId [Id]
live
StateT
GenState
IO
(CostCentreStack -> (Ident, JStgExpr, [JStgExpr], CostCentreStack))
-> StateT GenState IO CostCentreStack
-> StateT
GenState IO (Ident, JStgExpr, [JStgExpr], CostCentreStack)
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CostCentreStack -> StateT GenState IO CostCentreStack
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CostCentreStack
cc)
genCase :: HasDebugCallStack
=> ExprCtx
-> Id
-> CgStgExpr
-> AltType
-> [CgStgAlt]
-> LiveVars
-> G (JStgStat, ExprResult)
genCase :: HasDebugCallStack =>
ExprCtx
-> Id
-> CgStgExpr
-> AltType
-> [GenStgAlt 'CodeGen]
-> LiveVars
-> G (JStgStat, ExprResult)
genCase ExprCtx
ctx Id
bnd CgStgExpr
e AltType
at [GenStgAlt 'CodeGen]
alts LiveVars
l
| StgLit (LitString ByteString
bs) <- CgStgExpr
e
, [GenStgAlt AltCon
DEFAULT [BinderP 'CodeGen]
_ CgStgExpr
rhs] <- [GenStgAlt 'CodeGen]
alts
, StgApp Id
i [StgArg]
args <- CgStgExpr
rhs
, Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
i Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
unpackCStringAppendIdKey
, [StgVarArg Id
b',StgArg
x] <- [StgArg]
args
, Id
bnd Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
b'
, Just FastString
d <- ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
bs
, [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
= do
prof <- StgToJSConfig -> Bool
csProf (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
let profArg = if Bool
prof then [JStgExpr
jCafCCS] else []
a <- genArg x
return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)
, ExprInline
)
| StgLit (LitString ByteString
bs) <- CgStgExpr
e
, [GenStgAlt AltCon
DEFAULT [BinderP 'CodeGen]
_ CgStgExpr
rhs] <- [GenStgAlt 'CodeGen]
alts
, StgApp Id
i [StgArg]
args <- CgStgExpr
rhs
, Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
i Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
unpackCStringAppendUtf8IdKey
, [StgVarArg Id
b',StgArg
x] <- [StgArg]
args
, Id
bnd Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
b'
, Just FastString
d <- ByteString -> Maybe FastString
decodeModifiedUTF8 ByteString
bs
, [JStgExpr
top] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
= do
prof <- StgToJSConfig -> Bool
csProf (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
let profArg = if Bool
prof then [JStgExpr
jCafCCS] else []
a <- genArg x
return ( top |= app "h$appendToHsString" (toJExpr d : a ++ profArg)
, ExprInline
)
| CgStgExpr -> Bool
isInlineExpr CgStgExpr
e = do
bndi <- Id -> G [Ident]
identsForId Id
bnd
let ctx' = Id -> ExprCtx -> ExprCtx
ctxSetTop Id
bnd
(ExprCtx -> ExprCtx) -> ExprCtx -> ExprCtx
forall a b. (a -> b) -> a -> b
$ [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget (Id -> [JStgExpr] -> [TypedExpr]
assocIdExprs Id
bnd ((Ident -> JStgExpr) -> [Ident] -> [JStgExpr]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr [Ident]
bndi))
(ExprCtx -> ExprCtx) -> ExprCtx -> ExprCtx
forall a b. (a -> b) -> a -> b
$ ExprCtx
ctx
(ej, r) <- genExpr ctx' e
massert (r == ExprInline)
(aj, ar) <- genAlts ctx bnd at alts
(saveCCS,restoreCCS) <- ifProfilingM $ do
ccsVar <- freshIdent
pure ( ccsVar ||= toJExpr jCurrentCCS
, toJExpr jCurrentCCS |= toJExpr ccsVar
)
return ( mconcat
[ mconcat (map decl bndi)
, saveCCS
, ej
, restoreCCS
, aj
]
, ar
)
| Bool
otherwise = do
rj <- HasDebugCallStack =>
ExprCtx
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> LiveVars -> G JStgStat
ExprCtx
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> LiveVars -> G JStgStat
genRet ExprCtx
ctx Id
bnd AltType
at [GenStgAlt 'CodeGen]
alts LiveVars
l
let ctx' = Id -> ExprCtx -> ExprCtx
ctxSetTop Id
bnd
(ExprCtx -> ExprCtx) -> ExprCtx -> ExprCtx
forall a b. (a -> b) -> a -> b
$ [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget (Id -> [JStgExpr] -> [TypedExpr]
assocIdExprs Id
bnd ((StgReg -> JStgExpr) -> [StgReg] -> [JStgExpr]
forall a b. (a -> b) -> [a] -> [b]
map StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr [StgReg
R1 ..]))
(ExprCtx -> ExprCtx) -> ExprCtx -> ExprCtx
forall a b. (a -> b) -> a -> b
$ ExprCtx
ctx
(ej, _r) <- genExpr ctx' e
return (rj <> ej, ExprCont)
genRet :: HasDebugCallStack
=> ExprCtx
-> Id
-> AltType
-> [CgStgAlt]
-> LiveVars
-> G JStgStat
genRet :: HasDebugCallStack =>
ExprCtx
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> LiveVars -> G JStgStat
genRet ExprCtx
ctx Id
e AltType
at [GenStgAlt 'CodeGen]
as LiveVars
l = StateT GenState IO Ident
freshIdent StateT GenState IO Ident -> (Ident -> G JStgStat) -> G JStgStat
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ident -> G JStgStat
f
where
allRefs :: [Id]
allRefs :: [Id]
allRefs = Set Id -> [Id]
forall a. Set a -> [a]
S.toList (Set Id -> [Id]) -> ([Set Id] -> Set Id) -> [Set Id] -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set Id] -> Set Id
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Id] -> [Id]) -> [Set Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ (GenStgAlt 'CodeGen -> Set Id) -> [GenStgAlt 'CodeGen] -> [Set Id]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM (CgStgExpr -> Set Id)
-> (GenStgAlt 'CodeGen -> CgStgExpr)
-> GenStgAlt 'CodeGen
-> Set Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs) [GenStgAlt 'CodeGen]
as
lneLive :: Int
lneLive :: Int
lneLive = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes ((Id -> Maybe Int) -> [Id] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map (ExprCtx -> Id -> Maybe Int
ctxLneBindingStackSize ExprCtx
ctx) [Id]
allRefs)
ctx' :: ExprCtx
ctx' = ExprCtx -> Int -> ExprCtx
ctxLneShrinkStack ExprCtx
ctx Int
lneLive
lneVars :: [Id]
lneVars = ((Id, Int) -> Id) -> [(Id, Int)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Int) -> Id
forall a b. (a, b) -> a
fst ([(Id, Int)] -> [Id]) -> [(Id, Int)] -> [Id]
forall a b. (a -> b) -> a -> b
$ ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx'
isLne :: Id -> Bool
isLne Id
i = ExprCtx -> Id -> Bool
ctxIsLneBinding ExprCtx
ctx Id
i Bool -> Bool -> Bool
|| ExprCtx -> Id -> Bool
ctxIsLneLiveVar ExprCtx
ctx' Id
i
nonLne :: [Id]
nonLne = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Bool
isLne) (LiveVars -> [Id]
dVarSetElems LiveVars
l)
f :: Ident -> G JStgStat
f :: Ident -> G JStgStat
f r :: Ident
r@(Ident -> FastString
identFS -> FastString
ri) = do
pushLne <- Int -> ExprCtx -> G JStgStat
HasDebugCallStack => Int -> ExprCtx -> G JStgStat
pushLneFrame Int
lneLive ExprCtx
ctx
saveCCS <- ifProfilingM $ push [jCurrentCCS]
free <- optimizeFree 0 nonLne
pushRet <- pushRetArgs free (toJExpr r)
fun' <- fun free
sr <- genStaticRefs l
prof <- profiling
emitClosureInfo $ ClosureInfo
{ ciVar = r
, ciRegs = CIRegs 0 altRegs
, ciName = ri
, ciLayout = fixedLayout . reverse $
map (stackSlotType . fst3) free
++ if prof then [ObjV] else map stackSlotType lneVars
, ciType = CIStackFrame
, ciStatic = sr
}
emitToplevel $ FuncStat r [] fun'
return (pushLne <> saveCCS <> pushRet)
fst3 :: (a, b, c) -> a
fst3 ~(a
x,b
_,c
_) = a
x
altRegs :: HasDebugCallStack => [JSRep]
altRegs :: HasDebugCallStack => [JSRep]
altRegs = case AltType
at of
PrimAlt PrimRep
ptc -> [HasDebugCallStack => PrimRep -> JSRep
PrimRep -> JSRep
primRepToJSRep PrimRep
ptc]
MultiValAlt Int
_n -> HasDebugCallStack => Id -> [JSRep]
Id -> [JSRep]
idJSRep Id
e
AltType
_ -> [JSRep
PtrV]
pop_handle_CCS :: [(JStgExpr, StackSlot)] -> G JStgStat
pop_handle_CCS :: [(JStgExpr, StackSlot)] -> G JStgStat
pop_handle_CCS [] = JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
forall a. Monoid a => a
mempty
pop_handle_CCS [(JStgExpr, StackSlot)]
xs = do
[StackSlot] -> G ()
addSlots (((JStgExpr, StackSlot) -> StackSlot)
-> [(JStgExpr, StackSlot)] -> [StackSlot]
forall a b. (a -> b) -> [a] -> [b]
map (JStgExpr, StackSlot) -> StackSlot
forall a b. (a, b) -> b
snd [(JStgExpr, StackSlot)]
xs)
a <- Int -> G JStgStat
adjSpN ([(JStgExpr, StackSlot)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(JStgExpr, StackSlot)]
xs)
return (loadSkip 0 (map fst xs) <> a)
fun :: [(Id, Int, Bool)] -> G JStgStat
fun [(Id, Int, Bool)]
free = G JStgStat -> G JStgStat
forall a. G a -> G a
resetSlots (G JStgStat -> G JStgStat) -> G JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ do
decs <- Id -> G JStgStat
declVarsForId Id
e
load <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> identsForId e
loadv <- verifyRuntimeReps [e]
ras <- loadRetArgs free
rasv <- verifyRuntimeReps (map (\(Id
x,Int
_,Bool
_)->Id
x) free)
restoreCCS <- ifProfilingM . pop_handle_CCS $ pure (jCurrentCCS, SlotUnknown)
rlne <- popLneFrame False lneLive ctx'
rlnev <- verifyRuntimeReps lneVars
(alts, _altr) <- genAlts ctx' e at as
return $ decs <> load <> loadv <> ras <> rasv <> restoreCCS <> rlne <> rlnev <> alts <>
returnStack
genAlts :: HasDebugCallStack
=> ExprCtx
-> Id
-> AltType
-> [CgStgAlt]
-> G (JStgStat, ExprResult)
genAlts :: HasDebugCallStack =>
ExprCtx
-> Id
-> AltType
-> [GenStgAlt 'CodeGen]
-> G (JStgStat, ExprResult)
genAlts ExprCtx
ctx Id
e AltType
at [GenStgAlt 'CodeGen]
alts = do
(st, er) <- case AltType
at of
AltType
PolyAlt -> case [GenStgAlt 'CodeGen]
alts of
[GenStgAlt 'CodeGen
alt] -> (Branch (Maybe JStgExpr) -> JStgStat
forall a. Branch a -> JStgStat
branch_stat (Branch (Maybe JStgExpr) -> JStgStat)
-> (Branch (Maybe JStgExpr) -> ExprResult)
-> Branch (Maybe JStgExpr)
-> (JStgStat, ExprResult)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Branch (Maybe JStgExpr) -> ExprResult
forall a. Branch a -> ExprResult
branch_result) (Branch (Maybe JStgExpr) -> (JStgStat, ExprResult))
-> StateT GenState IO (Branch (Maybe JStgExpr))
-> G (JStgStat, ExprResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExprCtx
-> Id
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JStgExpr))
mkAlgBranch ExprCtx
ctx Id
e GenStgAlt 'CodeGen
alt
[GenStgAlt 'CodeGen]
_ -> String -> G (JStgStat, ExprResult)
forall a. HasCallStack => String -> a
panic String
"genAlts: multiple polyalt"
PrimAlt PrimRep
_tc
| [GenStgAlt AltCon
_ [BinderP 'CodeGen]
bs CgStgExpr
expr] <- [GenStgAlt 'CodeGen]
alts
-> do
ie <- Id -> G [JStgExpr]
varsForId Id
e
dids <- mconcat <$> mapM declVarsForId bs
bss <- concatMapM varsForId bs
(ej, er) <- genExpr ctx expr
return (dids <> assignAll bss ie <> ej, er)
PrimAlt PrimRep
tc
-> do
ie <- Id -> G [JStgExpr]
varsForId Id
e
(r, bss) <- normalizeBranches ctx <$>
mapM (isolateSlots . mkPrimIfBranch ctx [primRepToJSRep tc]) alts
setSlots []
return (mkSw ie bss, r)
MultiValAlt Int
n
| [GenStgAlt AltCon
_ [BinderP 'CodeGen]
bs CgStgExpr
expr] <- [GenStgAlt 'CodeGen]
alts
-> do
eids <- Id -> G [JStgExpr]
varsForId Id
e
l <- loadUbxTup eids bs n
(ej, er) <- genExpr ctx expr
return (l <> ej, er)
AlgAlt TyCon
tc
| [GenStgAlt 'CodeGen
_alt] <- [GenStgAlt 'CodeGen]
alts
, TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc
-> String -> G (JStgStat, ExprResult)
forall a. HasCallStack => String -> a
panic String
"genAlts: unexpected unboxed tuple"
AlgAlt TyCon
_tc
| [GenStgAlt 'CodeGen
alt] <- [GenStgAlt 'CodeGen]
alts
-> do
Branch _ s r <- ExprCtx
-> Id
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JStgExpr))
mkAlgBranch ExprCtx
ctx Id
e GenStgAlt 'CodeGen
alt
return (s, r)
AlgAlt TyCon
_tc
| [GenStgAlt 'CodeGen
alt,GenStgAlt 'CodeGen
_] <- [GenStgAlt 'CodeGen]
alts
, DataAlt DataCon
dc <- GenStgAlt 'CodeGen -> AltCon
forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt 'CodeGen
alt
, DataCon -> Bool
isBoolDataCon DataCon
dc
-> do
i <- Id -> StateT GenState IO JStgExpr
varForId Id
e
nbs <- normalizeBranches ctx <$>
mapM (isolateSlots . mkAlgBranch ctx e) alts
case nbs of
(ExprResult
r, [Branch Maybe JStgExpr
_ JStgStat
s1 ExprResult
_, Branch Maybe JStgExpr
_ JStgStat
s2 ExprResult
_]) -> do
let s :: JStgStat
s = if DataCon -> Int
dataConTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
then JStgExpr -> JStgStat -> JStgStat -> JStgStat
IfStat JStgExpr
i JStgStat
s1 JStgStat
s2
else JStgExpr -> JStgStat -> JStgStat -> JStgStat
IfStat JStgExpr
i JStgStat
s2 JStgStat
s1
[StackSlot] -> G ()
setSlots []
(JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat
s, ExprResult
r)
(ExprResult, [Branch (Maybe JStgExpr)])
_ -> String -> G (JStgStat, ExprResult)
forall a. HasCallStack => String -> a
error String
"genAlts: invalid branches for Bool"
AlgAlt TyCon
_tc -> do
ei <- Id -> StateT GenState IO JStgExpr
varForId Id
e
(r, brs) <- normalizeBranches ctx <$>
mapM (isolateSlots . mkAlgBranch ctx e) alts
setSlots []
return (mkSwitch (ei .^ "f" .^ "a") brs, r)
AltType
_ -> String -> SDoc -> G (JStgStat, ExprResult)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genAlts: unhandled case variant" ((AltType, Int) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (AltType
at, [GenStgAlt 'CodeGen] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenStgAlt 'CodeGen]
alts))
ver <- verifyMatchRep e at
pure (ver <> st, er)
verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStgStat
verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStgStat
verifyMatchRep Id
x AltType
alt = do
runtime_assert <- StgToJSConfig -> Bool
csRuntimeAssert (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> StateT GenState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
if not runtime_assert
then pure mempty
else case alt of
AlgAlt TyCon
tc -> do
ix <- Id -> G [JStgExpr]
varsForId Id
x
pure $ ApplStat (global "h$verify_match_alg") (ValExpr (JStr (mkFastString (renderWithContext defaultSDocContext (ppr tc)))):ix)
AltType
_ -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty
data Branch a = Branch
{ forall a. Branch a -> a
branch_expr :: a
, forall a. Branch a -> JStgStat
branch_stat :: JStgStat
, forall a. Branch a -> ExprResult
branch_result :: ExprResult
}
deriving (Branch a -> Branch a -> Bool
(Branch a -> Branch a -> Bool)
-> (Branch a -> Branch a -> Bool) -> Eq (Branch a)
forall a. Eq a => Branch a -> Branch a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Branch a -> Branch a -> Bool
== :: Branch a -> Branch a -> Bool
$c/= :: forall a. Eq a => Branch a -> Branch a -> Bool
/= :: Branch a -> Branch a -> Bool
Eq,(forall a b. (a -> b) -> Branch a -> Branch b)
-> (forall a b. a -> Branch b -> Branch a) -> Functor Branch
forall a b. a -> Branch b -> Branch a
forall a b. (a -> b) -> Branch a -> Branch b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Branch a -> Branch b
fmap :: forall a b. (a -> b) -> Branch a -> Branch b
$c<$ :: forall a b. a -> Branch b -> Branch a
<$ :: forall a b. a -> Branch b -> Branch a
Functor)
normalizeBranches :: ExprCtx
-> [Branch a]
-> (ExprResult, [Branch a])
normalizeBranches :: forall a. ExprCtx -> [Branch a] -> (ExprResult, [Branch a])
normalizeBranches ExprCtx
ctx [Branch a]
brs
| (ExprResult -> Bool) -> [ExprResult] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ExprResult -> ExprResult -> Bool
forall a. Eq a => a -> a -> Bool
==ExprResult
ExprCont) ((Branch a -> ExprResult) -> [Branch a] -> [ExprResult]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Branch a -> ExprResult
forall a. Branch a -> ExprResult
branch_result [Branch a]
brs) =
(ExprResult
ExprCont, [Branch a]
brs)
| [ExprResult] -> ExprResult
HasDebugCallStack => [ExprResult] -> ExprResult
branchResult ((Branch a -> ExprResult) -> [Branch a] -> [ExprResult]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Branch a -> ExprResult
forall a. Branch a -> ExprResult
branch_result [Branch a]
brs) ExprResult -> ExprResult -> Bool
forall a. Eq a => a -> a -> Bool
== ExprResult
ExprCont =
(ExprResult
ExprCont, (Branch a -> Branch a) -> [Branch a] -> [Branch a]
forall a b. (a -> b) -> [a] -> [b]
map Branch a -> Branch a
mkCont [Branch a]
brs)
| Bool
otherwise =
(ExprResult
ExprInline, [Branch a]
brs)
where
mkCont :: Branch a -> Branch a
mkCont Branch a
b = case Branch a -> ExprResult
forall a. Branch a -> ExprResult
branch_result Branch a
b of
ExprResult
ExprInline -> Branch a
b { branch_stat = branch_stat b <> assignAll jsRegsFromR1
(concatMap typex_expr $ ctxTarget ctx)
, branch_result = ExprCont
}
ExprResult
_ -> Branch a
b
loadUbxTup :: [JStgExpr] -> [Id] -> Int -> G JStgStat
loadUbxTup :: [JStgExpr] -> [Id] -> Int -> G JStgStat
loadUbxTup [JStgExpr]
es [Id]
bs Int
_n = do
bs' <- (Id -> G [Ident]) -> [Id] -> G [Ident]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM Id -> G [Ident]
identsForId [Id]
bs
return $ declAssignAll bs' es
mkSw :: [JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat
mkSw :: [JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat
mkSw [JStgExpr
e] [Branch (Maybe [JStgExpr])]
cases = JStgExpr -> [Branch (Maybe JStgExpr)] -> JStgStat
mkSwitch JStgExpr
e ((Branch (Maybe [JStgExpr]) -> Branch (Maybe JStgExpr))
-> [Branch (Maybe [JStgExpr])] -> [Branch (Maybe JStgExpr)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe [JStgExpr] -> Maybe JStgExpr)
-> Branch (Maybe [JStgExpr]) -> Branch (Maybe JStgExpr)
forall a b. (a -> b) -> Branch a -> Branch b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([JStgExpr] -> JStgExpr) -> Maybe [JStgExpr] -> Maybe JStgExpr
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [JStgExpr] -> JStgExpr
forall a. HasCallStack => [a] -> a
head)) [Branch (Maybe [JStgExpr])]
cases)
mkSw [JStgExpr]
es [Branch (Maybe [JStgExpr])]
cases = [JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat
mkIfElse [JStgExpr]
es [Branch (Maybe [JStgExpr])]
cases
mkSwitch :: JStgExpr -> [Branch (Maybe JStgExpr)] -> JStgStat
mkSwitch :: JStgExpr -> [Branch (Maybe JStgExpr)] -> JStgStat
mkSwitch JStgExpr
e [Branch (Maybe JStgExpr)]
cases
| [Branch (Just JStgExpr
c1) JStgStat
s1 ExprResult
_] <- [Branch (Maybe JStgExpr)]
n
, [Branch Maybe JStgExpr
_ JStgStat
s2 ExprResult
_] <- [Branch (Maybe JStgExpr)]
d
= JStgExpr -> JStgStat -> JStgStat -> JStgStat
IfStat (Op -> JStgExpr -> JStgExpr -> JStgExpr
InfixExpr Op
StrictEqOp JStgExpr
e JStgExpr
c1) JStgStat
s1 JStgStat
s2
| [Branch (Just JStgExpr
c1) JStgStat
s1 ExprResult
_, Branch Maybe JStgExpr
_ JStgStat
s2 ExprResult
_] <- [Branch (Maybe JStgExpr)]
n
, [Branch (Maybe JStgExpr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Branch (Maybe JStgExpr)]
d
= JStgExpr -> JStgStat -> JStgStat -> JStgStat
IfStat (Op -> JStgExpr -> JStgExpr -> JStgExpr
InfixExpr Op
StrictEqOp JStgExpr
e JStgExpr
c1) JStgStat
s1 JStgStat
s2
| [Branch (Maybe JStgExpr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Branch (Maybe JStgExpr)]
d
= JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
e ((Branch (Maybe JStgExpr) -> (JStgExpr, JStgStat))
-> [Branch (Maybe JStgExpr)] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map Branch (Maybe JStgExpr) -> (JStgExpr, JStgStat)
forall {a}. Branch (Maybe a) -> (a, JStgStat)
addBreak ([Branch (Maybe JStgExpr)] -> [Branch (Maybe JStgExpr)]
forall a. HasCallStack => [a] -> [a]
init [Branch (Maybe JStgExpr)]
n)) (Branch (Maybe JStgExpr) -> JStgStat
forall a. Branch a -> JStgStat
branch_stat ([Branch (Maybe JStgExpr)] -> Branch (Maybe JStgExpr)
forall a. HasCallStack => [a] -> a
last [Branch (Maybe JStgExpr)]
n))
| [Branch Maybe JStgExpr
_ JStgStat
d0 ExprResult
_] <- [Branch (Maybe JStgExpr)]
d
= JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
SwitchStat JStgExpr
e ((Branch (Maybe JStgExpr) -> (JStgExpr, JStgStat))
-> [Branch (Maybe JStgExpr)] -> [(JStgExpr, JStgStat)]
forall a b. (a -> b) -> [a] -> [b]
map Branch (Maybe JStgExpr) -> (JStgExpr, JStgStat)
forall {a}. Branch (Maybe a) -> (a, JStgStat)
addBreak [Branch (Maybe JStgExpr)]
n) JStgStat
d0
| Bool
otherwise = String -> JStgStat
forall a. HasCallStack => String -> a
panic String
"mkSwitch: multiple default cases"
where
addBreak :: Branch (Maybe a) -> (a, JStgStat)
addBreak (Branch (Just a
c) JStgStat
s ExprResult
_) = (a
c, [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [JStgStat
s, Maybe LexicalFastString -> JStgStat
BreakStat Maybe LexicalFastString
forall a. Maybe a
Nothing])
addBreak Branch (Maybe a)
_ = String -> (a, JStgStat)
forall a. HasCallStack => String -> a
panic String
"mkSwitch: addBreak"
([Branch (Maybe JStgExpr)]
n,[Branch (Maybe JStgExpr)]
d) = (Branch (Maybe JStgExpr) -> Bool)
-> [Branch (Maybe JStgExpr)]
-> ([Branch (Maybe JStgExpr)], [Branch (Maybe JStgExpr)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Maybe JStgExpr -> Bool
forall a. Maybe a -> Bool
isJust (Maybe JStgExpr -> Bool)
-> (Branch (Maybe JStgExpr) -> Maybe JStgExpr)
-> Branch (Maybe JStgExpr)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch (Maybe JStgExpr) -> Maybe JStgExpr
forall a. Branch a -> a
branch_expr) [Branch (Maybe JStgExpr)]
cases
mkIfElse :: [JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat
mkIfElse :: [JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat
mkIfElse [JStgExpr]
e [Branch (Maybe [JStgExpr])]
s = [Branch (Maybe [JStgExpr])] -> JStgStat
go ([Branch (Maybe [JStgExpr])] -> [Branch (Maybe [JStgExpr])]
forall a. [a] -> [a]
L.reverse [Branch (Maybe [JStgExpr])]
s)
where
go :: [Branch (Maybe [JStgExpr])] -> JStgStat
go = \case
[Branch Maybe [JStgExpr]
_ JStgStat
s ExprResult
_] -> JStgStat
s
(Branch (Just [JStgExpr]
e0) JStgStat
s ExprResult
_ : [Branch (Maybe [JStgExpr])]
xs) -> JStgExpr -> JStgStat -> JStgStat -> JStgStat
IfStat ([JStgExpr] -> [JStgExpr] -> JStgExpr
mkEq [JStgExpr]
e [JStgExpr]
e0) JStgStat
s ([Branch (Maybe [JStgExpr])] -> JStgStat
go [Branch (Maybe [JStgExpr])]
xs)
[] -> String -> JStgStat
forall a. HasCallStack => String -> a
panic String
"mkIfElse: empty expression list"
[Branch (Maybe [JStgExpr])]
_ -> String -> JStgStat
forall a. HasCallStack => String -> a
panic String
"mkIfElse: multiple DEFAULT cases"
mkEq :: [JStgExpr] -> [JStgExpr] -> JStgExpr
mkEq :: [JStgExpr] -> [JStgExpr] -> JStgExpr
mkEq [JStgExpr]
es1 [JStgExpr]
es2
| [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
es1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
es2 = (JStgExpr -> JStgExpr -> JStgExpr) -> [JStgExpr] -> JStgExpr
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (Op -> JStgExpr -> JStgExpr -> JStgExpr
InfixExpr Op
LAndOp) ((JStgExpr -> JStgExpr -> JStgExpr)
-> [JStgExpr] -> [JStgExpr] -> [JStgExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Op -> JStgExpr -> JStgExpr -> JStgExpr
InfixExpr Op
StrictEqOp) [JStgExpr]
es1 [JStgExpr]
es2)
| Bool
otherwise = String -> JStgExpr
forall a. HasCallStack => String -> a
panic String
"mkEq: incompatible expressions"
mkAlgBranch :: ExprCtx
-> Id
-> CgStgAlt
-> G (Branch (Maybe JStgExpr))
mkAlgBranch :: ExprCtx
-> Id
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JStgExpr))
mkAlgBranch ExprCtx
top Id
d GenStgAlt 'CodeGen
alt
| DataAlt DataCon
dc <- GenStgAlt 'CodeGen -> AltCon
forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt 'CodeGen
alt
, DataCon -> Bool
isUnboxableCon DataCon
dc
, [BinderP 'CodeGen
b] <- GenStgAlt 'CodeGen -> [BinderP 'CodeGen]
forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs GenStgAlt 'CodeGen
alt
= do
idd <- Id -> StateT GenState IO JStgExpr
varForId Id
d
fldx <- identsForId b
case fldx of
[Ident
fld] -> do
(ej, er) <- HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
top (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
return (Branch Nothing (mconcat [fld ||= idd, ej]) er)
[Ident]
_ -> String -> StateT GenState IO (Branch (Maybe JStgExpr))
forall a. HasCallStack => String -> a
panic String
"mkAlgBranch: invalid size"
| Bool
otherwise
= do
cc <- AltCon -> G (Maybe JStgExpr)
caseCond (GenStgAlt 'CodeGen -> AltCon
forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt 'CodeGen
alt)
idd <- varForId d
b <- loadParams idd (alt_bndrs alt)
(ej, er) <- genExpr top (alt_rhs alt)
return (Branch cc (b <> ej) er)
mkPrimIfBranch :: ExprCtx
-> [JSRep]
-> CgStgAlt
-> G (Branch (Maybe [JStgExpr]))
mkPrimIfBranch :: ExprCtx
-> [JSRep]
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe [JStgExpr]))
mkPrimIfBranch ExprCtx
top [JSRep]
_vt GenStgAlt 'CodeGen
alt =
(\Maybe [JStgExpr]
ic (JStgStat
ej,ExprResult
er) -> Maybe [JStgExpr]
-> JStgStat -> ExprResult -> Branch (Maybe [JStgExpr])
forall a. a -> JStgStat -> ExprResult -> Branch a
Branch Maybe [JStgExpr]
ic JStgStat
ej ExprResult
er) (Maybe [JStgExpr]
-> (JStgStat, ExprResult) -> Branch (Maybe [JStgExpr]))
-> StateT GenState IO (Maybe [JStgExpr])
-> StateT
GenState IO ((JStgStat, ExprResult) -> Branch (Maybe [JStgExpr]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AltCon -> StateT GenState IO (Maybe [JStgExpr])
ifCond (GenStgAlt 'CodeGen -> AltCon
forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt 'CodeGen
alt) StateT
GenState IO ((JStgStat, ExprResult) -> Branch (Maybe [JStgExpr]))
-> G (JStgStat, ExprResult)
-> StateT GenState IO (Branch (Maybe [JStgExpr]))
forall a b.
StateT GenState IO (a -> b)
-> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HasDebugCallStack =>
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult)
genExpr ExprCtx
top (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
ifCond :: AltCon -> G (Maybe [JStgExpr])
ifCond :: AltCon -> StateT GenState IO (Maybe [JStgExpr])
ifCond = \case
DataAlt DataCon
da -> Maybe [JStgExpr] -> StateT GenState IO (Maybe [JStgExpr])
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [JStgExpr] -> StateT GenState IO (Maybe [JStgExpr]))
-> Maybe [JStgExpr] -> StateT GenState IO (Maybe [JStgExpr])
forall a b. (a -> b) -> a -> b
$ [JStgExpr] -> Maybe [JStgExpr]
forall a. a -> Maybe a
Just [Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (DataCon -> Int
dataConTag DataCon
da)]
LitAlt Literal
l -> [JStgExpr] -> Maybe [JStgExpr]
forall a. a -> Maybe a
Just ([JStgExpr] -> Maybe [JStgExpr])
-> G [JStgExpr] -> StateT GenState IO (Maybe [JStgExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Literal -> G [JStgExpr]
Literal -> G [JStgExpr]
genLit Literal
l
AltCon
DEFAULT -> Maybe [JStgExpr] -> StateT GenState IO (Maybe [JStgExpr])
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [JStgExpr]
forall a. Maybe a
Nothing
caseCond :: AltCon -> G (Maybe JStgExpr)
caseCond :: AltCon -> G (Maybe JStgExpr)
caseCond = \case
AltCon
DEFAULT -> Maybe JStgExpr -> G (Maybe JStgExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JStgExpr
forall a. Maybe a
Nothing
DataAlt DataCon
da -> Maybe JStgExpr -> G (Maybe JStgExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe JStgExpr -> G (Maybe JStgExpr))
-> Maybe JStgExpr -> G (Maybe JStgExpr)
forall a b. (a -> b) -> a -> b
$ JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int -> JStgExpr) -> Int -> JStgExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dataConTag DataCon
da)
LitAlt Literal
l -> HasDebugCallStack => Literal -> G [JStgExpr]
Literal -> G [JStgExpr]
genLit Literal
l G [JStgExpr]
-> ([JStgExpr] -> G (Maybe JStgExpr)) -> G (Maybe JStgExpr)
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[JStgExpr
e] -> Maybe JStgExpr -> G (Maybe JStgExpr)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just JStgExpr
e)
[JStgExpr]
es -> String -> SDoc -> G (Maybe JStgExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"caseCond: expected single-variable literal" ([JExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([JExpr] -> SDoc) -> [JExpr] -> SDoc
forall a b. (a -> b) -> a -> b
$ JStgExpr -> JExpr
jStgExprToJS (JStgExpr -> JExpr) -> [JStgExpr] -> [JExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [JStgExpr]
es)
loadParams :: JStgExpr -> [Id] -> G JStgStat
loadParams :: JStgExpr -> [Id] -> G JStgStat
loadParams JStgExpr
from [Id]
args = do
as <- [[(Ident, Bool)]] -> [(Ident, Bool)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Ident, Bool)]] -> [(Ident, Bool)])
-> StateT GenState IO [[(Ident, Bool)]]
-> StateT GenState IO [(Ident, Bool)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> Bool -> StateT GenState IO [(Ident, Bool)])
-> [Id] -> [Bool] -> StateT GenState IO [[(Ident, Bool)]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Id
a Bool
u -> (Ident -> (Ident, Bool)) -> [Ident] -> [(Ident, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (,Bool
u) ([Ident] -> [(Ident, Bool)])
-> G [Ident] -> StateT GenState IO [(Ident, Bool)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [Ident]
identsForId Id
a) [Id]
args [Bool]
use
case as of
[] -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
forall a. Monoid a => a
mempty
[(Ident
x,Bool
u)] -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ JStgExpr -> Ident -> Bool -> JStgStat
loadIfUsed (JStgExpr
from JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_) Ident
x Bool
u
[(Ident
x1,Bool
u1),(Ident
x2,Bool
u2)] -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
[ JStgExpr -> Ident -> Bool -> JStgStat
loadIfUsed (JStgExpr
from JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_) Ident
x1 Bool
u1
, JStgExpr -> Ident -> Bool -> JStgStat
loadIfUsed (JStgExpr
from JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField2_) Ident
x2 Bool
u2
]
((Ident
x,Bool
u):[(Ident, Bool)]
xs) -> do d <- StateT GenState IO Ident
freshIdent
return $ mconcat
[ loadIfUsed (from .^ closureField1_) x u
, mconcat [ d ||= from .^ closureField2_
, loadConVarsIfUsed (Var d) xs
]
]
where
use :: [Bool]
use = Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True
loadIfUsed :: JStgExpr -> Ident -> Bool -> JStgStat
loadIfUsed JStgExpr
fr Ident
tgt Bool
True = Ident
tgt Ident -> JStgExpr -> JStgStat
||= JStgExpr
fr
loadIfUsed JStgExpr
_ Ident
_ Bool
_ = JStgStat
forall a. Monoid a => a
mempty
loadConVarsIfUsed :: JStgExpr -> [(Ident, Bool)] -> JStgStat
loadConVarsIfUsed JStgExpr
fr [(Ident, Bool)]
cs = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$ ((Ident, Bool) -> Int -> JStgStat)
-> [(Ident, Bool)] -> [Int] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Ident, Bool) -> Int -> JStgStat
f [(Ident, Bool)]
cs [(Int
1::Int)..]
where f :: (Ident, Bool) -> Int -> JStgStat
f (Ident
x,Bool
u) Int
n = JStgExpr -> Ident -> Bool -> JStgStat
loadIfUsed (JStgExpr -> Ident -> JStgExpr
SelExpr JStgExpr
fr (FastString -> Ident
name (Int -> FastString
dataFieldName Int
n))) Ident
x Bool
u
branchResult :: HasDebugCallStack => [ExprResult] -> ExprResult
branchResult :: HasDebugCallStack => [ExprResult] -> ExprResult
branchResult = \case
[] -> String -> ExprResult
forall a. HasCallStack => String -> a
panic String
"branchResult: empty list"
[ExprResult
e] -> ExprResult
e
(ExprResult
ExprCont:[ExprResult]
_) -> ExprResult
ExprCont
(ExprResult
_:[ExprResult]
es)
| ExprResult -> [ExprResult] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ExprResult
ExprCont [ExprResult]
es -> ExprResult
ExprCont
| Bool
otherwise -> ExprResult
ExprInline
pushRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> JStgExpr -> G JStgStat
pushRetArgs :: HasDebugCallStack => [(Id, Int, Bool)] -> JStgExpr -> G JStgStat
pushRetArgs [(Id, Int, Bool)]
free JStgExpr
fun = do
rs <- ((Id, Int, Bool) -> StateT GenState IO (JStgExpr, Bool))
-> [(Id, Int, Bool)] -> StateT GenState IO [(JStgExpr, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Id
i,Int
n,Bool
b) -> (\[JStgExpr]
es->([JStgExpr]
es[JStgExpr] -> Int -> JStgExpr
forall a. HasCallStack => [a] -> Int -> a
!!(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1),Bool
b)) ([JStgExpr] -> (JStgExpr, Bool))
-> G [JStgExpr] -> StateT GenState IO (JStgExpr, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Id -> G [JStgExpr]
Id -> G [JStgExpr]
genIdArg Id
i) [(Id, Int, Bool)]
free
pushOptimized (rs++[(fun,False)])
loadRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> G JStgStat
loadRetArgs :: HasDebugCallStack => [(Id, Int, Bool)] -> G JStgStat
loadRetArgs [(Id, Int, Bool)]
free = do
ids <- ((Id, Int, Bool) -> StateT GenState IO (Ident, StackSlot))
-> [(Id, Int, Bool)] -> StateT GenState IO [(Ident, StackSlot)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Id
i,Int
n,Bool
_b) -> ([(Ident, StackSlot)] -> Int -> (Ident, StackSlot)
forall a. HasCallStack => [a] -> Int -> a
!! (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) ([(Ident, StackSlot)] -> (Ident, StackSlot))
-> StateT GenState IO [(Ident, StackSlot)]
-> StateT GenState IO (Ident, StackSlot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Id -> StateT GenState IO [(Ident, StackSlot)]
Id -> StateT GenState IO [(Ident, StackSlot)]
genIdStackArgI Id
i) [(Id, Int, Bool)]
free
popSkipI 1 ids
allVars :: JStgExpr -> [Ident]
allVars :: JStgExpr -> [Ident]
allVars (ValExpr JVal
v) = case JVal
v of
(JVar Ident
i) -> [Ident
i]
(JList [JStgExpr]
xs) -> (JStgExpr -> [Ident]) -> [JStgExpr] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap JStgExpr -> [Ident]
allVars [JStgExpr]
xs
(JHash UniqMap FastString JStgExpr
xs) -> ((FastString, JStgExpr) -> [Ident])
-> [(FastString, JStgExpr)] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (JStgExpr -> [Ident]
allVars (JStgExpr -> [Ident])
-> ((FastString, JStgExpr) -> JStgExpr)
-> (FastString, JStgExpr)
-> [Ident]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FastString, JStgExpr) -> JStgExpr
forall a b. (a, b) -> b
snd) (UniqMap FastString JStgExpr -> [(FastString, JStgExpr)]
forall k a. UniqMap k a -> [(k, a)]
UM.nonDetUniqMapToList UniqMap FastString JStgExpr
xs)
(JInt {}) -> []
(JDouble {}) -> []
(JStr {}) -> []
(JRegEx {}) -> []
(JBool {}) -> []
(JFunc [Ident]
is JStgStat
_s) -> [Ident]
is
allVars (InfixExpr Op
_op JStgExpr
lh JStgExpr
rh) = JStgExpr -> [Ident]
allVars JStgExpr
lh [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ JStgExpr -> [Ident]
allVars JStgExpr
rh
allVars (ApplExpr JStgExpr
f [JStgExpr]
xs) = JStgExpr -> [Ident]
allVars JStgExpr
f [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ (JStgExpr -> [Ident]) -> [JStgExpr] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap JStgExpr -> [Ident]
allVars [JStgExpr]
xs
allVars (IfExpr JStgExpr
c JStgExpr
t JStgExpr
e) = JStgExpr -> [Ident]
allVars JStgExpr
c [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ JStgExpr -> [Ident]
allVars JStgExpr
t [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ JStgExpr -> [Ident]
allVars JStgExpr
e
allVars (UOpExpr UOp
_op JStgExpr
x) = JStgExpr -> [Ident]
allVars JStgExpr
x
allVars (SelExpr JStgExpr
e Ident
_) = JStgExpr -> [Ident]
allVars JStgExpr
e
allVars (IdxExpr JStgExpr
e JStgExpr
i) = JStgExpr -> [Ident]
allVars JStgExpr
e [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ JStgExpr -> [Ident]
allVars JStgExpr
i
allocDynAll :: Bool -> Maybe JStgStat -> [(Ident,JStgExpr,[JStgExpr],CostCentreStack)] -> G JStgStat
allocDynAll :: Bool
-> Maybe JStgStat
-> [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
-> G JStgStat
allocDynAll Bool
haveDecl Maybe JStgStat
middle [(Ident
to,JStgExpr
entry,[JStgExpr]
free,CostCentreStack
cc)]
| Maybe JStgStat -> Bool
forall a. Maybe a -> Bool
isNothing Maybe JStgStat
middle Bool -> Bool -> Bool
&& Ident
to Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (JStgExpr -> [Ident]) -> [JStgExpr] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap JStgExpr -> [Ident]
allVars [JStgExpr]
free = do
ccs <- CostCentreStack -> G (Maybe JStgExpr)
ccsVarJ CostCentreStack
cc
s <- getSettings
return $ allocDynamic s (not haveDecl) to entry free ccs
allocDynAll Bool
haveDecl Maybe JStgStat
middle [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
cls = do
settings <- StateT GenState IO StgToJSConfig
getSettings
let
middle' :: JStgStat
middle' = JStgStat -> Maybe JStgStat -> JStgStat
forall a. a -> Maybe a -> a
fromMaybe JStgStat
forall a. Monoid a => a
mempty Maybe JStgStat
middle
decl_maybe Ident
i JStgExpr
e
| Bool
haveDecl = Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
i JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
e
| Bool
otherwise = Ident
i Ident -> JStgExpr -> JStgStat
||= JStgExpr
e
makeObjs :: G JStgStat
makeObjs =
([JStgStat] -> JStgStat)
-> StateT GenState IO [JStgStat] -> G JStgStat
forall a b.
(a -> b) -> StateT GenState IO a -> StateT GenState IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat (StateT GenState IO [JStgStat] -> G JStgStat)
-> StateT GenState IO [JStgStat] -> G JStgStat
forall a b. (a -> b) -> a -> b
$ [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
-> ((Ident, JStgExpr, [JStgExpr], CostCentreStack) -> G JStgStat)
-> StateT GenState IO [JStgStat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
cls (((Ident, JStgExpr, [JStgExpr], CostCentreStack) -> G JStgStat)
-> StateT GenState IO [JStgStat])
-> ((Ident, JStgExpr, [JStgExpr], CostCentreStack) -> G JStgStat)
-> StateT GenState IO [JStgStat]
forall a b. (a -> b) -> a -> b
$ \(Ident
i,JStgExpr
f,[JStgExpr]
_,CostCentreStack
cc) -> do
ccs <- Maybe Ident -> [Ident]
forall a. Maybe a -> [a]
maybeToList (Maybe Ident -> [Ident])
-> StateT GenState IO (Maybe Ident) -> G [Ident]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CostCentreStack -> StateT GenState IO (Maybe Ident)
costCentreStackLbl CostCentreStack
cc
pure $ mconcat
[ decl_maybe i $ if csInlineAlloc settings
then ValExpr (jhFromList $ [ (closureInfo_ , f)
, (closureField1_, null_)
, (closureField2_, null_)
, (closureMeta_ , zero_)
]
++ fmap (\Ident
cid -> (FastString
"cc", JVal -> JStgExpr
ValExpr (Ident -> JVal
JVar Ident
cid))) ccs)
else ApplExpr hdC (f : fmap (ValExpr . JVar) ccs)
]
fillObjs :: [JStgStat]
fillObjs = ((Ident, JStgExpr, [JStgExpr], CostCentreStack) -> JStgStat)
-> [(Ident, JStgExpr, [JStgExpr], CostCentreStack)] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, JStgExpr, [JStgExpr], CostCentreStack) -> JStgStat
fillObj [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
cls
fillObj (Ident
ident,JStgExpr
_,[JStgExpr]
es,CostCentreStack
_) =
let i :: JStgExpr
i = Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
ident
in case [JStgExpr]
es of
[] -> JStgStat
forall a. Monoid a => a
mempty
[JStgExpr
ex] -> JStgExpr -> JStgExpr
closureField1 JStgExpr
i JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
ex
[JStgExpr
e1,JStgExpr
e2] -> [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
[ JStgExpr -> JStgExpr
closureField1 JStgExpr
i JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
e1
, JStgExpr -> JStgExpr
closureField2 JStgExpr
i JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
e2
]
(JStgExpr
ex:[JStgExpr]
es)
| StgToJSConfig -> Bool
csInlineAlloc StgToJSConfig
settings Bool -> Bool -> Bool
|| [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
es Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
24
-> [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [ JStgExpr -> JStgExpr
closureField1 JStgExpr
i JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
ex
, JStgExpr -> JStgExpr
closureField2 JStgExpr
i JStgExpr -> JStgExpr -> JStgStat
|= JVal -> JStgExpr
ValExpr ([(FastString, JStgExpr)] -> JVal
jhFromList ([FastString] -> [JStgExpr] -> [(FastString, JStgExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> FastString) -> [Int] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map Int -> FastString
dataFieldName [Int
1..]) [JStgExpr]
es))
]
| Bool
otherwise
-> [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [ JStgExpr -> JStgExpr
closureField1 JStgExpr
i JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
ex
, JStgExpr -> JStgExpr
closureField2 JStgExpr
i JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr (Int -> JStgExpr
allocData ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
es)) [JStgExpr]
es
]
checkObjs :: [JStgStat]
checkObjs | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
settings =
((Ident, JStgExpr, [JStgExpr], CostCentreStack) -> JStgStat)
-> [(Ident, JStgExpr, [JStgExpr], CostCentreStack)] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
map (\(Ident
i,JStgExpr
_,[JStgExpr]
_,CostCentreStack
_) -> JStgExpr -> [JStgExpr] -> JStgStat
ApplStat JStgExpr
hdCheckObj [Ident -> JStgExpr
Var Ident
i]) [(Ident, JStgExpr, [JStgExpr], CostCentreStack)]
cls
| Bool
otherwise = [JStgStat]
forall a. Monoid a => a
mempty
objs <- makeObjs
return $ mconcat [objs, middle', mconcat fillObjs, mconcat checkObjs]
genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStgStat, ExprResult)
genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStgStat, ExprResult)
genPrimOp ExprCtx
ctx PrimOp
op [StgArg]
args Type
t = do
as <- (StgArg -> G [JStgExpr]) -> [StgArg] -> G [JStgExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg [StgArg]
args
prof <- csProf <$> getSettings
bound <- csBoundsCheck <$> getSettings
let prim_gen = FastString -> JSM PrimRes -> JSM PrimRes
forall a. FastString -> JSM a -> JSM a
withTag FastString
"h$PRM" (JSM PrimRes -> JSM PrimRes) -> JSM PrimRes -> JSM PrimRes
forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Type
-> PrimOp
-> [JStgExpr]
-> [JStgExpr]
-> JSM PrimRes
genPrim Bool
prof Bool
bound Type
t PrimOp
op ((TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr ([TypedExpr] -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [JStgExpr]
as
jsm <- liftIO initJSM
return $ case runJSM jsm prim_gen of
PrimInline JStgStat
s -> (JStgStat
s, ExprResult
ExprInline)
PRPrimCall JStgStat
s -> (JStgStat
s, ExprResult
ExprCont)