{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
module GHC.StgToJS.Expr
( genExpr
, genEntryType
, loadLiveFun
, genStaticRefsRhs
, genStaticRefs
, genBody
)
where
import GHC.Prelude
import GHC.JS.Syntax
import GHC.JS.Make
import GHC.StgToJS.Apply
import GHC.StgToJS.Arg
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.FFI
import GHC.StgToJS.Heap
import GHC.StgToJS.Monad
import GHC.StgToJS.DataCon
import GHC.StgToJS.Types
import GHC.StgToJS.Literal
import GHC.StgToJS.Prim
import GHC.StgToJS.Profiling
import GHC.StgToJS.Regs
import GHC.StgToJS.StgUtils
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Utils
import GHC.StgToJS.Stack
import GHC.StgToJS.Ids
import GHC.Types.Basic
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.Stg.Syntax
import GHC.Stg.Utils
import GHC.Builtin.PrimOps
import GHC.Core
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.Panic.Plain
import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)
import qualified Control.Monad.Trans.State.Strict as State
import GHC.Data.FastString
import qualified GHC.Data.List.SetOps as ListSetOps
import Data.Monoid
import Data.Maybe
import Data.Function
import Data.Either
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 (JStat, ExprResult)
genExpr :: (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
stg = case CgStgExpr
stg of
StgApp Id
f [StgArg]
args -> (() :: Constraint) =>
ExprCtx -> Id -> [StgArg] -> G (JStat, ExprResult)
ExprCtx -> Id -> [StgArg] -> G (JStat, ExprResult)
genApp ExprCtx
ctx Id
f [StgArg]
args
StgLit Literal
l -> do
[JExpr]
ls <- (() :: Constraint) => Literal -> G [JExpr]
Literal -> G [JExpr]
genLit Literal
l
let r :: JStat
r = (() :: Constraint) => ExprCtx -> [JExpr] -> JStat
ExprCtx -> [JExpr] -> JStat
assignToExprCtx ExprCtx
ctx [JExpr]
ls
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStat
r,Maybe [JExpr] -> ExprResult
ExprInline Maybe [JExpr]
forall a. Maybe a
Nothing)
StgConApp DataCon
con ConstructorNumber
_n [StgArg]
args [Type]
_ -> do
[JExpr]
as <- (StgArg -> G [JExpr]) -> [StgArg] -> G [JExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (() :: Constraint) => StgArg -> G [JExpr]
StgArg -> G [JExpr]
genArg [StgArg]
args
JStat
c <- ExprCtx -> DataCon -> [JExpr] -> G JStat
genCon ExprCtx
ctx DataCon
con [JExpr]
as
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
c, Maybe [JExpr] -> ExprResult
ExprInline ([JExpr] -> Maybe [JExpr]
forall a. a -> Maybe a
Just [JExpr]
as))
StgOpApp (StgFCallOp ForeignCall
f Type
_) [StgArg]
args Type
t
-> (() :: Constraint) =>
ExprCtx
-> ForeignCall
-> Type
-> [JExpr]
-> [StgArg]
-> G (JStat, ExprResult)
ExprCtx
-> ForeignCall
-> Type
-> [JExpr]
-> [StgArg]
-> G (JStat, ExprResult)
genForeignCall ExprCtx
ctx ForeignCall
f Type
t ((TypedExpr -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr ([TypedExpr] -> [JExpr]) -> [TypedExpr] -> [JExpr]
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 (JStat, ExprResult)
genPrimOp ExprCtx
ctx PrimOp
op [StgArg]
args Type
t
StgOpApp (StgPrimCallOp PrimCall
c) [StgArg]
args Type
t
-> ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStat, ExprResult)
genPrimCall ExprCtx
ctx PrimCall
c [StgArg]
args Type
t
StgCase CgStgExpr
e BinderP 'CodeGen
b AltType
at [GenStgAlt 'CodeGen]
alts
-> (() :: Constraint) =>
ExprCtx
-> Id
-> CgStgExpr
-> AltType
-> [GenStgAlt 'CodeGen]
-> LiveVars
-> G (JStat, ExprResult)
ExprCtx
-> Id
-> CgStgExpr
-> AltType
-> [GenStgAlt 'CodeGen]
-> LiveVars
-> G (JStat, 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
(JStat
b',ExprCtx
ctx') <- (() :: Constraint) =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStat, ExprCtx)
ExprCtx -> GenStgBinding 'CodeGen -> G (JStat, ExprCtx)
genBind ExprCtx
ctx GenStgBinding 'CodeGen
b
(JStat
s,ExprResult
r) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
b' JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
s, ExprResult
r)
StgLetNoEscape XLetNoEscape 'CodeGen
_ GenStgBinding 'CodeGen
b CgStgExpr
e -> do
(JStat
b', ExprCtx
ctx') <- (() :: Constraint) =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStat, ExprCtx)
ExprCtx -> GenStgBinding 'CodeGen -> G (JStat, ExprCtx)
genBindLne ExprCtx
ctx GenStgBinding 'CodeGen
b
(JStat
s, ExprResult
r) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
b' JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
s, ExprResult
r)
StgTick (ProfNote CostCentre
cc Bool
count Bool
scope) CgStgExpr
e -> do
JStat
setSCCstats <- G JStat -> G JStat
forall m. Monoid m => G m -> G m
ifProfilingM (G JStat -> G JStat) -> G JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ CostCentre -> Bool -> Bool -> G JStat
setCC CostCentre
cc Bool
count Bool
scope
(JStat
stats, ExprResult
result) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
e
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
setSCCstats JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
stats, ExprResult
result)
StgTick (SourceNote RealSrcSpan
span String
_sname) CgStgExpr
e
-> (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr (RealSrcSpan -> ExprCtx -> ExprCtx
ctxSetSrcSpan RealSrcSpan
span ExprCtx
ctx) CgStgExpr
e
StgTick GenTickish 'TickishPassStg
_m CgStgExpr
e
-> (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
e
genBind :: HasDebugCallStack
=> ExprCtx
-> CgStgBinding
-> G (JStat, ExprCtx)
genBind :: (() :: Constraint) =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStat, ExprCtx)
genBind ExprCtx
ctx GenStgBinding 'CodeGen
bndr =
case GenStgBinding 'CodeGen
bndr of
StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
r -> do
JStat
j <- Id -> GenStgRhs 'CodeGen -> G (Maybe JStat)
assign Id
BinderP 'CodeGen
b GenStgRhs 'CodeGen
r G (Maybe JStat) -> (Maybe JStat -> G JStat) -> G JStat
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 JStat
ja -> JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStat
ja
Maybe JStat
Nothing -> Maybe JStat -> [(Id, GenStgRhs 'CodeGen)] -> G JStat
allocCls Maybe JStat
forall a. Maybe a
Nothing [(Id
BinderP 'CodeGen
b,GenStgRhs 'CodeGen
r)]
(JStat, ExprCtx) -> G (JStat, ExprCtx)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
j, ExprCtx -> [(Id, GenStgRhs 'CodeGen)] -> ExprCtx
forall {pass :: StgPass}.
ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs ExprCtx
ctx [(Id
BinderP 'CodeGen
b,GenStgRhs 'CodeGen
r)])
StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs -> do
[Maybe JStat]
jas <- ((Id, GenStgRhs 'CodeGen) -> G (Maybe JStat))
-> [(Id, GenStgRhs 'CodeGen)] -> StateT GenState IO [Maybe JStat]
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 JStat))
-> (Id, GenStgRhs 'CodeGen) -> G (Maybe JStat)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> GenStgRhs 'CodeGen -> G (Maybe JStat)
assign) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
let m :: Maybe JStat
m = if [Maybe JStat] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe JStat]
jas then Maybe JStat
forall a. Maybe a
Nothing else JStat -> Maybe JStat
forall a. a -> Maybe a
Just ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> [JStat] -> JStat
forall a b. (a -> b) -> a -> b
$ [Maybe JStat] -> [JStat]
forall a. [Maybe a] -> [a]
catMaybes [Maybe JStat]
jas)
JStat
j <- Maybe JStat -> [(Id, GenStgRhs 'CodeGen)] -> G JStat
allocCls Maybe JStat
m ([(Id, GenStgRhs 'CodeGen)] -> G JStat)
-> ([(Maybe JStat, (Id, GenStgRhs 'CodeGen))]
-> [(Id, GenStgRhs 'CodeGen)])
-> [(Maybe JStat, (Id, GenStgRhs 'CodeGen))]
-> G JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe JStat, (Id, GenStgRhs 'CodeGen))
-> (Id, GenStgRhs 'CodeGen))
-> [(Maybe JStat, (Id, GenStgRhs 'CodeGen))]
-> [(Id, GenStgRhs 'CodeGen)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe JStat, (Id, GenStgRhs 'CodeGen)) -> (Id, GenStgRhs 'CodeGen)
forall a b. (a, b) -> b
snd ([(Maybe JStat, (Id, GenStgRhs 'CodeGen))]
-> [(Id, GenStgRhs 'CodeGen)])
-> ([(Maybe JStat, (Id, GenStgRhs 'CodeGen))]
-> [(Maybe JStat, (Id, GenStgRhs 'CodeGen))])
-> [(Maybe JStat, (Id, GenStgRhs 'CodeGen))]
-> [(Id, GenStgRhs 'CodeGen)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe JStat, (Id, GenStgRhs 'CodeGen)) -> Bool)
-> [(Maybe JStat, (Id, GenStgRhs 'CodeGen))]
-> [(Maybe JStat, (Id, GenStgRhs 'CodeGen))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe JStat -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe JStat -> Bool)
-> ((Maybe JStat, (Id, GenStgRhs 'CodeGen)) -> Maybe JStat)
-> (Maybe JStat, (Id, GenStgRhs 'CodeGen))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe JStat, (Id, GenStgRhs 'CodeGen)) -> Maybe JStat
forall a b. (a, b) -> a
fst) ([(Maybe JStat, (Id, GenStgRhs 'CodeGen))] -> G JStat)
-> [(Maybe JStat, (Id, GenStgRhs 'CodeGen))] -> G JStat
forall a b. (a -> b) -> a -> b
$ [Maybe JStat]
-> [(Id, GenStgRhs 'CodeGen)]
-> [(Maybe JStat, (Id, GenStgRhs 'CodeGen))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe JStat]
jas [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
(JStat, ExprCtx) -> G (JStat, ExprCtx)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
j, ExprCtx -> [(Id, GenStgRhs 'CodeGen)] -> ExprCtx
forall {pass :: StgPass}.
ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs ExprCtx
ctx [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs)
where
ctx' :: ExprCtx
ctx' = ExprCtx -> ExprCtx
ctxClearLneFrame ExprCtx
ctx
assign :: Id -> CgStgRhs -> G (Maybe JStat)
assign :: Id -> GenStgRhs 'CodeGen -> G (Maybe JStat)
assign Id
b (StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ccs UpdateFlag
_upd [] CgStgExpr
expr)
| 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
[Ident]
tgts <- Id -> G [Ident]
identsForId Id
b
[JExpr]
the_fvjs <- Id -> G [JExpr]
varsForId Id
the_fv
case ([Ident]
tgts, [JExpr]
the_fvjs) of
([Ident
tgt], [JExpr
the_fvj]) -> Maybe JStat -> G (Maybe JStat)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe JStat -> G (Maybe JStat)) -> Maybe JStat -> G (Maybe JStat)
forall a b. (a -> b) -> a -> b
$ JStat -> Maybe JStat
forall a. a -> Maybe a
Just
(Ident
tgt Ident -> JExpr -> JStat
||= JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var (FastString
"h$c_sel_" FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> String -> FastString
mkFastString String
sel_tag)) [JExpr
the_fvj])
([Ident], [JExpr])
_ -> String -> G (Maybe JStat)
forall a. HasCallStack => String -> a
panic String
"genBind.assign: invalid size"
assign Id
b (StgRhsClosure XRhsClosure 'CodeGen
_ext CostCentreStack
_ccs UpdateFlag
_upd [] CgStgExpr
expr)
| (UniqSet Id, Bool) -> Bool
forall a b. (a, b) -> b
snd (UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr (ExprCtx -> UniqSet Id
ctxEvaluatedIds ExprCtx
ctx) CgStgExpr
expr) = do
JStat
d <- Id -> G JStat
declVarsForId Id
b
[JExpr]
tgt <- Id -> G [JExpr]
varsForId Id
b
let ctx' :: ExprCtx
ctx' = ExprCtx
ctx { ctxTarget = assocIdExprs b tgt }
(JStat
j, ExprResult
_) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
expr
Maybe JStat -> G (Maybe JStat)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> Maybe JStat
forall a. a -> Maybe a
Just (JStat
d JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
j))
assign Id
_b StgRhsCon{} = Maybe JStat -> G (Maybe JStat)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JStat
forall a. Maybe a
Nothing
assign Id
b GenStgRhs 'CodeGen
r = (() :: Constraint) => ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
genEntry ExprCtx
ctx' Id
b GenStgRhs 'CodeGen
r G () -> G (Maybe JStat) -> G (Maybe JStat)
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 JStat -> G (Maybe JStat)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JStat
forall a. Maybe a
Nothing
addEvalRhs :: ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs ExprCtx
c [] = ExprCtx
c
addEvalRhs ExprCtx
c ((Id
b,GenStgRhs pass
r):[(Id, GenStgRhs pass)]
xs)
| StgRhsCon{} <- GenStgRhs pass
r = ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs (Id -> ExprCtx -> ExprCtx
ctxAssertEvaluated Id
b ExprCtx
c) [(Id, GenStgRhs pass)]
xs
| (StgRhsClosure XRhsClosure pass
_ CostCentreStack
_ UpdateFlag
ReEntrant [BinderP pass]
_ GenStgExpr pass
_) <- GenStgRhs pass
r = ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs (Id -> ExprCtx -> ExprCtx
ctxAssertEvaluated Id
b ExprCtx
c) [(Id, GenStgRhs pass)]
xs
| Bool
otherwise = ExprCtx -> [(Id, GenStgRhs pass)] -> ExprCtx
addEvalRhs ExprCtx
c [(Id, GenStgRhs pass)]
xs
genBindLne :: HasDebugCallStack
=> ExprCtx
-> CgStgBinding
-> G (JStat, ExprCtx)
genBindLne :: (() :: Constraint) =>
ExprCtx -> GenStgBinding 'CodeGen -> G (JStat, ExprCtx)
genBindLne ExprCtx
ctx GenStgBinding 'CodeGen
bndr = do
[(Id, Int)]
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)]
(() :: Constraint) =>
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)
JStat
declUpds <- [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> StateT GenState IO [JStat] -> G JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Id, GenStgRhs 'CodeGen) -> G JStat)
-> [(Id, GenStgRhs 'CodeGen)] -> StateT GenState IO [JStat]
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 ((Ident -> JStat) -> StateT GenState IO Ident -> G JStat
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 -> JExpr -> JStat
||= JExpr
null_) (StateT GenState IO Ident -> G JStat)
-> ((Id, GenStgRhs 'CodeGen) -> StateT GenState IO Ident)
-> (Id, GenStgRhs 'CodeGen)
-> G JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> StateT GenState IO Ident
identForId (Id -> StateT GenState IO Ident)
-> ((Id, GenStgRhs 'CodeGen) -> Id)
-> (Id, GenStgRhs 'CodeGen)
-> StateT GenState IO Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> Id
forall a b. (a, b) -> a
fst) [(Id, GenStgRhs 'CodeGen)]
updBinds
let ctx' :: ExprCtx
ctx' = [(Id, Int)] -> [Id] -> ExprCtx -> ExprCtx
ctxUpdateLneFrame [(Id, Int)]
vis [Id]
bound ExprCtx
ctx
((Id, GenStgRhs 'CodeGen) -> G ())
-> [(Id, GenStgRhs 'CodeGen)] -> G ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Id -> GenStgRhs 'CodeGen -> G ())
-> (Id, GenStgRhs 'CodeGen) -> G ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Id -> GenStgRhs 'CodeGen -> G ())
-> (Id, GenStgRhs 'CodeGen) -> G ())
-> (Id -> GenStgRhs 'CodeGen -> G ())
-> (Id, GenStgRhs 'CodeGen)
-> G ()
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
ExprCtx -> Id -> GenStgRhs 'CodeGen -> G ()
genEntryLne ExprCtx
ctx') [(Id, GenStgRhs 'CodeGen)]
binds
(JStat, ExprCtx) -> G (JStat, ExprCtx)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
declUpds, ExprCtx
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 :: (() :: Constraint) => 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) =
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))
bh :: JStat
bh | UpdateFlag -> Bool
isUpdatable UpdateFlag
update =
(JExpr -> JStat) -> JStat
forall a. ToSat a => a -> JStat
jVar (\JExpr
x -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ JExpr
x JExpr -> JExpr -> JStat
|= JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$bh_lne") [JExpr -> JExpr -> JExpr
Sub JExpr
sp (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
myOffset), Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Int
payloadSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)]
, JExpr -> JStat -> JStat -> JStat
IfStat JExpr
x (JExpr -> JStat
ReturnStat JExpr
x) JStat
forall a. Monoid a => a
mempty
])
| Bool
otherwise = JStat
forall a. Monoid a => a
mempty
JStat
lvs <- Bool -> Int -> ExprCtx -> G JStat
popLneFrame Bool
True Int
payloadSize ExprCtx
ctx
JStat
body <- (() :: Constraint) =>
ExprCtx -> Id -> StgReg -> [Id] -> CgStgExpr -> G JStat
ExprCtx -> Id -> StgReg -> [Id] -> CgStgExpr -> G JStat
genBody ExprCtx
ctx Id
i StgReg
R1 [Id]
[BinderP 'CodeGen]
args CgStgExpr
body
ei :: Ident
ei@(TxtI FastString
eii) <- Id -> StateT GenState IO Ident
identForEntryId Id
i
CIStatic
sr <- GenStgRhs 'CodeGen -> G CIStatic
genStaticRefsRhs GenStgRhs 'CodeGen
rhs
let f :: JVal
f = [Ident] -> JStat -> JVal
JFunc [] (JStat
bh JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
lvs JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
body)
ClosureInfo -> G ()
emitClosureInfo (ClosureInfo -> G ()) -> ClosureInfo -> G ()
forall a b. (a -> b) -> a -> b
$
Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
ei
(Int -> [VarType] -> CIRegs
CIRegs Int
0 ([VarType] -> CIRegs) -> [VarType] -> CIRegs
forall a b. (a -> b) -> a -> b
$ (Id -> [VarType]) -> [Id] -> [VarType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (() :: Constraint) => Id -> [VarType]
Id -> [VarType]
idVt [Id]
[BinderP 'CodeGen]
args)
(FastString
eii FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
", " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> String -> FastString
mkFastString (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
i)))
([VarType] -> CILayout
fixedLayout ([VarType] -> CILayout)
-> ([VarType] -> [VarType]) -> [VarType] -> CILayout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VarType] -> [VarType]
forall a. [a] -> [a]
reverse ([VarType] -> CILayout) -> [VarType] -> CILayout
forall a b. (a -> b) -> a -> b
$
((Id, Int) -> VarType) -> [(Id, Int)] -> [VarType]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> VarType
stackSlotType (Id -> VarType) -> ((Id, Int) -> Id) -> (Id, Int) -> VarType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Int) -> Id
forall a b. (a, b) -> a
fst) (ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx))
CIType
CIStackFrame
CIStatic
sr
JStat -> G ()
emitToplevel (Ident
ei Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JVal
f)
genEntryLne ExprCtx
ctx Id
i (StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mu [GenTickish 'TickishPassStg]
_ticks [StgArg]
args) = 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 :: Ident
ei@(TxtI FastString
_eii) <- Id -> StateT GenState IO Ident
identForEntryId Id
i
Ident
ii <- StateT GenState IO Ident
freshIdent
JStat
p <- Bool -> Int -> ExprCtx -> G JStat
popLneFrame Bool
True Int
payloadSize ExprCtx
ctx
[JExpr]
args' <- (StgArg -> G [JExpr]) -> [StgArg] -> G [JExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (() :: Constraint) => StgArg -> G [JExpr]
StgArg -> G [JExpr]
genArg [StgArg]
args
JStat
ac <- Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat
allocCon Ident
ii DataCon
con CostCentreStack
cc [JExpr]
args'
JStat -> G ()
emitToplevel (Ident
ei Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([Ident] -> JStat -> JVal
JFunc []
([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [Ident -> JStat
decl Ident
ii, JStat
p, JStat
ac, JExpr
r1 JExpr -> JExpr -> JStat
|= Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
ii, JStat
returnStack])))
genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G ()
genEntry :: (() :: Constraint) => 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) = 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
JStat
ll <- [Id] -> G JStat
loadLiveFun [Id]
live
JStat
llv <- [Id] -> G JStat
(() :: Constraint) => [Id] -> G JStat
verifyRuntimeReps [Id]
live
JStat
upd <- UpdateFlag -> Id -> G JStat
genUpdFrame UpdateFlag
upd_flag Id
i
JStat
body <- (() :: Constraint) =>
ExprCtx -> Id -> StgReg -> [Id] -> CgStgExpr -> G JStat
ExprCtx -> Id -> StgReg -> [Id] -> CgStgExpr -> G JStat
genBody ExprCtx
entryCtx Id
i StgReg
R2 [Id]
[BinderP 'CodeGen]
args CgStgExpr
body
ei :: Ident
ei@(TxtI FastString
eii) <- Id -> StateT GenState IO Ident
identForEntryId Id
i
CIType
et <- [Id] -> G CIType
(() :: Constraint) => [Id] -> G CIType
genEntryType [Id]
[BinderP 'CodeGen]
args
JStat
setcc <- JStat -> G JStat
forall m. Monoid m => m -> G m
ifProfiling (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$
if CIType
et CIType -> CIType -> Bool
forall a. Eq a => a -> a -> Bool
== CIType
CIThunk
then JStat
enterCostCentreThunk
else CostCentreStack -> JStat
enterCostCentreFun CostCentreStack
cc
CIStatic
sr <- GenStgRhs 'CodeGen -> G CIStatic
genStaticRefsRhs GenStgRhs 'CodeGen
rhs
ClosureInfo -> G ()
emitClosureInfo (ClosureInfo -> G ()) -> ClosureInfo -> G ()
forall a b. (a -> b) -> a -> b
$ Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
ei
(Int -> [VarType] -> CIRegs
CIRegs Int
0 ([VarType] -> CIRegs) -> [VarType] -> CIRegs
forall a b. (a -> b) -> a -> b
$ VarType
PtrV VarType -> [VarType] -> [VarType]
forall a. a -> [a] -> [a]
: (Id -> [VarType]) -> [Id] -> [VarType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (() :: Constraint) => Id -> [VarType]
Id -> [VarType]
idVt [Id]
[BinderP 'CodeGen]
args)
(FastString
eii FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> FastString
", " FastString -> FastString -> FastString
forall a. Semigroup a => a -> a -> a
<> String -> FastString
mkFastString (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
i)))
([VarType] -> CILayout
fixedLayout ([VarType] -> CILayout) -> [VarType] -> CILayout
forall a b. (a -> b) -> a -> b
$ (Id -> VarType) -> [Id] -> [VarType]
forall a b. (a -> b) -> [a] -> [b]
map ((() :: Constraint) => Type -> VarType
Type -> VarType
uTypeVt (Type -> VarType) -> (Id -> Type) -> Id -> VarType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [Id]
live)
CIType
et
CIStatic
sr
JStat -> G ()
emitToplevel (Ident
ei Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([Ident] -> JStat -> JVal
JFunc [] ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat
ll, JStat
llv, JStat
upd, JStat
setcc, JStat
body])))
where
entryCtx :: ExprCtx
entryCtx = [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget [] (ExprCtx -> ExprCtx
ctxClearLneFrame ExprCtx
ctx)
genEntryType :: HasDebugCallStack => [Id] -> G CIType
genEntryType :: (() :: Constraint) => [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]
args0 = do
[[JExpr]]
args' <- (Id -> G [JExpr]) -> [Id] -> StateT GenState IO [[JExpr]]
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 (() :: Constraint) => Id -> G [JExpr]
Id -> G [JExpr]
genIdArg [Id]
args
CIType -> G CIType
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CIType -> G CIType) -> CIType -> G CIType
forall a b. (a -> b) -> a -> b
$ Int -> Int -> CIType
CIFun ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
args) ([JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([JExpr] -> Int) -> [JExpr] -> Int
forall a b. (a -> b) -> a -> b
$ [[JExpr]] -> [JExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JExpr]]
args')
where
args :: [Id]
args = (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
. Type -> Bool
isRuntimeRepKindedTy (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) [Id]
args0
genBody :: HasDebugCallStack
=> ExprCtx
-> Id
-> StgReg
-> [Id]
-> CgStgExpr
-> G JStat
genBody :: (() :: Constraint) =>
ExprCtx -> Id -> StgReg -> [Id] -> CgStgExpr -> G JStat
genBody ExprCtx
ctx Id
i StgReg
startReg [Id]
args CgStgExpr
e = do
JStat
la <- do
[Ident]
args' <- (Id -> G [Ident]) -> [Id] -> G [Ident]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (() :: Constraint) => Id -> G [Ident]
Id -> G [Ident]
genIdArgI [Id]
args
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Ident] -> [JExpr] -> JStat
declAssignAll [Ident]
args' ((StgReg -> JExpr) -> [StgReg] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StgReg -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [StgReg
startReg..]))
JStat
lav <- [Id] -> G JStat
(() :: Constraint) => [Id] -> G JStat
verifyRuntimeReps [Id]
args
let res_vars :: [(PrimRep, Int)]
res_vars = [Id] -> Id -> [(PrimRep, Int)]
(() :: Constraint) => [Id] -> Id -> [(PrimRep, Int)]
resultSize [Id]
args Id
i
let go_var :: [JExpr] -> [(PrimRep, Int)] -> [TypedExpr]
go_var [JExpr]
regs = \case
[] -> []
((PrimRep
rep,Int
size):[(PrimRep, Int)]
rs) ->
let !([JExpr]
regs0,[JExpr]
regs1) = Int -> [JExpr] -> ([JExpr], [JExpr])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
size [JExpr]
regs
!ts :: [TypedExpr]
ts = [JExpr] -> [(PrimRep, Int)] -> [TypedExpr]
go_var [JExpr]
regs1 [(PrimRep, Int)]
rs
in PrimRep -> [JExpr] -> TypedExpr
TypedExpr PrimRep
rep [JExpr]
regs0 TypedExpr -> [TypedExpr] -> [TypedExpr]
forall a. a -> [a] -> [a]
: [TypedExpr]
ts
let tgt :: [TypedExpr]
tgt = [JExpr] -> [(PrimRep, Int)] -> [TypedExpr]
go_var [JExpr]
jsRegsFromR1 [(PrimRep, Int)]
res_vars
let !ctx' :: ExprCtx
ctx' = ExprCtx
ctx { ctxTarget = tgt }
(JStat
e, ExprResult
_r) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ JStat
la JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
lav JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
e JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
returnStack
resultSize :: HasDebugCallStack => [Id] -> Id -> [(PrimRep, Int)]
resultSize :: (() :: Constraint) => [Id] -> Id -> [(PrimRep, Int)]
resultSize [Id]
args Id
i = [(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 = Type -> Int -> [PrimRep]
trim_args (Type -> Type
unwrapType (Id -> Type
idType Id
i)) ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
args)
trim_args :: Type -> Int -> [PrimRep]
trim_args Type
t Int
0 = (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
t
trim_args Type
t Int
n
| Just (FunTyFlag
_af, Type
_mult, Type
arg, Type
res) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
t
, Int
nargs <- [PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRepArgs Type
arg)
, Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
nargs) Bool
True
= Type -> Int -> [PrimRep]
trim_args (Type -> Type
unwrapType Type
res) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nargs)
| Bool
otherwise
= String -> SDoc -> [PrimRep] -> [PrimRep]
forall a. String -> SDoc -> a -> a
pprTrace String
"result_type: not a function type, assume LiftedRep" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t)
[PrimRep
LiftedRep]
verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStat
verifyRuntimeReps :: (() :: Constraint) => [Id] -> G JStat
verifyRuntimeReps [Id]
xs = do
Bool
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 Bool -> Bool
not Bool
runtime_assert
then JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStat
forall a. Monoid a => a
mempty
else [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> StateT GenState IO [JStat] -> G JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> G JStat) -> [Id] -> StateT GenState IO [JStat]
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 JStat
verifyRuntimeRep [Id]
xs
where
verifyRuntimeRep :: Id -> G JStat
verifyRuntimeRep Id
i = do
[JExpr]
i' <- Id -> G [JExpr]
varsForId Id
i
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ [JExpr] -> [VarType] -> JStat
go [JExpr]
i' ((() :: Constraint) => Id -> [VarType]
Id -> [VarType]
idVt Id
i)
go :: [JExpr] -> [VarType] -> JStat
go [JExpr]
js (VarType
VoidV:[VarType]
vs) = [JExpr] -> [VarType] -> JStat
go [JExpr]
js [VarType]
vs
go (JExpr
j1:JExpr
j2:[JExpr]
js) (VarType
LongV:[VarType]
vs) = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_long" [JExpr
j1,JExpr
j2] JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JExpr] -> [VarType] -> JStat
go [JExpr]
js [VarType]
vs
go (JExpr
j1:JExpr
j2:[JExpr]
js) (VarType
AddrV:[VarType]
vs) = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_addr" [JExpr
j1,JExpr
j2] JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JExpr] -> [VarType] -> JStat
go [JExpr]
js [VarType]
vs
go (JExpr
j:[JExpr]
js) (VarType
v:[VarType]
vs) = JExpr -> VarType -> JStat
ver JExpr
j VarType
v JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JExpr] -> [VarType] -> JStat
go [JExpr]
js [VarType]
vs
go [] [] = JStat
forall a. Monoid a => a
mempty
go [JExpr]
_ [VarType]
_ = String -> SDoc -> JStat
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"verifyRuntimeReps: inconsistent sizes" ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
xs)
ver :: JExpr -> VarType -> JStat
ver JExpr
j VarType
PtrV = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_heapobj" [JExpr
j]
ver JExpr
j VarType
IntV = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_int" [JExpr
j]
ver JExpr
j VarType
RtsObjV = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_rtsobj" [JExpr
j]
ver JExpr
j VarType
DoubleV = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_double" [JExpr
j]
ver JExpr
j VarType
ArrV = FastString -> [JExpr] -> JStat
v FastString
"h$verify_rep_arr" [JExpr
j]
ver JExpr
_ VarType
_ = JStat
forall a. Monoid a => a
mempty
v :: FastString -> [JExpr] -> JStat
v FastString
f [JExpr]
as = JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
f) [JExpr]
as
loadLiveFun :: [Id] -> G JStat
loadLiveFun :: [Id] -> G JStat
loadLiveFun [Id]
l = do
[Ident]
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 [Ident]
l' of
[] -> JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStat
forall a. Monoid a => a
mempty
[Ident
v] -> JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
v Ident -> JExpr -> JStat
||= JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField1_)
[Ident
v1,Ident
v2] -> JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ Ident
v1 Ident -> JExpr -> JStat
||= JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField1_
, Ident
v2 Ident -> JExpr -> JStat
||= JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField2_
]
(Ident
v:[Ident]
vs) -> do
Ident
d <- StateT GenState IO Ident
freshIdent
let l'' :: JStat
l'' = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> ([Ident] -> [JStat]) -> [Ident] -> JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Ident -> JStat) -> [Int] -> [Ident] -> [JStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (JExpr -> Int -> Ident -> JStat
loadLiveVar (JExpr -> Int -> Ident -> JStat) -> JExpr -> Int -> Ident -> JStat
forall a b. (a -> b) -> a -> b
$ Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
d) [(Int
1::Int)..] ([Ident] -> JStat) -> [Ident] -> JStat
forall a b. (a -> b) -> a -> b
$ [Ident]
vs
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ Ident
v Ident -> JExpr -> JStat
||= JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField1_
, Ident
d Ident -> JExpr -> JStat
||= JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField2_
, JStat
l''
]
where
loadLiveVar :: JExpr -> Int -> Ident -> JStat
loadLiveVar JExpr
d Int
n Ident
v = let ident :: Ident
ident = FastString -> Ident
TxtI (Int -> FastString
dataFieldName Int
n)
in Ident
v Ident -> JExpr -> JStat
||= JExpr -> Ident -> JExpr
SelExpr JExpr
d Ident
ident
popLneFrame :: Bool -> Int -> ExprCtx -> G JStat
popLneFrame :: Bool -> Int -> ExprCtx -> G JStat
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
[Ident]
ids <- Id -> G [Ident]
identsForId Id
i
let !id_n :: Ident
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)
(Ident, StackSlot) -> StateT GenState IO (Ident, StackSlot)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ident
id_n, Id -> Int -> StackSlot
SlotId Id
i Int
n)
[(Ident, StackSlot)]
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 :: Int
skip = if Bool
inEntry then Int
1 else Int
0
Int -> [(Ident, StackSlot)] -> G JStat
popSkipI Int
skip [(Ident, StackSlot)]
is
genUpdFrame :: UpdateFlag -> Id -> G JStat
genUpdFrame :: UpdateFlag -> Id -> G JStat
genUpdFrame UpdateFlag
u Id
i
| UpdateFlag -> Bool
isReEntrant UpdateFlag
u = JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStat
forall a. Monoid a => a
mempty
| Id -> Bool
isOneShotBndr Id
i = G JStat
maybeBh
| UpdateFlag -> Bool
isUpdatable UpdateFlag
u = G JStat
updateThunk
| Bool
otherwise = G JStat
maybeBh
where
isReEntrant :: UpdateFlag -> Bool
isReEntrant UpdateFlag
ReEntrant = Bool
True
isReEntrant UpdateFlag
_ = Bool
False
maybeBh :: G JStat
maybeBh = do
StgToJSConfig
settings <- StateT GenState IO StgToJSConfig
getSettings
G JStat -> G JStat
assertRtsStat (JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ StgToJSConfig -> JStat
bhSingleEntry StgToJSConfig
settings)
bhSingleEntry :: StgToJSConfig -> JStat
bhSingleEntry :: StgToJSConfig -> JStat
bhSingleEntry StgToJSConfig
_settings = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureEntry_ JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$blackholeTrap"
, JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= JExpr
undefined_
, JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
closureField2_ JExpr -> JExpr -> JStat
|= JExpr
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
UniqFM Id CgStgExpr
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]
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
||
(() :: Constraint) => Type -> Maybe Levity
Type -> Maybe Levity
typeLevity_maybe (Id -> Type
idType Id
x) Maybe Levity -> Maybe Levity -> Bool
forall a. Eq a => a -> a -> Bool
== Levity -> Maybe Levity
forall a. a -> Maybe a
Just Levity
Unlifted))
(LiveVars -> [Id]
dVarSetElems LiveVars
sv)
[FastString] -> CIStatic
CIStaticRefs ([FastString] -> CIStatic)
-> ([Maybe FastString] -> [FastString])
-> [Maybe FastString]
-> CIStatic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe FastString] -> [FastString]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FastString] -> CIStatic)
-> StateT GenState IO [Maybe FastString] -> G CIStatic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> StateT GenState IO (Maybe FastString))
-> [Id] -> StateT GenState IO [Maybe FastString]
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 -> StateT GenState IO (Maybe FastString)
getStaticRef [Id]
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
itxt (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 :: (() :: Constraint) =>
Int -> [Id] -> StateT GenState IO [(Id, Int, Bool)]
optimizeFree Int
offset [Id]
ids = do
let
idSize :: Id -> Int
idSize :: Id -> Int
idSize Id
i = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (VarType -> Int) -> [VarType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map VarType -> Int
varSize ((() :: Constraint) => Type -> [VarType]
Type -> [VarType]
typeVt (Type -> [VarType]) -> (Id -> Type) -> Id -> [VarType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType (Id -> [VarType]) -> Id -> [VarType]
forall a b. (a -> b) -> a -> b
$ 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'
[StackSlot]
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 :: Map StackSlot Int
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..])
([(Id, Int)]
remaining, [(Id, Int, Int, Bool)]
fixed) = [Either (Id, Int) (Id, Int, Int, Bool)]
-> ([(Id, Int)], [(Id, Int, Int, Bool)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Id, Int) (Id, Int, Int, Bool)]
-> ([(Id, Int)], [(Id, Int, Int, Bool)]))
-> [Either (Id, Int) (Id, Int, Int, Bool)]
-> ([(Id, Int)], [(Id, Int, Int, Bool)])
forall a b. (a -> b) -> a -> b
$
((Id, Int) -> Either (Id, Int) (Id, Int, Int, Bool))
-> [(Id, Int)] -> [Either (Id, Int) (Id, Int, Int, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\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)) [(Id, Int)]
ids'
takenSlots :: Set Int
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]
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, Bool)]
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)]
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')
[(Id, Int, Bool)] -> StateT GenState IO [(Id, Int, Bool)]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id, Int, Bool)] -> StateT GenState IO [(Id, Int, Bool)])
-> [(Id, Int, Bool)] -> StateT GenState IO [(Id, Int, Bool)]
forall a b. (a -> b) -> a -> b
$ ((Id, Int, Int, Bool) -> (Id, Int, Bool))
-> [(Id, Int, Int, Bool)] -> [(Id, Int, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
i,Int
n,Int
_,Bool
b) -> (Id
i,Int
n,Bool
b)) [(Id, Int, Int, Bool)]
allSlots
allocCls :: Maybe JStat -> [(Id, CgStgRhs)] -> G JStat
allocCls :: Maybe JStat -> [(Id, GenStgRhs 'CodeGen)] -> G JStat
allocCls Maybe JStat
dynMiddle [(Id, GenStgRhs 'CodeGen)]
xs = do
([JStat]
stat, [(Ident, JExpr, [JExpr], CostCentreStack)]
dyn) <- [Either JStat (Ident, JExpr, [JExpr], CostCentreStack)]
-> ([JStat], [(Ident, JExpr, [JExpr], CostCentreStack)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either JStat (Ident, JExpr, [JExpr], CostCentreStack)]
-> ([JStat], [(Ident, JExpr, [JExpr], CostCentreStack)]))
-> StateT
GenState IO [Either JStat (Ident, JExpr, [JExpr], CostCentreStack)]
-> StateT
GenState IO ([JStat], [(Ident, JExpr, [JExpr], CostCentreStack)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Id, GenStgRhs 'CodeGen)
-> StateT
GenState
IO
(Either JStat (Ident, JExpr, [JExpr], CostCentreStack)))
-> [(Id, GenStgRhs 'CodeGen)]
-> StateT
GenState IO [Either JStat (Ident, JExpr, [JExpr], CostCentreStack)]
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)
-> StateT
GenState IO (Either JStat (Ident, JExpr, [JExpr], CostCentreStack))
toCl [(Id, GenStgRhs 'CodeGen)]
xs
JStat
ac <- Bool
-> Maybe JStat
-> [(Ident, JExpr, [JExpr], CostCentreStack)]
-> G JStat
allocDynAll Bool
True Maybe JStat
dynMiddle [(Ident, JExpr, [JExpr], CostCentreStack)]
dyn
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat]
stat JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
ac)
where
toCl :: (Id, CgStgRhs)
-> G (Either JStat (Ident,JExpr,[JExpr],CostCentreStack))
toCl :: (Id, GenStgRhs 'CodeGen)
-> StateT
GenState IO (Either JStat (Ident, JExpr, [JExpr], CostCentreStack))
toCl (Id
i, StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mui [GenTickish 'TickishPassStg]
_ticjs [StgArg
a]) | DataCon -> Bool
isUnboxableCon DataCon
con = do
Ident
ii <- Id -> StateT GenState IO Ident
identForId Id
i
JStat
ac <- Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat
allocCon Ident
ii DataCon
con CostCentreStack
cc ([JExpr] -> G JStat) -> G [JExpr] -> G JStat
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (() :: Constraint) => StgArg -> G [JExpr]
StgArg -> G [JExpr]
genArg StgArg
a
Either JStat (Ident, JExpr, [JExpr], CostCentreStack)
-> StateT
GenState IO (Either JStat (Ident, JExpr, [JExpr], CostCentreStack))
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStat -> Either JStat (Ident, JExpr, [JExpr], CostCentreStack)
forall a b. a -> Either a b
Left (Ident -> JStat
decl Ident
ii JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
ac))
toCl (Id
i, StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
_mu [GenTickish 'TickishPassStg]
_ticks [StgArg]
ar) =
(Ident, JExpr, [JExpr], CostCentreStack)
-> Either JStat (Ident, JExpr, [JExpr], CostCentreStack)
forall a b. b -> Either a b
Right ((Ident, JExpr, [JExpr], CostCentreStack)
-> Either JStat (Ident, JExpr, [JExpr], CostCentreStack))
-> StateT GenState IO (Ident, JExpr, [JExpr], CostCentreStack)
-> StateT
GenState IO (Either JStat (Ident, JExpr, [JExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,) (Ident
-> JExpr
-> [JExpr]
-> CostCentreStack
-> (Ident, JExpr, [JExpr], CostCentreStack))
-> StateT GenState IO Ident
-> StateT
GenState
IO
(JExpr
-> [JExpr]
-> CostCentreStack
-> (Ident, JExpr, [JExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i
StateT
GenState
IO
(JExpr
-> [JExpr]
-> CostCentreStack
-> (Ident, JExpr, [JExpr], CostCentreStack))
-> StateT GenState IO JExpr
-> StateT
GenState
IO
([JExpr]
-> CostCentreStack -> (Ident, JExpr, [JExpr], 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 JExpr
varForDataConWorker DataCon
con
StateT
GenState
IO
([JExpr]
-> CostCentreStack -> (Ident, JExpr, [JExpr], CostCentreStack))
-> G [JExpr]
-> StateT
GenState
IO
(CostCentreStack -> (Ident, JExpr, [JExpr], 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 [JExpr]) -> [StgArg] -> G [JExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (() :: Constraint) => StgArg -> G [JExpr]
StgArg -> G [JExpr]
genArg [StgArg]
ar
StateT
GenState
IO
(CostCentreStack -> (Ident, JExpr, [JExpr], CostCentreStack))
-> StateT GenState IO CostCentreStack
-> StateT GenState IO (Ident, JExpr, [JExpr], 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)) =
let live :: [Id]
live = GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr GenStgRhs 'CodeGen
cl
in (Ident, JExpr, [JExpr], CostCentreStack)
-> Either JStat (Ident, JExpr, [JExpr], CostCentreStack)
forall a b. b -> Either a b
Right ((Ident, JExpr, [JExpr], CostCentreStack)
-> Either JStat (Ident, JExpr, [JExpr], CostCentreStack))
-> StateT GenState IO (Ident, JExpr, [JExpr], CostCentreStack)
-> StateT
GenState IO (Either JStat (Ident, JExpr, [JExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,) (Ident
-> JExpr
-> [JExpr]
-> CostCentreStack
-> (Ident, JExpr, [JExpr], CostCentreStack))
-> StateT GenState IO Ident
-> StateT
GenState
IO
(JExpr
-> [JExpr]
-> CostCentreStack
-> (Ident, JExpr, [JExpr], CostCentreStack))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i
StateT
GenState
IO
(JExpr
-> [JExpr]
-> CostCentreStack
-> (Ident, JExpr, [JExpr], CostCentreStack))
-> StateT GenState IO JExpr
-> StateT
GenState
IO
([JExpr]
-> CostCentreStack -> (Ident, JExpr, [JExpr], 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 JExpr
varForEntryId Id
i
StateT
GenState
IO
([JExpr]
-> CostCentreStack -> (Ident, JExpr, [JExpr], CostCentreStack))
-> G [JExpr]
-> StateT
GenState
IO
(CostCentreStack -> (Ident, JExpr, [JExpr], 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 [JExpr]) -> [Id] -> G [JExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM Id -> G [JExpr]
varsForId [Id]
live
StateT
GenState
IO
(CostCentreStack -> (Ident, JExpr, [JExpr], CostCentreStack))
-> StateT GenState IO CostCentreStack
-> StateT GenState IO (Ident, JExpr, [JExpr], 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 (JStat, ExprResult)
genCase :: (() :: Constraint) =>
ExprCtx
-> Id
-> CgStgExpr
-> AltType
-> [GenStgAlt 'CodeGen]
-> LiveVars
-> G (JStat, ExprResult)
genCase ExprCtx
ctx Id
bnd CgStgExpr
e AltType
at [GenStgAlt 'CodeGen]
alts LiveVars
l
| (UniqSet Id, Bool) -> Bool
forall a b. (a, b) -> b
snd (UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr (ExprCtx -> UniqSet Id
ctxEvaluatedIds ExprCtx
ctx) CgStgExpr
e) = do
[Ident]
bndi <- Id -> G [Ident]
identsForId Id
bnd
let ctx' :: ExprCtx
ctx' = Id -> ExprCtx -> ExprCtx
ctxSetTop Id
bnd
(ExprCtx -> ExprCtx) -> ExprCtx -> ExprCtx
forall a b. (a -> b) -> a -> b
$ [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget (Id -> [JExpr] -> [TypedExpr]
assocIdExprs Id
bnd ((Ident -> JExpr) -> [Ident] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [Ident]
bndi))
(ExprCtx -> ExprCtx) -> ExprCtx -> ExprCtx
forall a b. (a -> b) -> a -> b
$ ExprCtx
ctx
(JStat
ej, ExprResult
r) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
let d :: Maybe [JExpr]
d = case ExprResult
r of
ExprInline Maybe [JExpr]
d0 -> Maybe [JExpr]
d0
ExprResult
ExprCont -> String -> SDoc -> Maybe [JExpr]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genCase: expression was not inline"
(StgPprOpts -> CgStgExpr -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts CgStgExpr
e)
(JStat
aj, ExprResult
ar) <- (() :: Constraint) =>
ExprCtx
-> Id
-> AltType
-> Maybe [JExpr]
-> [GenStgAlt 'CodeGen]
-> G (JStat, ExprResult)
ExprCtx
-> Id
-> AltType
-> Maybe [JExpr]
-> [GenStgAlt 'CodeGen]
-> G (JStat, ExprResult)
genAlts (Id -> ExprCtx -> ExprCtx
ctxAssertEvaluated Id
bnd ExprCtx
ctx) Id
bnd AltType
at Maybe [JExpr]
d [GenStgAlt 'CodeGen]
alts
(JStat
saveCCS,JStat
restoreCCS) <- G (JStat, JStat) -> G (JStat, JStat)
forall m. Monoid m => G m -> G m
ifProfilingM (G (JStat, JStat) -> G (JStat, JStat))
-> G (JStat, JStat) -> G (JStat, JStat)
forall a b. (a -> b) -> a -> b
$ do
Ident
ccsVar <- StateT GenState IO Ident
freshIdent
(JStat, JStat) -> G (JStat, JStat)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Ident
ccsVar Ident -> JExpr -> JStat
||= JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
jCurrentCCS
, JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
jCurrentCCS JExpr -> JExpr -> JStat
|= Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
ccsVar
)
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((Ident -> JStat) -> [Ident] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> JStat
decl [Ident]
bndi)
, JStat
saveCCS
, JStat
ej
, JStat
restoreCCS
, JStat
aj
]
, ExprResult
ar
)
| Bool
otherwise = do
JStat
rj <- (() :: Constraint) =>
ExprCtx
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> LiveVars -> G JStat
ExprCtx
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> LiveVars -> G JStat
genRet (Id -> ExprCtx -> ExprCtx
ctxAssertEvaluated Id
bnd ExprCtx
ctx) Id
bnd AltType
at [GenStgAlt 'CodeGen]
alts LiveVars
l
let ctx' :: ExprCtx
ctx' = Id -> ExprCtx -> ExprCtx
ctxSetTop Id
bnd
(ExprCtx -> ExprCtx) -> ExprCtx -> ExprCtx
forall a b. (a -> b) -> a -> b
$ [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget (Id -> [JExpr] -> [TypedExpr]
assocIdExprs Id
bnd ((StgReg -> JExpr) -> [StgReg] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map StgReg -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [StgReg
R1 ..]))
(ExprCtx -> ExprCtx) -> ExprCtx -> ExprCtx
forall a b. (a -> b) -> a -> b
$ ExprCtx
ctx
(JStat
ej, ExprResult
_r) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx' CgStgExpr
e
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
rj JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
ej, ExprResult
ExprCont)
genRet :: HasDebugCallStack
=> ExprCtx
-> Id
-> AltType
-> [CgStgAlt]
-> LiveVars
-> G JStat
genRet :: (() :: Constraint) =>
ExprCtx
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> LiveVars -> G JStat
genRet ExprCtx
ctx Id
e AltType
at [GenStgAlt 'CodeGen]
as LiveVars
l = StateT GenState IO Ident
freshIdent StateT GenState IO Ident -> (Ident -> G JStat) -> G JStat
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 JStat
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 key 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 JStat
f :: Ident -> G JStat
f r :: Ident
r@(TxtI FastString
ri) = do
JStat
pushLne <- Int -> ExprCtx -> G JStat
(() :: Constraint) => Int -> ExprCtx -> G JStat
pushLneFrame Int
lneLive ExprCtx
ctx
JStat
saveCCS <- G JStat -> G JStat
forall m. Monoid m => G m -> G m
ifProfilingM (G JStat -> G JStat) -> G JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ [JExpr] -> G JStat
push [JExpr
jCurrentCCS]
[(Id, Int, Bool)]
free <- Int -> [Id] -> StateT GenState IO [(Id, Int, Bool)]
(() :: Constraint) =>
Int -> [Id] -> StateT GenState IO [(Id, Int, Bool)]
optimizeFree Int
0 [Id]
nonLne
JStat
pushRet <- [(Id, Int, Bool)] -> JExpr -> G JStat
(() :: Constraint) => [(Id, Int, Bool)] -> JExpr -> G JStat
pushRetArgs [(Id, Int, Bool)]
free (Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
r)
JStat
fun' <- [(Id, Int, Bool)] -> G JStat
fun [(Id, Int, Bool)]
free
CIStatic
sr <- LiveVars -> G CIStatic
genStaticRefs LiveVars
l
Bool
prof <- StateT GenState IO Bool
profiling
ClosureInfo -> G ()
emitClosureInfo (ClosureInfo -> G ()) -> ClosureInfo -> G ()
forall a b. (a -> b) -> a -> b
$
Ident
-> CIRegs
-> FastString
-> CILayout
-> CIType
-> CIStatic
-> ClosureInfo
ClosureInfo Ident
r
(Int -> [VarType] -> CIRegs
CIRegs Int
0 [VarType]
(() :: Constraint) => [VarType]
altRegs)
FastString
ri
([VarType] -> CILayout
fixedLayout ([VarType] -> CILayout)
-> ([VarType] -> [VarType]) -> [VarType] -> CILayout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VarType] -> [VarType]
forall a. [a] -> [a]
reverse ([VarType] -> CILayout) -> [VarType] -> CILayout
forall a b. (a -> b) -> a -> b
$
((Id, Int, Bool) -> VarType) -> [(Id, Int, Bool)] -> [VarType]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> VarType
stackSlotType (Id -> VarType)
-> ((Id, Int, Bool) -> Id) -> (Id, Int, Bool) -> VarType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Int, Bool) -> Id
forall {a} {b} {c}. (a, b, c) -> a
fst3) [(Id, Int, Bool)]
free
[VarType] -> [VarType] -> [VarType]
forall a. [a] -> [a] -> [a]
++ if Bool
prof then [VarType
ObjV] else (Id -> VarType) -> [Id] -> [VarType]
forall a b. (a -> b) -> [a] -> [b]
map Id -> VarType
stackSlotType [Id]
lneVars)
CIType
CIStackFrame
CIStatic
sr
JStat -> G ()
emitToplevel (JStat -> G ()) -> JStat -> G ()
forall a b. (a -> b) -> a -> b
$ Ident
r Ident -> JExpr -> JStat
||= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([Ident] -> JStat -> JVal
JFunc [] JStat
fun')
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
pushLne JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
saveCCS JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
pushRet)
fst3 :: (a, b, c) -> a
fst3 ~(a
x,b
_,c
_) = a
x
altRegs :: HasDebugCallStack => [VarType]
altRegs :: (() :: Constraint) => [VarType]
altRegs = case AltType
at of
PrimAlt PrimRep
ptc -> [(() :: Constraint) => PrimRep -> VarType
PrimRep -> VarType
primRepVt PrimRep
ptc]
MultiValAlt Int
_n -> (() :: Constraint) => Id -> [VarType]
Id -> [VarType]
idVt Id
e
AltType
_ -> [VarType
PtrV]
pop_handle_CCS :: [(JExpr, StackSlot)] -> G JStat
pop_handle_CCS :: [(JExpr, StackSlot)] -> G JStat
pop_handle_CCS [] = JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStat
forall a. Monoid a => a
mempty
pop_handle_CCS [(JExpr, StackSlot)]
xs = do
[StackSlot] -> G ()
addSlots (((JExpr, StackSlot) -> StackSlot)
-> [(JExpr, StackSlot)] -> [StackSlot]
forall a b. (a -> b) -> [a] -> [b]
map (JExpr, StackSlot) -> StackSlot
forall a b. (a, b) -> b
snd [(JExpr, StackSlot)]
xs)
JStat
a <- Int -> G JStat
adjSpN ([(JExpr, StackSlot)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(JExpr, StackSlot)]
xs)
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [JExpr] -> JStat
loadSkip Int
0 (((JExpr, StackSlot) -> JExpr) -> [(JExpr, StackSlot)] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map (JExpr, StackSlot) -> JExpr
forall a b. (a, b) -> a
fst [(JExpr, StackSlot)]
xs) JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
a)
fun :: [(Id, Int, Bool)] -> G JStat
fun [(Id, Int, Bool)]
free = G JStat -> G JStat
forall a. G a -> G a
resetSlots (G JStat -> G JStat) -> G JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ do
JStat
decs <- Id -> G JStat
declVarsForId Id
e
JStat
load <- ([JExpr] -> [JExpr] -> JStat) -> [JExpr] -> [JExpr] -> JStat
forall a b c. (a -> b -> c) -> b -> a -> c
flip [JExpr] -> [JExpr] -> JStat
assignAll ((StgReg -> JExpr) -> [StgReg] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map StgReg -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [StgReg
R1 ..]) ([JExpr] -> JStat) -> ([Ident] -> [JExpr]) -> [Ident] -> JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident -> JExpr) -> [Ident] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([Ident] -> JStat) -> G [Ident] -> G JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G [Ident]
identsForId Id
e
JStat
loadv <- [Id] -> G JStat
(() :: Constraint) => [Id] -> G JStat
verifyRuntimeReps [Id
e]
JStat
ras <- [(Id, Int, Bool)] -> G JStat
(() :: Constraint) => [(Id, Int, Bool)] -> G JStat
loadRetArgs [(Id, Int, Bool)]
free
JStat
rasv <- [Id] -> G JStat
(() :: Constraint) => [Id] -> G JStat
verifyRuntimeReps (((Id, Int, Bool) -> Id) -> [(Id, Int, Bool)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
x,Int
_,Bool
_)->Id
x) [(Id, Int, Bool)]
free)
JStat
restoreCCS <- G JStat -> G JStat
forall m. Monoid m => G m -> G m
ifProfilingM (G JStat -> G JStat)
-> ([(JExpr, StackSlot)] -> G JStat)
-> [(JExpr, StackSlot)]
-> G JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(JExpr, StackSlot)] -> G JStat
pop_handle_CCS ([(JExpr, StackSlot)] -> G JStat)
-> [(JExpr, StackSlot)] -> G JStat
forall a b. (a -> b) -> a -> b
$ (JExpr, StackSlot) -> [(JExpr, StackSlot)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JExpr
jCurrentCCS, StackSlot
SlotUnknown)
JStat
rlne <- Bool -> Int -> ExprCtx -> G JStat
popLneFrame Bool
False Int
lneLive ExprCtx
ctx'
JStat
rlnev <- [Id] -> G JStat
(() :: Constraint) => [Id] -> G JStat
verifyRuntimeReps [Id]
lneVars
(JStat
alts, ExprResult
_altr) <- (() :: Constraint) =>
ExprCtx
-> Id
-> AltType
-> Maybe [JExpr]
-> [GenStgAlt 'CodeGen]
-> G (JStat, ExprResult)
ExprCtx
-> Id
-> AltType
-> Maybe [JExpr]
-> [GenStgAlt 'CodeGen]
-> G (JStat, ExprResult)
genAlts ExprCtx
ctx' Id
e AltType
at Maybe [JExpr]
forall a. Maybe a
Nothing [GenStgAlt 'CodeGen]
as
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ JStat
decs JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
load JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
loadv JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
ras JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
rasv JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
restoreCCS JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
rlne JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
rlnev JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
alts JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<>
JStat
returnStack
genAlts :: HasDebugCallStack
=> ExprCtx
-> Id
-> AltType
-> Maybe [JExpr]
-> [CgStgAlt]
-> G (JStat, ExprResult)
genAlts :: (() :: Constraint) =>
ExprCtx
-> Id
-> AltType
-> Maybe [JExpr]
-> [GenStgAlt 'CodeGen]
-> G (JStat, ExprResult)
genAlts ExprCtx
ctx Id
e AltType
at Maybe [JExpr]
me [GenStgAlt 'CodeGen]
alts = do
(JStat
st, ExprResult
er) <- case AltType
at of
AltType
PolyAlt -> case [GenStgAlt 'CodeGen]
alts of
[GenStgAlt 'CodeGen
alt] -> (Branch (Maybe JExpr) -> JStat
forall a. Branch a -> JStat
branch_stat (Branch (Maybe JExpr) -> JStat)
-> (Branch (Maybe JExpr) -> ExprResult)
-> Branch (Maybe JExpr)
-> (JStat, 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 JExpr) -> ExprResult
forall a. Branch a -> ExprResult
branch_result) (Branch (Maybe JExpr) -> (JStat, ExprResult))
-> StateT GenState IO (Branch (Maybe JExpr))
-> G (JStat, ExprResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExprCtx
-> Id
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JExpr))
mkAlgBranch ExprCtx
ctx Id
e GenStgAlt 'CodeGen
alt
[GenStgAlt 'CodeGen]
_ -> String -> G (JStat, 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
[JExpr]
ie <- Id -> G [JExpr]
varsForId Id
e
JStat
dids <- [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> StateT GenState IO [JStat] -> G JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> G JStat) -> [Id] -> StateT GenState IO [JStat]
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 JStat
declVarsForId [Id]
[BinderP 'CodeGen]
bs
[JExpr]
bss <- (Id -> G [JExpr]) -> [Id] -> G [JExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM Id -> G [JExpr]
varsForId [Id]
[BinderP 'CodeGen]
bs
(JStat
ej, ExprResult
er) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
expr
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
dids JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JExpr] -> [JExpr] -> JStat
assignAll [JExpr]
bss [JExpr]
ie JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
ej, ExprResult
er)
PrimAlt PrimRep
tc
-> do
[JExpr]
ie <- Id -> G [JExpr]
varsForId Id
e
(ExprResult
r, [Branch (Maybe [JExpr])]
bss) <- ExprCtx
-> [Branch (Maybe [JExpr])]
-> (ExprResult, [Branch (Maybe [JExpr])])
forall a. ExprCtx -> [Branch a] -> (ExprResult, [Branch a])
normalizeBranches ExprCtx
ctx ([Branch (Maybe [JExpr])]
-> (ExprResult, [Branch (Maybe [JExpr])]))
-> StateT GenState IO [Branch (Maybe [JExpr])]
-> StateT GenState IO (ExprResult, [Branch (Maybe [JExpr])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(GenStgAlt 'CodeGen -> StateT GenState IO (Branch (Maybe [JExpr])))
-> [GenStgAlt 'CodeGen]
-> StateT GenState IO [Branch (Maybe [JExpr])]
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 (StateT GenState IO (Branch (Maybe [JExpr]))
-> StateT GenState IO (Branch (Maybe [JExpr]))
forall a. G a -> G a
isolateSlots (StateT GenState IO (Branch (Maybe [JExpr]))
-> StateT GenState IO (Branch (Maybe [JExpr])))
-> (GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe [JExpr])))
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe [JExpr]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprCtx
-> [VarType]
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe [JExpr]))
mkPrimIfBranch ExprCtx
ctx [(() :: Constraint) => PrimRep -> VarType
PrimRep -> VarType
primRepVt PrimRep
tc]) [GenStgAlt 'CodeGen]
alts
[StackSlot] -> G ()
setSlots []
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkSw [JExpr]
ie [Branch (Maybe [JExpr])]
bss, ExprResult
r)
MultiValAlt Int
n
| [GenStgAlt AltCon
_ [BinderP 'CodeGen]
bs CgStgExpr
expr] <- [GenStgAlt 'CodeGen]
alts
-> do
[JExpr]
eids <- Id -> G [JExpr]
varsForId Id
e
JStat
l <- [JExpr] -> [Id] -> Int -> G JStat
loadUbxTup [JExpr]
eids [Id]
[BinderP 'CodeGen]
bs Int
n
(JStat
ej, ExprResult
er) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
expr
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
l JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
ej, ExprResult
er)
AlgAlt TyCon
tc
| [GenStgAlt 'CodeGen
_alt] <- [GenStgAlt 'CodeGen]
alts
, TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc
-> String -> G (JStat, ExprResult)
forall a. HasCallStack => String -> a
panic String
"genAlts: unexpected unboxed tuple"
AlgAlt TyCon
_tc
| Just [JExpr]
es <- Maybe [JExpr]
me
, [GenStgAlt (DataAlt DataCon
dc) [BinderP 'CodeGen]
bs CgStgExpr
expr] <- [GenStgAlt 'CodeGen]
alts
, Bool -> Bool
not (DataCon -> Bool
isUnboxableCon DataCon
dc)
-> do
[[Ident]]
bsi <- (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]
[BinderP 'CodeGen]
bs
(JStat
ej, ExprResult
er) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
ctx CgStgExpr
expr
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Ident] -> [JExpr] -> JStat
declAssignAll ([[Ident]] -> [Ident]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ident]]
bsi) [JExpr]
es JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
ej, ExprResult
er)
AlgAlt TyCon
_tc
| [GenStgAlt 'CodeGen
alt] <- [GenStgAlt 'CodeGen]
alts
-> do
Branch Maybe JExpr
_ JStat
s ExprResult
r <- ExprCtx
-> Id
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JExpr))
mkAlgBranch ExprCtx
ctx Id
e GenStgAlt 'CodeGen
alt
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
s, ExprResult
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
JExpr
i <- Id -> StateT GenState IO JExpr
varForId Id
e
(ExprResult, [Branch (Maybe JExpr)])
nbs <- ExprCtx
-> [Branch (Maybe JExpr)] -> (ExprResult, [Branch (Maybe JExpr)])
forall a. ExprCtx -> [Branch a] -> (ExprResult, [Branch a])
normalizeBranches ExprCtx
ctx ([Branch (Maybe JExpr)] -> (ExprResult, [Branch (Maybe JExpr)]))
-> StateT GenState IO [Branch (Maybe JExpr)]
-> StateT GenState IO (ExprResult, [Branch (Maybe JExpr)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(GenStgAlt 'CodeGen -> StateT GenState IO (Branch (Maybe JExpr)))
-> [GenStgAlt 'CodeGen]
-> StateT GenState IO [Branch (Maybe JExpr)]
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 (StateT GenState IO (Branch (Maybe JExpr))
-> StateT GenState IO (Branch (Maybe JExpr))
forall a. G a -> G a
isolateSlots (StateT GenState IO (Branch (Maybe JExpr))
-> StateT GenState IO (Branch (Maybe JExpr)))
-> (GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JExpr)))
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JExpr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprCtx
-> Id
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JExpr))
mkAlgBranch ExprCtx
ctx Id
e) [GenStgAlt 'CodeGen]
alts
case (ExprResult, [Branch (Maybe JExpr)])
nbs of
(ExprResult
r, [Branch Maybe JExpr
_ JStat
s1 ExprResult
_, Branch Maybe JExpr
_ JStat
s2 ExprResult
_]) -> do
let s :: JStat
s = if DataCon -> Int
dataConTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
then JExpr -> JStat -> JStat -> JStat
IfStat JExpr
i JStat
s1 JStat
s2
else JExpr -> JStat -> JStat -> JStat
IfStat JExpr
i JStat
s2 JStat
s1
[StackSlot] -> G ()
setSlots []
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
s, ExprResult
r)
(ExprResult, [Branch (Maybe JExpr)])
_ -> String -> G (JStat, ExprResult)
forall a. HasCallStack => String -> a
error String
"genAlts: invalid branches for Bool"
AlgAlt TyCon
_tc -> do
JExpr
ei <- Id -> StateT GenState IO JExpr
varForId Id
e
(ExprResult
r, [Branch (Maybe JExpr)]
brs) <- ExprCtx
-> [Branch (Maybe JExpr)] -> (ExprResult, [Branch (Maybe JExpr)])
forall a. ExprCtx -> [Branch a] -> (ExprResult, [Branch a])
normalizeBranches ExprCtx
ctx ([Branch (Maybe JExpr)] -> (ExprResult, [Branch (Maybe JExpr)]))
-> StateT GenState IO [Branch (Maybe JExpr)]
-> StateT GenState IO (ExprResult, [Branch (Maybe JExpr)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(GenStgAlt 'CodeGen -> StateT GenState IO (Branch (Maybe JExpr)))
-> [GenStgAlt 'CodeGen]
-> StateT GenState IO [Branch (Maybe JExpr)]
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 (StateT GenState IO (Branch (Maybe JExpr))
-> StateT GenState IO (Branch (Maybe JExpr))
forall a. G a -> G a
isolateSlots (StateT GenState IO (Branch (Maybe JExpr))
-> StateT GenState IO (Branch (Maybe JExpr)))
-> (GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JExpr)))
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JExpr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprCtx
-> Id
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JExpr))
mkAlgBranch ExprCtx
ctx Id
e) [GenStgAlt 'CodeGen]
alts
[StackSlot] -> G ()
setSlots []
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JExpr -> [Branch (Maybe JExpr)] -> JStat
mkSwitch (JExpr
ei JExpr -> FastString -> JExpr
.^ FastString
"f" JExpr -> FastString -> JExpr
.^ FastString
"a") [Branch (Maybe JExpr)]
brs, ExprResult
r)
AltType
_ -> String -> SDoc -> G (JStat, 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))
JStat
ver <- (() :: Constraint) => Id -> AltType -> G JStat
Id -> AltType -> G JStat
verifyMatchRep Id
e AltType
at
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStat
ver JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
st, ExprResult
er)
verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStat
verifyMatchRep :: (() :: Constraint) => Id -> AltType -> G JStat
verifyMatchRep Id
x AltType
alt = do
Bool
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 Bool -> Bool
not Bool
runtime_assert
then JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStat
forall a. Monoid a => a
mempty
else case AltType
alt of
AlgAlt TyCon
tc -> do
[JExpr]
ix <- Id -> G [JExpr]
varsForId Id
x
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$verify_match_alg") (JVal -> JExpr
ValExpr(FastString -> JVal
JStr(String -> FastString
mkFastString (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc))))JExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
:[JExpr]
ix)
AltType
_ -> JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStat
forall a. Monoid a => a
mempty
data Branch a = Branch
{ forall a. Branch a -> a
branch_expr :: a
, forall a. Branch a -> JStat
branch_stat :: JStat
, 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
(() :: Constraint) => [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 =
(Maybe [JExpr] -> ExprResult
ExprInline Maybe [JExpr]
forall a. Maybe a
Nothing, [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
ExprInline{} -> Branch a
b { branch_stat = branch_stat b <> assignAll jsRegsFromR1
(concatMap typex_expr $ ctxTarget ctx)
, branch_result = ExprCont
}
ExprResult
_ -> Branch a
b
loadUbxTup :: [JExpr] -> [Id] -> Int -> G JStat
loadUbxTup :: [JExpr] -> [Id] -> Int -> G JStat
loadUbxTup [JExpr]
es [Id]
bs Int
_n = do
[Ident]
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
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ [Ident] -> [JExpr] -> JStat
declAssignAll [Ident]
bs' [JExpr]
es
mkSw :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkSw :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkSw [JExpr
e] [Branch (Maybe [JExpr])]
cases = JExpr -> [Branch (Maybe JExpr)] -> JStat
mkSwitch JExpr
e ((Branch (Maybe [JExpr]) -> Branch (Maybe JExpr))
-> [Branch (Maybe [JExpr])] -> [Branch (Maybe JExpr)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe [JExpr] -> Maybe JExpr)
-> Branch (Maybe [JExpr]) -> Branch (Maybe JExpr)
forall a b. (a -> b) -> Branch a -> Branch b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([JExpr] -> JExpr) -> Maybe [JExpr] -> Maybe JExpr
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [JExpr] -> JExpr
forall a. HasCallStack => [a] -> a
head)) [Branch (Maybe [JExpr])]
cases)
mkSw [JExpr]
es [Branch (Maybe [JExpr])]
cases = [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkIfElse [JExpr]
es [Branch (Maybe [JExpr])]
cases
mkSwitch :: JExpr -> [Branch (Maybe JExpr)] -> JStat
mkSwitch :: JExpr -> [Branch (Maybe JExpr)] -> JStat
mkSwitch JExpr
e [Branch (Maybe JExpr)]
cases
| [Branch (Just JExpr
c1) JStat
s1 ExprResult
_] <- [Branch (Maybe JExpr)]
n
, [Branch Maybe JExpr
_ JStat
s2 ExprResult
_] <- [Branch (Maybe JExpr)]
d
= JExpr -> JStat -> JStat -> JStat
IfStat (JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
StrictEqOp JExpr
e JExpr
c1) JStat
s1 JStat
s2
| [Branch (Just JExpr
c1) JStat
s1 ExprResult
_, Branch Maybe JExpr
_ JStat
s2 ExprResult
_] <- [Branch (Maybe JExpr)]
n
, [Branch (Maybe JExpr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Branch (Maybe JExpr)]
d
= JExpr -> JStat -> JStat -> JStat
IfStat (JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
StrictEqOp JExpr
e JExpr
c1) JStat
s1 JStat
s2
| [Branch (Maybe JExpr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Branch (Maybe JExpr)]
d
= JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
e ((Branch (Maybe JExpr) -> (JExpr, JStat))
-> [Branch (Maybe JExpr)] -> [(JExpr, JStat)]
forall a b. (a -> b) -> [a] -> [b]
map Branch (Maybe JExpr) -> (JExpr, JStat)
forall {a}. Branch (Maybe a) -> (a, JStat)
addBreak ([Branch (Maybe JExpr)] -> [Branch (Maybe JExpr)]
forall a. HasCallStack => [a] -> [a]
init [Branch (Maybe JExpr)]
n)) (Branch (Maybe JExpr) -> JStat
forall a. Branch a -> JStat
branch_stat ([Branch (Maybe JExpr)] -> Branch (Maybe JExpr)
forall a. HasCallStack => [a] -> a
last [Branch (Maybe JExpr)]
n))
| [Branch Maybe JExpr
_ JStat
d0 ExprResult
_] <- [Branch (Maybe JExpr)]
d
= JExpr -> [(JExpr, JStat)] -> JStat -> JStat
SwitchStat JExpr
e ((Branch (Maybe JExpr) -> (JExpr, JStat))
-> [Branch (Maybe JExpr)] -> [(JExpr, JStat)]
forall a b. (a -> b) -> [a] -> [b]
map Branch (Maybe JExpr) -> (JExpr, JStat)
forall {a}. Branch (Maybe a) -> (a, JStat)
addBreak [Branch (Maybe JExpr)]
n) JStat
d0
| Bool
otherwise = String -> JStat
forall a. HasCallStack => String -> a
panic String
"mkSwitch: multiple default cases"
where
addBreak :: Branch (Maybe a) -> (a, JStat)
addBreak (Branch (Just a
c) JStat
s ExprResult
_) = (a
c, [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat
s, Maybe JsLabel -> JStat
BreakStat Maybe JsLabel
forall a. Maybe a
Nothing])
addBreak Branch (Maybe a)
_ = String -> (a, JStat)
forall a. HasCallStack => String -> a
panic String
"mkSwitch: addBreak"
([Branch (Maybe JExpr)]
n,[Branch (Maybe JExpr)]
d) = (Branch (Maybe JExpr) -> Bool)
-> [Branch (Maybe JExpr)]
-> ([Branch (Maybe JExpr)], [Branch (Maybe JExpr)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Maybe JExpr -> Bool
forall a. Maybe a -> Bool
isJust (Maybe JExpr -> Bool)
-> (Branch (Maybe JExpr) -> Maybe JExpr)
-> Branch (Maybe JExpr)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch (Maybe JExpr) -> Maybe JExpr
forall a. Branch a -> a
branch_expr) [Branch (Maybe JExpr)]
cases
mkIfElse :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkIfElse :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
mkIfElse [JExpr]
e [Branch (Maybe [JExpr])]
s = [Branch (Maybe [JExpr])] -> JStat
go ([Branch (Maybe [JExpr])] -> [Branch (Maybe [JExpr])]
forall a. [a] -> [a]
L.reverse [Branch (Maybe [JExpr])]
s)
where
go :: [Branch (Maybe [JExpr])] -> JStat
go = \case
[Branch Maybe [JExpr]
_ JStat
s ExprResult
_] -> JStat
s
(Branch (Just [JExpr]
e0) JStat
s ExprResult
_ : [Branch (Maybe [JExpr])]
xs) -> JExpr -> JStat -> JStat -> JStat
IfStat ([JExpr] -> [JExpr] -> JExpr
mkEq [JExpr]
e [JExpr]
e0) JStat
s ([Branch (Maybe [JExpr])] -> JStat
go [Branch (Maybe [JExpr])]
xs)
[] -> String -> JStat
forall a. HasCallStack => String -> a
panic String
"mkIfElse: empty expression list"
[Branch (Maybe [JExpr])]
_ -> String -> JStat
forall a. HasCallStack => String -> a
panic String
"mkIfElse: multiple DEFAULT cases"
mkEq :: [JExpr] -> [JExpr] -> JExpr
mkEq :: [JExpr] -> [JExpr] -> JExpr
mkEq [JExpr]
es1 [JExpr]
es2
| [JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
es1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
es2 = (JExpr -> JExpr -> JExpr) -> [JExpr] -> JExpr
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
LAndOp) ((JExpr -> JExpr -> JExpr) -> [JExpr] -> [JExpr] -> [JExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
StrictEqOp) [JExpr]
es1 [JExpr]
es2)
| Bool
otherwise = String -> JExpr
forall a. HasCallStack => String -> a
panic String
"mkEq: incompatible expressions"
mkAlgBranch :: ExprCtx
-> Id
-> CgStgAlt
-> G (Branch (Maybe JExpr))
mkAlgBranch :: ExprCtx
-> Id
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe JExpr))
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
JExpr
idd <- Id -> StateT GenState IO JExpr
varForId Id
d
[Ident]
fldx <- Id -> G [Ident]
identsForId Id
BinderP 'CodeGen
b
case [Ident]
fldx of
[Ident
fld] -> do
(JStat
ej, ExprResult
er) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
top (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
Branch (Maybe JExpr) -> StateT GenState IO (Branch (Maybe JExpr))
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe JExpr -> JStat -> ExprResult -> Branch (Maybe JExpr)
forall a. a -> JStat -> ExprResult -> Branch a
Branch Maybe JExpr
forall a. Maybe a
Nothing ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [Ident
fld Ident -> JExpr -> JStat
||= JExpr
idd, JStat
ej]) ExprResult
er)
[Ident]
_ -> String -> StateT GenState IO (Branch (Maybe JExpr))
forall a. HasCallStack => String -> a
panic String
"mkAlgBranch: invalid size"
| Bool
otherwise
= do
Maybe JExpr
cc <- AltCon -> G (Maybe JExpr)
caseCond (GenStgAlt 'CodeGen -> AltCon
forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt 'CodeGen
alt)
JExpr
idd <- Id -> StateT GenState IO JExpr
varForId Id
d
JStat
b <- JExpr -> [Id] -> G JStat
loadParams JExpr
idd (GenStgAlt 'CodeGen -> [BinderP 'CodeGen]
forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs GenStgAlt 'CodeGen
alt)
(JStat
ej, ExprResult
er) <- (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
top (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
Branch (Maybe JExpr) -> StateT GenState IO (Branch (Maybe JExpr))
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe JExpr -> JStat -> ExprResult -> Branch (Maybe JExpr)
forall a. a -> JStat -> ExprResult -> Branch a
Branch Maybe JExpr
cc (JStat
b JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
ej) ExprResult
er)
mkPrimIfBranch :: ExprCtx
-> [VarType]
-> CgStgAlt
-> G (Branch (Maybe [JExpr]))
mkPrimIfBranch :: ExprCtx
-> [VarType]
-> GenStgAlt 'CodeGen
-> StateT GenState IO (Branch (Maybe [JExpr]))
mkPrimIfBranch ExprCtx
top [VarType]
_vt GenStgAlt 'CodeGen
alt =
(\Maybe [JExpr]
ic (JStat
ej,ExprResult
er) -> Maybe [JExpr] -> JStat -> ExprResult -> Branch (Maybe [JExpr])
forall a. a -> JStat -> ExprResult -> Branch a
Branch Maybe [JExpr]
ic JStat
ej ExprResult
er) (Maybe [JExpr] -> (JStat, ExprResult) -> Branch (Maybe [JExpr]))
-> StateT GenState IO (Maybe [JExpr])
-> StateT
GenState IO ((JStat, ExprResult) -> Branch (Maybe [JExpr]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AltCon -> StateT GenState IO (Maybe [JExpr])
ifCond (GenStgAlt 'CodeGen -> AltCon
forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con GenStgAlt 'CodeGen
alt) StateT GenState IO ((JStat, ExprResult) -> Branch (Maybe [JExpr]))
-> G (JStat, ExprResult)
-> StateT GenState IO (Branch (Maybe [JExpr]))
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
<*> (() :: Constraint) => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
genExpr ExprCtx
top (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
ifCond :: AltCon -> G (Maybe [JExpr])
ifCond :: AltCon -> StateT GenState IO (Maybe [JExpr])
ifCond = \case
DataAlt DataCon
da -> Maybe [JExpr] -> StateT GenState IO (Maybe [JExpr])
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [JExpr] -> StateT GenState IO (Maybe [JExpr]))
-> Maybe [JExpr] -> StateT GenState IO (Maybe [JExpr])
forall a b. (a -> b) -> a -> b
$ [JExpr] -> Maybe [JExpr]
forall a. a -> Maybe a
Just [Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (DataCon -> Int
dataConTag DataCon
da)]
LitAlt Literal
l -> [JExpr] -> Maybe [JExpr]
forall a. a -> Maybe a
Just ([JExpr] -> Maybe [JExpr])
-> G [JExpr] -> StateT GenState IO (Maybe [JExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (() :: Constraint) => Literal -> G [JExpr]
Literal -> G [JExpr]
genLit Literal
l
AltCon
DEFAULT -> Maybe [JExpr] -> StateT GenState IO (Maybe [JExpr])
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [JExpr]
forall a. Maybe a
Nothing
caseCond :: AltCon -> G (Maybe JExpr)
caseCond :: AltCon -> G (Maybe JExpr)
caseCond = \case
AltCon
DEFAULT -> Maybe JExpr -> G (Maybe JExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JExpr
forall a. Maybe a
Nothing
DataAlt DataCon
da -> Maybe JExpr -> G (Maybe JExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe JExpr -> G (Maybe JExpr)) -> Maybe JExpr -> G (Maybe JExpr)
forall a b. (a -> b) -> a -> b
$ JExpr -> Maybe JExpr
forall a. a -> Maybe a
Just (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Int -> JExpr) -> Int -> JExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dataConTag DataCon
da)
LitAlt Literal
l -> (() :: Constraint) => Literal -> G [JExpr]
Literal -> G [JExpr]
genLit Literal
l G [JExpr] -> ([JExpr] -> G (Maybe JExpr)) -> G (Maybe JExpr)
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
[JExpr
e] -> Maybe JExpr -> G (Maybe JExpr)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JExpr -> Maybe JExpr
forall a. a -> Maybe a
Just JExpr
e)
[JExpr]
es -> String -> SDoc -> G (Maybe JExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"caseCond: expected single-variable literal" ([JExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [JExpr]
es)
loadParams :: JExpr -> [Id] -> G JStat
loadParams :: JExpr -> [Id] -> G JStat
loadParams JExpr
from [Id]
args = do
[(Ident, Bool)]
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
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ case [(Ident, Bool)]
as of
[] -> JStat
forall a. Monoid a => a
mempty
[(Ident
x,Bool
u)] -> JExpr -> Ident -> Bool -> JStat
loadIfUsed (JExpr
from JExpr -> FastString -> JExpr
.^ FastString
closureField1_) Ident
x Bool
u
[(Ident
x1,Bool
u1),(Ident
x2,Bool
u2)] -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ JExpr -> Ident -> Bool -> JStat
loadIfUsed (JExpr
from JExpr -> FastString -> JExpr
.^ FastString
closureField1_) Ident
x1 Bool
u1
, JExpr -> Ident -> Bool -> JStat
loadIfUsed (JExpr
from JExpr -> FastString -> JExpr
.^ FastString
closureField2_) Ident
x2 Bool
u2
]
((Ident
x,Bool
u):[(Ident, Bool)]
xs) -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ JExpr -> Ident -> Bool -> JStat
loadIfUsed (JExpr
from JExpr -> FastString -> JExpr
.^ FastString
closureField1_) Ident
x Bool
u
, (JExpr -> JStat) -> JStat
forall a. ToSat a => a -> JStat
jVar (\JExpr
d -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [ JExpr
d JExpr -> JExpr -> JStat
|= JExpr
from JExpr -> FastString -> JExpr
.^ FastString
closureField2_
, JExpr -> [(Ident, Bool)] -> JStat
loadConVarsIfUsed JExpr
d [(Ident, Bool)]
xs
])
]
where
use :: [Bool]
use = Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True
loadIfUsed :: JExpr -> Ident -> Bool -> JStat
loadIfUsed JExpr
fr Ident
tgt Bool
True = Ident
tgt Ident -> JExpr -> JStat
||= JExpr
fr
loadIfUsed JExpr
_ Ident
_ Bool
_ = JStat
forall a. Monoid a => a
mempty
loadConVarsIfUsed :: JExpr -> [(Ident, Bool)] -> JStat
loadConVarsIfUsed JExpr
fr [(Ident, Bool)]
cs = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> [JStat] -> JStat
forall a b. (a -> b) -> a -> b
$ ((Ident, Bool) -> Int -> JStat)
-> [(Ident, Bool)] -> [Int] -> [JStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Ident, Bool) -> Int -> JStat
f [(Ident, Bool)]
cs [(Int
1::Int)..]
where f :: (Ident, Bool) -> Int -> JStat
f (Ident
x,Bool
u) Int
n = JExpr -> Ident -> Bool -> JStat
loadIfUsed (JExpr -> Ident -> JExpr
SelExpr JExpr
fr (FastString -> Ident
TxtI (Int -> FastString
dataFieldName Int
n))) Ident
x Bool
u
branchResult :: HasDebugCallStack => [ExprResult] -> ExprResult
branchResult :: (() :: Constraint) => [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 -> Maybe [JExpr] -> ExprResult
ExprInline Maybe [JExpr]
forall a. Maybe a
Nothing
pushRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> JExpr -> G JStat
pushRetArgs :: (() :: Constraint) => [(Id, Int, Bool)] -> JExpr -> G JStat
pushRetArgs [(Id, Int, Bool)]
free JExpr
fun = do
[(JExpr, Bool)]
rs <- ((Id, Int, Bool) -> StateT GenState IO (JExpr, Bool))
-> [(Id, Int, Bool)] -> StateT GenState IO [(JExpr, 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) -> (\[JExpr]
es->([JExpr]
es[JExpr] -> Int -> JExpr
forall a. HasCallStack => [a] -> Int -> a
!!(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1),Bool
b)) ([JExpr] -> (JExpr, Bool))
-> G [JExpr] -> StateT GenState IO (JExpr, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (() :: Constraint) => Id -> G [JExpr]
Id -> G [JExpr]
genIdArg Id
i) [(Id, Int, Bool)]
free
[(JExpr, Bool)] -> G JStat
pushOptimized ([(JExpr, Bool)]
rs[(JExpr, Bool)] -> [(JExpr, Bool)] -> [(JExpr, Bool)]
forall a. [a] -> [a] -> [a]
++[(JExpr
fun,Bool
False)])
loadRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> G JStat
loadRetArgs :: (() :: Constraint) => [(Id, Int, Bool)] -> G JStat
loadRetArgs [(Id, Int, Bool)]
free = do
[(Ident, StackSlot)]
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
<$> (() :: Constraint) => Id -> StateT GenState IO [(Ident, StackSlot)]
Id -> StateT GenState IO [(Ident, StackSlot)]
genIdStackArgI Id
i) [(Id, Int, Bool)]
free
Int -> [(Ident, StackSlot)] -> G JStat
popSkipI Int
1 [(Ident, StackSlot)]
ids
allocDynAll :: Bool -> Maybe JStat -> [(Ident,JExpr,[JExpr],CostCentreStack)] -> G JStat
allocDynAll :: Bool
-> Maybe JStat
-> [(Ident, JExpr, [JExpr], CostCentreStack)]
-> G JStat
allocDynAll Bool
haveDecl Maybe JStat
middle [(Ident, JExpr, [JExpr], CostCentreStack)]
cls = do
StgToJSConfig
settings <- StateT GenState IO StgToJSConfig
getSettings
let
middle' :: JStat
middle' = JStat -> Maybe JStat -> JStat
forall a. a -> Maybe a -> a
fromMaybe JStat
forall a. Monoid a => a
mempty Maybe JStat
middle
decl_maybe :: Ident -> JExpr -> JStat
decl_maybe Ident
i JExpr
e
| Bool
haveDecl = Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> JExpr -> JStat
|= JExpr
e
| Bool
otherwise = Ident
i Ident -> JExpr -> JStat
||= JExpr
e
makeObjs :: G JStat
makeObjs :: G JStat
makeObjs =
([JStat] -> JStat) -> StateT GenState IO [JStat] -> G JStat
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 [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat (StateT GenState IO [JStat] -> G JStat)
-> StateT GenState IO [JStat] -> G JStat
forall a b. (a -> b) -> a -> b
$ [(Ident, JExpr, [JExpr], CostCentreStack)]
-> ((Ident, JExpr, [JExpr], CostCentreStack) -> G JStat)
-> StateT GenState IO [JStat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Ident, JExpr, [JExpr], CostCentreStack)]
cls (((Ident, JExpr, [JExpr], CostCentreStack) -> G JStat)
-> StateT GenState IO [JStat])
-> ((Ident, JExpr, [JExpr], CostCentreStack) -> G JStat)
-> StateT GenState IO [JStat]
forall a b. (a -> b) -> a -> b
$ \(Ident
i,JExpr
f,[JExpr]
_,CostCentreStack
cc) -> do
[Ident]
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
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ Ident -> JExpr -> JStat
decl_maybe Ident
i (JExpr -> JStat) -> JExpr -> JStat
forall a b. (a -> b) -> a -> b
$ if StgToJSConfig -> Bool
csInlineAlloc StgToJSConfig
settings
then JVal -> JExpr
ValExpr ([(FastString, JExpr)] -> JVal
jhFromList ([(FastString, JExpr)] -> JVal) -> [(FastString, JExpr)] -> JVal
forall a b. (a -> b) -> a -> b
$ [ (FastString
closureEntry_ , JExpr
f)
, (FastString
closureField1_, JExpr
null_)
, (FastString
closureField2_, JExpr
null_)
, (FastString
closureMeta_ , JExpr
zero_)
]
[(FastString, JExpr)]
-> [(FastString, JExpr)] -> [(FastString, JExpr)]
forall a. [a] -> [a] -> [a]
++ (Ident -> (FastString, JExpr)) -> [Ident] -> [(FastString, JExpr)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Ident
cid -> (FastString
"cc", JVal -> JExpr
ValExpr (Ident -> JVal
JVar Ident
cid))) [Ident]
ccs)
else JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$c") (JExpr
f JExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
: (Ident -> JExpr) -> [Ident] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (JVal -> JExpr
ValExpr (JVal -> JExpr) -> (Ident -> JVal) -> Ident -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar) [Ident]
ccs)
]
fillObjs :: JStat
fillObjs = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> [JStat] -> JStat
forall a b. (a -> b) -> a -> b
$ ((Ident, JExpr, [JExpr], CostCentreStack) -> JStat)
-> [(Ident, JExpr, [JExpr], CostCentreStack)] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, JExpr, [JExpr], CostCentreStack) -> JStat
fillObj [(Ident, JExpr, [JExpr], CostCentreStack)]
cls
fillObj :: (Ident, JExpr, [JExpr], CostCentreStack) -> JStat
fillObj (Ident
i,JExpr
_,[JExpr]
es,CostCentreStack
_)
| StgToJSConfig -> Bool
csInlineAlloc StgToJSConfig
settings Bool -> Bool -> Bool
|| [JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
es Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
24 =
case [JExpr]
es of
[] -> JStat
forall a. Monoid a => a
mempty
[JExpr
ex] -> Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
ex
[JExpr
e1,JExpr
e2] -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
e1
, Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField2_ JExpr -> JExpr -> JStat
|= JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
e2
]
(JExpr
ex:[JExpr]
es) -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
ex
, Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField2_ JExpr -> JExpr -> JStat
|= JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([(FastString, JExpr)] -> JVal
jhFromList ([FastString] -> [JExpr] -> [(FastString, JExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FastString]
dataFieldNames [JExpr]
es))
]
| Bool
otherwise = case [JExpr]
es of
[] -> JStat
forall a. Monoid a => a
mempty
[JExpr
ex] -> Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= JExpr
ex
[JExpr
e1,JExpr
e2] -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= JExpr
e1
, Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField2_ JExpr -> JExpr -> JStat
|= JExpr
e2
]
(JExpr
ex:[JExpr]
es) -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
[ Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= JExpr
ex
, Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i JExpr -> FastString -> JExpr
.^ FastString
closureField2_ JExpr -> JExpr -> JStat
|= [JExpr] -> JExpr
fillFun [JExpr]
es
]
fillFun :: [JExpr] -> JExpr
fillFun [] = JExpr
null_
fillFun [JExpr]
es = JExpr -> [JExpr] -> JExpr
ApplExpr (Int -> JExpr
allocData ([JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
es)) [JExpr]
es
checkObjs :: JStat
checkObjs | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
settings = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> [JStat] -> JStat
forall a b. (a -> b) -> a -> b
$
((Ident, JExpr, [JExpr], CostCentreStack) -> JStat)
-> [(Ident, JExpr, [JExpr], CostCentreStack)] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
map (\(Ident
i,JExpr
_,[JExpr]
_,CostCentreStack
_) -> JExpr -> [JExpr] -> JStat
ApplStat (JVal -> JExpr
ValExpr (Ident -> JVal
JVar (FastString -> Ident
TxtI FastString
"h$checkObj"))) [Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
i]) [(Ident, JExpr, [JExpr], CostCentreStack)]
cls
| Bool
otherwise = JStat
forall a. Monoid a => a
mempty
JStat
objs <- G JStat
makeObjs
JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat
objs, JStat
middle', JStat
fillObjs, JStat
checkObjs]
genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult)
genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult)
genPrimOp ExprCtx
ctx PrimOp
op [StgArg]
args Type
t = do
[JExpr]
as <- (StgArg -> G [JExpr]) -> [StgArg] -> G [JExpr]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (() :: Constraint) => StgArg -> G [JExpr]
StgArg -> G [JExpr]
genArg [StgArg]
args
Bool
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
Bool
bound <- StgToJSConfig -> Bool
csBoundsCheck (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
(JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((JStat, ExprResult) -> G (JStat, ExprResult))
-> (JStat, ExprResult) -> G (JStat, ExprResult)
forall a b. (a -> b) -> a -> b
$ case Bool -> Bool -> Type -> PrimOp -> [JExpr] -> [JExpr] -> PrimRes
genPrim Bool
prof Bool
bound Type
t PrimOp
op ((TypedExpr -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr ([TypedExpr] -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [JExpr]
as of
PrimInline JStat
s -> (JStat
s, Maybe [JExpr] -> ExprResult
ExprInline Maybe [JExpr]
forall a. Maybe a
Nothing)
PRPrimCall JStat
s -> (JStat
s, ExprResult
ExprCont)