{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.StgToJS.Arg
( genArg
, genIdArg
, genIdArgI
, genIdStackArgI
, allocConStatic
, allocUnboxedConStatic
, allocateStaticList
, jsStaticArg
, jsStaticArgs
)
where
import GHC.Prelude
import GHC.JS.JStg.Syntax
import GHC.JS.Ident
import GHC.JS.Make
import GHC.StgToJS.DataCon
import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.Literal
import GHC.StgToJS.Utils
import GHC.StgToJS.Profiling
import GHC.StgToJS.Ids
import GHC.Builtin.Types
import GHC.Stg.Syntax
import GHC.Core.DataCon
import GHC.Types.CostCentre
import GHC.Types.Unique.FM
import GHC.Types.Id
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import qualified Control.Monad.Trans.State.Strict as State
genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg]
genStaticArg StgArg
a = case StgArg
a of
StgLitArg Literal
l -> (StaticLit -> StaticArg) -> [StaticLit] -> [StaticArg]
forall a b. (a -> b) -> [a] -> [b]
map StaticLit -> StaticArg
StaticLitArg ([StaticLit] -> [StaticArg])
-> StateT GenState IO [StaticLit] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal -> StateT GenState IO [StaticLit]
genStaticLit Literal
l
StgVarArg Id
i -> do
unFloat <- (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
case lookupUFM unFloat i of
Maybe CgStgExpr
Nothing -> G [StaticArg]
reg
Just CgStgExpr
expr -> CgStgExpr -> G [StaticArg]
unfloated CgStgExpr
expr
where
r :: JSRep
r = HasDebugCallStack => PrimOrVoidRep -> JSRep
PrimOrVoidRep -> JSRep
primOrVoidRepToJSRep (PrimOrVoidRep -> JSRep) -> PrimOrVoidRep -> JSRep
forall a b. (a -> b) -> a -> b
$ StgArg -> PrimOrVoidRep
stgArgRep1 StgArg
a
reg :: G [StaticArg]
reg
| JSRep -> Bool
isVoid JSRep
r =
[StaticArg] -> G [StaticArg]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Id
i Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
trueDataConId =
[StaticArg] -> G [StaticArg]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [StaticLit -> StaticArg
StaticLitArg (Bool -> StaticLit
BoolLit Bool
True)]
| Id
i Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
falseDataConId =
[StaticArg] -> G [StaticArg]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [StaticLit -> StaticArg
StaticLitArg (Bool -> StaticLit
BoolLit Bool
False)]
| JSRep -> Bool
isMultiVar JSRep
r =
(Ident -> StaticArg) -> [Ident] -> [StaticArg]
forall a b. (a -> b) -> [a] -> [b]
map (\(Ident -> FastString
identFS -> FastString
t) -> FastString -> StaticArg
StaticObjArg FastString
t) ([Ident] -> [StaticArg])
-> StateT GenState IO [Ident] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConTag -> StateT GenState IO Ident)
-> [ConTag] -> 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 -> ConTag -> StateT GenState IO Ident
identForIdN Id
i) [ConTag
1..JSRep -> ConTag
varSize JSRep
r]
| Bool
otherwise = (\(Ident -> FastString
identFS -> FastString
it) -> [FastString -> StaticArg
StaticObjArg FastString
it]) (Ident -> [StaticArg]) -> StateT GenState IO Ident -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i
unfloated :: CgStgExpr -> G [StaticArg]
unfloated :: CgStgExpr -> G [StaticArg]
unfloated (StgLit Literal
l) = (StaticLit -> StaticArg) -> [StaticLit] -> [StaticArg]
forall a b. (a -> b) -> [a] -> [b]
map StaticLit -> StaticArg
StaticLitArg ([StaticLit] -> [StaticArg])
-> StateT GenState IO [StaticLit] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal -> StateT GenState IO [StaticLit]
genStaticLit Literal
l
unfloated (StgConApp DataCon
dc ConstructorNumber
_n [StgArg]
args [[PrimRep]]
_)
| DataCon -> Bool
isBoolDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxableCon DataCon
dc =
(StaticArg -> [StaticArg] -> [StaticArg]
forall a. a -> [a] -> [a]
:[]) (StaticArg -> [StaticArg])
-> ([[StaticArg]] -> StaticArg) -> [[StaticArg]] -> [StaticArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [StaticArg] -> StaticArg
allocUnboxedConStatic DataCon
dc ([StaticArg] -> StaticArg)
-> ([[StaticArg]] -> [StaticArg]) -> [[StaticArg]] -> StaticArg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[StaticArg]] -> [StaticArg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[StaticArg]] -> [StaticArg])
-> StateT GenState IO [[StaticArg]] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [StaticArg])
-> [StgArg] -> StateT GenState IO [[StaticArg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [StaticArg]
StgArg -> G [StaticArg]
genStaticArg [StgArg]
args
| [StgArg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StgArg]
args = (\(Ident -> FastString
identFS -> FastString
t) -> [FastString -> StaticArg
StaticObjArg FastString
t]) (Ident -> [StaticArg]) -> StateT GenState IO Ident -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId (DataCon -> Id
dataConWorkId DataCon
dc)
| Bool
otherwise = do
as <- [[StaticArg]] -> [StaticArg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[StaticArg]] -> [StaticArg])
-> StateT GenState IO [[StaticArg]] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [StaticArg])
-> [StgArg] -> StateT GenState IO [[StaticArg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [StaticArg]
StgArg -> G [StaticArg]
genStaticArg [StgArg]
args
e <- identFS <$> identForDataConWorker dc
return [StaticConArg e as]
unfloated CgStgExpr
x = String -> SDoc -> G [StaticArg]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genArg: unexpected unfloated expression" (StgPprOpts -> CgStgExpr -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts CgStgExpr
x)
genArg :: HasDebugCallStack => StgArg -> G [JStgExpr]
genArg :: HasDebugCallStack => StgArg -> G [JStgExpr]
genArg StgArg
a = case StgArg
a of
StgLitArg Literal
l -> HasDebugCallStack => Literal -> G [JStgExpr]
Literal -> G [JStgExpr]
genLit Literal
l
StgVarArg Id
i -> do
unFloat <- (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
case lookupUFM unFloat i of
Just CgStgExpr
expr -> HasDebugCallStack => CgStgExpr -> G [JStgExpr]
CgStgExpr -> G [JStgExpr]
unfloated CgStgExpr
expr
Maybe CgStgExpr
Nothing
| JSRep -> Bool
isVoid JSRep
HasDebugCallStack => JSRep
r -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Id
i Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
trueDataConId -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [JStgExpr
true_]
| Id
i Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
falseDataConId -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [JStgExpr
false_]
| JSRep -> Bool
isMultiVar JSRep
HasDebugCallStack => JSRep
r -> (ConTag -> StateT GenState IO JStgExpr) -> [ConTag] -> G [JStgExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id -> ConTag -> StateT GenState IO JStgExpr
varForIdN Id
i) [ConTag
1..JSRep -> ConTag
varSize JSRep
HasDebugCallStack => JSRep
r]
| Bool
otherwise -> (JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
:[]) (JStgExpr -> [JStgExpr])
-> StateT GenState IO JStgExpr -> G [JStgExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO JStgExpr
varForId Id
i
where
r :: HasDebugCallStack => JSRep
r :: HasDebugCallStack => JSRep
r = HasDebugCallStack => PrimOrVoidRep -> JSRep
PrimOrVoidRep -> JSRep
primOrVoidRepToJSRep (PrimOrVoidRep -> JSRep) -> PrimOrVoidRep -> JSRep
forall a b. (a -> b) -> a -> b
$ StgArg -> PrimOrVoidRep
stgArgRep1 StgArg
a
unfloated :: HasDebugCallStack => CgStgExpr -> G [JStgExpr]
unfloated :: HasDebugCallStack => CgStgExpr -> G [JStgExpr]
unfloated = \case
StgLit Literal
l -> HasDebugCallStack => Literal -> G [JStgExpr]
Literal -> G [JStgExpr]
genLit Literal
l
StgConApp DataCon
dc ConstructorNumber
_n [StgArg]
args [[PrimRep]]
_
| DataCon -> Bool
isBoolDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxableCon DataCon
dc
-> (JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
:[]) (JStgExpr -> [JStgExpr])
-> ([[JStgExpr]] -> JStgExpr) -> [[JStgExpr]] -> [JStgExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [JStgExpr] -> JStgExpr
allocUnboxedCon DataCon
dc ([JStgExpr] -> JStgExpr)
-> ([[JStgExpr]] -> [JStgExpr]) -> [[JStgExpr]] -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[JStgExpr]] -> [JStgExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[JStgExpr]] -> [JStgExpr])
-> StateT GenState IO [[JStgExpr]] -> G [JStgExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [JStgExpr])
-> [StgArg] -> StateT GenState IO [[JStgExpr]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg [StgArg]
args
| [StgArg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StgArg]
args -> (JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
:[]) (JStgExpr -> [JStgExpr])
-> StateT GenState IO JStgExpr -> G [JStgExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO JStgExpr
varForId (DataCon -> Id
dataConWorkId DataCon
dc)
| Bool
otherwise -> do
as <- [[JStgExpr]] -> [JStgExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[JStgExpr]] -> [JStgExpr])
-> StateT GenState IO [[JStgExpr]] -> G [JStgExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [JStgExpr])
-> [StgArg] -> StateT GenState IO [[JStgExpr]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg [StgArg]
args
e <- varForDataConWorker dc
inl_alloc <- csInlineAlloc <$> getSettings
return [allocDynamicE inl_alloc e as Nothing]
CgStgExpr
x -> String -> SDoc -> G [JStgExpr]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genArg: unexpected unfloated expression" (StgPprOpts -> CgStgExpr -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts CgStgExpr
x)
genIdArg :: HasDebugCallStack => Id -> G [JStgExpr]
genIdArg :: HasDebugCallStack => Id -> G [JStgExpr]
genIdArg Id
i = HasDebugCallStack => StgArg -> G [JStgExpr]
StgArg -> G [JStgExpr]
genArg (Id -> StgArg
StgVarArg Id
i)
genIdArgI :: HasDebugCallStack => Id -> G [Ident]
genIdArgI :: HasDebugCallStack => Id -> StateT GenState IO [Ident]
genIdArgI Id
i
| JSRep -> Bool
isVoid JSRep
r = [Ident] -> StateT GenState IO [Ident]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
| JSRep -> Bool
isMultiVar JSRep
r = (ConTag -> StateT GenState IO Ident)
-> [ConTag] -> 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 -> ConTag -> StateT GenState IO Ident
identForIdN Id
i) [ConTag
1..JSRep -> ConTag
varSize JSRep
r]
| Bool
otherwise = (Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[]) (Ident -> [Ident])
-> StateT GenState IO Ident -> StateT GenState IO [Ident]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO Ident
identForId Id
i
where
r :: JSRep
r = HasDebugCallStack => UnaryType -> JSRep
UnaryType -> JSRep
unaryTypeJSRep (UnaryType -> JSRep) -> (Id -> UnaryType) -> Id -> JSRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> UnaryType
idType (Id -> JSRep) -> Id -> JSRep
forall a b. (a -> b) -> a -> b
$ Id
i
genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident,StackSlot)]
genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident, StackSlot)]
genIdStackArgI Id
i = (ConTag -> Ident -> (Ident, StackSlot))
-> [ConTag] -> [Ident] -> [(Ident, StackSlot)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ConTag -> Ident -> (Ident, StackSlot)
f [ConTag
1..] ([Ident] -> [(Ident, StackSlot)])
-> StateT GenState IO [Ident] -> G [(Ident, StackSlot)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Id -> StateT GenState IO [Ident]
Id -> StateT GenState IO [Ident]
genIdArgI Id
i
where
f :: Int -> Ident -> (Ident,StackSlot)
f :: ConTag -> Ident -> (Ident, StackSlot)
f ConTag
n Ident
ident = (Ident
ident, Id -> ConTag -> StackSlot
SlotId Id
i ConTag
n)
allocConStatic :: HasDebugCallStack => Ident -> CostCentreStack -> DataCon -> [StgArg] -> G ()
allocConStatic :: HasDebugCallStack =>
Ident -> CostCentreStack -> DataCon -> [StgArg] -> G ()
allocConStatic (Ident -> FastString
identFS -> FastString
to) CostCentreStack
cc DataCon
con [StgArg]
args = do
as <- (StgArg -> G [StaticArg])
-> [StgArg] -> StateT GenState IO [[StaticArg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [StaticArg]
StgArg -> G [StaticArg]
genStaticArg [StgArg]
args
cc' <- costCentreStackLbl cc
allocConStatic' cc' (concat as)
where
allocConStatic' :: HasDebugCallStack => Maybe Ident -> [StaticArg] -> G ()
allocConStatic' :: HasDebugCallStack => Maybe Ident -> [StaticArg] -> G ()
allocConStatic' Maybe Ident
cc' []
| DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> ConTag
dataConTag DataCon
con ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
1 =
FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed (StaticUnboxed -> StaticVal) -> StaticUnboxed -> StaticVal
forall a b. (a -> b) -> a -> b
$ Bool -> StaticUnboxed
StaticUnboxedBool Bool
False) Maybe Ident
cc'
| DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> ConTag
dataConTag DataCon
con ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
2 =
FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed (StaticUnboxed -> StaticVal) -> StaticUnboxed -> StaticVal
forall a b. (a -> b) -> a -> b
$ Bool -> StaticUnboxed
StaticUnboxedBool Bool
True) Maybe Ident
cc'
| Bool
otherwise = do
e <- Ident -> FastString
identFS (Ident -> FastString)
-> StateT GenState IO Ident -> StateT GenState IO FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon -> StateT GenState IO Ident
identForDataConWorker DataCon
con
emitStatic to (StaticData e []) cc'
allocConStatic' Maybe Ident
cc' [StaticArg
x]
| DataCon -> Bool
isUnboxableCon DataCon
con =
case StaticArg
x of
StaticLitArg (IntLit Integer
i) ->
FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed (StaticUnboxed -> StaticVal) -> StaticUnboxed -> StaticVal
forall a b. (a -> b) -> a -> b
$ Integer -> StaticUnboxed
StaticUnboxedInt Integer
i) Maybe Ident
cc'
StaticLitArg (BoolLit Bool
b) ->
FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed (StaticUnboxed -> StaticVal) -> StaticUnboxed -> StaticVal
forall a b. (a -> b) -> a -> b
$ Bool -> StaticUnboxed
StaticUnboxedBool Bool
b) Maybe Ident
cc'
StaticLitArg (DoubleLit SaneDouble
d) ->
FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to (StaticUnboxed -> StaticVal
StaticUnboxed (StaticUnboxed -> StaticVal) -> StaticUnboxed -> StaticVal
forall a b. (a -> b) -> a -> b
$ SaneDouble -> StaticUnboxed
StaticUnboxedDouble SaneDouble
d) Maybe Ident
cc'
StaticArg
_ ->
String -> SDoc -> G ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocConStatic: invalid unboxed literal" (StaticArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr StaticArg
x)
allocConStatic' Maybe Ident
cc' [StaticArg]
xs =
if DataCon
con DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
consDataCon
then case [StgArg]
args of
(StgArg
a0:StgArg
a1:[StgArg]
_) -> (StaticVal -> Maybe Ident -> G ())
-> Maybe Ident -> StaticVal -> G ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
to) Maybe Ident
cc' (StaticVal -> G ()) -> StateT GenState IO StaticVal -> G ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [StgArg] -> StgArg -> StateT GenState IO StaticVal
allocateStaticList [StgArg
a0] StgArg
a1
[StgArg]
_ -> String -> G ()
forall a. HasCallStack => String -> a
panic String
"allocConStatic: invalid args for consDataCon"
else do
e <- Ident -> FastString
identFS (Ident -> FastString)
-> StateT GenState IO Ident -> StateT GenState IO FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon -> StateT GenState IO Ident
identForDataConWorker DataCon
con
emitStatic to (StaticData e xs) cc'
allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg
allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg
allocUnboxedConStatic DataCon
con = \case
[]
| DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> ConTag
dataConTag DataCon
con ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
1
-> StaticLit -> StaticArg
StaticLitArg (Bool -> StaticLit
BoolLit Bool
False)
| DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> ConTag
dataConTag DataCon
con ConTag -> ConTag -> Bool
forall a. Eq a => a -> a -> Bool
== ConTag
2
-> StaticLit -> StaticArg
StaticLitArg (Bool -> StaticLit
BoolLit Bool
True)
[a :: StaticArg
a@(StaticLitArg (IntLit Integer
_i))] -> StaticArg
a
[a :: StaticArg
a@(StaticLitArg (DoubleLit SaneDouble
_d))] -> StaticArg
a
[StaticArg]
_ -> String -> SDoc -> StaticArg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocUnboxedConStatic: not an unboxed constructor" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con)
allocateStaticList :: [StgArg] -> StgArg -> G StaticVal
allocateStaticList :: [StgArg] -> StgArg -> StateT GenState IO StaticVal
allocateStaticList [StgArg]
xs a :: StgArg
a@(StgVarArg Id
i)
| Id -> Maybe DataCon
isDataConId_maybe Id
i Maybe DataCon -> Maybe DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Maybe DataCon
forall a. a -> Maybe a
Just DataCon
nilDataCon = [StgArg] -> Maybe StgArg -> StateT GenState IO StaticVal
listAlloc [StgArg]
xs Maybe StgArg
forall a. Maybe a
Nothing
| Bool
otherwise = do
unFloat <- (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
case lookupUFM unFloat i of
Just (StgConApp DataCon
dc ConstructorNumber
_n [StgArg
h,StgArg
t] [[PrimRep]]
_)
| DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
consDataCon -> [StgArg] -> StgArg -> StateT GenState IO StaticVal
allocateStaticList (StgArg
hStgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
:[StgArg]
xs) StgArg
t
Maybe CgStgExpr
_ -> [StgArg] -> Maybe StgArg -> StateT GenState IO StaticVal
listAlloc [StgArg]
xs (StgArg -> Maybe StgArg
forall a. a -> Maybe a
Just StgArg
a)
where
listAlloc :: [StgArg] -> Maybe StgArg -> G StaticVal
listAlloc :: [StgArg] -> Maybe StgArg -> StateT GenState IO StaticVal
listAlloc [StgArg]
xs Maybe StgArg
Nothing = do
as <- [[StaticArg]] -> [StaticArg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[StaticArg]] -> [StaticArg])
-> ([[StaticArg]] -> [[StaticArg]]) -> [[StaticArg]] -> [StaticArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[StaticArg]] -> [[StaticArg]]
forall a. [a] -> [a]
reverse ([[StaticArg]] -> [StaticArg])
-> StateT GenState IO [[StaticArg]] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [StaticArg])
-> [StgArg] -> StateT GenState IO [[StaticArg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [StaticArg]
StgArg -> G [StaticArg]
genStaticArg [StgArg]
xs
return (StaticList as Nothing)
listAlloc [StgArg]
xs (Just StgArg
r) = do
as <- [[StaticArg]] -> [StaticArg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[StaticArg]] -> [StaticArg])
-> ([[StaticArg]] -> [[StaticArg]]) -> [[StaticArg]] -> [StaticArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[StaticArg]] -> [[StaticArg]]
forall a. [a] -> [a]
reverse ([[StaticArg]] -> [StaticArg])
-> StateT GenState IO [[StaticArg]] -> G [StaticArg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> G [StaticArg])
-> [StgArg] -> StateT GenState IO [[StaticArg]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HasDebugCallStack => StgArg -> G [StaticArg]
StgArg -> G [StaticArg]
genStaticArg [StgArg]
xs
r' <- genStaticArg r
case r' of
[StaticObjArg FastString
ri] -> StaticVal -> StateT GenState IO StaticVal
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([StaticArg] -> Maybe FastString -> StaticVal
StaticList [StaticArg]
as (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
ri))
[StaticArg]
_ ->
String -> SDoc -> StateT GenState IO StaticVal
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocateStaticList: invalid argument (tail)" (([StgArg], StgArg) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([StgArg]
xs, StgArg
r))
allocateStaticList [StgArg]
_ StgArg
_ = String -> StateT GenState IO StaticVal
forall a. HasCallStack => String -> a
panic String
"allocateStaticList: unexpected literal in list"
jsStaticArg :: StaticArg -> JStgExpr
jsStaticArg :: StaticArg -> JStgExpr
jsStaticArg = \case
StaticLitArg StaticLit
l -> StaticLit -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StaticLit
l
StaticObjArg FastString
t -> FastString -> JStgExpr
global FastString
t
StaticConArg FastString
c [StaticArg]
args ->
Bool -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgExpr
allocDynamicE Bool
False (FastString -> JStgExpr
global FastString
c) ((StaticArg -> JStgExpr) -> [StaticArg] -> [JStgExpr]
forall a b. (a -> b) -> [a] -> [b]
map StaticArg -> JStgExpr
jsStaticArg [StaticArg]
args) Maybe JStgExpr
forall a. Maybe a
Nothing
jsStaticArgs :: [StaticArg] -> JStgExpr
jsStaticArgs :: [StaticArg] -> JStgExpr
jsStaticArgs = JVal -> JStgExpr
ValExpr (JVal -> JStgExpr)
-> ([StaticArg] -> JVal) -> [StaticArg] -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JStgExpr] -> JVal
JList ([JStgExpr] -> JVal)
-> ([StaticArg] -> [JStgExpr]) -> [StaticArg] -> JVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StaticArg -> JStgExpr) -> [StaticArg] -> [JStgExpr]
forall a b. (a -> b) -> [a] -> [b]
map StaticArg -> JStgExpr
jsStaticArg