{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module GHC.StgToJS.DataCon
( genCon
, allocCon
, allocUnboxedCon
, allocDynamicE
, allocDynamic
)
where
import GHC.Prelude
import GHC.JS.JStg.Syntax
import GHC.JS.Ident
import GHC.JS.Make
import GHC.JS.Transform
import GHC.StgToJS.Closure
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.Profiling
import GHC.StgToJS.Utils
import GHC.StgToJS.Ids
import GHC.Core.DataCon
import GHC.Types.CostCentre
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Data.Maybe
genCon :: ExprCtx -> DataCon -> [JStgExpr] -> G JStgStat
genCon :: ExprCtx -> DataCon -> [JStgExpr] -> G JStgStat
genCon ExprCtx
ctx DataCon
con [JStgExpr]
args
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
con
= JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ ExprCtx -> [JStgExpr] -> JStgStat
assignToExprCtx ExprCtx
ctx [JStgExpr]
args
| [Var Ident
ctxi] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TypedExpr -> [JStgExpr]
typex_expr) (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
= Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat
allocCon Ident
ctxi DataCon
con CostCentreStack
currentCCS [JStgExpr]
args
| [JStgExpr]
xs <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx)
= String -> SDoc -> G JStgStat
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genCon: unhandled DataCon" ((DataCon, [JExpr], [JExpr]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon
con
, (JStgExpr -> JExpr) -> [JStgExpr] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map JStgExpr -> JExpr
jStgExprToJS [JStgExpr]
args
, (JStgExpr -> JExpr) -> [JStgExpr] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map JStgExpr -> JExpr
jStgExprToJS [JStgExpr]
xs
))
allocCon :: Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat
allocCon :: Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat
allocCon Ident
to DataCon
con CostCentreStack
cc [JStgExpr]
xs
| DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxableCon DataCon
con =
JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
forall a b. (a -> b) -> a -> b
$ JStgExpr -> AOp -> JStgExpr -> JStgStat
AssignStat (Ident -> JStgExpr
Var Ident
to) AOp
AssignOp (DataCon -> [JStgExpr] -> JStgExpr
allocUnboxedCon DataCon
con [JStgExpr]
xs)
| Bool
otherwise = do
e <- DataCon -> G JStgExpr
varForDataConWorker DataCon
con
cs <- getSettings
prof <- profiling
ccsJ <- if prof then ccsVarJ cc else return Nothing
return $ allocDynamic cs False to e xs ccsJ
allocUnboxedCon :: DataCon -> [JStgExpr] -> JStgExpr
allocUnboxedCon :: DataCon -> [JStgExpr] -> JStgExpr
allocUnboxedCon DataCon
con = \case
[]
| DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> Int
dataConTag DataCon
con Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> JStgExpr
false_
| DataCon -> Bool
isBoolDataCon DataCon
con Bool -> Bool -> Bool
&& DataCon -> Int
dataConTag DataCon
con Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 -> JStgExpr
true_
[JStgExpr
x]
| DataCon -> Bool
isUnboxableCon DataCon
con -> JStgExpr
x
[JStgExpr]
xs -> String -> SDoc -> JStgExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocUnboxedCon: not an unboxed constructor" ((DataCon, [JExpr]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon
con, (JStgExpr -> JExpr) -> [JStgExpr] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map JStgExpr -> JExpr
jStgExprToJS [JStgExpr]
xs))
allocDynamicE :: Bool
-> JStgExpr
-> [JStgExpr]
-> Maybe JStgExpr
-> JStgExpr
allocDynamicE :: Bool -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgExpr
allocDynamicE Bool
inline_alloc JStgExpr
entry [JStgExpr]
free Maybe JStgExpr
cc
| Bool
inline_alloc Bool -> Bool -> Bool
|| [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
free Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
jsClosureCount
= Closure -> JStgExpr
newClosure (Closure -> JStgExpr) -> Closure -> JStgExpr
forall a b. (a -> b) -> a -> b
$ JStgExpr -> [JStgExpr] -> JStgExpr -> Maybe JStgExpr -> Closure
mkClosure JStgExpr
entry [JStgExpr]
free JStgExpr
zero_ Maybe JStgExpr
cc
| Bool
otherwise = JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr JStgExpr
allocFun (JStgExpr
entry JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
: [JStgExpr]
free [JStgExpr] -> [JStgExpr] -> [JStgExpr]
forall a. [a] -> [a] -> [a]
++ Maybe JStgExpr -> [JStgExpr]
forall a. Maybe a -> [a]
maybeToList Maybe JStgExpr
cc)
where
allocFun :: JStgExpr
allocFun = Int -> JStgExpr
allocClsA ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
free)
allocDynamic :: StgToJSConfig -> Bool -> Ident -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgStat
allocDynamic :: StgToJSConfig
-> Bool
-> Ident
-> JStgExpr
-> [JStgExpr]
-> Maybe JStgExpr
-> JStgStat
allocDynamic StgToJSConfig
s Bool
need_decl Ident
to JStgExpr
entry [JStgExpr]
free Maybe JStgExpr
cc
| Bool
need_decl = Ident -> Maybe JStgExpr -> JStgStat
DeclStat Ident
to (JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just JStgExpr
value)
| Bool
otherwise = JStgExpr -> AOp -> JStgExpr -> JStgStat
AssignStat (Ident -> JStgExpr
Var Ident
to) AOp
AssignOp JStgExpr
value
where
value :: JStgExpr
value = Bool -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgExpr
allocDynamicE (StgToJSConfig -> Bool
csInlineAlloc StgToJSConfig
s) JStgExpr
entry [JStgExpr]
free Maybe JStgExpr
cc