    {-# 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  : 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
    var FastString
    t
      StaticConArg FastString
    c [StaticArg]
    args ->
        Bool -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgExpr
    allocDynamicE Bool
    False (FastString -> JStgExpr
    var 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