    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE BlockArguments #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  GHC.StgToJS.Apply
    -- 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
    --
    --
    -- Module that deals with expression application in JavaScript. In some cases we
    -- rely on pre-generated functions that are bundled with the RTS (see rtsApply).
    -----------------------------------------------------------------------------

    module GHC.StgToJS.Apply
      ( genApp
      , rtsApply
      )
    where

    import GHC.Prelude hiding ((.|.))

    import GHC.JS.JStg.Syntax
    import GHC.JS.JStg.Monad
    import GHC.JS.Ident
    import GHC.JS.Make

    import GHC.StgToJS.Arg
    import GHC.StgToJS.Closure
    import GHC.StgToJS.DataCon
    import GHC.StgToJS.ExprCtx
    import GHC.StgToJS.Heap
    import GHC.StgToJS.Monad
    import GHC.StgToJS.Types
    import GHC.StgToJS.Profiling
    import GHC.StgToJS.Regs
    import GHC.StgToJS.Utils
    import GHC.StgToJS.Rts.Types
    import GHC.StgToJS.Stack
    import GHC.StgToJS.Ids

    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Types.CostCentre
    import GHC.Types.RepType (mightBeFunTy)

    import GHC.Stg.Syntax

    import GHC.Builtin.Names

    import GHC.Core.TyCon
    import GHC.Core.DataCon
    import GHC.Core.Type hiding (typeSize)

    import GHC.Utils.Misc
    import GHC.Utils.Monad
    import GHC.Utils.Panic
    import GHC.Utils.Outputable (vcat, ppr)
    import GHC.Data.FastString

    import qualified Data.Bits as Bits
    import Data.Monoid
    import Data.Array

    -- | Pre-generated functions for fast Apply.
    -- These are bundled with the RTS.
    rtsApply :: StgToJSConfig -> JSM JStgStat
    rtsApply :: StgToJSConfig -> JSM JStgStat
    rtsApply StgToJSConfig
    cfg = [JSM JStgStat] -> JSM JStgStat
    forall a. Monoid a => [JSM a] -> JSM a
    jBlock
         [ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat)
    -> StateT JEnv Identity [JStgStat] -> JSM JStgStat
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (ApplySpec -> JSM JStgStat)
    -> [ApplySpec] -> StateT JEnv Identity [JStgStat]
    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 (StgToJSConfig -> ApplySpec -> JSM JStgStat
    specApply StgToJSConfig
    cfg) [ApplySpec]
    applySpec
         , [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat)
    -> StateT JEnv Identity [JStgStat] -> JSM JStgStat
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Int -> JSM JStgStat) -> [Int] -> StateT JEnv Identity [JStgStat]
    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 (StgToJSConfig -> Int -> JSM JStgStat
    pap StgToJSConfig
    cfg)       [Int]
    specPap
         , JSM JStgStat
    mkApplyArr
         , StgToJSConfig -> JSM JStgStat
    genericStackApply StgToJSConfig
    cfg
         , StgToJSConfig -> JSM JStgStat
    genericFastApply  StgToJSConfig
    cfg
         , StgToJSConfig -> JSM JStgStat
    zeroApply         StgToJSConfig
    cfg
         , StgToJSConfig -> JSM JStgStat
    updates           StgToJSConfig
    cfg
         , StgToJSConfig -> JSM JStgStat
    papGen            StgToJSConfig
    cfg
         , StgToJSConfig -> JSM JStgStat
    selectors         StgToJSConfig
    cfg
         , JSM JStgStat
    moveRegs2
         ]

    -- | Generate an application of some args to an Id.
    --
    -- The case where args is null is common as it's used to generate the evaluation
    -- code for an Id.
    genApp
      :: HasDebugCallStack
      => ExprCtx
      -> Id
      -> [StgArg]
      -> G (JStgStat, ExprResult)
    genApp :: HasDebugCallStack =>
    ExprCtx -> Id -> [StgArg] -> G (JStgStat, ExprResult)
    genApp ExprCtx
    ctx Id
    i [StgArg]
    args

        -- let-no-escape
        | Just Int
    n <- ExprCtx -> Id -> Maybe Int
    ctxLneBindingStackSize ExprCtx
    ctx Id
    i
        = do
          as'      <- (StgArg -> StateT GenState IO [JStgExpr])
    -> [StgArg] -> StateT GenState IO [JStgExpr]
    forall (m :: * -> *) (f :: * -> *) a b.
    (Monad m, Traversable f) =>
    (a -> m [b]) -> f a -> m [b]
    concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
    StgArg -> StateT GenState IO [JStgExpr]
    genArg [StgArg]
    args
          ei       <- varForEntryId i
          let ra = [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat)
    -> ([JStgStat] -> [JStgStat]) -> [JStgStat] -> JStgStat
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [JStgStat] -> [JStgStat]
    forall a. [a] -> [a]
    reverse ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
    forall a b. (a -> b) -> a -> b
    $
                     (StgReg -> JStgExpr -> JStgStat)
    -> [StgReg] -> [JStgExpr] -> [JStgStat]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\StgReg
    r JStgExpr
    a -> StgReg -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr StgReg
    r JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    a) [StgReg
    R1 ..] [JStgExpr]
    as'
          p <- pushLneFrame n ctx
          a <- adjSp 1 -- for the header (which will only be written when the thread is suspended)
          return (ra <> p <> a <> returnS ei, ExprCont)

        -- proxy#
        | [] <- [StgArg]
    args
        , Id -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique Id
    i Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    proxyHashKey
        , [JStgExpr
    top] <- (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)
        = (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
    forall a. a -> StateT GenState IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgExpr
    top JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    null_, ExprResult
    ExprInline)

        -- unboxed tuple or strict type: return fields individually
        | [] <- [StgArg]
    args
        , Type -> Bool
    isUnboxedTupleType (Id -> Type
    idType Id
    i) Bool -> Bool -> Bool
    || HasDebugCallStack => Type -> Bool
    Type -> Bool
    isStrictType (Id -> Type
    idType Id
    i)
        = do
          a <- Id -> [TypedExpr] -> G JStgStat
    storeIdFields Id
    i (ExprCtx -> [TypedExpr]
    ctxTarget ExprCtx
    ctx)
          return (a, ExprInline)

        -- Handle alternative heap object representation: in some cases, a heap
        -- object is not represented as a JS object but directly as a number or a
        -- string. I.e. only the payload is stored because the box isn't useful.
        -- It happens for "Int Int#" for example: no need to box the Int# in JS.
        --
        -- We must check that:
        --  - the object is subject to the optimization (cf isUnboxable predicate)
        --  - we know that it is already evaluated (cf ctxIsEvaluated), otherwise we
        --  need to evaluate it properly first.
        --
        -- In which case we generate a dynamic check (using isObject) that either:
        --  - returns the payload of the heap object, if it uses the generic heap
        --  object representation
        --  - returns the object directly, otherwise
        | [] <- [StgArg]
    args
        , [JSRep
    vt] <- HasDebugCallStack => Id -> [JSRep]
    Id -> [JSRep]
    idJSRep Id
    i
        , JSRep -> Bool
    isUnboxable JSRep
    vt
        , Id -> Bool
    ctxIsEvaluated Id
    i
        = do
          let c :: JStgExpr
    c = [JStgExpr] -> JStgExpr
    forall a. HasCallStack => [a] -> a
    head ((TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap TypedExpr -> [JStgExpr]
    typex_expr ([TypedExpr] -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
    forall a b. (a -> b) -> a -> b
    $ ExprCtx -> [TypedExpr]
    ctxTarget ExprCtx
    ctx)
          is <- Id -> StateT GenState IO [JStgExpr]
    varsForId Id
    i
          case is of
            [JStgExpr
    i'] ->
              (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
    forall a. a -> StateT GenState IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( JStgExpr
    c JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
    if_ (JStgExpr -> JStgExpr
    isObject JStgExpr
    i') (JStgExpr -> JStgExpr
    closureField1 JStgExpr
    i') JStgExpr
    i'
                     , ExprResult
    ExprInline
                     )
            [JStgExpr]
    _ -> [Char] -> G (JStgStat, ExprResult)
    forall a. HasCallStack => [Char] -> a
    panic [Char]
    "genApp: invalid size"

        -- case of Id without args and known to be already evaluated: return fields
        -- individually
        | [] <- [StgArg]
    args
        , Id -> Bool
    ctxIsEvaluated Id
    i Bool -> Bool -> Bool
    || HasDebugCallStack => Type -> Bool
    Type -> Bool
    isStrictType (Id -> Type
    idType Id
    i)
        = do
          a <- Id -> [TypedExpr] -> G JStgStat
    storeIdFields Id
    i (ExprCtx -> [TypedExpr]
    ctxTarget ExprCtx
    ctx)
          -- optional runtime assert for detecting unexpected thunks (unevaluated)
          settings <- getSettings
          let ww = case (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) of
                     [JStgExpr
    t] | StgToJSConfig -> Bool
    csAssertRts StgToJSConfig
    settings ->
                             JStgExpr -> JStgStat -> JStgStat -> JStgStat
    ifS (JStgExpr -> JStgExpr
    isObject JStgExpr
    t JStgExpr -> JStgExpr -> JStgExpr
    .&&. JStgExpr -> JStgExpr
    isThunk JStgExpr
    t)
                                 (FastString -> [JStgExpr] -> JStgStat
    appS FastString
    "throw" [FastString -> JStgExpr
    String FastString
    "unexpected thunk"]) -- yuck
                                 JStgStat
    forall a. Monoid a => a
    mempty
                     [JStgExpr]
    _   -> JStgStat
    forall a. Monoid a => a
    mempty
          return (a `mappend` ww, ExprInline)

        -- Case: "newtype" datacon wrapper
        --
        -- If the wrapped argument is known to be already evaluated, then we don't
        -- need to enter it.
        | DataConWrapId DataCon
    dc <- Id -> IdDetails
    idDetails Id
    i
        , TyCon -> Bool
    isNewTyCon (DataCon -> TyCon
    dataConTyCon DataCon
    dc)
        = do
          as <- (StgArg -> StateT GenState IO [JStgExpr])
    -> [StgArg] -> StateT GenState IO [JStgExpr]
    forall (m :: * -> *) (f :: * -> *) a b.
    (Monad m, Traversable f) =>
    (a -> m [b]) -> f a -> m [b]
    concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
    StgArg -> StateT GenState IO [JStgExpr]
    genArg [StgArg]
    args
          case as of
            [JStgExpr
    ai] -> do
              let t :: JStgExpr
    t = [JStgExpr] -> JStgExpr
    forall a. HasCallStack => [a] -> a
    head ((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))
                  a' :: Id
    a' = case [StgArg]
    args of
                    [StgVarArg Id
    a'] -> Id
    a'
                    [StgArg]
    _              -> [Char] -> Id
    forall a. HasCallStack => [Char] -> a
    panic [Char]
    "genApp: unexpected arg"
              if Id -> Bool
    isStrictId Id
    a' Bool -> Bool -> Bool
    || Id -> Bool
    ctxIsEvaluated Id
    a'
                then (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
    forall a. a -> StateT GenState IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgExpr
    t JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    ai, ExprResult
    ExprInline)
                else (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
    forall a. a -> StateT GenState IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgExpr -> JStgStat
    returnS (FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "h$e" [JStgExpr
    ai]), ExprResult
    ExprCont)
            [JStgExpr]
    _ -> [Char] -> G (JStgStat, ExprResult)
    forall a. HasCallStack => [Char] -> a
    panic [Char]
    "genApp: invalid size"

        -- no args and Id can't be a function: just enter it
        | [] <- [StgArg]
    args
        , Id -> Int
    idFunRepArity Id
    i Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0
        , Bool -> Bool
    not (Type -> Bool
    mightBeFunTy (Id -> Type
    idType Id
    i))
        = do
          enter_id <- HasDebugCallStack => Id -> StateT GenState IO [JStgExpr]
    Id -> StateT GenState IO [JStgExpr]
    genIdArg Id
    i StateT GenState IO [JStgExpr]
    -> ([JStgExpr] -> G JStgExpr) -> G JStgExpr
    forall a b.
    StateT GenState IO a
    -> (a -> StateT GenState IO b) -> StateT GenState IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>=
                        \case
                           [JStgExpr
    x] -> JStgExpr -> G JStgExpr
    forall a. a -> StateT GenState IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return JStgExpr
    x
                           [JStgExpr]
    xs  -> [Char] -> SDoc -> G JStgExpr
    forall a. HasCallStack => [Char] -> SDoc -> a
    pprPanic [Char]
    "genApp: unexpected multi-var argument"
                                    ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ([JStgExpr] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [JStgExpr]
    xs), Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    i])
          return (returnS (app "h$e" [enter_id]), ExprCont)

        -- fully saturated global function:
        --  - deals with arguments
        --  - jumps into the function
        | Int
    n <- [StgArg] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [StgArg]
    args
        , Int
    n Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Int
    0
        , Id -> Int
    idFunRepArity Id
    i Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    n
        , Bool -> Bool
    not (Id -> Bool
    isLocalId Id
    i)
        , Id -> Bool
    isStrictId Id
    i
        = do
          as' <- (StgArg -> StateT GenState IO [JStgExpr])
    -> [StgArg] -> StateT GenState IO [JStgExpr]
    forall (m :: * -> *) (f :: * -> *) a b.
    (Monad m, Traversable f) =>
    (a -> m [b]) -> f a -> m [b]
    concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
    StgArg -> StateT GenState IO [JStgExpr]
    genArg [StgArg]
    args
          is  <- assignAll jsRegsFromR1 <$> varsForId i
          jmp <- jumpToII i as' is
          return (jmp, ExprCont)

        -- oversaturated function:
        --  - push continuation with extra args
        --  - deals with arguments
        --  - jumps into the function
        | Id -> Int
    idFunRepArity Id
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < [StgArg] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [StgArg]
    args
        , Id -> Bool
    isStrictId Id
    i
        , Id -> Int
    idFunRepArity Id
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0
        = do
          let ([StgArg]
    reg,[StgArg]
    over) = Int -> [StgArg] -> ([StgArg], [StgArg])
    forall a. Int -> [a] -> ([a], [a])
    splitAt (Id -> Int
    idFunRepArity Id
    i) [StgArg]
    args
          reg' <- (StgArg -> StateT GenState IO [JStgExpr])
    -> [StgArg] -> StateT GenState IO [JStgExpr]
    forall (m :: * -> *) (f :: * -> *) a b.
    (Monad m, Traversable f) =>
    (a -> m [b]) -> f a -> m [b]
    concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
    StgArg -> StateT GenState IO [JStgExpr]
    genArg [StgArg]
    reg
          pc   <- pushCont over
          is   <- assignAll jsRegsFromR1 <$> varsForId i
          jmp  <- jumpToII i reg' is
          return (pc <> jmp, ExprCont)

        -- generic apply:
        --  - try to find a pre-generated apply function that matches
        --  - use it if any
        --  - otherwise use generic apply function h$ap_gen_fast
        | Bool
    otherwise
        = do
          is  <- [JStgExpr] -> [JStgExpr] -> JStgStat
    assignAll [JStgExpr]
    jsRegsFromR1 ([JStgExpr] -> JStgStat)
    -> StateT GenState IO [JStgExpr] -> G JStgStat
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Id -> StateT GenState IO [JStgExpr]
    varsForId Id
    i
          jmp <- jumpToFast args is
          return (jmp, ExprCont)

    -- avoid one indirection for global ids
    -- fixme in many cases we can also jump directly to the entry for local?
    jumpToII :: Id -> [JStgExpr] -> JStgStat -> G JStgStat
    jumpToII :: Id -> [JStgExpr] -> JStgStat -> G JStgStat
    jumpToII Id
    i [JStgExpr]
    vars JStgStat
    load_app_in_r1
      | Id -> Bool
    isLocalId Id
    i = do
         ii <- Id -> G JStgExpr
    varForId Id
    i
         return $ mconcat
          [ assignAllReverseOrder jsRegsFromR2 vars
          , load_app_in_r1
          , returnS (closureEntry ii)
          ]
      | Bool
    otherwise   = do
         ei <- Id -> G JStgExpr
    varForEntryId Id
    i
         return $ mconcat
          [ assignAllReverseOrder jsRegsFromR2 vars
          , load_app_in_r1
          , returnS ei
          ]

    -- | Try to use a specialized pre-generated application function.
    -- If there is none, use h$ap_gen_fast instead
    jumpToFast :: HasDebugCallStack => [StgArg] -> JStgStat -> G JStgStat
    jumpToFast :: HasDebugCallStack => [StgArg] -> JStgStat -> G JStgStat
    jumpToFast [StgArg]
    args JStgStat
    load_app_in_r1 = do
      -- get JS expressions for every argument
      -- Arguments may have more than one expression (e.g. Word64#)
      vars <- (StgArg -> StateT GenState IO [JStgExpr])
    -> [StgArg] -> StateT GenState IO [JStgExpr]
    forall (m :: * -> *) (f :: * -> *) a b.
    (Monad m, Traversable f) =>
    (a -> m [b]) -> f a -> m [b]
    concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
    StgArg -> StateT GenState IO [JStgExpr]
    genArg [StgArg]
    args
      -- try to find a specialized apply function
      let spec = ApplyConv -> [StgArg] -> [JStgExpr] -> ApplySpec
    mkApplySpec ApplyConv
    RegsConv [StgArg]
    args [JStgExpr]
    vars
      ap_fun <- selectApply spec
      pure $ mconcat
        [ assignAllReverseOrder jsRegsFromR2 vars
        , load_app_in_r1
        , case ap_fun of
            -- specialized apply: no tag
            Right JStgExpr
    fun -> JStgExpr -> JStgStat
    returnS (JStgExpr -> [JStgExpr] -> JStgExpr
    ApplExpr JStgExpr
    fun [])
            -- generic apply: pass a tag indicating number of args/slots
            Left  JStgExpr
    fun -> JStgExpr -> JStgStat
    returnS (JStgExpr -> [JStgExpr] -> JStgExpr
    ApplExpr JStgExpr
    fun [ApplySpec -> JStgExpr
    specTagExpr ApplySpec
    spec])
        ]

    -- | Calling convention for an apply function
    data ApplyConv
      = RegsConv  -- ^ Fast calling convention: use registers
      | StackConv -- ^ Slow calling convention: use the stack
      deriving (Int -> ApplyConv -> ShowS
    [ApplyConv] -> ShowS
    ApplyConv -> [Char]
    (Int -> ApplyConv -> ShowS)
    -> (ApplyConv -> [Char])
    -> ([ApplyConv] -> ShowS)
    -> Show ApplyConv
    forall a.
    (Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> ApplyConv -> ShowS
    showsPrec :: Int -> ApplyConv -> ShowS
    $cshow :: ApplyConv -> [Char]
    show :: ApplyConv -> [Char]
    $cshowList :: [ApplyConv] -> ShowS
    showList :: [ApplyConv] -> ShowS
    Show,ApplyConv -> ApplyConv -> Bool
    (ApplyConv -> ApplyConv -> Bool)
    -> (ApplyConv -> ApplyConv -> Bool) -> Eq ApplyConv
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: ApplyConv -> ApplyConv -> Bool
    == :: ApplyConv -> ApplyConv -> Bool
    $c/= :: ApplyConv -> ApplyConv -> Bool
    /= :: ApplyConv -> ApplyConv -> Bool
    Eq,Eq ApplyConv
    Eq ApplyConv =>
    (ApplyConv -> ApplyConv -> Ordering)
    -> (ApplyConv -> ApplyConv -> Bool)
    -> (ApplyConv -> ApplyConv -> Bool)
    -> (ApplyConv -> ApplyConv -> Bool)
    -> (ApplyConv -> ApplyConv -> Bool)
    -> (ApplyConv -> ApplyConv -> ApplyConv)
    -> (ApplyConv -> ApplyConv -> ApplyConv)
    -> Ord ApplyConv
    ApplyConv -> ApplyConv -> Bool
    ApplyConv -> ApplyConv -> Ordering
    ApplyConv -> ApplyConv -> ApplyConv
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: ApplyConv -> ApplyConv -> Ordering
    compare :: ApplyConv -> ApplyConv -> Ordering
    $c< :: ApplyConv -> ApplyConv -> Bool
    < :: ApplyConv -> ApplyConv -> Bool
    $c<= :: ApplyConv -> ApplyConv -> Bool
    <= :: ApplyConv -> ApplyConv -> Bool
    $c> :: ApplyConv -> ApplyConv -> Bool
    > :: ApplyConv -> ApplyConv -> Bool
    $c>= :: ApplyConv -> ApplyConv -> Bool
    >= :: ApplyConv -> ApplyConv -> Bool
    $cmax :: ApplyConv -> ApplyConv -> ApplyConv
    max :: ApplyConv -> ApplyConv -> ApplyConv
    $cmin :: ApplyConv -> ApplyConv -> ApplyConv
    min :: ApplyConv -> ApplyConv -> ApplyConv
    Ord)

    -- | Name of the generic apply function
    genericApplyName :: ApplyConv -> FastString
    genericApplyName :: ApplyConv -> FastString
    genericApplyName = \case
      ApplyConv
    RegsConv  -> FastString
    "h$ap_gen_fast"
      ApplyConv
    StackConv -> FastString
    "h$ap_gen"

    -- | Expr of the generic apply function
    genericApplyExpr :: ApplyConv -> JStgExpr
    genericApplyExpr :: ApplyConv -> JStgExpr
    genericApplyExpr ApplyConv
    conv = FastString -> JStgExpr
    var (ApplyConv -> FastString
    genericApplyName ApplyConv
    conv)

    -- | Return the name of the specialized apply function for the given number of
    -- args, number of arg variables, and calling convention.
    specApplyName :: ApplySpec -> FastString
    specApplyName :: ApplySpec -> FastString
    specApplyName = \case
      -- specialize a few for compiler performance (avoid building FastStrings over
      -- and over for common cases)
      ApplySpec ApplyConv
    RegsConv  Int
    0 Int
    0    -> FastString
    "h$ap_0_0_fast"
      ApplySpec ApplyConv
    StackConv Int
    0 Int
    0    -> FastString
    "h$ap_0_0"
      ApplySpec ApplyConv
    RegsConv  Int
    1 Int
    0    -> FastString
    "h$ap_1_0_fast"
      ApplySpec ApplyConv
    StackConv Int
    1 Int
    0    -> FastString
    "h$ap_1_0"
      ApplySpec ApplyConv
    RegsConv  Int
    1 Int
    1    -> FastString
    "h$ap_1_1_fast"
      ApplySpec ApplyConv
    StackConv Int
    1 Int
    1    -> FastString
    "h$ap_1_1"
      ApplySpec ApplyConv
    RegsConv  Int
    1 Int
    2    -> FastString
    "h$ap_1_2_fast"
      ApplySpec ApplyConv
    StackConv Int
    1 Int
    2    -> FastString
    "h$ap_1_2"
      ApplySpec ApplyConv
    RegsConv  Int
    2 Int
    1    -> FastString
    "h$ap_2_1_fast"
      ApplySpec ApplyConv
    StackConv Int
    2 Int
    1    -> FastString
    "h$ap_2_1"
      ApplySpec ApplyConv
    RegsConv  Int
    2 Int
    2    -> FastString
    "h$ap_2_2_fast"
      ApplySpec ApplyConv
    StackConv Int
    2 Int
    2    -> FastString
    "h$ap_2_2"
      ApplySpec ApplyConv
    RegsConv  Int
    2 Int
    3    -> FastString
    "h$ap_2_3_fast"
      ApplySpec ApplyConv
    StackConv Int
    2 Int
    3    -> FastString
    "h$ap_2_3"
      ApplySpec ApplyConv
    conv Int
    nargs Int
    nvars -> [Char] -> FastString
    mkFastString ([Char] -> FastString) -> [Char] -> FastString
    forall a b. (a -> b) -> a -> b
    $ [[Char]] -> [Char]
    forall a. Monoid a => [a] -> a
    mconcat
                                      [ [Char]
    "h$ap_", Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    nargs
                                      , [Char]
    "_"    , Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    nvars
                                      , case ApplyConv
    conv of
                                          ApplyConv
    RegsConv  -> [Char]
    "_fast"
                                          ApplyConv
    StackConv -> [Char]
    ""
                                      ]

    -- | Return the expression of the specialized apply function for the given
    -- number of args, number of arg variables, and calling convention.
    --
    -- Warning: the returned function may not be generated! Use specApplyExprMaybe
    -- if you want to ensure that it exists.
    specApplyExpr :: ApplySpec -> JStgExpr
    specApplyExpr :: ApplySpec -> JStgExpr
    specApplyExpr ApplySpec
    spec = FastString -> JStgExpr
    var (ApplySpec -> FastString
    specApplyName ApplySpec
    spec)

    -- | Return the expression of the specialized apply function for the given
    -- number of args, number of arg variables, and calling convention.
    -- Return Nothing if it isn't generated.
    specApplyExprMaybe :: ApplySpec -> Maybe JStgExpr
    specApplyExprMaybe :: ApplySpec -> Maybe JStgExpr
    specApplyExprMaybe ApplySpec
    spec =
      if ApplySpec
    spec ApplySpec -> [ApplySpec] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [ApplySpec]
    applySpec
        then JStgExpr -> Maybe JStgExpr
    forall a. a -> Maybe a
    Just (ApplySpec -> JStgExpr
    specApplyExpr ApplySpec
    spec)
        else Maybe JStgExpr
    forall a. Maybe a
    Nothing

    -- | Make an ApplySpec from a calling convention, a list of Haskell args, and a
    -- list of corresponding JS variables
    mkApplySpec :: ApplyConv -> [StgArg] -> [JStgExpr] -> ApplySpec
    mkApplySpec :: ApplyConv -> [StgArg] -> [JStgExpr] -> ApplySpec
    mkApplySpec ApplyConv
    conv [StgArg]
    args [JStgExpr]
    vars = ApplySpec
      { specConv :: ApplyConv
    specConv = ApplyConv
    conv
      , specArgs :: Int
    specArgs = [StgArg] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [StgArg]
    args
      , specVars :: Int
    specVars = [JStgExpr] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [JStgExpr]
    vars
      }

    -- | Find a specialized application function if there is one
    selectApply
      :: ApplySpec
      -> G (Either JStgExpr JStgExpr) -- ^ the function to call (Left for generic, Right for specialized)
    selectApply :: ApplySpec -> G (Either JStgExpr JStgExpr)
    selectApply ApplySpec
    spec =
      case ApplySpec -> Maybe JStgExpr
    specApplyExprMaybe ApplySpec
    spec of
        Just JStgExpr
    e  -> Either JStgExpr JStgExpr -> G (Either JStgExpr JStgExpr)
    forall a. a -> StateT GenState IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgExpr -> Either JStgExpr JStgExpr
    forall a b. b -> Either a b
    Right JStgExpr
    e)
        Maybe JStgExpr
    Nothing -> Either JStgExpr JStgExpr -> G (Either JStgExpr JStgExpr)
    forall a. a -> StateT GenState IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgExpr -> Either JStgExpr JStgExpr
    forall a b. a -> Either a b
    Left (ApplyConv -> JStgExpr
    genericApplyExpr (ApplySpec -> ApplyConv
    specConv ApplySpec
    spec)))

    -- | Apply specification
    data ApplySpec = ApplySpec
      { ApplySpec -> ApplyConv
    specConv :: !ApplyConv -- ^ Calling convention
      , ApplySpec -> Int
    specArgs :: !Int       -- ^ number of Haskell arguments
      , ApplySpec -> Int
    specVars :: !Int       -- ^ number of JavaScript variables for the arguments
      }
      deriving (Int -> ApplySpec -> ShowS
    [ApplySpec] -> ShowS
    ApplySpec -> [Char]
    (Int -> ApplySpec -> ShowS)
    -> (ApplySpec -> [Char])
    -> ([ApplySpec] -> ShowS)
    -> Show ApplySpec
    forall a.
    (Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> ApplySpec -> ShowS
    showsPrec :: Int -> ApplySpec -> ShowS
    $cshow :: ApplySpec -> [Char]
    show :: ApplySpec -> [Char]
    $cshowList :: [ApplySpec] -> ShowS
    showList :: [ApplySpec] -> ShowS
    Show,ApplySpec -> ApplySpec -> Bool
    (ApplySpec -> ApplySpec -> Bool)
    -> (ApplySpec -> ApplySpec -> Bool) -> Eq ApplySpec
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: ApplySpec -> ApplySpec -> Bool
    == :: ApplySpec -> ApplySpec -> Bool
    $c/= :: ApplySpec -> ApplySpec -> Bool
    /= :: ApplySpec -> ApplySpec -> Bool
    Eq,Eq ApplySpec
    Eq ApplySpec =>
    (ApplySpec -> ApplySpec -> Ordering)
    -> (ApplySpec -> ApplySpec -> Bool)
    -> (ApplySpec -> ApplySpec -> Bool)
    -> (ApplySpec -> ApplySpec -> Bool)
    -> (ApplySpec -> ApplySpec -> Bool)
    -> (ApplySpec -> ApplySpec -> ApplySpec)
    -> (ApplySpec -> ApplySpec -> ApplySpec)
    -> Ord ApplySpec
    ApplySpec -> ApplySpec -> Bool
    ApplySpec -> ApplySpec -> Ordering
    ApplySpec -> ApplySpec -> ApplySpec
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: ApplySpec -> ApplySpec -> Ordering
    compare :: ApplySpec -> ApplySpec -> Ordering
    $c< :: ApplySpec -> ApplySpec -> Bool
    < :: ApplySpec -> ApplySpec -> Bool
    $c<= :: ApplySpec -> ApplySpec -> Bool
    <= :: ApplySpec -> ApplySpec -> Bool
    $c> :: ApplySpec -> ApplySpec -> Bool
    > :: ApplySpec -> ApplySpec -> Bool
    $c>= :: ApplySpec -> ApplySpec -> Bool
    >= :: ApplySpec -> ApplySpec -> Bool
    $cmax :: ApplySpec -> ApplySpec -> ApplySpec
    max :: ApplySpec -> ApplySpec -> ApplySpec
    $cmin :: ApplySpec -> ApplySpec -> ApplySpec
    min :: ApplySpec -> ApplySpec -> ApplySpec
    Ord)

    -- | List of specialized apply function templates
    applySpec :: [ApplySpec]
    applySpec :: [ApplySpec]
    applySpec = [ ApplyConv -> Int -> Int -> ApplySpec
    ApplySpec ApplyConv
    conv Int
    nargs Int
    nvars
                | ApplyConv
    conv  <- [ApplyConv
    RegsConv, ApplyConv
    StackConv]
                , Int
    nargs <- [Int
    0..Int
    4]
                , Int
    nvars <- [Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max Int
    0 (Int
    nargsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1)..(Int
    nargsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    *Int
    2)]
                ]

    -- | Generate a tag for the given ApplySpec
    --
    -- Warning: tag doesn't take into account the calling convention
    specTag :: ApplySpec -> Int
    specTag :: ApplySpec -> Int
    specTag ApplySpec
    spec = Int -> Int -> Int
    forall a. Bits a => a -> Int -> a
    Bits.shiftL (ApplySpec -> Int
    specVars ApplySpec
    spec) Int
    8 Int -> Int -> Int
    forall a. Bits a => a -> a -> a
    Bits..|. (ApplySpec -> Int
    specArgs ApplySpec
    spec)

    -- | Generate a tag expression for the given ApplySpec
    specTagExpr :: ApplySpec -> JStgExpr
    specTagExpr :: ApplySpec -> JStgExpr
    specTagExpr = Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (Int -> JStgExpr) -> (ApplySpec -> Int) -> ApplySpec -> JStgExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ApplySpec -> Int
    specTag

    -- | Build arrays to quickly lookup apply functions
    --
    --  h$apply[r << 8 | n] = function application for r regs, n args
    --  h$paps[r]           = partial application for r registers (number of args is in the object)
    mkApplyArr :: JSM JStgStat
    mkApplyArr :: JSM JStgStat
    mkApplyArr =
      do mk_ap_gens  <- (JStgExpr -> JStgStat)
    -> (JStgExpr -> JStgExpr)
    -> (JStgExpr -> JStgStat)
    -> (JStgExpr -> JStgStat)
    -> JSM JStgStat
    jFor (JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    zero_) (JStgExpr -> JStgExpr -> JStgExpr
    .<. Integer -> JStgExpr
    Int Integer
    65536) JStgExpr -> JStgStat
    preIncrS
                        \JStgExpr
    j -> FastString -> JStgExpr
    var FastString
    "h$apply" JStgExpr -> JStgExpr -> JStgExpr
    .! JStgExpr
    j JStgExpr -> JStgExpr -> JStgStat
    |= FastString -> JStgExpr
    var FastString
    "h$ap_gen"
         mk_pap_gens <- jFor (|= zero_) (.<. Int 128) preIncrS
                        \JStgExpr
    j -> FastString -> JStgExpr
    var FastString
    "h$paps" JStgExpr -> JStgExpr -> JStgExpr
    .! JStgExpr
    j JStgExpr -> JStgExpr -> JStgStat
    |= FastString -> JStgExpr
    var FastString
    "h$pap_gen"
         return $ mconcat
           [ global "h$apply" ||= toJExpr (JList [])
           , global "h$paps"  ||= toJExpr (JList [])
           , ApplStat (var "h$initStatic" .^ "push")
             [ jLam' $
               mconcat
               [ mk_ap_gens
               , mk_pap_gens
               , mconcat (map assignSpec applySpec)
               , mconcat (map assignPap specPap)
               ]
             ]
           ]
      where
        assignSpec :: ApplySpec -> JStgStat
        assignSpec :: ApplySpec -> JStgStat
    assignSpec ApplySpec
    spec = case ApplySpec -> ApplyConv
    specConv ApplySpec
    spec of
          -- both fast/slow (regs/stack) specialized apply functions have the same
          -- tags. We store the stack ones in the array because they are used as
          -- continuation stack frames.
          ApplyConv
    StackConv -> FastString -> JStgExpr
    var FastString
    "h$apply" JStgExpr -> JStgExpr -> JStgExpr
    .! ApplySpec -> JStgExpr
    specTagExpr ApplySpec
    spec JStgExpr -> JStgExpr -> JStgStat
    |= ApplySpec -> JStgExpr
    specApplyExpr ApplySpec
    spec
          ApplyConv
    RegsConv  -> JStgStat
    forall a. Monoid a => a
    mempty

        assignPap :: Int -> JStgStat
        assignPap :: Int -> JStgStat
    assignPap Int
    p = FastString -> JStgExpr
    var FastString
    "h$paps" JStgExpr -> JStgExpr -> JStgExpr
    .! Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    p JStgExpr -> JStgExpr -> JStgStat
    |=
                          (FastString -> JStgExpr
    var ([Char] -> FastString
    mkFastString ([Char] -> FastString) -> [Char] -> FastString
    forall a b. (a -> b) -> a -> b
    $ ([Char]
    "h$pap_" [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    p)))

    -- | Push a continuation on the stack
    --
    -- First push the given args, then push an apply function (specialized if
    -- possible, otherwise the generic h$ap_gen function).
    pushCont :: HasDebugCallStack
             => [StgArg]
             -> G JStgStat
    pushCont :: HasDebugCallStack => [StgArg] -> G JStgStat
    pushCont [StgArg]
    args = do
      vars <- (StgArg -> StateT GenState IO [JStgExpr])
    -> [StgArg] -> StateT GenState IO [JStgExpr]
    forall (m :: * -> *) (f :: * -> *) a b.
    (Monad m, Traversable f) =>
    (a -> m [b]) -> f a -> m [b]
    concatMapM HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
    StgArg -> StateT GenState IO [JStgExpr]
    genArg [StgArg]
    args
      let spec = ApplyConv -> [StgArg] -> [JStgExpr] -> ApplySpec
    mkApplySpec ApplyConv
    StackConv [StgArg]
    args [JStgExpr]
    vars
      selectApply spec >>= \case
        Right JStgExpr
    app -> [JStgExpr] -> G JStgStat
    push ([JStgExpr] -> G JStgStat) -> [JStgExpr] -> G JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgExpr] -> [JStgExpr]
    forall a. [a] -> [a]
    reverse ([JStgExpr] -> [JStgExpr]) -> [JStgExpr] -> [JStgExpr]
    forall a b. (a -> b) -> a -> b
    $ JStgExpr
    app JStgExpr -> [JStgExpr] -> [JStgExpr]
    forall a. a -> [a] -> [a]
    : [JStgExpr]
    vars
        Left  JStgExpr
    app -> [JStgExpr] -> G JStgStat
    push ([JStgExpr] -> G JStgStat) -> [JStgExpr] -> G JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgExpr] -> [JStgExpr]
    forall a. [a] -> [a]
    reverse ([JStgExpr] -> [JStgExpr]) -> [JStgExpr] -> [JStgExpr]
    forall a b. (a -> b) -> a -> b
    $ JStgExpr
    app JStgExpr -> [JStgExpr] -> [JStgExpr]
    forall a. a -> [a] -> [a]
    : ApplySpec -> JStgExpr
    specTagExpr ApplySpec
    spec JStgExpr -> [JStgExpr] -> [JStgExpr]
    forall a. a -> [a] -> [a]
    : [JStgExpr]
    vars

    -- | Generic stack apply function (h$ap_gen) that can do everything, but less
    -- efficiently than other more specialized functions.
    --
    -- Stack layout:
    --  -3: ...
    --  -2: args
    --  -1: tag (number of arg slots << 8 | number of args)
    --
    -- Regs:
    --  R1 = applied closure
    --
    genericStackApply :: StgToJSConfig -> JSM JStgStat
    genericStackApply :: StgToJSConfig -> JSM JStgStat
    genericStackApply StgToJSConfig
    cfg = ClosureInfo -> JSM JStgStat -> JSM JStgStat
    closure ClosureInfo
    info JSM JStgStat
    body
      where
        -- h$ap_gen body
        body :: JSM JStgStat
    body = (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall t.
    (JVarMagic t, ToJExpr t) =>
    (t -> JSM JStgStat) -> JSM JStgStat
    jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
    -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ \JStgExpr
    cf ->
          do fun <- JStgExpr -> JStgExpr -> JSM JStgStat
    fun_case JStgExpr
    cf (JStgExpr -> JStgExpr
    funArity' JStgExpr
    cf)
             pap <- fun_case cf (papArity r1)
             return $
               mconcat $
               [ traceRts cfg (jString "h$ap_gen")
               , cf |= closureEntry r1
               -- switch on closure type
               , SwitchStat (entryClosureType cf)
                 [ (toJExpr Thunk    , thunk_case cfg cf)
                 , (toJExpr Fun      , fun)
                 , (toJExpr Pap      , pap)
                 , (toJExpr Blackhole, blackhole_case cfg)
                 ]
                 (default_case cf)
               ]

        -- info table for h$ap_gen
        info :: ClosureInfo
    info = ClosureInfo
          { ciVar :: Ident
    ciVar     = FastString -> Ident
    global FastString
    "h$ap_gen"
          , ciRegs :: CIRegs
    ciRegs    = Int -> [JSRep] -> CIRegs
    CIRegs Int
    0 [JSRep
    PtrV] -- closure to apply to
          , ciName :: FastString
    ciName    = FastString
    "h$ap_gen"
          , ciLayout :: CILayout
    ciLayout  = CILayout
    CILayoutVariable
          , ciType :: CIType
    ciType    = CIType
    CIStackFrame
          , ciStatic :: CIStatic
    ciStatic  = CIStatic
    forall a. Monoid a => a
    mempty
          }

        default_case :: JStgExpr -> JStgStat
    default_case JStgExpr
    cf = FastString -> [JStgExpr] -> JStgStat
    appS FastString
    "throw" [FastString -> JStgExpr
    jString FastString
    "h$ap_gen: unexpected closure type "
                                        JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + (JStgExpr -> JStgExpr
    entryClosureType JStgExpr
    cf)]

        thunk_case :: StgToJSConfig -> JStgExpr -> JStgStat
    thunk_case StgToJSConfig
    cfg JStgExpr
    cf = [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat
          [ StgToJSConfig -> JStgStat -> JStgStat
    profStat StgToJSConfig
    cfg JStgStat
    pushRestoreCCS
          , JStgExpr -> JStgStat
    returnS JStgExpr
    cf
          ]

        blackhole_case :: StgToJSConfig -> JStgStat
    blackhole_case StgToJSConfig
    cfg = [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat
          [ StgToJSConfig -> [JStgExpr] -> JStgStat
    push' StgToJSConfig
    cfg [JStgExpr
    r1, FastString -> JStgExpr
    var FastString
    "h$return"]
          , JStgExpr -> JStgStat
    returnS (FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "h$blockOnBlackhole" [JStgExpr
    r1])
          ]

        fun_case :: JStgExpr -> JStgExpr -> JSM JStgStat
    fun_case JStgExpr
    c JStgExpr
    arity = ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
      JStgExpr, JStgExpr, JStgExpr)
     -> JSM JStgStat)
    -> JSM JStgStat
    forall args.
    JSArgument args =>
    (args -> JSM JStgStat) -> JSM JStgStat
    jVars \(JStgExpr
    tag, JStgExpr
    needed_args, JStgExpr
    needed_regs, JStgExpr
    given_args, JStgExpr
    given_regs, JStgExpr
    newTag, JStgExpr
    newAp, JStgExpr
    p, JStgExpr
    dat) ->
          do build_pap_payload <- JStgExpr
    -> (JStgExpr -> JStgExpr)
    -> (JStgExpr -> JSM JStgStat)
    -> JSM JStgStat
    loop JStgExpr
    0 (JStgExpr -> JStgExpr -> JStgExpr
    .<. JStgExpr
    given_regs)
                                  \JStgExpr
    i -> JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat [ (JStgExpr
    dat JStgExpr -> FastString -> JStgExpr
    .^ FastString
    "push") JStgExpr -> [JStgExpr] -> JStgStat
    `ApplStat` [JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! (JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - JStgExpr
    i JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - JStgExpr
    2)]
                                                         , JStgExpr -> JStgStat
    postIncrS JStgExpr
    i
                                                         ]
             load_reg_values <- loop 0 (.<. needed_regs)
                                \JStgExpr
    i -> JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $
                                      [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat [ StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    cfg (FastString -> JStgExpr
    jString FastString
    "h$ap_gen: loading register: " JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    i)
                                              , FastString -> [JStgExpr] -> JStgStat
    appS FastString
    "h$setReg" [ JStgExpr
    iJStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    +JStgExpr
    2 , JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! (JStgExpr
    spJStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    -JStgExpr
    2JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    -JStgExpr
    i)]
                                              , JStgExpr -> JStgStat
    postIncrS JStgExpr
    i
                                              ]
             set_reg_values <- loop 0 (.<. given_regs)
               \JStgExpr
    i -> JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $
                     [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat [ FastString -> [JStgExpr] -> JStgStat
    appS FastString
    "h$setReg" [ JStgExpr
    iJStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    +JStgExpr
    2, JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! (JStgExpr
    spJStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    -JStgExpr
    2JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    -JStgExpr
    i)]
                             , JStgExpr -> JStgStat
    postIncrS JStgExpr
    i
                             ]
             return $
               mconcat $ [ tag         |= stack .! (sp - 1) -- tag on the stack
                         , given_args  |= mask8 tag         -- indicates the number of passed args
                         , given_regs  |= tag .>>. 8        -- and the number of passed values for registers
                         , needed_args |= mask8 arity
                         , needed_regs |= arity .>>. 8
                         , traceRts cfg (jString "h$ap_gen: args: " + given_args
                                         + jString " regs: " + given_regs)
                         , ifBlockS (given_args .===. needed_args)
                           --------------------------------
                           -- exactly saturated application
                           --------------------------------
                           [ traceRts cfg (jString "h$ap_gen: exact")
                           -- Set registers to register values on the stack
                           , set_reg_values
                           -- drop register values from the stack
                           , sp |= sp - given_regs - 2
                           -- enter closure in R1
                           , returnS c
                           ]
                           [ ifBlockS (given_args .>. needed_args)
                             ----------------------------
                             -- oversaturated application
                             ----------------------------
                             [ traceRts cfg (jString "h$ap_gen: oversat: arity: " + needed_args
                                             + jString " regs: " + needed_regs)

                             -- load needed register values
                             , load_reg_values

                             -- compute new tag with consumed register values and args removed
                             , newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args)
                             -- find application function for the remaining regs/args
                             , newAp |= var "h$apply" .! newTag
                             , traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n"))

                             -- Drop used registers from the stack.
                             -- Test if the application function needs a tag and push it.
                             , ifS (newAp .===. var "h$ap_gen")
                               ((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag))
                               (sp |= sp - needed_regs - 1)

                             -- Push generic application function as continuation
                             , stack .! sp |= newAp

                             -- Push "current thread CCS restore" function as continuation
                             , profStat cfg pushRestoreCCS

                             -- enter closure in R1
                             , returnS c
                             ]

                             -----------------------------
                             -- undersaturated application
                             -----------------------------
                             [ traceRts cfg (jString "h$ap_gen: undersat")
                             -- find PAP entry function corresponding to given_regs count
                             , p      |= var "h$paps" .! given_regs

                             -- build PAP payload: R1 + tag + given register values
                             , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args)
                             , dat    |= toJExpr [r1, newTag]
                             , build_pap_payload

                             -- remove register values from the stack.
                             , sp  |= sp - given_regs - 2

                             -- alloc PAP closure, store reference to it in R1.
                             , r1  |= initClosure cfg p dat jCurrentCCS

                             -- return to the continuation on the stack
                             , returnStack
                             ]
                           ]
                         ]

    -- | Generic fast apply function (h$ap_gen_fast) that can do everything, but less
    -- efficiently than other more specialized functions.
    --
    -- Signature tag in argument. Tag: (regs << 8 | arity)
    --
    -- Regs:
    --  R1 = closure to apply to
    --
    genericFastApply :: StgToJSConfig -> JSM JStgStat
    genericFastApply :: StgToJSConfig -> JSM JStgStat
    genericFastApply StgToJSConfig
    s =
       Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall args.
    JSArgument args =>
    Ident -> (args -> JSM JStgStat) -> JSM JStgStat
    jFunction (FastString -> Ident
    global FastString
    "h$ap_gen_fast")
       \(MkSolo JStgExpr
    tag) -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall t.
    (JVarMagic t, ToJExpr t) =>
    (t -> JSM JStgStat) -> JSM JStgStat
    jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
    -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ \JStgExpr
    c ->
         do push_stk_app <- JStgExpr -> JStgExpr -> JSM JStgStat
    pushStackApply JStgExpr
    c JStgExpr
    tag
            fast_fun     <- jVar \JStgExpr
    farity ->
                                   do fast_fun <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
    funCase JStgExpr
    c JStgExpr
    tag JStgExpr
    farity
                                      return $ mconcat $
                                        [ farity |= funArity' c
                                        , traceRts s (jString "h$ap_gen_fast: fun " + farity)
                                        , fast_fun]
            fast_pap     <- jVar \JStgExpr
    parity ->
                                   do fast_pap <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
    funCase JStgExpr
    c JStgExpr
    tag JStgExpr
    parity
                                      return $ mconcat $
                                        [ parity |= papArity r1
                                        , traceRts s (jString "h$ap_gen_fast: pap " + parity)
                                        , fast_pap
                                        ]
            return $ mconcat $
              [traceRts s (jString "h$ap_gen_fast: " + tag)
              , c |= closureEntry r1
              , SwitchStat (entryClosureType c)
                [ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk")
                    <> push_stk_app
                    <> returnS c)
                , (toJExpr Fun, fast_fun)
                , (toJExpr Pap, fast_pap)
                , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con")
                    <> jwhenS (tag .!=. 0)
                                (appS "throw" [jString "h$ap_gen_fast: invalid apply"])
                                <> returnS c)
                , (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole")
                    <> push_stk_app
                    <> push' s [r1, var "h$return"]
                    <> returnS (app "h$blockOnBlackhole" [r1]))
                ] $ appS "throw" [jString "h$ap_gen_fast: unexpected closure type: " + entryClosureType c]
              ]

      where
         -- thunk: push everything to stack frame, enter thunk first
        pushStackApply :: JStgExpr -> JStgExpr -> JSM JStgStat
        pushStackApply :: JStgExpr -> JStgExpr -> JSM JStgStat
    pushStackApply JStgExpr
    _c JStgExpr
    tag =
          (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall t.
    (JVarMagic t, ToJExpr t) =>
    (t -> JSM JStgStat) -> JSM JStgStat
    jVar \JStgExpr
    ap ->
                 do push_all_regs <- JStgExpr -> JSM JStgStat
    pushAllRegs JStgExpr
    tag
                    return $ mconcat $
                      [ push_all_regs
                      , ap |= var "h$apply" .! tag
                      , ifS (ap .===. var "h$ap_gen")
                        ((sp |= sp + 2) <> (stack .! (sp-1) |= tag))
                        (sp |= sp + 1)
                      , stack .! sp |= ap
                      , profStat s pushRestoreCCS
                      ]

        funCase :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
        funCase :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
    funCase JStgExpr
    c JStgExpr
    tag JStgExpr
    arity = ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
      JStgExpr, JStgExpr)
     -> JSM JStgStat)
    -> JSM JStgStat
    forall args.
    JSArgument args =>
    (args -> JSM JStgStat) -> JSM JStgStat
    jVars (((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
       JStgExpr, JStgExpr)
      -> JSM JStgStat)
     -> JSM JStgStat)
    -> ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr,
         JStgExpr, JStgExpr)
        -> JSM JStgStat)
    -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $
          \(JStgExpr
    ar, JStgExpr
    myAr, JStgExpr
    myRegs, JStgExpr
    regsStart, JStgExpr
    newTag, JStgExpr
    newAp, JStgExpr
    dat, JStgExpr
    p) ->

            do get_regs <- JStgExpr
    -> (JStgExpr -> JStgExpr)
    -> (JStgExpr -> JSM JStgStat)
    -> JSM JStgStat
    loop JStgExpr
    0 (JStgExpr -> JStgExpr -> JStgExpr
    .<. JStgExpr
    myRegs) ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
    -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $
                 \JStgExpr
    i -> JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $
                       (JStgExpr
    dat JStgExpr -> FastString -> JStgExpr
    .^ FastString
    "push") JStgExpr -> [JStgExpr] -> JStgStat
    `ApplStat` [FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "h$getReg" [JStgExpr
    iJStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    +JStgExpr
    2]] JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgExpr -> JStgStat
    postIncrS JStgExpr
    i
               push_args <- pushArgs regsStart myRegs

               return $ mconcat $
                 [ ar     |= mask8 arity
                 , myAr   |= mask8 tag
                 , myRegs |= tag .>>. 8
                 , traceRts s (jString "h$ap_gen_fast: args: " + myAr
                               + jString " regs: "             + myRegs)
                 , ifS (myAr .===. ar)
                 -- call the function directly
                   (traceRts s (jString "h$ap_gen_fast: exact") <> returnS c)
                   (ifBlockS (myAr .>. ar)
                   -- push stack frame with remaining args, then call fun
                    [ traceRts s (jString "h$ap_gen_fast: oversat " + sp)
                    , regsStart |= (arity .>>. 8) + 1
                    , sp |= sp + myRegs - regsStart + 1
                    , traceRts s (jString "h$ap_gen_fast: oversat " + sp)
                    , push_args
                    , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar
                    , newAp |= var "h$apply" .! newTag
                    , ifS (newAp .===. var "h$ap_gen")
                      ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag))
                      (sp |= sp + 1)
                    , stack .! sp |= newAp
                    , profStat s pushRestoreCCS
                    , returnS c
                    ]
                   -- else
                    [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag)
                    , jwhenS (tag .!=. 0) $ mconcat
                      [ p |= var "h$paps" .! myRegs
                      , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]
                      , get_regs
                      , r1 |= initClosure s p dat jCurrentCCS
                      ]
                    , returnStack
                    ])
                 ]

        pushAllRegs :: JStgExpr -> JSM JStgStat
        pushAllRegs :: JStgExpr -> JSM JStgStat
    pushAllRegs JStgExpr
    tag =
          (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall t.
    (JVarMagic t, ToJExpr t) =>
    (t -> JSM JStgStat) -> JSM JStgStat
    jVar \JStgExpr
    regs ->
                 JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
    forall a b. (a -> b) -> a -> b
    $
                 [ JStgExpr
    regs JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    tag JStgExpr -> JStgExpr -> JStgExpr
    .>>. JStgExpr
    8
                 , JStgExpr
    sp JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    regs
                 , JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
    SwitchStat JStgExpr
    regs ((Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> (JStgExpr, JStgStat)
    pushReg [Int
    65,Int
    64..Int
    2]) JStgStat
    forall a. Monoid a => a
    mempty
                 ]
          where
            pushReg :: Int -> (JStgExpr, JStgStat)
            pushReg :: Int -> (JStgExpr, JStgStat)
    pushReg Int
    r = (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (Int
    rInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1),  JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! (JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (Int
    r Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    2)) JStgExpr -> JStgExpr -> JStgStat
    |= Int -> JStgExpr
    jsReg Int
    r)

        pushArgs :: JStgExpr -> JStgExpr -> JSM JStgStat
        pushArgs :: JStgExpr -> JStgExpr -> JSM JStgStat
    pushArgs JStgExpr
    start JStgExpr
    end =
          JStgExpr
    -> (JStgExpr -> JStgExpr)
    -> (JStgExpr -> JSM JStgStat)
    -> JSM JStgStat
    loop JStgExpr
    end (JStgExpr -> JStgExpr -> JStgExpr
    .>=.JStgExpr
    start)
          \JStgExpr
    i -> JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $
                StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    jString FastString
    "pushing register: " JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    i)
                JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> (JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! (JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    start JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - JStgExpr
    i) JStgExpr -> JStgExpr -> JStgStat
    |= FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "h$getReg" [JStgExpr
    iJStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    +JStgExpr
    1])
                JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgExpr -> JStgStat
    postDecrS JStgExpr
    i

    -- | Make specialized apply function for the given ApplySpec
    specApply :: StgToJSConfig -> ApplySpec -> JSM JStgStat
    specApply :: StgToJSConfig -> ApplySpec -> JSM JStgStat
    specApply StgToJSConfig
    cfg spec :: ApplySpec
    spec@(ApplySpec ApplyConv
    conv Int
    nargs Int
    nvars) =
      let fun_name :: FastString
    fun_name = ApplySpec -> FastString
    specApplyName ApplySpec
    spec
      in case ApplyConv
    conv of
        ApplyConv
    RegsConv  -> StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
    fastApply  StgToJSConfig
    cfg FastString
    fun_name Int
    nargs Int
    nvars
        ApplyConv
    StackConv -> StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
    stackApply StgToJSConfig
    cfg FastString
    fun_name Int
    nargs Int
    nvars

    -- | Make specialized apply function with Stack calling convention
    stackApply
      :: StgToJSConfig
      -> FastString
      -> Int
      -> Int
      -> JSM JStgStat
    stackApply :: StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
    stackApply StgToJSConfig
    s FastString
    fun_name Int
    nargs Int
    nvars =
      -- special case for h$ap_0_0
      if Int
    nargs Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 Bool -> Bool -> Bool
    && Int
    nvars Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0
        then ClosureInfo -> JSM JStgStat -> JSM JStgStat
    closure ClosureInfo
    info0 JSM JStgStat
    body0
        else ClosureInfo -> JSM JStgStat -> JSM JStgStat
    closure ClosureInfo
    info JSM JStgStat
    body
      where
        info :: ClosureInfo
    info  = Ident
    -> CIRegs
    -> FastString
    -> CILayout
    -> CIType
    -> CIStatic
    -> ClosureInfo
    ClosureInfo (FastString -> Ident
    global FastString
    fun_name) (Int -> [JSRep] -> CIRegs
    CIRegs Int
    0 [JSRep
    PtrV]) FastString
    fun_name (Int -> CILayout
    CILayoutUnknown Int
    nvars) CIType
    CIStackFrame CIStatic
    forall a. Monoid a => a
    mempty
        info0 :: ClosureInfo
    info0 = Ident
    -> CIRegs
    -> FastString
    -> CILayout
    -> CIType
    -> CIStatic
    -> ClosureInfo
    ClosureInfo (FastString -> Ident
    global FastString
    fun_name) (Int -> [JSRep] -> CIRegs
    CIRegs Int
    0 [JSRep
    PtrV]) FastString
    fun_name (Int -> [JSRep] -> CILayout
    CILayoutFixed Int
    0 [])    CIType
    CIStackFrame CIStatic
    forall a. Monoid a => a
    mempty

        body0 :: JSM JStgStat
    body0 = (Int -> JStgStat
    adjSpN' Int
    1 JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <>) (JStgStat -> JStgStat) -> JSM JStgStat -> JSM JStgStat
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> StgToJSConfig -> JStgExpr -> JSM JStgStat
    enter StgToJSConfig
    s JStgExpr
    r1

        body :: JSM JStgStat
    body = (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall t.
    (JVarMagic t, ToJExpr t) =>
    (t -> JSM JStgStat) -> JSM JStgStat
    jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
    -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ \JStgExpr
    c ->
          do fun_case <- JStgExpr -> JSM JStgStat
    funCase JStgExpr
    c
             pap_case <- papCase c
             return $ mconcat
               [ c |= closureEntry r1
               , traceRts s (toJExpr fun_name
                              + jString " "
                              + (c .^ "n")
                              + jString " sp: " + sp
                              + jString " a: "  + (c .^ "a"))
               , SwitchStat (entryClosureType c)
                 [ (toJExpr Thunk, traceRts s (toJExpr $ fun_name <> ": thunk") <> profStat s pushRestoreCCS <> returnS c)
                 , (toJExpr Fun, traceRts s (toJExpr $ fun_name <> ": fun") <> fun_case)
                 , (toJExpr Pap, traceRts s (toJExpr $ fun_name <> ": pap") <> pap_case)
                 , (toJExpr Blackhole, push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))
                 ] (appS "throw" [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (entryClosureType c)])
               ]

        funExact :: JStgExpr -> JStgStat
    funExact JStgExpr
    c = Int -> [JStgExpr] -> JStgStat
    popSkip Int
    1 ([JStgExpr] -> [JStgExpr]
    forall a. [a] -> [a]
    reverse ([JStgExpr] -> [JStgExpr]) -> [JStgExpr] -> [JStgExpr]
    forall a b. (a -> b) -> a -> b
    $ Int -> [JStgExpr] -> [JStgExpr]
    forall a. Int -> [a] -> [a]
    take Int
    nvars [JStgExpr]
    jsRegsFromR2) JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgExpr -> JStgStat
    returnS JStgExpr
    c
        stackArgs :: [JStgExpr]
    stackArgs = (Int -> JStgExpr) -> [Int] -> [JStgExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    x -> JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! (JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    x)) [Int
    1..Int
    nvars]

        papCase :: JStgExpr -> JSM JStgStat
        papCase :: JStgExpr -> JSM JStgStat
    papCase JStgExpr
    c = ((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
    forall args.
    JSArgument args =>
    (args -> JSM JStgStat) -> JSM JStgStat
    jVars \(JStgExpr
    expr, JStgExpr
    arity0, JStgExpr
    arity) ->
          do oversat_case <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
    oversatCase JStgExpr
    c JStgExpr
    arity0 JStgExpr
    arity
             return $ mconcat $
               case expr of
                 ValExpr (JVar Ident
    pap) -> [ JStgExpr
    arity0 JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    papArity JStgExpr
    r1
                                       , JStgExpr
    arity JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    mask8 JStgExpr
    arity0
                                       , StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": found pap, arity: ") JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    arity)
                                       , JStgExpr -> JStgStat -> JStgStat -> JStgStat
    ifS (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nargs JStgExpr -> JStgExpr -> JStgExpr
    .===. JStgExpr
    arity)
                                       --then
                                         (StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": exact")) JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgExpr -> JStgStat
    funExact JStgExpr
    c)
                                       -- else
                                         (JStgExpr -> JStgStat -> JStgStat -> JStgStat
    ifS (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nargs JStgExpr -> JStgExpr -> JStgExpr
    .>. JStgExpr
    arity)
                                          (StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": oversat")) JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgStat
    oversat_case)
                                          (StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": undersat"))
                                           JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> StgToJSConfig
    -> Ident -> JStgExpr -> JStgExpr -> [JStgExpr] -> JStgStat
    mkPap StgToJSConfig
    s Ident
    pap JStgExpr
    r1 (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nargs) [JStgExpr]
    stackArgs
                                           JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> (JStgExpr
    sp JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (Int
    nvars Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1))
                                           JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> (JStgExpr
    r1 JStgExpr -> JStgExpr -> JStgStat
    |= Ident -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Ident
    pap)
                                           JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgStat
    returnStack))
                                       ]
                 JStgExpr
    _                   -> [JStgStat]
    forall a. Monoid a => a
    mempty

        funCase :: JStgExpr -> JSM JStgStat
        funCase :: JStgExpr -> JSM JStgStat
    funCase JStgExpr
    c = ((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
    forall args.
    JSArgument args =>
    (args -> JSM JStgStat) -> JSM JStgStat
    jVars \(JStgExpr
    expr, JStgExpr
    ar0, JStgExpr
    ar) ->
          do oversat_case <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
    oversatCase JStgExpr
    c JStgExpr
    ar0 JStgExpr
    ar
             return $ mconcat $
               case expr of
                 ValExpr (JVar Ident
    pap) -> [ JStgExpr
    ar0 JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    funArity' JStgExpr
    c
                                       , JStgExpr
    ar JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    mask8 JStgExpr
    ar0
                                       , JStgExpr -> JStgStat -> JStgStat -> JStgStat
    ifS (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nargs JStgExpr -> JStgExpr -> JStgExpr
    .===. JStgExpr
    ar)
                                         (StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": exact")) JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgExpr -> JStgStat
    funExact JStgExpr
    c)
                                         (JStgExpr -> JStgStat -> JStgStat -> JStgStat
    ifS (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nargs JStgExpr -> JStgExpr -> JStgExpr
    .>. JStgExpr
    ar)
                                          (StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": oversat"))
                                           JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgStat
    oversat_case)
                                          (StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": undersat"))
                                           JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> StgToJSConfig
    -> Ident -> JStgExpr -> JStgExpr -> [JStgExpr] -> JStgStat
    mkPap StgToJSConfig
    s Ident
    pap (StgReg -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr StgReg
    R1) (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nargs) [JStgExpr]
    stackArgs
                                           JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> (JStgExpr
    sp JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (Int
    nvarsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1))
                                           JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> (JStgExpr
    r1 JStgExpr -> JStgExpr -> JStgStat
    |= Ident -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Ident
    pap)
                                           JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgStat
    returnStack))
                                       ]
                 JStgExpr
    _                  -> [JStgStat]
    forall a. Monoid a => a
    mempty

        -- oversat: call the function but keep enough on the stack for the next
        oversatCase :: JStgExpr -- function
                    -> JStgExpr -- the arity tag
                    -> JStgExpr -- real arity (arity & 0xff)
                    -> JSM JStgStat
        oversatCase :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
    oversatCase JStgExpr
    c JStgExpr
    arity JStgExpr
    arity0 =
          ((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
    forall args.
    JSArgument args =>
    (args -> JSM JStgStat) -> JSM JStgStat
    jVars \(JStgExpr
    rs, JStgExpr
    newAp) ->
                 JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
    forall a b. (a -> b) -> a -> b
    $
                 [ JStgExpr
    rs JStgExpr -> JStgExpr -> JStgStat
    |= (JStgExpr
    arity JStgExpr -> JStgExpr -> JStgExpr
    .>>. JStgExpr
    8)
                 , JStgExpr -> JStgStat
    loadRegs JStgExpr
    rs
                 , JStgExpr
    sp JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - JStgExpr
    rs
                 , JStgExpr
    newAp JStgExpr -> JStgExpr -> JStgStat
    |= (FastString -> JStgExpr
    var FastString
    "h$apply" JStgExpr -> JStgExpr -> JStgExpr
    .! ((Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nargsJStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    -JStgExpr
    arity0)JStgExpr -> JStgExpr -> JStgExpr
    .|.((Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nvarsJStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    -JStgExpr
    rs)JStgExpr -> JStgExpr -> JStgExpr
    .<<.JStgExpr
    8)))
                 , JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! JStgExpr
    sp JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    newAp
                 , StgToJSConfig -> JStgStat -> JStgStat
    profStat StgToJSConfig
    s JStgStat
    pushRestoreCCS
                 , StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": new stack frame: ") JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + (JStgExpr
    newAp JStgExpr -> FastString -> JStgExpr
    .^ FastString
    "n"))
                 , JStgExpr -> JStgStat
    returnS JStgExpr
    c
                 ]
          where
            loadRegs :: JStgExpr -> JStgStat
    loadRegs JStgExpr
    rs = JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
    SwitchStat JStgExpr
    rs [(JStgExpr, JStgStat)]
    switchAlts JStgStat
    forall a. Monoid a => a
    mempty
              where
                switchAlts :: [(JStgExpr, JStgStat)]
    switchAlts = (Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    x -> (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    x, Int -> JStgExpr
    jsReg (Int
    xInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! (JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    x))) [Int
    nvars,Int
    nvarsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1..Int
    1]

    -- | Make specialized apply function with Regs calling convention
    --
    -- h$ap_n_r_fast is entered if a function of unknown arity is called, n
    -- arguments are already in r registers
    fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
    fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat
    fastApply StgToJSConfig
    s FastString
    fun_name Int
    nargs Int
    nvars = if Int
    nargs Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 Bool -> Bool -> Bool
    && Int
    nvars Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0
                                       -- special case for h$ap_0_0_fast
                                       then Ident -> JSM JStgStat -> JSM JStgStat
    jFunction' Ident
    func JSM JStgStat
    ap_fast
                                       -- general case
                                       else Ident -> JSM JStgStat -> JSM JStgStat
    jFunction' Ident
    func JSM JStgStat
    body
      where
          func :: Ident
    func    = FastString -> Ident
    global FastString
    fun_name
          ap_fast :: JSM JStgStat
          ap_fast :: JSM JStgStat
    ap_fast = StgToJSConfig -> JStgExpr -> JSM JStgStat
    enter StgToJSConfig
    s JStgExpr
    r1

          regArgs :: [JStgExpr]
    regArgs = Int -> [JStgExpr] -> [JStgExpr]
    forall a. Int -> [a] -> [a]
    take Int
    nvars [JStgExpr]
    jsRegsFromR2

          mkAp :: Int -> Int -> [JStgExpr]
          mkAp :: Int -> Int -> [JStgExpr]
    mkAp Int
    n' Int
    r' = [ ApplySpec -> JStgExpr
    specApplyExpr (ApplyConv -> Int -> Int -> ApplySpec
    ApplySpec ApplyConv
    StackConv Int
    n' Int
    r') ]

          body :: JSM JStgStat
    body = ((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
    forall args.
    JSArgument args =>
    (args -> JSM JStgStat) -> JSM JStgStat
    jVars (((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat)
    -> ((JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ \(JStgExpr
    c, JStgExpr
    farity, JStgExpr
    arity)  ->
            do fun_case_fun <- JStgExpr -> JStgExpr -> JSM JStgStat
    funCase JStgExpr
    c JStgExpr
    farity
               fun_case_pap <- funCase c arity
               return $ mconcat $
                 [ c |= closureEntry r1
                 , traceRts s (toJExpr (fun_name <> ": sp ") + sp)
                 , SwitchStat (entryClosureType c)
                   [(toJExpr Fun, traceRts s (toJExpr (fun_name <> ": ")
                                              + clName c
                                              + jString " (arity: " + (c .^ "a") + jString ")")
                                  <> (farity |= funArity' c)
                                  <> fun_case_fun)
                   ,(toJExpr Pap, traceRts s (toJExpr (fun_name <> ": pap")) <> (arity |= papArity r1) <> fun_case_pap)
                   ,(toJExpr Thunk, traceRts s (toJExpr (fun_name <> ": thunk")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> profStat s pushRestoreCCS <> returnS c)
                   ,(toJExpr Blackhole, traceRts s (toJExpr (fun_name <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))]
                   (appS "throw" [toJExpr (fun_name <> ": unexpected closure type: ") + entryClosureType c])
                 ]

          funCase :: JStgExpr -> JStgExpr -> JSM JStgStat
          funCase :: JStgExpr -> JStgExpr -> JSM JStgStat
    funCase JStgExpr
    c JStgExpr
    arity = ((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
    forall args.
    JSArgument args =>
    (args -> JSM JStgStat) -> JSM JStgStat
    jVars \(JStgExpr
    arg, JStgExpr
    ar) ->
            do oversat_case <- JStgExpr -> JStgExpr -> JSM JStgStat
    oversatCase JStgExpr
    c JStgExpr
    arity
               return $ mconcat $
                 case arg of
                   ValExpr (JVar Ident
    pap) -> [ JStgExpr
    ar JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    mask8 JStgExpr
    arity
                                         ,  JStgExpr -> JStgStat -> JStgStat -> JStgStat
    ifS (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nargs JStgExpr -> JStgExpr -> JStgExpr
    .===. JStgExpr
    ar)
                                         -- then
                                           (StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": exact")) JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgExpr -> JStgStat
    returnS JStgExpr
    c)
                                         -- else
                                           (JStgExpr -> JStgStat -> JStgStat -> JStgStat
    ifS (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nargs JStgExpr -> JStgExpr -> JStgExpr
    .>. JStgExpr
    ar)
                                           --then
                                            (StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": oversat")) JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgStat
    oversat_case)
                                           -- else
                                            (StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": undersat"))
                                             JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> StgToJSConfig
    -> Ident -> JStgExpr -> JStgExpr -> [JStgExpr] -> JStgStat
    mkPap StgToJSConfig
    s Ident
    pap JStgExpr
    r1 (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nargs) [JStgExpr]
    regArgs
                                             JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> (JStgExpr
    r1 JStgExpr -> JStgExpr -> JStgStat
    |= Ident -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Ident
    pap)
                                             JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgStat
    returnStack))
                                         ]
                   JStgExpr
    _             -> [JStgStat]
    forall a. Monoid a => a
    mempty

          oversatCase :: JStgExpr -> JStgExpr -> JSM JStgStat
          oversatCase :: JStgExpr -> JStgExpr -> JSM JStgStat
    oversatCase JStgExpr
    c JStgExpr
    arity =
             ((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
    forall args.
    JSArgument args =>
    (args -> JSM JStgStat) -> JSM JStgStat
    jVars \(JStgExpr
    rs, JStgExpr
    rsRemain) ->
                    JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
    forall a b. (a -> b) -> a -> b
    $
                    [ JStgExpr
    rs JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    arity JStgExpr -> JStgExpr -> JStgExpr
    .>>. JStgExpr
    8
                    , JStgExpr
    rsRemain JStgExpr -> JStgExpr -> JStgStat
    |= Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nvars JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - JStgExpr
    rs
                    , StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr
                                  (FastString
    fun_name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    " regs oversat ")
                                  JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    rs
                                  JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + FastString -> JStgExpr
    jString FastString
    " remain: "
                                  JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    rsRemain)
                    , JStgExpr -> JStgStat
    saveRegs JStgExpr
    rs
                    , JStgExpr
    sp JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    rsRemain JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    1
                    , JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! JStgExpr
    sp JStgExpr -> JStgExpr -> JStgStat
    |= FastString -> JStgExpr
    var FastString
    "h$apply" JStgExpr -> JStgExpr -> JStgExpr
    .! ((JStgExpr
    rsRemainJStgExpr -> JStgExpr -> JStgExpr
    .<<.JStgExpr
    8)JStgExpr -> JStgExpr -> JStgExpr
    .|. (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    nargs JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - JStgExpr -> JStgExpr
    mask8 JStgExpr
    arity))
                    , StgToJSConfig -> JStgStat -> JStgStat
    profStat StgToJSConfig
    s JStgStat
    pushRestoreCCS
                    , JStgExpr -> JStgStat
    returnS JStgExpr
    c
                    ]
            where
              saveRegs :: JStgExpr -> JStgStat
    saveRegs JStgExpr
    n = JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
    SwitchStat JStgExpr
    n [(JStgExpr, JStgStat)]
    switchAlts JStgStat
    forall a. Monoid a => a
    mempty
                where
                  switchAlts :: [(JStgExpr, JStgStat)]
    switchAlts = (Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    x -> (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    x, JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! (JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (Int
    nvarsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    x)) JStgExpr -> JStgExpr -> JStgStat
    |= Int -> JStgExpr
    jsReg (Int
    xInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    2))) [Int
    0..Int
    nvarsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1]

    zeroApply :: StgToJSConfig -> JSM JStgStat
    zeroApply :: StgToJSConfig -> JSM JStgStat
    zeroApply StgToJSConfig
    s = Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall args.
    JSArgument args =>
    Ident -> (args -> JSM JStgStat) -> JSM JStgStat
    jFunction (FastString -> Ident
    global FastString
    "h$e")
                  ((Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat)
    -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ \(MkSolo JStgExpr
    c) -> (JStgStat -> JStgStat) -> JSM JStgStat -> JSM JStgStat
    forall a b.
    (a -> b) -> StateT JEnv Identity a -> StateT JEnv Identity b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((JStgExpr
    r1 JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    c) JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <>) (JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ StgToJSConfig -> JStgExpr -> JSM JStgStat
    enter StgToJSConfig
    s JStgExpr
    c

    -- carefully enter a closure that might be a thunk or a function

    -- ex may be a local var, but must've been copied to R1 before calling this
    enter :: StgToJSConfig -> JStgExpr -> JSM JStgStat
    enter :: StgToJSConfig -> JStgExpr -> JSM JStgStat
    enter StgToJSConfig
    s JStgExpr
    ex = (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall t.
    (JVarMagic t, ToJExpr t) =>
    (t -> JSM JStgStat) -> JSM JStgStat
    jVar \JStgExpr
    c ->
      JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
    forall a b. (a -> b) -> a -> b
    $
      [ JStgExpr -> JStgStat -> JStgStat
    jwhenS (FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "typeof" [JStgExpr
    ex] JStgExpr -> JStgExpr -> JStgExpr
    .!==. JStgExpr
    jTyObject) JStgStat
    returnStack
      , JStgExpr
    c JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    closureEntry JStgExpr
    ex
      , JStgExpr -> JStgStat -> JStgStat
    jwhenS (JStgExpr
    c JStgExpr -> JStgExpr -> JStgExpr
    .===. FastString -> JStgExpr
    var FastString
    "h$unbox_e") ((JStgExpr
    r1 JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    closureField1 JStgExpr
    ex) JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgStat
    returnStack)
      , JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
    SwitchStat (JStgExpr -> JStgExpr
    entryClosureType JStgExpr
    c)
        [ (ClosureType -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr ClosureType
    Con, JStgStat
    forall a. Monoid a => a
    mempty)
        , (ClosureType -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr ClosureType
    Fun, JStgStat
    forall a. Monoid a => a
    mempty)
        , (ClosureType -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr ClosureType
    Pap, JStgStat
    returnStack)
        , (ClosureType -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr ClosureType
    Blackhole, StgToJSConfig -> [JStgExpr] -> JStgStat
    push' StgToJSConfig
    s [FastString -> JStgExpr
    var FastString
    "h$ap_0_0", JStgExpr
    ex, FastString -> JStgExpr
    var FastString
    "h$return"]
            JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgExpr -> JStgStat
    returnS (FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "h$blockOnBlackhole" [JStgExpr
    ex]))
        ] (JStgExpr -> JStgStat
    returnS JStgExpr
    c)
      ]

    updates :: StgToJSConfig -> JSM JStgStat
    updates :: StgToJSConfig -> JSM JStgStat
    updates StgToJSConfig
    s = do
      upd_frm <- JSM JStgStat
    update_frame
      upd_frm_lne <- update_frame_lne
      return $ BlockStat [upd_frm, upd_frm_lne]
      where
        unbox_closure :: JStgExpr -> Closure
    unbox_closure JStgExpr
    f1 = Closure { clEntry :: JStgExpr
    clEntry  = FastString -> JStgExpr
    var FastString
    "h$unbox_e"
                                   , clField1 :: JStgExpr
    clField1 = JStgExpr
    f1
                                   , clField2 :: JStgExpr
    clField2 = JStgExpr
    null_
                                   , clMeta :: JStgExpr
    clMeta   = JStgExpr
    0
                                   , clCC :: Maybe JStgExpr
    clCC     = Maybe JStgExpr
    forall a. Maybe a
    Nothing
                                   }
        upd_loop' :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
    upd_loop' JStgExpr
    ss' JStgExpr
    si' JStgExpr
    sir' = JStgExpr
    -> (JStgExpr -> JStgExpr)
    -> (JStgExpr -> JSM JStgStat)
    -> JSM JStgStat
    loop JStgExpr
    zero_ (JStgExpr -> JStgExpr -> JStgExpr
    .<. JStgExpr
    ss' JStgExpr -> FastString -> JStgExpr
    .^ FastString
    "length")
                            ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
    -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ \JStgExpr
    i -> JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat
                              [ JStgExpr
    si' JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    ss' JStgExpr -> JStgExpr -> JStgExpr
    .! JStgExpr
    i
                              , JStgExpr
    sir' JStgExpr -> JStgExpr -> JStgStat
    |= (JStgExpr -> JStgExpr
    closureField2 JStgExpr
    si') JStgExpr -> [JStgExpr] -> JStgExpr
    `ApplExpr` [JStgExpr
    r1]
                              , JStgExpr -> JStgStat -> JStgStat -> JStgStat
    ifS (FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "typeof" [JStgExpr
    sir'] JStgExpr -> JStgExpr -> JStgExpr
    .===. JStgExpr
    jTyObject)
                                (CopyCC -> JStgExpr -> JStgExpr -> JStgStat
    copyClosure CopyCC
    DontCopyCC JStgExpr
    si' JStgExpr
    sir')
                                (JStgExpr -> Closure -> JStgStat
    assignClosure JStgExpr
    si' (Closure -> JStgStat) -> Closure -> JStgStat
    forall a b. (a -> b) -> a -> b
    $ JStgExpr -> Closure
    unbox_closure JStgExpr
    sir')
                              , JStgExpr -> JStgStat
    postIncrS JStgExpr
    i
                              ]
        update_frame :: JSM JStgStat
    update_frame = ClosureInfo -> JSM JStgStat -> JSM JStgStat
    closure
                       (Ident
    -> CIRegs
    -> FastString
    -> CILayout
    -> CIType
    -> CIStatic
    -> ClosureInfo
    ClosureInfo (FastString -> Ident
    global FastString
    "h$upd_frame") (Int -> [JSRep] -> CIRegs
    CIRegs Int
    0 [JSRep
    PtrV]) FastString
    "h$upd_frame" (Int -> [JSRep] -> CILayout
    CILayoutFixed Int
    1 [JSRep
    PtrV]) CIType
    CIStackFrame CIStatic
    forall a. Monoid a => a
    mempty)
                       (JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
     -> JSM JStgStat)
    -> JSM JStgStat
    forall args.
    JSArgument args =>
    (args -> JSM JStgStat) -> JSM JStgStat
    jVars \(JStgExpr
    updatee, JStgExpr
    waiters, JStgExpr
    ss, JStgExpr
    si, JStgExpr
    sir) ->
                           do upd_loop         <- JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat
    upd_loop' JStgExpr
    ss JStgExpr
    si JStgExpr
    sir
                              wake_thread_loop <- loop zero_ (.<. waiters .^ "length")
                                                  \JStgExpr
    i -> JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $
                                                        FastString -> [JStgExpr] -> JStgStat
    appS FastString
    "h$wakeupThread" [JStgExpr
    waiters JStgExpr -> JStgExpr -> JStgExpr
    .! JStgExpr
    i]
                                                        JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgExpr -> JStgStat
    postIncrS JStgExpr
    i
                              let updateCC JStgExpr
    updatee = JStgExpr -> JStgExpr
    closureCC JStgExpr
    updatee JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    jCurrentCCS

                              return $ mconcat $
                                [ updatee |= stack .! (sp - 1)
                                   , traceRts s (jString "h$upd_frame updatee alloc: " + updatee .^ "alloc")
                                   , -- wake up threads blocked on blackhole
                                     waiters |= closureField2 updatee
                                   , jwhenS (waiters .!==. null_) wake_thread_loop
                                   , -- update selectors
                                     jwhenS ((app "typeof" [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel"))
                                     ((ss |= closureMeta updatee .^ "sel")
                                      <> upd_loop)
                                   , -- overwrite the object
                                     ifS (app "typeof" [r1] .===. jTyObject)
                                     (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureEntry r1) .^ "n"))
                                              , copyClosure DontCopyCC updatee r1
                                              ])
                                   -- the heap object is represented by another type of value
                                   -- (e.g. a JS number or string) so the unboxing closure
                                   -- will simply return it.
                                     (assignClosure updatee (unbox_closure r1))
                                   , profStat s (updateCC updatee)
                                   , adjSpN' 2
                                   , traceRts s (jString "h$upd_frame: updating: "
                                                 + updatee
                                                 + jString " -> "
                                                 + r1)
                                   , returnStack
                                   ]

        update_frame_lne :: JSM JStgStat
    update_frame_lne = ClosureInfo -> JSM JStgStat -> JSM JStgStat
    closure
                         (Ident
    -> CIRegs
    -> FastString
    -> CILayout
    -> CIType
    -> CIStatic
    -> ClosureInfo
    ClosureInfo (FastString -> Ident
    global FastString
    "h$upd_frame_lne") (Int -> [JSRep] -> CIRegs
    CIRegs Int
    0 [JSRep
    PtrV]) FastString
    "h$upd_frame_lne" (Int -> [JSRep] -> CILayout
    CILayoutFixed Int
    1 [JSRep
    PtrV]) CIType
    CIStackFrame CIStatic
    forall a. Monoid a => a
    mempty)
                         (JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall t.
    (JVarMagic t, ToJExpr t) =>
    (t -> JSM JStgStat) -> JSM JStgStat
    jVar \JStgExpr
    updateePos ->
                             JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
    forall a b. (a -> b) -> a -> b
    $
                             [ JStgExpr
    updateePos JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! (JStgExpr
    sp JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - JStgExpr
    1)
                             , (JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! JStgExpr
    updateePos JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    r1)
                             , Int -> JStgStat
    adjSpN' Int
    2
                             , StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    jString FastString
    "h$upd_frame_lne: updating: "
                                           JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    updateePos
                                           JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + FastString -> JStgExpr
    jString FastString
    " -> "
                                           JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    r1)
                             , JStgStat
    returnStack
                             ]

    selectors :: StgToJSConfig -> JSM JStgStat
    selectors :: StgToJSConfig -> JSM JStgStat
    selectors StgToJSConfig
    s =
      do
        sel_one  <- FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
    mkSel FastString
    "1"      JStgExpr -> JStgExpr
    closureField1
        sel_twoA <- mkSel "2a"  closureField2
        sel_twoB <- mkSel "2b"  (closureField1 . closureField2)
        rest     <- mconcat <$> (mapM mkSelN [3..16])
        return $
          sel_one <> sel_twoA <> sel_twoB <> rest
       where
        mkSelN :: Int -> JSM JStgStat
        mkSelN :: Int -> JSM JStgStat
    mkSelN Int
    x = FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
    mkSel ([Char] -> FastString
    mkFastString ([Char] -> FastString) -> [Char] -> FastString
    forall a b. (a -> b) -> a -> b
    $ Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    x)
                         (\JStgExpr
    e -> JStgExpr -> Ident -> JStgExpr
    SelExpr (JStgExpr -> JStgExpr
    closureField2 (JStgExpr -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr JStgExpr
    e))
                                (FastString -> Ident
    global (FastString -> Ident) -> FastString -> Ident
    forall a b. (a -> b) -> a -> b
    $ [Char] -> FastString
    mkFastString ([Char]
    "d" [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> [Char]
    forall a. Show a => a -> [Char]
    show (Int
    xInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1))))

        mkSel :: FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
        mkSel :: FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat
    mkSel FastString
    name JStgExpr -> JStgExpr
    sel = [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat)
    -> StateT JEnv Identity [JStgStat] -> JSM JStgStat
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [JSM JStgStat] -> StateT JEnv Identity [JStgStat]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence
          [Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall args.
    JSArgument args =>
    Ident -> (args -> JSM JStgStat) -> JSM JStgStat
    jFunction (FastString -> Ident
    global FastString
    createName) ((Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat)
    -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $
           \(MkSolo JStgExpr
    r) -> JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat
              [ StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    "selector create: " FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    " for ") JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + (JStgExpr
    r JStgExpr -> FastString -> JStgExpr
    .^ FastString
    "alloc"))
              , JStgExpr -> JStgStat -> JStgStat -> JStgStat
    ifS (JStgExpr -> JStgExpr
    isThunk JStgExpr
    r JStgExpr -> JStgExpr -> JStgExpr
    .||. JStgExpr -> JStgExpr
    isBlackhole JStgExpr
    r)
                  (JStgExpr -> JStgStat
    returnS (FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "h$mkSelThunk" [JStgExpr
    r, JVal -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString -> JVal
    v FastString
    entryName), JVal -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString -> JVal
    v FastString
    resName)]))
                  (JStgExpr -> JStgStat
    returnS (JStgExpr -> JStgExpr
    sel JStgExpr
    r))
              ]
          , Ident -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall args.
    JSArgument args =>
    Ident -> (args -> JSM JStgStat) -> JSM JStgStat
    jFunction (FastString -> Ident
    global FastString
    resName) ((Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat)
    -> (Solo JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $
            \(MkSolo JStgExpr
    r) -> JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat
              [ StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    "selector result: " FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    " for ") JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + (JStgExpr
    r JStgExpr -> FastString -> JStgExpr
    .^ FastString
    "alloc"))
              , JStgExpr -> JStgStat
    returnS (JStgExpr -> JStgExpr
    sel JStgExpr
    r)
              ]
          , ClosureInfo -> JSM JStgStat -> JSM JStgStat
    closure
            (Ident
    -> CIRegs
    -> FastString
    -> CILayout
    -> CIType
    -> CIStatic
    -> ClosureInfo
    ClosureInfo (FastString -> Ident
    global FastString
    entryName) (Int -> [JSRep] -> CIRegs
    CIRegs Int
    0 [JSRep
    PtrV]) (FastString
    "select " FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    name) (Int -> [JSRep] -> CILayout
    CILayoutFixed Int
    1 [JSRep
    PtrV]) CIType
    CIThunk CIStatic
    forall a. Monoid a => a
    mempty)
            ((JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall t.
    (JVarMagic t, ToJExpr t) =>
    (t -> JSM JStgStat) -> JSM JStgStat
    jVar ((JStgExpr -> JSM JStgStat) -> JSM JStgStat)
    -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ \JStgExpr
    tgt ->
              JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
    forall a b. (a -> b) -> a -> b
    $
              [ JStgExpr
    tgt JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    closureField1 JStgExpr
    r1
              , StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    "selector entry: " FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    " for ") JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + (JStgExpr
    tgt JStgExpr -> FastString -> JStgExpr
    .^ FastString
    "alloc"))
              , JStgExpr -> JStgStat -> JStgStat -> JStgStat
    ifS (JStgExpr -> JStgExpr
    isThunk JStgExpr
    tgt JStgExpr -> JStgExpr -> JStgExpr
    .||. JStgExpr -> JStgExpr
    isBlackhole JStgExpr
    tgt)
                  (JStgExpr -> JStgStat
    preIncrS JStgExpr
    sp
                   JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> (JStgExpr
    stack JStgExpr -> JStgExpr -> JStgExpr
    .! JStgExpr
    sp JStgExpr -> JStgExpr -> JStgStat
    |= FastString -> JStgExpr
    var FastString
    frameName)
                   JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgExpr -> JStgStat
    returnS (FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "h$e" [JStgExpr
    tgt]))
                  (JStgExpr -> JStgStat
    returnS (FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "h$e" [JStgExpr -> JStgExpr
    sel JStgExpr
    tgt]))
              ])
          , ClosureInfo -> JSM JStgStat -> JSM JStgStat
    closure
            (Ident
    -> CIRegs
    -> FastString
    -> CILayout
    -> CIType
    -> CIStatic
    -> ClosureInfo
    ClosureInfo (FastString -> Ident
    global FastString
    frameName) (Int -> [JSRep] -> CIRegs
    CIRegs Int
    0 [JSRep
    PtrV]) (FastString
    "select " FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    " frame") (Int -> [JSRep] -> CILayout
    CILayoutFixed Int
    0 []) CIType
    CIStackFrame CIStatic
    forall a. Monoid a => a
    mempty)
            (JSM JStgStat -> JSM JStgStat) -> JSM JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $
            [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat [ StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    "selector frame: " FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    name))
                    , JStgExpr -> JStgStat
    postDecrS JStgExpr
    sp
                    , JStgExpr -> JStgStat
    returnS (FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "h$e" [JStgExpr -> JStgExpr
    sel JStgExpr
    r1])
                    ]
          ]

          where
             v :: FastString -> JVal
    v FastString
    x   = Ident -> JVal
    JVar (FastString -> Ident
    global FastString
    x)
             n :: FastString -> FastString
    n FastString
    ext =  FastString
    "h$c_sel_" FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    name FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ext
             createName :: FastString
    createName = FastString -> FastString
    n FastString
    ""
             resName :: FastString
    resName    = FastString -> FastString
    n FastString
    "_res"
             entryName :: FastString
    entryName  = FastString -> FastString
    n FastString
    "_e"
             frameName :: FastString
    frameName  = FastString -> FastString
    n FastString
    "_frame_e"

    -- arity is the remaining arity after our supplied arguments are applied
    mkPap :: StgToJSConfig
          -> Ident   -- ^ id of the pap object
          -> JStgExpr   -- ^ the function that's called (can be a second pap)
          -> JStgExpr   -- ^ number of arguments in pap
          -> [JStgExpr] -- ^ values for the supplied arguments
          -> JStgStat
    mkPap :: StgToJSConfig
    -> Ident -> JStgExpr -> JStgExpr -> [JStgExpr] -> JStgStat
    mkPap StgToJSConfig
    s Ident
    tgt JStgExpr
    fun JStgExpr
    n [JStgExpr]
    values =
          StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s ([Char] -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr ([Char] -> JStgExpr) -> [Char] -> JStgExpr
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "making pap with: " [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> [Char]
    forall a. Show a => a -> [Char]
    show ([JStgExpr] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [JStgExpr]
    values) [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    " items")
          JStgStat -> JStgStat -> JStgStat
    forall a. Monoid a => a -> a -> a
    `mappend`
          StgToJSConfig
    -> Bool
    -> Ident
    -> JStgExpr
    -> [JStgExpr]
    -> Maybe JStgExpr
    -> JStgStat
    allocDynamic StgToJSConfig
    s Bool
    True Ident
    tgt (Ident -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Ident
    entry) (JStgExpr
    funJStgExpr -> [JStgExpr] -> [JStgExpr]
    forall a. a -> [a] -> [a]
    :JStgExpr
    papArJStgExpr -> [JStgExpr] -> [JStgExpr]
    forall a. a -> [a] -> [a]
    :(JStgExpr -> JStgExpr) -> [JStgExpr] -> [JStgExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map JStgExpr -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr [JStgExpr]
    values')
            (if StgToJSConfig -> Bool
    csProf StgToJSConfig
    s then JStgExpr -> Maybe JStgExpr
    forall a. a -> Maybe a
    Just JStgExpr
    jCurrentCCS else Maybe JStgExpr
    forall a. Maybe a
    Nothing)
      where
        papAr :: JStgExpr
    papAr = JStgExpr -> Maybe JStgExpr -> JStgExpr
    funOrPapArity JStgExpr
    fun Maybe JStgExpr
    forall a. Maybe a
    Nothing JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr ([JStgExpr] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [JStgExpr]
    values Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    256) JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - JStgExpr
    n

        values' :: [JStgExpr]
    values' | [JStgExpr] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    GHC.Prelude.null [JStgExpr]
    values = [JStgExpr
    null_]
                | Bool
    otherwise   = [JStgExpr]
    values
        entry :: Ident
    entry | [JStgExpr] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [JStgExpr]
    values Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    numSpecPap = FastString -> Ident
    global FastString
    "h$pap_gen"
              | Bool
    otherwise                  = Array Int Ident
    specPapIdents Array Int Ident -> Int -> Ident
    forall i e. Ix i => Array i e -> i -> e
    ! [JStgExpr] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [JStgExpr]
    values

    -- | Number of specialized PAPs (pre-generated for a given number of args)
    numSpecPap :: Int
    numSpecPap :: Int
    numSpecPap = Int
    6

    -- specialized (faster) pap generated for [0..numSpecPap]
    -- others use h$pap_gen
    specPap :: [Int]
    specPap :: [Int]
    specPap = [Int
    0..Int
    numSpecPap]

    -- | Cache of specialized PAP idents
    specPapIdents :: Array Int Ident
    specPapIdents :: Array Int Ident
    specPapIdents = (Int, Int) -> [Ident] -> Array Int Ident
    forall i e. Ix i => (i, i) -> [e] -> Array i e
    listArray (Int
    0,Int
    numSpecPap) ([Ident] -> Array Int Ident) -> [Ident] -> Array Int Ident
    forall a b. (a -> b) -> a -> b
    $ (Int -> Ident) -> [Int] -> [Ident]
    forall a b. (a -> b) -> [a] -> [b]
    map (FastString -> Ident
    global (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> FastString
    mkFastString ([Char] -> FastString) -> (Int -> [Char]) -> Int -> FastString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([Char]
    "h$pap_"[Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++) ShowS -> (Int -> [Char]) -> Int -> [Char]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> [Char]
    forall a. Show a => a -> [Char]
    show) [Int]
    specPap

    pap :: StgToJSConfig
        -> Int
        -> JSM JStgStat
    pap :: StgToJSConfig -> Int -> JSM JStgStat
    pap StgToJSConfig
    s Int
    r = ClosureInfo -> JSM JStgStat -> JSM JStgStat
    closure (Ident
    -> CIRegs
    -> FastString
    -> CILayout
    -> CIType
    -> CIStatic
    -> ClosureInfo
    ClosureInfo Ident
    funcIdent CIRegs
    CIRegsUnknown FastString
    funcName (Int -> CILayout
    CILayoutUnknown (Int
    rInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    2)) CIType
    CIPap CIStatic
    forall a. Monoid a => a
    mempty) JSM JStgStat
    body
      where
        funcIdent :: Ident
    funcIdent = FastString -> Ident
    global FastString
    funcName
        funcName :: FastString
    funcName = [Char] -> FastString
    mkFastString ([Char]
    "h$pap_" [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    r)

        body :: JSM JStgStat
    body = ((JStgExpr, JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat)
    -> JSM JStgStat
    forall args.
    JSArgument args =>
    (args -> JSM JStgStat) -> JSM JStgStat
    jVars (((JStgExpr, JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat)
     -> JSM JStgStat)
    -> ((JStgExpr, JStgExpr, JStgExpr, JStgExpr) -> JSM JStgStat)
    -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ \(JStgExpr
    c, JStgExpr
    d, JStgExpr
    f, JStgExpr
    extra) ->
                 JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
    forall a b. (a -> b) -> a -> b
    $
                 [ JStgExpr
    c JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    closureField1 JStgExpr
    r1
                 , JStgExpr
    d JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    closureField2 JStgExpr
    r1
                 , JStgExpr
    f JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    closureEntry  JStgExpr
    c
                 , StgToJSConfig -> JStgExpr -> FastString -> JStgStat
    forall a. ToJExpr a => StgToJSConfig -> JStgExpr -> a -> JStgStat
    assertRts StgToJSConfig
    s (JStgExpr -> JStgExpr
    isFun' JStgExpr
    f JStgExpr -> JStgExpr -> JStgExpr
    .||. JStgExpr -> JStgExpr
    isPap' JStgExpr
    f) (FastString
    funcName FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": expected function or pap")
                 , StgToJSConfig -> JStgStat -> JStgStat
    profStat StgToJSConfig
    s (CostCentreStack -> JStgStat
    enterCostCentreFun CostCentreStack
    currentCCS)
                 , JStgExpr
    extra JStgExpr -> JStgExpr -> JStgStat
    |= (JStgExpr -> Maybe JStgExpr -> JStgExpr
    funOrPapArity JStgExpr
    c (JStgExpr -> Maybe JStgExpr
    forall a. a -> Maybe a
    Just JStgExpr
    f) JStgExpr -> JStgExpr -> JStgExpr
    .>>. JStgExpr
    8) JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    r
                 , StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    s (FastString -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (FastString
    funcName FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> FastString
    ": pap extra args moving: ") JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    extra)
                 , JStgExpr -> JStgStat
    moveBy JStgExpr
    extra
                 , JStgExpr -> JStgStat
    loadOwnArgs JStgExpr
    d
                 , JStgExpr
    r1 JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    c
                 , JStgExpr -> JStgStat
    returnS JStgExpr
    f
                 ]
        moveBy :: JStgExpr -> JStgStat
    moveBy JStgExpr
    extra = JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
    SwitchStat JStgExpr
    extra
                       ([(JStgExpr, JStgStat)] -> [(JStgExpr, JStgStat)]
    forall a. [a] -> [a]
    reverse ([(JStgExpr, JStgStat)] -> [(JStgExpr, JStgStat)])
    -> [(JStgExpr, JStgStat)] -> [(JStgExpr, JStgStat)]
    forall a b. (a -> b) -> a -> b
    $ (Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> (JStgExpr, JStgStat)
    moveCase [Int
    1..Int
    maxRegInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    rInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1]) JStgStat
    forall a. Monoid a => a
    mempty
        moveCase :: Int -> (JStgExpr, JStgStat)
    moveCase Int
    m = (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    m, Int -> JStgExpr
    jsReg (Int
    mInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    rInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) JStgExpr -> JStgExpr -> JStgStat
    |= Int -> JStgExpr
    jsReg (Int
    mInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1))
        loadOwnArgs :: JStgExpr -> JStgStat
    loadOwnArgs JStgExpr
    d = [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
    forall a b. (a -> b) -> a -> b
    $ (Int -> JStgStat) -> [Int] -> [JStgStat]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    r ->
            Int -> JStgExpr
    jsReg (Int
    rInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> Int -> JStgExpr
    forall {a}. (Show a, Num a) => JStgExpr -> a -> JStgExpr
    dField JStgExpr
    d (Int
    rInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    2)) [Int
    1..Int
    r]
        dField :: JStgExpr -> a -> JStgExpr
    dField JStgExpr
    d a
    n = JStgExpr -> Ident -> JStgExpr
    SelExpr JStgExpr
    d (FastString -> Ident
    global (FastString -> Ident) -> ([Char] -> FastString) -> [Char] -> Ident
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> FastString
    mkFastString ([Char] -> Ident) -> [Char] -> Ident
    forall a b. (a -> b) -> a -> b
    $ (Char
    'd'Char -> ShowS
    forall a. a -> [a] -> [a]
    :a -> [Char]
    forall a. Show a => a -> [Char]
    show (a
    na -> a -> a
    forall a. Num a => a -> a -> a
    -a
    1)))

    -- Construct a generic PAP
    papGen :: StgToJSConfig -> JSM JStgStat
    papGen :: StgToJSConfig -> JSM JStgStat
    papGen StgToJSConfig
    cfg =
       ClosureInfo -> JSM JStgStat -> JSM JStgStat
    closure (Ident
    -> CIRegs
    -> FastString
    -> CILayout
    -> CIType
    -> CIStatic
    -> ClosureInfo
    ClosureInfo Ident
    funcIdent CIRegs
    CIRegsUnknown FastString
    funcName CILayout
    CILayoutVariable CIType
    CIPap CIStatic
    forall a. Monoid a => a
    mempty)
               (((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
     -> JSM JStgStat)
    -> JSM JStgStat
    forall args.
    JSArgument args =>
    (args -> JSM JStgStat) -> JSM JStgStat
    jVars (((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
      -> JSM JStgStat)
     -> JSM JStgStat)
    -> ((JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr, JStgExpr)
        -> JSM JStgStat)
    -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ \(JStgExpr
    c, JStgExpr
    f, JStgExpr
    d, JStgExpr
    pr, JStgExpr
    or, JStgExpr
    r) ->
                  JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $ [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat
                  [ JStgExpr
    c JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    closureField1 JStgExpr
    r1
                  , JStgExpr
    d JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    closureField2 JStgExpr
    r1
                  , JStgExpr
    f JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    closureEntry  JStgExpr
    c
                  , JStgExpr
    pr JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> Maybe JStgExpr -> JStgExpr
    funOrPapArity JStgExpr
    c (JStgExpr -> Maybe JStgExpr
    forall a. a -> Maybe a
    Just JStgExpr
    f) JStgExpr -> JStgExpr -> JStgExpr
    .>>. JStgExpr
    8
                  , JStgExpr
    or JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr -> JStgExpr
    papArity JStgExpr
    r1 JStgExpr -> JStgExpr -> JStgExpr
    .>>. JStgExpr
    8
                  , JStgExpr
    r JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    pr JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    - JStgExpr
    or
                  , StgToJSConfig -> JStgExpr -> JStgExpr -> JStgStat
    forall a. ToJExpr a => StgToJSConfig -> JStgExpr -> a -> JStgStat
    assertRts StgToJSConfig
    cfg
                    (JStgExpr -> JStgExpr
    isFun' JStgExpr
    f JStgExpr -> JStgExpr -> JStgExpr
    .||. JStgExpr -> JStgExpr
    isPap' JStgExpr
    f)
                    (FastString -> JStgExpr
    jString FastString
    "h$pap_gen: expected function or pap")
                  , StgToJSConfig -> JStgStat -> JStgStat
    profStat StgToJSConfig
    cfg (CostCentreStack -> JStgStat
    enterCostCentreFun CostCentreStack
    currentCCS)
                  , StgToJSConfig -> JStgExpr -> JStgStat
    traceRts StgToJSConfig
    cfg (FastString -> JStgExpr
    jString FastString
    "h$pap_gen: generic pap extra args moving: " JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    + JStgExpr
    or)
                  , FastString -> [JStgExpr] -> JStgStat
    appS FastString
    "h$moveRegs2" [JStgExpr
    or, JStgExpr
    r]
                  , JStgExpr -> JStgExpr -> JStgStat
    loadOwnArgs JStgExpr
    d JStgExpr
    r
                  , JStgExpr
    r1 JStgExpr -> JStgExpr -> JStgStat
    |= JStgExpr
    c
                  , JStgExpr -> JStgStat
    returnS JStgExpr
    f
                  ])

      where
        funcIdent :: Ident
    funcIdent = FastString -> Ident
    global FastString
    funcName
        funcName :: FastString
    funcName = FastString
    "h$pap_gen"
        loadOwnArgs :: JStgExpr -> JStgExpr -> JStgStat
    loadOwnArgs JStgExpr
    d JStgExpr
    r =
          let prop :: Int -> JStgExpr
    prop Int
    n = JStgExpr
    d JStgExpr -> FastString -> JStgExpr
    .^ (FastString
    "d" FastString -> FastString -> FastString
    forall a. Semigroup a => a -> a -> a
    <> [Char] -> FastString
    mkFastString (Int -> [Char]
    forall a. Show a => a -> [Char]
    show (Int -> [Char]) -> Int -> [Char]
    forall a b. (a -> b) -> a -> b
    $ Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1))
              loadOwnArg :: Int -> (JStgExpr, JStgStat)
    loadOwnArg Int
    n = (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr Int
    n, Int -> JStgExpr
    jsReg (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) JStgExpr -> JStgExpr -> JStgStat
    |= Int -> JStgExpr
    prop Int
    n)
          in  JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
    SwitchStat JStgExpr
    r ((Int -> (JStgExpr, JStgStat)) -> [Int] -> [(JStgExpr, JStgStat)]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> (JStgExpr, JStgStat)
    loadOwnArg [Int
    127,Int
    126..Int
    1]) JStgStat
    forall a. Monoid a => a
    mempty

    -- general utilities
    -- move the first n registers, starting at R2, m places up (do not use with negative m)
    moveRegs2 :: JSM JStgStat
    moveRegs2 :: JSM JStgStat
    moveRegs2 = Ident -> ((JStgExpr, JStgExpr) -> JSM JStgStat) -> JSM JStgStat
    forall args.
    JSArgument args =>
    Ident -> (args -> JSM JStgStat) -> JSM JStgStat
    jFunction (FastString -> Ident
    global FastString
    "h$moveRegs2") (JStgExpr, JStgExpr) -> JSM JStgStat
    moveSwitch
      where
        moveSwitch :: (JStgExpr, JStgExpr) -> JSM JStgStat
    moveSwitch (JStgExpr
    n,JStgExpr
    m) = JStgExpr -> JStgExpr -> JSM JStgStat
    defaultCase JStgExpr
    n JStgExpr
    m JSM JStgStat -> (JStgStat -> JSM JStgStat) -> JSM JStgStat
    forall a b.
    StateT JEnv Identity a
    -> (a -> StateT JEnv Identity b) -> StateT JEnv Identity b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat)
    -> (JStgStat -> JStgStat) -> JStgStat -> JSM JStgStat
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
    SwitchStat ((JStgExpr
    n JStgExpr -> JStgExpr -> JStgExpr
    .<<. JStgExpr
    8) JStgExpr -> JStgExpr -> JStgExpr
    .|. JStgExpr
    m) [(JStgExpr, JStgStat)]
    switchCases
        -- fast cases
        switchCases :: [(JStgExpr, JStgStat)]
    switchCases = [Int -> Int -> (JStgExpr, JStgStat)
    switchCase Int
    n Int
    m | Int
    n <- [Int
    1..Int
    5], Int
    m <- [Int
    1..Int
    4]]
        switchCase :: Int -> Int -> (JStgExpr, JStgStat)
        switchCase :: Int -> Int -> (JStgExpr, JStgStat)
    switchCase Int
    n Int
    m = (Int -> JStgExpr
    forall a. ToJExpr a => a -> JStgExpr
    toJExpr (Int -> JStgExpr) -> Int -> JStgExpr
    forall a b. (a -> b) -> a -> b
    $
                          (Int
    n Int -> Int -> Int
    forall a. Bits a => a -> Int -> a
    `Bits.shiftL` Int
    8) Int -> Int -> Int
    forall a. Bits a => a -> a -> a
    Bits..|. Int
    m
                         , [JStgStat] -> JStgStat
    forall a. Monoid a => [a] -> a
    mconcat ((Int -> JStgStat) -> [Int] -> [JStgStat]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> Int -> JStgStat
    `moveRegFast` Int
    m) [Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1,Int
    n..Int
    2])
                           JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> Maybe JsLabel -> JStgStat
    BreakStat Maybe JsLabel
    forall a. Maybe a
    Nothing {-[j| break; |]-})
        moveRegFast :: Int -> Int -> JStgStat
    moveRegFast Int
    n Int
    m = Int -> JStgExpr
    jsReg (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    m) JStgExpr -> JStgExpr -> JStgStat
    |= Int -> JStgExpr
    jsReg Int
    n
        -- fallback
        defaultCase :: JStgExpr -> JStgExpr -> JSM JStgStat
    defaultCase JStgExpr
    n JStgExpr
    m =
          JStgExpr
    -> (JStgExpr -> JStgExpr)
    -> (JStgExpr -> JSM JStgStat)
    -> JSM JStgStat
    loop JStgExpr
    n (JStgExpr -> JStgExpr -> JStgExpr
    .>.JStgExpr
    0) (\JStgExpr
    i -> JStgStat -> JSM JStgStat
    forall a. a -> StateT JEnv Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
    forall a b. (a -> b) -> a -> b
    $
                               FastString -> [JStgExpr] -> JStgStat
    appS FastString
    "h$setReg" [JStgExpr
    iJStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    +JStgExpr
    1JStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    +JStgExpr
    m, FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "h$getReg" [JStgExpr
    iJStgExpr -> JStgExpr -> JStgExpr
    forall a. Num a => a -> a -> a
    +JStgExpr
    1]]
                               JStgStat -> JStgStat -> JStgStat
    forall a. Semigroup a => a -> a -> a
    <> JStgExpr -> JStgStat
    postDecrS JStgExpr
    i)

    -- Initalize a variable sized object from an array of values
    initClosure :: StgToJSConfig -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
    initClosure :: StgToJSConfig -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
    initClosure StgToJSConfig
    cfg JStgExpr
    entry JStgExpr
    values JStgExpr
    ccs = FastString -> [JStgExpr] -> JStgExpr
    app FastString
    "h$init_closure"
      [ Closure -> JStgExpr
    newClosure (Closure -> JStgExpr) -> Closure -> JStgExpr
    forall a b. (a -> b) -> a -> b
    $ Closure
          { clEntry :: JStgExpr
    clEntry  = JStgExpr
    entry
          , clField1 :: JStgExpr
    clField1 = JStgExpr
    null_
          , clField2 :: JStgExpr
    clField2 = JStgExpr
    null_
          , clMeta :: JStgExpr
    clMeta   = JStgExpr
    0
          , clCC :: Maybe JStgExpr
    clCC     = if StgToJSConfig -> Bool
    csProf StgToJSConfig
    cfg then JStgExpr -> Maybe JStgExpr
    forall a. a -> Maybe a
    Just JStgExpr
    ccs else Maybe JStgExpr
    forall a. Maybe a
    Nothing
          }
      , JStgExpr
    values
      ]

    -- | Return an expression for every field of the given Id
    getIdFields :: Id -> G [TypedExpr]
    getIdFields :: Id -> G [TypedExpr]
    getIdFields Id
    i = Id -> [JStgExpr] -> [TypedExpr]
    assocIdExprs Id
    i ([JStgExpr] -> [TypedExpr])
    -> StateT GenState IO [JStgExpr] -> G [TypedExpr]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Id -> StateT GenState IO [JStgExpr]
    varsForId Id
    i

    -- | Store fields of Id into the given target expressions
    storeIdFields :: Id -> [TypedExpr] -> G JStgStat
    storeIdFields :: Id -> [TypedExpr] -> G JStgStat
    storeIdFields Id
    i [TypedExpr]
    dst = do
      fields <- Id -> G [TypedExpr]
    getIdFields Id
    i
      pure (assignCoerce1 dst fields)