{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}

-- | MCode to LLVM IR, for the subset the JIT supports. See design.md for
-- the conventions ("Code generation" for how this module is organized).
--
-- Within a function, every Unison stack slot is an LLVM alloca: @%u<k>@
-- holds the unboxed word and @%b<k>@ the boxed pointer of the slot at
-- frame offset @k@, which is stack index @fp + k@. The frame depth
-- @d@ (the interpreter's @sp - fp@) is known statically at every point, so
-- MCode's "slot @i@ from the top" is frame offset @d - i@. The real stack
-- is touched only at entry, before a tail call, and on exit paths.
--
-- The generator is strict throughout (see "Unison.Runtime.JIT.Strict"):
-- its text is 'Text', its sequences are 'Deque's, its pairs are 'Pair's,
-- and every field of its state is strict, so nothing it builds is a thunk.
module Unison.Runtime.JIT.Codegen
  ( Env (..),
    Cells (..),
    CtxOffsets (..),
    RtsFacts (..),
    Function (..),
    Deferred (..),
    AuxKey,
    AuxMemo,
    genFunction,
    genDeferred,
    modulePrelude,
    pushCount,
    startsSupported,
    callOutWorthwhile,
    instrNative,
    instrNativeIn,
    Switches (..),
    switches,
    unitForeign,
    workerShape,
  )
where

import Control.Monad (foldM, forM, forM_, unless, void, when)
import Control.Monad.State.Strict hiding (put)
import Control.Monad.State.Strict qualified as State
import Data.Bits (shiftL, shiftR)
import Data.Char (ord)
import Data.Int (Int64)
import Data.IntMap.Strict qualified as IM
import Data.IntSet qualified as IS
import Data.Map.Strict qualified as Map
import Data.Maybe (isJust, isNothing)
import Data.Primitive.PrimArray (primArrayToList)
import Data.Vector qualified as V
import Data.Word (Word64)
import Foreign.Ptr (Ptr, WordPtr (..), ptrToWordPtr)
import GHC.Float (castDoubleToWord64)
import System.Info (os)
import Unison.Builtin.Decls qualified as Ty (eitherRef, optionalRef, pairRef, seqViewRef, unitRef)
import Unison.Reference (Reference)
import Unison.Runtime.ANF (PackedTag (..))
import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..))
import Unison.Runtime.JIT.Config (Config, disabled, exitCall)
import Unison.Runtime.JIT.Exits (Exit (..))
import Unison.Runtime.JIT.Frames (Frame (..))
import Unison.Runtime.JIT.Layout
import Unison.Runtime.JIT.Pool
import Unison.Runtime.JIT.Strict
import Unison.Runtime.MCode hiding (Env)
import Unison.Runtime.MCode qualified as MCode (GRef (Env))
import Unison.Runtime.Stack (MCombs, MRef, MSection, Val (..))
import Unison.Runtime.TypeTags qualified as TT
import Unison.Util.Deque (Deque, (<|), (><), (|>), pattern Empty, pattern (:<|))
import Unison.Util.Deque qualified as D
import Unison.Util.EnumContainers qualified as EC
import Unison.Util.Text qualified as UT

-- | Byte offsets of the fields of the C @Ctx@, from @unison_jit_ctx_layout@.
data CtxOffsets = CtxOffsets
  { CtxOffsets -> Int
oUstk, CtxOffsets -> Int
oBstk, CtxOffsets -> Int
oPool, CtxOffsets -> Int
oStackSize, CtxOffsets -> Int
oHplim, CtxOffsets -> Int
oAp, CtxOffsets -> Int
oFp, CtxOffsets -> Int
oSp, CtxOffsets -> Int
oMaxSp, CtxOffsets -> Int
oStressPoll, CtxOffsets -> Int
oStressPollLeft, CtxOffsets -> Int
oStressCallee, CtxOffsets -> Int
oStressCalleeLeft, CtxOffsets -> Int
oFrames, CtxOffsets -> Int
oNFrames, CtxOffsets -> Int
oMaxFrames, CtxOffsets -> Int
oCStackLimit, CtxOffsets -> Int
oCap, CtxOffsets -> Int
oBudgetEnd, CtxOffsets -> Int
oHp, CtxOffsets -> Int
oHpLim, CtxOffsets -> Int
oHenv, CtxOffsets -> Int
oNLocals :: !Int
  }

-- | From unison_jit_rts_facts: the info pointers and layouts of the two
-- arrays a @Seg@ is made of.
data RtsFacts = RtsFacts
  { RtsFacts -> Int
rArrWordsInfo, RtsFacts -> Int
rArrPtrsInfo :: !Int,
    -- | ByteArray#: header words including the byte count, and the word index of the count
    RtsFacts -> Int
rBytesHeader, RtsFacts -> Int
rBytesCount :: !Int,
    -- | Array#: header words, word index of the element count and of the payload size
    RtsFacts -> Int
rPtrsHeader, RtsFacts -> Int
rPtrsCount, RtsFacts -> Int
rPtrsSize :: !Int,
    -- | log2 of elements per card-table byte
    RtsFacts -> Int
rCardBits :: !Int,
    -- | word index of a MutVar#'s content
    RtsFacts -> Int
rMutVarVar :: !Int,
    -- | info pointer a mutable Array# gets when written
    RtsFacts -> Int
rArrPtrsDirtyInfo :: !Int
  }

data Env = Env
  { Env -> Layouts
envLayouts :: !Layouts,
    Env -> CtxOffsets
envCtx :: !CtxOffsets,
    -- | index of this module's first exit in the global table
    Env -> Int
envExitBase :: !Int,
    -- | index of this module's first frame in the global frame table
    Env -> Int
envFrameBase :: !Int,
    -- | emit the stress-mode poll countdown
    Env -> Bool
envStressPoll :: !Bool,
    -- | emit the stress-mode "callee not compiled" countdown
    Env -> Bool
envStressCallee :: !Bool,
    -- | exits write the frame back through a call (see 'joinCall')
    Env -> Bool
envExitCall :: !Bool,
    -- | the group being compiled, for the arity of Let body combinators
    Env -> MCombs
envCombs :: !MCombs,
    -- | pool index of every constant this group uses
    Env -> Map PoolKey Int
envPool :: !(Map.Map PoolKey Int),
    Env -> RtsFacts
envRts :: !RtsFacts,
    -- | the number each type reference has in the cache (the type part of
    -- a packed tag), for the one match arm that compares a whole tag (a
    -- lone wide constructor's; no other declaration of a type is needed:
    -- field counts come from the arms and the objects, 'genDMatchClosure')
    Env -> Map Reference Word64
envTypeNumbers :: !(Map.Map Reference Word64),
    -- | cells for the auxiliary functions (re-entry points), taken in order
    Env -> Cells
envCells :: !Cells,
    -- | features turned off for debugging (see Config)
    Env -> Deque Text
envDisabled :: !(Deque Text),
    -- | leave the re-entry points that are only used when something exits
    -- (bodies of Lets inside bindings, slow paths of instructions with a
    -- native fast path) to be generated when they turn out to be used:
    -- each gets a cell and a 'Deferred', but no code
    Env -> Bool
envLazy :: !Bool,
    -- | the auxiliary functions already known for the function this one
    -- belongs to, generated or deferred: a re-entry function generated
    -- later reuses the cells its parent handed out
    Env -> AuxMemo
envKnown :: !AuxMemo,
    -- | the functions defined in the module being generated, by cell: a
    -- call to one of them is a direct call to its symbol, which LLVM can
    -- inline, instead of a call through the cell
    Env -> Map (Ptr NativeCell) Text
envLocal :: !(Map.Map (Ptr NativeCell) Text),
    -- | the functions of this module that have a worker (see 'feWorker'),
    -- by cell: the worker's symbol and its arity
    Env -> Map (Ptr NativeCell) (Pair Text Int)
envWorkers :: !(Map.Map (Ptr NativeCell) (Pair Text Int)),
    -- | the code is from a sandboxed code cache: Ref.cas and
    -- Ref.readForCas are left to the interpreter, which refuses them
    Env -> Bool
envSandboxed :: !Bool,
    -- | the function's own symbol gets internal linkage: it is a private
    -- copy of a callee (see Compile's 'uCopy'), which LLVM drops once it
    -- is inlined at every call. Its worker is internal already; its
    -- auxiliary functions stay external, since they are installed in cells
    Env -> Bool
envInternal :: !Bool,
    -- | what the settings turn on in the generator (see 'switches')
    Env -> Switches
envSwitches :: !Switches,
    -- | the size of the constant pool's first array (see Pool): a function
    -- that uses only indices below it never checks the array it was given
    Env -> Int
envPoolStable :: !Int
  }

-- | The cells left for auxiliary functions: a supply without end (the
-- first pass over a module, which only counts what each function needs),
-- or what remains of the module's block.
data Cells = Counting | Cells !(Deque (Ptr NativeCell))

-- | The next cell, if there is one.
takeCell :: Cells -> Maybe (Pair (Ptr NativeCell) Cells)
takeCell :: Cells -> Maybe (Pair (Ptr NativeCell) Cells)
takeCell = \case
  Cells
Counting -> Pair (Ptr NativeCell) Cells -> Maybe (Pair (Ptr NativeCell) Cells)
forall a. a -> Maybe a
Just (Ptr NativeCell -> Cells -> Pair (Ptr NativeCell) Cells
forall a b. a -> b -> Pair a b
Pair Ptr NativeCell
noNativeCell Cells
Counting)
  Cells (Ptr NativeCell
c :<| Deque (Ptr NativeCell)
cs) -> Pair (Ptr NativeCell) Cells -> Maybe (Pair (Ptr NativeCell) Cells)
forall a. a -> Maybe a
Just (Ptr NativeCell -> Cells -> Pair (Ptr NativeCell) Cells
forall a b. a -> b -> Pair a b
Pair Ptr NativeCell
c (Deque (Ptr NativeCell) -> Cells
Cells Deque (Ptr NativeCell)
cs))
  Cells Deque (Ptr NativeCell)
_ -> Maybe (Pair (Ptr NativeCell) Cells)
forall a. Maybe a
Nothing

-- | What an auxiliary function is generated from: the section (without its
-- combinator references, which have no Ord; their CombIx stays), the depth
-- it starts at, and the frame base.
type AuxKey = (GSection (), Int, Int)

type AuxMemo = Map.Map AuxKey (Pair Text (Ptr NativeCell))

-- | A re-entry function that was given a cell but not generated: all that
-- 'genDeferred' needs to generate it later.
data Deferred = Deferred
  { Deferred -> Text
dName :: !Text,
    Deferred -> CombIx
dCix :: !CombIx,
    -- | slots on the stack at entry
    Deferred -> Int
dLoaded :: !Int,
    Deferred -> Int
dFrameSize :: !Int,
    -- | the frame base (see 'feBase')
    Deferred -> Int
dBase :: !Int,
    Deferred -> MSection
dBody :: !MSection,
    Deferred -> Ptr NativeCell
dCell :: !(Ptr NativeCell)
  }

data Function = Function
  { Function -> Text
fnName :: !Text,
    -- | the LLVM text of the function and what comes with it (a module's
    -- IR can run to tens of megabytes)
    Function -> Text
fnIR :: !Text,
    -- | in index order, starting at the module's base plus the count before this function
    Function -> Deque Exit
fnExits :: !(Deque Exit),
    -- | likewise for the frame table
    Function -> Deque Frame
fnFrames :: !(Deque Frame),
    Function -> Ptr NativeCell
fnCell :: !(Ptr NativeCell),
    -- | the auxiliary functions defined alongside (re-entry points after
    -- call-outs, bodies of Lets inside bindings) and their cells
    Function -> Deque (Pair Text (Ptr NativeCell))
fnAux :: !(Deque (Pair Text (Ptr NativeCell))),
    -- | the re-entry functions given a cell but left for later
    Function -> Deque Deferred
fnDeferred :: !(Deque Deferred),
    -- | every auxiliary function known after this one was generated
    Function -> AuxMemo
fnMemo :: !AuxMemo,
    -- | why parts of the function fell back to the interpreter
    Function -> Deque Text
fnNotes :: !(Deque Text)
  }

-- | Declarations every module needs.
modulePrelude :: Text
modulePrelude :: Text
modulePrelude =
  Deque Text -> Text
unlinesT (Deque Text -> Text) -> ([Text] -> Deque Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    [ Text
"declare ptr @llvm.stacksave.p0()",
      -- floats: the libm functions compiled Haskell calls for the same operations,
      -- and the intrinsics for what it does with instructions (see genPrim1)
      Text
"declare double @exp(double)",
      Text
"declare double @log(double)",
      Text
"declare double @pow(double, double)",
      Text
"declare double @cos(double)",
      Text
"declare double @sin(double)",
      Text
"declare double @tan(double)",
      Text
"declare double @cosh(double)",
      Text
"declare double @sinh(double)",
      Text
"declare double @tanh(double)",
      Text
"declare double @acos(double)",
      Text
"declare double @asin(double)",
      Text
"declare double @atan(double)",
      Text
"declare double @asinh(double)",
      Text
"declare double @acosh(double)",
      Text
"declare double @atanh(double)",
      Text
"declare double @llvm.fabs.f64(double)",
      Text
"declare double @llvm.sqrt.f64(double)",
      Text
"declare double @llvm.ceil.f64(double)",
      Text
"declare double @llvm.floor.f64(double)",
      Text
"declare double @llvm.rint.f64(double)",
      Text
"declare i64 @llvm.fptosi.sat.i64.f64(double)",
      Text
"declare i64 @unison_jit_pow(i64, i64)",
      Text
"declare double @unison_jit_atan2(double, double)",
      -- arrays and refs (see "Arrays and Refs" in jit_rt.c); the pair is (ok, value)
      Text
"declare i64 @unison_jit_barray_copy(ptr, i64, ptr, i64, i64, i64)",
      Text
"declare ptr @unison_jit_barray_freeze(ptr, ptr, i64, i64, i64)",
      Text
"declare ptr @unison_jit_barray_to_bytes(ptr, ptr, i64, i64)",
      Text
"declare ptr @unison_jit_barray_from_bytes(ptr, ptr)",
      Text
"declare ptr @unison_jit_barray_new(ptr, i64, i64, i64)",
      Text
"declare ptr @unison_jit_barray_contents(ptr, ptr)",
      Text
"declare ptr @unison_jit_parray_new(ptr, i64, i64, i64, ptr)",
      Text
"declare i64 @unison_jit_parray_copy(ptr, i64, ptr, i64, i64, i64)",
      Text
"declare ptr @unison_jit_parray_freeze(ptr, ptr, i64, i64, i64)",
      Text
"declare ptr @unison_jit_ref_new(ptr, i64, ptr)",
      Text
"declare ptr @unison_jit_ref_read_for_cas(ptr, ptr)",
      Text
"declare i64 @unison_jit_ref_cas(ptr, ptr, ptr, i64, ptr)",
      Text
"declare { i64, i64 } @unison_jit_murmur(i64, ptr)",
      Text
"declare { i64, i64 } @unison_jit_ueq(i64, ptr, i64, ptr, i64)",
      Text
"declare { i64, i64 } @unison_jit_ucmp(i64, ptr, i64, ptr, i64)",
      Text
"declare ptr @unison_jit_resolve_dyn(ptr, i64)",
      Text
"declare i64 @unison_jit_rec_pos(ptr, i64)",
      Text
"declare ptr @unison_jit_rec_set(ptr, ptr, i64, i64, ptr)",
      Text
"declare i64 @unison_jit_set_aff(ptr, ptr, ptr)",
      Text
"declare ptr @unison_jit_local_env(ptr, ptr)",
      Text
"declare ptr @unison_jit_wrap_ptr(ptr, i64)",
      Text
"declare ptr @unison_jit_alloc_words(ptr, i64)",
      Text
"declare preserve_mostcc void @unison_jit_exit_frame(ptr, ptr, i64, i64, ptr)",
      Text
"declare void @unison_jit_write_mutvar(ptr, ptr, ptr)",
      Text
"declare void @unison_jit_exit_fail()",
      Text
"declare i64 @unison_jit_list_size(ptr)",
      Text
"declare ptr @unison_jit_list_view(ptr, ptr, ptr, i64, i64)",
      Text
"declare ptr @unison_jit_list_push(ptr, ptr, i64, ptr, i64)",
      Text
"declare ptr @unison_jit_list_index(ptr, ptr, i64, ptr, i64)",
      Text
"declare ptr @unison_jit_list_lit(ptr, ptr, i64, ptr)",
      Text
"declare ptr @unison_jit_list_wrap(ptr, ptr)",
      Text
"declare ptr @unison_jit_list_cut(ptr, ptr, i64, i64)",
      Text
"declare ptr @unison_jit_list_split(ptr, ptr, i64, ptr, i64, i64)",
      Text
"declare ptr @unison_jit_list_append(ptr, ptr, ptr)",
      Text
"declare i64 @unison_jit_text_size(ptr)",
      Text
"declare ptr @unison_jit_text_append(ptr, ptr, ptr)",
      Text
"declare ptr @unison_jit_text_cut(ptr, ptr, i64, i64)",
      Text
"declare i64 @unison_jit_text_eq(ptr, ptr)",
      Text
"declare i64 @unison_jit_bytes_size(ptr)",
      Text
"declare ptr @unison_jit_bytes_append(ptr, ptr, ptr)",
      Text
"declare ptr @unison_jit_bytes_cut(ptr, ptr, i64, i64)",
      Text
"declare i64 @unison_jit_foreign_eq(ptr, ptr, i64)",
      Text
"declare ptr @unison_jit_bytes_index(ptr, ptr, i64, ptr, i64, ptr)",
      Text
"declare ptr @unison_jit_bytes_flatten(ptr, ptr)",
      Text
"declare ptr @unison_jit_text_uncons(ptr, ptr, ptr, i64, ptr, i64, ptr, ptr, i64)",
      Text
"declare ptr @unison_jit_int_to_text(ptr, i64, i64)",
      Text
"declare ptr @unison_jit_float_to_text(ptr, i64)",
      Text
"declare ptr @unison_jit_text_to_num(ptr, ptr, ptr, i64, ptr, i64)",
      Text
"declare ptr @unison_jit_text_pack(ptr, ptr, ptr)",
      Text
"declare ptr @unison_jit_bytes_pack(ptr, ptr, ptr)",
      Text
"declare ptr @unison_jit_text_unpack(ptr, ptr, ptr)",
      Text
"declare ptr @unison_jit_bytes_unpack(ptr, ptr, ptr)",
      Text
"declare ptr @unison_jit_text_index_of(ptr, ptr, ptr, ptr, i64, ptr)",
      Text
"declare ptr @unison_jit_bytes_index_of(ptr, ptr, ptr, ptr, i64, ptr)",
      Text
"declare i64 @unison_jit_text_cmp(ptr, ptr)",
      Text
"declare i64 @unison_jit_foreign_cmp(ptr, ptr, i64)",
      Text
"declare ptr @unison_jit_char_to_text(ptr, i64)",
      Text
"declare ptr @unison_jit_text_repeat(ptr, i64, ptr)",
      Text
"declare ptr @unison_jit_text_reverse(ptr, ptr)",
      Text
"declare ptr @unison_jit_text_case(ptr, ptr, i64)",
      Text
"declare ptr @unison_jit_text_to_utf8(ptr, ptr)",
      Text
"declare ptr @unison_jit_text_from_utf8(ptr, ptr, ptr, i64)",
      Text
"declare ptr @unison_jit_bytes_decode_nat(ptr, ptr, i64, i64, ptr, i64, ptr, i64, ptr, ptr)",
      Text
"declare ptr @unison_jit_bytes_encode_nat(ptr, i64, i64, i64)",
      Text
"declare i64 @unison_jit_bytes_read_ok(ptr, i64, i64)",
      Text
"declare i64 @unison_jit_bytes_read_at(ptr, i64, i64, i64)",
      Text
"declare ptr @unison_jit_bytes_to_base(ptr, ptr, i64)",
      Text
"declare ptr @unison_jit_bytes_from_base(ptr, ptr, i64, ptr, i64)",
      Text
"declare ptr @unison_jit_name(ptr, ptr, i64, i64)",
      Text
"declare i64 @llvm.ctlz.i64(i64, i1)",
      Text
"declare i64 @llvm.cttz.i64(i64, i1)",
      Text
"declare i64 @llvm.ctpop.i64(i64)",
      Text
"declare i64 @llvm.bswap.i64(i64)",
      -- branch weights: the first target is the cold one, or the hot one
      Text
"!0 = !{!\"branch_weights\", i32 1, i32 4000}",
      Text
"!1 = !{!\"branch_weights\", i32 4000, i32 1}"
    ]

-- | Marks a conditional branch whose first target is rarely taken (an
-- exit, a slow path), or nearly always. Without these the register
-- allocator keeps what the exit paths need in callee-saved registers, and
-- every call of the function pays to save and restore them.
unlikely, likely :: Text
unlikely :: Text
unlikely = Text
", !prof !0"
likely :: Text
likely = Text
", !prof !1"

-- ---------------------------------------------------------------------------
-- The generator

-- The state is strict in every field, and what the fields hold is strict
-- too (a 'Text', a 'Deque', a 'Pair', a strict map), so 'modify'' and 'put'
-- leave nothing unevaluated behind.
data GS = GS
  { GS -> Int
gsFresh :: !Int,
    -- | finished blocks, in order: label and instructions
    GS -> Deque (Pair Text (Deque Text))
gsBlocks :: !(Deque (Pair Text (Deque Text))),
    -- | the block being written: label and instructions
    GS -> Pair Text (Deque Text)
gsCur :: !(Pair Text (Deque Text)),
    -- | exits, in order
    GS -> Deque Exit
gsExits :: !(Deque Exit),
    GS -> Int
gsNExits :: !Int,
    -- | frames, in order
    GS -> Deque Frame
gsFrames :: !(Deque Frame),
    GS -> Int
gsNFrames :: !Int,
    -- | highest frame offset used
    GS -> Int
gsMaxK :: !Int,
    -- | slots whose value is a boolean held as an i1 register, with no
    -- closure built yet (design.md, "Slots"). Absent means the slot's
    -- allocas hold the value. Saved and restored around branch arms.
    GS -> IntMap Text
gsKinds :: !(IM.IntMap Text),
    -- | set when the function can't be compiled after all
    GS -> Maybe Text
gsFailed :: !(Maybe Text),
    -- | auxiliary functions generated so far: their IR, their names and
    -- cells, how many there are, and the cells left to hand out
    GS -> Deque Text
gsAuxText :: !(Deque Text),
    GS -> Deque (Pair Text (Ptr NativeCell))
gsAuxCells :: !(Deque (Pair Text (Ptr NativeCell))),
    GS -> Int
gsNAux :: !Int,
    GS -> Cells
gsCells :: !Cells,
    -- | why parts of the function fell back to the interpreter, for the log
    GS -> Deque Text
gsNotes :: !(Deque Text),
    -- | the captured segment of the closure being called: its arrays and
    -- element count, from 'closureCallee' for 'copyCaptured'
    GS -> Maybe Captured
gsCaptured :: !(Maybe Captured),
    -- | auxiliary functions already generated, by what they were generated
    -- from (section, depth, frame base). The same Let body or call-out
    -- continuation is met again wherever its enclosing code is generated
    -- more than once (inline after a binding and in an auxiliary function
    -- for the binding's body); without this the output grows exponentially
    -- with the nesting of bindings.
    -- The combinator references are dropped from the key (their CombIx
    -- stays), since they have no Ord.
    GS -> AuxMemo
gsAuxMemo :: !AuxMemo,
    -- | highest pool index the function being generated uses
    GS -> Int
gsMaxPool :: !Int,
    -- | the most words any exit site of the function being generated
    -- passes to the write-back routine (its argument block, 'joinCall')
    GS -> Int
gsMaxExitArgs :: !Int,
    -- | re-entry functions left for later, in order
    GS -> Deque Deferred
gsDeferred :: !(Deque Deferred),
    -- | set when the function was being generated as a worker and turned
    -- out to return other than one value somewhere; it has to be
    -- generated in the uniform form instead (not undone by 'attempt')
    GS -> Bool
gsNotWorker :: !Bool,
    -- | the function being generated is a worker: it doesn't load the
    -- addresses of the Unison stacks at entry (it only needs them where
    -- it exits), so each use loads them from @Ctx@
    GS -> Bool
gsWorker :: !Bool,
    -- | the shared write-back blocks of the function being generated
    -- (see 'joinShared'), by what they write; generated at the end
    GS -> Map SharedKey Shared
gsShared :: !(Map.Map SharedKey Shared),
    -- | the exit descriptors of the function being generated (see
    -- 'joinCall'): the global's name by its contents, and the globals
    GS -> Map Text Text
gsDescs :: !(Map.Map Text Text),
    GS -> Deque Text
gsDescText :: !(Deque Text)
  }

-- | What a write-back block does, which is all that exits and unwinds
-- differ in besides the status they return: the depth (an exit records
-- the stack pointer from it), the slots written (the live ones, see
-- 'liveAt'), whether the stack pointers are recorded in @Ctx@ (an exit)
-- or not (an unwind, where the callee that exited has recorded them),
-- the frame record for the binding being unwound (its index and depth),
-- and the enclosing inline bindings (index and base of each).
data SharedKey = SharedKey !Int ![Int] !Bool !(Maybe (Int, Int)) ![(Int, Int)]
  deriving (SharedKey -> SharedKey -> Bool
(SharedKey -> SharedKey -> Bool)
-> (SharedKey -> SharedKey -> Bool) -> Eq SharedKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SharedKey -> SharedKey -> Bool
== :: SharedKey -> SharedKey -> Bool
$c/= :: SharedKey -> SharedKey -> Bool
/= :: SharedKey -> SharedKey -> Bool
Eq, Eq SharedKey
Eq SharedKey =>
(SharedKey -> SharedKey -> Ordering)
-> (SharedKey -> SharedKey -> Bool)
-> (SharedKey -> SharedKey -> Bool)
-> (SharedKey -> SharedKey -> Bool)
-> (SharedKey -> SharedKey -> Bool)
-> (SharedKey -> SharedKey -> SharedKey)
-> (SharedKey -> SharedKey -> SharedKey)
-> Ord SharedKey
SharedKey -> SharedKey -> Bool
SharedKey -> SharedKey -> Ordering
SharedKey -> SharedKey -> SharedKey
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 :: SharedKey -> SharedKey -> Ordering
compare :: SharedKey -> SharedKey -> Ordering
$c< :: SharedKey -> SharedKey -> Bool
< :: SharedKey -> SharedKey -> Bool
$c<= :: SharedKey -> SharedKey -> Bool
<= :: SharedKey -> SharedKey -> Bool
$c> :: SharedKey -> SharedKey -> Bool
> :: SharedKey -> SharedKey -> Bool
$c>= :: SharedKey -> SharedKey -> Bool
>= :: SharedKey -> SharedKey -> Bool
$cmax :: SharedKey -> SharedKey -> SharedKey
max :: SharedKey -> SharedKey -> SharedKey
$cmin :: SharedKey -> SharedKey -> SharedKey
min :: SharedKey -> SharedKey -> SharedKey
Ord)

-- | A shared write-back block: its label, the environment it is generated
-- in (its enclosing bindings are those of the key), and the blocks that
-- branch to it, each with the status it returns.
data Shared = Shared !Text !FnEnv !(Deque (Pair Text Text))

-- | The registers 'closureCallee' leaves for 'copyCaptured': the two
-- segment arrays and the element count.
data Captured = Captured !Text !Text !Text

type Gen = State GS

-- | 'State.put' with the state evaluated first, as 'modify'' does.
put :: GS -> Gen ()
put :: GS -> Gen ()
put GS
s = GS
s GS -> Gen () -> Gen ()
forall a b. a -> b -> b
`seq` GS -> Gen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put GS
s

-- | The state for a fresh function: nothing generated, the given cells to
-- hand out, the given auxiliary functions known.
initialState :: Int -> Cells -> AuxMemo -> Bool -> GS
initialState :: Int -> Cells -> AuxMemo -> Bool -> GS
initialState Int
maxK Cells
cells AuxMemo
known Bool
worker =
  GS
    { gsFresh :: Int
gsFresh = Int
0,
      gsBlocks :: Deque (Pair Text (Deque Text))
gsBlocks = Deque (Pair Text (Deque Text))
forall a. Deque a
D.empty,
      gsCur :: Pair Text (Deque Text)
gsCur = Text -> Deque Text -> Pair Text (Deque Text)
forall a b. a -> b -> Pair a b
Pair Text
"head" Deque Text
forall a. Deque a
D.empty,
      gsExits :: Deque Exit
gsExits = Deque Exit
forall a. Deque a
D.empty,
      gsNExits :: Int
gsNExits = Int
0,
      gsFrames :: Deque Frame
gsFrames = Deque Frame
forall a. Deque a
D.empty,
      gsNFrames :: Int
gsNFrames = Int
0,
      gsMaxK :: Int
gsMaxK = Int
maxK,
      gsKinds :: IntMap Text
gsKinds = IntMap Text
forall a. IntMap a
IM.empty,
      gsFailed :: Maybe Text
gsFailed = Maybe Text
forall a. Maybe a
Nothing,
      gsAuxText :: Deque Text
gsAuxText = Deque Text
forall a. Deque a
D.empty,
      gsAuxCells :: Deque (Pair Text (Ptr NativeCell))
gsAuxCells = Deque (Pair Text (Ptr NativeCell))
forall a. Deque a
D.empty,
      gsNAux :: Int
gsNAux = Int
0,
      gsCells :: Cells
gsCells = Cells
cells,
      gsNotes :: Deque Text
gsNotes = Deque Text
forall a. Deque a
D.empty,
      gsCaptured :: Maybe Captured
gsCaptured = Maybe Captured
forall a. Maybe a
Nothing,
      gsAuxMemo :: AuxMemo
gsAuxMemo = AuxMemo
known,
      gsMaxPool :: Int
gsMaxPool = -Int
1,
      gsMaxExitArgs :: Int
gsMaxExitArgs = Int
0,
      gsDeferred :: Deque Deferred
gsDeferred = Deque Deferred
forall a. Deque a
D.empty,
      gsNotWorker :: Bool
gsNotWorker = Bool
False,
      gsWorker :: Bool
gsWorker = Bool
worker,
      gsShared :: Map SharedKey Shared
gsShared = Map SharedKey Shared
forall k a. Map k a
Map.empty,
      gsDescs :: Map Text Text
gsDescs = Map Text Text
forall k a. Map k a
Map.empty,
      gsDescText :: Deque Text
gsDescText = Deque Text
forall a. Deque a
D.empty
    }

-- | Gives up on the function (or on what 'attempt' is trying).
failWith :: Text -> Gen ()
failWith :: Text -> Gen ()
failWith Text
why = (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsFailed = Just $! why})

fresh :: Text -> Gen Text
fresh :: Text -> Gen Text
fresh Text
base = do
  Int
n <- (GS -> Int) -> StateT GS Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> Int
gsFresh
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsFresh = n + 1})
  pure (Text
"%" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n)

freshLabel :: Text -> Gen Text
freshLabel :: Text -> Gen Text
freshLabel Text
base = do
  Int
n <- (GS -> Int) -> StateT GS Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> Int
gsFresh
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsFresh = n + 1})
  pure (Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n)

emit :: Text -> Gen ()
emit :: Text -> Gen ()
emit Text
i = (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> let !(Pair Text
l Deque Text
is) = GS -> Pair Text (Deque Text)
gsCur GS
s in GS
s {gsCur = Pair l (is |> i)})

-- | The label of the block being written.
curLabel :: Gen Text
curLabel :: Gen Text
curLabel = (GS -> Text) -> Gen Text
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (\GS
s -> let !(Pair Text
l Deque Text
_) = GS -> Pair Text (Deque Text)
gsCur GS
s in Text
l)

-- | Ends the current block (which must have been terminated) and starts another.
startBlock :: Text -> Gen ()
startBlock :: Text -> Gen ()
startBlock Text
label = (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((GS -> GS) -> Gen ()) -> (GS -> GS) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \GS
s -> GS
s {gsBlocks = gsBlocks s |> gsCur s, gsCur = Pair label D.empty}

-- | Generates a block off to the side, then returns to the current one.
sideBlock :: Text -> Gen () -> Gen Text
sideBlock :: Text -> Gen () -> Gen Text
sideBlock Text
base Gen ()
body = do
  Text
label <- if Text
base Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"grow" Bool -> Bool -> Bool
|| Text
base Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"stale" then Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
base else Text -> Gen Text
freshLabel Text
base
  Text -> Gen () -> Gen ()
sideBlockNamed Text
label Gen ()
body
  pure Text
label

sideBlockNamed :: Text -> Gen () -> Gen ()
sideBlockNamed :: Text -> Gen () -> Gen ()
sideBlockNamed Text
label Gen ()
body = do
  Pair Text (Deque Text)
cur <- (GS -> Pair Text (Deque Text))
-> StateT GS Identity (Pair Text (Deque Text))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> Pair Text (Deque Text)
gsCur
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsCur = Pair label D.empty})
  Gen ()
body
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((GS -> GS) -> Gen ()) -> (GS -> GS) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \GS
s -> GS
s {gsBlocks = gsBlocks s |> gsCur s, gsCur = cur}

useK :: Int -> Gen ()
useK :: Int -> Gen ()
useK Int
k
  | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Text -> Gen ()
failWith (Text
"refers to a slot below the frame (offset " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  | Bool
otherwise = (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsMaxK = max (gsMaxK s) k})

uSlot, bSlot :: Int -> Text
uSlot :: Int -> Text
uSlot Int
k = Text
"%u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k
bSlot :: Int -> Text
bSlot Int
k = Text
"%b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k

-- | Slot offsets start at 1; offset 0 and below belong to the caller.
useSlot :: Int -> Gen ()
useSlot :: Int -> Gen ()
useSlot Int
k
  | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = Text -> Gen ()
failWith (Text
"refers to a slot below the frame (offset " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  | Bool
otherwise = Int -> Gen ()
useK Int
k

slotKind :: Int -> Gen (Maybe Text)
slotKind :: Int -> Gen (Maybe Text)
slotKind Int
k = (GS -> Maybe Text) -> Gen (Maybe Text)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Int -> IntMap Text -> Maybe Text
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k (IntMap Text -> Maybe Text)
-> (GS -> IntMap Text) -> GS -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GS -> IntMap Text
gsKinds)

-- | Marks slot @k@ as holding the boolean @c@ (an i1) with no closure.
setBoolKind :: Int -> Text -> Gen ()
setBoolKind :: Int -> Text -> Gen ()
setBoolKind Int
k Text
c = Int -> Gen ()
useSlot Int
k Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsKinds = IM.insert k c (gsKinds s)})

clearKind :: Int -> Gen ()
clearKind :: Int -> Gen ()
clearKind Int
k = (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsKinds = IM.delete k (gsKinds s)})

-- | Runs a generator and puts the slot kinds back afterwards: for code
-- (a branch arm, an inline binding) after which control rejoins other paths.
withKinds :: Gen a -> Gen a
withKinds :: forall a. Gen a -> Gen a
withKinds Gen a
g = do
  IntMap Text
ks <- (GS -> IntMap Text) -> StateT GS Identity (IntMap Text)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> IntMap Text
gsKinds
  a
r <- Gen a
g
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsKinds = ks})
  pure a
r

loadU :: Int -> Gen Text
loadU :: Int -> Gen Text
loadU Int
k = do
  Int -> Gen ()
useSlot Int
k
  Int -> Gen (Maybe Text)
slotKind Int
k Gen (Maybe Text) -> (Maybe Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Text
_ -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"-1" -- a boxed value's word
    Maybe Text
Nothing -> do
      Text
v <- Text -> Gen Text
fresh Text
"u"
      Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
uSlot Int
k)
      pure Text
v

-- | The closure in slot @k@; a boolean held as an i1 is materialized here.
loadB :: Int -> Gen Text
loadB :: Int -> Gen Text
loadB Int
k = do
  Int -> Gen ()
useSlot Int
k
  Int -> Gen (Maybe Text)
slotKind Int
k Gen (Maybe Text) -> (Maybe Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Text
c -> do
      -- the two closures are loaded here, not at entry: most functions
      -- only need them where they exit
      -- (and the pool's address with them, so that it needn't be kept
      -- across calls for this)
      Text
pool <- Text -> Gen Text
fresh Text
"pool"
      Text -> Gen ()
emit (Text
pool Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr %pool.a")
      Text
ta <- Text -> Gen Text
fresh Text
"true.a"
      Text -> Gen ()
emit (Text
ta Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pool Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
poolIndexTrue)
      Text
t <- Text -> Gen Text
fresh Text
"true"
      Text -> Gen ()
emit (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ta)
      Text
fa <- Text -> Gen Text
fresh Text
"false.a"
      Text -> Gen ()
emit (Text
fa Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pool Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
poolIndexFalse)
      Text
f <- Text -> Gen Text
fresh Text
"false"
      Text -> Gen ()
emit (Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fa)
      Text
p <- Text -> Gen Text
fresh Text
"bool"
      Text -> Gen ()
emit (Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f)
      pure Text
p
    Maybe Text
Nothing -> do
      Text
v <- Text -> Gen Text
fresh Text
"b"
      Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
bSlot Int
k)
      pure Text
v

storeU :: Int -> Text -> Gen ()
storeU :: Int -> Text -> Gen ()
storeU Int
k Text
v = Int -> Gen ()
useSlot Int
k Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Gen ()
clearKind Int
k Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
uSlot Int
k)

storeB :: Int -> Text -> Gen ()
storeB :: Int -> Text -> Gen ()
storeB Int
k Text
v = Int -> Gen ()
useSlot Int
k Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Gen ()
clearKind Int
k Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
bSlot Int
k)

-- | Address of stack index @fp + k@ in the unboxed or boxed stack.
stackAddrU, stackAddrB :: Int -> Gen Text
stackAddrU :: Int -> Gen Text
stackAddrU Int
k = do
  Text
f <- Int -> Gen Text
fpPlus Int
k
  Text
stk <- Text -> Gen Text
stackReg Text
"%ustk"
  Text
a <- Text -> Gen Text
fresh Text
"ua"
  Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stk Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f)
  pure Text
a
stackAddrB :: Int -> Gen Text
stackAddrB Int
k = do
  Text
f <- Int -> Gen Text
fpPlus Int
k
  Text
stk <- Text -> Gen Text
stackReg Text
"%bstk"
  Text
a <- Text -> Gen Text
fresh Text
"ba"
  Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stk Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f)
  pure Text
a

-- | The register holding the address of a Unison stack (@%ustk@ or
-- @%bstk@). Loaded at entry, except in a worker, which loads it from
-- @Ctx@ wherever it is used (see 'gsWorker').
stackReg :: Text -> Gen Text
stackReg :: Text -> Gen Text
stackReg Text
name = do
  Bool
lazy <- (GS -> Bool) -> StateT GS Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> Bool
gsWorker
  if Bool
lazy
    then do
      Text
r <- Text -> Gen Text
fresh (Int -> Text -> Text
UT.drop Int
1 Text
name)
      Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a")
      pure Text
r
    else Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
name

-- | A register holding @fp + k@, computed here. (The entry block has
-- its own, for the argument loads and the stack check. Sharing those
-- would keep them alive across every call for the sake of the exit
-- paths, which are where most uses are, and the register allocator would
-- rather save them than compute them again.) Using a slot offset records
-- it, so that the stack check covers it.
fpPlus :: Int -> Gen Text
fpPlus :: Int -> Gen Text
fpPlus Int
k = do
  Int -> Gen ()
useK Int
k
  Text
r <- Text -> Gen Text
fresh Text
"fpk"
  Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 %fp, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k)
  pure Text
r

ctxField :: Env -> (CtxOffsets -> Int) -> Gen Text
ctxField :: Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
f = do
  Text
a <- Text -> Gen Text
fresh Text
"ctx"
  Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i8, ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (CtxOffsets -> Int
f (Env -> CtxOffsets
envCtx Env
env)))
  pure Text
a

-- | Room for @words@ words of heap. The fast path bumps the context's copy
-- of the current allocation block's free pointer against a limit, as
-- compiled Haskell does with Hp and HpLim; the limit is the nearer of the
-- block's end and the allocation budget's end, so the budget costs nothing
-- here. When the object doesn't fit (or there is no block yet, or the budget
-- is used up) the slow path calls the allocator, which also moves the
-- context on to the new block. See "Allocation" in jit_rt.c. The caller
-- writes every word of the object before anything else can happen.
allocWords :: Env -> Int -> Gen Text
allocWords :: Env -> Int -> Gen Text
allocWords Env
env Int
words = do
  Text
hpA <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oHp
  Text
hp <- Text -> Gen Text
fresh Text
"hp"
  Text -> Gen ()
emit (Text
hp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hpA)
  Text
hp' <- Text -> Gen Text
fresh Text
"hp.new"
  Text -> Gen ()
emit (Text
hp' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
words)
  Text
limA <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oHpLim
  Text
lim <- Text -> Gen Text
fresh Text
"hplim"
  Text -> Gen ()
emit (Text
lim Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
limA)
  Text
full <- Text -> Gen Text
fresh Text
"full"
  Text -> Gen ()
emit (Text
full Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ugt ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hp' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lim)
  Text
fastL <- Text -> Gen Text
freshLabel Text
"alloc.fast"
  Text
slowL <- Text -> Gen Text
freshLabel Text
"alloc.slow"
  Text
joinL <- Text -> Gen Text
freshLabel Text
"alloc.join"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
full Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slowL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fastL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Text -> Gen ()
startBlock Text
fastL
  Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hp' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hpA)
  Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
joinL)
  Text -> Gen ()
startBlock Text
slowL
  Text
slowObj <- Text -> Gen Text
fresh Text
"obj.slow"
  Text -> Gen ()
emit (Text
slowObj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @unison_jit_alloc_words(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
words Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
joinL)
  Text -> Gen ()
startBlock Text
joinL
  Text
obj <- Text -> Gen Text
fresh Text
"obj"
  Text -> Gen ()
emit (Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi ptr [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fastL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ], [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slowObj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slowL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  pure Text
obj

-- ---------------------------------------------------------------------------
-- Exits

data FnEnv = FnEnv
  { FnEnv -> Env
feEnv :: !Env,
    -- | the LLVM function's name; auxiliary functions are named after it
    FnEnv -> Text
feName :: !Text,
    FnEnv -> CombIx
feCix :: !CombIx,
    -- | slots loaded at entry: the combinator's arity, or for an auxiliary
    -- function the depth it starts at
    FnEnv -> Int
feArity :: !Int,
    FnEnv -> Int
feFrameSize :: !Int,
    FnEnv -> Ptr NativeCell
feCell :: !(Ptr NativeCell),
    -- | the loop head, for self tail calls; an auxiliary function has none
    FnEnv -> Maybe Text
feHead :: !(Maybe Text),
    -- | the frame base: the frame offset the interpreter's @fp@ points at
    -- when it enters this function. Zero for a combinator. An auxiliary
    -- function generated inside an inline binding has the binding's base,
    -- and the interpreter holds a @Push@ frame for the binding's body. Slot
    -- offsets stay relative to the combinator's frame throughout.
    FnEnv -> Int
feBase :: !Int,
    -- | registers holding the type-tag and boolean closures, loaded at entry
    FnEnv -> Text
feTagChar, FnEnv -> Text
feTagFloat, FnEnv -> Text
feTagInt, FnEnv -> Text
feTagNat :: !Text,
    -- | the inline @Let@ bindings the code being generated is inside of,
    -- innermost first
    FnEnv -> Deque Enclosing
feEnclosing :: !(Deque Enclosing),
    -- | The function is being generated as a /worker/ (design.md,
    -- "Workers"): its arguments arrive as LLVM parameters instead of on the
    -- Unison stack, and it returns @{status, u, b}@, its one result in
    -- registers. The Unison stack is written only when something exits.
    -- The function the cell points to is then a wrapper around it.
    FnEnv -> Bool
feWorker :: !Bool,
    -- | Set while generating a worker's /fast entry/: the function its
    -- callers call, which holds only the paths that need nothing checked
    -- (no stack room, no poll: they can't exit, call or loop) and return
    -- at once, a base case typically. Any other path tail calls the full
    -- worker, named here, which starts again from the top.
    FnEnv -> Maybe Text
feFast :: !(Maybe Text),
    -- | the symbol of the LLVM function being generated
    FnEnv -> Text
feSym :: !Text,
    -- | the function gets internal linkage (see 'envInternal'); only the
    -- function the cell points to, not its auxiliary functions
    FnEnv -> Bool
feInternal :: !Bool,
    -- | an affine handler case's environment switch this code is inside
    -- of (see 'genInLocal'): the switch is in force until the case's
    -- @Yield@, and every exit until then writes a @Local@ frame record
    FnEnv -> Maybe Local
feLocal :: !(Maybe Local)
  }

-- | An environment switch in force (a native @InLocal@): the register
-- holding the environment to switch back to, and how many inline bindings
-- the code was inside of when the switch was made, which says where its
-- @Local@ frame goes among the bindings' records and which @Yield@ ends it.
data Local = Local
  { Local -> Text
loHenv0 :: !Text,
    Local -> Int
loDepth :: !Int
  }

-- | Whether a @Yield@ here ends the environment switch in force: it is at
-- the depth the switch was made at. A tail call here would leave the
-- switch in force with nothing to end it, so tail calls are exits then.
localEnds :: FnEnv -> Bool
localEnds :: FnEnv -> Bool
localEnds FnEnv
fe = case FnEnv -> Maybe Local
feLocal FnEnv
fe of
  Just Local
lo -> Local -> Int
loDepth Local
lo Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Deque Enclosing -> Int
forall a. Deque a -> Int
D.size (FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe)
  Maybe Local
Nothing -> Bool
False

-- | An inline @Let@ binding being generated. Inside it, the interpreter's
-- view is a fresh frame starting at @enBase@ (its @ap = fp = sp0@), so
-- exits write a frame record for it, and a @Yield@ delivers the results
-- to the body instead of returning.
data Enclosing = Enclosing
  { -- | frame table index
    Enclosing -> Int
enIndex :: !Int,
    -- | frame offset of the binding's frame base
    Enclosing -> Int
enBase :: !Int,
    -- | label of the body block
    Enclosing -> Text
enBody :: !Text,
    -- | number of results the body expects
    Enclosing -> Int
enResults :: !Int,
    -- | the slots the body reads once it runs (see 'liveAt')
    Enclosing -> Maybe IntSet
enLive :: !(Maybe IS.IntSet)
  }

-- | The slots the bodies of the enclosing bindings read once they run,
-- which an exit or unwind inside a binding has to write back as well as
-- what the resumed code itself reads.
enclosingLive :: FnEnv -> Maybe IS.IntSet
enclosingLive :: FnEnv -> Maybe IntSet
enclosingLive FnEnv
fe = (Enclosing -> Maybe IntSet -> Maybe IntSet)
-> Maybe IntSet -> Deque Enclosing -> Maybe IntSet
forall a b. (a -> b -> b) -> b -> Deque a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Enclosing
e Maybe IntSet
acc -> Enclosing -> Maybe IntSet
enLive Enclosing
e Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Maybe IntSet
acc) (IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
IS.empty) (FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe)

-- | The union of two slot sets, where Nothing (every slot) absorbs.
(<+>) :: Maybe IS.IntSet -> Maybe IS.IntSet -> Maybe IS.IntSet
Maybe IntSet
a <+> :: Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Maybe IntSet
b = IntSet -> IntSet -> IntSet
IS.union (IntSet -> IntSet -> IntSet)
-> Maybe IntSet -> Maybe (IntSet -> IntSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe IntSet
a Maybe (IntSet -> IntSet) -> Maybe IntSet -> Maybe IntSet
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe IntSet
b

infixr 5 <+>

-- | The slots (frame offsets, 1 and up) the interpreter reads when it
-- runs @sect@ at depth @d@ with the frame base at offset @base@, and in
-- whatever of the same frame runs after it; Nothing when that can't be
-- told statically, and every slot then has to count. Only these need to
-- be on the Unison stack when native code exits there: the others are
-- never read again (a slot dead here is dead at every later point of the
-- same path; a continuation captured later copies the frame as it is,
-- dead slots included, and never reads them either). Depths follow
-- 'genSection': MCode's "slot @i@ from the top" is offset @d - i@, an
-- instruction pushes 'pushCount' values, a @Let@'s body starts at its
-- combinator's arity, a data match arm pushes the constructor's fields.
-- An offset of 0 or below is the caller's (a pending argument), not ours.
liveAt :: Env -> Int -> Int -> MSection -> Maybe IS.IntSet
liveAt :: Env -> Int -> Int -> MSection -> Maybe IntSet
liveAt Env
env Int
base = Int -> MSection -> Maybe IntSet
go
  where
    go :: Int -> MSection -> Maybe IntSet
go Int
d = \case
      App Bool
_ GRef (RComb Val)
r Args
args -> Int -> GRef (RComb Val) -> Maybe IntSet
forall {comb}. Int -> GRef comb -> Maybe IntSet
refReads Int
d GRef (RComb Val)
r Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Int -> Args -> Maybe IntSet
argReads Int
base Int
d Args
args
      Call Bool
_ CombIx
_ RComb Val
_ Args
args -> Int -> Int -> Args -> Maybe IntSet
argReads Int
base Int
d Args
args
      Jump Int
i Args
args -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Int -> Args -> Maybe IntSet
argReads Int
base Int
d Args
args
      Match Int
i GBranch (RComb Val)
br -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> GBranch (RComb Val) -> Maybe IntSet
arms Int
d GBranch (RComb Val)
br
      NMatch Maybe Reference
_ Int
i GBranch (RComb Val)
br -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> GBranch (RComb Val) -> Maybe IntSet
arms Int
d GBranch (RComb Val)
br
      DMatch Maybe Reference
_ Int
i GBranch (RComb Val)
br -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> GBranch (RComb Val) -> Maybe IntSet
arms Int
d GBranch (RComb Val)
br
      -- the pure request has one field, the value; a request arm pushes
      -- its constructor's fields
      RMatch Int
i MSection
pu EnumMap Word64 (GBranch (RComb Val))
br ->
        Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
          Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> MSection -> Maybe IntSet
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MSection
pu
          Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> ((Word64, GBranch (RComb Val)) -> Maybe IntSet -> Maybe IntSet)
-> Maybe IntSet -> [(Word64, GBranch (RComb Val))] -> Maybe IntSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Word64
_, GBranch (RComb Val)
gb) Maybe IntSet
acc -> Int -> GBranch (RComb Val) -> Maybe IntSet
arms Int
d GBranch (RComb Val)
gb Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Maybe IntSet
acc) (IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
IS.empty) (EnumMap Word64 (GBranch (RComb Val))
-> [(Word64, GBranch (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (GBranch (RComb Val))
br)
      Yield Args
args -> Int -> Int -> Args -> Maybe IntSet
argReads Int
base Int
d Args
args
      Ins GInstr (RComb Val)
i MSection
rest -> Int -> Int -> GInstr (RComb Val) -> Maybe IntSet
forall comb. Int -> Int -> GInstr comb -> Maybe IntSet
instrReads Int
base Int
d GInstr (RComb Val)
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> (GInstr (RComb Val) -> Maybe Int
forall comb. GInstr comb -> Maybe Int
pushCount GInstr (RComb Val)
i Maybe Int -> (Int -> Maybe IntSet) -> Maybe IntSet
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
n -> Int -> MSection -> Maybe IntSet
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) MSection
rest)
      Let MSection
b (CIx Reference
_ Word64
_ Word64
w) Int
_ MSection
body Ptr NativeCell
_ -> case Word64 -> MCombs -> Maybe (GComb Val (RComb Val))
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w (Env -> MCombs
envCombs Env
env) of
        Just (Comb (LamI Int
bodyArity Int
_ MSection
_ Ptr NativeCell
_)) | Int
bodyArity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
d -> Int -> MSection -> Maybe IntSet
go Int
d MSection
b Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> MSection -> Maybe IntSet
go Int
bodyArity MSection
body
        Maybe (GComb Val (RComb Val))
_ -> Maybe IntSet
forall a. Maybe a
Nothing
      Die String
_ -> IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
IS.empty
      MSection
Exit -> IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
IS.empty
    refReads :: Int -> GRef comb -> Maybe IntSet
refReads Int
d = \case
      Stk Int
i -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
      GRef comb
_ -> IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
IS.empty
    -- the arms of a match: each runs with the fields it binds pushed
    -- (none, for a match on an unboxed value), the default arm with
    -- nothing pushed
    arms :: Int -> GBranch (RComb Val) -> Maybe IntSet
arms Int
d = \case
      Test1 Word64
_ Arm (RComb Val)
a MSection
b -> Int -> Arm (RComb Val) -> Maybe IntSet
arm Int
d Arm (RComb Val)
a Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> MSection -> Maybe IntSet
go Int
d MSection
b
      Test2 Word64
_ Arm (RComb Val)
a Word64
_ Arm (RComb Val)
b MSection
c -> Int -> Arm (RComb Val) -> Maybe IntSet
arm Int
d Arm (RComb Val)
a Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Arm (RComb Val) -> Maybe IntSet
arm Int
d Arm (RComb Val)
b Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> MSection -> Maybe IntSet
go Int
d MSection
c
      TestW MSection
df EnumMap Word64 (Arm (RComb Val))
m -> ((Word64, Arm (RComb Val)) -> Maybe IntSet -> Maybe IntSet)
-> Maybe IntSet -> [(Word64, Arm (RComb Val))] -> Maybe IntSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Word64
_, Arm (RComb Val)
a) Maybe IntSet
acc -> Int -> Arm (RComb Val) -> Maybe IntSet
arm Int
d Arm (RComb Val)
a Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Maybe IntSet
acc) (Int -> MSection -> Maybe IntSet
go Int
d MSection
df) (EnumMap Word64 (Arm (RComb Val)) -> [(Word64, Arm (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (Arm (RComb Val))
m)
      TestT MSection
df Map Text MSection
m -> (MSection -> Maybe IntSet -> Maybe IntSet)
-> Maybe IntSet -> [MSection] -> Maybe IntSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\MSection
a Maybe IntSet
acc -> Int -> MSection -> Maybe IntSet
go Int
d MSection
a Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Maybe IntSet
acc) (Int -> MSection -> Maybe IntSet
go Int
d MSection
df) (Map Text MSection -> [MSection]
forall k a. Map k a -> [a]
Map.elems Map Text MSection
m)
      TestY MSection
df Map Bytes MSection
m -> (MSection -> Maybe IntSet -> Maybe IntSet)
-> Maybe IntSet -> [MSection] -> Maybe IntSet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\MSection
a Maybe IntSet
acc -> Int -> MSection -> Maybe IntSet
go Int
d MSection
a Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Maybe IntSet
acc) (Int -> MSection -> Maybe IntSet
go Int
d MSection
df) (Map Bytes MSection -> [MSection]
forall k a. Map k a -> [a]
Map.elems Map Bytes MSection
m)
    arm :: Int -> Arm (RComb Val) -> Maybe IntSet
arm Int
d (Arm Int
n MSection
a) = Int -> MSection -> Maybe IntSet
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) MSection
a

-- | The slots an instruction reads (see 'liveAt').
instrReads :: Int -> Int -> GInstr comb -> Maybe IS.IntSet
instrReads :: forall comb. Int -> Int -> GInstr comb -> Maybe IntSet
instrReads Int
base Int
d = \case
  Prim1 Prim1
_ Int
i -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
  Prim2 Prim2
_ Int
i Int
j -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Int -> Maybe IntSet
slotAt Int
d Int
j
  RefCAS Int
i Int
j Int
k -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Int -> Maybe IntSet
slotAt Int
d Int
j Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Int -> Maybe IntSet
slotAt Int
d Int
k
  ForeignCall Bool
_ ForeignFunc
_ Args
args -> Int -> Int -> Args -> Maybe IntSet
argReads Int
base Int
d Args
args
  GInstr comb
DLLCall -> Maybe IntSet
forall a. Maybe a
Nothing
  SetAff Bool
_ Int
i Int
j -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Int -> Maybe IntSet
slotAt Int
d Int
j
  Capture Word64
_ -> Maybe IntSet
forall a. Maybe a
Nothing
  Discard Int
_ -> Maybe IntSet
forall a. Maybe a
Nothing
  Name GRef comb
r Args
args -> (case GRef comb
r of Stk Int
i -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i; GRef comb
_ -> IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
IS.empty) Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Int -> Args -> Maybe IntSet
argReads Int
base Int
d Args
args
  Info String
_ -> IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
IS.empty
  Pack Reference
_ PackedTag
_ Args
args -> Int -> Int -> Args -> Maybe IntSet
argReads Int
base Int
d Args
args
  RecPack RecordShape
_ Args
args -> Int -> Int -> Args -> Maybe IntSet
argReads Int
base Int
d Args
args
  RecUnpack Vector FieldRef
_ Int
i -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
  RecSet FieldRef
_ Args
args -> Int -> Int -> Args -> Maybe IntSet
argReads Int
base Int
d Args
args
  Lit MLit
_ -> IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
IS.empty
  Print Int
i -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
  Reset EnumSet Word64
_ Int
i Maybe Int
mi -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Maybe IntSet -> (Int -> Maybe IntSet) -> Maybe Int -> Maybe IntSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
IS.empty) (Int -> Int -> Maybe IntSet
slotAt Int
d) Maybe Int
mi
  InLocal Int
i -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
  Fork Int
i -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
  Atomically Int
i -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
  Seq Args
args -> Int -> Int -> Args -> Maybe IntSet
argReads Int
base Int
d Args
args
  TryForce Int
i -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
  SandboxingFailure Text
_ -> Maybe IntSet
forall a. Maybe a
Nothing
  KeepAlive Int
i -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
  NewForeignPtr Int
i Int
j -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Int -> Maybe IntSet
slotAt Int
d Int
j
  AddFinalizer Int
i Int
j -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Int -> Maybe IntSet
slotAt Int
d Int
j
  MkCallback Int
i Int
j -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Int -> Maybe IntSet
slotAt Int
d Int
j

-- | The slots an argument list reads, as 'argSources' resolves them.
argReads :: Int -> Int -> Args -> Maybe IS.IntSet
argReads :: Int -> Int -> Args -> Maybe IntSet
argReads Int
base Int
d = \case
  Args
ZArgs -> IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
IS.empty
  VArg1 Int
i -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
  VArg2 Int
i Int
j -> Int -> Int -> Maybe IntSet
slotAt Int
d Int
i Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Int -> Int -> Maybe IntSet
slotAt Int
d Int
j
  VArgR Int
i Int
l -> IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just ([Int] -> IntSet
IS.fromList [Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k | Int
k <- [Int
0 .. Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1])
  VArgN PrimArray Int
v -> IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just ([Int] -> IntSet
IS.fromList [Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i | Int
i <- PrimArray Int -> [Int]
forall a. Prim a => PrimArray a -> [a]
primArrayToList PrimArray Int
v, Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1])
  VArgV Int
i -> IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just ([Int] -> IntSet
IS.fromList [Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k | Int
k <- [Int
0 .. (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
base) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1])

-- | Slot @i@ from the top at depth @d@, if it is one of ours.
slotAt :: Int -> Int -> Maybe IS.IntSet
slotAt :: Int -> Int -> Maybe IntSet
slotAt Int
d Int
i
  | Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 = IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just (Int -> IntSet
IS.singleton (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i))
  | Bool
otherwise = IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
IS.empty

-- | The slots that have to be on the Unison stack when this exit is
-- taken at depth @d@: what the interpreter reads when it carries on from
-- there, and what the enclosing bindings' bodies read afterwards.
-- Nothing for an exit that calls the function again from its entry
-- (every slot).
exitLive :: FnEnv -> Int -> Exit -> Maybe IS.IntSet
exitLive :: FnEnv -> Int -> Exit -> Maybe IntSet
exitLive FnEnv
fe Int
d = \case
  Resume CombIx
_ MSection
sect -> Env -> Int -> Int -> MSection -> Maybe IntSet
liveAt Env
env Int
base Int
d MSection
sect Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> FnEnv -> Maybe IntSet
enclosingLive FnEnv
fe
  CallOut CombIx
_ GInstr (RComb Val)
instr MSection
rest Int
n Ptr NativeCell
_ -> Int -> Int -> GInstr (RComb Val) -> Maybe IntSet
forall comb. Int -> Int -> GInstr comb -> Maybe IntSet
instrReads Int
base Int
d GInstr (RComb Val)
instr Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> Env -> Int -> Int -> MSection -> Maybe IntSet
liveAt Env
env Int
base (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) MSection
rest Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> FnEnv -> Maybe IntSet
enclosingLive FnEnv
fe
  Named String
_ Exit
e -> FnEnv -> Int -> Exit -> Maybe IntSet
exitLive FnEnv
fe Int
d Exit
e
  Exit
_ -> Maybe IntSet
forall a. Maybe a
Nothing
  where
    env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
    base :: Int
base = FnEnv -> Int
currentBase FnEnv
fe

-- | The frame base the interpreter would see: @fp@ for the function's own
-- frame, or the innermost inline binding's base.
frameBase :: FnEnv -> Gen Text
frameBase :: FnEnv -> Gen Text
frameBase FnEnv
fe = Int -> Gen Text
fpPlus (FnEnv -> Int
currentBase FnEnv
fe)

-- | The frame offset of the interpreter's current frame base.
currentBase :: FnEnv -> Int
currentBase :: FnEnv -> Int
currentBase FnEnv
fe = case FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe of
  Deque Enclosing
Empty -> FnEnv -> Int
feBase FnEnv
fe
  Enclosing
e :<| Deque Enclosing
_ -> Enclosing -> Int
enBase Enclosing
e

-- | Writes the frame records for every enclosing inline binding,
-- innermost first (the order a chain of native callers would write them).
unwindEnclosing :: FnEnv -> Gen ()
unwindEnclosing :: FnEnv -> Gen ()
unwindEnclosing FnEnv
fe = Deque Enclosing -> Gen ()
go (FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe)
  where
    go :: Deque Enclosing -> Gen ()
go Deque Enclosing
Empty = () -> Gen ()
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go (Enclosing
e :<| Deque Enclosing
outer) = do
      let !(Pair Int
fsz Maybe Text
asz) = case Deque Enclosing
outer of
            Deque Enclosing
Empty -> Int -> Maybe Text -> Pair Int (Maybe Text)
forall a b. a -> b -> Pair a b
Pair (Enclosing -> Int
enBase Enclosing
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- FnEnv -> Int
feBase FnEnv
fe) Maybe Text
forall a. Maybe a
Nothing
            Enclosing
o :<| Deque Enclosing
_ -> Int -> Maybe Text -> Pair Int (Maybe Text)
forall a b. a -> b -> Pair a b
Pair (Enclosing -> Int
enBase Enclosing
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Enclosing -> Int
enBase Enclosing
o) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"0")
      Env -> Int -> Int -> Maybe Text -> Gen ()
writeRecord (FnEnv -> Env
feEnv FnEnv
fe) (Enclosing -> Int
enIndex Enclosing
e) Int
fsz Maybe Text
asz
      Deque Enclosing -> Gen ()
go Deque Enclosing
outer

-- | Writes one frame record. The pending-argument count is @fp - ap@
-- unless given.
writeRecord :: Env -> Int -> Int -> Maybe Text -> Gen ()
writeRecord :: Env -> Int -> Int -> Maybe Text -> Gen ()
writeRecord Env
env Int
ix Int
fsz Maybe Text
masz = do
  Text
fr <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oFrames
  Text
frp <- Text -> Gen Text
fresh Text
"frames"
  Text -> Gen ()
emit (Text
frp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fr)
  Text
nfa <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oNFrames
  Text
nf <- Text -> Gen Text
fresh Text
"nf"
  Text -> Gen ()
emit (Text
nf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nfa)
  -- the buffer's capacity is a bound the C stack budget implies; check it
  -- rather than trust it (jit_exit.c does the same for the call path)
  Text
mfa <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oMaxFrames
  Text
mf <- Text -> Gen Text
fresh Text
"maxf"
  Text -> Gen ()
emit (Text
mf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mfa)
  Text
full <- Text -> Gen Text
fresh Text
"full"
  Text -> Gen ()
emit (Text
full Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp sge i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mf)
  Text
fullL <- Text -> Gen Text
freshLabel Text
"frames.full"
  Text
okL <- Text -> Gen Text
freshLabel Text
"frames.ok"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
full Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fullL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
okL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Text -> Gen ()
startBlock Text
fullL
  Text -> Gen ()
emit Text
"call void @unison_jit_exit_fail()"
  Text -> Gen ()
emit Text
"unreachable"
  Text -> Gen ()
startBlock Text
okL
  Text
off <- Text -> Gen Text
fresh Text
"off"
  Text -> Gen ()
emit (Text
off Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = mul i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 3")
  Text
rec0 <- Text -> Gen Text
fresh Text
"rec"
  Text -> Gen ()
emit (Text
rec0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
frp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
off)
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rec0)
  Text
rec1 <- Text -> Gen Text
fresh Text
"rec"
  Text -> Gen ()
emit (Text
rec1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rec0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 1")
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
fsz Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rec1)
  Text
rec2 <- Text -> Gen Text
fresh Text
"rec"
  Text -> Gen ()
emit (Text
rec2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rec0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 2")
  Text
asz <- case Maybe Text
masz of
    Just Text
a -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
a
    Maybe Text
Nothing -> do
      Text
a <- Text -> Gen Text
fresh Text
"asz"
      Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = sub i64 %fpb, %ap")
      pure Text
a
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
asz Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rec2)
  Text
nf' <- Text -> Gen Text
fresh Text
"nf"
  Text -> Gen ()
emit (Text
nf' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nf' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nfa)

-- | Adds an exit and returns its global index.
addExit :: Env -> Exit -> Gen Int
addExit :: Env -> Exit -> StateT GS Identity Int
addExit Env
env Exit
e = do
  Int
n <- (GS -> Int) -> StateT GS Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> Int
gsNExits
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsExits = gsExits s |> e, gsNExits = n + 1})
  pure (Env -> Int
envExitBase Env
env Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)

-- | Adds a frame table entry and returns its global index.
addFrame :: Env -> Frame -> Gen Int
addFrame :: Env -> Frame -> StateT GS Identity Int
addFrame Env
env Frame
f = do
  Int
n <- (GS -> Int) -> StateT GS Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> Int
gsNFrames
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsFrames = gsFrames s |> f, gsNFrames = n + 1})
  pure (Env -> Int
envFrameBase Env
env Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)

-- | Writes the given slots back to the Unison stack.
writeSlots :: [Int] -> Gen ()
writeSlots :: [Int] -> Gen ()
writeSlots [] = () -> Gen ()
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
writeSlots [Int]
slots = do
  -- the frame's address on each stack once, then constant offsets
  Text
f <- Int -> Gen Text
fpPlus Int
0
  Text
ustk <- Text -> Gen Text
stackReg Text
"%ustk"
  Text
ub <- Text -> Gen Text
fresh Text
"ufr"
  Text -> Gen ()
emit (Text
ub Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ustk Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f)
  Text
bstk <- Text -> Gen Text
stackReg Text
"%bstk"
  Text
bb <- Text -> Gen Text
fresh Text
"bfr"
  Text -> Gen ()
emit (Text
bb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bstk Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f)
  [Int] -> (Int -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
slots ((Int -> Gen ()) -> Gen ()) -> (Int -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
k -> do
    Int -> Gen ()
useK Int
k
    Text
u <- Int -> Gen Text
loadU Int
k
    Text
ua <- Text -> Gen Text
fresh Text
"ua"
    Text -> Gen ()
emit (Text
ua Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ub Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k)
    Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
    Text
b <- Int -> Gen Text
loadB Int
k
    Text
ba <- Text -> Gen Text
fresh Text
"ba"
    Text -> Gen ()
emit (Text
ba Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k)
    Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)

-- | A stress-mode countdown on a pair of Ctx fields; gives an i1 that is
-- true every Nth time.
stressFire :: Env -> (CtxOffsets -> Int) -> (CtxOffsets -> Int) -> Gen Text
stressFire :: Env -> (CtxOffsets -> Int) -> (CtxOffsets -> Int) -> Gen Text
stressFire Env
env CtxOffsets -> Int
oLeft CtxOffsets -> Int
oEvery = do
  Text
left <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oLeft
  Text
n <- Text -> Gen Text
fresh Text
"left"
  Text -> Gen ()
emit (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
left)
  Text
n' <- Text -> Gen Text
fresh Text
"left"
  Text -> Gen ()
emit (Text
n' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = sub i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
  Text
fire <- Text -> Gen Text
fresh Text
"fire"
  Text -> Gen ()
emit (Text
fire Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp sle i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
  Text
every <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oEvery
  Text
ev <- Text -> Gen Text
fresh Text
"every"
  Text -> Gen ()
emit (Text
ev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
every)
  Text
reset <- Text -> Gen Text
fresh Text
"reset"
  Text -> Gen ()
emit (Text
reset Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fire Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n')
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reset Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
left)
  pure Text
fire

-- | Loads the callee's code pointer from its cell. Gives the pointer and
-- an i1 saying whether the callee must be treated as not compiled. A
-- callee defined in this module is named directly, and is always there
-- (except under the callee stress mode, which keeps the cell path tested).
loadCallee :: Env -> Ptr NativeCell -> Gen (Pair Text Text)
loadCallee :: Env -> Ptr NativeCell -> Gen (Pair Text Text)
loadCallee Env
env Ptr NativeCell
cell
  | Bool -> Bool
not (Env -> Bool
envStressCallee Env
env), Just Text
name <- Ptr NativeCell -> Map (Ptr NativeCell) Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ptr NativeCell
cell (Env -> Map (Ptr NativeCell) Text
envLocal Env
env) = Pair Text Text -> Gen (Pair Text Text)
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair (Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) Text
"false")
loadCallee Env
env Ptr NativeCell
cell = do
  let WordPtr Word
addr = Ptr NativeCell -> WordPtr
forall a. Ptr a -> WordPtr
ptrToWordPtr Ptr NativeCell
cell
  Text
fnp <- Text -> Gen Text
fresh Text
"fn"
  Text -> Gen ()
emit (Text
fnp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr inttoptr (i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word -> Text
forall a. Show a => a -> Text
tshow Word
addr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr)")
  Text
isNull <- Text -> Gen Text
fresh Text
"isnull"
  Text -> Gen ()
emit (Text
isNull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fnp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", null")
  if Env -> Bool
envStressCallee Env
env
    then do
      Text
fire <- Env -> (CtxOffsets -> Int) -> (CtxOffsets -> Int) -> Gen Text
stressFire Env
env CtxOffsets -> Int
oStressCalleeLeft CtxOffsets -> Int
oStressCallee
      Text
skip <- Text -> Gen Text
fresh Text
"skip"
      Text -> Gen ()
emit (Text
skip Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
isNull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fire)
      pure (Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair Text
fnp Text
skip)
    else Pair Text Text -> Gen (Pair Text Text)
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair Text
fnp Text
isNull)

-- | A block that writes the frame back to the Unison stack, records the
-- stack pointers in @Ctx@, and returns the exit's index. @d@ is the frame
-- depth at the exit point; every slot 1..d is written back.
exitBlock :: FnEnv -> Int -> Exit -> Gen Text
exitBlock :: FnEnv -> Int -> Exit -> Gen Text
exitBlock = Text -> FnEnv -> Int -> Exit -> Gen Text
exitBlockNamed Text
"exit"

exitBlockNamed :: Text -> FnEnv -> Int -> Exit -> Gen Text
exitBlockNamed :: Text -> FnEnv -> Int -> Exit -> Gen Text
exitBlockNamed Text
base FnEnv
fe Int
d Exit
e = do
  Int
ix <- Env -> Exit -> StateT GS Identity Int
addExit (FnEnv -> Env
feEnv FnEnv
fe) Exit
e
  Text -> Gen () -> Gen Text
sideBlock Text
base (FnEnv
-> Int
-> Maybe IntSet
-> Bool
-> Maybe (Pair Int Int)
-> Text
-> Gen ()
joinShared FnEnv
fe Int
d (FnEnv -> Int -> Exit -> Maybe IntSet
exitLive FnEnv
fe Int
d Exit
e) Bool
True Maybe (Pair Int Int)
forall a. Maybe a
Nothing (Int -> Text
forall a. Show a => a -> Text
tshow Int
ix))

-- | Ends the current block by branching to the function's write-back
-- block for the given key (see 'SharedKey'), which returns @status@ for
-- this path. One such block serves every exit and unwind that writes the
-- same thing, with the status as a phi: the write-back is most of a
-- function's code otherwise (a slot is a load, an address and a store on
-- each stack, for every slot at every exit; 72% of the lines of the
-- suite's largest module on 2026-10-09). LLVM's mem2reg turns the slot
-- loads of the shared block into phis of their own.
--
-- Only the slots in @live@ are written (every slot up to @d@ when it is
-- Nothing): the rest are never read again, see 'liveAt'.
--
-- A slot holding a boolean as an i1 register has no value in its
-- allocas; the shared block can't know which paths those are, so the
-- closure is built and stored here, on the cold path, before the branch.
joinShared :: FnEnv -> Int -> Maybe IS.IntSet -> Bool -> Maybe (Pair Int Int) -> Text -> Gen ()
joinShared :: FnEnv
-> Int
-> Maybe IntSet
-> Bool
-> Maybe (Pair Int Int)
-> Text
-> Gen ()
joinShared FnEnv
fe Int
d Maybe IntSet
live Bool
isExit Maybe (Pair Int Int)
ownFrame Text
status
  | Env -> Bool
envExitCall (FnEnv -> Env
feEnv FnEnv
fe) = FnEnv
-> Int
-> Maybe IntSet
-> Bool
-> Maybe (Pair Int Int)
-> Text
-> Gen ()
joinCall FnEnv
fe Int
d Maybe IntSet
live Bool
isExit Maybe (Pair Int Int)
ownFrame Text
status
  | Bool
otherwise = FnEnv
-> Int
-> Maybe IntSet
-> Bool
-> Maybe (Pair Int Int)
-> Text
-> Gen ()
joinBlock FnEnv
fe Int
d Maybe IntSet
live Bool
isExit Maybe (Pair Int Int)
ownFrame Text
status

-- | The slots a write-back writes: the live ones up to the depth.
liveSlots :: Int -> Maybe IS.IntSet -> [Int]
liveSlots :: Int -> Maybe IntSet -> [Int]
liveSlots Int
d Maybe IntSet
live = [Int] -> (IntSet -> [Int]) -> Maybe IntSet -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Int
1 .. Int
d] ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
d) ([Int] -> [Int]) -> (IntSet -> [Int]) -> IntSet -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IS.toAscList) Maybe IntSet
live

-- | Ends the current block with the write-back as one call to the IR
-- routine @unison_jit_exit_frame@ (cbits/jit_exit.c), the live slots
-- stored into an argument block (@%xargs@, one alloca per function in the
-- entry block, sized by 'gsMaxExitArgs') and the rest (what to do with
-- them: the offsets, the depth, the frame records) as a constant
-- descriptor of the module, then returns the status. The site is then
-- two stores per slot and one call, where the blocks of 'joinBlock' are
-- six instructions per slot, and nothing else of the write-back goes
-- through the optimizer or the backend. (The block rather than variadic
-- arguments: the routine is IR generated once for every target, and a
-- variadic function's IR carries the target's va_list ABI.) The routine has the @preserve_most@ convention: a callee's
-- exit inlined into its caller is followed by the caller's unwind, two
-- calls in a row with the caller's live values across the first, and
-- under the C convention those would need callee-saved registers, which
-- the function then saves at every entry (Collatz 4% slower). The
-- default since 2026-10-09 (@UNISON_JIT_EXITS@).
joinCall :: FnEnv -> Int -> Maybe IS.IntSet -> Bool -> Maybe (Pair Int Int) -> Text -> Gen ()
joinCall :: FnEnv
-> Int
-> Maybe IntSet
-> Bool
-> Maybe (Pair Int Int)
-> Text
-> Gen ()
joinCall FnEnv
fe Int
d Maybe IntSet
live Bool
isExit Maybe (Pair Int Int)
ownFrame Text
status = do
  let slots :: [Int]
slots = Int -> Maybe IntSet -> [Int]
liveSlots Int
d Maybe IntSet
live
      base :: Int
base = FnEnv -> Int
feBase FnEnv
fe
      es :: [Enclosing]
es = Deque Enclosing -> [Enclosing]
forall a. Deque a -> [a]
D.toList (FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe)
      -- the records, as 'flushShared' writes them: the binding being
      -- unwound, then the enclosing bindings innermost first, each with
      -- its frame size relative to the next binding out, and the Local
      -- frame of an environment switch in force (see 'genInLocal') where
      -- the switch was made, after the bindings entered since. The pending
      -- count of the outermost record is -1 ("fpb - ap", computed by the
      -- routine) and 0 for the rest.
      own :: [[Int]]
own = case Maybe (Pair Int Int)
ownFrame of
        Maybe (Pair Int Int)
Nothing -> []
        Just (Pair Int
ix Int
fdepth) -> [[Int
ix, Int
fdepth Int -> Int -> Int
forall a. Num a => a -> a -> a
- FnEnv -> Int
currentBase FnEnv
fe]]
      enclosing :: [[Int]]
enclosing = (Enclosing -> Maybe Enclosing -> [Int])
-> [Enclosing] -> [Maybe Enclosing] -> [[Int]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Enclosing
e Maybe Enclosing
outer -> [Enclosing -> Int
enIndex Enclosing
e, Enclosing -> Int
enBase Enclosing
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> (Enclosing -> Int) -> Maybe Enclosing -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
base Enclosing -> Int
enBase Maybe Enclosing
outer]) [Enclosing]
es ((Enclosing -> Maybe Enclosing) -> [Enclosing] -> [Maybe Enclosing]
forall a b. (a -> b) -> [a] -> [b]
map Enclosing -> Maybe Enclosing
forall a. a -> Maybe a
Just (Int -> [Enclosing] -> [Enclosing]
forall a. Int -> [a] -> [a]
drop Int
1 [Enclosing]
es) [Maybe Enclosing] -> [Maybe Enclosing] -> [Maybe Enclosing]
forall a. [a] -> [a] -> [a]
++ [Maybe Enclosing
forall a. Maybe a
Nothing])
      ordered :: [[Int]]
ordered = case FnEnv -> Maybe Local
feLocal FnEnv
fe of
        Maybe Local
Nothing -> [[Int]]
own [[Int]] -> [[Int]] -> [[Int]]
forall a. [a] -> [a] -> [a]
++ [[Int]]
enclosing
        Just Local
lo -> let inner :: Int
inner = [Enclosing] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Enclosing]
es Int -> Int -> Int
forall a. Num a => a -> a -> a
- Local -> Int
loDepth Local
lo in [[Int]]
own [[Int]] -> [[Int]] -> [[Int]]
forall a. [a] -> [a] -> [a]
++ Int -> [[Int]] -> [[Int]]
forall a. Int -> [a] -> [a]
take Int
inner [[Int]]
enclosing [[Int]] -> [[Int]] -> [[Int]]
forall a. [a] -> [a] -> [a]
++ [[-Int
1, Int
0]] [[Int]] -> [[Int]] -> [[Int]]
forall a. [a] -> [a] -> [a]
++ Int -> [[Int]] -> [[Int]]
forall a. Int -> [a] -> [a]
drop Int
inner [[Int]]
enclosing
      recs :: [[Int]]
recs = ([Int] -> Int -> [Int]) -> [[Int]] -> [Int] -> [[Int]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[Int]
r Int
pending -> [Int]
r [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
pending]) [[Int]]
ordered (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate ([[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
ordered Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
0 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [-Int
1 :: Int])
      flags :: Int
flags = (if Bool
isExit then Int
1 else Int
0) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if [Enclosing] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Enclosing]
es Bool -> Bool -> Bool
&& Maybe Local -> Bool
forall a. Maybe a -> Bool
isNothing (FnEnv -> Maybe Local
feLocal FnEnv
fe) then Int
2 else Int
0) :: Int
      header :: [Int]
header = [Int
flags, FnEnv -> Int
currentBase FnEnv
fe, Int
base, Int
d, [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
slots, [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
recs]
      contents :: Text
contents = Text -> Deque Text -> Text
intercalateT Text
", " ([Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ((Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Int -> Text) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
forall a. Show a => a -> Text
tshow) ([Int]
header [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
slots [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Int]]
recs)))
  Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isExit (Int -> Gen ()
useK Int
d)
  [Pair Text Text]
vals <- [Int]
-> (Int -> Gen (Pair Text Text))
-> StateT GS Identity [Pair Text Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
slots ((Int -> Gen (Pair Text Text))
 -> StateT GS Identity [Pair Text Text])
-> (Int -> Gen (Pair Text Text))
-> StateT GS Identity [Pair Text Text]
forall a b. (a -> b) -> a -> b
$ \Int
k -> Int -> Gen ()
useK Int
k Gen () -> Gen (Pair Text Text) -> Gen (Pair Text Text)
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair (Text -> Text -> Pair Text Text)
-> Gen Text -> StateT GS Identity (Text -> Pair Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Text
loadU Int
k StateT GS Identity (Text -> Pair Text Text)
-> Gen Text -> Gen (Pair Text Text)
forall a b.
StateT GS Identity (a -> b)
-> StateT GS Identity a -> StateT GS Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Gen Text
loadB Int
k)
  Map Text Text
descs <- (GS -> Map Text Text) -> StateT GS Identity (Map Text Text)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> Map Text Text
gsDescs
  Text
name <- case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
contents Map Text Text
descs of
    Just Text
n -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
n
    Maybe Text
Nothing -> do
      let n :: Text
n = Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feSym FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Map Text Text -> Int
forall k a. Map k a -> Int
Map.size Map Text Text
descs)
          n' :: Text
n' = Int -> Text
forall a. Show a => a -> Text
tshow ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
header Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
slots Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
recs)
      (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((GS -> GS) -> Gen ()) -> (GS -> GS) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \GS
s ->
        GS
s
          { gsDescs = Map.insert contents n descs,
            gsDescText = gsDescText s |> (n <> " = private unnamed_addr constant [" <> n' <> " x i64] [" <> contents <> "]")
          }
      pure Text
n
  -- the live values into the argument block: a word and a pointer per
  -- slot, then the Local environment when there is one
  let words :: [(Text, Text)]
words = (Pair Text Text -> [(Text, Text)])
-> [Pair Text Text] -> [(Text, Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Pair Text
u Text
b) -> [(Text
"i64", Text
u), (Text
"ptr", Text
b)]) [Pair Text Text]
vals [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [(Text, Text)]
-> (Local -> [(Text, Text)]) -> Maybe Local -> [(Text, Text)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Local
lo -> [(Text
"ptr", Local -> Text
loHenv0 Local
lo)]) (FnEnv -> Maybe Local
feLocal FnEnv
fe)
  -- at least one word: the call passes the block whether or not the
  -- site stores anything in it (a site with no live slots, such as an
  -- exit from a frame of size 0, stores nothing), and 'entryBlock'
  -- allocates the block only when the count is positive
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsMaxExitArgs = max (gsMaxExitArgs s) (max 1 (length words))})
  [(Int, (Text, Text))] -> ((Int, (Text, Text)) -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [(Text, Text)] -> [(Int, (Text, Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [(Text, Text)]
words) (((Int, (Text, Text)) -> Gen ()) -> Gen ())
-> ((Int, (Text, Text)) -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, (Text
ty, Text
v)) -> do
    Text
a <- Text -> Gen Text
fresh Text
"xa"
    Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr inbounds i64, ptr %xargs, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
i)
    Text -> Gen ()
emit (Text
"store " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a)
  -- the routine doesn't hand the status back: returning what was passed
  -- keeps it a constant here, so that LLVM still knows the function's
  -- range of statuses (a caller folds its checks of them with it)
  Text -> Gen ()
emit (Text
"call preserve_mostcc void @unison_jit_exit_frame(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 %fp, i64 %ap, ptr %xargs)")
  FnEnv -> Text -> Gen ()
retStatus FnEnv
fe Text
status

-- | 'joinShared' with generated write-back blocks (@UNISON_JIT_EXITS=blocks@).
joinBlock :: FnEnv -> Int -> Maybe IS.IntSet -> Bool -> Maybe (Pair Int Int) -> Text -> Gen ()
joinBlock :: FnEnv
-> Int
-> Maybe IntSet
-> Bool
-> Maybe (Pair Int Int)
-> Text
-> Gen ()
joinBlock FnEnv
fe Int
d Maybe IntSet
live Bool
isExit Maybe (Pair Int Int)
ownFrame Text
status = do
  let slots :: [Int]
slots = Int -> Maybe IntSet -> [Int]
liveSlots Int
d Maybe IntSet
live
  -- (the observing InLocal isn't generated in this mode, see 'localObservingOn')
  Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Local -> Bool
forall a. Maybe a -> Bool
isJust (FnEnv -> Maybe Local
feLocal FnEnv
fe)) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ Text -> Gen ()
failWith Text
"an environment switch with generated write-back blocks"
  IntMap Text
kinds <- (GS -> IntMap Text) -> StateT GS Identity (IntMap Text)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> IntMap Text
gsKinds
  [Int] -> (Int -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntMap Text -> [Int]
forall a. IntMap a -> [Int]
IM.keys IntMap Text
kinds) ((Int -> Gen ()) -> Gen ()) -> (Int -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
k -> Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
k Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
slots) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
    Text
b <- Int -> Gen Text
loadB Int
k
    Text -> Gen ()
emit (Text
"store i64 -1, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
uSlot Int
k)
    Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
bSlot Int
k)
  let key :: SharedKey
key = Int
-> [Int] -> Bool -> Maybe (Int, Int) -> [(Int, Int)] -> SharedKey
SharedKey Int
d [Int]
slots Bool
isExit ((Pair Int Int -> (Int, Int))
-> Maybe (Pair Int Int) -> Maybe (Int, Int)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Pair Int
ix Int
fd) -> (Int
ix, Int
fd)) Maybe (Pair Int Int)
ownFrame) [(Enclosing -> Int
enIndex Enclosing
e, Enclosing -> Int
enBase Enclosing
e) | Enclosing
e <- Deque Enclosing -> [Enclosing]
forall a. Deque a -> [a]
D.toList (FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe)]
  Text
from <- Gen Text
curLabel
  Map SharedKey Shared
shared <- (GS -> Map SharedKey Shared)
-> StateT GS Identity (Map SharedKey Shared)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> Map SharedKey Shared
gsShared
  Text
label <- case SharedKey -> Map SharedKey Shared -> Maybe Shared
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SharedKey
key Map SharedKey Shared
shared of
    Just (Shared Text
l FnEnv
_ Deque (Pair Text Text)
_) -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
l
    Maybe Shared
Nothing -> Text -> Gen Text
freshLabel Text
"wb"
  let pred_ :: Pair Text Text
pred_ = Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair Text
status Text
from
      entry :: Shared
entry = case SharedKey -> Map SharedKey Shared -> Maybe Shared
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SharedKey
key Map SharedKey Shared
shared of
        Just (Shared Text
l FnEnv
fe0 Deque (Pair Text Text)
preds) -> Text -> FnEnv -> Deque (Pair Text Text) -> Shared
Shared Text
l FnEnv
fe0 (Deque (Pair Text Text)
preds Deque (Pair Text Text) -> Pair Text Text -> Deque (Pair Text Text)
forall a. Deque a -> a -> Deque a
|> Pair Text Text
pred_)
        Maybe Shared
Nothing -> Text -> FnEnv -> Deque (Pair Text Text) -> Shared
Shared Text
label FnEnv
fe (Pair Text Text -> Deque (Pair Text Text)
forall a. a -> Deque a
D.singleton Pair Text Text
pred_)
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsShared = Map.insert key entry (gsShared s)})
  Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label)

-- | Generates the function's shared write-back blocks (see 'joinShared').
flushShared :: Gen ()
flushShared :: Gen ()
flushShared = do
  Map SharedKey Shared
shared <- (GS -> Map SharedKey Shared)
-> StateT GS Identity (Map SharedKey Shared)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> Map SharedKey Shared
gsShared
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsKinds = IM.empty})
  [(SharedKey, Shared)] -> ((SharedKey, Shared) -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map SharedKey Shared -> [(SharedKey, Shared)]
forall k a. Map k a -> [(k, a)]
Map.toList Map SharedKey Shared
shared) (((SharedKey, Shared) -> Gen ()) -> Gen ())
-> ((SharedKey, Shared) -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \(SharedKey Int
d [Int]
slots Bool
isExit Maybe (Int, Int)
ownFrame [(Int, Int)]
_, Shared Text
label FnEnv
fe Deque (Pair Text Text)
preds) ->
    Text -> Gen () -> Gen ()
sideBlockNamed Text
label (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
      let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      Text
st <- Text -> Gen Text
fresh Text
"st"
      Text -> Gen ()
emit (Text
st Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Deque Text -> Text
intercalateT Text
", " ((Pair Text Text -> Text) -> Deque (Pair Text Text) -> Deque Text
forall a b. (a -> b) -> Deque a -> Deque b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Pair Text
v Text
from) -> Text
"[ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
from Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]") Deque (Pair Text Text)
preds))
      [Int] -> Gen ()
writeSlots [Int]
slots
      Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isExit (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
        Text
b <- FnEnv -> Gen Text
frameBase FnEnv
fe
        Text
ap <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oAp
        Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Deque Enclosing -> Bool
forall a. Deque a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe) then Text
"%ap" else Text
b) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ap)
        Text
fp <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oFp
        Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fp)
        Text
sp <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oSp
        Text
f <- Int -> Gen Text
fpPlus Int
d
        Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sp)
        -- a worker's entry doesn't raise the high-water mark; its exits do
        Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FnEnv -> Bool
feWorker FnEnv
fe) (Env -> Text -> Gen ()
markWritten Env
env Text
f)
      Maybe (Int, Int) -> ((Int, Int) -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Int, Int)
ownFrame (((Int, Int) -> Gen ()) -> Gen ())
-> ((Int, Int) -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \(Int
ix, Int
fdepth) -> case FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe of
        Deque Enclosing
Empty -> Env -> Int -> Int -> Maybe Text -> Gen ()
writeRecord Env
env Int
ix (Int
fdepth Int -> Int -> Int
forall a. Num a => a -> a -> a
- FnEnv -> Int
feBase FnEnv
fe) Maybe Text
forall a. Maybe a
Nothing
        Enclosing
e :<| Deque Enclosing
_ -> Env -> Int -> Int -> Maybe Text -> Gen ()
writeRecord Env
env Int
ix (Int
fdepth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Enclosing -> Int
enBase Enclosing
e) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"0")
      FnEnv -> Gen ()
unwindEnclosing FnEnv
fe
      FnEnv -> Text -> Gen ()
retStatus FnEnv
fe Text
st

-- | Terminates the current block with a resume exit at this section.
exitResume :: FnEnv -> Int -> MSection -> Gen ()
exitResume :: FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect = case FnEnv -> Maybe Text
feFast FnEnv
fe of
  -- a fast entry can't exit (it has checked nothing): the full worker can
  Just Text
full -> FnEnv -> Text -> Gen ()
tailToFull FnEnv
fe Text
full
  Maybe Text
Nothing -> do
    Text
l <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
    Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l)

-- | In a fast entry: hands the call over to the full worker, with the
-- arguments it was called with (see 'feFast').
tailToFull :: FnEnv -> Text -> Gen ()
tailToFull :: FnEnv -> Text -> Gen ()
tailToFull FnEnv
fe Text
full = do
  Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources ([Int] -> Deque Int
forall a. [a] -> Deque a
D.fromList [Int
1 .. FnEnv -> Int
feArity FnEnv
fe])
  Text
r <- Text -> Gen Text
fresh Text
"r"
  Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerTail Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerCC Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
full Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(ptr %ctx, i64 %fp.in" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Deque (Pair Text Text) -> Text
argList Deque (Pair Text Text)
vals Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  Text -> Gen ()
emit (Text
"ret " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r)

-- | The calling convention of workers, and how one tail calls another.
-- @tailcc@ with @musttail@ guarantees a tail call between workers of any
-- signatures; LLVM's x86-64 backend refuses guaranteed tail calls under the
-- Win64 convention ("Can't handle guaranteed tail call under win64 yet"),
-- so on Windows workers use @fastcc@ and a plain @tail call@: a sibling
-- call where the callee's stack arguments fit the caller's, an ordinary
-- call otherwise, which the C stack guard bounds (2026-10-18).
workerCC, workerTail :: Text
(Text
workerCC, Text
workerTail)
  | String
os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"mingw32" = (Text
"fastcc", Text
"tail call")
  | Bool
otherwise = (Text
"tailcc", Text
"musttail call")

-- | Arguments as a worker takes them, each after a comma.
argList :: Deque (Pair Text Text) -> Text
argList :: Deque (Pair Text Text) -> Text
argList = (Pair Text Text -> Text) -> Deque (Pair Text Text) -> Text
forall m a. Monoid m => (a -> m) -> Deque a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Pair Text
u Text
b) -> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b)

-- | What a worker returns: the status, and when it is OK the result's
-- unboxed word and boxed pointer. With status 'statusTailCall' the other
-- two are instead the code pointer of a function to call and the stack
-- pointer to call it with.
workerRet :: Text
workerRet :: Text
workerRet = Text
"{ i64, i64, ptr }"

-- | The status a worker returns to say "call this function for me, as a
-- tail call": its arguments are on the Unison stack above the worker's
-- frame base. A worker can't make the call itself, since the callee has
-- the uniform signature and a different return type; the wrapper at the
-- bottom makes it as a real tail call, and a worker that called this one
-- with a plain call makes it as a plain call.
statusTailCall :: Int
statusTailCall :: Int
statusTailCall = -Int
2

-- | Returns a status from the function being generated, in its own
-- return type.
retStatus :: FnEnv -> Text -> Gen ()
retStatus :: FnEnv -> Text -> Gen ()
retStatus FnEnv
fe Text
st
  | FnEnv -> Bool
feWorker FnEnv
fe = do
      Text
r <- Text -> Gen Text
fresh Text
"ret"
      Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = insertvalue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" undef, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
st Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
      Text -> Gen ()
emit (Text
"ret " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r)
  | Bool
otherwise = Text -> Gen ()
emit (Text
"ret i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
st)

-- | Returns a worker's three values.
retWorker :: Text -> Text -> Text -> Gen ()
retWorker :: Text -> Text -> Text -> Gen ()
retWorker Text
st Text
u Text
b = do
  Text
r0 <- Text -> Gen Text
fresh Text
"ret"
  Text -> Gen ()
emit (Text
r0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = insertvalue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" { i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
st Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 undef, ptr undef }, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
  Text
r1 <- Text -> Gen Text
fresh Text
"ret"
  Text -> Gen ()
emit (Text
r1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = insertvalue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 2")
  Text -> Gen ()
emit (Text
"ret " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r1)

-- | Raises the high-water mark of slots written to the boxed stack (for
-- marking its cards on return) to the given stack index.
markWritten :: Env -> Text -> Gen ()
markWritten :: Env -> Text -> Gen ()
markWritten Env
env Text
top = do
  Text
maxA <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oMaxSp
  Text
old <- Text -> Gen Text
fresh Text
"maxsp"
  Text -> Gen ()
emit (Text
old Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
maxA)
  Text
gt <- Text -> Gen Text
fresh Text
"maxsp.gt"
  Text -> Gen ()
emit (Text
gt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp sgt i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
top Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
old)
  Text
new <- Text -> Gen Text
fresh Text
"maxsp"
  Text -> Gen ()
emit (Text
new Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
top Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
old)
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
new Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
maxA)

-- | Whether the code builds anything in the heap itself.
allocates :: MSection -> Bool
allocates :: MSection -> Bool
allocates = (GInstr (RComb Val) -> Bool) -> MSection -> Bool
anyInstr ((GInstr (RComb Val) -> Bool) -> MSection -> Bool)
-> (GInstr (RComb Val) -> Bool) -> MSection -> Bool
forall a b. (a -> b) -> a -> b
$ \case
  Pack Reference
_ PackedTag
_ Args
ZArgs -> Bool
False
  Pack {} -> Bool
True
  RecPack {} -> Bool
True
  RecSet {} -> Bool
True
  Prim2 Prim2
REFW Int
_ Int
_ -> Bool
True
  ForeignCall Bool
_ ForeignFunc
MutableArray_write Args
_ -> Bool
True
  RefCAS {} -> Bool
True
  -- the list helpers allocate, and charge the budget themselves
  Prim1 Prim1
op Int
_ -> Prim1
op Prim1 -> [Prim1] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim1
VWLS, Prim1
VWRS, Prim1
FLTB, Prim1
UCNS, Prim1
USNC, Prim1
ITOT, Prim1
NTOT, Prim1
FTOT, Prim1
TTOI, Prim1
TTON, Prim1
TTOF, Prim1
PAKT, Prim1
UPKT, Prim1
PAKB, Prim1
UPKB, Prim1
REFN, Prim1
RRFC]
  Prim2 Prim2
op Int
_ Int
_ -> Prim2
op Prim2 -> [Prim2] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim2
CONS, Prim2
SNOC, Prim2
IDXS, Prim2
CATS, Prim2
TAKS, Prim2
DRPS, Prim2
SPLL, Prim2
SPLR, Prim2
CATT, Prim2
TAKT, Prim2
DRPT, Prim2
CATB, Prim2
TAKB, Prim2
DRPB, Prim2
IDXB, Prim2
IXOT, Prim2
IXOB]
  ForeignCall Bool
_ ForeignFunc
f Args
_ -> ForeignFunc
f ForeignFunc -> [ForeignFunc] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([ForeignFunc]
textForeign [ForeignFunc] -> [ForeignFunc] -> [ForeignFunc]
forall a. Semigroup a => a -> a -> a
<> [ForeignFunc]
bytesForeign) Bool -> Bool -> Bool
|| Maybe ArrayOp -> Bool
forall a. Maybe a -> Bool
isJust (ForeignFunc -> Maybe ArrayOp
arrayForeign ForeignFunc
f)
  Seq Args
_ -> Bool
True
  Name {} -> Bool
True
  GInstr (RComb Val)
_ -> Bool
False

-- | Whether the code makes a call that returns to it.
makesCalls :: MSection -> Bool
makesCalls :: MSection -> Bool
makesCalls = \case
  Let {} -> Bool
True
  Ins GInstr (RComb Val)
_ MSection
rest -> MSection -> Bool
makesCalls MSection
rest
  Match Int
_ GBranch (RComb Val)
br -> (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
makesCalls GBranch (RComb Val)
br
  DMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
br -> (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
makesCalls GBranch (RComb Val)
br
  NMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
br -> (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
makesCalls GBranch (RComb Val)
br
  MSection
_ -> Bool
False

-- | Whether the code makes a call in tail position (which on Windows may
-- use C stack, see 'workerTail').
makesTailCalls :: MSection -> Bool
makesTailCalls :: MSection -> Bool
makesTailCalls = \case
  Call {} -> Bool
True
  App {} -> Bool
True
  Let MSection
b CombIx
_ Int
_ MSection
body Ptr NativeCell
_ -> MSection -> Bool
makesTailCalls MSection
b Bool -> Bool -> Bool
|| MSection -> Bool
makesTailCalls MSection
body
  Ins GInstr (RComb Val)
_ MSection
rest -> MSection -> Bool
makesTailCalls MSection
rest
  Match Int
_ GBranch (RComb Val)
br -> (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
makesTailCalls GBranch (RComb Val)
br
  DMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
br -> (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
makesTailCalls GBranch (RComb Val)
br
  NMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
br -> (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
makesTailCalls GBranch (RComb Val)
br
  MSection
_ -> Bool
False

anyInstr :: (GInstr (RComb Val) -> Bool) -> MSection -> Bool
anyInstr :: (GInstr (RComb Val) -> Bool) -> MSection -> Bool
anyInstr GInstr (RComb Val) -> Bool
p = MSection -> Bool
go
  where
    go :: MSection -> Bool
go = \case
      Ins GInstr (RComb Val)
i MSection
rest -> GInstr (RComb Val) -> Bool
p GInstr (RComb Val)
i Bool -> Bool -> Bool
|| MSection -> Bool
go MSection
rest
      Let MSection
b CombIx
_ Int
_ MSection
body Ptr NativeCell
_ -> MSection -> Bool
go MSection
b Bool -> Bool -> Bool
|| MSection -> Bool
go MSection
body
      Match Int
_ GBranch (RComb Val)
br -> (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
go GBranch (RComb Val)
br
      DMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
br -> (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
go GBranch (RComb Val)
br
      NMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
br -> (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
go GBranch (RComb Val)
br
      MSection
_ -> Bool
False

anyArm :: (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm :: (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
p = \case
  Test1 Word64
_ (Arm Int
_ MSection
a) MSection
d -> MSection -> Bool
p MSection
a Bool -> Bool -> Bool
|| MSection -> Bool
p MSection
d
  Test2 Word64
_ (Arm Int
_ MSection
a) Word64
_ (Arm Int
_ MSection
b) MSection
d -> MSection -> Bool
p MSection
a Bool -> Bool -> Bool
|| MSection -> Bool
p MSection
b Bool -> Bool -> Bool
|| MSection -> Bool
p MSection
d
  TestW MSection
d EnumMap Word64 (Arm (RComb Val))
m -> MSection -> Bool
p MSection
d Bool -> Bool -> Bool
|| ((Word64, Arm (RComb Val)) -> Bool)
-> [(Word64, Arm (RComb Val))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (MSection -> Bool
p (MSection -> Bool)
-> ((Word64, Arm (RComb Val)) -> MSection)
-> (Word64, Arm (RComb Val))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arm (RComb Val) -> MSection
forall comb. Arm comb -> GSection comb
armSection (Arm (RComb Val) -> MSection)
-> ((Word64, Arm (RComb Val)) -> Arm (RComb Val))
-> (Word64, Arm (RComb Val))
-> MSection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64, Arm (RComb Val)) -> Arm (RComb Val)
forall a b. (a, b) -> b
snd) (EnumMap Word64 (Arm (RComb Val)) -> [(Word64, Arm (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (Arm (RComb Val))
m)
  TestT MSection
d Map Text MSection
m -> MSection -> Bool
p MSection
d Bool -> Bool -> Bool
|| (MSection -> Bool) -> [MSection] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any MSection -> Bool
p (Map Text MSection -> [MSection]
forall k a. Map k a -> [a]
Map.elems Map Text MSection
m)
  TestY MSection
d Map Bytes MSection
m -> MSection -> Bool
p MSection
d Bool -> Bool -> Bool
|| (MSection -> Bool) -> [MSection] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any MSection -> Bool
p (Map Bytes MSection -> [MSection]
forall k a. Map k a -> [a]
Map.elems Map Bytes MSection
m)

-- | Whether a combinator can have a worker: every return it makes itself
-- yields exactly one value. (Its tail calls return whatever their callees
-- do; a caller that expects one value from this function gets one.) This
-- is a first sieve: how many values a @Yield (VArgV i)@ returns depends on
-- the frame depth, which only generating the code finds out, and
-- generating a worker fails if it turns out not to be one.
workerShape :: MSection -> Bool
workerShape :: MSection -> Bool
workerShape = \case
  Yield Args
args -> case Args
args of
    VArg1 Int
_ -> Bool
True
    VArgV Int
_ -> Bool
True
    Args
_ -> Bool
False
  Ins GInstr (RComb Val)
_ MSection
rest -> MSection -> Bool
workerShape MSection
rest
  Match Int
_ GBranch (RComb Val)
br -> GBranch (RComb Val) -> Bool
branches GBranch (RComb Val)
br
  DMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
br -> GBranch (RComb Val) -> Bool
branches GBranch (RComb Val)
br
  NMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
br -> GBranch (RComb Val) -> Bool
branches GBranch (RComb Val)
br
  Let MSection
_ CombIx
_ Int
_ MSection
body Ptr NativeCell
_ -> MSection -> Bool
workerShape MSection
body
  -- calls, and whatever exits
  MSection
_ -> Bool
True
  where
    branches :: GBranch (RComb Val) -> Bool
branches = \case
      Test1 Word64
_ (Arm Int
_ MSection
a) MSection
d -> MSection -> Bool
workerShape MSection
a Bool -> Bool -> Bool
&& MSection -> Bool
workerShape MSection
d
      Test2 Word64
_ (Arm Int
_ MSection
a) Word64
_ (Arm Int
_ MSection
b) MSection
d -> MSection -> Bool
workerShape MSection
a Bool -> Bool -> Bool
&& MSection -> Bool
workerShape MSection
b Bool -> Bool -> Bool
&& MSection -> Bool
workerShape MSection
d
      TestW MSection
d EnumMap Word64 (Arm (RComb Val))
m -> MSection -> Bool
workerShape MSection
d Bool -> Bool -> Bool
&& ((Word64, Arm (RComb Val)) -> Bool)
-> [(Word64, Arm (RComb Val))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (MSection -> Bool
workerShape (MSection -> Bool)
-> ((Word64, Arm (RComb Val)) -> MSection)
-> (Word64, Arm (RComb Val))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arm (RComb Val) -> MSection
forall comb. Arm comb -> GSection comb
armSection (Arm (RComb Val) -> MSection)
-> ((Word64, Arm (RComb Val)) -> Arm (RComb Val))
-> (Word64, Arm (RComb Val))
-> MSection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64, Arm (RComb Val)) -> Arm (RComb Val)
forall a b. (a, b) -> b
snd) (EnumMap Word64 (Arm (RComb Val)) -> [(Word64, Arm (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (Arm (RComb Val))
m)
      TestT MSection
d Map Text MSection
m -> MSection -> Bool
workerShape MSection
d Bool -> Bool -> Bool
&& (MSection -> Bool) -> [MSection] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all MSection -> Bool
workerShape (Map Text MSection -> [MSection]
forall k a. Map k a -> [a]
Map.elems Map Text MSection
m)
      TestY MSection
d Map Bytes MSection
m -> MSection -> Bool
workerShape MSection
d Bool -> Bool -> Bool
&& (MSection -> Bool) -> [MSection] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all MSection -> Bool
workerShape (Map Bytes MSection -> [MSection]
forall k a. Map k a -> [a]
Map.elems Map Bytes MSection
m)

-- ---------------------------------------------------------------------------
-- Functions

-- | Compiles one combinator, or says why it can't be.
genFunction :: Env -> Text -> CombIx -> Int -> Int -> MSection -> Ptr NativeCell -> Either Text Function
genFunction :: Env
-> Text
-> CombIx
-> Int
-> Int
-> MSection
-> Ptr NativeCell
-> Either Text Function
genFunction Env
env Text
name CombIx
cix Int
arity Int
frameSize MSection
body Ptr NativeCell
cell =
  Env
-> Text
-> CombIx
-> Int
-> Int
-> Ptr NativeCell
-> Maybe Text
-> Int
-> Bool
-> MSection
-> Either Text Function
runFunction Env
env Text
name CombIx
cix Int
arity Int
frameSize Ptr NativeCell
cell (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"head") Int
0 (Ptr NativeCell -> Map (Ptr NativeCell) (Pair Text Int) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Ptr NativeCell
cell (Env -> Map (Ptr NativeCell) (Pair Text Int)
envWorkers Env
env)) MSection
body

-- | Generates a re-entry function that was left for later.
genDeferred :: Env -> Deferred -> Either Text Function
genDeferred :: Env -> Deferred -> Either Text Function
genDeferred Env
env Deferred
d = Env
-> Text
-> CombIx
-> Int
-> Int
-> Ptr NativeCell
-> Maybe Text
-> Int
-> Bool
-> MSection
-> Either Text Function
runFunction Env
env (Deferred -> Text
dName Deferred
d) (Deferred -> CombIx
dCix Deferred
d) (Deferred -> Int
dLoaded Deferred
d) (Deferred -> Int
dFrameSize Deferred
d) (Deferred -> Ptr NativeCell
dCell Deferred
d) Maybe Text
forall a. Maybe a
Nothing (Deferred -> Int
dBase Deferred
d) Bool
False (Deferred -> MSection
dBody Deferred
d)

runFunction :: Env -> Text -> CombIx -> Int -> Int -> Ptr NativeCell -> Maybe Text -> Int -> Bool -> MSection -> Either Text Function
runFunction :: Env
-> Text
-> CombIx
-> Int
-> Int
-> Ptr NativeCell
-> Maybe Text
-> Int
-> Bool
-> MSection
-> Either Text Function
runFunction Env
env Text
name CombIx
cix Int
arity Int
frameSize Ptr NativeCell
cell Maybe Text
headL Int
base Bool
worker MSection
body =
  let -- a worker whose callers call a fast entry is itself named apart
      fast :: Bool
fast = Bool
worker Bool -> Bool -> Bool
&& MSection -> Bool
freePath MSection
body
      sym :: Text
sym
        | Bool
fast = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_wf"
        | Bool
worker = Text -> Text
workerName Text
name
        | Bool
otherwise = Text
name
      fe :: FnEnv
fe = Env
-> Text
-> CombIx
-> Int
-> Int
-> Ptr NativeCell
-> Maybe Text
-> Int
-> Text
-> Text
-> Text
-> Text
-> Deque Enclosing
-> Bool
-> Maybe Text
-> Text
-> Bool
-> Maybe Local
-> FnEnv
FnEnv Env
env Text
name CombIx
cix Int
arity Int
frameSize Ptr NativeCell
cell Maybe Text
headL Int
base Text
"%tag.char" Text
"%tag.float" Text
"%tag.int" Text
"%tag.nat" Deque Enclosing
forall a. Deque a
D.empty Bool
worker Maybe Text
forall a. Maybe a
Nothing Text
sym (Env -> Bool
envInternal Env
env) Maybe Local
forall a. Maybe a
Nothing
      gs0 :: GS
gs0 = Int -> Cells -> AuxMemo -> Bool -> GS
initialState Int
arity (Env -> Cells
envCells Env
env) (Env -> AuxMemo
envKnown Env
env) Bool
worker
      -- a worker comes with the function the cell points to, the wrapper,
      -- and maybe with a fast entry
      !(Pair Text
text Deque Text
extra, GS
gs) = (StateT GS Identity (Pair Text (Deque Text))
 -> GS -> (Pair Text (Deque Text), GS))
-> GS
-> StateT GS Identity (Pair Text (Deque Text))
-> (Pair Text (Deque Text), GS)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT GS Identity (Pair Text (Deque Text))
-> GS -> (Pair Text (Deque Text), GS)
forall s a. State s a -> s -> (a, s)
runState GS
gs0 (StateT GS Identity (Pair Text (Deque Text))
 -> (Pair Text (Deque Text), GS))
-> StateT GS Identity (Pair Text (Deque Text))
-> (Pair Text (Deque Text), GS)
forall a b. (a -> b) -> a -> b
$ do
        Text
t <- FnEnv -> MSection -> Gen Text
genFunctionText FnEnv
fe MSection
body
        Deque Text
f <- if Bool
fast then Text -> Deque Text
forall a. a -> Deque a
D.singleton (Text -> Deque Text) -> Gen Text -> StateT GS Identity (Deque Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FnEnv -> MSection -> Gen Text
genFastEntry FnEnv
fe {feFast = Just sym, feSym = workerName name, feHead = Nothing} MSection
body else Deque Text -> StateT GS Identity (Deque Text)
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Deque Text
forall a. Deque a
D.empty
        Deque Text
w <- if Bool
worker then Text -> Deque Text
forall a. a -> Deque a
D.singleton (Text -> Deque Text) -> Gen Text -> StateT GS Identity (Deque Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FnEnv -> MSection -> Gen Text
genWrapper FnEnv
fe MSection
body else Deque Text -> StateT GS Identity (Deque Text)
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Deque Text
forall a. Deque a
D.empty
        pure (Text -> Deque Text -> Pair Text (Deque Text)
forall a b. a -> b -> Pair a b
Pair Text
t (Deque Text
f Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> Deque Text
w))
   in case GS -> Maybe Text
gsFailed GS
gs of
        Maybe Text
_ | GS -> Bool
gsNotWorker GS
gs -> Text -> Either Text Function
forall a b. a -> Either a b
Left Text
"a worker would return other than one value"
        Just Text
why -> Text -> Either Text Function
forall a b. a -> Either a b
Left Text
why
        Maybe Text
Nothing ->
          Function -> Either Text Function
forall a b. b -> Either a b
Right (Function -> Either Text Function)
-> Function -> Either Text Function
forall a b. (a -> b) -> a -> b
$!
            Text
-> Text
-> Deque Exit
-> Deque Frame
-> Ptr NativeCell
-> Deque (Pair Text (Ptr NativeCell))
-> Deque Deferred
-> AuxMemo
-> Deque Text
-> Function
Function
              Text
name
              (Deque Text -> Text
unlinesT (Text
text Text -> Deque Text -> Deque Text
forall a. a -> Deque a -> Deque a
<| (Deque Text
extra Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> GS -> Deque Text
gsAuxText GS
gs)))
              (GS -> Deque Exit
gsExits GS
gs)
              (GS -> Deque Frame
gsFrames GS
gs)
              Ptr NativeCell
cell
              (GS -> Deque (Pair Text (Ptr NativeCell))
gsAuxCells GS
gs)
              (GS -> Deque Deferred
gsDeferred GS
gs)
              (GS -> AuxMemo
gsAuxMemo GS
gs)
              (GS -> Deque Text
gsNotes GS
gs)

-- | The text of one LLVM function for @body@, generated in the current
-- state (which must hold no blocks yet). Its exits and frames join the
-- state's lists.
genFunctionText :: FnEnv -> MSection -> Gen Text
genFunctionText :: FnEnv -> MSection -> Gen Text
genFunctionText FnEnv
fe MSection
body = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      arity :: Int
arity = FnEnv -> Int
feArity FnEnv
fe
  Int
growIx <- (GS -> Int) -> StateT GS Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> Int
gsNExits
  case FnEnv -> Maybe Text
feFast FnEnv
fe of
    Maybe Text
Nothing -> FnEnv -> MSection -> Gen ()
genHead FnEnv
fe MSection
body
    Just Text
_ -> FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe Int
arity MSection
body
  Text -> Gen ()
startBlock Text
"unreachable"
  Gen ()
flushShared
  GS
gs <- StateT GS Identity GS
forall s (m :: * -> *). MonadState s m => m s
get
  let block :: Pair a (Deque a) -> Deque a
block (Pair a
l Deque a
is)
        | a
l a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"unreachable" = Deque a
forall a. Deque a
D.empty
        | Bool
otherwise = (a
l a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
":") a -> Deque a -> Deque a
forall a. a -> Deque a -> Deque a
<| (a -> a) -> Deque a -> Deque a
forall a b. (a -> b) -> Deque a -> Deque b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
"  " a -> a -> a
forall a. Semigroup a => a -> a -> a
<>) Deque a
is
      maxK :: Int
maxK = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (GS -> Int
gsMaxK GS
gs) (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ FnEnv -> Int
feFrameSize FnEnv
fe)
      entry :: Deque Text
entry = Env
-> Bool -> Bool -> Int -> Int -> Int -> Int -> Int -> Deque Text
entryBlock Env
env (FnEnv -> Bool
feWorker FnEnv
fe) (FnEnv -> Maybe Text
feFast FnEnv
fe Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing) Int
arity (FnEnv -> Int
feBase FnEnv
fe) Int
maxK (GS -> Int
gsMaxPool GS
gs) (GS -> Int
gsMaxExitArgs GS
gs)
      -- the grow exit, the first this function added, asks for what the
      -- entry check demanded
      fixGrow :: Exit -> Exit
fixGrow Exit
e
        | GrowStack Int
_ Ptr NativeCell
c <- Exit
e = Int -> Ptr NativeCell -> Exit
GrowStack (Int
maxK Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
arity) Ptr NativeCell
c
        | Bool
otherwise = Exit
e
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((GS -> GS) -> Gen ()) -> (GS -> GS) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \GS
s -> case Int -> Deque Exit -> (Deque Exit, Deque Exit)
forall a. Int -> Deque a -> (Deque a, Deque a)
D.splitAt Int
growIx (GS -> Deque Exit
gsExits GS
s) of
    (Deque Exit
before, Exit
e :<| Deque Exit
after) -> GS
s {gsExits = (before |> fixGrow e) >< after}
    (Deque Exit, Deque Exit)
_ -> GS
s
  let header :: Text
header
        | FnEnv -> Bool
feWorker FnEnv
fe =
            Text
"define internal "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerCC
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" @"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feSym FnEnv
fe
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(ptr %ctx, i64 %fp.in"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Int -> Text) -> [Int] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Int
k -> Text
", i64 %a.u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr %a.b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k) [Int
1 .. Int
arity]
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") {"
        | Bool
otherwise = Text
"define " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if FnEnv -> Bool
feInternal FnEnv
fe then Text
"internal " else Text
"") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"i64 @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feSym FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(ptr %ctx, i64 %ap, i64 %fp.in, i64 %sp) {"
  Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Gen Text)
-> (Deque Text -> Text) -> Deque Text -> Gen Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deque Text -> Text
unlinesT (Deque Text -> Gen Text) -> Deque Text -> Gen Text
forall a b. (a -> b) -> a -> b
$
    GS -> Deque Text
gsDescText GS
gs Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> (Text
header Text -> Deque Text -> Deque Text
forall a. a -> Deque a -> Deque a
<| Deque Text
entry) Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> (Pair Text (Deque Text) -> Deque Text)
-> Deque (Pair Text (Deque Text)) -> Deque Text
forall m a. Monoid m => (a -> m) -> Deque a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pair Text (Deque Text) -> Deque Text
block (GS -> Deque (Pair Text (Deque Text))
gsBlocks GS
gs) Deque Text -> Text -> Deque Text
forall a. Deque a -> a -> Deque a
|> Text
"}"

-- | Generates a worker's fast entry (see 'feFast') as a function of its
-- own. Its exits (there are none that can be taken) join the function's.
genFastEntry :: FnEnv -> MSection -> Gen Text
genFastEntry :: FnEnv -> MSection -> Gen Text
genFastEntry FnEnv
fe MSection
body = do
  GS
s <- StateT GS Identity GS
forall s (m :: * -> *). MonadState s m => m s
get
  let gs0 :: GS
gs0 = GS
s {gsFresh = 0, gsBlocks = D.empty, gsCur = Pair "head" D.empty, gsMaxK = feArity fe, gsKinds = IM.empty, gsCaptured = Nothing, gsMaxPool = -1, gsMaxExitArgs = 0, gsShared = Map.empty, gsDescs = Map.empty, gsDescText = D.empty}
      !(Text
text, GS
gs) = Gen Text -> GS -> (Text, GS)
forall s a. State s a -> s -> (a, s)
runState (FnEnv -> MSection -> Gen Text
genFunctionText FnEnv
fe MSection
body) GS
gs0
  GS -> Gen ()
put
    GS
s
      { gsExits = gsExits gs,
        gsNExits = gsNExits gs,
        gsFrames = gsFrames gs,
        gsNFrames = gsNFrames gs,
        gsNotes = gsNotes gs,
        gsFailed = maybe (gsFailed gs) Just (gsFailed s),
        gsNotWorker = gsNotWorker s || gsNotWorker gs
      }
  pure Text
text

-- | Whether some path through the code returns without needing anything
-- checked: only instructions that can't exit, branches on words, and a
-- return. (Statically a match on a data value counts; whether it really
-- is a match on a boolean still in a register is known when the code is
-- generated, see 'checkFree'.)
freePath :: MSection -> Bool
freePath :: MSection -> Bool
freePath = \case
  Yield Args
_ -> Bool
True
  Ins GInstr (RComb Val)
i MSection
rest -> GInstr (RComb Val) -> Bool
exitFree GInstr (RComb Val)
i Bool -> Bool -> Bool
&& MSection -> Bool
freePath MSection
rest
  Match Int
_ GBranch (RComb Val)
br -> GBranch (RComb Val) -> Bool
plainBranch GBranch (RComb Val)
br Bool -> Bool -> Bool
&& (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
freePath GBranch (RComb Val)
br
  NMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
br -> GBranch (RComb Val) -> Bool
plainBranch GBranch (RComb Val)
br Bool -> Bool -> Bool
&& (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
freePath GBranch (RComb Val)
br
  DMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
br -> GBranch (RComb Val) -> Bool
plainBranch GBranch (RComb Val)
br Bool -> Bool -> Bool
&& (MSection -> Bool) -> GBranch (RComb Val) -> Bool
anyArm MSection -> Bool
freePath GBranch (RComb Val)
br
  MSection
_ -> Bool
False

-- | Instructions whose native code has no exit.
exitFree :: GInstr (RComb Val) -> Bool
exitFree :: GInstr (RComb Val) -> Bool
exitFree = \case
  Lit MLit
l -> MLit -> Bool
litSupported MLit
l
  Prim1 Prim1
op Int
_ -> Prim1
op Prim1 -> [Prim1] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim1
DECI, Prim1
DECN, Prim1
INCI, Prim1
INCN, Prim1
NEGI, Prim1
COMN, Prim1
COMI, Prim1
TRNC, Prim1
SGNI, Prim1
LZRO, Prim1
TZRO, Prim1
POPC]
  Prim2 Prim2
op Int
_ Int
_ ->
    Prim2
op
      Prim2 -> [Prim2] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Prim2
ADDI,
               Prim2
SUBI,
               Prim2
MULI,
               Prim2
EQLI,
               Prim2
NEQI,
               Prim2
LEQI,
               Prim2
LESI,
               Prim2
ANDI,
               Prim2
IORI,
               Prim2
XORI,
               Prim2
ADDN,
               Prim2
SUBN,
               Prim2
MULN,
               Prim2
EQLN,
               Prim2
NEQN,
               Prim2
LEQN,
               Prim2
LESN,
               Prim2
ANDN,
               Prim2
IORN,
               Prim2
XORN,
               Prim2
DRPN
             ]
  GInstr (RComb Val)
_ -> Bool
False

plainBranch :: GBranch (RComb Val) -> Bool
plainBranch :: GBranch (RComb Val) -> Bool
plainBranch = \case
  Test1 {} -> Bool
True
  Test2 {} -> Bool
True
  TestW {} -> Bool
True
  GBranch (RComb Val)
_ -> Bool
False

-- | Whether the code for this node, at this depth, can run before the
-- function's entry checks (see 'feFast').
checkFree :: Int -> MSection -> Gen Bool
checkFree :: Int -> MSection -> StateT GS Identity Bool
checkFree Int
d = \case
  Yield Args
_ -> Bool -> StateT GS Identity Bool
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Ins GInstr (RComb Val)
i MSection
_ -> Bool -> StateT GS Identity Bool
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GInstr (RComb Val) -> Bool
exitFree GInstr (RComb Val)
i)
  Match Int
_ GBranch (RComb Val)
br -> Bool -> StateT GS Identity Bool
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GBranch (RComb Val) -> Bool
plainBranch GBranch (RComb Val)
br)
  NMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
br -> Bool -> StateT GS Identity Bool
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GBranch (RComb Val) -> Bool
plainBranch GBranch (RComb Val)
br)
  -- a boolean still in a register: one branch, no closure to look at
  DMatch Maybe Reference
_ Int
i GBranch (RComb Val)
br -> do
    Maybe Text
kind <- Int -> Gen (Maybe Text)
slotKind (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    pure (Maybe Text
kind Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& GBranch (RComb Val) -> Bool
plainBranch GBranch (RComb Val)
br)
  MSection
_ -> Bool -> StateT GS Identity Bool
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | The symbol of a function's worker.
workerName :: Text -> Text
workerName :: Text -> Text
workerName Text
name = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_w"

-- | The function a worker's cell points to. It has the uniform signature:
-- it loads the arguments from the Unison stack, calls the worker, and on
-- OK stores the result and the stack pointers as a @Yield@ does. If the
-- worker asks for a tail call it makes it; any other status is an exit
-- the worker has already prepared, and is passed on.
--
-- Pending arguments (an over-application: @ap@ differs from @fp@) are the
-- interpreter's business when the function returns, so the wrapper hands
-- such a call to the interpreter straight away, and workers never see one.
genWrapper :: FnEnv -> MSection -> Gen Text
genWrapper :: FnEnv -> MSection -> Gen Text
genWrapper FnEnv
fe MSection
body = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      name :: Text
name = FnEnv -> Text
feName FnEnv
fe
      arity :: Int
arity = FnEnv -> Int
feArity FnEnv
fe
      field :: Text -> (CtxOffsets -> Int) -> Text
field Text
reg CtxOffsets -> Int
f = Text
reg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i8, ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (CtxOffsets -> Int
f (Env -> CtxOffsets
envCtx Env
env))
      indent :: Deque Text -> Deque Text
indent = (Text -> Text) -> Deque Text -> Deque Text
forall a b. (a -> b) -> Deque a -> Deque b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
      lines :: [a] -> Deque a
lines = [a] -> Deque a
forall a. [a] -> Deque a
D.fromList
  -- the exit for pending arguments: the interpreter resumes at the top
  Int
pendingIx <- Env -> Exit -> StateT GS Identity Int
addExit Env
env (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
body)
  Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Gen Text)
-> (Deque Text -> Text) -> Deque Text -> Gen Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deque Text -> Text
unlinesT (Deque Text -> Gen Text) -> Deque Text -> Gen Text
forall a b. (a -> b) -> a -> b
$
    [Text] -> Deque Text
forall a. [a] -> Deque a
lines
      [ Text
"define " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if FnEnv -> Bool
feInternal FnEnv
fe then Text
"internal " else Text
"") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"i64 @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(ptr %ctx, i64 %ap, i64 %fp.in, i64 %sp) {",
        Text
"  %pending = icmp ne i64 %ap, %fp.in",
        Text
"  br i1 %pending, label %pending.exit, label %enter" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely,
        Text
"enter:"
      ]
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> Deque Text -> Deque Text
indent
        ( [Text] -> Deque Text
forall a. [a] -> Deque a
lines
            [ Text -> (CtxOffsets -> Int) -> Text
field Text
"%ustk.a" CtxOffsets -> Int
oUstk,
              Text
"%ustk = load ptr, ptr %ustk.a",
              Text -> (CtxOffsets -> Int) -> Text
field Text
"%bstk.a" CtxOffsets -> Int
oBstk,
              Text
"%bstk = load ptr, ptr %bstk.a"
            ]
            Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> (Int -> Deque Text) -> [Int] -> Deque Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
              ( \Int
k' ->
                  let k :: Text
k = Int -> Text
forall a. Show a => a -> Text
tshow Int
k'
                   in [Text] -> Deque Text
forall a. [a] -> Deque a
lines
                        [ Text
"%ix" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 %fp.in, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k,
                          Text
"%u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a = getelementptr i64, ptr %ustk, i64 %ix" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k,
                          Text
"%u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr %u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a",
                          Text
"%b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a = getelementptr ptr, ptr %bstk, i64 %ix" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k,
                          Text
"%b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr %b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a"
                        ]
              )
              [Int
1 .. Int
arity]
            Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Deque Text
forall a. [a] -> Deque a
lines
              [ Text
"%r = call "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerCC
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" @"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
workerName Text
name
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(ptr %ctx, i64 %fp.in"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Int -> Text) -> [Int] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Int
k -> Text
", i64 %u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr %b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k) [Int
1 .. Int
arity]
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")",
                Text
"%st = extractvalue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" %r, 0",
                Text
"%r.u = extractvalue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" %r, 1",
                Text
"%r.b = extractvalue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" %r, 2",
                Text
"switch i64 %st, label %exit [ i64 0, label %ok  i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
statusTailCall Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %tail ]"
              ]
        )
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Deque Text
forall a. [a] -> Deque a
lines [Text
"ok:"]
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> Deque Text -> Deque Text
indent
        ( [Text] -> Deque Text
forall a. [a] -> Deque a
lines
            [ -- the worker may have run native code that moved nothing, but
              -- the stacks' addresses are the same for the whole native run
              Text
"%res = add i64 %fp.in, 1",
              Text
"%res.u = getelementptr i64, ptr %ustk, i64 %res",
              Text
"store i64 %r.u, ptr %res.u",
              Text
"%res.b = getelementptr ptr, ptr %bstk, i64 %res",
              Text
"store ptr %r.b, ptr %res.b",
              Text -> (CtxOffsets -> Int) -> Text
field Text
"%ap.a" CtxOffsets -> Int
oAp,
              Text
"store i64 %ap, ptr %ap.a",
              Text -> (CtxOffsets -> Int) -> Text
field Text
"%fp.a" CtxOffsets -> Int
oFp,
              Text
"store i64 %ap, ptr %fp.a",
              Text -> (CtxOffsets -> Int) -> Text
field Text
"%sp.a" CtxOffsets -> Int
oSp,
              Text
"store i64 %res, ptr %sp.a",
              Text -> (CtxOffsets -> Int) -> Text
field Text
"%maxsp.a" CtxOffsets -> Int
oMaxSp,
              Text
"%maxsp.old = load i64, ptr %maxsp.a",
              Text
"%maxsp.gt = icmp sgt i64 %res, %maxsp.old",
              Text
"%maxsp.new = select i1 %maxsp.gt, i64 %res, i64 %maxsp.old",
              Text
"store i64 %maxsp.new, ptr %maxsp.a",
              Text
"ret i64 0"
            ]
        )
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Deque Text
forall a. [a] -> Deque a
lines [Text
"tail:"]
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> Deque Text -> Deque Text
indent
        ( [Text] -> Deque Text
forall a. [a] -> Deque a
lines
            [ Text
"%fn = inttoptr i64 %r.u to ptr",
              Text
"%top = ptrtoint ptr %r.b to i64",
              Text
"%t = musttail call i64 %fn(ptr %ctx, i64 %ap, i64 %fp.in, i64 %top)",
              Text
"ret i64 %t"
            ]
        )
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Deque Text
forall a. [a] -> Deque a
lines [Text
"exit:", Text
"  ret i64 %st"]
      -- the frame is as the caller left it: only the stack pointers go back
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Deque Text
forall a. [a] -> Deque a
lines [Text
"pending.exit:"]
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> Deque Text -> Deque Text
indent
        ( [Text] -> Deque Text
forall a. [a] -> Deque a
lines
            [ Text -> (CtxOffsets -> Int) -> Text
field Text
"%p.ap.a" CtxOffsets -> Int
oAp,
              Text
"store i64 %ap, ptr %p.ap.a",
              Text -> (CtxOffsets -> Int) -> Text
field Text
"%p.fp.a" CtxOffsets -> Int
oFp,
              Text
"store i64 %fp.in, ptr %p.fp.a",
              Text -> (CtxOffsets -> Int) -> Text
field Text
"%p.sp.a" CtxOffsets -> Int
oSp,
              Text
"store i64 %sp, ptr %p.sp.a",
              Text
"ret i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
pendingIx
            ]
        )
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Deque Text
forall a. [a] -> Deque a
lines [Text
"}"]

-- | Generates an auxiliary function in this module: the code for @body@
-- starting at depth @loaded@ (that many slots are on the stack), entered
-- by the interpreter with its frame pointer at frame offset @base@. Gives
-- its name and cell, or Nothing if it can't be compiled or there are no
-- cells left. Its exits and frames join this module's tables.
--
-- When @later@ is set and the module is generated lazily, the function
-- only gets its name and cell, and a 'Deferred' to generate it from when
-- the interpreter has found the cell empty often enough.
genAuxFunction :: Bool -> FnEnv -> Int -> Int -> MSection -> Gen (Maybe (Pair Text (Ptr NativeCell)))
genAuxFunction :: Bool
-> FnEnv
-> Int
-> Int
-> MSection
-> Gen (Maybe (Pair Text (Ptr NativeCell)))
genAuxFunction Bool
later FnEnv
fe Int
loaded Int
base MSection
body = do
  GS
s <- StateT GS Identity GS
forall s (m :: * -> *). MonadState s m => m s
get
  let key :: (GSection (), Int, Int)
key = (MSection -> GSection ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void MSection
body, Int
loaded, Int
base)
  case ((GSection (), Int, Int)
-> AuxMemo -> Maybe (Pair Text (Ptr NativeCell))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (GSection (), Int, Int)
key (GS -> AuxMemo
gsAuxMemo GS
s), Cells -> Maybe (Pair (Ptr NativeCell) Cells)
takeCell (GS -> Cells
gsCells GS
s)) of
    (Just Pair Text (Ptr NativeCell)
known, Maybe (Pair (Ptr NativeCell) Cells)
_) -> Maybe (Pair Text (Ptr NativeCell))
-> Gen (Maybe (Pair Text (Ptr NativeCell)))
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pair Text (Ptr NativeCell) -> Maybe (Pair Text (Ptr NativeCell))
forall a. a -> Maybe a
Just Pair Text (Ptr NativeCell)
known)
    (Maybe (Pair Text (Ptr NativeCell))
_, Maybe (Pair (Ptr NativeCell) Cells)
Nothing) -> Maybe (Pair Text (Ptr NativeCell))
-> Gen (Maybe (Pair Text (Ptr NativeCell)))
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Pair Text (Ptr NativeCell))
forall a. Maybe a
Nothing
    (Maybe (Pair Text (Ptr NativeCell))
_, Just (Pair Ptr NativeCell
cell Cells
cells))
      | Bool
later Bool -> Bool -> Bool
&& Env -> Bool
envLazy (FnEnv -> Env
feEnv FnEnv
fe) -> do
          let name :: Text
name = FnEnv -> Text
feName FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_r" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (GS -> Int
gsNAux GS
s)
              known :: Pair Text (Ptr NativeCell)
known = Text -> Ptr NativeCell -> Pair Text (Ptr NativeCell)
forall a b. a -> b -> Pair a b
Pair Text
name Ptr NativeCell
cell
          GS -> Gen ()
put
            GS
s
              { gsCells = cells,
                gsNAux = gsNAux s + 1,
                gsDeferred = gsDeferred s |> Deferred name (feCix fe) loaded (feFrameSize fe) base body cell,
                gsAuxMemo = Map.insert key known (gsAuxMemo s)
              }
          pure (Pair Text (Ptr NativeCell) -> Maybe (Pair Text (Ptr NativeCell))
forall a. a -> Maybe a
Just Pair Text (Ptr NativeCell)
known)
    (Maybe (Pair Text (Ptr NativeCell))
_, Just (Pair Ptr NativeCell
cell Cells
cells)) -> do
      let name :: Text
name = FnEnv -> Text
feName FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_r" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (GS -> Int
gsNAux GS
s)
          known :: Pair Text (Ptr NativeCell)
known = Text -> Ptr NativeCell -> Pair Text (Ptr NativeCell)
forall a b. a -> b -> Pair a b
Pair Text
name Ptr NativeCell
cell
          -- (an environment switch in force at the exit this re-enters after has become a Local frame in K)
          fe' :: FnEnv
fe' = FnEnv
fe {feName = name, feArity = loaded, feCell = cell, feHead = Nothing, feBase = base, feEnclosing = D.empty, feWorker = False, feFast = Nothing, feSym = name, feInternal = False, feLocal = Nothing}
          gs0 :: GS
gs0 = GS
s {gsFresh = 0, gsBlocks = D.empty, gsCur = Pair "head" D.empty, gsMaxK = loaded, gsKinds = IM.empty, gsFailed = Nothing, gsCells = cells, gsNAux = gsNAux s + 1, gsCaptured = Nothing, gsMaxPool = -1, gsMaxExitArgs = 0, gsWorker = False, gsShared = Map.empty, gsDescs = Map.empty, gsDescText = D.empty}
          !(Text
text, GS
gs) = Gen Text -> GS -> (Text, GS)
forall s a. State s a -> s -> (a, s)
runState (FnEnv -> MSection -> Gen Text
genFunctionText FnEnv
fe' MSection
body) GS
gs0
      case GS -> Maybe Text
gsFailed GS
gs of
        Just Text
why -> GS -> Gen ()
put GS
s {gsNotes = gsNotes gs |> (name <> ": " <> why)} Gen ()
-> Gen (Maybe (Pair Text (Ptr NativeCell)))
-> Gen (Maybe (Pair Text (Ptr NativeCell)))
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Pair Text (Ptr NativeCell))
-> Gen (Maybe (Pair Text (Ptr NativeCell)))
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Pair Text (Ptr NativeCell))
forall a. Maybe a
Nothing
        Maybe Text
Nothing -> do
          GS -> Gen ()
put
            GS
s
              { gsNotes = gsNotes gs,
                gsExits = gsExits gs,
                gsNExits = gsNExits gs,
                gsFrames = gsFrames gs,
                gsNFrames = gsNFrames gs,
                gsAuxText = gsAuxText gs |> text,
                gsAuxCells = gsAuxCells gs |> known,
                gsNAux = gsNAux gs,
                gsCells = gsCells gs,
                gsDeferred = gsDeferred gs,
                gsAuxMemo = Map.insert key known (gsAuxMemo gs)
              }
          pure (Pair Text (Ptr NativeCell) -> Maybe (Pair Text (Ptr NativeCell))
forall a. a -> Maybe a
Just Pair Text (Ptr NativeCell)
known)

-- | Whether a @Let@ binding is generated inline: its first node must be
-- one the generator has code for. A binding that would exit straight away
-- is better left to the interpreter along with its @Let@, which saves the
-- binding's frame record. (Whether a whole function is worth compiling is
-- decided before this, in JIT.Estimate.)
startsSupported :: Switches -> MSection -> Bool
startsSupported :: Switches -> MSection -> Bool
startsSupported Switches
sw = \case
  Ins GInstr (RComb Val)
i MSection
rest -> Switches -> GInstr (RComb Val) -> MSection -> Bool
instrNativeIn Switches
sw GInstr (RComb Val)
i MSection
rest Bool -> Bool -> Bool
|| GInstr (RComb Val) -> MSection -> Bool
callOutWorthwhile GInstr (RComb Val)
i MSection
rest
  Match {} -> Bool
True
  DMatch {} -> Bool
True
  NMatch {} -> Bool
True
  RMatch {} -> Switches -> Bool
swRequests Switches
sw
  Call {} -> Bool
True
  App Bool
_ (MCode.Env CombIx
_ RComb Val
_) Args
_ -> Bool
True
  App Bool
_ (Stk Int
_) Args
_ -> Bool
True
  App Bool
_ (Dyn Word64
_) Args
_ -> Switches -> Bool
swRequests Switches
sw
  Yield {} -> Bool
True
  Let MSection
b CombIx
_ Int
_ MSection
_ Ptr NativeCell
_ -> Switches -> MSection -> Bool
startsSupported Switches
sw MSection
b
  MSection
_ -> Bool
False

-- | Whether an instruction the generator can't compile can be a call-out
-- with native code after it.
callOutWorthwhile :: GInstr (RComb Val) -> MSection -> Bool
callOutWorthwhile :: GInstr (RComb Val) -> MSection -> Bool
callOutWorthwhile GInstr (RComb Val)
i MSection
rest = case (GInstr (RComb Val) -> Maybe Int
forall comb. GInstr comb -> Maybe Int
pushCount GInstr (RComb Val)
i, MSection
rest) of
  (Just Int
_, Yield (VArgV Int
_)) -> Bool
False
  (Just Int
_, MSection
_) -> Bool
True
  (Maybe Int, MSection)
_ -> Bool
False

-- | The entry block: allocas, addresses from @Ctx@, argument loads, the
-- stack check, then a branch to the loop head. @maxK@ is the highest
-- frame offset the function touches, which is at least the frame size and
-- covers the arguments of every call it makes.
entryBlock :: Env -> Bool -> Bool -> Int -> Int -> Int -> Int -> Int -> Deque Text
entryBlock :: Env
-> Bool -> Bool -> Int -> Int -> Int -> Int -> Int -> Deque Text
entryBlock Env
env Bool
worker Bool
checks Int
arity Int
base Int
maxK Int
maxPool Int
maxExitArgs =
  (Text -> Text) -> Deque Text -> Deque Text
forall a b. (a -> b) -> Deque a -> Deque b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Deque Text -> Deque Text) -> Deque Text -> Deque Text
forall a b. (a -> b) -> a -> b
$
    -- %fp is the combinator's frame pointer, %fpb the interpreter's (the
    -- one passed in); they differ by the frame base
    [Text] -> Deque Text
forall a. [a] -> Deque a
lines
      [ Text
"%fp = sub i64 %fp.in, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
base,
        Text
"%fpb = add i64 %fp, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
base
      ]
      -- A worker isn't passed the stack pointer: its arguments, were they
      -- on the stack, would end there. Nor is it passed @ap@: a worker
      -- never has pending arguments (its wrapper sees to that, and native
      -- callers don't pass any), so @ap@ is the frame pointer.
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> (if Bool
worker then [Text] -> Deque Text
forall a. [a] -> Deque a
lines [Text
"%sp = add i64 %fp.in, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
arity, Text
"%ap = add i64 %fp.in, 0"] else Deque Text
forall a. Deque a
D.empty)
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> [Int] -> (Int -> Deque Text) -> Deque Text
forall {m}. Monoid m => [Int] -> (Int -> m) -> m
each [Int
1 .. Int
maxK] (\Int
k -> [Text] -> Deque Text
forall a. [a] -> Deque a
lines [Text
"%u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = alloca i64"])
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> [Int] -> (Int -> Deque Text) -> Deque Text
forall {m}. Monoid m => [Int] -> (Int -> m) -> m
each [Int
1 .. Int
maxK] (\Int
k -> [Text] -> Deque Text
forall a. [a] -> Deque a
lines [Text
"%b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = alloca ptr"])
      -- the argument block of the write-back calls ('joinCall'), sized for
      -- the site that passes the most; absent only when there is no such
      -- call (every call claims at least one word)
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> (if Int
maxExitArgs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then [Text] -> Deque Text
forall a. [a] -> Deque a
lines [Text
"%xargs = alloca [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
maxExitArgs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" x i64]"] else Deque Text
forall a. Deque a
D.empty)
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> [Int] -> (Int -> Deque Text) -> Deque Text
forall {m}. Monoid m => [Int] -> (Int -> m) -> m
each [Int
0 .. Int
maxK] (\Int
k -> [Text] -> Deque Text
forall a. [a] -> Deque a
lines [Text
"%fpk" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 %fp, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
k])
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Deque Text
forall a. [a] -> Deque a
lines
        [ (if Bool
worker then Text -> (CtxOffsets -> Int) -> Text
ctxAddr else Text -> Text -> (CtxOffsets -> Int) -> Text
ctxLoad Text
"ptr") Text
"%ustk" CtxOffsets -> Int
oUstk,
          (if Bool
worker then Text -> (CtxOffsets -> Int) -> Text
ctxAddr else Text -> Text -> (CtxOffsets -> Int) -> Text
ctxLoad Text
"ptr") Text
"%bstk" CtxOffsets -> Int
oBstk,
          Text -> Text -> (CtxOffsets -> Int) -> Text
ctxLoad Text
"ptr" Text
"%pool" CtxOffsets -> Int
oPool,
          Text -> Text -> (CtxOffsets -> Int) -> Text
ctxLoad Text
"ptr" Text
"%hplim.p" CtxOffsets -> Int
oHplim,
          Text -> Text -> (CtxOffsets -> Int) -> Text
ctxLoad Text
"i64" Text
"%stack.size" CtxOffsets -> Int
oStackSize
        ]
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> Deque Text
forall {a}. Show a => Text -> a -> Deque Text
poolLoad Text
"%tag.char" Int
poolIndexCharTag
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> Deque Text
forall {a}. Show a => Text -> a -> Deque Text
poolLoad Text
"%tag.float" Int
poolIndexFloatTag
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> Deque Text
forall {a}. Show a => Text -> a -> Deque Text
poolLoad Text
"%tag.int" Int
poolIndexIntTag
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> Text -> Int -> Deque Text
forall {a}. Show a => Text -> a -> Deque Text
poolLoad Text
"%tag.nat" Int
poolIndexNatTag
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> [Int] -> (Int -> Deque Text) -> Deque Text
forall {m}. Monoid m => [Int] -> (Int -> m) -> m
each
        [Int
1 .. Int
arity]
        ( \Int
k' ->
            let k :: Text
k = Int -> Text
forall a. Show a => a -> Text
tshow Int
k'
             in if Bool
worker
                  then
                    [Text] -> Deque Text
forall a. [a] -> Deque a
lines
                      [ Text
"store i64 %a.u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr %u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k,
                        Text
"store ptr %a.b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr %b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k
                      ]
                  else
                    [Text] -> Deque Text
forall a. [a] -> Deque a
lines
                      [ Text
"%arg.u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a = getelementptr i64, ptr %ustk, i64 %fpk" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k,
                        Text
"%arg.u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr %arg.u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a",
                        Text
"store i64 %arg.u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr %u" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k,
                        Text
"%arg.b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a = getelementptr ptr, ptr %bstk, i64 %fpk" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k,
                        Text
"%arg.b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr %arg.b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a",
                        Text
"store ptr %arg.b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr %b" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k
                      ]
        )
      -- the high-water mark of slots this function may write, for marking
      -- bstk on return. A worker writes the stack only where it exits or
      -- calls through the stack, and raises the mark there.
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> ( if Bool
worker
             then Deque Text
forall a. Deque a
D.empty
             else
               [Text] -> Deque Text
forall a. [a] -> Deque a
lines
                 [ Text
"%maxsp.a = getelementptr i8, ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (CtxOffsets -> Int
oMaxSp (Env -> CtxOffsets
envCtx Env
env)),
                   Text
"%maxsp.old = load i64, ptr %maxsp.a",
                   Text
"%maxsp.gt = icmp sgt i64 %fpk" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
maxK Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %maxsp.old",
                   Text
"%maxsp.new = select i1 %maxsp.gt, i64 %fpk" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
maxK Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 %maxsp.old",
                   Text
"store i64 %maxsp.new, ptr %maxsp.a"
                 ]
         )
      -- A constant past the pool's first array may not be in the array this
      -- run was entered with, if this function was installed after the run
      -- began (see Pool). Then exit, to be entered again with the current one.
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> ( if Int
maxPool Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Env -> Int
envPoolStable Env
env Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
checks
             then Deque Text
forall a. Deque a
D.empty
             else
               [Text] -> Deque Text
forall a. [a] -> Deque a
lines
                 [ Text
"%pool.n.a = getelementptr i64, ptr %pool, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rPtrsCount (Env -> RtsFacts
envRts Env
env) Int -> Int -> Int
forall a. Num a => a -> a -> a
- RtsFacts -> Int
rPtrsHeader (Env -> RtsFacts
envRts Env
env)),
                   Text
"%pool.n = load i64, ptr %pool.n.a",
                   Text
"%pool.ok = icmp ugt i64 %pool.n, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
maxPool,
                   Text
"br i1 %pool.ok, label %entry.room, label %stale" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
likely,
                   Text
"entry.room:"
                 ]
         )
      -- the interpreter's check: sp + size + 1 < stack size, else grow
      Deque Text -> Deque Text -> Deque Text
forall a. Semigroup a => a -> a -> a
<> ( if Bool
checks
             then
               [Text] -> Deque Text
forall a. [a] -> Deque a
lines
                 [ Text
"%need = add i64 %sp, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
maxK Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1),
                   Text
"%room = icmp slt i64 %need, %stack.size",
                   Text
"br i1 %room, label %head, label %grow" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
likely
                 ]
             else [Text] -> Deque Text
forall a. [a] -> Deque a
lines [Text
"br label %head"]
         )
  where
    lines :: [a] -> Deque a
lines = [a] -> Deque a
forall a. [a] -> Deque a
D.fromList
    each :: [Int] -> (Int -> m) -> m
each [Int]
ks Int -> m
f = (Int -> m) -> [Int] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Int -> m
f ([Int]
ks :: [Int])
    ctxAddr :: Text -> (CtxOffsets -> Int) -> Text
ctxAddr Text
name CtxOffsets -> Int
f = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a = getelementptr i8, ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (CtxOffsets -> Int
f (Env -> CtxOffsets
envCtx Env
env))
    ctxLoad :: Text -> Text -> (CtxOffsets -> Int) -> Text
ctxLoad Text
ty Text
name CtxOffsets -> Int
f =
      Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a = getelementptr i8, ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (CtxOffsets -> Int
f (Env -> CtxOffsets
envCtx Env
env)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a"
    poolLoad :: Text -> a -> Deque Text
poolLoad Text
name a
ix =
      [Text] -> Deque Text
forall a. [a] -> Deque a
lines
        [ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a = getelementptr ptr, ptr %pool, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow a
ix,
          Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a"
        ]

-- | The loop head: the high-water mark, the poll, then the body.
genHead :: FnEnv -> MSection -> Gen ()
genHead :: FnEnv -> MSection -> Gen ()
genHead FnEnv
fe MSection
body = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      d :: Int
d = FnEnv -> Int
feArity FnEnv
fe
  -- the entry block's stack check branches to %grow when the frame doesn't
  -- fit; the size asked for is fixed up in genFunction once it is known
  Text
_ <- Text -> FnEnv -> Int -> Exit -> Gen Text
exitBlockNamed Text
"grow" FnEnv
fe Int
d (Int -> Ptr NativeCell -> Exit
GrowStack (FnEnv -> Int
feFrameSize FnEnv
fe) (FnEnv -> Ptr NativeCell
feCell FnEnv
fe))
  -- likewise for the entry block's check of the constant pool
  Text
_ <- Text -> FnEnv -> Int -> Exit -> Gen Text
exitBlockNamed Text
"stale" FnEnv
fe Int
d (String -> Exit -> Exit
Named String
"stale constant pool" (Ptr NativeCell -> Exit
Reenter (FnEnv -> Ptr NativeCell
feCell FnEnv
fe)))
  -- poll
  -- The load is volatile: another thread sets HpLim, and without volatile
  -- LLVM would hoist the load out of the loop and the poll would never fire.
  Text
hp <- Text -> Gen Text
fresh Text
"hplim"
  Text -> Gen ()
emit (Text
hp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load volatile ptr, ptr %hplim.p")
  Text
stopHp <- Text -> Gen Text
fresh Text
"stop"
  Text -> Gen ()
emit (Text
stopHp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", null")
  -- The allocation budget: exhausted once the bump pointer has passed its
  -- end. Only code that allocates needs to look (a callee that allocates
  -- looks itself).
  Text
stopAlloc <-
    if MSection -> Bool
allocates MSection
body
      then do
        Text
hpA <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oHp
        Text
hp <- Text -> Gen Text
fresh Text
"hp"
        Text -> Gen ()
emit (Text
hp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hpA)
        Text
endA <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oBudgetEnd
        Text
end <- Text -> Gen Text
fresh Text
"budget.end"
        Text -> Gen ()
emit (Text
end Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
endA)
        Text
over <- Text -> Gen Text
fresh Text
"over"
        Text -> Gen ()
emit (Text
over Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ugt ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end)
        Text
stop <- Text -> Gen Text
fresh Text
"stop"
        Text -> Gen ()
emit (Text
stop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stopHp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
over)
        pure Text
stop
      else Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
stopHp
  -- A worker that makes calls checks the C stack here, once, instead of
  -- before each call. If the budget for native calls is used up, it goes
  -- back to the trampoline (its callers unwinding as for any exit) and is
  -- entered again at the bottom of the C stack. On Windows a tail call can
  -- be an ordinary call ('workerTail'), so a worker that makes tail calls
  -- checks too.
  Text
stop <-
    if FnEnv -> Bool
feWorker FnEnv
fe Bool -> Bool -> Bool
&& (MSection -> Bool
makesCalls MSection
body Bool -> Bool -> Bool
|| (String
os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"mingw32" Bool -> Bool -> Bool
&& MSection -> Bool
makesTailCalls MSection
body))
      then do
        Text
csp <- Text -> Gen Text
fresh Text
"csp"
        Text -> Gen ()
emit (Text
csp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @llvm.stacksave.p0()")
        Text
cspi <- Text -> Gen Text
fresh Text
"csp"
        Text -> Gen ()
emit (Text
cspi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
csp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
        Text
lim <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oCStackLimit
        Text
limv <- Text -> Gen Text
fresh Text
"lim"
        Text -> Gen ()
emit (Text
limv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lim)
        Text
deep <- Text -> Gen Text
fresh Text
"deep"
        Text -> Gen ()
emit (Text
deep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ult i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cspi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
limv)
        Text
stop <- Text -> Gen Text
fresh Text
"stop"
        Text -> Gen ()
emit (Text
stop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stopAlloc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
deep)
        pure Text
stop
      else Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
stopAlloc
  Text
reenter <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (Ptr NativeCell -> Exit
Reenter (FnEnv -> Ptr NativeCell
feCell FnEnv
fe))
  Text
bodyLabel <- Text -> Gen Text
freshLabel Text
"body"
  Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Env -> Bool
envStressPoll Env
env) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
    Text
left <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oStressPollLeft
    Text
n <- Text -> Gen Text
fresh Text
"left"
    Text -> Gen ()
emit (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
left)
    Text
n' <- Text -> Gen Text
fresh Text
"left"
    Text -> Gen ()
emit (Text
n' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = sub i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
    Text
fire <- Text -> Gen Text
fresh Text
"fire"
    Text -> Gen ()
emit (Text
fire Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp sle i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
    Text
every <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oStressPoll
    Text
ev <- Text -> Gen Text
fresh Text
"every"
    Text -> Gen ()
emit (Text
ev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
every)
    Text
reset <- Text -> Gen Text
fresh Text
"reset"
    Text -> Gen ()
emit (Text
reset Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fire Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n')
    Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reset Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
left)
    Text
stop' <- Text -> Gen Text
fresh Text
"stop"
    Text -> Gen ()
emit (Text
stop' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fire)
    Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stop' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reenter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bodyLabel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Env -> Bool
envStressPoll Env
env) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
    Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reenter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bodyLabel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Text -> Gen ()
startBlock Text
bodyLabel
  FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe Int
d MSection
body

-- | Generates a section at frame depth @d@. Every path ends in a terminator.
genSection :: FnEnv -> Int -> MSection -> Gen ()
genSection :: FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe Int
d MSection
sect = case FnEnv -> Maybe Text
feFast FnEnv
fe of
  Maybe Text
Nothing -> FnEnv -> Int -> MSection -> Gen ()
genSectionFull FnEnv
fe Int
d MSection
sect
  -- the fast entry: what can run unchecked runs here, and anything else
  -- is the full worker's, called with the arguments this was called with
  Just Text
full -> do
    Bool
free <- Int -> MSection -> StateT GS Identity Bool
checkFree Int
d MSection
sect
    if Bool
free then FnEnv -> Int -> MSection -> Gen ()
genSectionFull FnEnv
fe Int
d MSection
sect else FnEnv -> Text -> Gen ()
tailToFull FnEnv
fe Text
full

genSectionFull :: FnEnv -> Int -> MSection -> Gen ()
genSectionFull :: FnEnv -> Int -> MSection -> Gen ()
genSectionFull FnEnv
fe Int
d MSection
sect = case MSection
sect of
  -- an affine handler's switch to its own environment, in the form the
  -- rest of the case can observe (the other form is a no-op, in 'genInstr')
  Ins (InLocal Int
i) MSection
rest
    | Text -> Bool
on Text
"requests", Switches -> Bool
swLocalObserving (Env -> Switches
envSwitches (FnEnv -> Env
feEnv FnEnv
fe)), Bool -> Bool
not (MSection -> Bool
localUnobserved MSection
rest) -> FnEnv -> Int -> Int -> MSection -> MSection -> Gen ()
genInLocal FnEnv
fe Int
d Int
i MSection
rest MSection
sect
  Ins GInstr (RComb Val)
i MSection
rest -> FnEnv
-> Int
-> GInstr (RComb Val)
-> MSection
-> (Int -> Gen ())
-> Gen ()
genInstr FnEnv
fe Int
d GInstr (RComb Val)
i MSection
sect (\Int
d' -> FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe Int
d' MSection
rest)
  Yield Args
args -> FnEnv -> Int -> Args -> MSection -> Gen ()
genYield FnEnv
fe Int
d Args
args MSection
sect
  -- a tail call would leave an environment switch in force (see 'localEnds')
  Call {} | FnEnv -> Bool
localEnds FnEnv
fe -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  App {} | FnEnv -> Bool
localEnds FnEnv
fe -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  Call Bool
_ CombIx
cix RComb Val
comb Args
args -> FnEnv -> Int -> CombIx -> RComb Val -> Args -> MSection -> Gen ()
genCall FnEnv
fe Int
d CombIx
cix RComb Val
comb Args
args MSection
sect
  App Bool
_ GRef (RComb Val)
r Args
args | Text -> Bool
on Text
"app" -> FnEnv -> Int -> GRef (RComb Val) -> Args -> MSection -> Gen ()
genApp FnEnv
fe Int
d GRef (RComb Val)
r Args
args MSection
sect
  Match Int
i GBranch (RComb Val)
br -> do
    Text
x <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    FnEnv -> Int -> Text -> GBranch (RComb Val) -> MSection -> Gen ()
genBranch FnEnv
fe Int
d Text
x GBranch (RComb Val)
br MSection
sect
  DMatch Maybe Reference
mr Int
i GBranch (RComb Val)
br -> FnEnv
-> Int
-> Int
-> Maybe Reference
-> GBranch (RComb Val)
-> MSection
-> Gen ()
genDMatch FnEnv
fe Int
d Int
i Maybe Reference
mr GBranch (RComb Val)
br MSection
sect
  NMatch Maybe Reference
_ Int
i GBranch (RComb Val)
br -> do
    Text
x <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    FnEnv -> Int -> Text -> GBranch (RComb Val) -> MSection -> Gen ()
genBranch FnEnv
fe Int
d Text
x GBranch (RComb Val)
br MSection
sect
  Let MSection
binding CombIx
bcix Int
f MSection
body Ptr NativeCell
cell -> FnEnv
-> Int
-> MSection
-> CombIx
-> Int
-> MSection
-> Ptr NativeCell
-> MSection
-> Gen ()
genLet FnEnv
fe Int
d MSection
binding CombIx
bcix Int
f MSection
body Ptr NativeCell
cell MSection
sect
  RMatch Int
i MSection
pu EnumMap Word64 (GBranch (RComb Val))
br | Text -> Bool
on Text
"requests" -> FnEnv
-> Int
-> Int
-> MSection
-> EnumMap Word64 (GBranch (RComb Val))
-> MSection
-> Gen ()
genRMatch FnEnv
fe Int
d Int
i MSection
pu EnumMap Word64 (GBranch (RComb Val))
br MSection
sect
  -- the interpreter takes these: a request match with requests disabled,
  -- the slow call path with it disabled, a jump to a continuation, and the
  -- two ways a function stops
  RMatch {} -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  App {} -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  Jump {} -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  Die {} -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  MSection
Exit -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  where
    on :: Text -> Bool
on = FnEnv -> Text -> Bool
enabled FnEnv
fe

-- | Whether a feature is on (see Config's @disabled@).
enabled :: FnEnv -> Text -> Bool
enabled :: FnEnv -> Text -> Bool
enabled FnEnv
fe Text
name = Text
name Text -> Deque Text -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Env -> Deque Text
envDisabled (FnEnv -> Env
feEnv FnEnv
fe)

-- | A @Let@. A binding that is a call to a known function becomes a native
-- call. Other bindings are generated inline: their exits write a frame
-- record for this @Let@, and their @Yield@ delivers the results to the
-- body. If neither works, the interpreter takes the @Let@, and pushes the
-- frame itself.
genLet :: FnEnv -> Int -> MSection -> CombIx -> Int -> MSection -> Ptr NativeCell -> MSection -> Gen ()
genLet :: FnEnv
-> Int
-> MSection
-> CombIx
-> Int
-> MSection
-> Ptr NativeCell
-> MSection
-> Gen ()
genLet FnEnv
fe Int
d MSection
binding bcix :: CombIx
bcix@(CIx Reference
_ Word64
_ Word64
w) Int
f MSection
body Ptr NativeCell
cell MSection
sect = case Word64 -> MCombs -> Maybe (GComb Val (RComb Val))
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w (Env -> MCombs
envCombs Env
env) of
  Just (Comb (LamI Int
bodyArity Int
_ MSection
_ Ptr NativeCell
_))
    | Int
m <- Int
bodyArity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
d,
      Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 -> case MSection
binding of
        Call Bool
_ CombIx
ccix RComb Val
comb Args
ZArgs
          | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1,
            Just (Pair Int
u Int
ix) <- FnEnv -> CombIx -> RComb Val -> Maybe (Pair Int Int)
cachedConstant FnEnv
fe CombIx
ccix RComb Val
comb -> do
              Int -> Int -> Int -> Gen ()
pushCached Int
d Int
u Int
ix
              FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MSection
body
        App Bool
_ (MCode.Env CombIx
ccix RComb Val
comb) Args
ZArgs
          | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1,
            Just (Pair Int
u Int
ix) <- FnEnv -> CombIx -> RComb Val -> Maybe (Pair Int Int)
cachedConstant FnEnv
fe CombIx
ccix RComb Val
comb -> do
              Int -> Int -> Int -> Gen ()
pushCached Int
d Int
u Int
ix
              FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MSection
body
        Call Bool
_ CombIx
_ RComb Val
comb Args
args
          | Comb (LamI Int
arity Int
_ MSection
_ Ptr NativeCell
ccell) <- RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb,
            let srcs :: Deque Int
srcs = FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args,
            Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity -> do
              Ptr NativeCell
bcell <- StateT GS Identity (Ptr NativeCell)
bodyCell
              Int
ix <- Env -> Frame -> StateT GS Identity Int
addFrame Env
env (CombIx -> Int -> MSection -> Ptr NativeCell -> Frame
Frame CombIx
bcix Int
f MSection
body Ptr NativeCell
bcell)
              FnEnv
-> Int
-> Int
-> Ptr NativeCell
-> Deque Int
-> Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genNonTailCall FnEnv
fe Int
d Int
d Ptr NativeCell
ccell Deque Int
srcs Int
m MSection
sect (Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
ix Int
d)) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
                FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m) MSection
body
        App Bool
_ r :: GRef (RComb Val)
r@(MCode.Env CombIx
ccix RComb Val
comb) Args
args
          | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"app",
            Comb (LamI Int
arity Int
_ MSection
_ Ptr NativeCell
ccell) <- RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb,
            let srcs :: Deque Int
srcs = FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args,
            Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity -> do
              Ptr NativeCell
bcell <- StateT GS Identity (Ptr NativeCell)
bodyCell
              Int
ix <- Env -> Frame -> StateT GS Identity Int
addFrame Env
env (CombIx -> Int -> MSection -> Ptr NativeCell -> Frame
Frame CombIx
bcix Int
f MSection
body Ptr NativeCell
bcell)
              FnEnv
-> Int
-> Int
-> Ptr NativeCell
-> Deque Int
-> Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genNonTailCall FnEnv
fe Int
d Int
d Ptr NativeCell
ccell Deque Int
srcs Int
m MSection
sect (Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
ix Int
d)) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
                FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m) MSection
body
          -- Fewer arguments than the function takes: the value of the binding
          -- is a partial application, built in place from the function's
          -- closure in the pool ('genNameInline').
          | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"name",
            Maybe Text
Nothing <- FnEnv -> Maybe Text
feFast FnEnv
fe,
            Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1,
            Comb info :: GCombInfo (RComb Val)
info@(LamI Int
arity Int
_ MSection
_ Ptr NativeCell
_) <- RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb,
            let srcs :: Deque Int
srcs = FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args,
            Bool -> Bool
not (Deque Int -> Bool
forall a. Deque a -> Bool
D.null Deque Int
srcs),
            Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
arity,
            Just Int
pix <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (CombIx -> GCombInfo (RComb Val) -> PoolKey
KeyComb CombIx
ccix GCombInfo (RComb Val)
info) (Env -> Map PoolKey Int
envPool Env
env) -> do
              FnEnv -> Int -> Int -> Deque Int -> Gen ()
genNameInline FnEnv
fe Int
d Int
pix Deque Int
srcs
              FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MSection
body
          | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"app",
            Args
ZArgs <- Args
args,
            Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1,
            Just Int
ix <- FnEnv -> GRef (RComb Val) -> Maybe Int
combConstant FnEnv
fe GRef (RComb Val)
r -> do
              FnEnv -> Int -> Int -> Gen ()
poolConstant FnEnv
fe Int
d Int
ix
              FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MSection
body
          | Bool
otherwise -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
        App Bool
_ (Stk Int
i) Args
args | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"app" -> do
          Ptr NativeCell
bcell <- StateT GS Identity (Ptr NativeCell)
bodyCell
          Int
ix <- Env -> Frame -> StateT GS Identity Int
addFrame Env
env (CombIx -> Int -> MSection -> Ptr NativeCell -> Frame
Frame CombIx
bcix Int
f MSection
body Ptr NativeCell
bcell)
          FnEnv
-> Int
-> Int
-> Int
-> Deque Int
-> Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genClosureCall FnEnv
fe Int
d Int
d (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) (FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args) Int
m MSection
sect (Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
ix Int
d)) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
            FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m) MSection
body
        MSection
_ | Switches -> MSection -> Bool
startsSupported (Env -> Switches
envSwitches Env
env) MSection
binding -> do
          Ptr NativeCell
bcell <- StateT GS Identity (Ptr NativeCell)
bodyCell
          Int
ix <- Env -> Frame -> StateT GS Identity Int
addFrame Env
env (CombIx -> Int -> MSection -> Ptr NativeCell -> Frame
Frame CombIx
bcix Int
f MSection
body Ptr NativeCell
bcell)
          Text
bodyL <- Text -> Gen Text
freshLabel Text
"body"
          let fe' :: FnEnv
fe' = FnEnv
fe {feEnclosing = Enclosing ix d bodyL m (liveAt env (currentBase fe) (d + m) body) <| feEnclosing fe}
          Bool
ok <- Gen () -> StateT GS Identity Bool
attempt (Gen () -> Gen ()
forall a. Gen a -> Gen a
withKinds (FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe' Int
d MSection
binding))
          if Bool
ok
            then do
              Text -> Gen ()
startBlock Text
bodyL
              FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m) MSection
body
            else FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
        MSection
_ -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  Maybe (GComb Val (RComb Val))
_ -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  where
    env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
    -- A Let inside a binding carries no cell (see attachNativeCells): its
    -- body combinator's arity counts the enclosing function's slots, so
    -- the interpreter can't enter it. An auxiliary function generated
    -- here, with the current frame base, can be.
    bodyCell :: StateT GS Identity (Ptr NativeCell)
bodyCell
      | Ptr NativeCell
cell Ptr NativeCell -> Ptr NativeCell -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr NativeCell
noNativeCell = Ptr NativeCell -> StateT GS Identity (Ptr NativeCell)
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ptr NativeCell
cell
      | Bool
otherwise = case Word64 -> MCombs -> Maybe (GComb Val (RComb Val))
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w (Env -> MCombs
envCombs Env
env) of
          Just (Comb (LamI Int
bodyArity Int
_ MSection
_ Ptr NativeCell
_)) ->
            Ptr NativeCell
-> (Pair Text (Ptr NativeCell) -> Ptr NativeCell)
-> Maybe (Pair Text (Ptr NativeCell))
-> Ptr NativeCell
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Ptr NativeCell
noNativeCell (\(Pair Text
_ Ptr NativeCell
c) -> Ptr NativeCell
c) (Maybe (Pair Text (Ptr NativeCell)) -> Ptr NativeCell)
-> Gen (Maybe (Pair Text (Ptr NativeCell)))
-> StateT GS Identity (Ptr NativeCell)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> FnEnv
-> Int
-> Int
-> MSection
-> Gen (Maybe (Pair Text (Ptr NativeCell)))
genAuxFunction Bool
True FnEnv
fe Int
bodyArity (FnEnv -> Int
currentBase FnEnv
fe) MSection
body
          Maybe (GComb Val (RComb Val))
_ -> Ptr NativeCell -> StateT GS Identity (Ptr NativeCell)
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ptr NativeCell
noNativeCell

-- | Loads @m@ results left on the stack above offset @base@ into their slots.
loadResults :: Int -> Int -> Gen ()
loadResults :: Int -> Int -> Gen ()
loadResults Int
base Int
m =
  [Int] -> (Int -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
m] ((Int -> Gen ()) -> Gen ()) -> (Int -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j -> do
    Text
ua <- Int -> Gen Text
stackAddrU (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j)
    Text
u <- Text -> Gen Text
fresh Text
"u"
    Text -> Gen ()
emit (Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
    Int -> Text -> Gen ()
storeU (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j) Text
u
    Text
ba <- Int -> Gen Text
stackAddrB (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j)
    Text
b <- Text -> Gen Text
fresh Text
"b"
    Text -> Gen ()
emit (Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
    Int -> Text -> Gen ()
storeB (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j) Text
b

-- | A native call that returns here. The callee's frame starts at offset
-- @base@ (the current depth for a @Let@ binding, or an enclosing binding's
-- base for a tail call inside one); its arguments come from the slots
-- @srcs@ at the current depth @d@. On @OK@ the continuation runs with the
-- results on the stack above @base@. Otherwise the slots up to @base@ are
-- written back, the frame record for this @Let@ (if given: index and frame
-- size) and those of the enclosing bindings are written, and the status is
-- passed on. If the callee can't be called, the interpreter resumes at
-- @sect@.
-- | The slots to write back when a call made at @base@ unwinds: what the
-- body that gets the callee's @m@ results reads, and the enclosing
-- bindings' bodies after it (see 'liveAt').
bodyLive :: FnEnv -> Int -> Int -> MSection -> Maybe IS.IntSet
bodyLive :: FnEnv -> Int -> Int -> MSection -> Maybe IntSet
bodyLive FnEnv
fe Int
base Int
m MSection
body = Env -> Int -> Int -> MSection -> Maybe IntSet
liveAt (FnEnv -> Env
feEnv FnEnv
fe) (FnEnv -> Int
currentBase FnEnv
fe) (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m) MSection
body Maybe IntSet -> Maybe IntSet -> Maybe IntSet
<+> FnEnv -> Maybe IntSet
enclosingLive FnEnv
fe

genNonTailCall :: FnEnv -> Int -> Int -> Ptr NativeCell -> Deque Int -> Int -> MSection -> Maybe (Pair Int Int) -> Gen () -> Gen ()
genNonTailCall :: FnEnv
-> Int
-> Int
-> Ptr NativeCell
-> Deque Int
-> Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genNonTailCall FnEnv
fe Int
d Int
base Ptr NativeCell
ccell Deque Int
srcs Int
m MSection
sect Maybe (Pair Int Int)
ownFrame Gen ()
continue
  | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1,
    Just (Pair Text
wname Int
arity) <- Ptr NativeCell
-> Map (Ptr NativeCell) (Pair Text Int) -> Maybe (Pair Text Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ptr NativeCell
ccell (Env -> Map (Ptr NativeCell) (Pair Text Int)
envWorkers (FnEnv -> Env
feEnv FnEnv
fe)),
    Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs =
      FnEnv
-> Int
-> Int
-> Text
-> Deque Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genWorkerCall FnEnv
fe Int
d Int
base Text
wname Deque Int
srcs MSection
sect Maybe (Pair Int Int)
ownFrame Gen ()
continue
  | Bool
otherwise =
      FnEnv
-> Int
-> Int
-> Gen (Pair Text Text)
-> Gen Text
-> Deque Int
-> Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genNonTailCallWith FnEnv
fe Int
d Int
base (Env -> Ptr NativeCell -> Gen (Pair Text Text)
loadCallee (FnEnv -> Env
feEnv FnEnv
fe) Ptr NativeCell
ccell) (Int -> Gen Text
fpPlus (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs)) Deque Int
srcs Int
m MSection
sect Maybe (Pair Int Int)
ownFrame Gen ()
continue

-- | 'genNonTailCall' with the callee given by a generator (the code
-- pointer and an i1 saying the call can't be made), and the callee's
-- stack pointer given by another, run after the arguments are in place
-- (a closure call copies its captured arguments there). The callee's @m@
-- results are loaded from the stack into their slots before the
-- continuation runs.
genNonTailCallWith :: FnEnv -> Int -> Int -> Gen (Pair Text Text) -> Gen Text -> Deque Int -> Int -> MSection -> Maybe (Pair Int Int) -> Gen () -> Gen ()
genNonTailCallWith :: FnEnv
-> Int
-> Int
-> Gen (Pair Text Text)
-> Gen Text
-> Deque Int
-> Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genNonTailCallWith FnEnv
fe Int
d Int
base Gen (Pair Text Text)
getCallee Gen Text
getTop Deque Int
srcs Int
m MSection
sect Maybe (Pair Int Int)
ownFrame Gen ()
continue = do
  let n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs
  Pair Text
fnp Text
skip <- Gen (Pair Text Text)
getCallee
  Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
  Text
guardL <- Text -> Gen Text
freshLabel Text
"guard"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
skip Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
guardL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Text -> Gen ()
startBlock Text
guardL
  FnEnv -> Text -> Gen ()
cStackGuard FnEnv
fe Text
slow
  -- arguments go above the callee's base, as moveArgs would put them
  Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
srcs
  Deque (Pair Text Text)
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall (m :: * -> *) a.
Monad m =>
Deque a -> (Int -> a -> m ()) -> m ()
iforM_ Deque (Pair Text Text)
vals ((Int -> Pair Text Text -> Gen ()) -> Gen ())
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j (Pair Text
u Text
b) -> do
    Text
ua <- Int -> Gen Text
stackAddrU (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
    Text
ba <- Int -> Gen Text
stackAddrB (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
  Text
bp <- Int -> Gen Text
fpPlus Int
base
  Text
top <- Gen Text
getTop
  Text
r <- Text -> Gen Text
fresh Text
"r"
  Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fnp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
top Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  Text
ok <- Text -> Gen Text
fresh Text
"ok"
  Text -> Gen ()
emit (Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
  -- the callee is exiting: record the frames the interpreter would have
  -- pushed, and pass the status along
  Text
unwind <- Text -> Gen () -> Gen Text
sideBlock Text
"unwind" (FnEnv
-> Int -> Maybe IntSet -> Maybe (Pair Int Int) -> Text -> Gen ()
unwindWith FnEnv
fe Int
base (FnEnv -> Int -> Int -> MSection -> Maybe IntSet
bodyLive FnEnv
fe Int
base Int
m MSection
sect) Maybe (Pair Int Int)
ownFrame Text
r)
  Text
contL <- Text -> Gen Text
freshLabel Text
"cont"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unwind Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
likely)
  Text -> Gen ()
startBlock Text
contL
  Int -> Int -> Gen ()
loadResults Int
base Int
m
  Gen ()
continue

-- | The C stack guard: branches to @slow@ instead of going on to a call
-- when the budget for native non-tail calls is used up. A worker has
-- checked at entry (see 'genHead') and doesn't check again here. Every
-- cycle of calls still passes a check: an edge without one goes from a
-- worker to a function with the uniform signature, whose own calls check.
cStackGuard :: FnEnv -> Text -> Gen ()
cStackGuard :: FnEnv -> Text -> Gen ()
cStackGuard FnEnv
fe Text
_ | FnEnv -> Bool
feWorker FnEnv
fe = () -> Gen ()
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
cStackGuard FnEnv
fe Text
slow = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
  Text
csp <- Text -> Gen Text
fresh Text
"csp"
  Text -> Gen ()
emit (Text
csp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @llvm.stacksave.p0()")
  Text
cspi <- Text -> Gen Text
fresh Text
"csp"
  Text -> Gen ()
emit (Text
cspi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
csp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
lim <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oCStackLimit
  Text
limv <- Text -> Gen Text
fresh Text
"lim"
  Text -> Gen ()
emit (Text
limv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lim)
  Text
deep <- Text -> Gen Text
fresh Text
"deep"
  Text -> Gen ()
emit (Text
deep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ult i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cspi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
limv)
  Text
callL <- Text -> Gen Text
freshLabel Text
"call"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
deep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
callL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Text -> Gen ()
startBlock Text
callL

-- | What a caller does when its callee comes back with the status in
-- register @r@, which isn't OK: write the slots up to @base@ back to the
-- stack, write the frame record for this @Let@ (if given) and those of
-- the enclosing bindings, and return the status.
unwindWith :: FnEnv -> Int -> Maybe IS.IntSet -> Maybe (Pair Int Int) -> Text -> Gen ()
unwindWith :: FnEnv
-> Int -> Maybe IntSet -> Maybe (Pair Int Int) -> Text -> Gen ()
unwindWith FnEnv
fe Int
base Maybe IntSet
live Maybe (Pair Int Int)
ownFrame Text
r = FnEnv
-> Int
-> Maybe IntSet
-> Bool
-> Maybe (Pair Int Int)
-> Text
-> Gen ()
joinShared FnEnv
fe Int
base Maybe IntSet
live Bool
False Maybe (Pair Int Int)
ownFrame Text
r

-- | A call to a function of this module that has a worker, expecting one
-- result: the arguments go in registers and the result comes back in
-- registers, so the Unison stack isn't touched unless the callee exits.
-- The callee's frame still has its place on the stack, above @base@, and
-- this function's stack check has made room for its arguments there
-- (the callee writes them if it exits before anything else).
--
-- The worker may come back asking for a tail call it couldn't make
-- itself ('statusTailCall'): its callee's arguments are on the stack
-- above @base@, and the call is made here, as a plain call through the
-- stack.
genWorkerCall :: FnEnv -> Int -> Int -> Text -> Deque Int -> MSection -> Maybe (Pair Int Int) -> Gen () -> Gen ()
genWorkerCall :: FnEnv
-> Int
-> Int
-> Text
-> Deque Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genWorkerCall FnEnv
fe Int
d Int
base Text
wname Deque Int
srcs MSection
sect Maybe (Pair Int Int)
ownFrame Gen ()
continue = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs
  Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
  -- the callee stress mode still takes the slow path now and then
  Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Env -> Bool
envStressCallee Env
env) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
    Text
fire <- Env -> (CtxOffsets -> Int) -> (CtxOffsets -> Int) -> Gen Text
stressFire Env
env CtxOffsets -> Int
oStressCalleeLeft CtxOffsets -> Int
oStressCallee
    Text
goL <- Text -> Gen Text
freshLabel Text
"go"
    Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fire Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
goL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
    Text -> Gen ()
startBlock Text
goL
  FnEnv -> Text -> Gen ()
cStackGuard FnEnv
fe Text
slow
  Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
srcs
  Int -> Gen ()
useK (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n Int
1)
  Text
bp <- Int -> Gen Text
fpPlus Int
base
  Text
r <- Text -> Gen Text
fresh Text
"r"
  Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerCC Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
wname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Deque (Pair Text Text) -> Text
argList (Deque (Pair Text Text) -> Deque (Pair Text Text)
forall a. Deque a -> Deque a
D.reverse Deque (Pair Text Text)
vals) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  Text
st <- Text -> Gen Text
fresh Text
"st"
  Text -> Gen ()
emit (Text
st Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = extractvalue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
  Text
ru <- Text -> Gen Text
fresh Text
"r.u"
  Text -> Gen ()
emit (Text
ru Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = extractvalue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
  Text
rb <- Text -> Gen Text
fresh Text
"r.b"
  Text -> Gen ()
emit (Text
rb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = extractvalue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 2")
  Text
ok <- Text -> Gen Text
fresh Text
"ok"
  Text -> Gen ()
emit (Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
st Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
  Text
callL <- Gen Text
curLabel
  Text
contL <- Text -> Gen Text
freshLabel Text
"cont"
  Text
notOkL <- Text -> Gen Text
freshLabel Text
"notok"
  Text
tailL <- Text -> Gen Text
freshLabel Text
"tailcall"
  Text
tailOkL <- Text -> Gen Text
freshLabel Text
"tailcall.ok"
  Text
unwindL <- Text -> Gen Text
freshLabel Text
"unwind"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
notOkL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
likely)
  -- not OK: a tail call to make, or an exit
  Text
r2 <- Text -> Gen Text
fresh Text
"r"
  Text -> Gen () -> Gen ()
sideBlockNamed Text
notOkL (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
    Text
tc <- Text -> Gen Text
fresh Text
"tc"
    Text -> Gen ()
emit (Text
tc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
st Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
statusTailCall)
    Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tailL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unwindL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Text
u2 <- Text -> Gen Text
fresh Text
"u"
  Text
b2 <- Text -> Gen Text
fresh Text
"b"
  Text -> Gen () -> Gen ()
sideBlockNamed Text
tailL (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
    Text
fn <- Text -> Gen Text
fresh Text
"fn"
    Text -> Gen ()
emit (Text
fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ru Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
    Text
top <- Text -> Gen Text
fresh Text
"top"
    Text -> Gen ()
emit (Text
top Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
    Text -> Gen ()
emit (Text
r2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
top Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text
ok2 <- Text -> Gen Text
fresh Text
"ok"
    Text -> Gen ()
emit (Text
ok2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
    Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ok2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tailOkL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unwindL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
likely)
  Text -> Gen () -> Gen ()
sideBlockNamed Text
tailOkL (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
    Text
ua <- Int -> Gen Text
stackAddrU (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    Text -> Gen ()
emit (Text
u2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
    Text
ba <- Int -> Gen Text
stackAddrB (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    Text -> Gen ()
emit (Text
b2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
    Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contL)
  Text -> Gen () -> Gen ()
sideBlockNamed Text
unwindL (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
    Text
status <- Text -> Gen Text
fresh Text
"status"
    Text -> Gen ()
emit (Text
status Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi i64 [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
st Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
notOkL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ], [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tailL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
    FnEnv
-> Int -> Maybe IntSet -> Maybe (Pair Int Int) -> Text -> Gen ()
unwindWith FnEnv
fe Int
base (FnEnv -> Int -> Int -> MSection -> Maybe IntSet
bodyLive FnEnv
fe Int
base Int
1 MSection
sect) Maybe (Pair Int Int)
ownFrame Text
status
  Text -> Gen ()
startBlock Text
contL
  Text
u <- Text -> Gen Text
fresh Text
"u"
  Text -> Gen ()
emit (Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi i64 [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ru Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
callL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ], [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tailOkL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  Text
b <- Text -> Gen Text
fresh Text
"b"
  Text -> Gen ()
emit (Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi ptr [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
callL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ], [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tailOkL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  Int -> Text -> Gen ()
storeU (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
u
  Int -> Text -> Gen ()
storeB (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
b
  Gen ()
continue

-- | Runs a generator that may fail. On failure the state is rolled back
-- (except the name counter) and False is returned; nothing was emitted.
attempt :: Gen () -> Gen Bool
attempt :: Gen () -> StateT GS Identity Bool
attempt Gen ()
g = do
  GS
before <- StateT GS Identity GS
forall s (m :: * -> *). MonadState s m => m s
get
  Gen ()
g
  GS
after <- StateT GS Identity GS
forall s (m :: * -> *). MonadState s m => m s
get
  case GS -> Maybe Text
gsFailed GS
after of
    Maybe Text
Nothing -> Bool -> StateT GS Identity Bool
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Just Text
why -> do
      GS -> Gen ()
put GS
before {gsFresh = gsFresh after, gsNotes = gsNotes after |> why, gsNotWorker = gsNotWorker after}
      pure Bool
False

-- | Branch on an i64 value. @arm@ generates one arm at depth @d@; if it
-- can't (a data match arm that needs fields the native path doesn't
-- push), that arm exits at the whole section instead.
genBranch :: FnEnv -> Int -> Text -> GBranch (RComb Val) -> MSection -> Gen ()
genBranch :: FnEnv -> Int -> Text -> GBranch (RComb Val) -> MSection -> Gen ()
genBranch FnEnv
fe Int
d Text
x GBranch (RComb Val)
br MSection
sect = FnEnv
-> Int
-> Text
-> GBranch (RComb Val)
-> MSection
-> (Word64 -> Arm (RComb Val) -> Gen ())
-> Gen ()
genBranchWith FnEnv
fe Int
d Text
x GBranch (RComb Val)
br MSection
sect (\Word64
_ (Arm Int
_ MSection
s) -> FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe Int
d MSection
s)

-- | 'genBranch' with the code for an arm supplied: it gets the case's
-- constructor tag (or word) and the arm, with the field count it binds.
genBranchWith :: FnEnv -> Int -> Text -> GBranch (RComb Val) -> MSection -> (Word64 -> Arm (RComb Val) -> Gen ()) -> Gen ()
genBranchWith :: FnEnv
-> Int
-> Text
-> GBranch (RComb Val)
-> MSection
-> (Word64 -> Arm (RComb Val) -> Gen ())
-> Gen ()
genBranchWith FnEnv
fe Int
d Text
x GBranch (RComb Val)
br MSection
sect Word64 -> Arm (RComb Val) -> Gen ()
armCode = case GBranch (RComb Val)
br of
  Test1 Word64
u Arm (RComb Val)
y MSection
n -> do
    Text
c <- Text -> Gen Text
fresh Text
"is"
    Text -> Gen ()
emit (Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
signed Word64
u)
    Text
ly <- Text -> Gen () -> Gen Text
block Text
"yes" (Word64 -> Arm (RComb Val) -> Gen ()
armCode Word64
u Arm (RComb Val)
y)
    Text
ln <- Text -> Gen () -> Gen Text
block Text
"no" (FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe Int
d MSection
n)
    Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ly Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ln)
  Test2 Word64
u Arm (RComb Val)
cu Word64
v Arm (RComb Val)
cv MSection
e -> do
    Text
lu <- Text -> Gen () -> Gen Text
block Text
"case" (Word64 -> Arm (RComb Val) -> Gen ()
armCode Word64
u Arm (RComb Val)
cu)
    Text
lv <- Text -> Gen () -> Gen Text
block Text
"case" (Word64 -> Arm (RComb Val) -> Gen ()
armCode Word64
v Arm (RComb Val)
cv)
    Text
le <- Text -> Gen () -> Gen Text
block Text
"default" (FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe Int
d MSection
e)
    Text -> Gen ()
emit (Text
"switch i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
le Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [ i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
signed Word64
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lu Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
signed Word64
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  TestW MSection
df EnumMap Word64 (Arm (RComb Val))
cs -> do
    Text
ldf <- Text -> Gen () -> Gen Text
block Text
"default" (FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe Int
d MSection
df)
    Deque Text
arms <- (Deque Text
 -> (Word64, Arm (RComb Val)) -> StateT GS Identity (Deque Text))
-> Deque Text
-> [(Word64, Arm (RComb Val))]
-> StateT GS Identity (Deque Text)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Deque Text
acc (Word64
w, Arm (RComb Val)
a) -> (\Text
l -> Deque Text
acc Deque Text -> Text -> Deque Text
forall a. Deque a -> a -> Deque a
|> (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
signed Word64
w Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l)) (Text -> Deque Text) -> Gen Text -> StateT GS Identity (Deque Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Gen () -> Gen Text
block Text
"case" (Word64 -> Arm (RComb Val) -> Gen ()
armCode Word64
w Arm (RComb Val)
a)) Deque Text
forall a. Deque a
D.empty (EnumMap Word64 (Arm (RComb Val)) -> [(Word64, Arm (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (Arm (RComb Val))
cs)
    Text -> Gen ()
emit (Text
"switch i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ldf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Deque Text -> Text
intercalateT Text
" " Deque Text
arms Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  -- matches on text and on big numbers are the interpreter's
  TestT {} -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  TestY {} -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  where
    -- an arm off to the side (the default arm has no constructor and runs
    -- at depth d); one that can't be generated exits at the match
    block :: Text -> Gen () -> Gen Text
block Text
base Gen ()
code = do
      Text
label <- Text -> Gen Text
freshLabel Text
base
      Bool
ok <- Gen () -> StateT GS Identity Bool
attempt (Gen () -> Gen ()
forall a. Gen a -> Gen a
withKinds (Text -> Gen () -> Gen ()
sideBlockNamed Text
label Gen ()
code))
      Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ Text -> Gen () -> Gen ()
sideBlockNamed Text
label (FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect)
      pure Text
label

signed :: Word64 -> Text
signed :: Word64 -> Text
signed Word64
w = Int64 -> Text
forall a. Show a => a -> Text
tshow (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w :: Int64)

-- | Branch on the constructor of a data value: a boolean still in a
-- register is one branch, anything else a dispatch on the closure.
genDMatch :: FnEnv -> Int -> Int -> Maybe Reference -> GBranch (RComb Val) -> MSection -> Gen ()
genDMatch :: FnEnv
-> Int
-> Int
-> Maybe Reference
-> GBranch (RComb Val)
-> MSection
-> Gen ()
genDMatch FnEnv
fe Int
d Int
i Maybe Reference
mr GBranch (RComb Val)
br MSection
sect =
  Int -> Gen (Maybe Text)
slotKind (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Gen (Maybe Text) -> (Maybe Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Text
c -> FnEnv -> Int -> Text -> GBranch (RComb Val) -> MSection -> Gen ()
genBoolBranch FnEnv
fe Int
d Text
c GBranch (RComb Val)
br MSection
sect
    Maybe Text
Nothing -> FnEnv
-> Int
-> Int
-> Maybe Reference
-> GBranch (RComb Val)
-> MSection
-> Gen ()
genDMatchClosure FnEnv
fe Int
d Int
i Maybe Reference
mr GBranch (RComb Val)
br MSection
sect

-- | A match on a boolean that is still an i1: one branch. False is
-- constructor 0, true is 1.
genBoolBranch :: FnEnv -> Int -> Text -> GBranch (RComb Val) -> MSection -> Gen ()
genBoolBranch :: FnEnv -> Int -> Text -> GBranch (RComb Val) -> MSection -> Gen ()
genBoolBranch FnEnv
fe Int
d Text
c GBranch (RComb Val)
br MSection
sect = case GBranch (RComb Val)
br of
  Test1 Word64
u (Arm Int
_ MSection
y) MSection
n -> Pair MSection MSection -> Gen ()
two (if Word64
u Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
1 then MSection -> MSection -> Pair MSection MSection
forall a b. a -> b -> Pair a b
Pair MSection
y MSection
n else MSection -> MSection -> Pair MSection MSection
forall a b. a -> b -> Pair a b
Pair MSection
n MSection
y)
  Test2 Word64
u (Arm Int
_ MSection
cu) Word64
v (Arm Int
_ MSection
cv) MSection
e -> Pair MSection MSection -> Gen ()
two (MSection -> MSection -> Pair MSection MSection
forall a b. a -> b -> Pair a b
Pair (Word64
-> Word64 -> MSection -> Word64 -> MSection -> MSection -> MSection
forall {a} {p}. Eq a => a -> a -> p -> a -> p -> p -> p
pick Word64
1 Word64
u MSection
cu Word64
v MSection
cv MSection
e) (Word64
-> Word64 -> MSection -> Word64 -> MSection -> MSection -> MSection
forall {a} {p}. Eq a => a -> a -> p -> a -> p -> p -> p
pick Word64
0 Word64
u MSection
cu Word64
v MSection
cv MSection
e))
  TestW MSection
df EnumMap Word64 (Arm (RComb Val))
cs -> Pair MSection MSection -> Gen ()
two (MSection -> MSection -> Pair MSection MSection
forall a b. a -> b -> Pair a b
Pair (MSection
-> (Arm (RComb Val) -> MSection)
-> Maybe (Arm (RComb Val))
-> MSection
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MSection
df Arm (RComb Val) -> MSection
forall comb. Arm comb -> GSection comb
armSection (Word64
-> EnumMap Word64 (Arm (RComb Val)) -> Maybe (Arm (RComb Val))
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
1 EnumMap Word64 (Arm (RComb Val))
cs)) (MSection
-> (Arm (RComb Val) -> MSection)
-> Maybe (Arm (RComb Val))
-> MSection
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MSection
df Arm (RComb Val) -> MSection
forall comb. Arm comb -> GSection comb
armSection (Word64
-> EnumMap Word64 (Arm (RComb Val)) -> Maybe (Arm (RComb Val))
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
0 EnumMap Word64 (Arm (RComb Val))
cs)))
  TestT {} -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  TestY {} -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  where
    pick :: a -> a -> p -> a -> p -> p -> p
pick a
t a
u p
cu a
v p
cv p
e
      | a
u a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
t = p
cu
      | a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
t = p
cv
      | Bool
otherwise = p
e
    two :: Pair MSection MSection -> Gen ()
two (Pair MSection
t MSection
f) = do
      Text
lt <- Text -> MSection -> Gen Text
arm Text
"true" MSection
t
      Text
lf <- Text -> MSection -> Gen Text
arm Text
"false" MSection
f
      Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lf)
    arm :: Text -> MSection -> Gen Text
arm Text
base MSection
s = do
      Text
label <- Text -> Gen Text
freshLabel Text
base
      Bool
ok <- Gen () -> StateT GS Identity Bool
attempt (Gen () -> Gen ()
forall a. Gen a -> Gen a
withKinds (Text -> Gen () -> Gen ()
sideBlockNamed Text
label (FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe Int
d MSection
s)))
      Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ Text -> Gen () -> Gen ()
sideBlockNamed Text
label (FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect)
      pure Text
label

-- | A match on a data closure. Each arm's field count ('Arm', from the
-- ANF case the arm was emitted for) fixes the shape of the
-- object the arm is for: no fields is @GEnum@, 1 to 6 are @GData1@ to
-- @GData6@, more is @GDataG@. The shape is what the pointer tag gives,
-- from bits already in a register (tag 7, which @GData3@, @GData4@,
-- @GData6@ and @GDataG@ share, with a load of the info pointer). So the
-- dispatch is over the shapes the arms have: a shape with one arm, in a
-- match with no default of its own (so one in which every constructor has
-- an arm), branches straight to it; otherwise the shape's block loads the
-- packed tag and switches on the constructor number, as the interpreter's
-- @dataBranch@ does. A data value of a shape no arm has runs the default
-- arm (at depth d, nothing pushed, as @dataBranch@ does for a constructor
-- without an arm) when the match has one, and anything else exits to the
-- interpreter, which raises its own error.
--
-- The field count native code reads is always the object's: for shapes 0
-- to 6 the pointer tag that selected the arm is the count; a wide
-- constructor's arm first checks the object's two arrays hold exactly
-- its count ('requireWide'). No declaration of the type is consulted, so
-- code whose types the runtime never saw declared (code sent over the
-- network) compiles like any other, and a value with an unusual field
-- count is read as far as it goes and never past.
--
-- What that leaves is type confusion: a match on type T applied to a
-- value of type U with the same shape, which only ill-typed code can
-- arrange (Any.unsafeExtract, a value built elsewhere) and which the
-- interpreter does not check either (its dataBranch picks the arm by
-- constructor number alone). For shapes 0 to 6 the layout is fixed by
-- the pointer tag, so such a value is at worst matched wrongly. For the
-- shared tag 7 the info pointer only says "some type's wide
-- constructor", so a lone wide arm compares the whole packed tag, type
-- number included, before reading.
genDMatchClosure :: FnEnv -> Int -> Int -> Maybe Reference -> GBranch (RComb Val) -> MSection -> Gen ()
genDMatchClosure :: FnEnv
-> Int
-> Int
-> Maybe Reference
-> GBranch (RComb Val)
-> MSection
-> Gen ()
genDMatchClosure FnEnv
fe Int
d Int
i Maybe Reference
mr GBranch (RComb Val)
br MSection
sect = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      ls :: Layouts
ls = Env -> Layouts
envLayouts Env
env
  Text
p <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
  Text
raw <- Text -> Gen Text
fresh Text
"raw"
  Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
other <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
  case GBranch (RComb Val)
br of
    TestT {} -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
    TestY {} -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
    GBranch (RComb Val)
_ -> do
      Text
tagBits <- Text -> Gen Text
fresh Text
"ptrtag"
      Text -> Gen ()
emit (Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
      Text
base <- Text -> Gen Text
fresh Text
"base"
      Text -> Gen ()
emit (Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = sub i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagBits)
      let -- the constructors with an arm, with the field count each binds
          ctors :: [(Word64, Int)]
ctors = [(Word64
u, Int
n) | (Word64
u, Arm Int
n MSection
_) <- GBranch (RComb Val) -> [(Word64, Arm (RComb Val))]
forall c. GBranch c -> [(Word64, Arm c)]
branchArms GBranch (RComb Val)
br]
          shapeOf :: a -> a
shapeOf a
n = a -> a -> a
forall a. Ord a => a -> a -> a
min a
n a
7 -- 7 is DataG
          layoutOf :: Int -> Layout
layoutOf Int
s = if Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6 then Layouts -> Vector Layout
lData Layouts
ls Vector Layout -> Int -> Layout
forall a. Vector a -> Int -> a
V.! Int
s else Layouts -> Layout
lDataG Layouts
ls
          armsOfShape :: Int -> [(Word64, Int)]
armsOfShape Int
s = [(Word64, Int)
c | c :: (Word64, Int)
c@(Word64
_, Int
n) <- [(Word64, Int)]
ctors, Int -> Int
forall {a}. (Ord a, Num a) => a -> a
shapeOf Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
s]
          -- a default arm of the match's own, as opposed to the "missing
          -- case" the emitter puts where the source had none
          hasDefault :: Bool
hasDefault = case GBranch (RComb Val) -> MSection
forall c. GBranch c -> GSection c
branchDefaultOf GBranch (RComb Val)
br of
            Die String
_ -> Bool
False
            MSection
_ -> Bool
True
          -- an arm off to the side; one that can't be generated exits at the match
          armBlock :: Text -> Gen () -> Gen Text
armBlock Text
name Gen ()
code = do
            Text
label <- Text -> Gen Text
freshLabel Text
name
            Bool
ok <- Gen () -> StateT GS Identity Bool
attempt (Gen () -> Gen ()
forall a. Gen a -> Gen a
withKinds (Text -> Gen () -> Gen ()
sideBlockNamed Text
label Gen ()
code))
            Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ Text -> Gen () -> Gen ()
sideBlockNamed Text
label (FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect)
            pure Text
label
      Maybe Text
defaultL <-
        if Bool
hasDefault
          then Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Gen Text -> Gen (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Gen () -> Gen Text
armBlock Text
"default" (FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe Int
d (GBranch (RComb Val) -> MSection
forall c. GBranch c -> GSection c
branchDefaultOf GBranch (RComb Val)
br))
          else Maybe Text -> Gen (Maybe Text)
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
      let -- where a data value of a constructor without an arm goes
          noArm :: Text
noArm = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
other Text -> Text
forall a. a -> a
id Maybe Text
defaultL
          armFor :: (Word64, Int) -> Gen Text
armFor (Word64
u, Int
n) = case GBranch (RComb Val) -> Word64 -> Maybe (Arm (RComb Val))
forall c. GBranch c -> Word64 -> Maybe (Arm c)
branchArmOf GBranch (RComb Val)
br Word64
u of
            Maybe (Arm (RComb Val))
Nothing -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
noArm
            Just (Arm Int
_ MSection
body) -> Text -> Gen () -> Gen Text
armBlock Text
"case" (Gen () -> Gen Text) -> Gen () -> Gen Text
forall a b. (a -> b) -> a -> b
$ do
              Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
7) (FnEnv -> Text -> Int -> Text -> Gen ()
requireWide FnEnv
fe Text
base Int
n Text
other)
              Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (FnEnv -> Int -> Text -> Int -> Text -> Gen ()
pushFields FnEnv
fe Int
d Text
base Int
n Text
other)
              FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) MSection
body
          -- the block for a shape: the arm itself when it is the only one
          -- and no constructor is without an arm; otherwise a load of the
          -- packed tag at the shape's offset and a switch on the
          -- constructor number, or for a lone wide constructor a compare
          -- of the whole tag
          shapeBlock :: Int -> Gen Text
shapeBlock Int
s = case Int -> [(Word64, Int)]
armsOfShape Int
s of
            [] -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
noArm
            [(Word64, Int)]
cs -> do
              [Pair Word64 Text]
arms <- [(Word64, Int)]
-> ((Word64, Int) -> StateT GS Identity (Pair Word64 Text))
-> StateT GS Identity [Pair Word64 Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Word64, Int)]
cs (((Word64, Int) -> StateT GS Identity (Pair Word64 Text))
 -> StateT GS Identity [Pair Word64 Text])
-> ((Word64, Int) -> StateT GS Identity (Pair Word64 Text))
-> StateT GS Identity [Pair Word64 Text]
forall a b. (a -> b) -> a -> b
$ \(Word64, Int)
c -> Word64 -> Text -> Pair Word64 Text
forall a b. a -> b -> Pair a b
Pair ((Word64, Int) -> Word64
forall a b. (a, b) -> a
fst (Word64, Int)
c) (Text -> Pair Word64 Text)
-> Gen Text -> StateT GS Identity (Pair Word64 Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Int) -> Gen Text
armFor (Word64, Int)
c
              case [Pair Word64 Text]
arms of
                [Pair Word64
_ Text
al] | Bool -> Bool
not Bool
hasDefault, Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
7 -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
al
                [Pair Word64 Text]
_ -> do
                  Text
l <- Text -> Gen Text
freshLabel (if Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7 then Text
"wide" else Text
"shape")
                  Text -> Gen () -> Gen ()
sideBlockNamed Text
l (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
                    let layout :: Layout
layout = Int -> Layout
layoutOf Int
s
                    Text
addr <- Text -> Gen Text
fresh Text
"tag.a"
                    Text -> Gen ()
emit (Text
addr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int -> Int
lFieldOffset Layout
layout (Layout -> Int
lPtrs Layout
layout)))
                    Text
ptr <- Text -> Gen Text
fresh Text
"tag.p"
                    Text -> Gen ()
emit (Text
ptr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
addr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
                    Text
packed <- Text -> Gen Text
fresh Text
"packed"
                    Text -> Gen ()
emit (Text
packed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ptr)
                    case [Pair Word64 Text]
arms of
                      [Pair Word64
u Text
al]
                        | Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7,
                          Just Word64
rt <- Maybe Reference
mr Maybe Reference -> (Reference -> Maybe Word64) -> Maybe Word64
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Reference
r -> Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r (Env -> Map Reference Word64
envTypeNumbers Env
env) -> do
                            let PackedTag Word64
want = RTag -> CTag -> PackedTag
TT.packTags (Word64 -> RTag
TT.RTag Word64
rt) (Word16 -> CTag
TT.CTag (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
u))
                            Text
ok <- Text -> Gen Text
fresh Text
"sametag"
                            Text -> Gen ()
emit (Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
packed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
want)
                            Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
al Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
noArm)
                      [Pair Word64 Text]
_ -> do
                        Text
tag <- Text -> Gen Text
fresh Text
"tag"
                        Text -> Gen ()
emit (Text
tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
packed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 65535") -- maskTags
                        Text -> Gen ()
emit (Text
"switch i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
noArm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Deque Text -> Text
intercalateT Text
" " ([Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ((Pair Word64 Text -> Text) -> [Pair Word64 Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Pair Word64
u Text
al) -> Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
al) [Pair Word64 Text]
arms)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
                  pure Text
l
      -- every data shape gets a block: a shape with no arm goes to the
      -- default arm (or exits, without one)
      [Pair Layout Text]
entries <- [Int]
-> (Int -> StateT GS Identity (Pair Layout Text))
-> StateT GS Identity [Pair Layout Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. Int
7] ((Int -> StateT GS Identity (Pair Layout Text))
 -> StateT GS Identity [Pair Layout Text])
-> (Int -> StateT GS Identity (Pair Layout Text))
-> StateT GS Identity [Pair Layout Text]
forall a b. (a -> b) -> a -> b
$ \Int
s -> Layout -> Text -> Pair Layout Text
forall a b. a -> b -> Pair a b
Pair (Int -> Layout
layoutOf Int
s) (Text -> Pair Layout Text)
-> Gen Text -> StateT GS Identity (Pair Layout Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Text
shapeBlock Int
s
      let owns :: [Pair Int Text]
owns = [Int -> Text -> Pair Int Text
forall a b. a -> b -> Pair a b
Pair (Layout -> Int
lPtrTag Layout
layout) Text
l | Pair Layout
layout Text
l <- [Pair Layout Text]
entries, Layout -> Int
lPtrTag Layout
layout Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
7, Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
other]
          shared :: [Pair Int Text]
shared = [Int -> Text -> Pair Int Text
forall a b. a -> b -> Pair a b
Pair (Layout -> Int
lInfo Layout
layout) Text
l | Pair Layout
layout Text
l <- [Pair Layout Text]
entries, Layout -> Int
lPtrTag Layout
layout Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7, Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
other]
      Text
sevenL <-
        if [Pair Int Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pair Int Text]
shared
          then Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
other
          else do
            Text
l <- Text -> Gen Text
freshLabel Text
"shape7"
            Text -> Gen () -> Gen ()
sideBlockNamed Text
l (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
              Text
bp <- Text -> Gen Text
fresh Text
"base.p"
              Text -> Gen ()
emit (Text
bp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
              Text
info <- Text -> Gen Text
fresh Text
"info"
              Text -> Gen ()
emit (Text
info Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bp)
              Text -> Gen ()
emit (Text
"switch i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
info Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
other Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Deque Text -> Text
intercalateT Text
" " ([Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ((Pair Int Text -> Text) -> [Pair Int Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Pair Int
inf Text
al) -> Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
inf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
al) [Pair Int Text]
shared)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
            pure Text
l
      Text -> Gen ()
emit (Text
"switch i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
other Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Deque Text -> Text
intercalateT Text
" " ([Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ((Pair Int Text -> Text) -> [Pair Int Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Pair Int
t Text
l) -> Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l) [Pair Int Text]
owns [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"i64 7, label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sevenL | Text
sevenL Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
other])) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")

-- | Branches to @bad@ unless the wide constructor (@GDataG@) at untagged
-- address @base@ holds exactly @n@ fields: its boxed array has @n@
-- elements and its unboxed array @8n@ bytes. The two arrays are built from
-- one field list everywhere ('Unison.Runtime.Stack.segFromList', the
-- value decoder, 'genPack'), so a well-formed object passes; the check is
-- what lets an arm read @n@ fields of an object it knows nothing else
-- about. The interpreter's @dumpSeg@ reads the same two lengths.
requireWide :: FnEnv -> Text -> Int -> Text -> Gen ()
requireWide :: FnEnv -> Text -> Int -> Text -> Gen ()
requireWide FnEnv
fe Text
base Int
n Text
bad = do
  let ls :: Layouts
ls = Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe)
      rts :: RtsFacts
rts = Env -> RtsFacts
envRts (FnEnv -> Env
feEnv FnEnv
fe)
      layout :: Layout
layout = Layouts -> Layout
lDataG Layouts
ls
      loadFrom :: Text -> Text -> a -> Gen Text
loadFrom Text
from Text
what a
off = do
        Text
a <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a")
        Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
from Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow a
off)
        Text
pp <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".p")
        Text -> Gen ()
emit (Text
pp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
        Text
v <- Text -> Gen Text
fresh Text
what
        Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pp)
        pure Text
v
  Text
useg <- Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> a -> Gen Text
loadFrom Text
base Text
"useg" (Layout -> Int -> Int
lFieldOffset Layout
layout Int
0)
  Text
bseg <- Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> a -> Gen Text
loadFrom Text
base Text
"bseg" (Layout -> Int -> Int
lFieldOffset Layout
layout Int
1)
  Text
bytes <- Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> a -> Gen Text
loadFrom Text
useg Text
"ubytes" (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* RtsFacts -> Int
rBytesCount RtsFacts
rts)
  Text
ptrs <- Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> a -> Gen Text
loadFrom Text
bseg Text
"bptrs" (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* RtsFacts -> Int
rPtrsCount RtsFacts
rts)
  Text
okU <- Text -> Gen Text
fresh Text
"wide.u"
  Text -> Gen ()
emit (Text
okU Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bytes Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n))
  Text
okB <- Text -> Gen Text
fresh Text
"wide.b"
  Text -> Gen ()
emit (Text
okB Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ptrs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n)
  Text
ok <- Text -> Gen Text
fresh Text
"wide"
  Text -> Gen ()
emit (Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
okU Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
okB)
  Text
narrow <- Text -> Gen Text
fresh Text
"narrow"
  Text -> Gen ()
emit (Text
narrow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = xor i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", true")
  Text -> Text -> Text -> Gen ()
branchIf Text
"wide" Text
narrow Text
bad

-- | The arms of a branch with their constructor numbers (none for a text
-- or bytes match).
branchArms :: GBranch c -> [(Word64, Arm c)]
branchArms :: forall c. GBranch c -> [(Word64, Arm c)]
branchArms = \case
  Test1 Word64
v Arm c
cv GSection c
_ -> [(Word64
v, Arm c
cv)]
  Test2 Word64
v Arm c
cv Word64
w Arm c
cw GSection c
_ -> [(Word64
v, Arm c
cv), (Word64
w, Arm c
cw)]
  TestW GSection c
_ EnumMap Word64 (Arm c)
cs -> EnumMap Word64 (Arm c) -> [(Word64, Arm c)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (Arm c)
cs
  GBranch c
_ -> []

-- | The arm of a branch for a constructor number, if it has one.
branchArmOf :: GBranch c -> Word64 -> Maybe (Arm c)
branchArmOf :: forall c. GBranch c -> Word64 -> Maybe (Arm c)
branchArmOf GBranch c
br Word64
u = case GBranch c
br of
  Test1 Word64
v Arm c
cv GSection c
_ -> if Word64
u Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
v then Arm c -> Maybe (Arm c)
forall a. a -> Maybe a
Just Arm c
cv else Maybe (Arm c)
forall a. Maybe a
Nothing
  Test2 Word64
v Arm c
cv Word64
w Arm c
cw GSection c
_ -> if Word64
u Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
v then Arm c -> Maybe (Arm c)
forall a. a -> Maybe a
Just Arm c
cv else if Word64
u Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
w then Arm c -> Maybe (Arm c)
forall a. a -> Maybe a
Just Arm c
cw else Maybe (Arm c)
forall a. Maybe a
Nothing
  TestW GSection c
_ EnumMap Word64 (Arm c)
cs -> Word64 -> EnumMap Word64 (Arm c) -> Maybe (Arm c)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
u EnumMap Word64 (Arm c)
cs
  GBranch c
_ -> Maybe (Arm c)
forall a. Maybe a
Nothing

-- | The default arm of a branch.
branchDefaultOf :: GBranch c -> GSection c
branchDefaultOf :: forall c. GBranch c -> GSection c
branchDefaultOf = \case
  Test1 Word64
_ Arm c
_ GSection c
df -> GSection c
df
  Test2 Word64
_ Arm c
_ Word64
_ Arm c
_ GSection c
df -> GSection c
df
  TestW GSection c
df EnumMap Word64 (Arm c)
_ -> GSection c
df
  TestT GSection c
df Map Text (GSection c)
_ -> GSection c
df
  TestY GSection c
df Map Bytes (GSection c)
_ -> GSection c
df

-- | Loads the packed tag of the data closure whose tagged pointer is the
-- i64 in @raw@, admitting the given shapes: a switch on the pointer tag
-- for the shapes that have their own, then, for pointer tag 7, a switch
-- on the info pointer for the shapes that share it. Anything else
-- branches to @other@. Gives the untagged address and the tag word.
-- | Loads the packed tag of the data closure whose tagged address is
-- @raw@, whatever its shape among @kinds@ (anything else branches to
-- @other@). Gives the untagged address, the packed tag and the shape found,
-- as an index into @kinds@.
loadPackedTag :: Text -> Text -> [Layout] -> Gen (Triple Text Text Text)
loadPackedTag :: Text -> Text -> [Layout] -> Gen (Triple Text Text Text)
loadPackedTag Text
raw Text
other [Layout]
kinds = do
  Text
tagBits <- Text -> Gen Text
fresh Text
"ptrtag"
  Text -> Gen ()
emit (Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
  Text
base <- Text -> Gen Text
fresh Text
"base"
  Text -> Gen ()
emit (Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = sub i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagBits)
  Text
dispatch <- Text -> Gen Text
freshLabel Text
"dispatch"
  let own :: [Layout]
own = (Layout -> Bool) -> [Layout] -> [Layout]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
7) (Int -> Bool) -> (Layout -> Int) -> Layout -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Int
lPtrTag) [Layout]
kinds
      shared :: [Layout]
shared = (Layout -> Bool) -> [Layout] -> [Layout]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7) (Int -> Bool) -> (Layout -> Int) -> Layout -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Int
lPtrTag) [Layout]
kinds
      -- one block per shape, loading the packed tag from its offset
      loadIn :: Layout -> StateT GS Identity (Triple Layout Text Text)
loadIn Layout
layout = do
        Text
l <- Text -> Gen Text
freshLabel Text
"kind"
        Text
packed <- Text -> Gen Text
fresh Text
"packed"
        Text -> Gen () -> Gen ()
sideBlockNamed Text
l (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
          Text
addr <- Text -> Gen Text
fresh Text
"tag.a"
          Text -> Gen ()
emit (Text
addr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int -> Int
lFieldOffset Layout
layout (Layout -> Int
lPtrs Layout
layout)))
          Text
ptr <- Text -> Gen Text
fresh Text
"tag.p"
          Text -> Gen ()
emit (Text
ptr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
addr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
          Text -> Gen ()
emit (Text
packed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ptr)
          Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dispatch)
        pure (Layout -> Text -> Text -> Triple Layout Text Text
forall a b c. a -> b -> c -> Triple a b c
Triple Layout
layout Text
l Text
packed)
  [Triple Layout Text Text]
owns <- (Layout -> StateT GS Identity (Triple Layout Text Text))
-> [Layout] -> StateT GS Identity [Triple Layout Text Text]
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 Layout -> StateT GS Identity (Triple Layout Text Text)
loadIn [Layout]
own
  [Triple Layout Text Text]
shareds <- (Layout -> StateT GS Identity (Triple Layout Text Text))
-> [Layout] -> StateT GS Identity [Triple Layout Text Text]
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 Layout -> StateT GS Identity (Triple Layout Text Text)
loadIn [Layout]
shared
  Text
sevenL <-
    if [Triple Layout Text Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Triple Layout Text Text]
shareds
      then Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
other
      else do
        Text
l <- Text -> Gen Text
freshLabel Text
"kind7"
        Text -> Gen () -> Gen ()
sideBlockNamed Text
l (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
          Text
bp <- Text -> Gen Text
fresh Text
"base.p"
          Text -> Gen ()
emit (Text
bp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
          Text
info <- Text -> Gen Text
fresh Text
"info"
          Text -> Gen ()
emit (Text
info Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bp)
          Text -> Gen ()
emit (Text
"switch i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
info Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
other Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Deque Text -> Text
intercalateT Text
" " ([Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ((Triple Layout Text Text -> Text)
-> [Triple Layout Text Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Triple Layout
layout Text
l' Text
_) -> Text
" i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lInfo Layout
layout) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l') [Triple Layout Text Text]
shareds)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
        pure Text
l
  Text -> Gen ()
emit (Text
"switch i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
other Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Deque Text -> Text
intercalateT Text
" " ([Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ((Triple Layout Text Text -> Text)
-> [Triple Layout Text Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Triple Layout
layout Text
l Text
_) -> Text
" i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lPtrTag Layout
layout) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l) [Triple Layout Text Text]
owns [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
" i64 7, label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sevenL | Bool -> Bool
not ([Triple Layout Text Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Triple Layout Text Text]
shareds)])) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  Text -> Gen ()
startBlock Text
dispatch
  Text
packed <- Text -> Gen Text
fresh Text
"packed"
  Text -> Gen ()
emit (Text
packed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Deque Text -> Text
intercalateT Text
", " ([Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ((Triple Layout Text Text -> Text)
-> [Triple Layout Text Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Triple Layout
_ Text
l Text
v) -> Text
"[ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]") ([Triple Layout Text Text]
owns [Triple Layout Text Text]
-> [Triple Layout Text Text] -> [Triple Layout Text Text]
forall a. [a] -> [a] -> [a]
++ [Triple Layout Text Text]
shareds))))
  Text
shape <- Text -> Gen Text
fresh Text
"shape"
  let indexOf :: Layout -> Int
indexOf Layout
layout = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Int -> Int
forall a. a -> a
id (Int -> [(Int, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Layout -> Int
lInfo Layout
layout) ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Layout -> Int) -> [Layout] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Layout -> Int
lInfo [Layout]
kinds) [Int
0 :: Int ..]))
  Text -> Gen ()
emit (Text
shape Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Deque Text -> Text
intercalateT Text
", " ([Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ((Triple Layout Text Text -> Text)
-> [Triple Layout Text Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Triple Layout
layout Text
l Text
_) -> Text
"[ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
indexOf Layout
layout) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]") ([Triple Layout Text Text]
owns [Triple Layout Text Text]
-> [Triple Layout Text Text] -> [Triple Layout Text Text]
forall a. [a] -> [a] -> [a]
++ [Triple Layout Text Text]
shareds))))
  pure (Text -> Text -> Text -> Triple Text Text Text
forall a b c. a -> b -> c -> Triple a b c
Triple Text
base Text
packed Text
shape)

-- | A match on a request closure (an affine handler's @RMatch@). The
-- closure is a data constructor like any other; its packed tag is
-- @ability << 16 | constructor@, and zero for the pure request, @Data1
-- effectRef 0 v@, whose one field is the handled computation's value. The
-- branches are keyed by ability number, then constructor, and an arm
-- pushes its constructor's fields as a data match does, its count from
-- the arm itself ('Arm') once the object is seen to have
-- that shape: the pointer tag's (and for tag 7 the info pointer's) shape
-- must be the count's, and a wide constructor's arrays must hold exactly
-- the count ('requireWide'). An ability or constructor without an arm, or
-- a closure of another kind or shape, is the interpreter's (it dies with
-- "unhandled ability").
genRMatch :: FnEnv -> Int -> Int -> MSection -> EC.EnumMap Word64 (GBranch (RComb Val)) -> MSection -> Gen ()
genRMatch :: FnEnv
-> Int
-> Int
-> MSection
-> EnumMap Word64 (GBranch (RComb Val))
-> MSection
-> Gen ()
genRMatch FnEnv
fe Int
d Int
i MSection
pu EnumMap Word64 (GBranch (RComb Val))
br MSection
sect = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      ls :: Layouts
ls = Env -> Layouts
envLayouts Env
env
      kinds :: [Layout]
kinds = Vector Layout -> [Layout]
forall a. Vector a -> [a]
V.toList (Layouts -> Vector Layout
lData Layouts
ls) [Layout] -> [Layout] -> [Layout]
forall a. [a] -> [a] -> [a]
++ [Layouts -> Layout
lDataG Layouts
ls]
  Text
p <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
  Text
raw <- Text -> Gen Text
fresh Text
"raw"
  Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
other <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
  Triple Text
base Text
packed Text
shape <- Text -> Text -> [Layout] -> Gen (Triple Text Text Text)
loadPackedTag Text
raw Text
other [Layout]
kinds
  let PackedTag Word64
pureTag = PackedTag
TT.pureEffectTag
      -- the object must have the shape of an arm's count before the arm
      -- reads that many fields
      requireShape :: Int -> Gen ()
requireShape Int
n = do
        Text
wrong <- Text -> Gen Text
fresh Text
"shape.ne"
        Text -> Gen ()
emit (Text
wrong Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shape Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
7 :: Int))
        Text -> Text -> Text -> Gen ()
branchIf Text
"shape" Text
wrong Text
other
        Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
7) (FnEnv -> Text -> Int -> Text -> Gen ()
requireWide FnEnv
fe Text
base Int
n Text
other)
  Text
isPure <- Text -> Gen Text
fresh Text
"pure"
  Text -> Gen ()
emit (Text
isPure Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
packed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
pureTag)
  Text
pureL <- Text -> Gen Text
freshLabel Text
"pure"
  Text
reqL <- Text -> Gen Text
freshLabel Text
"request"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
isPure Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pureL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reqL)
  Bool
okPure <- Gen () -> StateT GS Identity Bool
attempt (Gen () -> Gen ()
forall a. Gen a -> Gen a
withKinds (Text -> Gen () -> Gen ()
sideBlockNamed Text
pureL (Int -> Gen ()
requireShape Int
1 Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FnEnv -> Int -> Text -> Int -> Text -> Gen ()
pushFields FnEnv
fe Int
d Text
base Int
1 Text
other Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MSection
pu)))
  Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
okPure (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ Text -> Gen () -> Gen ()
sideBlockNamed Text
pureL (FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect)
  Text -> Gen ()
startBlock Text
reqL
  Text
ability <- Text -> Gen Text
fresh Text
"ability"
  Text -> Gen ()
emit (Text
ability Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = lshr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
packed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 16")
  Text
ctor <- Text -> Gen Text
fresh Text
"ctor"
  Text -> Gen ()
emit (Text
ctor Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
packed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 65535") -- maskTags
  [Pair Word64 Text]
arms <- [(Word64, GBranch (RComb Val))]
-> ((Word64, GBranch (RComb Val))
    -> StateT GS Identity (Pair Word64 Text))
-> StateT GS Identity [Pair Word64 Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EnumMap Word64 (GBranch (RComb Val))
-> [(Word64, GBranch (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (GBranch (RComb Val))
br) (((Word64, GBranch (RComb Val))
  -> StateT GS Identity (Pair Word64 Text))
 -> StateT GS Identity [Pair Word64 Text])
-> ((Word64, GBranch (RComb Val))
    -> StateT GS Identity (Pair Word64 Text))
-> StateT GS Identity [Pair Word64 Text]
forall a b. (a -> b) -> a -> b
$ \(Word64
e, GBranch (RComb Val)
gb) -> do
    Text
l <- Text -> Gen Text
freshLabel Text
"ability"
    let arm :: Word64 -> Arm (RComb Val) -> Gen ()
arm Word64
_ (Arm Int
n MSection
body)
          | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> Gen ()
requireShape Int
0 Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe Int
d MSection
body
          | Bool
otherwise = Int -> Gen ()
requireShape Int
n Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FnEnv -> Int -> Text -> Int -> Text -> Gen ()
pushFields FnEnv
fe Int
d Text
base Int
n Text
other Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) MSection
body
    Text -> Gen () -> Gen ()
sideBlockNamed Text
l (FnEnv
-> Int
-> Text
-> GBranch (RComb Val)
-> MSection
-> (Word64 -> Arm (RComb Val) -> Gen ())
-> Gen ()
genBranchWith FnEnv
fe Int
d Text
ctor GBranch (RComb Val)
gb MSection
sect Word64 -> Arm (RComb Val) -> Gen ()
arm)
    pure (Word64 -> Text -> Pair Word64 Text
forall a b. a -> b -> Pair a b
Pair Word64
e Text
l)
  Text -> Gen ()
emit (Text
"switch i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ability Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
other Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Deque Text -> Text
intercalateT Text
" " ([Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ((Pair Word64 Text -> Text) -> [Pair Word64 Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Pair Word64
e Text
l) -> Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l) [Pair Word64 Text]
arms)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")

-- | Pushes the @n@ fields of the constructor closure at untagged address
-- @base@ onto slots d+1..d+n, first field on top (as the interpreter's
-- @dumpSeg@ does).
pushFields :: FnEnv -> Int -> Text -> Int -> Text -> Gen ()
pushFields :: FnEnv -> Int -> Text -> Int -> Text -> Gen ()
pushFields FnEnv
fe Int
d Text
base Int
n Text
_slow = do
  let ls :: Layouts
ls = Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe)
      rts :: RtsFacts
rts = Env -> RtsFacts
envRts (FnEnv -> Env
feEnv FnEnv
fe)
      loadFrom :: Text -> Text -> Text -> a -> Gen Text
loadFrom Text
from Text
what Text
ty a
off = do
        Text
a <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a")
        Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
from Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow a
off)
        Text
pp <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".p")
        Text -> Gen ()
emit (Text
pp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
        Text
v <- Text -> Gen Text
fresh Text
what
        Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pp)
        pure Text
v
      loadAt :: Text -> Text -> Int -> Gen Text
loadAt = Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
base
  if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6
    then do
      -- field j: pointer j and non-pointer 1 + j (after the tag)
      let layout :: Layout
layout = Layouts -> Vector Layout
lData Layouts
ls Vector Layout -> Int -> Layout
forall a. Vector a -> Int -> a
V.! Int
n
      [Int] -> (Int -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> Gen ()) -> Gen ()) -> (Int -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j -> do
        Text
b <- Text -> Text -> Int -> Gen Text
loadAt Text
"fb" Text
"ptr" (Layout -> Int -> Int
lFieldOffset Layout
layout Int
j)
        Text
u <- Text -> Text -> Int -> Gen Text
loadAt Text
"fu" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout (Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j))
        Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Text
u Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Text
b
    else do
      -- DataG: the two arrays, which hold the fields in reverse, so
      -- element j goes to slot d+1+j
      let layout :: Layout
layout = Layouts -> Layout
lDataG Layouts
ls
      Text
usegI <- Text -> Text -> Int -> Gen Text
loadAt Text
"useg" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout Int
0)
      Text
bsegI <- Text -> Text -> Int -> Gen Text
loadAt Text
"bseg" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout Int
1)
      [Int] -> (Int -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> Gen ()) -> Gen ()) -> (Int -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j -> do
        Text
u <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
usegI Text
"fu" Text
"i64" (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (RtsFacts -> Int
rBytesHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j))
        Text
b <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
bsegI Text
"fb" Text
"ptr" (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (RtsFacts -> Int
rPtrsHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j))
        Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j) Text
u Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j) Text
b

-- | The slots that an argument list selects, top first, as frame offsets.
-- @VArgV@ means "everything in the frame above index i", and the frame
-- the interpreter sees is the innermost inline binding's, if any.
argSources :: FnEnv -> Int -> Args -> Deque Int
argSources :: FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d = \case
  Args
ZArgs -> Deque Int
forall a. Deque a
D.empty
  VArg1 Int
i -> Int -> Deque Int
forall a. a -> Deque a
D.singleton (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
  VArg2 Int
i Int
j -> [Int] -> Deque Int
forall a. [a] -> Deque a
D.fromList [Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i, Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j]
  VArgR Int
i Int
l -> [Int] -> Deque Int
forall a. [a] -> Deque a
D.fromList [Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k | Int
k <- [Int
0 .. Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
  VArgN PrimArray Int
v -> [Int] -> Deque Int
forall a. [a] -> Deque a
D.fromList [Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i | Int
i <- PrimArray Int -> [Int]
forall a. Prim a => PrimArray a -> [a]
primArrayToList PrimArray Int
v]
  VArgV Int
i -> [Int] -> Deque Int
forall a. [a] -> Deque a
D.fromList [Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k | Int
k <- [Int
0 .. (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
base) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
  where
    base :: Int
base = FnEnv -> Int
currentBase FnEnv
fe

-- | Loads the selected values into registers (a parallel move must read everything first).
loadSources :: Deque Int -> Gen (Deque (Pair Text Text))
loadSources :: Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources = (Int -> Gen (Pair Text Text))
-> Deque Int -> StateT GS Identity (Deque (Pair Text Text))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Deque a -> f (Deque b)
traverse (\Int
k -> Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair (Text -> Text -> Pair Text Text)
-> Gen Text -> StateT GS Identity (Text -> Pair Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Text
loadU Int
k StateT GS Identity (Text -> Pair Text Text)
-> Gen Text -> Gen (Pair Text Text)
forall a b.
StateT GS Identity (a -> b)
-> StateT GS Identity a -> StateT GS Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Gen Text
loadB Int
k)

-- | Return: move the results into place as @moveArgs@ then @frameArgs@ would,
-- and hand them to the continuation.
genYield :: FnEnv -> Int -> Args -> MSection -> Gen ()
genYield :: FnEnv -> Int -> Args -> MSection -> Gen ()
genYield FnEnv
fe Int
d Args
args MSection
_sect
  | Enclosing
e :<| Deque Enclosing
_ <- FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe = do
      -- inside an inline binding: the results go to the body
      let srcs :: Deque Int
srcs = FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args
          n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs
      if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Enclosing -> Int
enResults Enclosing
e
        then Text -> Gen ()
failWith Text
"binding yields the wrong number of values"
        else do
          Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FnEnv -> Bool
localEnds FnEnv
fe) (FnEnv -> Gen ()
endLocal FnEnv
fe)
          Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
srcs
          Deque (Pair Text Text)
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall (m :: * -> *) a.
Monad m =>
Deque a -> (Int -> a -> m ()) -> m ()
iforM_ Deque (Pair Text Text)
vals ((Int -> Pair Text Text -> Gen ()) -> Gen ())
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j (Pair Text
u Text
b) -> do
            Int -> Text -> Gen ()
storeU (Enclosing -> Int
enBase Enclosing
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Text
u
            Int -> Text -> Gen ()
storeB (Enclosing -> Int
enBase Enclosing
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Text
b
          Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Enclosing -> Text
enBody Enclosing
e)
genYield FnEnv
fe Int
d Args
args MSection
sect = do
  let base :: Int
base = FnEnv -> Int
feBase FnEnv
fe
  -- pending arguments (fp /= ap) mean over-application; leave that to the interpreter
  Text
pending <- Text -> Gen Text
fresh Text
"pending"
  Text -> Gen ()
emit (Text
pending Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 %ap, %fpb")
  Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
  Text
fast <- Text -> Gen Text
freshLabel Text
"yield"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pending Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fast Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Text -> Gen ()
startBlock Text
fast
  Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FnEnv -> Bool
localEnds FnEnv
fe) (FnEnv -> Gen ()
endLocal FnEnv
fe)
  let srcs :: Deque Int
srcs = FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args
      n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs
  Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
srcs
  -- a worker hands its one result back in registers
  if FnEnv -> Bool
feWorker FnEnv
fe
    then case Deque (Pair Text Text)
vals of
      Pair Text
u Text
b :<| Deque (Pair Text Text)
Empty -> Text -> Text -> Text -> Gen ()
retWorker Text
"0" Text
u Text
b
      Deque (Pair Text Text)
_ -> (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsFailed = Just "a worker yields other than one value", gsNotWorker = True})
    else FnEnv -> Int -> Int -> Deque (Pair Text Text) -> Gen ()
genYieldStack FnEnv
fe Int
base Int
n Deque (Pair Text Text)
vals

-- | The rest of a return through the stack: the results go above the
-- frame base, and the stack pointers into @Ctx@.
genYieldStack :: FnEnv -> Int -> Int -> Deque (Pair Text Text) -> Gen ()
genYieldStack :: FnEnv -> Int -> Int -> Deque (Pair Text Text) -> Gen ()
genYieldStack FnEnv
fe Int
base Int
n Deque (Pair Text Text)
vals = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
  Deque (Pair Text Text)
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall (m :: * -> *) a.
Monad m =>
Deque a -> (Int -> a -> m ()) -> m ()
iforM_ Deque (Pair Text Text)
vals ((Int -> Pair Text Text -> Gen ()) -> Gen ())
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j (Pair Text
u Text
b) -> do
    Text
ua <- Int -> Gen Text
stackAddrU (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
    Text
ba <- Int -> Gen Text
stackAddrB (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
  Text
ap <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oAp
  Text -> Gen ()
emit (Text
"store i64 %ap, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ap)
  Text
fp <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oFp
  Text -> Gen ()
emit (Text
"store i64 %ap, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fp) -- frameArgs: fp = ap
  Text
sp <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oSp
  Text
f <- Int -> Gen Text
fpPlus (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sp)
  Text -> Gen ()
emit Text
"ret i64 0"

-- | A tail call: to this function (a loop) or to another one through its cell.
genCall :: FnEnv -> Int -> CombIx -> RComb Val -> Args -> MSection -> Gen ()
genCall :: FnEnv -> Int -> CombIx -> RComb Val -> Args -> MSection -> Gen ()
genCall FnEnv
fe Int
d CombIx
cix RComb Val
comb Args
args MSection
sect
  -- a top-level value, evaluated when it was loaded: a constant, returned
  | Args
ZArgs <- Args
args,
    Just (Pair Int
u Int
ix) <- FnEnv -> CombIx -> RComb Val -> Maybe (Pair Int Int)
cachedConstant FnEnv
fe CombIx
cix RComb Val
comb = do
      Int -> Int -> Int -> Gen ()
pushCached Int
d Int
u Int
ix
      FnEnv -> Int -> Args -> MSection -> Gen ()
genYield FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Args
VArg1 Int
0) MSection
sect
  | Enclosing
e :<| Deque Enclosing
_ <- FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe = case RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb of
      -- a tail call inside an inline binding is a call that returns to the body
      Comb (LamI Int
arity Int
_ MSection
_ Ptr NativeCell
ccell)
        | let srcs :: Deque Int
srcs = FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args,
          Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity ->
            FnEnv
-> Int
-> Int
-> Ptr NativeCell
-> Deque Int
-> Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genNonTailCall FnEnv
fe Int
d (Enclosing -> Int
enBase Enclosing
e) Ptr NativeCell
ccell Deque Int
srcs (Enclosing -> Int
enResults Enclosing
e) MSection
sect Maybe (Pair Int Int)
forall a. Maybe a
Nothing (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
              Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Enclosing -> Text
enBody Enclosing
e)
      GComb Val (RComb Val)
_ -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  | CombIx
cix CombIx -> CombIx -> Bool
forall a. Eq a => a -> a -> Bool
== FnEnv -> CombIx
feCix FnEnv
fe,
    Just Text
headL <- FnEnv -> Maybe Text
feHead FnEnv
fe = do
      let srcs :: Deque Int
srcs = FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args
          n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs
      if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= FnEnv -> Int
feArity FnEnv
fe
        then FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
        else do
          Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
srcs
          Deque (Pair Text Text)
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall (m :: * -> *) a.
Monad m =>
Deque a -> (Int -> a -> m ()) -> m ()
iforM_ Deque (Pair Text Text)
vals ((Int -> Pair Text Text -> Gen ()) -> Gen ())
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j (Pair Text
u Text
b) -> do
            Int -> Text -> Gen ()
storeU (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Text
u
            Int -> Text -> Gen ()
storeB (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Text
b
          Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
headL)
  | Bool
otherwise = case RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb of
      Comb (LamI Int
arity Int
_ MSection
_ Ptr NativeCell
cell) -> do
        let srcs :: Deque Int
srcs = FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args
            n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs
            base :: Int
base = FnEnv -> Int
feBase FnEnv
fe
        if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
arity
          then FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
          else case Ptr NativeCell
-> Map (Ptr NativeCell) (Pair Text Int) -> Maybe (Pair Text Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ptr NativeCell
cell (Env -> Map (Ptr NativeCell) (Pair Text Int)
envWorkers Env
env) of
            -- worker to worker: a real tail call with the arguments in registers
            Just (Pair Text
wname Int
_) | FnEnv -> Bool
feWorker FnEnv
fe -> do
              Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Env -> Bool
envStressCallee Env
env) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ do
                Text
fire <- Env -> (CtxOffsets -> Int) -> (CtxOffsets -> Int) -> Gen Text
stressFire Env
env CtxOffsets -> Int
oStressCalleeLeft CtxOffsets -> Int
oStressCallee
                Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
                Text
goL <- Text -> Gen Text
freshLabel Text
"tail"
                Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fire Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
goL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
                Text -> Gen ()
startBlock Text
goL
              Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
srcs
              Text
r <- Text -> Gen Text
fresh Text
"r"
              Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerTail Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerCC Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
wname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(ptr %ctx, i64 %fpb" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Deque (Pair Text Text) -> Text
argList (Deque (Pair Text Text) -> Deque (Pair Text Text)
forall a. Deque a -> Deque a
D.reverse Deque (Pair Text Text)
vals) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
              Text -> Gen ()
emit (Text
"ret " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
workerRet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r)
            Maybe (Pair Text Int)
_ -> do
              Pair Text
fnp Text
isNull <- Env -> Ptr NativeCell -> Gen (Pair Text Text)
loadCallee Env
env Ptr NativeCell
cell
              Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
              Text
go <- Text -> Gen Text
freshLabel Text
"tail"
              Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
isNull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
go Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
              Text -> Gen ()
startBlock Text
go
              Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
srcs
              Deque (Pair Text Text)
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall (m :: * -> *) a.
Monad m =>
Deque a -> (Int -> a -> m ()) -> m ()
iforM_ Deque (Pair Text Text)
vals ((Int -> Pair Text Text -> Gen ()) -> Gen ())
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j (Pair Text
u Text
b) -> do
                Text
ua <- Int -> Gen Text
stackAddrU (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
                Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
                Text
ba <- Int -> Gen Text
stackAddrB (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
                Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
              Text
f <- Int -> Gen Text
fpPlus (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
              FnEnv -> Text -> Text -> Gen ()
tailCallThroughStack FnEnv
fe Text
fnp Text
f
      GComb Val (RComb Val)
_ -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  where
    env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe

-- | A tail call to a function with the uniform signature, its arguments
-- already on the stack above the frame base, with the stack pointer in
-- @top@. A worker can't make it (the return types differ): it returns
-- 'statusTailCall' with the code pointer and stack pointer, and whoever
-- called it makes the call.
tailCallThroughStack :: FnEnv -> Text -> Text -> Gen ()
tailCallThroughStack :: FnEnv -> Text -> Text -> Gen ()
tailCallThroughStack FnEnv
fe Text
fnp Text
top
  | FnEnv -> Bool
feWorker FnEnv
fe = do
      -- the callee's entry raises the high-water mark over its arguments
      Text
fni <- Text -> Gen Text
fresh Text
"fn"
      Text -> Gen ()
emit (Text
fni Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fnp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
      Text
tp <- Text -> Gen Text
fresh Text
"top"
      Text -> Gen ()
emit (Text
tp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
top Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
      Text -> Text -> Text -> Gen ()
retWorker (Int -> Text
forall a. Show a => a -> Text
tshow Int
statusTailCall) Text
fni Text
tp
  | Bool
otherwise = do
      Text
r <- Text -> Gen Text
fresh Text
"r"
      Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = musttail call i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fnp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(ptr %ctx, i64 %ap, i64 %fpb, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
top Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
      Text -> Gen ()
emit (Text
"ret i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r)

-- | A call to a function value (@App@). A known combinator used as a value
-- (@Env@) with the right number of arguments is a plain call. A value on
-- the stack (@Stk@) is called through its closure, see 'genClosureCall'.
-- Anything else (a dynamic-scope reference, a mismatched arity) is left
-- to the interpreter.
genApp :: FnEnv -> Int -> MRef -> Args -> MSection -> Gen ()
genApp :: FnEnv -> Int -> GRef (RComb Val) -> Args -> MSection -> Gen ()
genApp FnEnv
fe Int
d GRef (RComb Val)
r Args
args MSection
sect = case GRef (RComb Val)
r of
  MCode.Env CombIx
cix RComb Val
comb
    | CachedVal {} <- RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb, Args
ZArgs <- Args
args -> FnEnv -> Int -> CombIx -> RComb Val -> Args -> MSection -> Gen ()
genCall FnEnv
fe Int
d CombIx
cix RComb Val
comb Args
args MSection
sect
    | Comb (LamI Int
arity Int
_ MSection
_ Ptr NativeCell
_) <- RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb,
      Deque Int -> Int
forall a. Deque a -> Int
D.size (FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity ->
        FnEnv -> Int -> CombIx -> RComb Val -> Args -> MSection -> Gen ()
genCall FnEnv
fe Int
d CombIx
cix RComb Val
comb Args
args MSection
sect
    -- the combinator as a value: a constant closure, returned
    | Args
ZArgs <- Args
args,
      Just Int
ix <- FnEnv -> GRef (RComb Val) -> Maybe Int
combConstant FnEnv
fe GRef (RComb Val)
r -> do
        FnEnv -> Int -> Int -> Gen ()
poolConstant FnEnv
fe Int
d Int
ix
        FnEnv -> Int -> Args -> MSection -> Gen ()
genYield FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Args
VArg1 Int
0) MSection
sect
  Stk Int
i
    | Enclosing
e :<| Deque Enclosing
_ <- FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe ->
        FnEnv
-> Int
-> Int
-> Int
-> Deque Int
-> Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genClosureCall FnEnv
fe Int
d (Enclosing -> Int
enBase Enclosing
e) (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Deque Int
srcs (Enclosing -> Int
enResults Enclosing
e) MSection
sect Maybe (Pair Int Int)
forall a. Maybe a
Nothing (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
          Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Enclosing -> Text
enBody Enclosing
e)
    | Bool
otherwise -> FnEnv
-> Int -> Gen (Pair Text Text) -> Deque Int -> MSection -> Gen ()
genTailClosureCall FnEnv
fe Int
d (FnEnv -> Int -> Int -> Int -> Gen (Pair Text Text)
closureCallee FnEnv
fe (FnEnv -> Int
feBase FnEnv
fe Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Int
n) Deque Int
srcs MSection
sect
  -- An ability request: the handler is the closure the environment maps
  -- the ability's number to (see "Ability requests" in design.md), and
  -- it is called like any other function value, with the request as its
  -- argument and this frame as its continuation. A number the environment
  -- doesn't map to an affine handler is the interpreter's.
  Dyn Word64
key
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"requests",
      Enclosing
e :<| Deque Enclosing
_ <- FnEnv -> Deque Enclosing
feEnclosing FnEnv
fe ->
        FnEnv
-> Int
-> Int
-> Gen (Pair Text Text)
-> Gen Text
-> Deque Int
-> Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genNonTailCallWith FnEnv
fe Int
d (Enclosing -> Int
enBase Enclosing
e) (FnEnv -> Int -> Word64 -> Int -> Gen (Pair Text Text)
dynCallee FnEnv
fe (Enclosing -> Int
enBase Enclosing
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Word64
key Int
n) (FnEnv -> Int -> Gen Text
copyCaptured FnEnv
fe (Enclosing -> Int
enBase Enclosing
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)) Deque Int
srcs (Enclosing -> Int
enResults Enclosing
e) MSection
sect Maybe (Pair Int Int)
forall a. Maybe a
Nothing (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
          Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Enclosing -> Text
enBody Enclosing
e)
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"requests" -> FnEnv
-> Int -> Gen (Pair Text Text) -> Deque Int -> MSection -> Gen ()
genTailClosureCall FnEnv
fe Int
d (FnEnv -> Int -> Word64 -> Int -> Gen (Pair Text Text)
dynCallee FnEnv
fe (FnEnv -> Int
feBase FnEnv
fe Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Word64
key Int
n) Deque Int
srcs MSection
sect
  GRef (RComb Val)
_ -> FnEnv -> Int -> MSection -> Gen ()
exitResume FnEnv
fe Int
d MSection
sect
  where
    srcs :: Deque Int
srcs = FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args
    n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs

-- | A tail call to a function value whose callee is given by @getCallee@
-- (see 'closureCallee'): the arguments go above the frame base, the
-- captured ones above them, and the call goes through the stack.
genTailClosureCall :: FnEnv -> Int -> Gen (Pair Text Text) -> Deque Int -> MSection -> Gen ()
genTailClosureCall :: FnEnv
-> Int -> Gen (Pair Text Text) -> Deque Int -> MSection -> Gen ()
genTailClosureCall FnEnv
fe Int
d Gen (Pair Text Text)
getCallee Deque Int
srcs MSection
sect = do
  let base :: Int
base = FnEnv -> Int
feBase FnEnv
fe
      n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs
  -- pending arguments would be applied to the result; the interpreter's job
  Text
pending <- Text -> Gen Text
fresh Text
"pending"
  Text -> Gen ()
emit (Text
pending Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 %ap, %fpb")
  Pair Text
fnp Text
skip0 <- Gen (Pair Text Text)
getCallee
  Text
skip <- Text -> Gen Text
fresh Text
"skip"
  Text -> Gen ()
emit (Text
skip Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
skip0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pending)
  Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
  Text
go <- Text -> Gen Text
freshLabel Text
"tail"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
skip Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
go Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Text -> Gen ()
startBlock Text
go
  Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
srcs
  Deque (Pair Text Text)
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall (m :: * -> *) a.
Monad m =>
Deque a -> (Int -> a -> m ()) -> m ()
iforM_ Deque (Pair Text Text)
vals ((Int -> Pair Text Text -> Gen ()) -> Gen ())
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j (Pair Text
u Text
b) -> do
    Text
ua <- Int -> Gen Text
stackAddrU (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
    Text
ba <- Int -> Gen Text
stackAddrB (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
  Text
top <- FnEnv -> Int -> Gen Text
copyCaptured FnEnv
fe (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
  FnEnv -> Text -> Text -> Gen ()
tailCallThroughStack FnEnv
fe Text
fnp Text
top

-- | The callee of an ability request: the handler the environment in the
-- context maps the ability number to, examined like a closure in a slot
-- (null when it isn't an affine handler's, which fails the closure check).
dynCallee :: FnEnv -> Int -> Word64 -> Int -> Gen (Pair Text Text)
dynCallee :: FnEnv -> Int -> Word64 -> Int -> Gen (Pair Text Text)
dynCallee FnEnv
fe Int
from Word64
key Int
n = do
  Text
ha <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField (FnEnv -> Env
feEnv FnEnv
fe) CtxOffsets -> Int
oHenv
  Text
henv <- Text -> Gen Text
fresh Text
"henv"
  Text -> Gen ()
emit (Text
henv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ha)
  Text
h <- Text -> Gen Text
fresh Text
"handler"
  Text -> Gen ()
emit (Text
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @unison_jit_resolve_dyn(ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
henv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  FnEnv -> Int -> Text -> Int -> Gen (Pair Text Text)
closureCalleeFrom FnEnv
fe Int
from Text
h Int
n

-- | A top-level value that was evaluated when it was loaded: its unboxed
-- word and the pool index of its boxed part.
cachedConstant :: FnEnv -> CombIx -> RComb Val -> Maybe (Pair Int Int)
cachedConstant :: FnEnv -> CombIx -> RComb Val -> Maybe (Pair Int Int)
cachedConstant FnEnv
fe CombIx
cix RComb Val
comb = case RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb of
  CachedVal Word64
_ Val
v -> Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair (Val -> Int
getUnboxedVal Val
v) (Int -> Pair Int Int) -> Maybe Int -> Maybe (Pair Int Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (CombIx -> Closure -> PoolKey
KeyCached CombIx
cix (Val -> Closure
getBoxedVal Val
v)) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe))
  GComb Val (RComb Val)
_ -> Maybe (Pair Int Int)
forall a. Maybe a
Nothing

-- | Pushes a cached top-level value.
pushCached :: Int -> Int -> Int -> Gen ()
pushCached :: Int -> Int -> Int -> Gen ()
pushCached Int
d Int
u Int
ix = do
  Int -> Gen ()
usePool Int
ix
  Text
a <- Text -> Gen Text
fresh Text
"pool.a"
  Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr ptr, ptr %pool, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
ix)
  Text
v <- Text -> Gen Text
fresh Text
"const"
  Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a)
  Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Text
forall a. Show a => a -> Text
tshow Int
u)
  Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
v

-- | The pool index of a known combinator's closure (an @App@ with no
-- arguments of a combinator with some arity), if it has one.
combConstant :: FnEnv -> MRef -> Maybe Int
combConstant :: FnEnv -> GRef (RComb Val) -> Maybe Int
combConstant FnEnv
fe = \case
  MCode.Env CombIx
cix RComb Val
comb
    | Comb info :: GCombInfo (RComb Val)
info@(LamI Int
arity Int
_ MSection
_ Ptr NativeCell
_) <- RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb,
      Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ->
        PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (CombIx -> GCombInfo (RComb Val) -> PoolKey
KeyComb CombIx
cix GCombInfo (RComb Val)
info) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe))
  GRef (RComb Val)
_ -> Maybe Int
forall a. Maybe a
Nothing

-- | A non-tail call to the closure in slot @k@ with the given argument
-- slots; the callee's frame starts at @base@. See 'genNonTailCall'.
genClosureCall :: FnEnv -> Int -> Int -> Int -> Deque Int -> Int -> MSection -> Maybe (Pair Int Int) -> Gen () -> Gen ()
genClosureCall :: FnEnv
-> Int
-> Int
-> Int
-> Deque Int
-> Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genClosureCall FnEnv
fe Int
d Int
base Int
k Deque Int
srcs Int
m MSection
sect Maybe (Pair Int Int)
ownFrame Gen ()
continue =
  FnEnv
-> Int
-> Int
-> Gen (Pair Text Text)
-> Gen Text
-> Deque Int
-> Int
-> MSection
-> Maybe (Pair Int Int)
-> Gen ()
-> Gen ()
genNonTailCallWith FnEnv
fe Int
d Int
base (FnEnv -> Int -> Int -> Int -> Gen (Pair Text Text)
closureCallee FnEnv
fe (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs) Int
k (Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs)) (FnEnv -> Int -> Gen Text
copyCaptured FnEnv
fe (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs)) Deque Int
srcs Int
m MSection
sect Maybe (Pair Int Int)
ownFrame Gen ()
continue

-- | Examines the closure in slot @k@ for a call with @n@ supplied
-- arguments: it must be a @PAp@ whose arity is @n@ plus its captured
-- arguments, with compiled code, and the captured arguments must fit on
-- the stack above frame offset @from@, where 'copyCaptured' will put them.
-- Gives the code pointer and an i1 that is true when the call can't be
-- made natively. Leaves the captured count in @%cap.n@ and the segment
-- arrays in @%cap.u@ and @%cap.b@ for 'copyCaptured' (registers named per
-- call site through the suffix).
closureCallee :: FnEnv -> Int -> Int -> Int -> Gen (Pair Text Text)
closureCallee :: FnEnv -> Int -> Int -> Int -> Gen (Pair Text Text)
closureCallee FnEnv
fe Int
from Int
k Int
n = Int -> Gen Text
loadB Int
k Gen Text -> (Text -> Gen (Pair Text Text)) -> Gen (Pair Text Text)
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
p -> FnEnv -> Int -> Text -> Int -> Gen (Pair Text Text)
closureCalleeFrom FnEnv
fe Int
from Text
p Int
n

-- | 'closureCallee' for the closure pointer in register @p@.
closureCalleeFrom :: FnEnv -> Int -> Text -> Int -> Gen (Pair Text Text)
closureCalleeFrom :: FnEnv -> Int -> Text -> Int -> Gen (Pair Text Text)
closureCalleeFrom FnEnv
fe Int
from Text
p Int
n = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      ls :: Layouts
ls = Env -> Layouts
envLayouts Env
env
      layout :: Layout
layout = Layouts -> Layout
lPAp Layouts
ls
      rts :: RtsFacts
rts = Env -> RtsFacts
envRts Env
env
      loadFrom :: Text -> Text -> Text -> a -> Gen Text
loadFrom Text
from Text
what Text
ty a
off = do
        Text
a <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a")
        Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
from Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow a
off)
        Text
pp <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".p")
        Text -> Gen ()
emit (Text
pp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
        Text
v <- Text -> Gen Text
fresh Text
what
        Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pp)
        pure Text
v
  Text
raw <- Text -> Gen Text
fresh Text
"raw"
  Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
tagBits <- Text -> Gen Text
fresh Text
"ptrtag"
  Text -> Gen ()
emit (Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
  Text
notTag <- Text -> Gen Text
fresh Text
"notpap"
  Text -> Gen ()
emit (Text
notTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lPtrTag Layout
layout))
  Text
base <- Text -> Gen Text
fresh Text
"pap"
  Text -> Gen ()
emit (Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -8")
  -- The loads below are only valid for a PAp, but any closure has at
  -- least the header, and the payload words read are within the
  -- allocation of a PAp; for another kind they may read past its
  -- payload, so they are guarded by a branch.
  Text
okL <- Text -> Gen Text
freshLabel Text
"pap"
  Text
joinL <- Text -> Gen Text
freshLabel Text
"pap.join"
  Text
cur0 <- Gen Text
curLabel
  -- a PAp shares pointer tag 7 with other kinds, so the tag alone doesn't
  -- identify it: the info pointer is compared too (a dependent load the
  -- tag check saved while PAp had its own tag; measured as noise)
  [Text]
notPreds <-
    if Layout -> Int
lPtrTag Layout
layout Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
7
      then [Text
cur0] [Text] -> Gen () -> StateT GS Identity [Text]
forall a b. a -> StateT GS Identity b -> StateT GS Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
notTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
joinL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
okL)
      else do
        Text
chkL <- Text -> Gen Text
freshLabel Text
"pap.info"
        Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
notTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
joinL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
chkL)
        Text -> Gen ()
startBlock Text
chkL
        Text
info <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
base Text
"info" Text
"i64" (Int
0 :: Int)
        Text
notInfo <- Text -> Gen Text
fresh Text
"notpap"
        Text -> Gen ()
emit (Text
notInfo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
info Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lInfo Layout
layout))
        Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
notInfo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
joinL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
okL)
        pure [Text
cur0, Text
chkL]
  Text -> Gen ()
startBlock Text
okL
  Text
arity <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
base Text
"arity" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout (Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2))
  Text
cellA <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
base Text
"cell" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout (Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4))
  Text
cellP <- Text -> Gen Text
fresh Text
"cell.p"
  Text -> Gen ()
emit (Text
cellP Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cellA Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Text
fnp0 <- Text -> Gen Text
fresh Text
"fn"
  -- acquire: a module's pool entries are written before its cells (see
  -- MCode.readNativeCode)
  Text -> Gen ()
emit (Text
fnp0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load atomic ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cellP Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" acquire, align 8")
  Text
isNull <- Text -> Gen Text
fresh Text
"isnull"
  Text -> Gen ()
emit (Text
isNull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fnp0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", null")
  -- the segment's arrays are the closure's own fields
  Text
useg <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
base Text
"useg" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout Int
2)
  Text
bseg <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
base Text
"bseg" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout Int
3)
  Text
count <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
bseg Text
"count" Text
"i64" (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* RtsFacts -> Int
rPtrsCount RtsFacts
rts)
  Text
need <- Text -> Gen Text
fresh Text
"need"
  Text -> Gen ()
emit (Text
need Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
count Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n)
  Text
wrong <- Text -> Gen Text
fresh Text
"wrong"
  Text -> Gen ()
emit (Text
wrong Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
need)
  -- The captured arguments go to slots fp + from + 1 .. fp + from + count
  -- ('copyCaptured'), so those must exist: fp + from + count + 1 < stack
  -- size, the interpreter's slack. The static part (from) is covered by the
  -- entry check through 'fpPlus'; the count is only known here. Measured
  -- from %fp and the copy's own base, not from %fpb, the function's: a call
  -- in a deep frame writes that much higher.
  -- The callee checks its own frame.
  Text
top <- Text -> Gen Text
fresh Text
"top"
  Text -> Gen ()
emit (Text
top Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 %fp, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
from Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
  Text
limit <- Text -> Gen Text
fresh Text
"limit"
  Text -> Gen ()
emit (Text
limit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
top Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
count)
  Text
noRoom <- Text -> Gen Text
fresh Text
"noroom"
  Text -> Gen ()
emit (Text
noRoom Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp sge i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
limit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %stack.size")
  Text
bad0 <- Text -> Gen Text
fresh Text
"bad"
  Text -> Gen ()
emit (Text
bad0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
isNull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
wrong)
  Text
bad <- Text -> Gen Text
fresh Text
"bad"
  Text -> Gen ()
emit (Text
bad Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bad0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
noRoom)
  Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
joinL)
  Text -> Gen ()
startBlock Text
joinL
  let notEntries :: Text -> Text
notEntries Text
v = Text -> Deque Text -> Text
intercalateT Text
", " ([Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList [Text
"[ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]" | Text
l <- [Text]
notPreds])
  Text
skip0 <- Text -> Gen Text
fresh Text
"skip"
  Text -> Gen ()
emit (Text
skip0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
notEntries Text
"true" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bad Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
okL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  Text
fnp <- Text -> Gen Text
fresh Text
"fn"
  Text -> Gen ()
emit (Text
fnp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
notEntries Text
"null" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fnp0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
okL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  Text
usegR <- Text -> Gen Text
fresh Text
"cap.u"
  Text -> Gen ()
emit (Text
usegR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
notEntries Text
"0" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
useg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
okL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  Text
bsegR <- Text -> Gen Text
fresh Text
"cap.b"
  Text -> Gen ()
emit (Text
bsegR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
notEntries Text
"0" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bseg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
okL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  Text
countR <- Text -> Gen Text
fresh Text
"cap.n"
  Text -> Gen ()
emit (Text
countR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
notEntries Text
"0" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
count Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
okL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
st -> GS
st {gsCaptured = Just $! Captured usegR bsegR countR})
  Text
skip <-
    if Env -> Bool
envStressCallee Env
env
      then do
        Text
fire <- Env -> (CtxOffsets -> Int) -> (CtxOffsets -> Int) -> Gen Text
stressFire Env
env CtxOffsets -> Int
oStressCalleeLeft CtxOffsets -> Int
oStressCallee
        Text
sk <- Text -> Gen Text
fresh Text
"skip"
        Text -> Gen ()
emit (Text
sk Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
skip0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fire)
        pure Text
sk
      else Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
skip0
  pure (Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair Text
fnp Text
skip)

-- | Copies the captured arguments left by 'closureCallee' to the slots
-- above frame offset @from@, as @dumpSeg@ does, and gives the register
-- holding the resulting stack pointer. Marks the high-water mark, since
-- the count isn't static.
copyCaptured :: FnEnv -> Int -> Gen Text
copyCaptured :: FnEnv -> Int -> Gen Text
copyCaptured FnEnv
fe Int
from = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      rts :: RtsFacts
rts = Env -> RtsFacts
envRts Env
env
  Captured Text
useg Text
bseg Text
count <-
    (GS -> Maybe Captured) -> StateT GS Identity (Maybe Captured)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GS -> Maybe Captured
gsCaptured StateT GS Identity (Maybe Captured)
-> (Maybe Captured -> StateT GS Identity Captured)
-> StateT GS Identity Captured
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Captured
c -> Captured -> StateT GS Identity Captured
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Captured
c
      Maybe Captured
Nothing -> String -> StateT GS Identity Captured
forall a. HasCallStack => String -> a
error String
"copyCaptured: no closure examined"
  (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
st -> GS
st {gsCaptured = Nothing})
  Text
cur <- Gen Text
curLabel
  Text
headL <- Text -> Gen Text
freshLabel Text
"cp.head"
  Text
bodyL <- Text -> Gen Text
freshLabel Text
"cp.body"
  Text
endL <- Text -> Gen Text
freshLabel Text
"cp.end"
  Text
fromR <- Int -> Gen Text
fpPlus Int
from
  Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
headL)
  Text -> Gen ()
startBlock Text
headL
  Text
k <- Text -> Gen Text
fresh Text
"k"
  Text
k1 <- Text -> Gen Text
fresh Text
"k"
  Text -> Gen ()
emit (Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi i64 [ 0, %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cur Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ], [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bodyL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  Text
done <- Text -> Gen Text
fresh Text
"done"
  Text -> Gen ()
emit (Text
done Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
count)
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
done Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
endL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bodyL)
  Text -> Gen ()
startBlock Text
bodyL
  -- element k of each array goes to slot from + 1 + k
  Text
ui <- Text -> Gen Text
fresh Text
"ui"
  Text -> Gen ()
emit (Text
ui Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rBytesHeader RtsFacts
rts))
  Text
ua <- Text -> Gen Text
fresh Text
"ua"
  Text -> Gen ()
emit (Text
ua Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
useg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Text
up <- Text -> Gen Text
fresh Text
"up"
  Text -> Gen ()
emit (Text
up Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ui)
  Text
u <- Text -> Gen Text
fresh Text
"u"
  Text -> Gen ()
emit (Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
up)
  Text
bi <- Text -> Gen Text
fresh Text
"bi"
  Text -> Gen ()
emit (Text
bi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rPtrsHeader RtsFacts
rts))
  Text
ba <- Text -> Gen Text
fresh Text
"ba"
  Text -> Gen ()
emit (Text
ba Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bseg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Text
bp <- Text -> Gen Text
fresh Text
"bp"
  Text -> Gen ()
emit (Text
bp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bi)
  Text
b <- Text -> Gen Text
fresh Text
"b"
  Text -> Gen ()
emit (Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bp)
  Text
slot <- Text -> Gen Text
fresh Text
"slot"
  Text -> Gen ()
emit (Text
slot Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fromR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k)
  Text
slot1 <- Text -> Gen Text
fresh Text
"slot"
  Text -> Gen ()
emit (Text
slot1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slot Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
  Text
dstU <- Text -> Gen Text
fresh Text
"ua"
  Text
ustk <- Text -> Gen Text
stackReg Text
"%ustk"
  Text -> Gen ()
emit (Text
dstU Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ustk Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slot1)
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dstU)
  Text
dstB <- Text -> Gen Text
fresh Text
"ba"
  Text
bstk <- Text -> Gen Text
stackReg Text
"%bstk"
  Text -> Gen ()
emit (Text
dstB Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bstk Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slot1)
  Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dstB)
  Text -> Gen ()
emit (Text
k1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
  Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
headL)
  Text -> Gen ()
startBlock Text
endL
  Text
top <- Text -> Gen Text
fresh Text
"top"
  Text -> Gen ()
emit (Text
top Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fromR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
count)
  -- the high-water mark for card marking on return
  Env -> Text -> Gen ()
markWritten Env
env Text
top
  pure Text
top

-- ---------------------------------------------------------------------------
-- Instructions

litSupported :: MLit -> Bool
litSupported :: MLit -> Bool
litSupported = \case
  MI Int
_ -> Bool
True
  MN Word64
_ -> Bool
True
  MC Char
_ -> Bool
True
  MD Double
_ -> Bool
True
  MLit
_ -> Bool
False

prim1Supported :: Prim1 -> Bool
prim1Supported :: Prim1 -> Bool
prim1Supported Prim1
op =
  Prim1
op
    Prim1 -> [Prim1] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Prim1
DECI,
             Prim1
DECN,
             Prim1
INCI,
             Prim1
INCN,
             Prim1
NEGI,
             Prim1
COMN,
             Prim1
COMI,
             Prim1
TRNC,
             Prim1
SGNI,
             Prim1
LZRO,
             Prim1
TZRO,
             Prim1
POPC,
             Prim1
ITOF,
             Prim1
NTOF,
             Prim1
ABSF,
             Prim1
CEIL,
             Prim1
FLOR,
             Prim1
TRNF,
             Prim1
RNDF,
             Prim1
EXPF,
             Prim1
LOGF,
             Prim1
SQRT,
             Prim1
COSF,
             Prim1
SINF,
             Prim1
TANF,
             Prim1
COSH,
             Prim1
SINH,
             Prim1
TANH,
             Prim1
ACOS,
             Prim1
ASIN,
             Prim1
ATAN,
             Prim1
ASNH,
             Prim1
ACSH,
             Prim1
ATNH
           ]

prim2Supported :: Prim2 -> Bool
prim2Supported :: Prim2 -> Bool
prim2Supported Prim2
op =
  Prim2
op
    Prim2 -> [Prim2] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Prim2
ADDI,
             Prim2
SUBI,
             Prim2
MULI,
             Prim2
DIVI,
             Prim2
MODI,
             Prim2
EQLI,
             Prim2
NEQI,
             Prim2
LEQI,
             Prim2
LESI,
             Prim2
ANDI,
             Prim2
IORI,
             Prim2
XORI,
             Prim2
SHLI,
             Prim2
SHRI,
             Prim2
ADDN,
             Prim2
SUBN,
             Prim2
MULN,
             Prim2
DIVN,
             Prim2
MODN,
             Prim2
EQLN,
             Prim2
NEQN,
             Prim2
LEQN,
             Prim2
LESN,
             Prim2
ANDN,
             Prim2
IORN,
             Prim2
XORN,
             Prim2
SHLN,
             Prim2
SHRN,
             Prim2
DRPN,
             Prim2
POWI,
             Prim2
POWN,
             Prim2
CAST,
             Prim2
ADDF,
             Prim2
SUBF,
             Prim2
MULF,
             Prim2
DIVF,
             Prim2
EQLF,
             Prim2
NEQF,
             Prim2
LEQF,
             Prim2
LESF,
             Prim2
MINF,
             Prim2
MAXF,
             Prim2
POWF,
             Prim2
LOGB,
             Prim2
ATN2
           ]

-- | Whether 'genInstr' has native code for an instruction (at least a fast
-- path), as opposed to calling out for it every time. Must agree with the
-- cases of 'genInstr'; the estimate of what compiling a function saves
-- relies on it (see JIT.Estimate).
-- | The Text and Bytes foreign functions with native versions (see "The
-- rest of Text and Bytes" in jit_rt.c).
textForeign, bytesForeign :: [ForeignFunc]
textForeign :: [ForeignFunc]
textForeign = [ForeignFunc
Text_repeat, ForeignFunc
Text_reverse, ForeignFunc
Text_toUppercase, ForeignFunc
Text_toLowercase, ForeignFunc
Text_toUtf8, ForeignFunc
Text_fromUtf8_impl_v3, ForeignFunc
Char_toText]
bytesForeign :: [ForeignFunc]
bytesForeign =
  [ ForeignFunc
Bytes_decodeNat16be,
    ForeignFunc
Bytes_decodeNat16le,
    ForeignFunc
Bytes_decodeNat32be,
    ForeignFunc
Bytes_decodeNat32le,
    ForeignFunc
Bytes_decodeNat64be,
    ForeignFunc
Bytes_decodeNat64le,
    ForeignFunc
Bytes_encodeNat16be,
    ForeignFunc
Bytes_encodeNat16le,
    ForeignFunc
Bytes_encodeNat32be,
    ForeignFunc
Bytes_encodeNat32le,
    ForeignFunc
Bytes_encodeNat64be,
    ForeignFunc
Bytes_encodeNat64le,
    ForeignFunc
Bytes_read,
    ForeignFunc
Bytes_read16be,
    ForeignFunc
Bytes_read16le,
    ForeignFunc
Bytes_read32be,
    ForeignFunc
Bytes_read32le,
    ForeignFunc
Bytes_read64be,
    ForeignFunc
Bytes_read64le,
    ForeignFunc
Bytes_toBase16,
    ForeignFunc
Bytes_toBase32,
    ForeignFunc
Bytes_toBase64,
    ForeignFunc
Bytes_toBase64UrlUnpadded,
    ForeignFunc
Bytes_fromBase16,
    ForeignFunc
Bytes_fromBase32,
    ForeignFunc
Bytes_fromBase64,
    ForeignFunc
Bytes_fromBase64UrlUnpadded
  ]

-- | The width in bytes and endianness (1 for big) of the Bytes number functions.
decodeNatKind, encodeNatKind, readKind :: ForeignFunc -> Maybe (Pair Int Int)
decodeNatKind :: ForeignFunc -> Maybe (Pair Int Int)
decodeNatKind = \case
  ForeignFunc
Bytes_decodeNat16be -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
2 Int
1)
  ForeignFunc
Bytes_decodeNat16le -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
2 Int
0)
  ForeignFunc
Bytes_decodeNat32be -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
4 Int
1)
  ForeignFunc
Bytes_decodeNat32le -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
4 Int
0)
  ForeignFunc
Bytes_decodeNat64be -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
8 Int
1)
  ForeignFunc
Bytes_decodeNat64le -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
8 Int
0)
  ForeignFunc
_ -> Maybe (Pair Int Int)
forall a. Maybe a
Nothing
encodeNatKind :: ForeignFunc -> Maybe (Pair Int Int)
encodeNatKind = \case
  ForeignFunc
Bytes_encodeNat16be -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
2 Int
1)
  ForeignFunc
Bytes_encodeNat16le -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
2 Int
0)
  ForeignFunc
Bytes_encodeNat32be -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
4 Int
1)
  ForeignFunc
Bytes_encodeNat32le -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
4 Int
0)
  ForeignFunc
Bytes_encodeNat64be -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
8 Int
1)
  ForeignFunc
Bytes_encodeNat64le -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
8 Int
0)
  ForeignFunc
_ -> Maybe (Pair Int Int)
forall a. Maybe a
Nothing
readKind :: ForeignFunc -> Maybe (Pair Int Int)
readKind = \case
  ForeignFunc
Bytes_read -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
1 Int
1)
  ForeignFunc
Bytes_read16be -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
2 Int
1)
  ForeignFunc
Bytes_read16le -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
2 Int
0)
  ForeignFunc
Bytes_read32be -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
4 Int
1)
  ForeignFunc
Bytes_read32le -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
4 Int
0)
  ForeignFunc
Bytes_read64be -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
8 Int
1)
  ForeignFunc
Bytes_read64le -> Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
8 Int
0)
  ForeignFunc
_ -> Maybe (Pair Int Int)
forall a. Maybe a
Nothing

-- | The base of the Bytes encoding functions: 16, 32, 64, or 65 for base 64
-- with the URL alphabet and no padding.
toBaseKind, fromBaseKind :: ForeignFunc -> Maybe Int
toBaseKind :: ForeignFunc -> Maybe Int
toBaseKind = \case
  ForeignFunc
Bytes_toBase16 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
16
  ForeignFunc
Bytes_toBase32 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
32
  ForeignFunc
Bytes_toBase64 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
64
  ForeignFunc
Bytes_toBase64UrlUnpadded -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
65
  ForeignFunc
_ -> Maybe Int
forall a. Maybe a
Nothing
fromBaseKind :: ForeignFunc -> Maybe Int
fromBaseKind = \case
  ForeignFunc
Bytes_fromBase16 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
16
  ForeignFunc
Bytes_fromBase32 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
32
  ForeignFunc
Bytes_fromBase64 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
64
  ForeignFunc
Bytes_fromBase64UrlUnpadded -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
65
  ForeignFunc
_ -> Maybe Int
forall a. Maybe a
Nothing

instrNative :: Switches -> GInstr comb -> Bool
instrNative :: forall comb. Switches -> GInstr comb -> Bool
instrNative Switches
sw = \case
  Lit MLit
_ -> Bool
True
  Pack {} -> Bool
True
  RecPack {} -> Switches -> Bool
swRecords Switches
sw
  RecUnpack {} -> Switches -> Bool
swRecords Switches
sw
  RecSet {} -> Switches -> Bool
swRecords Switches
sw
  -- VALU is native only as the first half of Universal.murmurHashUntyped
  -- (see genInstr); on its own it is a call-out, which the estimate accepts
  Prim1 Prim1
op Int
_ -> Prim1 -> Bool
prim1Supported Prim1
op Bool -> Bool -> Bool
|| Prim1
op Prim1 -> [Prim1] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim1
REFR, Prim1
REFN, Prim1
TIKR, Prim1
RRFC, Prim1
VALU, Prim1
NOTB, Prim1
SIZS, Prim1
VWLS, Prim1
VWRS, Prim1
SIZT, Prim1
SIZB, Prim1
FLTB, Prim1
UCNS, Prim1
USNC, Prim1
ITOT, Prim1
NTOT, Prim1
FTOT, Prim1
TTOI, Prim1
TTON, Prim1
TTOF, Prim1
PAKT, Prim1
UPKT, Prim1
PAKB, Prim1
UPKB]
  Prim2 Prim2
op Int
_ Int
_ -> Prim2 -> Bool
prim2Supported Prim2
op Bool -> Bool -> Bool
|| Prim2
op Prim2 -> [Prim2] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim2
REFW, Prim2
EQLU, Prim2
LEQU, Prim2
LESU, Prim2
CMPU, Prim2
ANDB, Prim2
IORB, Prim2
CONS, Prim2
SNOC, Prim2
IDXS, Prim2
CATS, Prim2
TAKS, Prim2
DRPS, Prim2
SPLL, Prim2
SPLR, Prim2
CATT, Prim2
TAKT, Prim2
DRPT, Prim2
EQLT, Prim2
CATB, Prim2
TAKB, Prim2
DRPB, Prim2
IDXB, Prim2
IXOT, Prim2
IXOB, Prim2
LEQT, Prim2
LEST]
  Seq Args
_ -> Bool
True
  RefCAS {} -> Bool
True
  ForeignCall Bool
_ ForeignFunc
f Args
_ -> ForeignFunc
f ForeignFunc -> [ForeignFunc] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([ForeignFunc
MutableArray_size, ForeignFunc
MutableArray_read, ForeignFunc
MutableArray_write, ForeignFunc
ImmutableArray_size, ForeignFunc
ImmutableArray_read, ForeignFunc
Universal_murmurHashUntyped] [ForeignFunc] -> [ForeignFunc] -> [ForeignFunc]
forall a. Semigroup a => a -> a -> a
<> [ForeignFunc]
textForeign [ForeignFunc] -> [ForeignFunc] -> [ForeignFunc]
forall a. Semigroup a => a -> a -> a
<> [ForeignFunc]
bytesForeign) Bool -> Bool -> Bool
|| Maybe ArrayOp -> Bool
forall a. Maybe a -> Bool
isJust (ForeignFunc -> Maybe ArrayOp
arrayForeign ForeignFunc
f) Bool -> Bool -> Bool
|| Maybe PtrOp -> Bool
forall a. Maybe a -> Bool
isJust (ForeignFunc -> Maybe PtrOp
ptrForeign ForeignFunc
f)
  -- (up to four arguments; more is rare, and then it is a call-out)
  Name GRef comb
r Args
_ -> case GRef comb
r of Dyn Word64
_ -> Bool
False; GRef comb
_ -> Bool
True
  -- storing an affine handler's next state (see 'genInstr'); with the
  -- environment update it is the interpreter's
  SetAff Bool
False Int
_ Int
_ -> Switches -> Bool
swRequests Switches
sw
  GInstr comb
_ -> Bool
False

-- | 'instrNative' for an instruction in its section: an affine handler's
-- @InLocal@ is native (a no-op) when the rest of its case can't tell the
-- environment wasn't switched, see 'localUnobserved'.
instrNativeIn :: Switches -> GInstr (RComb Val) -> MSection -> Bool
instrNativeIn :: Switches -> GInstr (RComb Val) -> MSection -> Bool
instrNativeIn Switches
sw GInstr (RComb Val)
i MSection
rest =
  Switches -> GInstr (RComb Val) -> Bool
forall comb. Switches -> GInstr comb -> Bool
instrNative Switches
sw GInstr (RComb Val)
i Bool -> Bool -> Bool
|| case GInstr (RComb Val)
i of
    InLocal Int
_ -> Switches -> Bool
swRequests Switches
sw Bool -> Bool -> Bool
&& (MSection -> Bool
localUnobserved MSection
rest Bool -> Bool -> Bool
|| Switches -> Bool
swLocalObserving Switches
sw)
    GInstr (RComb Val)
_ -> Bool
False

-- | What the settings turn on in the generator, for the predicates above,
-- which the estimator asks without a function environment in reach.
data Switches = Switches
  { -- | ability requests and the affine handler instructions are generated
    -- (off under @UNISON_JIT_DISABLE=requests@)
    Switches -> Bool
swRequests :: !Bool,
    -- | the record instructions are generated (off under
    -- @UNISON_JIT_DISABLE=records@)
    Switches -> Bool
swRecords :: !Bool,
    -- | the observing form of @InLocal@ is generated (see 'genInLocal'):
    -- its Local frame record is written by the exit routine, which the
    -- generated write-back blocks of @UNISON_JIT_EXITS=blocks@ don't have
    Switches -> Bool
swLocalObserving :: !Bool
  }

switches :: Config -> Switches
switches :: Config -> Switches
switches Config
cfg = Bool -> Bool -> Bool -> Switches
Switches Bool
requests (String
"records" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Config -> [String]
disabled Config
cfg) (Bool
requests Bool -> Bool -> Bool
&& Config -> Bool
exitCall Config
cfg)
  where
    requests :: Bool
requests = String
"requests" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Config -> [String]
disabled Config
cfg

-- | Whether a section, the rest of an affine handler's case after its
-- @InLocal@, can run without the environment switch the instruction makes
-- in the interpreter. The switch is observed by requests, @Reset@,
-- @Capture@, @Discard@, @SetAff@ with the environment update, raising an
-- exception (a failing foreign call, @THRO@), and by any exit that resumes
-- the interpreter ahead of one of those. So: straight-line code to the
-- @Yield@, made of literals, constructors, partial applications of known
-- functions, the handler's own state update, and the native primitives,
-- none of which look at the environment. Even an exit in such a body (a
-- lazy field found by a @Pack@, say) is harmless: the interpreter finishes
-- the case in the requester's environment, which nothing left in it reads,
-- and the @Yield@ pops the requester's frame, which is what the @Local@
-- frame would have left it with.
localUnobserved :: MSection -> Bool
localUnobserved :: MSection -> Bool
localUnobserved = \case
  Yield Args
_ -> Bool
True
  Ins GInstr (RComb Val)
i MSection
rest -> GInstr (RComb Val) -> Bool
forall {comb}. GInstr comb -> Bool
harmless GInstr (RComb Val)
i Bool -> Bool -> Bool
&& MSection -> Bool
localUnobserved MSection
rest
  MSection
_ -> Bool
False
  where
    harmless :: GInstr comb -> Bool
harmless = \case
      Lit MLit
_ -> Bool
True
      Pack {} -> Bool
True
      RecPack {} -> Bool
True
      RecUnpack {} -> Bool
True
      RecSet {} -> Bool
True
      Name GRef comb
r Args
_ -> case GRef comb
r of Dyn Word64
_ -> Bool
False; GRef comb
_ -> Bool
True
      SetAff Bool
False Int
_ Int
_ -> Bool
True
      Prim1 Prim1
op Int
_ -> Prim1 -> Bool
prim1Supported Prim1
op
      Prim2 Prim2
op Int
_ Int
_ -> Prim2 -> Bool
prim2Supported Prim2
op
      GInstr comb
_ -> Bool
False

-- | An affine handler's @InLocal@ when the rest of the case observes the
-- environment (a request of its own, a call): the switch the interpreter
-- makes, reproduced. The helper builds the case's environment (@HEnv@ of
-- the @Affine@ closure's @aenv@ and the empty @denv@); the old one goes
-- in a register and the new one in @Ctx@, where every request site reads
-- it, and the switch count goes up. The rest of the case is generated
-- with the switch in force ('feLocal'): its @Yield@ switches back
-- ('endLocal'), and every exit or unwind before that writes a @Local@
-- frame record with the old environment ('joinCall'), so the interpreter
-- continues as it would after its own @InLocal@, with the current
-- environment it reads back from the trampoline. The slow path is a
-- call-out: the interpreter runs the instruction and the rest of the case
-- re-enters with the @Local@ frame in @K@. Taken when the helper refuses
-- the closure, or when as many switches are in force as the out-area that
-- an exit hands their environments back in has room for.
genInLocal :: FnEnv -> Int -> Int -> MSection -> MSection -> Gen ()
genInLocal :: FnEnv -> Int -> Int -> MSection -> MSection -> Gen ()
genInLocal FnEnv
fe Int
d Int
i MSection
rest MSection
sect = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
  Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d (Int -> GInstr (RComb Val)
forall comb. Int -> GInstr comb
InLocal Int
i) MSection
sect
  Text
nla <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oNLocals
  Text
nl <- Text -> Gen Text
fresh Text
"nlocals"
  Text -> Gen ()
emit (Text
nl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nla)
  Text
full <- Text -> Gen Text
fresh Text
"full"
  Text -> Gen ()
emit (Text
full Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp sge i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
nativeLocals)
  Text -> Text -> Text -> Gen ()
branchIf Text
"local" Text
full Text
slow
  Text
aff <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
  Text
h <- Text -> Gen Text
fresh Text
"local"
  Text -> Gen ()
emit (Text
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @unison_jit_local_env(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aff Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  Text
miss <- Text -> Gen Text
fresh Text
"miss"
  Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", null")
  Text -> Text -> Text -> Gen ()
branchIf Text
"local" Text
miss Text
slow
  Text
ha <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oHenv
  Text
h0 <- Text -> Gen Text
fresh Text
"henv0"
  Text -> Gen ()
emit (Text
h0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ha)
  Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ha)
  Text
nl' <- Text -> Gen Text
fresh Text
"nlocals"
  Text -> Gen ()
emit (Text
nl' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nl' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nla)
  FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe {feLocal = Just (Local h0 (D.size (feEnclosing fe)))} Int
d MSection
rest

-- | Switches in force at once that an exit can hand back; must match
-- UNISON_JIT_LOCALS in jit_rt.h.
nativeLocals :: Int
nativeLocals :: Int
nativeLocals = Int
32

-- | The end of an environment switch, at the case's @Yield@: the old
-- environment goes back into @Ctx@ and the switch count down.
endLocal :: FnEnv -> Gen ()
endLocal :: FnEnv -> Gen ()
endLocal FnEnv
fe = Maybe Local -> (Local -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (FnEnv -> Maybe Local
feLocal FnEnv
fe) ((Local -> Gen ()) -> Gen ()) -> (Local -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Local
lo -> do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
  Text
ha <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oHenv
  Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Local -> Text
loHenv0 Local
lo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ha)
  Text
nla <- Env -> (CtxOffsets -> Int) -> Gen Text
ctxField Env
env CtxOffsets -> Int
oNLocals
  Text
nl <- Text -> Gen Text
fresh Text
"nlocals"
  Text -> Gen ()
emit (Text
nl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nla)
  Text
nl' <- Text -> Gen Text
fresh Text
"nlocals"
  Text -> Gen ()
emit (Text
nl' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -1")
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nl' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nla)

-- | An instruction at depth @d@; continues with the depth after it.
genInstr :: FnEnv -> Int -> GInstr (RComb Val) -> MSection -> (Int -> Gen ()) -> Gen ()
genInstr :: FnEnv
-> Int
-> GInstr (RComb Val)
-> MSection
-> (Int -> Gen ())
-> Gen ()
genInstr FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect Int -> Gen ()
k = case GInstr (RComb Val)
instr of
  Lit MLit
l | MLit -> Bool
litSupported MLit
l -> do
    let !(Pair Text
u Text
tag) = case MLit
l of
          MI Int
i -> Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair (Int -> Text
forall a. Show a => a -> Text
tshow Int
i) (FnEnv -> Text
feTagInt FnEnv
fe)
          MN Word64
n -> Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair (Int64 -> Text
forall a. Show a => a -> Text
tshow (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n :: Int64)) (FnEnv -> Text
feTagNat FnEnv
fe)
          MC Char
c -> Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair (Int -> Text
forall a. Show a => a -> Text
tshow (Char -> Int
ord Char
c)) (FnEnv -> Text
feTagChar FnEnv
fe)
          MD Double
x -> Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair (Int64 -> Text
forall a. Show a => a -> Text
tshow (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Word64
castDoubleToWord64 Double
x) :: Int64)) (FnEnv -> Text
feTagFloat FnEnv
fe)
          MLit
_ -> String -> Pair Text Text
forall a. HasCallStack => String -> a
error String
"unreachable"
    Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
u
    Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
tag
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- boxed literals and constructors without fields are pool constants
  Lit MLit
l | Just Int
ix <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (MLit -> PoolKey
KeyLit MLit
l) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
    FnEnv -> Int -> Int -> Gen ()
poolConstant FnEnv
fe Int
d Int
ix
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Pack Reference
r PackedTag
t Args
ZArgs | Just Int
ix <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
r PackedTag
t) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
    FnEnv -> Int -> Int -> Gen ()
poolConstant FnEnv
fe Int
d Int
ix
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Pack Reference
r PackedTag
t Args
args
    | Just Int
refIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
r (Word64 -> PackedTag
PackedTag Word64
0)) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)),
      Just Deque Int
fields <- FnEnv -> Int -> Args -> Maybe (Deque Int)
packFields FnEnv
fe Int
d Args
args -> do
        Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
        FnEnv -> Int -> Int -> PackedTag -> Deque Int -> Text -> Gen ()
genPack FnEnv
fe Int
d Int
refIx PackedTag
t Deque Int
fields Text
slow
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- a record literal: built from the pool's empty record of its shape
  RecPack RecordShape
shape Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"records",
      Just Int
protoIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (RecordShape -> PoolKey
KeyRecord RecordShape
shape) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
        FnEnv -> Int -> Int -> Deque Int -> Text -> Gen ()
genRecPack FnEnv
fe Int
d Int
protoIx (FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args) Text
slow
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- a record pattern, or a field read: the named fields are pushed
  RecUnpack Vector FieldRef
fields Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"records" -> do
    Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
    FnEnv -> Int -> Int -> [FieldRef] -> Text -> Gen ()
genRecUnpack FnEnv
fe Int
d Int
i (Vector FieldRef -> [FieldRef]
forall a. Vector a -> [a]
V.toList Vector FieldRef
fields) Text
slow
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Vector FieldRef -> Int
forall a. Vector a -> Int
V.length Vector FieldRef
fields)
  -- a field update: a copy with one slot replaced, by the C helper, which
  -- gives null for anything that isn't a record with that field
  RecSet (FieldRef Word64
f) (VArg2 Int
ri Int
vi) | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"records" -> do
    Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
    Text
rec <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ri)
    Text
u <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
vi)
    Text
b <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
vi)
    Text
r <- Text -> Gen Text
fresh Text
"rec"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @unison_jit_rec_set(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text
miss <- Text -> Gen Text
fresh Text
"miss"
    Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", null")
    Text -> Text -> Text -> Gen ()
branchIf Text
"recset" Text
miss Text
slow
    Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
    Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
r
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- An affine handler's switch to its own environment: nothing left in
  -- the case can tell (see 'localUnobserved'), so nothing is done; the
  -- interpreter's Local frame would only restore what was never changed.
  InLocal Int
_ | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"requests", Ins GInstr (RComb Val)
_ MSection
rest <- MSection
sect, MSection -> Bool
localUnobserved MSection
rest -> Int -> Gen ()
k Int
d
  -- The handler's next state goes into the ref inside the Affine closure
  -- in slot i, through the runtime's barrier; the helper refuses anything
  -- that isn't an Affine closure, and the interpreter runs it then.
  SetAff Bool
False Int
i Int
j | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"requests" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
aff <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
v <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    Text
r <- Text -> Gen Text
fresh Text
"setaff"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @unison_jit_set_aff(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aff Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text
miss <- Text -> Gen Text
fresh Text
"miss"
    Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
    Text -> Text -> Text -> Gen ()
branchIf Text
"setaff" Text
miss Text
slow
    Int -> Gen ()
k Int
d
  Prim1 Prim1
op Int
i | Prim1 -> Bool
prim1Supported Prim1
op -> do
    Text
x <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    FnEnv -> Int -> Prim1 -> Text -> MSection -> Gen ()
genPrim1 FnEnv
fe Int
d Prim1
op Text
x MSection
sect
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
NOTB Int
i -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
c <- FnEnv -> Int -> Text -> Gen Text
loadBoolean FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Text
slow
    Text
r <- Text -> Gen Text
fresh Text
"not"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = xor i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", true")
    FnEnv -> Int -> Text -> Gen ()
resultBool FnEnv
fe Int
d Text
r
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
op Int
i Int
j | Prim2
op Prim2 -> [Prim2] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim2
ANDB, Prim2
IORB] -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
x <- FnEnv -> Int -> Text -> Gen Text
loadBoolean FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Text
slow
    Text
y <- FnEnv -> Int -> Text -> Gen Text
loadBoolean FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Text
slow
    Text
r <- Text -> Gen Text
fresh Text
"bool"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
ANDB then Text
"and" else Text
"or") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y)
    FnEnv -> Int -> Text -> Gen ()
resultBool FnEnv
fe Int
d Text
r
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
REFR Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"ref" -> do
    FnEnv -> Int -> Int -> GInstr (RComb Val) -> MSection -> Gen ()
genRefRead FnEnv
fe Int
d (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) GInstr (RComb Val)
instr MSection
sect
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- A partial application: a function value with the arguments added.
  -- Of a known function, whose closure is in the pool: built in place
  -- ('genNameInline'). Of a function value on the stack: a copy made by
  -- a C helper, with the arguments passed on the Unison stack
  -- ('genNameStack'). Any number of arguments either way.
  Name (MCode.Env CombIx
cix RComb Val
comb) Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"name",
      Comb GCombInfo (RComb Val)
info <- RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb,
      Just Int
ix <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (CombIx -> GCombInfo (RComb Val) -> PoolKey
KeyComb CombIx
cix GCombInfo (RComb Val)
info) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        FnEnv -> Int -> Int -> Deque Int -> Gen ()
genNameInline FnEnv
fe Int
d Int
ix (FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args)
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Name (Stk Int
i) Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"name" -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
f <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        FnEnv -> Int -> Text -> Text -> Deque Int -> Gen ()
genNameStack FnEnv
fe Int
d Text
slow Text
f (FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args)
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- Lists: C helpers that are ports of the Haskell operations (see "Lists"
  -- in jit_rt.c). They handle every list; the slow path is only for a
  -- closure that isn't one.
  Prim1 Prim1
SIZS Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"list" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
l <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
n <- Text -> Gen Text
fresh Text
"size"
    Text -> Gen ()
emit (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @unison_jit_list_size(ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text
miss <- Text -> Gen Text
fresh Text
"miss"
    Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp slt i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
    Text -> Text -> Text -> Gen ()
branchIf Text
"list" Text
miss Text
slow
    FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagNat FnEnv
fe) Text
n
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
op Int
i
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"list",
      Prim1
op Prim1 -> Prim1 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim1
VWLS Bool -> Bool -> Bool
|| Prim1
op Prim1 -> Prim1 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim1
VWRS,
      Just Int
emptyIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.seqViewRef PackedTag
TT.seqViewEmptyTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        let PackedTag Word64
elemTag = PackedTag
TT.seqViewElemTag
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
l <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
e <- Int -> Gen Text
poolValue Int
emptyIx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_list_view(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
elemTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Prim1
op Prim1 -> Prim1 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim1
VWLS then Text
"1" else Text
"0") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
op Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"list",
      Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
CONS Bool -> Bool -> Bool
|| Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
SNOC -> do
        -- cons takes the element first, snoc the list
        let !(Pair Int
kl Int
kx) = if Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
CONS then Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) else Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
l <- Int -> Gen Text
loadB Int
kl
        Text
u <- Int -> Gen Text
loadU Int
kx
        Text
b <- Int -> Gen Text
loadB Int
kx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_list_push(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
CONS then Text
"1" else Text
"0") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
op Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"list",
      Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
TAKS Bool -> Bool -> Bool
|| Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
DRPS -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
n <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
l <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_list_cut(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
TAKS then Text
"1" else Text
"0") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
op Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"list",
      Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
SPLL Bool -> Bool -> Bool
|| Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
SPLR,
      Just Int
emptyIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.seqViewRef PackedTag
TT.seqViewEmptyTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        let PackedTag Word64
elemTag = PackedTag
TT.seqViewElemTag
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
n <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
l <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
        Text
e <- Int -> Gen Text
poolValue Int
emptyIx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_list_split(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
elemTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
SPLL then Text
"1" else Text
"0") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
CATS Int
i Int
j | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"list" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
x <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
y <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_list_append(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- A list literal: the elements are added one at a time to a deque that
  -- is wrapped at the end. The only slow path is an untagged element.
  Seq Args
args | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"list" -> do
    Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources (FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args)
    Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
    Text -> Deque Text -> Gen ()
requireTagged Text
slow ((Pair Text Text -> Text) -> Deque (Pair Text Text) -> Deque Text
forall a b. (a -> b) -> Deque a -> Deque b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Pair Text
_ Text
b) -> Text
b) Deque (Pair Text Text)
vals)
    let add :: Text -> Pair Text Text -> Gen Text
add Text
acc (Pair Text
u Text
b) = do
          Text
r <- Text -> Gen Text
fresh Text
"lit"
          Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @unison_jit_list_lit(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
          pure Text
r
    Text
acc <- (Text -> Pair Text Text -> Gen Text)
-> Text -> Deque (Pair Text Text) -> Gen Text
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Text -> Pair Text Text -> Gen Text
add Text
"null" Deque (Pair Text Text)
vals
    Text
r <- Text -> Gen Text
fresh Text
"list"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @unison_jit_list_wrap(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
    Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
r
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- Text: the same arrangement (see "Text" in jit_rt.c). The helpers handle
  -- every text; the slow path is only for a closure that isn't one.
  Prim1 Prim1
SIZT Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
t <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
n <- Text -> Gen Text
fresh Text
"size"
    Text -> Gen ()
emit (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @unison_jit_text_size(ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text
miss <- Text -> Gen Text
fresh Text
"miss"
    Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp slt i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
    Text -> Text -> Text -> Gen ()
branchIf Text
"text" Text
miss Text
slow
    FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagNat FnEnv
fe) Text
n
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
CATT Int
i Int
j | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
x <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
y <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_text_append(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
op Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text",
      Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
TAKT Bool -> Bool -> Bool
|| Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
DRPT -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
n <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
t <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_text_cut(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
TAKT then Text
"1" else Text
"0") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
EQLT Int
i Int
j | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
x <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
y <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    Text
r <- Text -> Gen Text
fresh Text
"eq"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @unison_jit_text_eq(ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text
miss <- Text -> Gen Text
fresh Text
"miss"
    Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp slt i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
    Text -> Text -> Text -> Gen ()
branchIf Text
"text" Text
miss Text
slow
    Text
c <- Text -> Gen Text
fresh Text
"bool"
    Text -> Gen ()
emit (Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
    FnEnv -> Int -> Text -> Gen ()
resultBool FnEnv
fe Int
d Text
c
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- Bytes: the same rope with chunks of bytes and the same helpers (see
  -- "Ropes" in jit_rt.c), plus Bytes.at and Bytes.flatten.
  Prim1 Prim1
SIZB Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
b <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
n <- Text -> Gen Text
fresh Text
"size"
    Text -> Gen ()
emit (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @unison_jit_bytes_size(ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text
miss <- Text -> Gen Text
fresh Text
"miss"
    Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp slt i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
    Text -> Text -> Text -> Gen ()
branchIf Text
"bytes" Text
miss Text
slow
    FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagNat FnEnv
fe) Text
n
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
FLTB Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
b <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_bytes_flatten(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
CATB Int
i Int
j | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
x <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
y <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_bytes_append(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
op Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes",
      Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
TAKB Bool -> Bool -> Bool
|| Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
DRPB -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
n <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
b <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_bytes_cut(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
TAKB then Text
"1" else Text
"0") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
IDXB Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes",
      Just Int
noneIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.optionalRef PackedTag
TT.noneTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        let PackedTag Word64
someTag = PackedTag
TT.someTag
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
ix <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
b <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
        Text
none <- Int -> Gen Text
poolValue Int
noneIx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_bytes_index(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
none Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
someTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagNat FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- The rest of Text and Bytes (see that section of jit_rt.c): uncons and
  -- unsnoc, numbers to and from text, pack and unpack, indexOf, the
  -- orderings, and the foreign functions. A helper answers "not handled"
  -- for a form it doesn't decide, and the call-out does it.
  Prim1 Prim1
op Int
i
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text",
      Prim1
op Prim1 -> Prim1 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim1
UCNS Bool -> Bool -> Bool
|| Prim1
op Prim1 -> Prim1 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim1
USNC,
      Just Int
noneIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.optionalRef PackedTag
TT.noneTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)),
      Just Int
pairIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.pairRef (Word64 -> PackedTag
PackedTag Word64
0)) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)),
      Just Int
unitIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.unitRef PackedTag
TT.unitTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        let PackedTag Word64
someTag = PackedTag
TT.someTag
            PackedTag Word64
pairTag = PackedTag
TT.pairTag
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
t <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
none <- Int -> Gen Text
poolValue Int
noneIx
        Text
pair <- Int -> Gen Text
poolValue Int
pairIx
        Text
unit <- Int -> Gen Text
poolValue Int
unitIx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_text_uncons(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
none Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
someTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pair Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
pairTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagChar FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Prim1
op Prim1 -> Prim1 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim1
UCNS then Text
"1" else Text
"0") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
op Int
i
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text",
      Prim1
op Prim1 -> Prim1 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim1
ITOT Bool -> Bool -> Bool
|| Prim1
op Prim1 -> Prim1 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim1
NTOT -> do
        Text
n <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
r <- Text -> Gen Text
fresh Text
"text"
        Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @unison_jit_int_to_text(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Prim1
op Prim1 -> Prim1 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim1
ITOT then Text
"1" else Text
"0") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
        Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
r
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
FTOT Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text" -> do
    Text
bits <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
r <- Text -> Gen Text
fresh Text
"text"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @unison_jit_float_to_text(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
    Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
r
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
op Int
i
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text",
      Prim1
op Prim1 -> [Prim1] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim1
TTOI, Prim1
TTON, Prim1
TTOF],
      Just Int
noneIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.optionalRef PackedTag
TT.noneTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        let PackedTag Word64
someTag = PackedTag
TT.someTag
            !(Pair Text
tag Text
kind) = case Prim1
op of
              Prim1
TTOI -> Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair (FnEnv -> Text
feTagInt FnEnv
fe) Text
"0"
              Prim1
TTON -> Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair (FnEnv -> Text
feTagNat FnEnv
fe) Text
"1"
              Prim1
_ -> Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair (FnEnv -> Text
feTagFloat FnEnv
fe) Text
"2"
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
t <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
none <- Int -> Gen Text
poolValue Int
noneIx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_text_to_num(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
none Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
someTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
kind Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
PAKT Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
l <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_text_pack(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagChar FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
UPKT Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
t <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_text_unpack(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagChar FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
IXOT Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text",
      Just Int
noneIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.optionalRef PackedTag
TT.noneTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        let PackedTag Word64
someTag = PackedTag
TT.someTag
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
x <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
y <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
        Text
none <- Int -> Gen Text
poolValue Int
noneIx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_text_index_of(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
none Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
someTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagNat FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
op Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text",
      Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
LEQT Bool -> Bool -> Bool
|| Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
LEST -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
x <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
y <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
        Text
r <- Text -> Gen Text
fresh Text
"cmp"
        Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @unison_jit_text_cmp(ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Text
miss <- Text -> Gen Text
fresh Text
"miss"
        Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 2")
        Text -> Text -> Text -> Gen ()
branchIf Text
"text" Text
miss Text
slow
        Text
c <- Text -> Gen Text
fresh Text
"bool"
        Text -> Gen ()
emit (Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
LEQT then Text
"sle" else Text
"slt") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
        FnEnv -> Int -> Text -> Gen ()
resultBool FnEnv
fe Int
d Text
c
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
PAKB Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
l <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_bytes_pack(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagNat FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
UPKB Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
b <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_bytes_unpack(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagNat FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
IXOB Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes",
      Just Int
noneIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.optionalRef PackedTag
TT.noneTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        let PackedTag Word64
someTag = PackedTag
TT.someTag
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
x <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
y <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
        Text
none <- Int -> Gen Text
poolValue Int
noneIx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_bytes_index_of(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
none Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
someTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagNat FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
Text_repeat Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text",
      Int
kn :<| Int
kt :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
n <- Int -> Gen Text
loadU Int
kn
        Text
t <- Int -> Gen Text
loadB Int
kt
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_text_repeat(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
f Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text",
      ForeignFunc
f ForeignFunc -> [ForeignFunc] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ForeignFunc
Text_reverse, ForeignFunc
Text_toUppercase, ForeignFunc
Text_toLowercase, ForeignFunc
Text_toUtf8],
      Int
kt :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
t <- Int -> Gen Text
loadB Int
kt
        let call :: Text
call = case ForeignFunc
f of
              ForeignFunc
Text_reverse -> Text
"@unison_jit_text_reverse(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
              ForeignFunc
Text_toUppercase -> Text
"@unison_jit_text_case(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 1)"
              ForeignFunc
Text_toLowercase -> Text
"@unison_jit_text_case(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 0)"
              ForeignFunc
_ -> Text
"@unison_jit_text_to_utf8(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow Text
call
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
Text_fromUtf8_impl_v3 Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text",
      Int
kb :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args,
      Just Int
eitherIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.eitherRef (Word64 -> PackedTag
PackedTag Word64
0)) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        let PackedTag Word64
rightTag = PackedTag
TT.rightTag
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
b <- Int -> Gen Text
loadB Int
kb
        Text
eith <- Int -> Gen Text
poolValue Int
eitherIx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_text_from_utf8(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
eith Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
rightTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
Char_toText Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text",
      Int
kc :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args -> do
        Text
c <- Int -> Gen Text
loadU Int
kc
        Text
r <- Text -> Gen Text
fresh Text
"text"
        Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @unison_jit_char_to_text(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
        Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
r
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
f Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes",
      Just (Pair Int
width Int
be) <- ForeignFunc -> Maybe (Pair Int Int)
decodeNatKind ForeignFunc
f,
      Int
kb :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args,
      Just Int
noneIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.optionalRef PackedTag
TT.noneTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)),
      Just Int
pairIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.pairRef (Word64 -> PackedTag
PackedTag Word64
0)) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)),
      Just Int
unitIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.unitRef PackedTag
TT.unitTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        let PackedTag Word64
someTag = PackedTag
TT.someTag
            PackedTag Word64
pairTag = PackedTag
TT.pairTag
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
b <- Int -> Gen Text
loadB Int
kb
        Text
none <- Int -> Gen Text
poolValue Int
noneIx
        Text
pair <- Int -> Gen Text
poolValue Int
pairIx
        Text
unit <- Int -> Gen Text
poolValue Int
unitIx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_bytes_decode_nat(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
width Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
be Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
none Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
someTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pair Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
pairTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagNat FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
f Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes",
      Just (Pair Int
width Int
be) <- ForeignFunc -> Maybe (Pair Int Int)
encodeNatKind ForeignFunc
f,
      Int
kn :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args -> do
        Text
n <- Int -> Gen Text
loadU Int
kn
        Text
r <- Text -> Gen Text
fresh Text
"bytes"
        Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr @unison_jit_bytes_encode_nat(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
width Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
be Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
        Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
r
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
f Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes",
      Just (Pair Int
width Int
be) <- ForeignFunc -> Maybe (Pair Int Int)
readKind ForeignFunc
f,
      Int
ki :<| Int
kb :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
ix <- Int -> Gen Text
loadU Int
ki
        Text
b <- Int -> Gen Text
loadB Int
kb
        Text
ok <- Text -> Gen Text
fresh Text
"ok"
        Text -> Gen ()
emit (Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @unison_jit_bytes_read_ok(ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
width Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Text
miss <- Text -> Gen Text
fresh Text
"miss"
        Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
        Text -> Text -> Text -> Gen ()
branchIf Text
"bytes" Text
miss Text
slow
        Text
v <- Text -> Gen Text
fresh Text
"read"
        Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @unison_jit_bytes_read_at(ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
width Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
be Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagNat FnEnv
fe) Text
v
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
f Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes",
      Just Int
base <- ForeignFunc -> Maybe Int
toBaseKind ForeignFunc
f,
      Int
kb :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
b <- Int -> Gen Text
loadB Int
kb
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_bytes_to_base(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
f Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes",
      Just Int
base <- ForeignFunc -> Maybe Int
fromBaseKind ForeignFunc
f,
      Int
kb :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args,
      Just Int
eitherIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.eitherRef (Word64 -> PackedTag
PackedTag Word64
0)) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        let PackedTag Word64
rightTag = PackedTag
TT.rightTag
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
b <- Int -> Gen Text
loadB Int
kb
        Text
eith <- Int -> Gen Text
poolValue Int
eitherIx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_bytes_from_base(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
eith Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
rightTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
IDXS Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"list",
      Just Int
noneIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.optionalRef PackedTag
TT.noneTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        let PackedTag Word64
someTag = PackedTag
TT.someTag
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
ix <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
l <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
        Text
none <- Int -> Gen Text
poolValue Int
noneIx
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_list_index(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
none Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
someTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
REFW Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"ref",
      Just Int
unitIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.unitRef PackedTag
TT.unitTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        FnEnv
-> Int
-> Int
-> Int
-> Int
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genRefWrite FnEnv
fe Int
d (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Int
unitIx GInstr (RComb Val)
instr MSection
sect
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
op Int
i Int
j
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"cmp",
      Prim2
op Prim2 -> [Prim2] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prim2
EQLU, Prim2
LEQU, Prim2
LESU, Prim2
CMPU] -> do
        FnEnv
-> Int
-> Prim2
-> Int
-> Int
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genUniversal FnEnv
fe Int
d Prim2
op (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) GInstr (RComb Val)
instr MSection
sect
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
MutableArray_size Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"array",
      Int
ka :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args -> do
        FnEnv
-> Int
-> Pair Int Int
-> Int
-> Maybe Int
-> Maybe (Pair Int Int)
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genArrayOp FnEnv
fe Int
d (FnEnv -> Pair Int Int
mutableArrayWrap FnEnv
fe) Int
ka Maybe Int
forall a. Maybe a
Nothing Maybe (Pair Int Int)
forall a. Maybe a
Nothing GInstr (RComb Val)
instr MSection
sect
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
MutableArray_read Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"array",
      Int
ka :<| Int
ki :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args -> do
        FnEnv
-> Int
-> Pair Int Int
-> Int
-> Maybe Int
-> Maybe (Pair Int Int)
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genArrayOp FnEnv
fe Int
d (FnEnv -> Pair Int Int
mutableArrayWrap FnEnv
fe) Int
ka (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
ki) Maybe (Pair Int Int)
forall a. Maybe a
Nothing GInstr (RComb Val)
instr MSection
sect
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
MutableArray_write Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"array",
      Int
ka :<| Int
ki :<| Int
kv :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args,
      Just Int
unitIx <- PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.unitRef PackedTag
TT.unitTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        FnEnv
-> Int
-> Pair Int Int
-> Int
-> Maybe Int
-> Maybe (Pair Int Int)
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genArrayOp FnEnv
fe Int
d (FnEnv -> Pair Int Int
mutableArrayWrap FnEnv
fe) Int
ka (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
ki) (Pair Int Int -> Maybe (Pair Int Int)
forall a. a -> Maybe a
Just (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
kv Int
unitIx)) GInstr (RComb Val)
instr MSection
sect
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
ImmutableArray_size Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"array",
      Int
ka :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args -> do
        FnEnv
-> Int
-> Pair Int Int
-> Int
-> Maybe Int
-> Maybe (Pair Int Int)
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genArrayOp FnEnv
fe Int
d (Layouts -> Pair Int Int
lArrayWrap (Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe))) Int
ka Maybe Int
forall a. Maybe a
Nothing Maybe (Pair Int Int)
forall a. Maybe a
Nothing GInstr (RComb Val)
instr MSection
sect
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
ImmutableArray_read Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"array",
      Int
ka :<| Int
ki :<| Deque Int
Empty <- FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args -> do
        FnEnv
-> Int
-> Pair Int Int
-> Int
-> Maybe Int
-> Maybe (Pair Int Int)
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genArrayOp FnEnv
fe Int
d (Layouts -> Pair Int Int
lArrayWrap (Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe))) Int
ka (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
ki) Maybe (Pair Int Int)
forall a. Maybe a
Nothing GInstr (RComb Val)
instr MSection
sect
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- the rest of the array builtins: C helpers (see "Arrays and Refs" in jit_rt.c)
  ForeignCall Bool
_ ForeignFunc
f Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"array",
      Just ArrayOp
op <- ForeignFunc -> Maybe ArrayOp
arrayForeign ForeignFunc
f -> do
        FnEnv
-> Int
-> ArrayOp
-> Deque Int
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genArrayForeign FnEnv
fe Int
d ArrayOp
op (FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args) GInstr (RComb Val)
instr MSection
sect
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ForeignCall Bool
_ ForeignFunc
f Args
args
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"ptr",
      Just PtrOp
op <- ForeignFunc -> Maybe PtrOp
ptrForeign ForeignFunc
f -> do
        FnEnv
-> Int
-> PtrOp
-> Deque Int
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genPtrOp FnEnv
fe Int
d PtrOp
op (FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args) GInstr (RComb Val)
instr MSection
sect
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  -- Universal.murmurHashUntyped is Value.value (VALU) followed by the
  -- foreign hash of the reflected value. The two together are one C helper
  -- that hashes the closures directly ("Universal.murmurHashUntyped" in
  -- jit_rt.c); the reflected value's slot gets the original value, which
  -- nothing reads. A value the helper doesn't handle goes to the call-out
  -- for VALU, after which the foreign call is a call-out of its own.
  Prim1 Prim1
VALU Int
i
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"hash",
      Ins GInstr (RComb Val)
_ (Ins (ForeignCall Bool
_ ForeignFunc
Universal_murmurHashUntyped (VArg1 Int
0)) MSection
rest) <- MSection
sect -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
u <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
b <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
r <- Text -> Gen Text
fresh Text
"pair"
        Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call { i64, i64 } @unison_jit_murmur(i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Text
ok <- Text -> Gen Text
fresh Text
"ok"
        Text -> Gen ()
emit (Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = extractvalue { i64, i64 } " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
        Text
miss <- Text -> Gen Text
fresh Text
"miss"
        Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
        Text -> Text -> Text -> Gen ()
branchIf Text
"hash" Text
miss Text
slow
        Text
h <- Text -> Gen Text
fresh Text
"hash"
        Text -> Gen ()
emit (Text
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = extractvalue { i64, i64 } " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
        Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
u
        Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
b
        FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (FnEnv -> Text
feTagNat FnEnv
fe) Text
h
        FnEnv -> Int -> MSection -> Gen ()
genSection FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) MSection
rest
  -- Refs: Scope.ref, Ref.readForCas, Ticket.read and Ref.cas
  Prim1 Prim1
REFN Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"ref" -> do
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
u <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
b <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text -> Deque Text -> Gen ()
requireTagged Text
slow (Text -> Deque Text
forall a. a -> Deque a
D.singleton Text
b)
    Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_ref_new(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
RRFC Int
i
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"ref",
      Bool -> Bool
not (Env -> Bool
envSandboxed (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
r <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_ref_read_for_cas(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim1 Prim1
TIKR Int
i | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"ref" -> do
    let ls :: Layouts
ls = Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe)
    Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
    Text
p <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
raw <- Text -> Gen Text
fresh Text
"raw"
    Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
    Text
fo <- Text -> Text -> Int -> Text -> Gen Text
taggedObject Text
"foreign" Text
raw (Layouts -> Int
lForeignInfo Layouts
ls) Text
slow
    Text
wrapped <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
fo Text
"wrap" Text
"i64" (Layouts -> Int
lHeaderBytes Layouts
ls)
    Text
w <- Text -> Text -> Pair Int Int -> Text -> Gen Text
taggedObjectTag Text
"ticket" Text
wrapped (Layouts -> Pair Int Int
lTicketWrap Layouts
ls) Text
slow
    Text
valp <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
w Text
"val" Text
"i64" (Layouts -> Int
lHeaderBytes Layouts
ls)
    Pair Text
u Text
b <- FnEnv -> Text -> Text -> Gen (Pair Text Text)
valFields FnEnv
fe Text
valp Text
slow
    Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
u
    Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
b
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  RefCAS Int
i Int
j Int
kv
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"ref",
      Bool -> Bool
not (Env -> Bool
envSandboxed (FnEnv -> Env
feEnv FnEnv
fe)) -> do
        Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
        Text
r <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
        Text
t <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
        Text
u <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
kv)
        Text
b <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
kv)
        Text -> Deque Text -> Gen ()
requireTagged Text
slow (Text -> Deque Text
forall a. a -> Deque a
D.singleton Text
b)
        Text
res <- Text -> Gen Text
fresh Text
"cas"
        Text -> Gen ()
emit (Text
res Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @unison_jit_ref_cas(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
        Text
miss <- Text -> Gen Text
fresh Text
"miss"
        Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp slt i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
res Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
        Text -> Text -> Text -> Gen ()
branchIf Text
"cas" Text
miss Text
slow
        Text
c <- Text -> Gen Text
fresh Text
"c"
        Text -> Gen ()
emit (Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
res Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
        FnEnv -> Int -> Text -> Gen ()
resultBool FnEnv
fe Int
d Text
c
        Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Prim2 Prim2
op Int
i Int
j | Prim2 -> Bool
prim2Supported Prim2
op -> do
    Text
x <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
    Text
y <- Int -> Gen Text
loadU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)
    FnEnv -> Int -> Prim2 -> Text -> Text -> MSection -> Gen ()
genPrim2 FnEnv
fe Int
d Prim2
op Text
x Text
y MSection
sect
    Int -> Gen ()
k (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  GInstr (RComb Val)
_ -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen ()
genCallOut FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect

-- | The boolean in slot @k@ as an i1. One still held as an i1 costs
-- nothing; otherwise the closure must be an enumeration (else @slow@),
-- and it is true unless its tag is the false constructor's, which is how
-- the interpreter reads one.
loadBoolean :: FnEnv -> Int -> Text -> Gen Text
loadBoolean :: FnEnv -> Int -> Text -> Gen Text
loadBoolean FnEnv
fe Int
k Text
slow =
  Int -> Gen (Maybe Text)
slotKind Int
k Gen (Maybe Text) -> (Maybe Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Text
c -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
c
    Maybe Text
Nothing -> do
      let layout :: Layout
layout = Layouts -> Vector Layout
lData (Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe)) Vector Layout -> Int -> Layout
forall a. Vector a -> Int -> a
V.! Int
0
          PackedTag Word64
false = PackedTag
TT.falseTag
      Text
p <- Int -> Gen Text
loadB Int
k
      Text
raw <- Text -> Gen Text
fresh Text
"raw"
      Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
      Text
tagBits <- Text -> Gen Text
fresh Text
"ptrtag"
      Text -> Gen ()
emit (Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
      Text
notEnum <- Text -> Gen Text
fresh Text
"notenum"
      Text -> Gen ()
emit (Text
notEnum Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lPtrTag Layout
layout))
      Text -> Text -> Text -> Gen ()
branchIf Text
"enum" Text
notEnum Text
slow
      Text
base <- Text -> Gen Text
fresh Text
"base"
      Text -> Gen ()
emit (Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -8")
      Text
packed <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
base Text
"tag" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout (Layout -> Int
lPtrs Layout
layout))
      Text
c <- Text -> Gen Text
fresh Text
"bool"
      Text -> Gen ()
emit (Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
packed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
false)
      pure Text
c

-- | An instruction the generator has no code for: the interpreter runs
-- it, and native code continues after it in an auxiliary function (a
-- re-entry point). Not worth it when the instruction's results are
-- yielded straight away, or when the instruction reshapes the stack; the
-- interpreter then takes the whole section.
genCallOut :: FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen ()
genCallOut :: FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen ()
genCallOut FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect = do
  Text
l <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
False FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
  Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l)

-- | The exit block for leaving an instruction to the interpreter: a
-- call-out when one is possible, else a resume at the section. Also the
-- slow path of instructions with a native fast path (@slowPath@): the
-- code after a slow path is only needed when the fast path misses, so its
-- re-entry function can be left for later.
callOutExit :: Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit :: Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
slowPath FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect = case (GInstr (RComb Val) -> Maybe Int
forall comb. GInstr comb -> Maybe Int
pushCount GInstr (RComb Val)
instr, MSection
sect) of
  (Just Int
n, Ins GInstr (RComb Val)
_ MSection
rest)
    | FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"callout",
      GInstr (RComb Val) -> MSection -> Bool
callOutWorthwhile GInstr (RComb Val)
instr MSection
rest ->
        Bool
-> FnEnv
-> Int
-> Int
-> MSection
-> Gen (Maybe (Pair Text (Ptr NativeCell)))
genAuxFunction Bool
slowPath FnEnv
fe (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) (FnEnv -> Int
currentBase FnEnv
fe) MSection
rest Gen (Maybe (Pair Text (Ptr NativeCell)))
-> (Maybe (Pair Text (Ptr NativeCell)) -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe (Pair Text (Ptr NativeCell))
Nothing -> Gen Text
resume
          Just (Pair Text
_ Ptr NativeCell
cell) -> FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx
-> GInstr (RComb Val) -> MSection -> Int -> Ptr NativeCell -> Exit
CallOut (FnEnv -> CombIx
feCix FnEnv
fe) GInstr (RComb Val)
instr MSection
rest Int
n Ptr NativeCell
cell)
  (Maybe Int, MSection)
_ -> Gen Text
resume
  where
    resume :: Gen Text
resume = FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)

-- | How many values an instruction leaves on the stack, or Nothing for
-- one that changes the stack in other ways (captures and discards cut it
-- back to a mark). MCode doesn't record this, so the trampoline checks
-- the stack pointer against it before re-entering native code; a wrong
-- entry here costs a resume, not correctness. Every constructor is
-- listed so that a new instruction fails to compile until it is added.
-- | The slots a @Pack@'s arguments come from, in field order, when the
-- code generator can build the constructor (one or two fields so far).
packFields :: FnEnv -> Int -> Args -> Maybe (Deque Int)
packFields :: FnEnv -> Int -> Args -> Maybe (Deque Int)
packFields FnEnv
fe Int
d Args
args = case Args
args of
  Args
ZArgs -> Maybe (Deque Int)
forall a. Maybe a
Nothing
  Args
_ -> Deque Int -> Maybe (Deque Int)
forall a. a -> Maybe a
Just (FnEnv -> Int -> Args -> Deque Int
argSources FnEnv
fe Int
d Args
args)

-- | Branches to @slow@ if any of the boxed values is an untagged pointer.
-- The interpreter can leave one in a stack slot: a top-level constant such
-- as @noneClo@ stored as itself puts the static closure's address there,
-- which is untagged whether or not the CAF has been forced (the bang in
-- @bpoke@ evaluates it but stores the same pointer). Native code must not copy
-- such a pointer into a strict field (a @Val@'s, a constructor's), because
-- GHC's optimized code reads a strict field without evaluating it and
-- would take the thunk's words for the constructor's fields. Reads through
-- a pointer are guarded by the tag switch in 'genDMatchClosure'; this
-- guards the writes. (Found 2026-10-03: a @None@ from a call-out packed into
-- a pair crashed the GC in eager mode on the optimized build.)
requireTagged :: Text -> Deque Text -> Gen ()
requireTagged :: Text -> Deque Text -> Gen ()
requireTagged Text
slow Deque Text
bs = do
  Deque Text
zs <- Deque Text -> (Text -> Gen Text) -> StateT GS Identity (Deque Text)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Deque Text
bs ((Text -> Gen Text) -> StateT GS Identity (Deque Text))
-> (Text -> Gen Text) -> StateT GS Identity (Deque Text)
forall a b. (a -> b) -> a -> b
$ \Text
b -> do
    Text
raw <- Text -> Gen Text
fresh Text
"raw"
    Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
    Text
t <- Text -> Gen Text
fresh Text
"ptrtag"
    Text -> Gen ()
emit (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
    Text
z <- Text -> Gen Text
fresh Text
"untagged"
    Text -> Gen ()
emit (Text
z Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
    pure Text
z
  case Deque Text
zs of
    Deque Text
Empty -> () -> Gen ()
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Text
z0 :<| Deque Text
rest -> do
      Text
anyZ <- (Text -> Text -> Gen Text) -> Text -> Deque Text -> Gen Text
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Text
acc Text
z -> do Text
r <- Text -> Gen Text
fresh Text
"untagged"; Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
z); pure Text
r) Text
z0 Deque Text
rest
      Text -> Text -> Text -> Gen ()
branchIf Text
"tagged" Text
anyZ Text
slow

-- | Allocates a constructor with the given fields and pushes it. The
-- reference comes from the pool entry for the type's enumeration
-- constructor 0 (its first field). Each Pack allocates separately, since
-- a run of instructions can exit between two Packs and words taken for a
-- later one would be left uninitialized in the nursery, which the debug
-- RTS's heap walker rejects. An untagged field value goes to @slow@.
genPack :: FnEnv -> Int -> Int -> PackedTag -> Deque Int -> Text -> Gen ()
genPack :: FnEnv -> Int -> Int -> PackedTag -> Deque Int -> Text -> Gen ()
genPack FnEnv
fe Int
d Int
refIx (PackedTag Word64
t) Deque Int
fields Text
slow = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      ls :: Layouts
ls = Env -> Layouts
envLayouts Env
env
      rts :: RtsFacts
rts = Env -> RtsFacts
envRts Env
env
      n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
fields
      wide :: Bool
wide = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
6
      layout :: Layout
layout = if Bool
wide then Layouts -> Layout
lDataG Layouts
ls else Layouts -> Vector Layout
lData Layouts
ls Vector Layout -> Int -> Layout
forall a. Vector a -> Int -> a
V.! Int
n
      ptrTag :: Int
ptrTag = Layout -> Int
lPtrTag Layout
layout
      conWords :: Int
conWords = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lNptrs Layout
layout
      -- a DataG also gets its two arrays, in the same chunk
      cardWords :: Int
cardWords = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` RtsFacts -> Int
rCardBits RtsFacts
rts) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` RtsFacts -> Int
rCardBits RtsFacts
rts
      cardWords' :: Int
cardWords' = (Int
cardWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
      bytesWords :: Int
bytesWords = RtsFacts -> Int
rBytesHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
      ptrsWords :: Int
ptrsWords = RtsFacts -> Int
rPtrsHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cardWords'
      words :: Int
words
        | Bool
wide = Int
conWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bytesWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ptrsWords
        | Bool
otherwise = Int
conWords
  -- the fields, before the allocation call so nothing is held across it
  Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
fields
  Text -> Deque Text -> Gen ()
requireTagged Text
slow ((Pair Text Text -> Text) -> Deque (Pair Text Text) -> Deque Text
forall a b. (a -> b) -> Deque a -> Deque b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Pair Text
_ Text
b) -> Text
b) Deque (Pair Text Text)
vals)
  -- the Reference: the pointer field of the pool's Enum for this type
  Int -> Gen ()
usePool Int
refIx
  Text
ea <- Text -> Gen Text
fresh Text
"enum.a"
  Text -> Gen ()
emit (Text
ea Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr ptr, ptr %pool, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
refIx)
  Text
ep <- Text -> Gen Text
fresh Text
"enum"
  Text -> Gen ()
emit (Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ea)
  Text
ei <- Text -> Gen Text
fresh Text
"enum"
  Text -> Gen ()
emit (Text
ei Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
eb <- Text -> Gen Text
fresh Text
"enum.base"
  Text -> Gen ()
emit (Text
eb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ei Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -8")
  Text
ra <- Text -> Gen Text
fresh Text
"ref.a"
  Text -> Gen ()
emit (Text
ra Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
eb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int -> Int
lFieldOffset (Layouts -> Vector Layout
lData Layouts
ls Vector Layout -> Int -> Layout
forall a. Vector a -> Int -> a
V.! Int
0) Int
0))
  Text
rp <- Text -> Gen Text
fresh Text
"ref.p"
  Text -> Gen ()
emit (Text
rp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ra Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Text
ref <- Text -> Gen Text
fresh Text
"ref"
  Text -> Gen ()
emit (Text
ref Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rp)
  -- charge the budget and allocate
  Text
obj <- Env -> Int -> Gen Text
allocWords Env
env Int
words
  let word :: Int -> Gen Text
word Int
i = do
        Text
a <- Text -> Gen Text
fresh Text
"w"
        Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
i)
        pure Text
a
      payload :: Int -> Gen Text
payload Int
i = Int -> Gen Text
word (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) -- after the header
      storeAt :: Int -> Text -> Gen ()
storeAt Int
i Text
what = do
        Text
a <- Int -> Gen Text
word Int
i
        Text -> Gen ()
emit (Text
"store " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a)
  Text
hdr <- Int -> Gen Text
word Int
0
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lInfo Layout
layout) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hdr)
  -- the reference is the last pointer, the tag the first word after it
  Text
refA <- Int -> Gen Text
payload (Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ref Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
refA)
  Text
tagA <- Int -> Gen Text
payload (Layout -> Int
lPtrs Layout
layout)
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagA)
  if Bool -> Bool
not Bool
wide
    then Deque (Pair Text Text)
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall (m :: * -> *) a.
Monad m =>
Deque a -> (Int -> a -> m ()) -> m ()
iforM_ Deque (Pair Text Text)
vals ((Int -> Pair Text Text -> Gen ()) -> Gen ())
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j (Pair Text
u Text
b) -> do
      Text
ba <- Int -> Gen Text
payload Int
j
      Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
      Text
ua <- Int -> Gen Text
payload (Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j)
      Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
    else do
      -- the chunk after the constructor: the ByteArray#, then the Array#.
      -- The arrays hold the fields in reverse: element n-1-j is field j.
      let ubytes :: Int
ubytes = Int
conWords
          bptrs :: Int
bptrs = Int
ubytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bytesWords
      Int -> Text -> Gen ()
storeAt Int
ubytes (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rArrWordsInfo RtsFacts
rts))
      Int -> Text -> Gen ()
storeAt (Int
ubytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rBytesCount RtsFacts
rts) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n))
      -- the Array#: element count, then payload size including the card table
      Int -> Text -> Gen ()
storeAt Int
bptrs (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rArrPtrsInfo RtsFacts
rts))
      Int -> Text -> Gen ()
storeAt (Int
bptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsCount RtsFacts
rts) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n)
      Int -> Text -> Gen ()
storeAt (Int
bptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsSize RtsFacts
rts) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cardWords'))
      [Int] -> (Int -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
cardWords' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> Gen ()) -> Gen ()) -> (Int -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
c -> Int -> Text -> Gen ()
storeAt (Int
bptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c) Text
"i64 0"
      Deque (Pair Text Text)
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall (m :: * -> *) a.
Monad m =>
Deque a -> (Int -> a -> m ()) -> m ()
iforM_ Deque (Pair Text Text)
vals ((Int -> Pair Text Text -> Gen ()) -> Gen ())
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j (Pair Text
u Text
b) -> do
        Int -> Text -> Gen ()
storeAt (Int
ubytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rBytesHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u)
        Int -> Text -> Gen ()
storeAt (Int
bptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)) (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b)
      -- the constructor's two array fields
      Text
ua <- Int -> Gen Text
word Int
ubytes
      Int -> Text -> Gen ()
storeAt Int
1 (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
      Text
ba <- Int -> Gen Text
word Int
bptrs
      Int -> Text -> Gen ()
storeAt Int
2 (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
  -- the result is the tagged pointer
  Text
oi <- Text -> Gen Text
fresh Text
"obj"
  Text -> Gen ()
emit (Text
oi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
ti <- Text -> Gen Text
fresh Text
"tagged"
  Text -> Gen ()
emit (Text
ti Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
oi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
ptrTag :: Int))
  Text
tp <- Text -> Gen Text
fresh Text
"tagged"
  Text -> Gen ()
emit (Text
tp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ti Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
  Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
tp

-- | Allocates a record with the given fields (in ascending field-name
-- order, the shape's slot order) and pushes it: the record closure, its
-- values' @Array#@ and a @Val@ box per field, in one chunk. The shape's
-- words (the names' array, the field numbers' and the slots' arrays, the
-- shape reference, the names' offset and length) are copied from the pool's
-- empty record of the shape at @protoIx@. An untagged field value goes to @slow@.
genRecPack :: FnEnv -> Int -> Int -> Deque Int -> Text -> Gen ()
genRecPack :: FnEnv -> Int -> Int -> Deque Int -> Text -> Gen ()
genRecPack FnEnv
fe Int
d Int
protoIx Deque Int
fields Text
slow = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      ls :: Layouts
ls = Env -> Layouts
envLayouts Env
env
      rts :: RtsFacts
rts = Env -> RtsFacts
envRts Env
env
      layout :: Layout
layout = Layouts -> Layout
lRecord Layouts
ls
      vl :: Layout
vl = Layouts -> Layout
lVal Layouts
ls
      n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
fields
      recWords :: Int
recWords = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lNptrs Layout
layout
      cardWords :: Int
cardWords = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` RtsFacts -> Int
rCardBits RtsFacts
rts) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` RtsFacts -> Int
rCardBits RtsFacts
rts
      cardWords' :: Int
cardWords' = (Int
cardWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
      arrWords :: Int
arrWords = RtsFacts -> Int
rPtrsHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cardWords'
      valWords :: Int
valWords = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
vl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lNptrs Layout
vl
      words :: Int
words = Int
recWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
arrWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
valWords
      -- the chunk: the record, then the Array#, then the Vals
      arr :: Int
arr = Int
recWords
      valsAt :: Int
valsAt = Int
arr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
arrWords
  -- the fields, before the allocation call so nothing is held across it
  Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
fields
  Text -> Deque Text -> Gen ()
requireTagged Text
slow ((Pair Text Text -> Text) -> Deque (Pair Text Text) -> Deque Text
forall a b. (a -> b) -> Deque a -> Deque b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Pair Text
_ Text
b) -> Text
b) Deque (Pair Text Text)
vals)
  -- the shape, from the prototype
  Text
proto <- Int -> Gen Text
poolValue Int
protoIx
  Text
pi' <- Text -> Gen Text
fresh Text
"proto"
  Text -> Gen ()
emit (Text
pi' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
proto Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
pb <- Text -> Gen Text
fresh Text
"proto.base"
  Text -> Gen ()
emit (Text
pb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pi' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -8")
  Text
names <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
pb Text
"names" Text
"ptr" (Layout -> Int -> Int
lFieldOffset Layout
layout Int
0)
  Text
keys <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
pb Text
"keys" Text
"ptr" (Layout -> Int -> Int
lFieldOffset Layout
layout Int
1)
  Text
slots <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
pb Text
"slots" Text
"ptr" (Layout -> Int -> Int
lFieldOffset Layout
layout Int
2)
  Text
ref <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
pb Text
"shaperef" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout (Layout -> Int
lPtrs Layout
layout))
  Text
noff <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
pb Text
"noff" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout (Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
  Text
nlen <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
pb Text
"nlen" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout (Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2))
  -- charge the budget and allocate
  Text
obj <- Env -> Int -> Gen Text
allocWords Env
env Int
words
  let word :: Int -> Gen Text
word Int
i = do
        Text
a <- Text -> Gen Text
fresh Text
"w"
        Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
i)
        pure Text
a
      storeAt :: Int -> Text -> Gen ()
storeAt Int
i Text
what = do
        Text
a <- Int -> Gen Text
word Int
i
        Text -> Gen ()
emit (Text
"store " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a)
      tagged :: Int -> Int -> Gen Text
tagged Int
i Int
tg = do
        Text
a <- Int -> Gen Text
word Int
i
        Text
v <- Text -> Gen Text
fresh Text
"addr"
        Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
        Text
tv <- Text -> Gen Text
fresh Text
"tagged"
        Text -> Gen ()
emit (Text
tv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
tg :: Int))
        Text
tp <- Text -> Gen Text
fresh Text
"tagged"
        Text -> Gen ()
emit (Text
tp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
        pure Text
tp
  -- the Array#: element count, then payload size including the card table
  Int -> Text -> Gen ()
storeAt Int
arr (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rArrPtrsInfo RtsFacts
rts))
  Int -> Text -> Gen ()
storeAt (Int
arr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsCount RtsFacts
rts) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n)
  Int -> Text -> Gen ()
storeAt (Int
arr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsSize RtsFacts
rts) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cardWords'))
  [Int] -> (Int -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
cardWords' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> Gen ()) -> Gen ()) -> (Int -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
c -> Int -> Text -> Gen ()
storeAt (Int
arr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c) Text
"i64 0"
  -- the Vals: pointer b, then word u; element j of the array is Val j (tag 1)
  Deque (Pair Text Text)
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall (m :: * -> *) a.
Monad m =>
Deque a -> (Int -> a -> m ()) -> m ()
iforM_ Deque (Pair Text Text)
vals ((Int -> Pair Text Text -> Gen ()) -> Gen ())
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j (Pair Text
u Text
b) -> do
    let vb :: Int
vb = Int
valsAt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
valWords
    Int -> Text -> Gen ()
storeAt Int
vb (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lInfo Layout
vl))
    Int -> Text -> Gen ()
storeAt (Int
vb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b)
    Int -> Text -> Gen ()
storeAt (Int
vb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
vl) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u)
    Text
vp <- Int -> Int -> Gen Text
tagged Int
vb Int
1
    Int -> Text -> Gen ()
storeAt (Int
arr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j) (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
vp)
  -- the record: the shape's words, then the values' array, offset and length
  Int -> Text -> Gen ()
storeAt Int
0 (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lInfo Layout
layout))
  Int -> Text -> Gen ()
storeAt Int
1 (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
names)
  Int -> Text -> Gen ()
storeAt Int
2 (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
keys)
  Int -> Text -> Gen ()
storeAt Int
3 (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slots)
  Text
ap <- Int -> Gen Text
word Int
arr
  Int -> Text -> Gen ()
storeAt Int
4 (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ap)
  Int -> Text -> Gen ()
storeAt (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
layout) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ref)
  Int -> Text -> Gen ()
storeAt (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
layout) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
noff)
  Int -> Text -> Gen ()
storeAt (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
layout) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nlen)
  Int -> Text -> Gen ()
storeAt (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
layout) Text
"i64 0"
  Int -> Text -> Gen ()
storeAt (Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
layout) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n)
  Text
tp <- Int -> Int -> Gen Text
tagged Int
0 (Layout -> Int
lPtrTag Layout
layout)
  Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
  Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
tp

-- | Pushes the named fields of the record in slot @d - i@ onto slots
-- d+1..d+n, first field on top (as the interpreter's @dumpSeg@ does). The
-- slot of each field comes from the value's own shape, through
-- @unison_jit_rec_pos@, since the same code runs for records of every
-- shape the pattern matches. Anything that isn't a record, a field the
-- record doesn't have, or an element that isn't an evaluated @Val@
-- branches to @slow@.
genRecUnpack :: FnEnv -> Int -> Int -> [FieldRef] -> Text -> Gen ()
genRecUnpack :: FnEnv -> Int -> Int -> [FieldRef] -> Text -> Gen ()
genRecUnpack FnEnv
fe Int
d Int
i [FieldRef]
fields Text
slow = do
  let ls :: Layouts
ls = Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe)
      rts :: RtsFacts
rts = Env -> RtsFacts
envRts (FnEnv -> Env
feEnv FnEnv
fe)
      layout :: Layout
layout = Layouts -> Layout
lRecord Layouts
ls
      vl :: Layout
vl = Layouts -> Layout
lVal Layouts
ls
      n :: Int
n = [FieldRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FieldRef]
fields
  Text
p <- Int -> Gen Text
loadB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
  Text
raw <- Text -> Gen Text
fresh Text
"raw"
  Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
tagBits <- Text -> Gen Text
fresh Text
"ptrtag"
  Text -> Gen ()
emit (Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
  Text
notTag <- Text -> Gen Text
fresh Text
"notrec"
  Text -> Gen ()
emit (Text
notTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lPtrTag Layout
layout))
  Text -> Text -> Text -> Gen ()
branchIf Text
"record" Text
notTag Text
slow
  Text
base <- Text -> Gen Text
fresh Text
"base"
  Text -> Gen ()
emit (Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -8")
  Text
info <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
base Text
"info" Text
"i64" Int
0
  Text
notRec <- Text -> Gen Text
fresh Text
"notrec"
  Text -> Gen ()
emit (Text
notRec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
info Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lInfo Layout
layout))
  Text -> Text -> Text -> Gen ()
branchIf Text
"record" Text
notRec Text
slow
  Text
arr <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
base Text
"vals" Text
"ptr" (Layout -> Int -> Int
lFieldOffset Layout
layout Int
3)
  Text
voff <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
base Text
"voff" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
layout (Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3))
  [(Int, FieldRef)] -> ((Int, FieldRef) -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [FieldRef] -> [(Int, FieldRef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [FieldRef]
fields) (((Int, FieldRef) -> Gen ()) -> Gen ())
-> ((Int, FieldRef) -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \(Int
j, FieldRef Word64
f) -> do
    Text
pos <- Text -> Gen Text
fresh Text
"pos"
    Text -> Gen ()
emit (Text
pos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @unison_jit_rec_pos(ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text
missing <- Text -> Gen Text
fresh Text
"nofield"
    Text -> Gen ()
emit (Text
missing Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp slt i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
    Text -> Text -> Text -> Gen ()
branchIf Text
"field" Text
missing Text
slow
    Text
ix <- Text -> Gen Text
fresh Text
"ix"
    Text -> Gen ()
emit (Text
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
voff Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos)
    Text
ix' <- Text -> Gen Text
fresh Text
"ix"
    Text -> Gen ()
emit (Text
ix' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rPtrsHeader RtsFacts
rts))
    Text
ea <- Text -> Gen Text
fresh Text
"elem.a"
    Text -> Gen ()
emit (Text
ea Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ix')
    Text
v <- Text -> Gen Text
fresh Text
"elem"
    Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ea)
    Text
vi <- Text -> Gen Text
fresh Text
"elem"
    Text -> Gen ()
emit (Text
vi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
    Text
vt <- Text -> Gen Text
fresh Text
"elem.tag"
    Text -> Gen ()
emit (Text
vt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
vi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
    Text
notVal <- Text -> Gen Text
fresh Text
"notval"
    Text -> Gen ()
emit (Text
notVal Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
vt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lPtrTag Layout
vl))
    Text -> Text -> Text -> Gen ()
branchIf Text
"val" Text
notVal Text
slow
    Text
vb <- Text -> Gen Text
fresh Text
"elem.base"
    Text -> Gen ()
emit (Text
vb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
vi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -8")
    Text
b <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
vb Text
"fb" Text
"ptr" (Layout -> Int -> Int
lFieldOffset Layout
vl Int
0)
    Text
u <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
vb Text
"fu" Text
"i64" (Layout -> Int -> Int
lFieldOffset Layout
vl (Layout -> Int
lPtrs Layout
vl))
    Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Text
u
    Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Text
b

-- | Loads through a Ref: the closure in slot @k@ must be @Foreign
-- (WrapIORef ref)@, checked by info pointer, and the MutVar#'s content an
-- evaluated @Val@ (pointer tag 1). Anything else branches to @slow@.
-- Gives the MutVar# address and the Val's fields.
refFields :: FnEnv -> Int -> Text -> Gen (Triple Text Text Text)
refFields :: FnEnv -> Int -> Text -> Gen (Triple Text Text Text)
refFields FnEnv
fe Int
k Text
slow = do
  let ls :: Layouts
ls = Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe)
      rts :: RtsFacts
rts = Env -> RtsFacts
envRts (FnEnv -> Env
feEnv FnEnv
fe)
      check :: Text -> Text -> Gen ()
check Text
what Text
c = do
        Text
l <- Text -> Gen Text
freshLabel Text
what
        Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
        Text -> Gen ()
startBlock Text
l
      loadFrom :: Text -> Text -> Text -> a -> Gen Text
loadFrom Text
from Text
what Text
ty a
off = do
        Text
a <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a")
        Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
from Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow a
off)
        Text
pp <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".p")
        Text -> Gen ()
emit (Text
pp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
        Text
v <- Text -> Gen Text
fresh Text
what
        Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pp)
        pure Text
v
      -- an object with pointer tag 7 and the given info pointer; gives its untagged address
      object :: Text -> Text -> Int -> Gen Text
object Text
what Text
raw Int
info = do
        Text
tagBits <- Text -> Gen Text
fresh Text
"ptrtag"
        Text -> Gen ()
emit (Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
        Text
notTag <- Text -> Gen Text
fresh Text
"nottag"
        Text -> Gen ()
emit (Text
notTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
        Text -> Text -> Gen ()
check Text
what Text
notTag
        Text
base <- Text -> Gen Text
fresh Text
what
        Text -> Gen ()
emit (Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -8")
        Text
i <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
base (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".info") Text
"i64" (Int
0 :: Int)
        Text
notInfo <- Text -> Gen Text
fresh Text
"notinfo"
        Text -> Gen ()
emit (Text
notInfo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
info)
        Text -> Text -> Gen ()
check Text
what Text
notInfo
        pure Text
base
  Text
p <- Int -> Gen Text
loadB Int
k
  Text
raw <- Text -> Gen Text
fresh Text
"raw"
  Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
fo <- Text -> Text -> Int -> Gen Text
object Text
"foreign" Text
raw (Layouts -> Int
lForeignInfo Layouts
ls)
  Text
wrapped <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
fo Text
"wrap" Text
"i64" (Layouts -> Int
lHeaderBytes Layouts
ls)
  Text
w <- Text -> Text -> Int -> Gen Text
object Text
"ioref" Text
wrapped (Layouts -> Int
lIORefInfo Layouts
ls)
  Text
mv <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
w Text
"mutvar" Text
"i64" (Layouts -> Int
lHeaderBytes Layouts
ls)
  Text
valp <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
mv Text
"val" Text
"i64" (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* RtsFacts -> Int
rMutVarVar RtsFacts
rts)
  Text
vtag <- Text -> Gen Text
fresh Text
"ptrtag"
  Text -> Gen ()
emit (Text
vtag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
valp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
  Text
notVal <- Text -> Gen Text
fresh Text
"notval"
  Text -> Gen ()
emit (Text
notVal Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
vtag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lPtrTag (Layouts -> Layout
lVal Layouts
ls)))
  Text -> Text -> Gen ()
check Text
"val" Text
notVal
  Text
vbase <- Text -> Gen Text
fresh Text
"val"
  Text -> Gen ()
emit (Text
vbase Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
valp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -8")
  Text
b <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
vbase Text
"vb" Text
"ptr" (Layout -> Int -> Int
lFieldOffset (Layouts -> Layout
lVal Layouts
ls) Int
0)
  Text
u <- Text -> Text -> Text -> Int -> Gen Text
forall {a}. Show a => Text -> Text -> Text -> a -> Gen Text
loadFrom Text
vbase Text
"vu" Text
"i64" (Layout -> Int -> Int
lFieldOffset (Layouts -> Layout
lVal Layouts
ls) Int
1)
  pure (Text -> Text -> Text -> Triple Text Text Text
forall a b c. a -> b -> c -> Triple a b c
Triple Text
mv Text
u Text
b)

-- | @Ref.read@: the Val's fields go to the result slot.
genRefRead :: FnEnv -> Int -> Int -> GInstr (RComb Val) -> MSection -> Gen ()
genRefRead :: FnEnv -> Int -> Int -> GInstr (RComb Val) -> MSection -> Gen ()
genRefRead FnEnv
fe Int
d Int
k GInstr (RComb Val)
instr MSection
sect = do
  Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
  Triple Text
_ Text
u Text
b <- FnEnv -> Int -> Text -> Gen (Triple Text Text Text)
refFields FnEnv
fe Int
k Text
slow
  Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
u
  Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
b

-- | @Ref.write@: a fresh @Val@ holding the value, stored through the
-- runtime's barrier; the result is unit.
genRefWrite :: FnEnv -> Int -> Int -> Int -> Int -> GInstr (RComb Val) -> MSection -> Gen ()
genRefWrite :: FnEnv
-> Int
-> Int
-> Int
-> Int
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genRefWrite FnEnv
fe Int
d Int
k Int
kv Int
unitIx GInstr (RComb Val)
instr MSection
sect = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      ls :: Layouts
ls = Env -> Layouts
envLayouts Env
env
      layout :: Layout
layout = Layouts -> Layout
lVal Layouts
ls
      words :: Int
words = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lNptrs Layout
layout
  Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
  -- the value, before anything else: the allocation call is a GC-safe
  -- point only for what is on the Unison stack, not for registers
  Text
u <- Int -> Gen Text
loadU Int
kv
  Text
b <- Int -> Gen Text
loadB Int
kv
  Text -> Deque Text -> Gen ()
requireTagged Text
slow (Text -> Deque Text
forall a. a -> Deque a
D.singleton Text
b)
  Triple Text
mv Text
_ Text
_ <- FnEnv -> Int -> Text -> Gen (Triple Text Text Text)
refFields FnEnv
fe Int
k Text
slow
  Text
obj <- Env -> Int -> Gen Text
allocWords Env
env Int
words
  Text
hdr <- Text -> Gen Text
fresh Text
"w"
  Text -> Gen ()
emit (Text
hdr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 0")
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lInfo Layout
layout) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hdr)
  Text
ba <- Text -> Gen Text
fresh Text
"w"
  Text -> Gen ()
emit (Text
ba Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 1")
  Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
  Text
ua <- Text -> Gen Text
fresh Text
"w"
  Text -> Gen ()
emit (Text
ua Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 2")
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
  Text
oi <- Text -> Gen Text
fresh Text
"obj"
  Text -> Gen ()
emit (Text
oi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
ti <- Text -> Gen Text
fresh Text
"tagged"
  Text -> Gen ()
emit (Text
ti Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
oi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lPtrTag Layout
layout))
  Text
tp <- Text -> Gen Text
fresh Text
"tagged"
  Text -> Gen ()
emit (Text
tp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ti Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Text
mvp <- Text -> Gen Text
fresh Text
"mutvar.p"
  Text -> Gen ()
emit (Text
mvp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Text -> Gen ()
emit (Text
"call void @unison_jit_write_mutvar(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mvp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  FnEnv -> Int -> Int -> Gen ()
poolConstant FnEnv
fe Int
d Int
unitIx

-- | Universal comparison (@==@, @<=@, @<@, @compare@ on any type). The
-- fast path: both values unboxed with the same type-tag closure, which is
-- how @Val@'s instances compare them (a word comparison, signed for Int,
-- unsigned for Nat, bitwise for Float and Char). Anything else goes to the
-- IR helpers @unison_jit_ueq@ / @unison_jit_ucmp@, which walk both values
-- and answer "not handled" for the cases they leave to the call-out
-- ("Hashing and comparison" in design.md).
genUniversal :: FnEnv -> Int -> Prim2 -> Int -> Int -> GInstr (RComb Val) -> MSection -> Gen ()
genUniversal :: FnEnv
-> Int
-> Prim2
-> Int
-> Int
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genUniversal FnEnv
fe Int
d Prim2
op Int
ki Int
kj GInstr (RComb Val)
instr MSection
sect = do
  Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
  Text
bi <- Int -> Gen Text
loadB Int
ki
  Text
bj <- Int -> Gen Text
loadB Int
kj
  Text
ui <- Int -> Gen Text
loadU Int
ki
  Text
uj <- Int -> Gen Text
loadU Int
kj
  Text
same <- Text -> Gen Text
fresh Text
"same"
  Text -> Gen ()
emit (Text
same Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bj)
  let isTag :: Text -> Gen Text
isTag Text
name = do
        Text
c <- Text -> Gen Text
fresh Text
"istag"
        Text -> Gen ()
emit (Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)
        pure Text
c
  Text
isNat <- Text -> Gen Text
isTag (FnEnv -> Text
feTagNat FnEnv
fe)
  Text
isInt <- Text -> Gen Text
isTag (FnEnv -> Text
feTagInt FnEnv
fe)
  Text
isOther <- case Prim2
op of
    Prim2
EQLU -> do
      Text
c1 <- Text -> Gen Text
isTag (FnEnv -> Text
feTagChar FnEnv
fe)
      Text
c2 <- Text -> Gen Text
isTag (FnEnv -> Text
feTagFloat FnEnv
fe)
      Text
o <- Text -> Gen Text
fresh Text
"istag"
      Text -> Gen ()
emit (Text
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c2)
      pure Text
o
    Prim2
_ -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"false"
  Text
num <- Text -> Gen Text
fresh Text
"isnum"
  Text -> Gen ()
emit (Text
num Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
isNat Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
isInt)
  Text
known <- Text -> Gen Text
fresh Text
"known"
  Text -> Gen ()
emit (Text
known Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
num Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
isOther)
  Text
fast <- Text -> Gen Text
fresh Text
"fast"
  Text -> Gen ()
emit (Text
fast Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
same Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
known)
  Text
go <- Text -> Gen Text
freshLabel Text
"univ"
  -- which kinds of rope the helper is to take: texts, bytes
  let kinds :: Int
kinds = (if FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"text" then Int
1 else Int
0) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if FnEnv -> Text -> Bool
enabled FnEnv
fe Text
"bytes" then Int
2 else Int
0) :: Int
      isCmp :: Bool
isCmp = Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
CMPU
      deliver :: Text -> Gen ()
deliver Text
c = if Bool
isCmp then FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagInt FnEnv
fe) Text
c else FnEnv -> Int -> Text -> Gen ()
resultBool FnEnv
fe Int
d Text
c
  -- anything but two numbers of the same type goes to the IR helper, which
  -- walks the two values ("Universal.== and Universal.compare" in
  -- jit_helpers.c) and answers "not handled" for what it leaves to the
  -- interpreter: functions of different references, maps, mismatched kinds
  Text
feq <- Text -> Gen Text
freshLabel Text
"feq"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fast Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
go Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
feq Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
likely)
  Text -> Gen ()
startBlock Text
feq
  Text
r <- Text -> Gen Text
fresh Text
"pair"
  let helper :: Text
helper = if Prim2
op Prim2 -> Prim2 -> Bool
forall a. Eq a => a -> a -> Bool
== Prim2
EQLU then Text
"unison_jit_ueq" else Text
"unison_jit_ucmp"
  Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call { i64, i64 } @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
helper Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ui Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
kinds Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  Text
okv <- Text -> Gen Text
fresh Text
"ok"
  Text -> Gen ()
emit (Text
okv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = extractvalue { i64, i64 } " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
  Text
miss <- Text -> Gen Text
fresh Text
"miss"
  Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
okv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
  Text
ok <- Text -> Gen Text
freshLabel Text
"feq.ok"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Text -> Gen ()
startBlock Text
ok
  Text
v <- Text -> Gen Text
fresh Text
"v"
  Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = extractvalue { i64, i64 } " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 1")
  Text
c2 <- case Prim2
op of
    Prim2
EQLU -> Text -> Text -> Text -> Gen Text
cmp Text
"ne" Text
v Text
"0"
    Prim2
LEQU -> Text -> Text -> Text -> Gen Text
cmp Text
"sle" Text
v Text
"0"
    Prim2
LESU -> Text -> Text -> Text -> Gen Text
cmp Text
"slt" Text
v Text
"0"
    Prim2
_ -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
v
  Text
join <- Text -> Gen Text
freshLabel Text
"univ.join"
  Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
join)
  Text -> Gen ()
startBlock Text
go
  Text
c1 <- Prim2 -> Text -> Text -> Text -> Gen Text
genUniversalValue Prim2
op Text
isInt Text
ui Text
uj
  Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
join)
  Text -> Gen ()
startBlock Text
join
  Text
c <- Text -> Gen Text
fresh Text
"c"
  Text -> Gen ()
emit (Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = phi " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Bool
isCmp then Text
"i64" else Text
"i1") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
go Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ], [ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]")
  Text -> Gen ()
deliver Text
c

-- | The comparison of two words of the same numeric type: an i1 for the
-- boolean operations, the Int -1, 0 or 1 for compare.
genUniversalValue :: Prim2 -> Text -> Text -> Text -> Gen Text
genUniversalValue :: Prim2 -> Text -> Text -> Text -> Gen Text
genUniversalValue Prim2
op Text
isInt Text
ui Text
uj = do
  let signedUnsigned :: Text -> Text -> Gen Text
signedUnsigned Text
s Text
u = do
        Text
cs <- Text -> Text -> Text -> Gen Text
cmp Text
s Text
ui Text
uj
        Text
cu <- Text -> Text -> Text -> Gen Text
cmp Text
u Text
ui Text
uj
        Text
r <- Text -> Gen Text
fresh Text
"c"
        Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
isInt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cu)
        pure Text
r
  case Prim2
op of
    Prim2
EQLU -> Text -> Text -> Text -> Gen Text
cmp Text
"eq" Text
ui Text
uj
    Prim2
LEQU -> Text -> Text -> Gen Text
signedUnsigned Text
"sle" Text
"ule"
    Prim2
LESU -> Text -> Text -> Gen Text
signedUnsigned Text
"slt" Text
"ult"
    Prim2
_ -> do
      Text
lt <- Text -> Text -> Gen Text
signedUnsigned Text
"slt" Text
"ult"
      Text
eq <- Text -> Text -> Text -> Gen Text
cmp Text
"eq" Text
ui Text
uj
      Text
a <- Text -> Gen Text
fresh Text
"r"
      Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
eq Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 0, i64 1")
      Text
r <- Text -> Gen Text
fresh Text
"r"
      Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 -1, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a)
      pure Text
r

-- | An object with pointer tag 7 and the given info pointer, else branch
-- to @slow@; gives the untagged address.
taggedObject :: Text -> Text -> Int -> Text -> Gen Text
taggedObject :: Text -> Text -> Int -> Text -> Gen Text
taggedObject Text
what Text
raw Int
info Text
slow = Text -> Text -> Pair Int Int -> Text -> Gen Text
taggedObjectTag Text
what Text
raw (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
info Int
7) Text
slow

-- | The wrapper of a mutable array: its info pointer, and pointer tag 7.
mutableArrayWrap :: FnEnv -> Pair Int Int
mutableArrayWrap :: FnEnv -> Pair Int Int
mutableArrayWrap FnEnv
fe = Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair (Layouts -> Int
lMutableArrayInfo (Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe))) Int
7

-- | As 'taggedObject', for a constructor with the given (info, pointer tag).
taggedObjectTag :: Text -> Text -> Pair Int Int -> Text -> Gen Text
taggedObjectTag :: Text -> Text -> Pair Int Int -> Text -> Gen Text
taggedObjectTag Text
what Text
raw (Pair Int
info Int
tag) Text
slow = do
  Text
tagBits <- Text -> Gen Text
fresh Text
"ptrtag"
  Text -> Gen ()
emit (Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
  Text
notTag <- Text -> Gen Text
fresh Text
"nottag"
  Text -> Gen ()
emit (Text
notTag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagBits Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
tag)
  Text -> Text -> Text -> Gen ()
branchIf Text
what Text
notTag Text
slow
  Text
base <- Text -> Gen Text
fresh Text
what
  Text -> Gen ()
emit (Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -8")
  Text
ip <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".info.p")
  Text -> Gen ()
emit (Text
ip Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Text
i <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".info")
  Text -> Gen ()
emit (Text
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ip)
  Text
notInfo <- Text -> Gen Text
fresh Text
"notinfo"
  Text -> Gen ()
emit (Text
notInfo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
info)
  Text -> Text -> Text -> Gen ()
branchIf Text
what Text
notInfo Text
slow
  pure Text
base

-- | Branches to @slow@ if the condition holds, else continues in a new block.
branchIf :: Text -> Text -> Text -> Gen ()
branchIf :: Text -> Text -> Text -> Gen ()
branchIf Text
what Text
c Text
slow = do
  Text
l <- Text -> Gen Text
freshLabel Text
what
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Text -> Gen ()
startBlock Text
l

-- | A load of the given type at a byte offset from an address held in an i64.
loadAt :: Text -> Text -> Text -> Int -> Gen Text
loadAt :: Text -> Text -> Text -> Int -> Gen Text
loadAt Text
from Text
what Text
ty Int
off = do
  Text
a <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".a")
  Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
from Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
off)
  Text
pp <- Text -> Gen Text
fresh (Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".p")
  Text -> Gen ()
emit (Text
pp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Text
v <- Text -> Gen Text
fresh Text
what
  Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pp)
  pure Text
v

-- | The fields of the evaluated @Val@ at the tagged address (else @slow@).
valFields :: FnEnv -> Text -> Text -> Gen (Pair Text Text)
valFields :: FnEnv -> Text -> Text -> Gen (Pair Text Text)
valFields FnEnv
fe Text
valp Text
slow = do
  let ls :: Layouts
ls = Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe)
  Text
vtag <- Text -> Gen Text
fresh Text
"ptrtag"
  Text -> Gen ()
emit (Text
vtag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
valp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 7")
  Text
notVal <- Text -> Gen Text
fresh Text
"notval"
  Text -> Gen ()
emit (Text
notVal Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ne i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
vtag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lPtrTag (Layouts -> Layout
lVal Layouts
ls)))
  Text -> Text -> Text -> Gen ()
branchIf Text
"val" Text
notVal Text
slow
  Text
vbase <- Text -> Gen Text
fresh Text
"val"
  Text -> Gen ()
emit (Text
vbase Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
valp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -8")
  Text
b <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
vbase Text
"vb" Text
"ptr" (Layout -> Int -> Int
lFieldOffset (Layouts -> Layout
lVal Layouts
ls) Int
0)
  Text
u <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
vbase Text
"vu" Text
"i64" (Layout -> Int -> Int
lFieldOffset (Layouts -> Layout
lVal Layouts
ls) Int
1)
  pure (Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair Text
u Text
b)

-- | Allocates a @Val@ holding the value in slot @kv@; gives its tagged
-- address. The value is read before the allocation call; an untagged
-- boxed value goes to @slow@.
allocVal :: FnEnv -> Int -> Text -> Gen Text
allocVal :: FnEnv -> Int -> Text -> Gen Text
allocVal FnEnv
fe Int
kv Text
slow = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      layout :: Layout
layout = Layouts -> Layout
lVal (Env -> Layouts
envLayouts Env
env)
      words :: Int
words = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lNptrs Layout
layout
  Text
u <- Int -> Gen Text
loadU Int
kv
  Text
b <- Int -> Gen Text
loadB Int
kv
  Text -> Deque Text -> Gen ()
requireTagged Text
slow (Text -> Deque Text
forall a. a -> Deque a
D.singleton Text
b)
  Text
obj <- Env -> Int -> Gen Text
allocWords Env
env Int
words
  Text
hdr <- Text -> Gen Text
fresh Text
"w"
  Text -> Gen ()
emit (Text
hdr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 0")
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lInfo Layout
layout) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hdr)
  Text
ba <- Text -> Gen Text
fresh Text
"w"
  Text -> Gen ()
emit (Text
ba Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 1")
  Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
  Text
ua <- Text -> Gen Text
fresh Text
"w"
  Text -> Gen ()
emit (Text
ua Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 2")
  Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
  Text
oi <- Text -> Gen Text
fresh Text
"obj"
  Text -> Gen ()
emit (Text
oi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
ti <- Text -> Gen Text
fresh Text
"tagged"
  Text -> Gen ()
emit (Text
ti Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
oi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lPtrTag Layout
layout))
  Text
tp <- Text -> Gen Text
fresh Text
"tagged"
  Text -> Gen ()
emit (Text
tp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ti Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  pure Text
tp

-- | @MutableArray.size@, @read@ and @write@ (the last two given an index
-- slot, write also a value slot and the pool index of unit). The closure
-- must be @Foreign (WrapMutableArray arr)@ and the index in bounds;
-- otherwise the call-out runs the foreign call, which raises the error.
-- A write does what compiled Haskell does: store, set the dirty info
-- pointer, mark the card.
genArrayOp :: FnEnv -> Int -> Pair Int Int -> Int -> Maybe Int -> Maybe (Pair Int Int) -> GInstr (RComb Val) -> MSection -> Gen ()
genArrayOp :: FnEnv
-> Int
-> Pair Int Int
-> Int
-> Maybe Int
-> Maybe (Pair Int Int)
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genArrayOp FnEnv
fe Int
d Pair Int Int
wrap Int
ka Maybe Int
mki Maybe (Pair Int Int)
mwrite GInstr (RComb Val)
instr MSection
sect = do
  let ls :: Layouts
ls = Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe)
      rts :: RtsFacts
rts = Env -> RtsFacts
envRts (FnEnv -> Env
feEnv FnEnv
fe)
  Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
  -- a value to write is boxed up front, before anything is loaded from the heap
  Maybe Text
newVal <- (Pair Int Int -> Gen Text)
-> Maybe (Pair Int Int) -> Gen (Maybe Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (\(Pair Int
kv Int
_) -> FnEnv -> Int -> Text -> Gen Text
allocVal FnEnv
fe Int
kv Text
slow) Maybe (Pair Int Int)
mwrite
  Text
p <- Int -> Gen Text
loadB Int
ka
  Text
raw <- Text -> Gen Text
fresh Text
"raw"
  Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
fo <- Text -> Text -> Int -> Text -> Gen Text
taggedObject Text
"foreign" Text
raw (Layouts -> Int
lForeignInfo Layouts
ls) Text
slow
  Text
wrapped <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
fo Text
"wrap" Text
"i64" (Layouts -> Int
lHeaderBytes Layouts
ls)
  Text
w <- Text -> Text -> Pair Int Int -> Text -> Gen Text
taggedObjectTag Text
"array" Text
wrapped Pair Int Int
wrap Text
slow
  Text
arr <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
w Text
"arr" Text
"i64" (Layouts -> Int
lHeaderBytes Layouts
ls)
  Text
count <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
arr Text
"count" Text
"i64" (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* RtsFacts -> Int
rPtrsCount RtsFacts
rts)
  case Maybe Int
mki of
    Maybe Int
Nothing -> FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagNat FnEnv
fe) Text
count
    Just Int
ki -> do
      Text
ix <- Int -> Gen Text
loadU Int
ki
      Text
oob <- Text -> Gen Text
fresh Text
"oob"
      Text -> Gen ()
emit (Text
oob Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp uge i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
count)
      Text -> Text -> Text -> Gen ()
branchIf Text
"inbounds" Text
oob Text
slow
      Text
ea <- Text -> Gen Text
fresh Text
"elem.a"
      Text -> Gen ()
emit (Text
ea Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rPtrsHeader RtsFacts
rts))
      Text
arrP <- Text -> Gen Text
fresh Text
"arr.p"
      Text -> Gen ()
emit (Text
arrP Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
      Text
ep <- Text -> Gen Text
fresh Text
"elem.p"
      Text -> Gen ()
emit (Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arrP Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ea)
      case (Maybe (Pair Int Int)
mwrite, Maybe Text
newVal) of
        (Just (Pair Int
_ Int
unitIx), Just Text
v) -> do
          Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ep)
          Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rArrPtrsDirtyInfo RtsFacts
rts) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arrP)
          -- the card table follows the elements; one byte per 2^cardBits elements
          Text
cardIx <- Text -> Gen Text
fresh Text
"card"
          Text -> Gen ()
emit (Text
cardIx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = lshr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rCardBits RtsFacts
rts))
          Text
cardsA <- Text -> Gen Text
fresh Text
"cards"
          Text -> Gen ()
emit (Text
cardsA Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = add i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
count Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rPtrsHeader RtsFacts
rts))
          Text
cardsP <- Text -> Gen Text
fresh Text
"cards.p"
          Text -> Gen ()
emit (Text
cardsP Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arrP Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cardsA)
          Text
cardP <- Text -> Gen Text
fresh Text
"card.p"
          Text -> Gen ()
emit (Text
cardP Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i8, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cardsP Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cardIx)
          Text -> Gen ()
emit (Text
"store i8 1, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cardP)
          FnEnv -> Int -> Int -> Gen ()
poolConstant FnEnv
fe Int
d Int
unitIx
        (Maybe (Pair Int Int), Maybe Text)
_ -> do
          Text
valp <- Text -> Gen Text
fresh Text
"val"
          Text -> Gen ()
emit (Text
valp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ep)
          Pair Text
u Text
b <- FnEnv -> Text -> Text -> Gen (Pair Text Text)
valFields FnEnv
fe Text
valp Text
slow
          Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
u
          Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
b

-- | The array and ref builtins done by C helpers, and what each is.
data ArrayOp
  = -- | size of a byte array (kind 0 mutable, 1 immutable)
    BSize Int
  | -- | read of width bytes, big-endian?, from a byte array of this kind
    BRead Int Bool Int
  | -- | write of width bytes, big-endian?
    BWrite Int Bool
  | -- | copyTo! between pointer arrays (source kind) or byte arrays
    PCopy Int
  | BCopy Int
  | -- | freeze! (True) or freeze of a slice
    PFreeze Bool
  | BFreeze Bool
  | ToBytes
  | FromBytes
  | -- | a new pointer array, with an initial value or the empty one
    PNew Bool
  | -- | a new byte array: filled from an argument?, pinned?
    BNew Bool Bool
  | -- | PinnedByteArray.cast: the same wrapper
    Cast
  | -- | PinnedByteArray.contents
    Contents

arrayForeign :: ForeignFunc -> Maybe ArrayOp
arrayForeign :: ForeignFunc -> Maybe ArrayOp
arrayForeign = \case
  ForeignFunc
MutableByteArray_size -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> ArrayOp
BSize Int
0)
  ForeignFunc
ImmutableByteArray_size -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> ArrayOp
BSize Int
1)
  ForeignFunc
MutableByteArray_read8 -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
1 Bool
True Int
0)
  ForeignFunc
MutableByteArray_read16be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
2 Bool
True Int
0)
  ForeignFunc
MutableByteArray_read24be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
3 Bool
True Int
0)
  ForeignFunc
MutableByteArray_read32be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
4 Bool
True Int
0)
  ForeignFunc
MutableByteArray_read40be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
5 Bool
True Int
0)
  ForeignFunc
MutableByteArray_read64be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
8 Bool
True Int
0)
  ForeignFunc
MutableByteArray_read16le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
2 Bool
False Int
0)
  ForeignFunc
MutableByteArray_read24le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
3 Bool
False Int
0)
  ForeignFunc
MutableByteArray_read32le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
4 Bool
False Int
0)
  ForeignFunc
MutableByteArray_read40le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
5 Bool
False Int
0)
  ForeignFunc
MutableByteArray_read64le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
8 Bool
False Int
0)
  ForeignFunc
ImmutableByteArray_read8 -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
1 Bool
True Int
1)
  ForeignFunc
ImmutableByteArray_read16be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
2 Bool
True Int
1)
  ForeignFunc
ImmutableByteArray_read24be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
3 Bool
True Int
1)
  ForeignFunc
ImmutableByteArray_read32be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
4 Bool
True Int
1)
  ForeignFunc
ImmutableByteArray_read40be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
5 Bool
True Int
1)
  ForeignFunc
ImmutableByteArray_read64be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
8 Bool
True Int
1)
  ForeignFunc
ImmutableByteArray_read16le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
2 Bool
False Int
1)
  ForeignFunc
ImmutableByteArray_read24le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
3 Bool
False Int
1)
  ForeignFunc
ImmutableByteArray_read32le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
4 Bool
False Int
1)
  ForeignFunc
ImmutableByteArray_read40le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
5 Bool
False Int
1)
  ForeignFunc
ImmutableByteArray_read64le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> Int -> ArrayOp
BRead Int
8 Bool
False Int
1)
  ForeignFunc
MutableByteArray_write8 -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> ArrayOp
BWrite Int
1 Bool
True)
  ForeignFunc
MutableByteArray_write16be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> ArrayOp
BWrite Int
2 Bool
True)
  ForeignFunc
MutableByteArray_write32be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> ArrayOp
BWrite Int
4 Bool
True)
  ForeignFunc
MutableByteArray_write64be -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> ArrayOp
BWrite Int
8 Bool
True)
  ForeignFunc
MutableByteArray_write16le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> ArrayOp
BWrite Int
2 Bool
False)
  ForeignFunc
MutableByteArray_write32le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> ArrayOp
BWrite Int
4 Bool
False)
  ForeignFunc
MutableByteArray_write64le -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> Bool -> ArrayOp
BWrite Int
8 Bool
False)
  ForeignFunc
MutableArray_copyTo_force -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> ArrayOp
PCopy Int
0)
  ForeignFunc
ImmutableArray_copyTo_force -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> ArrayOp
PCopy Int
1)
  ForeignFunc
MutableByteArray_copyTo_force -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> ArrayOp
BCopy Int
0)
  ForeignFunc
ImmutableByteArray_copyTo_force -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Int -> ArrayOp
BCopy Int
1)
  ForeignFunc
MutableArray_freeze_force -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> ArrayOp
PFreeze Bool
True)
  ForeignFunc
MutableArray_freeze -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> ArrayOp
PFreeze Bool
False)
  ForeignFunc
MutableByteArray_freeze_force -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> ArrayOp
BFreeze Bool
True)
  ForeignFunc
MutableByteArray_freeze -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> ArrayOp
BFreeze Bool
False)
  ForeignFunc
ImmutableByteArray_toBytes -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just ArrayOp
ToBytes
  ForeignFunc
ImmutableByteArray_fromBytes -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just ArrayOp
FromBytes
  ForeignFunc
Scope_array -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> ArrayOp
PNew Bool
False)
  ForeignFunc
IO_array -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> ArrayOp
PNew Bool
False)
  ForeignFunc
Scope_arrayOf -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> ArrayOp
PNew Bool
True)
  ForeignFunc
IO_arrayOf -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> ArrayOp
PNew Bool
True)
  ForeignFunc
Scope_bytearray -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> Bool -> ArrayOp
BNew Bool
False Bool
False)
  ForeignFunc
IO_bytearray -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> Bool -> ArrayOp
BNew Bool
False Bool
False)
  ForeignFunc
Scope_bytearrayOf -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> Bool -> ArrayOp
BNew Bool
True Bool
False)
  ForeignFunc
IO_bytearrayOf -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> Bool -> ArrayOp
BNew Bool
True Bool
False)
  ForeignFunc
Scope_pinnedByteArray -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> Bool -> ArrayOp
BNew Bool
False Bool
True)
  ForeignFunc
IO_pinnedByteArray -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> Bool -> ArrayOp
BNew Bool
False Bool
True)
  ForeignFunc
Scope_pinnedByteArrayOf -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> Bool -> ArrayOp
BNew Bool
True Bool
True)
  ForeignFunc
IO_pinnedByteArrayOf -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just (Bool -> Bool -> ArrayOp
BNew Bool
True Bool
True)
  ForeignFunc
PinnedByteArray_cast -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just ArrayOp
Cast
  ForeignFunc
PinnedByteArray_contents -> ArrayOp -> Maybe ArrayOp
forall a. a -> Maybe a
Just ArrayOp
Contents
  ForeignFunc
_ -> Maybe ArrayOp
forall a. Maybe a
Nothing

-- | The foreign functions whose result is unit (they need the constant).
unitForeign :: [ForeignFunc]
unitForeign :: [ForeignFunc]
unitForeign =
  [ForeignFunc
f | ForeignFunc
f <- [ForeignFunc
forall a. Bounded a => a
minBound .. ForeignFunc
forall a. Bounded a => a
maxBound], Just ArrayOp
op <- [ForeignFunc -> Maybe ArrayOp
arrayForeign ForeignFunc
f], ArrayOp -> Bool
givesUnit ArrayOp
op]
    [ForeignFunc] -> [ForeignFunc] -> [ForeignFunc]
forall a. Semigroup a => a -> a -> a
<> [ForeignFunc
f | ForeignFunc
f <- [ForeignFunc
forall a. Bounded a => a
minBound .. ForeignFunc
forall a. Bounded a => a
maxBound], Just (PtrOp PtrElem
_ Bool
_ Bool
True) <- [ForeignFunc -> Maybe PtrOp
ptrForeign ForeignFunc
f]]
  where
    givesUnit :: ArrayOp -> Bool
givesUnit = \case
      BWrite {} -> Bool
True
      PCopy Int
_ -> Bool
True
      BCopy Int
_ -> Bool
True
      ArrayOp
_ -> Bool
False

-- ---------------------------------------------------------------------------
-- FFI pointers

-- | What a @Ptr@ element is: a signed or unsigned integer of so many bytes,
-- a 32- or 64-bit float, or another pointer.
data PtrElem = PInt Int | PNat Int | PFloat32 | PFloat64 | PPtr

-- | A read or write (the last flag) through a @Ptr@, at an element index
-- (the middle flag) or at the pointer itself.
data PtrOp = PtrOp !PtrElem !Bool !Bool

-- | The @FFI.Ptr@ reads and writes: the loads and stores the Haskell
-- @peek@/@poke@ and @peekElemOff@/@pokeElemOff@ make, with the same
-- widening and narrowing as the foreign conventions (sign extension for
-- the @Int@s, zero extension for the @Nat@s, truncation on a write,
-- @Float32@ through a double). Allocation and freeing stay call-outs.
ptrForeign :: ForeignFunc -> Maybe PtrOp
ptrForeign :: ForeignFunc -> Maybe PtrOp
ptrForeign = \case
  ForeignFunc
FFI_Ptr_Int8_get -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
1) Bool
False Bool
False)
  ForeignFunc
FFI_Ptr_Int8_getAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
1) Bool
True Bool
False)
  ForeignFunc
FFI_Ptr_Int8_set -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
1) Bool
False Bool
True)
  ForeignFunc
FFI_Ptr_Int8_setAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
1) Bool
True Bool
True)
  ForeignFunc
FFI_Ptr_Int16_get -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
2) Bool
False Bool
False)
  ForeignFunc
FFI_Ptr_Int16_getAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
2) Bool
True Bool
False)
  ForeignFunc
FFI_Ptr_Int16_set -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
2) Bool
False Bool
True)
  ForeignFunc
FFI_Ptr_Int16_setAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
2) Bool
True Bool
True)
  ForeignFunc
FFI_Ptr_Int32_get -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
4) Bool
False Bool
False)
  ForeignFunc
FFI_Ptr_Int32_getAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
4) Bool
True Bool
False)
  ForeignFunc
FFI_Ptr_Int32_set -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
4) Bool
False Bool
True)
  ForeignFunc
FFI_Ptr_Int32_setAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
4) Bool
True Bool
True)
  ForeignFunc
FFI_Ptr_Int_get -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
8) Bool
False Bool
False)
  ForeignFunc
FFI_Ptr_Int_getAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
8) Bool
True Bool
False)
  ForeignFunc
FFI_Ptr_Int_set -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
8) Bool
False Bool
True)
  ForeignFunc
FFI_Ptr_Int_setAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PInt Int
8) Bool
True Bool
True)
  ForeignFunc
FFI_Ptr_Nat8_get -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
1) Bool
False Bool
False)
  ForeignFunc
FFI_Ptr_Nat8_getAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
1) Bool
True Bool
False)
  ForeignFunc
FFI_Ptr_Nat8_set -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
1) Bool
False Bool
True)
  ForeignFunc
FFI_Ptr_Nat8_setAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
1) Bool
True Bool
True)
  ForeignFunc
FFI_Ptr_Nat16_get -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
2) Bool
False Bool
False)
  ForeignFunc
FFI_Ptr_Nat16_getAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
2) Bool
True Bool
False)
  ForeignFunc
FFI_Ptr_Nat16_set -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
2) Bool
False Bool
True)
  ForeignFunc
FFI_Ptr_Nat16_setAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
2) Bool
True Bool
True)
  ForeignFunc
FFI_Ptr_Nat32_get -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
4) Bool
False Bool
False)
  ForeignFunc
FFI_Ptr_Nat32_getAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
4) Bool
True Bool
False)
  ForeignFunc
FFI_Ptr_Nat32_set -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
4) Bool
False Bool
True)
  ForeignFunc
FFI_Ptr_Nat32_setAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
4) Bool
True Bool
True)
  ForeignFunc
FFI_Ptr_Nat_get -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
8) Bool
False Bool
False)
  ForeignFunc
FFI_Ptr_Nat_getAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
8) Bool
True Bool
False)
  ForeignFunc
FFI_Ptr_Nat_set -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
8) Bool
False Bool
True)
  ForeignFunc
FFI_Ptr_Nat_setAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (Int -> PtrElem
PNat Int
8) Bool
True Bool
True)
  ForeignFunc
FFI_Ptr_Float32_get -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PFloat32) Bool
False Bool
False)
  ForeignFunc
FFI_Ptr_Float32_getAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PFloat32) Bool
True Bool
False)
  ForeignFunc
FFI_Ptr_Float32_set -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PFloat32) Bool
False Bool
True)
  ForeignFunc
FFI_Ptr_Float32_setAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PFloat32) Bool
True Bool
True)
  ForeignFunc
FFI_Ptr_Float_get -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PFloat64) Bool
False Bool
False)
  ForeignFunc
FFI_Ptr_Float_getAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PFloat64) Bool
True Bool
False)
  ForeignFunc
FFI_Ptr_Float_set -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PFloat64) Bool
False Bool
True)
  ForeignFunc
FFI_Ptr_Float_setAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PFloat64) Bool
True Bool
True)
  ForeignFunc
FFI_Ptr_Ptr_get -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PPtr) Bool
False Bool
False)
  ForeignFunc
FFI_Ptr_Ptr_getAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PPtr) Bool
True Bool
False)
  ForeignFunc
FFI_Ptr_Ptr_set -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PPtr) Bool
False Bool
True)
  ForeignFunc
FFI_Ptr_Ptr_setAt -> PtrOp -> Maybe PtrOp
forall a. a -> Maybe a
Just (PtrElem -> Bool -> Bool -> PtrOp
PtrOp (PtrElem
PPtr) Bool
True Bool
True)
  ForeignFunc
_ -> Maybe PtrOp
forall a. Maybe a
Nothing

-- | A pointer read or write. The pointer is the address inside the
-- @WrapPtr@ wrapper of the @Foreign@ closure in the first slot (unwrapped
-- as the array wrappers are); the element address is that plus the index
-- times the width. A read of a pointer wraps the address it loads through
-- a C helper that allocates the two closures. Nothing is checked about the
-- address, as nothing is in the interpreter.
genPtrOp :: FnEnv -> Int -> PtrOp -> Deque Int -> GInstr (RComb Val) -> MSection -> Gen ()
genPtrOp :: FnEnv
-> Int
-> PtrOp
-> Deque Int
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genPtrOp FnEnv
fe Int
d (PtrOp PtrElem
el Bool
indexed Bool
write) Deque Int
srcs GInstr (RComb Val)
instr MSection
sect = do
  Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
  let width :: Int
width = case PtrElem
el of
        PInt Int
w -> Int
w
        PNat Int
w -> Int
w
        PtrElem
PFloat32 -> Int
4
        PtrElem
PFloat64 -> Int
8
        PtrElem
PPtr -> Int
8
      ity :: Text
ity = Text
"i" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width)
      unitIx :: Maybe Int
unitIx = PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.unitRef PackedTag
TT.unitTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe))
      shape :: Maybe (Int, Maybe Int, Maybe Int)
shape = case (Deque Int -> [Int]
forall a. Deque a -> [a]
D.toList Deque Int
srcs, Bool
indexed, Bool
write) of
        ([Int
kp], Bool
False, Bool
False) -> (Int, Maybe Int, Maybe Int) -> Maybe (Int, Maybe Int, Maybe Int)
forall a. a -> Maybe a
Just (Int
kp, Maybe Int
forall a. Maybe a
Nothing, Maybe Int
forall a. Maybe a
Nothing)
        ([Int
kp, Int
ki], Bool
True, Bool
False) -> (Int, Maybe Int, Maybe Int) -> Maybe (Int, Maybe Int, Maybe Int)
forall a. a -> Maybe a
Just (Int
kp, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
ki, Maybe Int
forall a. Maybe a
Nothing)
        ([Int
kp, Int
kv], Bool
False, Bool
True) -> (Int, Maybe Int, Maybe Int) -> Maybe (Int, Maybe Int, Maybe Int)
forall a. a -> Maybe a
Just (Int
kp, Maybe Int
forall a. Maybe a
Nothing, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
kv)
        ([Int
kp, Int
ki, Int
kv], Bool
True, Bool
True) -> (Int, Maybe Int, Maybe Int) -> Maybe (Int, Maybe Int, Maybe Int)
forall a. a -> Maybe a
Just (Int
kp, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
ki, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
kv)
        ([Int], Bool, Bool)
_ -> Maybe (Int, Maybe Int, Maybe Int)
forall a. Maybe a
Nothing
  case Maybe (Int, Maybe Int, Maybe Int)
shape of
    Just (Int
kp, Maybe Int
mki, Maybe Int
mkv) | Bool -> Bool
not Bool
write Bool -> Bool -> Bool
|| Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
unitIx -> do
      Text
addr <- FnEnv -> Text -> Int -> Gen Text
ptrAddress FnEnv
fe Text
slow Int
kp
      Text
ea <- case Maybe Int
mki of
        Maybe Int
Nothing -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
addr
        Just Int
ki -> do
          Text
ix <- Int -> Gen Text
loadU Int
ki
          Text
off <- Text -> Text -> Text -> Gen Text
binop Text
"mul" Text
ix (Int -> Text
forall a. Show a => a -> Text
tshow Int
width)
          Text -> Text -> Text -> Gen Text
binop Text
"add" Text
addr Text
off
      Text
ep <- Text -> Gen Text
fresh Text
"elem.p"
      Text -> Gen ()
emit (Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ea Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
      case Maybe Int
mkv of
        Maybe Int
Nothing -> case PtrElem
el of
          PtrElem
PPtr -> do
            Text
a <- Text -> Gen Text
fresh Text
"addr"
            Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", align 1")
            Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_wrap_ptr(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
          PtrElem
PFloat32 -> do
            Text
f <- Text -> Gen Text
fresh Text
"f32"
            Text -> Gen ()
emit (Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load float, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", align 1")
            Text
f64 <- Text -> Gen Text
fresh Text
"f64"
            Text -> Gen ()
emit (Text
f64 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = fpext float " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to double")
            Text
v <- Text -> Gen Text
fresh Text
"bits"
            Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = bitcast double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f64 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
            FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagFloat FnEnv
fe) Text
v
          PtrElem
PFloat64 -> do
            Text
v <- Text -> Gen Text
fresh Text
"bits"
            Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", align 1")
            FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagFloat FnEnv
fe) Text
v
          PInt Int
w -> do
            Text
v <- Text -> Int -> Text -> Gen Text
forall {a}. (Show a, Num a, Eq a) => Text -> a -> Text -> Gen Text
loadInt Text
ep Int
w Text
"sext"
            FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagInt FnEnv
fe) Text
v
          PNat Int
w -> do
            Text
v <- Text -> Int -> Text -> Gen Text
forall {a}. (Show a, Num a, Eq a) => Text -> a -> Text -> Gen Text
loadInt Text
ep Int
w Text
"zext"
            FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagNat FnEnv
fe) Text
v
        Just Int
kv -> do
          case PtrElem
el of
            PtrElem
PPtr -> do
              Text
a <- FnEnv -> Text -> Int -> Gen Text
ptrAddress FnEnv
fe Text
slow Int
kv
              Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", align 1")
            PtrElem
PFloat32 -> do
              Text
u <- Int -> Gen Text
loadU Int
kv
              Text
f64 <- Text -> Gen Text
fresh Text
"f64"
              Text -> Gen ()
emit (Text
f64 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = bitcast i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to double")
              Text
f <- Text -> Gen Text
fresh Text
"f32"
              Text -> Gen ()
emit (Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = fptrunc double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f64 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to float")
              Text -> Gen ()
emit (Text
"store float " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", align 1")
            PtrElem
_ -> do
              Text
u <- Int -> Gen Text
loadU Int
kv
              Text
v <-
                if Int
width Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8
                  then Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
u
                  else do
                    Text
t <- Text -> Gen Text
fresh Text
"narrow"
                    Text -> Gen ()
emit (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = trunc i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ity)
                    pure Text
t
              Text -> Gen ()
emit (Text
"store " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", align 1")
          Maybe Int -> (Int -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int
unitIx (FnEnv -> Int -> Int -> Gen ()
poolConstant FnEnv
fe Int
d)
    Maybe (Int, Maybe Int, Maybe Int)
_ -> do
      Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow)
      Text -> Gen ()
startBlock Text
"unreachable.ptr"
  where
    loadInt :: Text -> a -> Text -> Gen Text
loadInt Text
ep a
w Text
ext = do
      let ity :: Text
ity = Text
"i" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow (a
8 a -> a -> a
forall a. Num a => a -> a -> a
* a
w)
      Text
raw <- Text -> Gen Text
fresh Text
"raw"
      Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", align 1")
      if a
w a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
8
        then Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
raw
        else do
          Text
v <- Text -> Gen Text
fresh Text
"wide"
          Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ext Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
          pure Text
v

-- | The address held by the @Ptr@ in slot @k@: a @Foreign@ closure around
-- a @WrapPtr@ whose one field is the address. Anything else goes to @slow@.
ptrAddress :: FnEnv -> Text -> Int -> Gen Text
ptrAddress :: FnEnv -> Text -> Int -> Gen Text
ptrAddress FnEnv
fe Text
slow Int
k = do
  let ls :: Layouts
ls = Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe)
  Text
p <- Int -> Gen Text
loadB Int
k
  Text
raw <- Text -> Gen Text
fresh Text
"raw"
  Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
fo <- Text -> Text -> Int -> Text -> Gen Text
taggedObject Text
"foreign" Text
raw (Layouts -> Int
lForeignInfo Layouts
ls) Text
slow
  Text
wrapped <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
fo Text
"wrap" Text
"i64" (Layouts -> Int
lHeaderBytes Layouts
ls)
  Text
w <- Text -> Text -> Pair Int Int -> Text -> Gen Text
taggedObjectTag Text
"ptr" Text
wrapped (Layouts -> Pair Int Int
lPtrWrap Layouts
ls) Text
slow
  Text -> Text -> Text -> Int -> Gen Text
loadAt Text
w Text
"addr" Text
"i64" (Layouts -> Int
lHeaderBytes Layouts
ls)

-- | Generates one of the array builtins above from its argument slots. A
-- helper that says "not handled" (a wrong closure, an index out of bounds,
-- which the interpreter then reports) sends the code to the call-out.
genArrayForeign :: FnEnv -> Int -> ArrayOp -> Deque Int -> GInstr (RComb Val) -> MSection -> Gen ()
genArrayForeign :: FnEnv
-> Int
-> ArrayOp
-> Deque Int
-> GInstr (RComb Val)
-> MSection
-> Gen ()
genArrayForeign FnEnv
fe Int
d ArrayOp
op Deque Int
srcs GInstr (RComb Val)
instr MSection
sect = do
  Text
slow <- Bool -> FnEnv -> Int -> GInstr (RComb Val) -> MSection -> Gen Text
callOutExit Bool
True FnEnv
fe Int
d GInstr (RComb Val)
instr MSection
sect
  let ls :: Layouts
ls = Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe)
      bool :: Bool -> a
bool Bool
b = if Bool
b then a
"1" else a
"0"
      unitIx :: Maybe Int
unitIx = PoolKey -> Map PoolKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.unitRef PackedTag
TT.unitTag) (Env -> Map PoolKey Int
envPool (FnEnv -> Env
feEnv FnEnv
fe))
      unitResult :: Text -> Gen ()
unitResult Text
call = case Maybe Int
unitIx of
        Just Int
ix -> FnEnv -> Int -> Text -> Int -> Text -> Gen ()
unitHelper FnEnv
fe Int
d Text
slow Int
ix Text
call
        Maybe Int
Nothing -> Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow) Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Gen ()
startBlock Text
"unreachable.unit" Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Gen ()
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  case (ArrayOp
op, Deque Int
srcs) of
    (BSize Int
kind, Int
ka :<| Deque Int
Empty) -> do
      Pair Text
_ Text
size <- FnEnv -> Text -> Int -> Int -> Gen (Pair Text Text)
byteArray FnEnv
fe Text
slow Int
ka Int
kind
      FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagNat FnEnv
fe) Text
size
    (BRead Int
width Bool
be Int
kind, Int
ka :<| Int
ki :<| Deque Int
Empty) -> do
      Pair Text
arr Text
size <- FnEnv -> Text -> Int -> Int -> Gen (Pair Text Text)
byteArray FnEnv
fe Text
slow Int
ka Int
kind
      Text
i <- Int -> Gen Text
loadU Int
ki
      Text
p <- FnEnv -> Text -> Text -> Text -> Text -> Int -> Gen Text
byteArrayElem FnEnv
fe Text
slow Text
arr Text
size Text
i Int
width
      let ity :: Text
ity = Text
"i" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width)
      Text
raw <- Text -> Gen Text
fresh Text
"raw"
      Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", align 1")
      Text
v <-
        if Int
width Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8
          then if Bool
be then Text -> Text -> Gen Text
bswap Text
"i64" Text
raw else Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
raw
          else do
            -- an odd width has no bswap of its own: swap the 64-bit extension
            -- and shift the bytes down
            Text
wide <- Text -> Gen Text
fresh Text
"wide"
            Text -> Gen ()
emit (Text
wide Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = zext " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
            if Bool -> Bool
not Bool
be
              then Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
wide
              else do
                Text
swapped <- Text -> Text -> Gen Text
bswap Text
"i64" Text
wide
                Text -> Text -> Text -> Gen Text
binop Text
"lshr" Text
swapped (Int -> Text
forall a. Show a => a -> Text
tshow (Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width))
      FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagNat FnEnv
fe) Text
v
    (BWrite Int
width Bool
be, Int
ka :<| Int
ki :<| Int
kv :<| Deque Int
Empty) | Just Int
ux <- Maybe Int
unitIx -> do
      Pair Text
arr Text
size <- FnEnv -> Text -> Int -> Int -> Gen (Pair Text Text)
byteArray FnEnv
fe Text
slow Int
ka Int
0
      Text
i <- Int -> Gen Text
loadU Int
ki
      Text
v <- Int -> Gen Text
loadU Int
kv
      Text
p <- FnEnv -> Text -> Text -> Text -> Text -> Int -> Gen Text
byteArrayElem FnEnv
fe Text
slow Text
arr Text
size Text
i Int
width
      let ity :: Text
ity = Text
"i" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width)
          trunc :: Text -> Gen Text
trunc Text
x = do
            Text
n <- Text -> Gen Text
fresh Text
"narrow"
            Text -> Gen ()
emit (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = trunc i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ity)
            pure Text
n
      -- the low `width` bytes of the value, swapped to the front for big-endian
      Text
narrow <- case (Bool
be, Int
width) of
        (Bool
False, Int
8) -> Text -> Gen Text
forall a. a -> StateT GS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
v
        (Bool
False, Int
_) -> Text -> Gen Text
trunc Text
v
        (Bool
True, Int
8) -> Text -> Text -> Gen Text
bswap Text
"i64" Text
v
        (Bool
True, Int
_) -> Text -> Text -> Gen Text
bswap Text
"i64" Text
v Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
sw -> Text -> Text -> Text -> Gen Text
binop Text
"lshr" Text
sw (Int -> Text
forall a. Show a => a -> Text
tshow (Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width)) Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen Text
trunc
      Text -> Gen ()
emit (Text
"store " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
narrow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", align 1")
      FnEnv -> Int -> Int -> Gen ()
poolConstant FnEnv
fe Int
d Int
ux
    (PCopy Int
kind, Int
kd :<| Int
kdo :<| Int
ks :<| Int
kso :<| Int
kl :<| Deque Int
Empty) -> do
      Text
dst <- Int -> Gen Text
loadB Int
kd
      Text
doff <- Int -> Gen Text
loadU Int
kdo
      Text
src <- Int -> Gen Text
loadB Int
ks
      Text
soff <- Int -> Gen Text
loadU Int
kso
      Text
l <- Int -> Gen Text
loadU Int
kl
      Text -> Gen ()
unitResult (Text
"@unison_jit_parray_copy(ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dst Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
doff Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
src Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
soff Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
kind Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    (BCopy Int
kind, Int
kd :<| Int
kdo :<| Int
ks :<| Int
kso :<| Int
kl :<| Deque Int
Empty) -> do
      Text
dst <- Int -> Gen Text
loadB Int
kd
      Text
doff <- Int -> Gen Text
loadU Int
kdo
      Text
src <- Int -> Gen Text
loadB Int
ks
      Text
soff <- Int -> Gen Text
loadU Int
kso
      Text
l <- Int -> Gen Text
loadU Int
kl
      Text -> Gen ()
unitResult (Text
"@unison_jit_barray_copy(ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dst Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
doff Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
src Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
soff Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
kind Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    (PFreeze Bool
True, Int
ka :<| Deque Int
Empty) -> do
      Text
a <- Int -> Gen Text
loadB Int
ka
      Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_parray_freeze(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 0, i64 0, i64 1)")
    (PFreeze Bool
False, Int
ka :<| Int
ko :<| Int
kl :<| Deque Int
Empty) -> do
      Text
a <- Int -> Gen Text
loadB Int
ka
      Text
off <- Int -> Gen Text
loadU Int
ko
      Text
l <- Int -> Gen Text
loadU Int
kl
      Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_parray_freeze(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
off Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 0)")
    (BFreeze Bool
True, Int
ka :<| Deque Int
Empty) -> do
      Text
a <- Int -> Gen Text
loadB Int
ka
      Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_barray_freeze(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 0, i64 0, i64 1)")
    (BFreeze Bool
False, Int
ka :<| Int
ko :<| Int
kl :<| Deque Int
Empty) -> do
      Text
a <- Int -> Gen Text
loadB Int
ka
      Text
off <- Int -> Gen Text
loadU Int
ko
      Text
l <- Int -> Gen Text
loadU Int
kl
      Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_barray_freeze(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
off Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 0)")
    (ArrayOp
ToBytes, Int
ka :<| Int
ko :<| Int
kl :<| Deque Int
Empty) -> do
      Text
a <- Int -> Gen Text
loadB Int
ka
      Text
off <- Int -> Gen Text
loadU Int
ko
      Text
l <- Int -> Gen Text
loadU Int
kl
      Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_barray_to_bytes(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
off Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    (ArrayOp
FromBytes, Int
kb :<| Deque Int
Empty) -> do
      Text
b <- Int -> Gen Text
loadB Int
kb
      Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_barray_from_bytes(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    (PNew Bool
False, Int
kn :<| Deque Int
Empty) -> do
      Text
n <- Int -> Gen Text
loadU Int
kn
      Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_parray_new(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 0, i64 0, ptr null)")
    (PNew Bool
True, Int
kv :<| Int
kn :<| Deque Int
Empty) -> do
      Text
u <- Int -> Gen Text
loadU Int
kv
      Text
b <- Int -> Gen Text
loadB Int
kv
      Text -> Deque Text -> Gen ()
requireTagged Text
slow (Text -> Deque Text
forall a. a -> Deque a
D.singleton Text
b)
      Text
n <- Int -> Gen Text
loadU Int
kn
      Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_parray_new(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 1, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    (BNew Bool
False Bool
pinned, Int
kn :<| Deque Int
Empty) -> do
      Text
n <- Int -> Gen Text
loadU Int
kn
      Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_barray_new(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 -1, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Text
forall {a}. IsString a => Bool -> a
bool Bool
pinned Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    (BNew Bool
True Bool
pinned, Int
kf :<| Int
kn :<| Deque Int
Empty) -> do
      Text
f <- Int -> Gen Text
loadU Int
kf
      -- the fill is a Word8: the low byte of the Nat
      Text
byte <- Text -> Gen Text
fresh Text
"fill"
      Text -> Gen ()
emit (Text
byte Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 255")
      Text
n <- Int -> Gen Text
loadU Int
kn
      Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_barray_new(ptr %ctx, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
byte Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Text
forall {a}. IsString a => Bool -> a
bool Bool
pinned Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    (ArrayOp
Cast, Int
ka :<| Deque Int
Empty) -> do
      -- the same closure, once it is known to be a mutable byte array
      Text
p <- Int -> Gen Text
loadB Int
ka
      Text
raw <- Text -> Gen Text
fresh Text
"raw"
      Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
      Text
fo <- Text -> Text -> Int -> Text -> Gen Text
taggedObject Text
"foreign" Text
raw (Layouts -> Int
lForeignInfo Layouts
ls) Text
slow
      Text
wrapped <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
fo Text
"wrap" Text
"i64" (Layouts -> Int
lHeaderBytes Layouts
ls)
      Text
_ <- Text -> Text -> Pair Int Int -> Text -> Gen Text
taggedObjectTag Text
"mbarray" Text
wrapped (Layouts -> Pair Int Int
lMutableByteArrayWrap Layouts
ls) Text
slow
      Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
      Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
p
    (ArrayOp
Contents, Int
ka :<| Deque Int
Empty) -> do
      Text
a <- Int -> Gen Text
loadB Int
ka
      Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_barray_contents(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    (ArrayOp, Deque Int)
_ -> do
      -- an argument shape the generator doesn't expect: the interpreter's
      Text -> Gen ()
emit (Text
"br label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow)
      Text -> Gen ()
startBlock Text
"unreachable.array"

-- | The @ByteArray#@ (kind 1) or @MutableByteArray#@ (kind 0) wrapped by the
-- closure in the slot, as its untagged address and its byte count; anything
-- else (a closure that isn't @Foreign (Wrap arr)@ for the right wrapper)
-- goes to @slow@. What the C helpers' @barray_of@ does, as generated code.
byteArray :: FnEnv -> Text -> Int -> Int -> Gen (Pair Text Text)
byteArray :: FnEnv -> Text -> Int -> Int -> Gen (Pair Text Text)
byteArray FnEnv
fe Text
slow Int
ka Int
kind = do
  let ls :: Layouts
ls = Env -> Layouts
envLayouts (FnEnv -> Env
feEnv FnEnv
fe)
      rts :: RtsFacts
rts = Env -> RtsFacts
envRts (FnEnv -> Env
feEnv FnEnv
fe)
      wrap :: Pair Int Int
wrap = if Int
kind Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Layouts -> Pair Int Int
lMutableByteArrayWrap Layouts
ls else Layouts -> Pair Int Int
lByteArrayWrap Layouts
ls
  Text
p <- Int -> Gen Text
loadB Int
ka
  Text
raw <- Text -> Gen Text
fresh Text
"raw"
  Text -> Gen ()
emit (Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
fo <- Text -> Text -> Int -> Text -> Gen Text
taggedObject Text
"foreign" Text
raw (Layouts -> Int
lForeignInfo Layouts
ls) Text
slow
  Text
wrapped <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
fo Text
"wrap" Text
"i64" (Layouts -> Int
lHeaderBytes Layouts
ls)
  Text
w <- Text -> Text -> Pair Int Int -> Text -> Gen Text
taggedObjectTag Text
"barray" Text
wrapped Pair Int Int
wrap Text
slow
  Text
arr <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
w Text
"arr" Text
"i64" (Layouts -> Int
lHeaderBytes Layouts
ls)
  Text
size <- Text -> Text -> Text -> Int -> Gen Text
loadAt Text
arr Text
"bytes" Text
"i64" (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* RtsFacts -> Int
rBytesCount RtsFacts
rts)
  pure (Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair Text
arr Text
size)

-- | A pointer to byte @i@ of the array, once @width@ bytes from there are
-- within its @size@ bytes (else @slow@). The check is the one the Haskell
-- primitives make: @i + width > size@ or, should that sum wrap, @i > size@.
byteArrayElem :: FnEnv -> Text -> Text -> Text -> Text -> Int -> Gen Text
byteArrayElem :: FnEnv -> Text -> Text -> Text -> Text -> Int -> Gen Text
byteArrayElem FnEnv
fe Text
slow Text
arr Text
size Text
i Int
width = do
  let rts :: RtsFacts
rts = Env -> RtsFacts
envRts (FnEnv -> Env
feEnv FnEnv
fe)
  Text
end <- Text -> Text -> Text -> Gen Text
binop Text
"add" Text
i (Int -> Text
forall a. Show a => a -> Text
tshow Int
width)
  Text
past <- Text -> Gen Text
fresh Text
"past"
  Text -> Gen ()
emit (Text
past Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ugt i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
size)
  Text
wrapped <- Text -> Gen Text
fresh Text
"wrapped"
  Text -> Gen ()
emit (Text
wrapped Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp ugt i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
size)
  Text
oob <- Text -> Gen Text
fresh Text
"oob"
  Text -> Gen ()
emit (Text
oob Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
past Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
wrapped)
  Text -> Text -> Text -> Gen ()
branchIf Text
"inbounds" Text
oob Text
slow
  Text
arrP <- Text -> Gen Text
fresh Text
"arr.p"
  Text -> Gen ()
emit (Text
arrP Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Text
off <- Text -> Text -> Text -> Gen Text
binop Text
"add" Text
i (Int -> Text
forall a. Show a => a -> Text
tshow (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* RtsFacts -> Int
rBytesHeader RtsFacts
rts))
  Text
ep <- Text -> Gen Text
fresh Text
"elem.p"
  Text -> Gen ()
emit (Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i8, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arrP Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
off)
  pure Text
ep

-- | @llvm.bswap@ of the value, at the given integer type.
bswap :: Text -> Text -> Gen Text
bswap :: Text -> Text -> Gen Text
bswap Text
ty Text
v = do
  Text
r <- Text -> Gen Text
fresh Text
"swapped"
  Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" @llvm.bswap." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  pure Text
r

-- | Calls a helper that returns 1 when it did the job and gives unit; the
-- call-out otherwise.
unitHelper :: FnEnv -> Int -> Text -> Int -> Text -> Gen ()
unitHelper :: FnEnv -> Int -> Text -> Int -> Text -> Gen ()
unitHelper FnEnv
fe Int
d Text
slow Int
unitIx Text
call = do
  Text
r <- Text -> Gen Text
fresh Text
"ok"
  Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
call)
  Text
miss <- Text -> Gen Text
fresh Text
"miss"
  Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0")
  Text -> Text -> Text -> Gen ()
branchIf Text
"helper" Text
miss Text
slow
  FnEnv -> Int -> Int -> Gen ()
poolConstant FnEnv
fe Int
d Int
unitIx

-- | The call that builds a partial application of the closure @f@ with up
-- to four more arguments (given as unboxed and boxed halves).
-- | A partial application of a known function (@Name (Env f)@, or a
-- @Let@ whose binding applies @f@ to fewer arguments than it takes),
-- built in place. The function's closure in the pool (index @pix@) is a
-- @PAp@ with nothing captured; the new one is a copy of its words with
-- two new arrays holding the @n@ values from the slots @srcs@, laid out
-- as the interpreter's @augSeg@ lays them (the last argument at index
-- 0; see "Partial applications" in jit_rt.c). The closure and its arrays
-- are one chunk, as a wide constructor's are ('genPack'). Pushes the
-- closure at @d + 1@. No limit on @n@: nothing goes through registers.
genNameInline :: FnEnv -> Int -> Int -> Deque Int -> Gen ()
genNameInline :: FnEnv -> Int -> Int -> Deque Int -> Gen ()
genNameInline FnEnv
fe Int
d Int
pix Deque Int
srcs = do
  let env :: Env
env = FnEnv -> Env
feEnv FnEnv
fe
      ls :: Layouts
ls = Env -> Layouts
envLayouts Env
env
      rts :: RtsFacts
rts = Env -> RtsFacts
envRts Env
env
      layout :: Layout
layout = Layouts -> Layout
lPAp Layouts
ls
      n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs
      papWords :: Int
papWords = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lPtrs Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
lNptrs Layout
layout
      cardWords :: Int
cardWords = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` RtsFacts -> Int
rCardBits RtsFacts
rts) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` RtsFacts -> Int
rCardBits RtsFacts
rts
      cardWords' :: Int
cardWords' = (Int
cardWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
      bytesWords :: Int
bytesWords = RtsFacts -> Int
rBytesHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
      ptrsWords :: Int
ptrsWords = RtsFacts -> Int
rPtrsHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cardWords'
      ubytes :: Int
ubytes = Int
papWords
      bptrs :: Int
bptrs = Int
ubytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bytesWords
      -- payload word i of the closure, as a word index from its header
      field :: Int -> Int
field Int
i = Layout -> Int -> Int
lFieldOffset Layout
layout Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
  -- the values, before the allocation so nothing is held across it
  Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
srcs
  Text
tmpl <- Int -> Gen Text
poolValue Int
pix
  Text
ti <- Text -> Gen Text
fresh Text
"pap.i"
  Text -> Gen ()
emit (Text
ti Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tmpl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
tb <- Text -> Gen Text
fresh Text
"pap.base"
  Text -> Gen ()
emit (Text
tb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ti Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", -8")
  Text
tp <- Text -> Gen Text
fresh Text
"pap.p"
  Text -> Gen ()
emit (Text
tp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Text
obj <- Env -> Int -> Gen Text
allocWords Env
env (Int
papWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bytesWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ptrsWords)
  let word :: Int -> Gen Text
word Int
i = do
        Text
a <- Text -> Gen Text
fresh Text
"w"
        Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
i)
        pure Text
a
      storeAt :: Int -> Text -> Gen ()
storeAt Int
i Text
what = Int -> Gen Text
word Int
i Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
a -> Text -> Gen ()
emit (Text
"store " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a)
  -- the closure: the template's words (the header, the reference, the
  -- entry, its empty arrays, and the combinator's numbers)...
  [Int] -> (Int -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
papWords Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> Gen ()) -> Gen ()) -> (Int -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    Text
sa <- Text -> Gen Text
fresh Text
"t.a"
    Text -> Gen ()
emit (Text
sa Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
i)
    Text
v <- Text -> Gen Text
fresh Text
"t"
    Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load i64, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sa)
    Int -> Text -> Gen ()
storeAt Int
i (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v)
  -- ...then the ByteArray# and the Array# after it, the fields in reverse
  Int -> Text -> Gen ()
storeAt Int
ubytes (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rArrWordsInfo RtsFacts
rts))
  Int -> Text -> Gen ()
storeAt (Int
ubytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rBytesCount RtsFacts
rts) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n))
  Int -> Text -> Gen ()
storeAt Int
bptrs (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (RtsFacts -> Int
rArrPtrsInfo RtsFacts
rts))
  Int -> Text -> Gen ()
storeAt (Int
bptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsCount RtsFacts
rts) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n)
  Int -> Text -> Gen ()
storeAt (Int
bptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsSize RtsFacts
rts) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cardWords'))
  [Int] -> (Int -> Gen ()) -> Gen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
cardWords' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> Gen ()) -> Gen ()) -> (Int -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
c -> Int -> Text -> Gen ()
storeAt (Int
bptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c) Text
"i64 0"
  Deque (Pair Text Text)
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall (m :: * -> *) a.
Monad m =>
Deque a -> (Int -> a -> m ()) -> m ()
iforM_ Deque (Pair Text Text)
vals ((Int -> Pair Text Text -> Gen ()) -> Gen ())
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j (Pair Text
u Text
b) -> do
    Int -> Text -> Gen ()
storeAt (Int
ubytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rBytesHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)) (Text
"i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u)
    Int -> Text -> Gen ()
storeAt (Int
bptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RtsFacts -> Int
rPtrsHeader RtsFacts
rts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j)) (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b)
  -- the closure's two array fields point at them
  Text
ua <- Int -> Gen Text
word Int
ubytes
  Int -> Text -> Gen ()
storeAt (Int -> Int
field Int
2) (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
  Text
ba <- Int -> Gen Text
word Int
bptrs
  Int -> Text -> Gen ()
storeAt (Int -> Int
field Int
3) (Text
"ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
  Text
oi <- Text -> Gen Text
fresh Text
"pap"
  Text -> Gen ()
emit (Text
oi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ptrtoint ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
obj Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  Text
tg <- Text -> Gen Text
fresh Text
"pap.tagged"
  Text -> Gen ()
emit (Text
tg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = or i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
oi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Layout -> Int
lPtrTag Layout
layout))
  Text
tgp <- Text -> Gen Text
fresh Text
"pap"
  Text -> Gen ()
emit (Text
tgp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = inttoptr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to ptr")
  Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
  Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
tgp

-- | A partial application of a function value found on the stack (@Name
-- (Stk i)@, the closure in register @f@): the C helper copies it with the
-- values added, since how much it already holds is only known when it
-- runs. The values go to the helper on the Unison stack, in the slots
-- above the depth, which are scratch here as they are for a call's
-- arguments and which the entry check covers. Null from the helper (not
-- a @PAp@) takes @slow@.
genNameStack :: FnEnv -> Int -> Text -> Text -> Deque Int -> Gen ()
genNameStack :: FnEnv -> Int -> Text -> Text -> Deque Int -> Gen ()
genNameStack FnEnv
fe Int
d Text
slow Text
f Deque Int
srcs = do
  let n :: Int
n = Deque Int -> Int
forall a. Deque a -> Int
D.size Deque Int
srcs
  Deque (Pair Text Text)
vals <- Deque Int -> StateT GS Identity (Deque (Pair Text Text))
loadSources Deque Int
srcs
  Deque (Pair Text Text)
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall (m :: * -> *) a.
Monad m =>
Deque a -> (Int -> a -> m ()) -> m ()
iforM_ Deque (Pair Text Text)
vals ((Int -> Pair Text Text -> Gen ()) -> Gen ())
-> (Int -> Pair Text Text -> Gen ()) -> Gen ()
forall a b. (a -> b) -> a -> b
$ \Int
j (Pair Text
u Text
b) -> do
    Text
ua <- Int -> Gen Text
stackAddrU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j)
    Text -> Gen ()
emit (Text
"store i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ua)
    Text
ba <- Int -> Gen Text
stackAddrB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j)
    Text -> Gen ()
emit (Text
"store ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ba)
  Text
base <- Int -> Gen Text
fpPlus (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Text
top <- Int -> Gen Text
fpPlus (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
  Env -> Text -> Gen ()
markWritten (FnEnv -> Env
feEnv FnEnv
fe) Text
top
  Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow (Text
"@unison_jit_name(ptr %ctx, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")

-- | Calls a list helper that returns a boxed result, or null for a case
-- it leaves to the interpreter (@slow@); pushes the result.
listHelper :: Int -> Text -> Text -> Gen ()
listHelper :: Int -> Text -> Text -> Gen ()
listHelper Int
d Text
slow Text
call = do
  Text
r <- Text -> Gen Text
fresh Text
"list"
  Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
call)
  Text
miss <- Text -> Gen Text
fresh Text
"miss"
  Text -> Gen ()
emit (Text
miss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp eq ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", null")
  Text -> Text -> Text -> Gen ()
branchIf Text
"list" Text
miss Text
slow
  Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
  Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
r

-- | A pool entry, loaded.
poolValue :: Int -> Gen Text
poolValue :: Int -> Gen Text
poolValue Int
ix = do
  Int -> Gen ()
usePool Int
ix
  Text
a <- Text -> Gen Text
fresh Text
"pool.a"
  Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr ptr, ptr %pool, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
ix)
  Text
v <- Text -> Gen Text
fresh Text
"const"
  Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a)
  pure Text
v

-- | Records that the function uses this pool index.
usePool :: Int -> Gen ()
usePool :: Int -> Gen ()
usePool Int
ix = (GS -> GS) -> Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\GS
s -> GS
s {gsMaxPool = max (gsMaxPool s) ix})

-- | Pushes a pool entry as a boxed value.
poolConstant :: FnEnv -> Int -> Int -> Gen ()
poolConstant :: FnEnv -> Int -> Int -> Gen ()
poolConstant FnEnv
_fe Int
d Int
ix = do
  Int -> Gen ()
usePool Int
ix
  Text
a <- Text -> Gen Text
fresh Text
"pool.a"
  Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = getelementptr ptr, ptr %pool, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
ix)
  Text
v <- Text -> Gen Text
fresh Text
"const"
  Text -> Gen ()
emit (Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = load ptr, ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a)
  Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"-1"
  Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
v

-- | Stores an unboxed result with its type tag at depth @d + 1@.
result :: FnEnv -> Int -> Text -> Text -> Gen ()
result :: FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
_fe Int
d Text
tag Text
v = Int -> Text -> Gen ()
storeU (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
v Gen () -> Gen () -> Gen ()
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Text -> Gen ()
storeB (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
tag

-- | Stores a boolean result: a boxed enumeration closure.
resultBool :: FnEnv -> Int -> Text -> Gen ()
resultBool :: FnEnv -> Int -> Text -> Gen ()
resultBool FnEnv
_fe Int
d Text
c = Int -> Text -> Gen ()
setBoolKind (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
c

binop :: Text -> Text -> Text -> Gen Text
binop :: Text -> Text -> Text -> Gen Text
binop Text
op Text
x Text
y = do
  Text
r <- Text -> Gen Text
fresh Text
"r"
  Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y)
  pure Text
r

cmp :: Text -> Text -> Text -> Gen Text
cmp :: Text -> Text -> Text -> Gen Text
cmp Text
op Text
x Text
y = do
  Text
r <- Text -> Gen Text
fresh Text
"c"
  Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = icmp " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y)
  pure Text
r

-- | Branches to a resume exit if the condition holds, else continues.
exitIf :: FnEnv -> Int -> MSection -> Text -> Gen ()
exitIf :: FnEnv -> Int -> MSection -> Text -> Gen ()
exitIf FnEnv
fe Int
d MSection
sect Text
c = do
  Text
slow <- FnEnv -> Int -> Exit -> Gen Text
exitBlock FnEnv
fe Int
d (CombIx -> MSection -> Exit
Resume (FnEnv -> CombIx
feCix FnEnv
fe) MSection
sect)
  Text
ok <- Text -> Gen Text
freshLabel Text
"ok"
  Text -> Gen ()
emit (Text
"br i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", label %" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unlikely)
  Text -> Gen ()
startBlock Text
ok

genPrim1 :: FnEnv -> Int -> Prim1 -> Text -> MSection -> Gen ()
genPrim1 :: FnEnv -> Int -> Prim1 -> Text -> MSection -> Gen ()
genPrim1 FnEnv
fe Int
d Prim1
op Text
x MSection
_sect = case Prim1
op of
  Prim1
DECI -> Text -> Text -> Text -> Gen Text
binop Text
"sub" Text
x Text
"1" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim1
DECN -> Text -> Text -> Text -> Gen Text
binop Text
"sub" Text
x Text
"1" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim1
INCI -> Text -> Text -> Text -> Gen Text
binop Text
"add" Text
x Text
"1" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim1
INCN -> Text -> Text -> Text -> Gen Text
binop Text
"add" Text
x Text
"1" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim1
NEGI -> Text -> Text -> Text -> Gen Text
binop Text
"sub" Text
"0" Text
x Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim1
COMN -> Text -> Text -> Text -> Gen Text
binop Text
"xor" Text
x Text
"-1" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim1
COMI -> Text -> Text -> Text -> Gen Text
binop Text
"xor" Text
x Text
"-1" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim1
TRNC -> do
    Text
neg <- Text -> Text -> Text -> Gen Text
cmp Text
"slt" Text
x Text
"0"
    Text
r <- Text -> Gen Text
fresh Text
"r"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
neg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 0, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x)
    Text -> Gen ()
nat Text
r
  Prim1
LZRO -> Text -> Text -> Gen ()
count Text
"ctlz" Text
", i1 false"
  Prim1
TZRO -> Text -> Text -> Gen ()
count Text
"cttz" Text
", i1 false"
  Prim1
POPC -> Text -> Text -> Gen ()
count Text
"ctpop" Text
""
  Prim1
SGNI -> do
    Text
neg <- Text -> Text -> Text -> Gen Text
cmp Text
"slt" Text
x Text
"0"
    Text
pos <- Text -> Text -> Text -> Gen Text
cmp Text
"sgt" Text
x Text
"0"
    Text
a <- Text -> Gen Text
fresh Text
"r"
    Text -> Gen ()
emit (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 1, i64 0")
    Text
r <- Text -> Gen Text
fresh Text
"r"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
neg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 -1, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a)
    Text -> Gen ()
int Text
r
  -- Floats. A Float is its IEEE bits in the unboxed slot. These match the
  -- interpreter's Haskell operation for operation (Machine/Primops.hs):
  -- compiled Haskell calls libm for exp, log, the trigonometric and
  -- hyperbolic functions, uses an instruction for sqrt and abs, and converts
  -- to Int with a saturating conversion (fcvtzs on arm64; NaN gives 0),
  -- which is what the saturating intrinsic lowers to. `round` is rint
  -- (half to even) then that conversion. `ceiling` and `floor` are
  -- GHC.Float's ceilingDoubleInt and floorDoubleInt: truncate, then add or
  -- subtract one (wrapping) if the remainder x - n has the right sign, which
  -- is not what a saturating ceil would give out of range, so it is done
  -- the same way here.
  Prim1
ITOF -> do
    Text
r <- Text -> Gen Text
fresh Text
"f"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = sitofp i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to double")
    Text -> Gen ()
flt Text
r
  Prim1
NTOF -> do
    Text
r <- Text -> Gen Text
fresh Text
"f"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = uitofp i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to double")
    Text -> Gen ()
flt Text
r
  Prim1
ABSF -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"llvm.fabs.f64" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
SQRT -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"llvm.sqrt.f64" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
EXPF -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"exp" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
LOGF -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"log" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
COSF -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"cos" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
SINF -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"sin" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
TANF -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"tan" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
COSH -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"cosh" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
SINH -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"sinh" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
TANH -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"tanh" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
ACOS -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"acos" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
ASIN -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"asin" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
ATAN -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"atan" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
ASNH -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"asinh" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
ACSH -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"acosh" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
ATNH -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"atanh" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim1
CEIL -> Text -> Text -> Gen ()
ceilFloor Text
"ogt" Text
"add"
  Prim1
FLOR -> Text -> Text -> Gen ()
ceilFloor Text
"olt" Text
"sub"
  Prim1
RNDF -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Gen Text
call1 Text
"llvm.rint.f64" Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen Text
toInt Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim1
TRNF -> Text -> Gen Text
toF Text
x Gen Text -> (Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen Text
toInt Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim1
_ -> String -> Gen ()
forall a. HasCallStack => String -> a
error String
"genPrim1: unsupported"
  where
    int :: Text -> Gen ()
int = FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagInt FnEnv
fe)
    nat :: Text -> Gen ()
nat = FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagNat FnEnv
fe)
    flt :: Text -> Gen ()
flt Text
f = Text -> Gen Text
ofF Text
f Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagFloat FnEnv
fe)
    count :: Text -> Text -> Gen ()
count Text
name Text
flag = do
      Text
r <- Text -> Gen Text
fresh Text
"r"
      Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @llvm." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".i64(i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
flag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
      Text -> Gen ()
nat Text
r
    call1 :: Text -> Text -> Gen Text
call1 Text
name Text
f = do
      Text
r <- Text -> Gen Text
fresh Text
"f"
      Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call double @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
      pure Text
r
    toInt :: Text -> Gen Text
toInt Text
f = do
      Text
r <- Text -> Gen Text
fresh Text
"r"
      Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @llvm.fptosi.sat.i64.f64(double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
      pure Text
r
    -- n = truncate x; r = x - n; if r `pred` 0 then n `op` 1 else n
    ceilFloor :: Text -> Text -> Gen ()
ceilFloor Text
pred Text
op = do
      Text
f <- Text -> Gen Text
toF Text
x
      Text
n <- Text -> Gen Text
toInt Text
f
      Text
back <- Text -> Gen Text
fresh Text
"f"
      Text -> Gen ()
emit (Text
back Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = sitofp i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to double")
      Text
rem <- Text -> Gen Text
fresh Text
"f"
      Text -> Gen ()
emit (Text
rem Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = fsub double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
back)
      Text
c <- Text -> Gen Text
fresh Text
"c"
      Text -> Gen ()
emit (Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = fcmp " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pred Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rem Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 0.0")
      Text
n1 <- Text -> Text -> Text -> Gen Text
binop Text
op Text
n Text
"1"
      Text
r <- Text -> Gen Text
fresh Text
"r"
      Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n)
      Text -> Gen ()
int Text
r

-- | An unboxed slot's bits as a double, and back.
toF, ofF :: Text -> Gen Text
toF :: Text -> Gen Text
toF Text
x = do
  Text
f <- Text -> Gen Text
fresh Text
"f"
  Text -> Gen ()
emit (Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = bitcast i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to double")
  pure Text
f
ofF :: Text -> Gen Text
ofF Text
f = do
  Text
r <- Text -> Gen Text
fresh Text
"bits"
  Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = bitcast double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to i64")
  pure Text
r

genPrim2 :: FnEnv -> Int -> Prim2 -> Text -> Text -> MSection -> Gen ()
genPrim2 :: FnEnv -> Int -> Prim2 -> Text -> Text -> MSection -> Gen ()
genPrim2 FnEnv
fe Int
d Prim2
op Text
x Text
y MSection
sect = case Prim2
op of
  Prim2
ADDN -> Text -> Text -> Text -> Gen Text
binop Text
"add" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim2
SUBN -> Text -> Text -> Text -> Gen Text
binop Text
"sub" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int -- Nat.sub gives an Int
  Prim2
MULN -> Text -> Text -> Text -> Gen Text
binop Text
"mul" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim2
ANDN -> Text -> Text -> Text -> Gen Text
binop Text
"and" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim2
IORN -> Text -> Text -> Text -> Gen Text
binop Text
"or" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim2
XORN -> Text -> Text -> Text -> Gen Text
binop Text
"xor" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim2
DRPN -> do
    -- if n >= m then 0 else m - n
    Text
c <- Text -> Text -> Text -> Gen Text
cmp Text
"uge" Text
y Text
x
    Text
s <- Text -> Text -> Text -> Gen Text
binop Text
"sub" Text
x Text
y
    Text
r <- Text -> Gen Text
fresh Text
"r"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 0, i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s)
    Text -> Gen ()
nat Text
r
  Prim2
DIVN -> Gen ()
divZero Gen () -> Gen Text -> Gen Text
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Text -> Text -> Gen Text
binop Text
"udiv" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim2
MODN -> Gen ()
divZero Gen () -> Gen Text -> Gen Text
forall a b.
StateT GS Identity a
-> StateT GS Identity b -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Text -> Text -> Gen Text
binop Text
"urem" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim2
ADDI -> Text -> Text -> Text -> Gen Text
binop Text
"add" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim2
SUBI -> Text -> Text -> Text -> Gen Text
binop Text
"sub" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim2
MULI -> Text -> Text -> Text -> Gen Text
binop Text
"mul" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim2
ANDI -> Text -> Text -> Text -> Gen Text
binop Text
"and" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim2
IORI -> Text -> Text -> Text -> Gen Text
binop Text
"or" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim2
XORI -> Text -> Text -> Text -> Gen Text
binop Text
"xor" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim2
DIVI -> do
    Gen ()
divZero
    Gen ()
divOverflow
    -- Haskell's div rounds toward negative infinity
    Text
q <- Text -> Text -> Text -> Gen Text
binop Text
"sdiv" Text
x Text
y
    Text
r <- Text -> Text -> Text -> Gen Text
binop Text
"srem" Text
x Text
y
    Text
nz <- Text -> Text -> Text -> Gen Text
cmp Text
"ne" Text
r Text
"0"
    Text
signs <- Text -> Text -> Text -> Gen Text
binop Text
"xor" Text
r Text
y
    Text
neg <- Text -> Text -> Text -> Gen Text
cmp Text
"slt" Text
signs Text
"0"
    Text
adjust <- Text -> Gen Text
fresh Text
"adj"
    Text -> Gen ()
emit (Text
adjust Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nz Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
neg)
    Text
q1 <- Text -> Text -> Text -> Gen Text
binop Text
"sub" Text
q Text
"1"
    Text
res <- Text -> Gen Text
fresh Text
"r"
    Text -> Gen ()
emit (Text
res Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
adjust Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
q1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
q)
    Text -> Gen ()
int Text
res
  Prim2
MODI -> do
    Gen ()
divZero
    Gen ()
divOverflow
    Text
r <- Text -> Text -> Text -> Gen Text
binop Text
"srem" Text
x Text
y
    Text
nz <- Text -> Text -> Text -> Gen Text
cmp Text
"ne" Text
r Text
"0"
    Text
signs <- Text -> Text -> Text -> Gen Text
binop Text
"xor" Text
r Text
y
    Text
neg <- Text -> Text -> Text -> Gen Text
cmp Text
"slt" Text
signs Text
"0"
    Text
adjust <- Text -> Gen Text
fresh Text
"adj"
    Text -> Gen ()
emit (Text
adjust Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = and i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nz Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
neg)
    Text
r1 <- Text -> Text -> Text -> Gen Text
binop Text
"add" Text
r Text
y
    Text
res <- Text -> Gen Text
fresh Text
"r"
    Text -> Gen ()
emit (Text
res Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
adjust Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r)
    Text -> Gen ()
int Text
res
  Prim2
EQLN -> Text -> Text -> Text -> Gen Text
cmp Text
"eq" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  Prim2
NEQN -> Text -> Text -> Text -> Gen Text
cmp Text
"ne" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  Prim2
LEQN -> Text -> Text -> Text -> Gen Text
cmp Text
"ule" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  Prim2
LESN -> Text -> Text -> Text -> Gen Text
cmp Text
"ult" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  Prim2
EQLI -> Text -> Text -> Text -> Gen Text
cmp Text
"eq" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  Prim2
NEQI -> Text -> Text -> Text -> Gen Text
cmp Text
"ne" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  Prim2
LEQI -> Text -> Text -> Text -> Gen Text
cmp Text
"sle" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  Prim2
LESI -> Text -> Text -> Text -> Gen Text
cmp Text
"slt" Text
x Text
y Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  Prim2
SHLN -> Text -> Text -> Gen Text
shift Text
"shl" Text
"0" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim2
SHRN -> Text -> Text -> Gen Text
shift Text
"lshr" Text
"0" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  Prim2
SHLI -> Text -> Text -> Gen Text
shift Text
"shl" Text
"0" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim2
SHRI -> do
    -- an arithmetic shift by 64 or more gives the sign
    Text
sign <- Text -> Gen Text
fresh Text
"sign"
    Text -> Gen ()
emit (Text
sign Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ashr i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 63")
    Text -> Text -> Gen Text
shift Text
"ashr" Text
sign Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  -- Haskell's ^ by squaring; the same result modulo 2^64 whatever the order
  -- of the multiplications, so a C loop is exact.
  Prim2
POWI -> Gen Text
callPow Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
int
  Prim2
POWN -> Gen Text
callPow Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
nat
  -- a value with another type tag (the tag's number is the second argument,
  -- a literal in the builtins that use this)
  Prim2
CAST -> do
    Text
isChar <- Text -> Text -> Text -> Gen Text
cmp Text
"eq" Text
y Text
"0"
    Text
isFloat <- Text -> Text -> Text -> Gen Text
cmp Text
"eq" Text
y Text
"1"
    Text
isInt <- Text -> Text -> Text -> Gen Text
cmp Text
"eq" Text
y Text
"2"
    Text
t0 <- Text -> Gen Text
fresh Text
"tag"
    Text -> Gen ()
emit (Text
t0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
isInt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagInt FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagNat FnEnv
fe)
    Text
t1 <- Text -> Gen Text
fresh Text
"tag"
    Text -> Gen ()
emit (Text
t1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
isFloat Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagFloat FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t0)
    Text
t2 <- Text -> Gen Text
fresh Text
"tag"
    Text -> Gen ()
emit (Text
t2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
isChar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FnEnv -> Text
feTagChar FnEnv
fe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t1)
    FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d Text
t2 Text
x
  -- Floats (see genPrim1 for the conventions)
  Prim2
ADDF -> Text -> Gen Text
fbin Text
"fadd" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim2
SUBF -> Text -> Gen Text
fbin Text
"fsub" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim2
MULF -> Text -> Gen Text
fbin Text
"fmul" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  Prim2
DIVF -> Text -> Gen Text
fbin Text
"fdiv" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
flt
  -- Haskell's == and /= on Double are the ordered and unordered IEEE tests
  Prim2
EQLF -> Text -> Gen Text
fcmp Text
"oeq" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  Prim2
NEQF -> Text -> Gen Text
fcmp Text
"une" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  Prim2
LEQF -> Text -> Gen Text
fcmp Text
"ole" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  Prim2
LESF -> Text -> Gen Text
fcmp Text
"olt" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Gen ()
bool
  -- Ord Double's defaults: max x y = if x <= y then y else x, min likewise
  Prim2
MAXF -> do
    Pair Text
fx Text
fy <- Gen (Pair Text Text)
floats
    Text
c <- Text -> Text -> Text -> Gen Text
fcmpOn Text
"ole" Text
fx Text
fy
    Text
r <- Text -> Gen Text
fresh Text
"f"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fx)
    Text -> Gen ()
flt Text
r
  Prim2
MINF -> do
    Pair Text
fx Text
fy <- Gen (Pair Text Text)
floats
    Text
c <- Text -> Text -> Text -> Gen Text
fcmpOn Text
"ole" Text
fx Text
fy
    Text
r <- Text -> Gen Text
fresh Text
"f"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fy)
    Text -> Gen ()
flt Text
r
  Prim2
POWF -> do
    Pair Text
fx Text
fy <- Gen (Pair Text Text)
floats
    Text
r <- Text -> Gen Text
fresh Text
"f"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call double @pow(double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text -> Gen ()
flt Text
r
  -- logBase x y = log y / log x
  Prim2
LOGB -> do
    Pair Text
fx Text
fy <- Gen (Pair Text Text)
floats
    Text
ly <- Text -> Gen Text
fresh Text
"f"
    Text -> Gen ()
emit (Text
ly Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call double @log(double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text
lx <- Text -> Gen Text
fresh Text
"f"
    Text -> Gen ()
emit (Text
lx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call double @log(double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text
r <- Text -> Gen Text
fresh Text
"f"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = fdiv double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ly Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lx)
    Text -> Gen ()
flt Text
r
  -- GHC's atan2 is defined by cases in Haskell, not libm's; the C helper is a port
  Prim2
ATN2 -> do
    Pair Text
fx Text
fy <- Gen (Pair Text Text)
floats
    Text
r <- Text -> Gen Text
fresh Text
"f"
    Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call double @unison_jit_atan2(double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Text -> Gen ()
flt Text
r
  Prim2
_ -> String -> Gen ()
forall a. HasCallStack => String -> a
error String
"genPrim2: unsupported"
  where
    int :: Text -> Gen ()
int = FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagInt FnEnv
fe)
    nat :: Text -> Gen ()
nat = FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagNat FnEnv
fe)
    bool :: Text -> Gen ()
bool = FnEnv -> Int -> Text -> Gen ()
resultBool FnEnv
fe Int
d
    flt :: Text -> Gen ()
flt Text
f = Text -> Gen Text
ofF Text
f Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FnEnv -> Int -> Text -> Text -> Gen ()
result FnEnv
fe Int
d (FnEnv -> Text
feTagFloat FnEnv
fe)
    floats :: Gen (Pair Text Text)
floats = Text -> Text -> Pair Text Text
forall a b. a -> b -> Pair a b
Pair (Text -> Text -> Pair Text Text)
-> Gen Text -> StateT GS Identity (Text -> Pair Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Gen Text
toF Text
x StateT GS Identity (Text -> Pair Text Text)
-> Gen Text -> Gen (Pair Text Text)
forall a b.
StateT GS Identity (a -> b)
-> StateT GS Identity a -> StateT GS Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Gen Text
toF Text
y
    fbin :: Text -> Gen Text
fbin Text
instr = do
      Pair Text
fx Text
fy <- Gen (Pair Text Text)
floats
      Text
r <- Text -> Gen Text
fresh Text
"f"
      Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
instr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fy)
      pure Text
r
    fcmpOn :: Text -> Text -> Text -> Gen Text
fcmpOn Text
pred Text
fx Text
fy = do
      Text
c <- Text -> Gen Text
fresh Text
"c"
      Text -> Gen ()
emit (Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = fcmp " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pred Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" double " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fy)
      pure Text
c
    fcmp :: Text -> Gen Text
fcmp Text
pred = Gen (Pair Text Text)
floats Gen (Pair Text Text) -> (Pair Text Text -> Gen Text) -> Gen Text
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Pair Text
fx Text
fy) -> Text -> Text -> Text -> Gen Text
fcmpOn Text
pred Text
fx Text
fy
    callPow :: Gen Text
callPow = do
      Text
r <- Text -> Gen Text
fresh Text
"r"
      Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = call i64 @unison_jit_pow(i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
      pure Text
r
    divZero :: Gen ()
divZero = Text -> Text -> Text -> Gen Text
cmp Text
"eq" Text
y Text
"0" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FnEnv -> Int -> MSection -> Text -> Gen ()
exitIf FnEnv
fe Int
d MSection
sect
    divOverflow :: Gen ()
divOverflow = Text -> Text -> Text -> Gen Text
cmp Text
"eq" Text
y Text
"-1" Gen Text -> (Text -> Gen ()) -> Gen ()
forall a b.
StateT GS Identity a
-> (a -> StateT GS Identity b) -> StateT GS Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FnEnv -> Int -> MSection -> Text -> Gen ()
exitIf FnEnv
fe Int
d MSection
sect
    -- Haskell rejects negative shifts and gives `big` for shifts of 64 or more
    shift :: Text -> Text -> Gen Text
shift Text
instr Text
big = do
      Text
neg <- Text -> Text -> Text -> Gen Text
cmp Text
"slt" Text
y Text
"0"
      FnEnv -> Int -> MSection -> Text -> Gen ()
exitIf FnEnv
fe Int
d MSection
sect Text
neg
      Text
wide <- Text -> Text -> Text -> Gen Text
cmp Text
"sge" Text
y Text
"64"
      Text
s <- Text -> Text -> Text -> Gen Text
binop Text
instr Text
x Text
y
      Text
r <- Text -> Gen Text
fresh Text
"r"
      Text -> Gen ()
emit (Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = select i1 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
wide Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
big Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", i64 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s)
      pure Text
r