{-# LANGUAGE LambdaCase   #-}
{-# LANGUAGE ViewPatterns #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Args
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
--                Luite Stegeman <luite.stegeman@iohk.io>
--                Sylvain Henry  <sylvain.henry@iohk.io>
--                Josh Meredith  <josh.meredith@iohk.io>
-- Stability   :  experimental
--
--  Code generation of application arguments
-----------------------------------------------------------------------------

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

{-
Note [ Unboxable Literals Optimization ]
~~~~~~~~~~~~~~~~~~

Boxable types in the JS backend are represented as heap objects. See Note
[StgToJS design] in GHC.StgToJS.hs for more details. Some types, such as Int8
do not benefit from not being wrapped in an object in the JS runtime. This optimization
detects such types and changes the code generator to generate a more efficient
representation. The change is minor and saves one level on indirection. Instead
of generating a wrapper object with a field for the value's payload, such as:

// a JS object for an Int8
var anInt8 = { d1 = <Int8# payload>
             , f  : info table / entry function which would scrutinize the payload
             }

we instead generate:

// notice, no wrapper object. This representation is essentially an Int8# in the JS backend
var anInt8 = <Int8# payload>

This optimization fires when the follow invariants hold:
  1. The value in question has a Type which has a single data constructor
  2. The data constructor holds a single field that is monomorphic
  3. The value in question is distinguishable from a THUNK using the JavaScript typeof operator.

From the haskell perspective this means that:
  1. An Int8# is always a JavaScript 'number', never a JavaScript object.
  2. An Int8 is either a JavaScript 'number' _or_ a JavaScript object depending on
     its use case and this optimization.

How is this sound?
~~~~~~~~~~~~~~~~~~

Normally this optimization would violate the guarantees of call-by-need, however
we are able to statically detect whether the type in question will be a THUNK or
not during code gen because the JS backend is consuming STG and we can check
during runtime with the typeof operator. Similarly we can check at runtime using
JavaScript's introspection operator `typeof`. Thus, when we know the value in
question will not be a THUNK we can safely elide the wrapping object, which
unboxes the value in the JS runtime. For example, an Int8 contains an Int8#
which has the JavaScript type 'number'. A THUNK of type Int8 would have a
JavaScript type 'object', so using 'typeof' allows us to check if we have
something that is definitely evaluated (i.e., a 'number') or something else. If
it is an 'object' then we may need to enter it to begin its evaluation. Consider
a type which has a 'ThreadId#' field; such as type would not be subject to this
optimization because it has to be represented as a JavaScript 'object' and thus
cannot be unboxed in this way. Another (edge) case is Int64#. Int64# is
similarly not unboxable in this way because Int64# does not fit in one
JavaScript variable and thus requires an 'object' for its representation in the
JavaScript runtime.

-}

-- | Generate JS code for static arguments
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] -- this seems wrong, not an obj?
         | 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 -- fixme what is allocunboxedcon?
         | [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)

-- | Generate JS code for an StgArg
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
     -- if our argument is a joinid, it can be an unboxed tuple
     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)

-- | Generate a Var as JStgExpr
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)

-- | Generate an Id as an Ident
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

-- | Generate IDs for stack arguments. See 'StgToJS.Expr.loadRetArgs' for use case
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)

-- | Allocate Static Constructors
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
    -- see Note [ Unboxable Literals Optimization ] for the purpose of these
    -- checks
    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'

-- | Allocate unboxed constructors
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)


-- | Allocate Static list
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"

-- | Generate JS code corresponding to a static arg
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

-- | Generate JS code corresponding to a list of static args
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