{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedTuples #-}
-- See the note in Stack.hs: the JIT relies on GCombInfo's optimized layout.
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}

module Unison.Runtime.MCode
  ( Args' (..),
    Args (..),
    FieldRef (..),
    RecordShape (..),
    mkRecordShape,
    shapeSlot,
    recordShape,
    recordShapeFrom,
    RefNums (..),
    MLit (..),
    GInstr (..),
    Instr,
    RInstr,
    GSection (.., MatchT, MatchW),
    RSection,
    Section,
    GComb (.., Lam),
    FrameLayout (..),
    emptyLayout,
    layoutPadding,
    widePadding,
    Deopt (..),
    BaseFrame (..),
    Slot (..),
    GCombInfo (..),
    NativeCell,
    readNativeCode,
    readNativeEntry,
    writeNativeCode,
    bumpNativeCount,
    readNativeCount,
    writeNativeCount,
    claimNativeCell,
    nativeRegisterEntryOffset,
    writeNativeRegisterEntry,
    releaseNativeCell,
    takeNativeCell,
    nativeCellRequested,
    readNativeVerdict,
    writeNativeVerdict,
    NativeCellPool (..),
    newNativeCells,
    nativeCellAt,
    newNativeCellPool,
    takeNativeCells,
    growNativeCellPool,
    noNativeCell,
    attachNativeCells,
    Comb,
    RComb (..),
    RCombInfo,
    GCombs,
    RCombs,
    CombIx (..),
    GRef (..),
    RRef,
    Ref,
    Prim1 (..),
    Prim2 (..),
    GBranch (..),
    Arm (..),
    ConstructorArity,
    armSection,
    Branch,
    RBranch,
    RecordFieldMappings (..),
    emptyRecordFieldMappings,
    convertFieldNamesToRefs,
    emitCombs,
    emitComb,
    emptyRCtx,
    resolveCombs,
    sanitizeCombsOfForeignFuncs,
    absurdCombs,
    emptyRNs,
    argsToLists,
    argsToArgs',
    countArgs,
    pushCount,
    combRef,
    combDeps,
    combTypes,
    prettyCombs,
    prettyComb,
    prettySection,
    prettyIns,
  )
where

import Control.Monad (forM_, when)
import Control.Monad.RWS
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Trans.Writer.CPS (WriterT, runWriterT)
import Data.Bifoldable (Bifoldable (..))
import Data.Bifunctor (Bifunctor, bimap, first)
import Data.Bitraversable (Bitraversable (..), bifoldMapDefault, bimapDefault)
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import Data.Coerce
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (toList)
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.List (intersperse)
import Data.Map.Strict qualified as M
import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)
import Data.Primitive.PrimArray
import Data.Primitive.PrimArray qualified as PA
import Data.Semigroup (Max (..))
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Traversable (for)
import Data.Vector (Vector)
import Data.Vector qualified as V
import Data.Void (Void, absurd)
import Data.Word (Word16, Word64)
import Foreign.Marshal.Alloc (callocBytes)
import Foreign.Ptr (WordPtr (..), nullPtr, plusPtr, ptrToWordPtr, wordPtrToPtr)
import Foreign.Storable (peekByteOff, pokeByteOff)
import GHC.Exts (Word (W#), Word#, atomicCasWordAddr#, atomicReadWordAddr#, atomicWriteWordAddr#, eqWord#, isTrue#, plusAddr#)
import GHC.IO (IO (..))
import GHC.Ptr (Ptr (..))
import GHC.Stack (HasCallStack)
import System.IO.Unsafe (unsafePerformIO)
import Unison.ABT.Normalized (pattern TAbss)
import Unison.Reference (Reference, showShort)
import Unison.Referent (Referent)
import Unison.Runtime.ANF
  ( ANormal,
    Branched (..),
    CTag,
    Direction (..),
    Func (..),
    Mem (..),
    PackedTag (..),
    SuperGroup (..),
    SuperNormal (..),
    packTags,
    pattern TApp,
    pattern TBLit,
    pattern TBox,
    pattern TDiscard,
    pattern TFOp,
    pattern TFrc,
    pattern THnd,
    pattern TLets,
    pattern TLit,
    pattern TLocal,
    pattern TMatch,
    pattern TName,
    pattern TPrm,
    pattern TShift,
    pattern TUpdate,
    pattern TVar,
  )
import Unison.Runtime.ANF qualified as ANF
import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName)
import Unison.Runtime.InternalError (internalBug)
import Unison.Runtime.MCode.Explode
import Unison.Runtime.MCode.Wide (letYields, wideBody, wideCon)
import Unison.Runtime.Wide (wideK, wideOn, wideWidth)
import Unison.Util.BiMap (BiMap)
import Unison.Util.BiMap qualified as BiMap
import Unison.Util.Bytes (Bytes)
import Unison.Util.EnumContainers as EC
import Unison.Util.Monoid (foldMapM)
import Unison.Util.Text (Text)
import Unison.Var (Var)

-- This outlines some of the ideas/features in this core
-- language, and how they may be used to implement features of
-- the surface language.

-----------------------
-- Delimited control --
-----------------------

-- There is native support for delimited control operations in
-- the core language. This means we can:
--   1. delimit a block of code with an integer tagged prompt,
--      which corresponds to pushing a frame onto the
--      continuation with said tag
--   2. capture a portion of the continuation up to a particular
--      tag frame and turn it into a value, which _removes_ the
--      tag frame from the continuation in the process
--   3. push such a captured value back onto the continuation

-- TBD: Since the captured continuations in _delimited_ control
-- are (in this case impure) functions, it may make sense to make
-- the representation of functions support these captured
-- continuations directly.

-- The obvious use case of this feature is effects and handlers.
-- Delimiting a block with a prompt is part of installing a
-- handler for said block at least naively. The other part is
-- establishing the code that should be executed for each
-- operation to be handled.

-- It's important (I believe) in #2 that the prompt be removed
-- from the continuation by a control effect. The captured
-- continuation not being automatically delimited corresponds to
-- a shallow handler's obligation to re-establish the handling of
-- a re-invoked computation if it wishes to do so. The delimiter
-- being removed from the capturing code's continuation
-- corresponds to a handler being allowed to yield effects from
-- the same siganture that it is handling.

-- In special cases, it should be possible to omit use of control
-- effects in handlers. At the least, if a handler case resumes
-- the computation in tail position, it should be unnecessary to
-- capture the continuation at all. If all cases act this way, we
-- don't need a delimiter, because we will never capture.

-- TBD: it may make more sense to have prompt pushing be part of
-- some other construct, due to A-normal forms of the code.

-----------------------------
-- Unboxed sum-of-products --
-----------------------------

-- It is not usually stated this way, but one of the core
-- features of the STG machine is that functions/closures can
-- return unboxed sum-of-products types. This is actually the way
-- _all_ data types work in STG. The discriminee of a case
-- statement must eventually return by pushing several values
-- onto the stack (the product part) and specifying which branch
-- to return to (the sum part).

-- The way heap allocated data is produced is that an
-- intermediate frame may be in the continuation that grabs this
-- information from the local storage and puts it into the heap.
-- If this frame were omitted, only the unboxed component would
-- be left. Also, in STG, the heap allocated data is just a means
-- of reconstructing its unboxed analogue. Evaluating a heap
-- allocated data type value just results in pushing its stored
-- fields back on the stack, and immediately returning the tag.

-- The portion of this with the heap allocation frame omitted
-- seems to be a natural match for the case analysis portion of
-- handlers. A naive implementation of an effect algebra is as
-- the data type of the polynomial functor generated by the
-- signature, and handling corresponds to case analysis. However,
-- in a real implementation, we don't want a heap allocated
-- representation of this algebra, because its purpose is control
-- flow. Each operation will be handled once as it occurs, and we
-- won't save work by remembering some reified representation of
-- which operations were used.

-- Since handlers in unison are written as functions, it seems to
-- make sense to define a calling convention for unboxed
-- sum-of-products as arguments. Variable numbers of stack
-- positions could be pushed for such arguments, with tags
-- specifying which case is being provided.

-- TBD: sum arguments to a function correspond to a product of
-- functions, so it's possible that the calling convention for
-- these functions should be similar to returning to a case,
-- where we push arguments and then select which of several
-- pieces of code to jump to. This view also seems relevant to
-- the optimized implementation of certain forms of handler,
-- where we want effects to just directly select some code to
-- execute based on state that has been threaded to that point.

-- One thing to note: it probably does not make sense to
-- completely divide returns into unboxed returns and allocation
-- frames. The reason this works in STG is laziness. Naming a
-- computation with `let` does not do any evaluation, but it does
-- allocate space for its (boxed) result. The only thing that
-- _does_ demand evaluation is case analysis. So, if a value with
-- sum type is being evaluated, we know it must be about to be
-- unpacked, and it makes little sense to pack it on the stack,
-- though we can build a closure version of it in the writeback
-- location established by `let`.

-- By contrast, in unison a `let` of a sum type evaluates it
-- immediately, even if no one is analyzing it. So we might waste
-- work rearranging the stack with the unpacked contents when we
-- only needed the closure version to begin with. Instead, we
-- gain the ability to make the unpacking operation use no stack,
-- because we know what we are unpacking must be a value. Turning
-- boxed function calls into unboxed versions thus seems like a
-- situational optimization, rather than a universal calling
-- convention.

-------------------------------
-- Delimited Dynamic Binding --
-------------------------------

-- There is a final component to the implementation of ability
-- handlers in this runtime system, and that is dynamically
-- scoped variables associated to each prompt. Each prompt
-- corresponds to an ability signature, and `reset` to a handler
-- for said signature, but we need storage space for the code
-- installed by said handler. It is possible to implement
-- dynamically scoped variables entirely with delimited
-- continuations, but it is more efficient to keep track of the
-- storage directly when manipulating the continuations.

-- The dynamic scoping---and how it interacts with
-- continuations---corresponds to the nested structure of
-- handlers. Installing a handler establishes a variable scope,
-- shadowing outer scopes for the same prompt. Shifting, however,
-- can exit these scopes dynamically. So, for instance, if we
-- have a structure like:

--    reset 0 $ ...
--      reset 1 $ ...
--        reset 0 $ ...
--          shift 1 <E>

-- We have nested scopes 0>1>0, with the second 0 shadowing the
-- first. However, when we shift to 1, the inner 0 scope is
-- captured into the continuation, and uses of the 0 ability in
-- <E> will be handled by the outer handler until it is shadowed
-- again (and the captured continuation will re-establish the
-- shadowing).

-- Mutation of the variables is possible, but mutation only
-- affects the current scope. Essentially, the dynamic scoping is
-- of mutable references, and when scope changes, we switch
-- between different references, and the mutation of each
-- reference does not affect the others. The purpose of the
-- mutation is to enable more efficient implementation of
-- certain recursive, 'deep' handlers, since those can operate
-- more like stateful code than control operators.

data Sandboxed = Tracked | Untracked
  deriving (Int -> Sandboxed -> ShowS
[Sandboxed] -> ShowS
Sandboxed -> [Char]
(Int -> Sandboxed -> ShowS)
-> (Sandboxed -> [Char])
-> ([Sandboxed] -> ShowS)
-> Show Sandboxed
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Sandboxed -> ShowS
showsPrec :: Int -> Sandboxed -> ShowS
$cshow :: Sandboxed -> [Char]
show :: Sandboxed -> [Char]
$cshowList :: [Sandboxed] -> ShowS
showList :: [Sandboxed] -> ShowS
Show, Sandboxed -> Sandboxed -> Bool
(Sandboxed -> Sandboxed -> Bool)
-> (Sandboxed -> Sandboxed -> Bool) -> Eq Sandboxed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Sandboxed -> Sandboxed -> Bool
== :: Sandboxed -> Sandboxed -> Bool
$c/= :: Sandboxed -> Sandboxed -> Bool
/= :: Sandboxed -> Sandboxed -> Bool
Eq, Eq Sandboxed
Eq Sandboxed =>
(Sandboxed -> Sandboxed -> Ordering)
-> (Sandboxed -> Sandboxed -> Bool)
-> (Sandboxed -> Sandboxed -> Bool)
-> (Sandboxed -> Sandboxed -> Bool)
-> (Sandboxed -> Sandboxed -> Bool)
-> (Sandboxed -> Sandboxed -> Sandboxed)
-> (Sandboxed -> Sandboxed -> Sandboxed)
-> Ord Sandboxed
Sandboxed -> Sandboxed -> Bool
Sandboxed -> Sandboxed -> Ordering
Sandboxed -> Sandboxed -> Sandboxed
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 :: Sandboxed -> Sandboxed -> Ordering
compare :: Sandboxed -> Sandboxed -> Ordering
$c< :: Sandboxed -> Sandboxed -> Bool
< :: Sandboxed -> Sandboxed -> Bool
$c<= :: Sandboxed -> Sandboxed -> Bool
<= :: Sandboxed -> Sandboxed -> Bool
$c> :: Sandboxed -> Sandboxed -> Bool
> :: Sandboxed -> Sandboxed -> Bool
$c>= :: Sandboxed -> Sandboxed -> Bool
>= :: Sandboxed -> Sandboxed -> Bool
$cmax :: Sandboxed -> Sandboxed -> Sandboxed
max :: Sandboxed -> Sandboxed -> Sandboxed
$cmin :: Sandboxed -> Sandboxed -> Sandboxed
min :: Sandboxed -> Sandboxed -> Sandboxed
Ord)

data Args'
  = Arg1 !Int
  | Arg2 !Int !Int
  | -- frame index of each argument to the function
    ArgN {-# UNPACK #-} !(PrimArray Int)
  | ArgR !Int !Int
  deriving (Int -> Args' -> ShowS
[Args'] -> ShowS
Args' -> [Char]
(Int -> Args' -> ShowS)
-> (Args' -> [Char]) -> ([Args'] -> ShowS) -> Show Args'
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Args' -> ShowS
showsPrec :: Int -> Args' -> ShowS
$cshow :: Args' -> [Char]
show :: Args' -> [Char]
$cshowList :: [Args'] -> ShowS
showList :: [Args'] -> ShowS
Show)

data Args
  = ZArgs
  | VArg1 !Int
  | VArg2 !Int !Int
  | VArgR !Int !Int
  | VArgN {-# UNPACK #-} !(PrimArray Int)
  | VArgV !Int
  deriving (Int -> Args -> ShowS
[Args] -> ShowS
Args -> [Char]
(Int -> Args -> ShowS)
-> (Args -> [Char]) -> ([Args] -> ShowS) -> Show Args
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Args -> ShowS
showsPrec :: Int -> Args -> ShowS
$cshow :: Args -> [Char]
show :: Args -> [Char]
$cshowList :: [Args] -> ShowS
showList :: [Args] -> ShowS
Show, Args -> Args -> Bool
(Args -> Args -> Bool) -> (Args -> Args -> Bool) -> Eq Args
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Args -> Args -> Bool
== :: Args -> Args -> Bool
$c/= :: Args -> Args -> Bool
/= :: Args -> Args -> Bool
Eq, Eq Args
Eq Args =>
(Args -> Args -> Ordering)
-> (Args -> Args -> Bool)
-> (Args -> Args -> Bool)
-> (Args -> Args -> Bool)
-> (Args -> Args -> Bool)
-> (Args -> Args -> Args)
-> (Args -> Args -> Args)
-> Ord Args
Args -> Args -> Bool
Args -> Args -> Ordering
Args -> Args -> Args
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 :: Args -> Args -> Ordering
compare :: Args -> Args -> Ordering
$c< :: Args -> Args -> Bool
< :: Args -> Args -> Bool
$c<= :: Args -> Args -> Bool
<= :: Args -> Args -> Bool
$c> :: Args -> Args -> Bool
> :: Args -> Args -> Bool
$c>= :: Args -> Args -> Bool
>= :: Args -> Args -> Bool
$cmax :: Args -> Args -> Args
max :: Args -> Args -> Args
$cmin :: Args -> Args -> Args
min :: Args -> Args -> Args
Ord)

argsToArgs' :: Args -> Args'
argsToArgs' :: Args -> Args'
argsToArgs' = \case
  Args
ZArgs -> PrimArray Int -> Args'
ArgN PrimArray Int
forall a. PrimArray a
PA.emptyPrimArray
  VArg1 Int
i -> Int -> Args'
Arg1 Int
i
  VArg2 Int
i Int
j -> Int -> Int -> Args'
Arg2 Int
i Int
j
  VArgR Int
i Int
l -> Int -> Int -> Args'
ArgR Int
i Int
l
  VArgN PrimArray Int
us -> PrimArray Int -> Args'
ArgN PrimArray Int
us
  VArgV Int
n -> Int -> Int -> Args'
ArgR Int
0 Int
n
{-# INLINEABLE argsToArgs' #-}

-- | Efficient mapping for record field names
newtype FieldRef = FieldRef Word64
  deriving newtype (Int -> FieldRef -> ShowS
[FieldRef] -> ShowS
FieldRef -> [Char]
(Int -> FieldRef -> ShowS)
-> (FieldRef -> [Char]) -> ([FieldRef] -> ShowS) -> Show FieldRef
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldRef -> ShowS
showsPrec :: Int -> FieldRef -> ShowS
$cshow :: FieldRef -> [Char]
show :: FieldRef -> [Char]
$cshowList :: [FieldRef] -> ShowS
showList :: [FieldRef] -> ShowS
Show, FieldRef -> FieldRef -> Bool
(FieldRef -> FieldRef -> Bool)
-> (FieldRef -> FieldRef -> Bool) -> Eq FieldRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldRef -> FieldRef -> Bool
== :: FieldRef -> FieldRef -> Bool
$c/= :: FieldRef -> FieldRef -> Bool
/= :: FieldRef -> FieldRef -> Bool
Eq, Eq FieldRef
Eq FieldRef =>
(FieldRef -> FieldRef -> Ordering)
-> (FieldRef -> FieldRef -> Bool)
-> (FieldRef -> FieldRef -> Bool)
-> (FieldRef -> FieldRef -> Bool)
-> (FieldRef -> FieldRef -> Bool)
-> (FieldRef -> FieldRef -> FieldRef)
-> (FieldRef -> FieldRef -> FieldRef)
-> Ord FieldRef
FieldRef -> FieldRef -> Bool
FieldRef -> FieldRef -> Ordering
FieldRef -> FieldRef -> FieldRef
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 :: FieldRef -> FieldRef -> Ordering
compare :: FieldRef -> FieldRef -> Ordering
$c< :: FieldRef -> FieldRef -> Bool
< :: FieldRef -> FieldRef -> Bool
$c<= :: FieldRef -> FieldRef -> Bool
<= :: FieldRef -> FieldRef -> Bool
$c> :: FieldRef -> FieldRef -> Bool
> :: FieldRef -> FieldRef -> Bool
$c>= :: FieldRef -> FieldRef -> Bool
>= :: FieldRef -> FieldRef -> Bool
$cmax :: FieldRef -> FieldRef -> FieldRef
max :: FieldRef -> FieldRef -> FieldRef
$cmin :: FieldRef -> FieldRef -> FieldRef
min :: FieldRef -> FieldRef -> FieldRef
Ord, Int -> FieldRef
FieldRef -> Int
FieldRef -> [FieldRef]
FieldRef -> FieldRef
FieldRef -> FieldRef -> [FieldRef]
FieldRef -> FieldRef -> FieldRef -> [FieldRef]
(FieldRef -> FieldRef)
-> (FieldRef -> FieldRef)
-> (Int -> FieldRef)
-> (FieldRef -> Int)
-> (FieldRef -> [FieldRef])
-> (FieldRef -> FieldRef -> [FieldRef])
-> (FieldRef -> FieldRef -> [FieldRef])
-> (FieldRef -> FieldRef -> FieldRef -> [FieldRef])
-> Enum FieldRef
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: FieldRef -> FieldRef
succ :: FieldRef -> FieldRef
$cpred :: FieldRef -> FieldRef
pred :: FieldRef -> FieldRef
$ctoEnum :: Int -> FieldRef
toEnum :: Int -> FieldRef
$cfromEnum :: FieldRef -> Int
fromEnum :: FieldRef -> Int
$cenumFrom :: FieldRef -> [FieldRef]
enumFrom :: FieldRef -> [FieldRef]
$cenumFromThen :: FieldRef -> FieldRef -> [FieldRef]
enumFromThen :: FieldRef -> FieldRef -> [FieldRef]
$cenumFromTo :: FieldRef -> FieldRef -> [FieldRef]
enumFromTo :: FieldRef -> FieldRef -> [FieldRef]
$cenumFromThenTo :: FieldRef -> FieldRef -> FieldRef -> [FieldRef]
enumFromThenTo :: FieldRef -> FieldRef -> FieldRef -> [FieldRef]
Enum, Int -> FieldRef
FieldRef -> Int
(FieldRef -> Int) -> (Int -> FieldRef) -> EnumKey FieldRef
forall k. (k -> Int) -> (Int -> k) -> EnumKey k
$ckeyToInt :: FieldRef -> Int
keyToInt :: FieldRef -> Int
$cintToKey :: Int -> FieldRef
intToKey :: Int -> FieldRef
EnumKey)

-- | The shape of a record: which fields it has, and where each one sits in a
-- record value's slots.
--
-- One of these is built per record-construction site and is carried by every
-- value built there. Reaching it from the value is what lets `Eq` and
-- `compareClosure` -- which are pure, with no access to the code cache --
-- order two records of *different* shapes by field name. That case is
-- reachable: two records with different fields can be compared once they are
-- wrapped in `Any`, which erases their types.
data RecordShape = RecordShape
  { -- | Interned id for this field set. Not used for ordering: it is handed
    -- out in allocation order, which is why ordering goes through
    -- 'shapeFields' instead.
    RecordShape -> RecordRef
shapeRef :: !ANF.RecordRef,
    -- | The record's field names, ascending. Slot @i@ of a record value holds
    -- the value of @shapeFields ! i@.
    RecordShape -> Vector FieldName
shapeFields :: !(Vector ANF.FieldName),
    -- | The field numbers ('FieldRef'), ascending; with 'shapeSlots' the
    -- slot of each field, for 'RecUnpack' and 'RecSet'. Two unboxed arrays
    -- searched by 'shapeSlot' rather than a map: a lookup is a binary search
    -- over a few words, and native code does the same search over the
    -- @ByteArray#@s (unison_jit_rec_pos). Built by 'mkRecordShape'.
    RecordShape -> PrimArray Word64
shapeKeys :: !(PrimArray Word64),
    -- | The slot of the field at the same index of 'shapeKeys'.
    RecordShape -> PrimArray Int
shapeSlots :: !(PrimArray Int)
  }
  deriving stock (Int -> RecordShape -> ShowS
[RecordShape] -> ShowS
RecordShape -> [Char]
(Int -> RecordShape -> ShowS)
-> (RecordShape -> [Char])
-> ([RecordShape] -> ShowS)
-> Show RecordShape
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecordShape -> ShowS
showsPrec :: Int -> RecordShape -> ShowS
$cshow :: RecordShape -> [Char]
show :: RecordShape -> [Char]
$cshowList :: [RecordShape] -> ShowS
showList :: [RecordShape] -> ShowS
Show)

-- | A shape from its reference, its field names ascending, and the number of
-- each field in that order (so the field at slot @i@ has number @refs !! i@).
mkRecordShape :: ANF.RecordRef -> Vector ANF.FieldName -> [FieldRef] -> RecordShape
mkRecordShape :: RecordRef -> Vector FieldName -> [FieldRef] -> RecordShape
mkRecordShape RecordRef
ref Vector FieldName
names [FieldRef]
refs =
  RecordShape
    { shapeRef :: RecordRef
shapeRef = RecordRef
ref,
      shapeFields :: Vector FieldName
shapeFields = Vector FieldName
names,
      shapeKeys :: PrimArray Word64
shapeKeys = [Word64] -> PrimArray Word64
forall a. Prim a => [a] -> PrimArray a
PA.primArrayFromList (((FieldRef, Int) -> Word64) -> [(FieldRef, Int)] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map (\(FieldRef Word64
k, Int
_) -> Word64
k) [(FieldRef, Int)]
sorted),
      shapeSlots :: PrimArray Int
shapeSlots = [Int] -> PrimArray Int
forall a. Prim a => [a] -> PrimArray a
PA.primArrayFromList (((FieldRef, Int) -> Int) -> [(FieldRef, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (FieldRef, Int) -> Int
forall a b. (a, b) -> b
snd [(FieldRef, Int)]
sorted)
    }
  where
    sorted :: [(FieldRef, Int)]
sorted = Map FieldRef Int -> [(FieldRef, Int)]
forall k a. Map k a -> [(k, a)]
M.toAscList ([(FieldRef, Int)] -> Map FieldRef Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([FieldRef] -> [Int] -> [(FieldRef, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FieldRef]
refs [Int
0 ..]))

-- | The slot of a field in a record of this shape: a binary search of
-- 'shapeKeys'. A field the shape lacks is an error, not a result: typechecked
-- code only reads fields the record has, so there is nothing to recover
-- from, and nothing to allocate on the way out.
shapeSlot :: RecordShape -> FieldRef -> Int
shapeSlot :: RecordShape -> FieldRef -> Int
shapeSlot RecordShape
shape (FieldRef Word64
k) = Int -> Int -> Int
go Int
0 (PrimArray Word64 -> Int
forall a. Prim a => PrimArray a -> Int
PA.sizeofPrimArray PrimArray Word64
keys)
  where
    keys :: PrimArray Word64
keys = RecordShape -> PrimArray Word64
shapeKeys RecordShape
shape
    go :: Int -> Int -> Int
go !Int
lo !Int
hi
      | Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
hi = [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"shapeSlot: no field " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
k [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" in record " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [FieldName] -> [Char]
forall a. Show a => a -> [Char]
show (Vector FieldName -> [FieldName]
forall a. Vector a -> [a]
V.toList (RecordShape -> Vector FieldName
shapeFields RecordShape
shape)))
      | Bool
otherwise =
          let mid :: Int
mid = (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hi) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
              k' :: Word64
k' = PrimArray Word64 -> Int -> Word64
forall a. Prim a => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Word64
keys Int
mid
           in if Word64
k' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
k
                then Int -> Int -> Int
go (Int
mid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
hi
                else
                  if Word64
k' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
k
                    then Int -> Int -> Int
go Int
lo Int
mid
                    else PrimArray Int -> Int -> Int
forall a. Prim a => PrimArray a -> Int -> a
PA.indexPrimArray (RecordShape -> PrimArray Int
shapeSlots RecordShape
shape) Int
mid
{-# INLINE shapeSlot #-}

-- | Records are equal and ordered by field name, never by 'shapeRef', so that
-- the result doesn't depend on the order field names happened to be interned.
instance Eq RecordShape where
  RecordShape
s1 == :: RecordShape -> RecordShape -> Bool
== RecordShape
s2 = RecordShape -> Vector FieldName
shapeFields RecordShape
s1 Vector FieldName -> Vector FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== RecordShape -> Vector FieldName
shapeFields RecordShape
s2

instance Ord RecordShape where
  compare :: RecordShape -> RecordShape -> Ordering
compare RecordShape
s1 RecordShape
s2 = Vector FieldName -> Vector FieldName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RecordShape -> Vector FieldName
shapeFields RecordShape
s1) (RecordShape -> Vector FieldName
shapeFields RecordShape
s2)

-- | Build the shape for a record schema from already-interned field names.
-- Returns Nothing if any of them is unknown, which shouldn't happen for a
-- schema that is itself already interned.
recordShapeFrom ::
  RecordFieldMappings ->
  ANF.RecordRef ->
  ANF.RecordSchema ->
  Maybe RecordShape
recordShapeFrom :: RecordFieldMappings
-> RecordRef -> RecordSchema -> Maybe RecordShape
recordShapeFrom (RecordFieldMappings FieldRef
_ BiMap FieldName FieldRef
m) RecordRef
ref (ANF.RecordSchema Set FieldName
fields) = do
  let names :: Vector FieldName
names = [FieldName] -> Vector FieldName
forall a. [a] -> Vector a
V.fromList (Set FieldName -> [FieldName]
forall a. Set a -> [a]
Set.toAscList Set FieldName
fields)
  Vector FieldRef
refs <- (FieldName -> Maybe FieldRef)
-> Vector FieldName -> Maybe (Vector FieldRef)
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) -> Vector a -> f (Vector b)
traverse (\FieldName
n -> FieldName -> BiMap FieldName FieldRef -> Maybe FieldRef
forall k v. Ord k => k -> BiMap k v -> Maybe v
BiMap.lookupL FieldName
n BiMap FieldName FieldRef
m) Vector FieldName
names
  pure (RecordRef -> Vector FieldName -> [FieldRef] -> RecordShape
mkRecordShape RecordRef
ref Vector FieldName
names (Vector FieldRef -> [FieldRef]
forall a. Vector a -> [a]
V.toList Vector FieldRef
refs))

-- | Build the shape for a record schema, assigning a 'FieldRef' to any field
-- name not yet seen.
recordShape ::
  (MonadState RecordFieldMappings m) =>
  ANF.RecordRef ->
  ANF.RecordSchema ->
  m RecordShape
recordShape :: forall (m :: * -> *).
MonadState RecordFieldMappings m =>
RecordRef -> RecordSchema -> m RecordShape
recordShape RecordRef
ref (ANF.RecordSchema Set FieldName
fields) = do
  let names :: Vector FieldName
names = [FieldName] -> Vector FieldName
forall a. [a] -> Vector a
V.fromList (Set FieldName -> [FieldName]
forall a. Set a -> [a]
Set.toAscList Set FieldName
fields)
  Vector FieldRef
refs <- Vector FieldName -> m (Vector FieldRef)
forall (m :: * -> *) (f :: * -> *).
(MonadState RecordFieldMappings m, Traversable f) =>
f FieldName -> m (f FieldRef)
convertFieldNamesToRefs Vector FieldName
names
  pure (RecordRef -> Vector FieldName -> [FieldRef] -> RecordShape
mkRecordShape RecordRef
ref Vector FieldName
names (Vector FieldRef -> [FieldRef]
forall a. Vector a -> [a]
V.toList Vector FieldRef
refs))

argsToLists :: Args -> [Int]
argsToLists :: Args -> [Int]
argsToLists = \case
  Args
ZArgs -> []
  VArg1 Int
i -> [Int
i]
  VArg2 Int
i Int
j -> [Int
i, Int
j]
  VArgR Int
i Int
l -> Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
l [Int
i ..]
  VArgN PrimArray Int
us -> PrimArray Int -> [Int]
forall a. Prim a => PrimArray a -> [a]
primArrayToList PrimArray Int
us
  VArgV Int
_ -> [Word] -> [Char] -> [Int]
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"argsToLists: DArgV"
{-# INLINEABLE argsToLists #-}

countArgs :: Args -> Int
countArgs :: Args -> Int
countArgs Args
ZArgs = Int
0
countArgs (VArg1 {}) = Int
1
countArgs (VArg2 {}) = Int
2
countArgs (VArgR Int
_ Int
l) = Int
l
countArgs (VArgN PrimArray Int
us) = PrimArray Int -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Int
us
countArgs (VArgV {}) = [Word] -> [Char] -> Int
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"countArgs: DArgV"
{-# INLINEABLE countArgs #-}

-- The first six constructors are the ones the interpreter dispatches on
-- most (measured 2026-10-15; "Layouts" in JIT/design.md): GHC
-- gives a type's first six constructors their own pointer tags, and a case
-- on any later one reads the info table. Nothing serializes or orders by
-- this order; the Tag instances are explicit.
data Prim1
  = VWLS -- viewl
  | VWRS -- viewr
  | SIZS -- size
  | SIZT -- size
  | UCNS -- uncons
  | REFR -- Ref.read
  | -- integral
    DECI -- decrement
  | DECN
  | INCI -- increment
  | INCN
  | NEGI -- negate
  | SGNI -- signum
  | LZRO -- leadingZeroes
  | TZRO -- trailingZeroes
  | COMN -- complement
  | COMI -- complement
  | POPC -- popCount
  -- floating
  | ABSF -- abs
  | EXPF -- exp
  | LOGF -- log
  | SQRT -- sqrt
  | COSF -- cos
  | ACOS -- acos
  | COSH -- cosh
  | ACSH -- acosh
  | SINF -- sin
  | ASIN -- asin
  | SINH -- sinh
  | ASNH -- asinh
  | TANF -- tan
  | ATAN -- atan
  | TANH -- tanh
  | ATNH -- atanh
  | ITOF -- intToFloat
  | NTOF -- natToFloat
  | CEIL -- ceiling
  | FLOR -- floor
  | TRNF -- truncate
  | RNDF -- round
  | TRNC -- truncate
  -- Bools
  | NOTB -- not
  -- text
  | USNC -- unsnoc
  | ITOT -- intToText
  | NTOT -- natToText
  | FTOT -- floatToText
  | TTOI -- textToInt
  | TTON -- textToNat
  | TTOF -- textToFloat
  | PAKT -- pack
  | UPKT -- unpack
  -- sequence
  | PAKB -- pack
  | UPKB -- unpack
  | SIZB -- size
  | FLTB -- flatten
  -- code
  | MISS -- isMissing
  | CACH -- cache
  | LKUP -- lookup
  | LOAD -- load
  | CVLD -- validate
  | VALU -- value
  | TLTT --  Term.Link.toText
  -- debug
  | DBTX -- debug text
  | SDBL -- sandbox link list
  | -- Refs
    REFN -- Ref.new
  | RRFC
  | TIKR
  deriving (Int -> Prim1 -> ShowS
[Prim1] -> ShowS
Prim1 -> [Char]
(Int -> Prim1 -> ShowS)
-> (Prim1 -> [Char]) -> ([Prim1] -> ShowS) -> Show Prim1
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Prim1 -> ShowS
showsPrec :: Int -> Prim1 -> ShowS
$cshow :: Prim1 -> [Char]
show :: Prim1 -> [Char]
$cshowList :: [Prim1] -> ShowS
showList :: [Prim1] -> ShowS
Show, Prim1 -> Prim1 -> Bool
(Prim1 -> Prim1 -> Bool) -> (Prim1 -> Prim1 -> Bool) -> Eq Prim1
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Prim1 -> Prim1 -> Bool
== :: Prim1 -> Prim1 -> Bool
$c/= :: Prim1 -> Prim1 -> Bool
/= :: Prim1 -> Prim1 -> Bool
Eq, Eq Prim1
Eq Prim1 =>
(Prim1 -> Prim1 -> Ordering)
-> (Prim1 -> Prim1 -> Bool)
-> (Prim1 -> Prim1 -> Bool)
-> (Prim1 -> Prim1 -> Bool)
-> (Prim1 -> Prim1 -> Bool)
-> (Prim1 -> Prim1 -> Prim1)
-> (Prim1 -> Prim1 -> Prim1)
-> Ord Prim1
Prim1 -> Prim1 -> Bool
Prim1 -> Prim1 -> Ordering
Prim1 -> Prim1 -> Prim1
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 :: Prim1 -> Prim1 -> Ordering
compare :: Prim1 -> Prim1 -> Ordering
$c< :: Prim1 -> Prim1 -> Bool
< :: Prim1 -> Prim1 -> Bool
$c<= :: Prim1 -> Prim1 -> Bool
<= :: Prim1 -> Prim1 -> Bool
$c> :: Prim1 -> Prim1 -> Bool
> :: Prim1 -> Prim1 -> Bool
$c>= :: Prim1 -> Prim1 -> Bool
>= :: Prim1 -> Prim1 -> Bool
$cmax :: Prim1 -> Prim1 -> Prim1
max :: Prim1 -> Prim1 -> Prim1
$cmin :: Prim1 -> Prim1 -> Prim1
min :: Prim1 -> Prim1 -> Prim1
Ord, Int -> Prim1
Prim1 -> Int
Prim1 -> [Prim1]
Prim1 -> Prim1
Prim1 -> Prim1 -> [Prim1]
Prim1 -> Prim1 -> Prim1 -> [Prim1]
(Prim1 -> Prim1)
-> (Prim1 -> Prim1)
-> (Int -> Prim1)
-> (Prim1 -> Int)
-> (Prim1 -> [Prim1])
-> (Prim1 -> Prim1 -> [Prim1])
-> (Prim1 -> Prim1 -> [Prim1])
-> (Prim1 -> Prim1 -> Prim1 -> [Prim1])
-> Enum Prim1
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Prim1 -> Prim1
succ :: Prim1 -> Prim1
$cpred :: Prim1 -> Prim1
pred :: Prim1 -> Prim1
$ctoEnum :: Int -> Prim1
toEnum :: Int -> Prim1
$cfromEnum :: Prim1 -> Int
fromEnum :: Prim1 -> Int
$cenumFrom :: Prim1 -> [Prim1]
enumFrom :: Prim1 -> [Prim1]
$cenumFromThen :: Prim1 -> Prim1 -> [Prim1]
enumFromThen :: Prim1 -> Prim1 -> [Prim1]
$cenumFromTo :: Prim1 -> Prim1 -> [Prim1]
enumFromTo :: Prim1 -> Prim1 -> [Prim1]
$cenumFromThenTo :: Prim1 -> Prim1 -> Prim1 -> [Prim1]
enumFromThenTo :: Prim1 -> Prim1 -> Prim1 -> [Prim1]
Enum, Prim1
Prim1 -> Prim1 -> Bounded Prim1
forall a. a -> a -> Bounded a
$cminBound :: Prim1
minBound :: Prim1
$cmaxBound :: Prim1
maxBound :: Prim1
Bounded)

-- The first six constructors are the ones the interpreter dispatches on
-- most (measured 2026-10-15; "Layouts" in JIT/design.md): GHC
-- gives a type's first six constructors their own pointer tags, and a case
-- on any later one reads the info table. Nothing serializes or orders by
-- this order; the Tag instances are explicit.
data Prim2
  = ADDN
  | EQLN
  | LESN
  | DRPN -- dropn
  | LEQN
  | MULN
  | -- integral
    ADDI -- +
  | SUBI -- -
  | SUBN
  | MULI
  | DIVI -- /
  | DIVN
  | MODI -- mod
  | MODN
  | SHLI -- shiftl
  | SHLN
  | SHRI -- shiftr
  | SHRN
  | POWI -- pow
  | POWN
  | EQLI -- ==
  | NEQI -- !=
  | NEQN
  | LEQI -- <=
  | LESI -- <
  | ANDN -- and
  | ANDI
  | IORN -- or
  | IORI
  | XORN -- xor
  | XORI
  | -- floating
    EQLF -- ==
  | NEQF -- !=
  | LEQF -- <=
  | LESF -- <
  | ADDF -- +
  | SUBF -- -
  | MULF
  | DIVF -- /
  | ATN2 -- atan2
  | POWF -- pow
  | LOGB -- logBase
  | MAXF -- max
  | MINF -- min
  | CAST -- unboxed runtime type cast (int to nat, etc.)
  -- Bools
  | ANDB -- and
  | IORB -- or
  -- universal
  | EQLU -- ==
  | CMPU -- compare
  | LEQU -- <=
  | LESU -- <
  -- text
  | DRPT -- drop
  | CATT -- append
  | TAKT -- take
  | IXOT -- indexof
  | EQLT -- ==
  | LEQT -- <=
  | LEST -- <
  -- sequence
  | DRPS -- drop
  | CATS -- append
  | TAKS -- take
  | CONS -- cons
  | SNOC -- snoc
  | IDXS -- index
  | SPLL -- splitLeft
  | SPLR -- splitRight
  -- bytes
  | TAKB -- take
  | DRPB -- drop
  | IDXB -- index
  | CATB -- append
  | IXOB -- indexof
  -- general
  | THRO -- throw
  | TRCE -- trace
  -- code
  | SDBX -- sandbox
  | SDBV -- sandbox Value
  -- Refs
  | REFW -- Ref.write
  deriving (Int -> Prim2 -> ShowS
[Prim2] -> ShowS
Prim2 -> [Char]
(Int -> Prim2 -> ShowS)
-> (Prim2 -> [Char]) -> ([Prim2] -> ShowS) -> Show Prim2
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Prim2 -> ShowS
showsPrec :: Int -> Prim2 -> ShowS
$cshow :: Prim2 -> [Char]
show :: Prim2 -> [Char]
$cshowList :: [Prim2] -> ShowS
showList :: [Prim2] -> ShowS
Show, Prim2 -> Prim2 -> Bool
(Prim2 -> Prim2 -> Bool) -> (Prim2 -> Prim2 -> Bool) -> Eq Prim2
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Prim2 -> Prim2 -> Bool
== :: Prim2 -> Prim2 -> Bool
$c/= :: Prim2 -> Prim2 -> Bool
/= :: Prim2 -> Prim2 -> Bool
Eq, Eq Prim2
Eq Prim2 =>
(Prim2 -> Prim2 -> Ordering)
-> (Prim2 -> Prim2 -> Bool)
-> (Prim2 -> Prim2 -> Bool)
-> (Prim2 -> Prim2 -> Bool)
-> (Prim2 -> Prim2 -> Bool)
-> (Prim2 -> Prim2 -> Prim2)
-> (Prim2 -> Prim2 -> Prim2)
-> Ord Prim2
Prim2 -> Prim2 -> Bool
Prim2 -> Prim2 -> Ordering
Prim2 -> Prim2 -> Prim2
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 :: Prim2 -> Prim2 -> Ordering
compare :: Prim2 -> Prim2 -> Ordering
$c< :: Prim2 -> Prim2 -> Bool
< :: Prim2 -> Prim2 -> Bool
$c<= :: Prim2 -> Prim2 -> Bool
<= :: Prim2 -> Prim2 -> Bool
$c> :: Prim2 -> Prim2 -> Bool
> :: Prim2 -> Prim2 -> Bool
$c>= :: Prim2 -> Prim2 -> Bool
>= :: Prim2 -> Prim2 -> Bool
$cmax :: Prim2 -> Prim2 -> Prim2
max :: Prim2 -> Prim2 -> Prim2
$cmin :: Prim2 -> Prim2 -> Prim2
min :: Prim2 -> Prim2 -> Prim2
Ord, Int -> Prim2
Prim2 -> Int
Prim2 -> [Prim2]
Prim2 -> Prim2
Prim2 -> Prim2 -> [Prim2]
Prim2 -> Prim2 -> Prim2 -> [Prim2]
(Prim2 -> Prim2)
-> (Prim2 -> Prim2)
-> (Int -> Prim2)
-> (Prim2 -> Int)
-> (Prim2 -> [Prim2])
-> (Prim2 -> Prim2 -> [Prim2])
-> (Prim2 -> Prim2 -> [Prim2])
-> (Prim2 -> Prim2 -> Prim2 -> [Prim2])
-> Enum Prim2
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Prim2 -> Prim2
succ :: Prim2 -> Prim2
$cpred :: Prim2 -> Prim2
pred :: Prim2 -> Prim2
$ctoEnum :: Int -> Prim2
toEnum :: Int -> Prim2
$cfromEnum :: Prim2 -> Int
fromEnum :: Prim2 -> Int
$cenumFrom :: Prim2 -> [Prim2]
enumFrom :: Prim2 -> [Prim2]
$cenumFromThen :: Prim2 -> Prim2 -> [Prim2]
enumFromThen :: Prim2 -> Prim2 -> [Prim2]
$cenumFromTo :: Prim2 -> Prim2 -> [Prim2]
enumFromTo :: Prim2 -> Prim2 -> [Prim2]
$cenumFromThenTo :: Prim2 -> Prim2 -> Prim2 -> [Prim2]
enumFromThenTo :: Prim2 -> Prim2 -> Prim2 -> [Prim2]
Enum, Prim2
Prim2 -> Prim2 -> Bounded Prim2
forall a. a -> a -> Bounded a
$cminBound :: Prim2
minBound :: Prim2
$cmaxBound :: Prim2
maxBound :: Prim2
Bounded)

data MLit
  = MI !Int
  | MN !Word64
  | MC !Char
  | MD !Double
  | MT !Text
  | MM !Referent -- Term Link
  | MY !Reference -- Type Link
  deriving (Int -> MLit -> ShowS
[MLit] -> ShowS
MLit -> [Char]
(Int -> MLit -> ShowS)
-> (MLit -> [Char]) -> ([MLit] -> ShowS) -> Show MLit
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MLit -> ShowS
showsPrec :: Int -> MLit -> ShowS
$cshow :: MLit -> [Char]
show :: MLit -> [Char]
$cshowList :: [MLit] -> ShowS
showList :: [MLit] -> ShowS
Show, MLit -> MLit -> Bool
(MLit -> MLit -> Bool) -> (MLit -> MLit -> Bool) -> Eq MLit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MLit -> MLit -> Bool
== :: MLit -> MLit -> Bool
$c/= :: MLit -> MLit -> Bool
/= :: MLit -> MLit -> Bool
Eq, Eq MLit
Eq MLit =>
(MLit -> MLit -> Ordering)
-> (MLit -> MLit -> Bool)
-> (MLit -> MLit -> Bool)
-> (MLit -> MLit -> Bool)
-> (MLit -> MLit -> Bool)
-> (MLit -> MLit -> MLit)
-> (MLit -> MLit -> MLit)
-> Ord MLit
MLit -> MLit -> Bool
MLit -> MLit -> Ordering
MLit -> MLit -> MLit
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 :: MLit -> MLit -> Ordering
compare :: MLit -> MLit -> Ordering
$c< :: MLit -> MLit -> Bool
< :: MLit -> MLit -> Bool
$c<= :: MLit -> MLit -> Bool
<= :: MLit -> MLit -> Bool
$c> :: MLit -> MLit -> Bool
> :: MLit -> MLit -> Bool
$c>= :: MLit -> MLit -> Bool
>= :: MLit -> MLit -> Bool
$cmax :: MLit -> MLit -> MLit
max :: MLit -> MLit -> MLit
$cmin :: MLit -> MLit -> MLit
min :: MLit -> MLit -> MLit
Ord)

type Instr = GInstr CombIx

type RInstr val = GInstr (RComb val)

-- Instructions for manipulating the data stack in the main portion of
-- a block
-- The first six constructors are the ones the interpreter dispatches on
-- most (measured 2026-10-15; "Layouts" in JIT/design.md): GHC
-- gives a type's first six constructors their own pointer tags, and a case
-- on any later one reads the info table. Nothing serializes or orders by
-- this order; the Tag instances are explicit.
data GInstr comb
  = -- 2-argument unboxed primitive operations
    Prim2
      !Prim2 -- primitive instruction
      !Int -- index of first prim argument
      !Int -- index of second prim argument
  | -- Push a particular value onto the appropriate stack
    Lit !MLit -- value to push onto the stack
  | -- 1-argument primitive operations
    Prim1
      !Prim1 -- primitive instruction
      !Int -- index of prim argument
  | -- Call out to a Haskell function.
    ForeignCall
      !Bool -- catch exceptions
      !ForeignFunc -- FFI call
      !Args -- arguments
  | -- Pack a data type value into a closure and place it
    -- on the stack.
    Pack
      !PackedTag -- tag: the type's number and the constructor's
      !Args -- arguments to pack
  | -- This is essentially the opposite of `Call`. Pack a given
    -- statically known function into a closure with arguments.
    -- No stack is necessary, because no nested evaluation happens,
    -- so the instruction directly takes a follow-up.
    Name !(GRef comb) !Args
  | -- Use a check-and-set ticket to update a reference
    -- (ref stack index, ticket stack index, new value stack index)
    RefCAS !Int !Int !Int
  | -- Call a dynamically loaded function. The vacuous form of this
    -- instruction is due to the very limited circumstances it can be
    -- called in. Foreign DLL functions are only loaded at runtime, so
    -- never inlined. This means that this instruction always occurs in
    -- the special form produced by the loading function. The entire
    -- body of the closure is `Ins DLLCall (Yield $ VArg1 0)`, and the
    -- arguments to the closure are the loaded DLL function followed by
    -- all its arguments. The function knows how many arguments it
    -- takes, so we don't need to store that information here.
    DLLCall
  | -- Set the value of an affine reference. Note that references are
    -- shared for the prompts of simultaneously installed affine
    -- handlers, so setting one sets all.
    --
    -- Also note: this corresponds to the `handle` part of a recursive
    -- handler, meaning the handler would normally be put back on the
    -- stack. So, this adds itself back to the current affine
    -- environment unless a flag indicates that it's unnecessary.
    SetAff
      !Bool -- is the env update necessary
      !Int -- stack index of the affine handler information
      !Int -- the stack index of the closure to store
  | -- Capture the continuation up to a given marker.
    Capture !Word64 -- the prompt tag
  | -- Discard the continuation up to a given marker.
    Discard !Int -- the index of the affine handler info
  | -- Dump some debugging information about the machine state to
    -- the screen.
    Info !String -- prefix for output
  | -- Write a small data constructor as a wide variable
    -- (Unison.Runtime.Wide): 'wideWidth' new slots, the value slot on top
    -- holding the packed tag and the witness of the field count, the
    -- fields in the slots below. Nothing is allocated.
    PackWide
      !PackedTag
      -- whether to write the slots at the frame's base as the frame's
      -- only slots, for a constructor in tail position: the Yield of
      -- exactly those slots that follows then moves nothing
      !Bool
      -- fields, at most 'wideK'
      !Args
  | -- Box a wide variable in place: when its value slot holds a witness,
    -- the heap object built from it and the field slots replaces it, so
    -- the slot holds an ordinary value from here on and the frame keeps
    -- its layout. Emitted where a wide variable escapes.
    Box
      -- the variable's value slot
      !Int
  | -- Pack a record type into a closure and place it on the stack.
    -- The args arrive in ascending field-name order, matching the shape's
    -- slot order.
    RecPack
      !RecordShape
      -- values to pack
      !Args
  | -- Unpack a set of fields from a record on the boxed stack.
    -- It may be a subset of the record's fields, so the slot each one sits in
    -- is read from the shape carried by the value rather than baked in here:
    -- one pattern can match records of several different shapes, in which a
    -- given field sits at a different slot.
    RecUnpack
      !(Vector FieldRef {- fields to unpack -})
      !Int {- index of record on boxed stack -}
  | -- Replace one field of a record on the boxed stack with a new value,
    -- keeping the record's own field set (and so its shape).
    --
    -- `args` is the record and its new value. As with 'RecUnpack' the slot the
    -- field sits in is read from the *value's* shape, so the same code works
    -- for records built at any construction site.
    RecSet
      !FieldRef {- field to replace -}
      !Args {- the record and the new value -}
  | -- Print a value on the unboxed stack
    Print !Int -- index of the primitive value to print
  | -- Put a delimiter and initial handler on the continuation.
    -- If the context is affine, and there is an affine handler
    -- available, it will be used. Otherwise the non-affine handler
    -- will be used.
    Reset
      !(EnumSet Word64) -- prompt ids
      !Int -- stack index of associated non-affine closure
      !(Maybe Int) -- stack index of affine closure
  | -- Push the local context of an affine handler into the continuation
    InLocal
      !Int -- stack index of the affine handler information
  | -- Fork thread evaluating delayed computation on boxed stack
    Fork !Int
  | -- Atomic transaction evaluating delayed computation on boxed stack
    Atomically !Int
  | -- Build a sequence consisting of a variable number of arguments
    Seq !Args
  | -- Force a delayed expression, catching any runtime exceptions involved
    TryForce !Int
  | -- Attempted to use a builtin that was not allowed in the current sandboxing context.
    SandboxingFailure !Text.Text -- The name of the builtin which failed was sandboxed.
  | -- keep a value alive while subsequent computations are run
    KeepAlive !Int
  | -- create a new foreign pointer with a unison finalizer
    NewForeignPtr
      !Int -- finalizer index
      !Int -- pointer index
  | -- add a unison finalizer to a foreign pointer
    AddFinalizer
      !Int -- foreign pointer index
      !Int -- finalizer index
  | -- build a C-callable function pointer from a Unison function
    MkCallback
      !Int -- FFI spec index
      !Int -- Unison function index
  deriving stock (Int -> GInstr comb -> ShowS
[GInstr comb] -> ShowS
GInstr comb -> [Char]
(Int -> GInstr comb -> ShowS)
-> (GInstr comb -> [Char])
-> ([GInstr comb] -> ShowS)
-> Show (GInstr comb)
forall comb. Show comb => Int -> GInstr comb -> ShowS
forall comb. Show comb => [GInstr comb] -> ShowS
forall comb. Show comb => GInstr comb -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall comb. Show comb => Int -> GInstr comb -> ShowS
showsPrec :: Int -> GInstr comb -> ShowS
$cshow :: forall comb. Show comb => GInstr comb -> [Char]
show :: GInstr comb -> [Char]
$cshowList :: forall comb. Show comb => [GInstr comb] -> ShowS
showList :: [GInstr comb] -> ShowS
Show, GInstr comb -> GInstr comb -> Bool
(GInstr comb -> GInstr comb -> Bool)
-> (GInstr comb -> GInstr comb -> Bool) -> Eq (GInstr comb)
forall comb. GInstr comb -> GInstr comb -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall comb. GInstr comb -> GInstr comb -> Bool
== :: GInstr comb -> GInstr comb -> Bool
$c/= :: forall comb. GInstr comb -> GInstr comb -> Bool
/= :: GInstr comb -> GInstr comb -> Bool
Eq, Eq (GInstr comb)
Eq (GInstr comb) =>
(GInstr comb -> GInstr comb -> Ordering)
-> (GInstr comb -> GInstr comb -> Bool)
-> (GInstr comb -> GInstr comb -> Bool)
-> (GInstr comb -> GInstr comb -> Bool)
-> (GInstr comb -> GInstr comb -> Bool)
-> (GInstr comb -> GInstr comb -> GInstr comb)
-> (GInstr comb -> GInstr comb -> GInstr comb)
-> Ord (GInstr comb)
GInstr comb -> GInstr comb -> Bool
GInstr comb -> GInstr comb -> Ordering
GInstr comb -> GInstr comb -> GInstr comb
forall comb. Eq (GInstr comb)
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
forall comb. GInstr comb -> GInstr comb -> Bool
forall comb. GInstr comb -> GInstr comb -> Ordering
forall comb. GInstr comb -> GInstr comb -> GInstr comb
$ccompare :: forall comb. GInstr comb -> GInstr comb -> Ordering
compare :: GInstr comb -> GInstr comb -> Ordering
$c< :: forall comb. GInstr comb -> GInstr comb -> Bool
< :: GInstr comb -> GInstr comb -> Bool
$c<= :: forall comb. GInstr comb -> GInstr comb -> Bool
<= :: GInstr comb -> GInstr comb -> Bool
$c> :: forall comb. GInstr comb -> GInstr comb -> Bool
> :: GInstr comb -> GInstr comb -> Bool
$c>= :: forall comb. GInstr comb -> GInstr comb -> Bool
>= :: GInstr comb -> GInstr comb -> Bool
$cmax :: forall comb. GInstr comb -> GInstr comb -> GInstr comb
max :: GInstr comb -> GInstr comb -> GInstr comb
$cmin :: forall comb. GInstr comb -> GInstr comb -> GInstr comb
min :: GInstr comb -> GInstr comb -> GInstr comb
Ord, (forall a b. (a -> b) -> GInstr a -> GInstr b)
-> (forall a b. a -> GInstr b -> GInstr a) -> Functor GInstr
forall a b. a -> GInstr b -> GInstr a
forall a b. (a -> b) -> GInstr a -> GInstr b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> GInstr a -> GInstr b
fmap :: forall a b. (a -> b) -> GInstr a -> GInstr b
$c<$ :: forall a b. a -> GInstr b -> GInstr a
<$ :: forall a b. a -> GInstr b -> GInstr a
Functor, (forall m. Monoid m => GInstr m -> m)
-> (forall m a. Monoid m => (a -> m) -> GInstr a -> m)
-> (forall m a. Monoid m => (a -> m) -> GInstr a -> m)
-> (forall a b. (a -> b -> b) -> b -> GInstr a -> b)
-> (forall a b. (a -> b -> b) -> b -> GInstr a -> b)
-> (forall b a. (b -> a -> b) -> b -> GInstr a -> b)
-> (forall b a. (b -> a -> b) -> b -> GInstr a -> b)
-> (forall a. (a -> a -> a) -> GInstr a -> a)
-> (forall a. (a -> a -> a) -> GInstr a -> a)
-> (forall a. GInstr a -> [a])
-> (forall a. GInstr a -> Bool)
-> (forall a. GInstr a -> Int)
-> (forall a. Eq a => a -> GInstr a -> Bool)
-> (forall a. Ord a => GInstr a -> a)
-> (forall a. Ord a => GInstr a -> a)
-> (forall a. Num a => GInstr a -> a)
-> (forall a. Num a => GInstr a -> a)
-> Foldable GInstr
forall a. Eq a => a -> GInstr a -> Bool
forall a. Num a => GInstr a -> a
forall a. Ord a => GInstr a -> a
forall m. Monoid m => GInstr m -> m
forall a. GInstr a -> Bool
forall a. GInstr a -> Int
forall a. GInstr a -> [a]
forall a. (a -> a -> a) -> GInstr a -> a
forall m a. Monoid m => (a -> m) -> GInstr a -> m
forall b a. (b -> a -> b) -> b -> GInstr a -> b
forall a b. (a -> b -> b) -> b -> GInstr a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => GInstr m -> m
fold :: forall m. Monoid m => GInstr m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> GInstr a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> GInstr a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> GInstr a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> GInstr a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> GInstr a -> b
foldr :: forall a b. (a -> b -> b) -> b -> GInstr a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> GInstr a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> GInstr a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> GInstr a -> b
foldl :: forall b a. (b -> a -> b) -> b -> GInstr a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> GInstr a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> GInstr a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> GInstr a -> a
foldr1 :: forall a. (a -> a -> a) -> GInstr a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> GInstr a -> a
foldl1 :: forall a. (a -> a -> a) -> GInstr a -> a
$ctoList :: forall a. GInstr a -> [a]
toList :: forall a. GInstr a -> [a]
$cnull :: forall a. GInstr a -> Bool
null :: forall a. GInstr a -> Bool
$clength :: forall a. GInstr a -> Int
length :: forall a. GInstr a -> Int
$celem :: forall a. Eq a => a -> GInstr a -> Bool
elem :: forall a. Eq a => a -> GInstr a -> Bool
$cmaximum :: forall a. Ord a => GInstr a -> a
maximum :: forall a. Ord a => GInstr a -> a
$cminimum :: forall a. Ord a => GInstr a -> a
minimum :: forall a. Ord a => GInstr a -> a
$csum :: forall a. Num a => GInstr a -> a
sum :: forall a. Num a => GInstr a -> a
$cproduct :: forall a. Num a => GInstr a -> a
product :: forall a. Num a => GInstr a -> a
Foldable, Functor GInstr
Foldable GInstr
(Functor GInstr, Foldable GInstr) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> GInstr a -> f (GInstr b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    GInstr (f a) -> f (GInstr a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> GInstr a -> m (GInstr b))
-> (forall (m :: * -> *) a.
    Monad m =>
    GInstr (m a) -> m (GInstr a))
-> Traversable GInstr
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => GInstr (m a) -> m (GInstr a)
forall (f :: * -> *) a.
Applicative f =>
GInstr (f a) -> f (GInstr a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GInstr a -> m (GInstr b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GInstr a -> f (GInstr b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GInstr a -> f (GInstr b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GInstr a -> f (GInstr b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
GInstr (f a) -> f (GInstr a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
GInstr (f a) -> f (GInstr a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GInstr a -> m (GInstr b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GInstr a -> m (GInstr b)
$csequence :: forall (m :: * -> *) a. Monad m => GInstr (m a) -> m (GInstr a)
sequence :: forall (m :: * -> *) a. Monad m => GInstr (m a) -> m (GInstr a)
Traversable)

type Section = GSection CombIx

type RSection val = GSection (RComb val)

-- The first six constructors are the ones the interpreter dispatches on
-- most (measured 2026-10-15; "Layouts" in JIT/design.md): GHC
-- gives a type's first six constructors their own pointer tags, and a case
-- on any later one reads the info table. Nothing serializes or orders by
-- this order; the Tag instances are explicit.
data GSection comb
  = -- Prefix an instruction onto a section
    Ins !(GInstr comb) !(GSection comb)
  | -- This is the 'fast path', for when we statically know we're
    -- making an exactly saturated call to a statically known
    -- function. This allows skipping various checks that can cost
    -- time in very tight loops. This also allows skipping the
    -- stack check if we know that the current stack allowance is
    -- sufficient for where we're jumping to.
    Call
      !Bool -- skip stack check
      !CombIx
      {- Lazy! Might be cyclic -} comb
      !Args -- arguments
  | -- Branch on a data type without dumping the tag onto the unboxed
    -- stack.
    DMatch
      !(Maybe Reference) -- expected data type
      !Int -- index of data item on boxed stack
      !(GBranch comb) -- branches, each arm with the field count it binds
  | -- Sequence two sections. The second is pushed as a return
    -- point for the results of the first. Stack modifications in
    -- the first are lost on return to the second.
    --
    -- The stored CombIx is a combinator that contains the second
    -- section, which can be used to reconstruct structures that
    -- throw away the section, like serializable continuation values.
    -- Code generation will emit the section as its own combinator,
    -- but also include it directly here.
    Let
      !(GSection comb) -- binding
      !CombIx -- body section refrence
      !Int -- stack safety
      !(GSection comb) -- body code
      !(Ptr NativeCell) -- native code cell of the body's combinator (the re-entry point)
  | -- Yield control to the current continuation, with arguments
    Yield !Args -- values to yield
  | -- Apply a function to arguments. This is the 'slow path', and
    -- handles applying functions from arbitrary sources. This
    -- requires checks to determine what exactly should happen.
    App
      !Bool -- skip argument check for known calling convention
      !(GRef comb) -- function to call
      !Args -- arguments
  | -- Jump to a captured continuation value.
    Jump
      !Int -- index of captured continuation
      !Args -- arguments to send to continuation
  | -- Branch on the value in the unboxed data stack
    Match
      !Int -- index of unboxed item to match on
      !(GBranch comb) -- branches
  | -- Throw an exception with the given message
    Die String
  | -- Immediately stop a thread of interpretation. This is more of
    -- a debugging tool than a proper operation to target.
    Exit
  | -- Branch on a numeric type without dumping it to the stack
    NMatch
      !(Maybe Reference) -- expected data type
      !Int -- index of data item on boxed stack
      !(GBranch comb) -- branches
  | -- Branch on a request representation without dumping the tag
    -- portion to the unboxed stack.
    RMatch
      !Int -- index of request item on the boxed stack
      !(GSection comb) -- pure case
      !(EnumMap Word64 (GBranch comb)) -- effect cases, by ability number
  deriving stock (Int -> GSection comb -> ShowS
[GSection comb] -> ShowS
GSection comb -> [Char]
(Int -> GSection comb -> ShowS)
-> (GSection comb -> [Char])
-> ([GSection comb] -> ShowS)
-> Show (GSection comb)
forall comb. Show comb => Int -> GSection comb -> ShowS
forall comb. Show comb => [GSection comb] -> ShowS
forall comb. Show comb => GSection comb -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall comb. Show comb => Int -> GSection comb -> ShowS
showsPrec :: Int -> GSection comb -> ShowS
$cshow :: forall comb. Show comb => GSection comb -> [Char]
show :: GSection comb -> [Char]
$cshowList :: forall comb. Show comb => [GSection comb] -> ShowS
showList :: [GSection comb] -> ShowS
Show, GSection comb -> GSection comb -> Bool
(GSection comb -> GSection comb -> Bool)
-> (GSection comb -> GSection comb -> Bool) -> Eq (GSection comb)
forall comb. Eq comb => GSection comb -> GSection comb -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall comb. Eq comb => GSection comb -> GSection comb -> Bool
== :: GSection comb -> GSection comb -> Bool
$c/= :: forall comb. Eq comb => GSection comb -> GSection comb -> Bool
/= :: GSection comb -> GSection comb -> Bool
Eq, Eq (GSection comb)
Eq (GSection comb) =>
(GSection comb -> GSection comb -> Ordering)
-> (GSection comb -> GSection comb -> Bool)
-> (GSection comb -> GSection comb -> Bool)
-> (GSection comb -> GSection comb -> Bool)
-> (GSection comb -> GSection comb -> Bool)
-> (GSection comb -> GSection comb -> GSection comb)
-> (GSection comb -> GSection comb -> GSection comb)
-> Ord (GSection comb)
GSection comb -> GSection comb -> Bool
GSection comb -> GSection comb -> Ordering
GSection comb -> GSection comb -> GSection comb
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
forall comb. Ord comb => Eq (GSection comb)
forall comb. Ord comb => GSection comb -> GSection comb -> Bool
forall comb. Ord comb => GSection comb -> GSection comb -> Ordering
forall comb.
Ord comb =>
GSection comb -> GSection comb -> GSection comb
$ccompare :: forall comb. Ord comb => GSection comb -> GSection comb -> Ordering
compare :: GSection comb -> GSection comb -> Ordering
$c< :: forall comb. Ord comb => GSection comb -> GSection comb -> Bool
< :: GSection comb -> GSection comb -> Bool
$c<= :: forall comb. Ord comb => GSection comb -> GSection comb -> Bool
<= :: GSection comb -> GSection comb -> Bool
$c> :: forall comb. Ord comb => GSection comb -> GSection comb -> Bool
> :: GSection comb -> GSection comb -> Bool
$c>= :: forall comb. Ord comb => GSection comb -> GSection comb -> Bool
>= :: GSection comb -> GSection comb -> Bool
$cmax :: forall comb.
Ord comb =>
GSection comb -> GSection comb -> GSection comb
max :: GSection comb -> GSection comb -> GSection comb
$cmin :: forall comb.
Ord comb =>
GSection comb -> GSection comb -> GSection comb
min :: GSection comb -> GSection comb -> GSection comb
Ord, (forall a b. (a -> b) -> GSection a -> GSection b)
-> (forall a b. a -> GSection b -> GSection a) -> Functor GSection
forall a b. a -> GSection b -> GSection a
forall a b. (a -> b) -> GSection a -> GSection b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> GSection a -> GSection b
fmap :: forall a b. (a -> b) -> GSection a -> GSection b
$c<$ :: forall a b. a -> GSection b -> GSection a
<$ :: forall a b. a -> GSection b -> GSection a
Functor, (forall m. Monoid m => GSection m -> m)
-> (forall m a. Monoid m => (a -> m) -> GSection a -> m)
-> (forall m a. Monoid m => (a -> m) -> GSection a -> m)
-> (forall a b. (a -> b -> b) -> b -> GSection a -> b)
-> (forall a b. (a -> b -> b) -> b -> GSection a -> b)
-> (forall b a. (b -> a -> b) -> b -> GSection a -> b)
-> (forall b a. (b -> a -> b) -> b -> GSection a -> b)
-> (forall a. (a -> a -> a) -> GSection a -> a)
-> (forall a. (a -> a -> a) -> GSection a -> a)
-> (forall a. GSection a -> [a])
-> (forall a. GSection a -> Bool)
-> (forall a. GSection a -> Int)
-> (forall a. Eq a => a -> GSection a -> Bool)
-> (forall a. Ord a => GSection a -> a)
-> (forall a. Ord a => GSection a -> a)
-> (forall a. Num a => GSection a -> a)
-> (forall a. Num a => GSection a -> a)
-> Foldable GSection
forall a. Eq a => a -> GSection a -> Bool
forall a. Num a => GSection a -> a
forall a. Ord a => GSection a -> a
forall m. Monoid m => GSection m -> m
forall a. GSection a -> Bool
forall a. GSection a -> Int
forall a. GSection a -> [a]
forall a. (a -> a -> a) -> GSection a -> a
forall m a. Monoid m => (a -> m) -> GSection a -> m
forall b a. (b -> a -> b) -> b -> GSection a -> b
forall a b. (a -> b -> b) -> b -> GSection a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => GSection m -> m
fold :: forall m. Monoid m => GSection m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> GSection a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> GSection a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> GSection a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> GSection a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> GSection a -> b
foldr :: forall a b. (a -> b -> b) -> b -> GSection a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> GSection a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> GSection a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> GSection a -> b
foldl :: forall b a. (b -> a -> b) -> b -> GSection a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> GSection a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> GSection a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> GSection a -> a
foldr1 :: forall a. (a -> a -> a) -> GSection a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> GSection a -> a
foldl1 :: forall a. (a -> a -> a) -> GSection a -> a
$ctoList :: forall a. GSection a -> [a]
toList :: forall a. GSection a -> [a]
$cnull :: forall a. GSection a -> Bool
null :: forall a. GSection a -> Bool
$clength :: forall a. GSection a -> Int
length :: forall a. GSection a -> Int
$celem :: forall a. Eq a => a -> GSection a -> Bool
elem :: forall a. Eq a => a -> GSection a -> Bool
$cmaximum :: forall a. Ord a => GSection a -> a
maximum :: forall a. Ord a => GSection a -> a
$cminimum :: forall a. Ord a => GSection a -> a
minimum :: forall a. Ord a => GSection a -> a
$csum :: forall a. Num a => GSection a -> a
sum :: forall a. Num a => GSection a -> a
$cproduct :: forall a. Num a => GSection a -> a
product :: forall a. Num a => GSection a -> a
Foldable, Functor GSection
Foldable GSection
(Functor GSection, Foldable GSection) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> GSection a -> f (GSection b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    GSection (f a) -> f (GSection a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> GSection a -> m (GSection b))
-> (forall (m :: * -> *) a.
    Monad m =>
    GSection (m a) -> m (GSection a))
-> Traversable GSection
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => GSection (m a) -> m (GSection a)
forall (f :: * -> *) a.
Applicative f =>
GSection (f a) -> f (GSection a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GSection a -> m (GSection b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GSection a -> f (GSection b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GSection a -> f (GSection b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GSection a -> f (GSection b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
GSection (f a) -> f (GSection a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
GSection (f a) -> f (GSection a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GSection a -> m (GSection b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GSection a -> m (GSection b)
$csequence :: forall (m :: * -> *) a. Monad m => GSection (m a) -> m (GSection a)
sequence :: forall (m :: * -> *) a. Monad m => GSection (m a) -> m (GSection a)
Traversable)

data CombIx
  = CIx
      !Reference -- top reference
      !Word64 -- top level
      !Word64 -- section
  deriving (CombIx -> CombIx -> Bool
(CombIx -> CombIx -> Bool)
-> (CombIx -> CombIx -> Bool) -> Eq CombIx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CombIx -> CombIx -> Bool
== :: CombIx -> CombIx -> Bool
$c/= :: CombIx -> CombIx -> Bool
/= :: CombIx -> CombIx -> Bool
Eq, Eq CombIx
Eq CombIx =>
(CombIx -> CombIx -> Ordering)
-> (CombIx -> CombIx -> Bool)
-> (CombIx -> CombIx -> Bool)
-> (CombIx -> CombIx -> Bool)
-> (CombIx -> CombIx -> Bool)
-> (CombIx -> CombIx -> CombIx)
-> (CombIx -> CombIx -> CombIx)
-> Ord CombIx
CombIx -> CombIx -> Bool
CombIx -> CombIx -> Ordering
CombIx -> CombIx -> CombIx
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 :: CombIx -> CombIx -> Ordering
compare :: CombIx -> CombIx -> Ordering
$c< :: CombIx -> CombIx -> Bool
< :: CombIx -> CombIx -> Bool
$c<= :: CombIx -> CombIx -> Bool
<= :: CombIx -> CombIx -> Bool
$c> :: CombIx -> CombIx -> Bool
> :: CombIx -> CombIx -> Bool
$c>= :: CombIx -> CombIx -> Bool
>= :: CombIx -> CombIx -> Bool
$cmax :: CombIx -> CombIx -> CombIx
max :: CombIx -> CombIx -> CombIx
$cmin :: CombIx -> CombIx -> CombIx
min :: CombIx -> CombIx -> CombIx
Ord, Int -> CombIx -> ShowS
[CombIx] -> ShowS
CombIx -> [Char]
(Int -> CombIx -> ShowS)
-> (CombIx -> [Char]) -> ([CombIx] -> ShowS) -> Show CombIx
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CombIx -> ShowS
showsPrec :: Int -> CombIx -> ShowS
$cshow :: CombIx -> [Char]
show :: CombIx -> [Char]
$cshowList :: [CombIx] -> ShowS
showList :: [CombIx] -> ShowS
Show)

combRef :: CombIx -> Reference
combRef :: CombIx -> Reference
combRef (CIx Reference
r Word64
_ Word64
_) = Reference
r

--
data RefNums = RN
  { -- maps type references to their number in the runtime
    RefNums -> Reference -> Word64
dnum :: Reference -> Word64,
    -- cnum maps combinator references to their number
    RefNums -> Reference -> Word64
cnum :: Reference -> Word64,
    -- anum maps combinator references to their main arity
    RefNums -> Reference -> Maybe Int
anum :: Reference -> Maybe Int,
    -- | the specialisations of a combinator of this batch
    -- (Unison.Runtime.MCode.Explode): its call patterns, in worker order
    RefNums -> Reference -> Maybe [Pattern]
explode :: Reference -> Maybe [Pattern],
    -- | the product a combinator of this batch returns on every path
    -- (Unison.Runtime.MCode.Explode): it has a product-return worker
    RefNums -> Reference -> Maybe Shape
retOf :: Reference -> Maybe Shape,
    -- Map record schemas into their runtime reference
    RefNums -> RecordSchema -> RecordRef
recNum :: ANF.RecordSchema -> ANF.RecordRef
  }

emptyRNs :: RefNums
emptyRNs :: RefNums
emptyRNs = (Reference -> Word64)
-> (Reference -> Word64)
-> (Reference -> Maybe Int)
-> (Reference -> Maybe [Pattern])
-> (Reference -> Maybe Shape)
-> (RecordSchema -> RecordRef)
-> RefNums
RN Reference -> Word64
forall {p} {a}. p -> a
mt Reference -> Word64
forall {p} {a}. p -> a
mt (Maybe Int -> Reference -> Maybe Int
forall a b. a -> b -> a
const Maybe Int
forall a. Maybe a
Nothing) (Maybe [Pattern] -> Reference -> Maybe [Pattern]
forall a b. a -> b -> a
const Maybe [Pattern]
forall a. Maybe a
Nothing) (Maybe Shape -> Reference -> Maybe Shape
forall a b. a -> b -> a
const Maybe Shape
forall a. Maybe a
Nothing) RecordSchema -> RecordRef
forall {p} {a}. p -> a
mt
  where
    mt :: p -> a
mt p
_ = [Word] -> [Char] -> a
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"RefNums: empty"

type Comb = GComb Void CombIx

-- Actual information for a proper combinator. The GComb type is no
-- longer strictly a 'combinator.'
data GCombInfo comb
  = LamI
      !Int -- Number of arguments
      !Int -- Maximum needed frame size
      !(GSection comb) -- Entry
      !(Ptr NativeCell) -- Where the JIT keeps this combinator's compiled code
  deriving stock (Int -> GCombInfo comb -> ShowS
[GCombInfo comb] -> ShowS
GCombInfo comb -> [Char]
(Int -> GCombInfo comb -> ShowS)
-> (GCombInfo comb -> [Char])
-> ([GCombInfo comb] -> ShowS)
-> Show (GCombInfo comb)
forall comb. Show comb => Int -> GCombInfo comb -> ShowS
forall comb. Show comb => [GCombInfo comb] -> ShowS
forall comb. Show comb => GCombInfo comb -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall comb. Show comb => Int -> GCombInfo comb -> ShowS
showsPrec :: Int -> GCombInfo comb -> ShowS
$cshow :: forall comb. Show comb => GCombInfo comb -> [Char]
show :: GCombInfo comb -> [Char]
$cshowList :: forall comb. Show comb => [GCombInfo comb] -> ShowS
showList :: [GCombInfo comb] -> ShowS
Show, GCombInfo comb -> GCombInfo comb -> Bool
(GCombInfo comb -> GCombInfo comb -> Bool)
-> (GCombInfo comb -> GCombInfo comb -> Bool)
-> Eq (GCombInfo comb)
forall comb. Eq comb => GCombInfo comb -> GCombInfo comb -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall comb. Eq comb => GCombInfo comb -> GCombInfo comb -> Bool
== :: GCombInfo comb -> GCombInfo comb -> Bool
$c/= :: forall comb. Eq comb => GCombInfo comb -> GCombInfo comb -> Bool
/= :: GCombInfo comb -> GCombInfo comb -> Bool
Eq, Eq (GCombInfo comb)
Eq (GCombInfo comb) =>
(GCombInfo comb -> GCombInfo comb -> Ordering)
-> (GCombInfo comb -> GCombInfo comb -> Bool)
-> (GCombInfo comb -> GCombInfo comb -> Bool)
-> (GCombInfo comb -> GCombInfo comb -> Bool)
-> (GCombInfo comb -> GCombInfo comb -> Bool)
-> (GCombInfo comb -> GCombInfo comb -> GCombInfo comb)
-> (GCombInfo comb -> GCombInfo comb -> GCombInfo comb)
-> Ord (GCombInfo comb)
GCombInfo comb -> GCombInfo comb -> Bool
GCombInfo comb -> GCombInfo comb -> Ordering
GCombInfo comb -> GCombInfo comb -> GCombInfo comb
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
forall comb. Ord comb => Eq (GCombInfo comb)
forall comb. Ord comb => GCombInfo comb -> GCombInfo comb -> Bool
forall comb.
Ord comb =>
GCombInfo comb -> GCombInfo comb -> Ordering
forall comb.
Ord comb =>
GCombInfo comb -> GCombInfo comb -> GCombInfo comb
$ccompare :: forall comb.
Ord comb =>
GCombInfo comb -> GCombInfo comb -> Ordering
compare :: GCombInfo comb -> GCombInfo comb -> Ordering
$c< :: forall comb. Ord comb => GCombInfo comb -> GCombInfo comb -> Bool
< :: GCombInfo comb -> GCombInfo comb -> Bool
$c<= :: forall comb. Ord comb => GCombInfo comb -> GCombInfo comb -> Bool
<= :: GCombInfo comb -> GCombInfo comb -> Bool
$c> :: forall comb. Ord comb => GCombInfo comb -> GCombInfo comb -> Bool
> :: GCombInfo comb -> GCombInfo comb -> Bool
$c>= :: forall comb. Ord comb => GCombInfo comb -> GCombInfo comb -> Bool
>= :: GCombInfo comb -> GCombInfo comb -> Bool
$cmax :: forall comb.
Ord comb =>
GCombInfo comb -> GCombInfo comb -> GCombInfo comb
max :: GCombInfo comb -> GCombInfo comb -> GCombInfo comb
$cmin :: forall comb.
Ord comb =>
GCombInfo comb -> GCombInfo comb -> GCombInfo comb
min :: GCombInfo comb -> GCombInfo comb -> GCombInfo comb
Ord, (forall a b. (a -> b) -> GCombInfo a -> GCombInfo b)
-> (forall a b. a -> GCombInfo b -> GCombInfo a)
-> Functor GCombInfo
forall a b. a -> GCombInfo b -> GCombInfo a
forall a b. (a -> b) -> GCombInfo a -> GCombInfo b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> GCombInfo a -> GCombInfo b
fmap :: forall a b. (a -> b) -> GCombInfo a -> GCombInfo b
$c<$ :: forall a b. a -> GCombInfo b -> GCombInfo a
<$ :: forall a b. a -> GCombInfo b -> GCombInfo a
Functor, (forall m. Monoid m => GCombInfo m -> m)
-> (forall m a. Monoid m => (a -> m) -> GCombInfo a -> m)
-> (forall m a. Monoid m => (a -> m) -> GCombInfo a -> m)
-> (forall a b. (a -> b -> b) -> b -> GCombInfo a -> b)
-> (forall a b. (a -> b -> b) -> b -> GCombInfo a -> b)
-> (forall b a. (b -> a -> b) -> b -> GCombInfo a -> b)
-> (forall b a. (b -> a -> b) -> b -> GCombInfo a -> b)
-> (forall a. (a -> a -> a) -> GCombInfo a -> a)
-> (forall a. (a -> a -> a) -> GCombInfo a -> a)
-> (forall a. GCombInfo a -> [a])
-> (forall a. GCombInfo a -> Bool)
-> (forall a. GCombInfo a -> Int)
-> (forall a. Eq a => a -> GCombInfo a -> Bool)
-> (forall a. Ord a => GCombInfo a -> a)
-> (forall a. Ord a => GCombInfo a -> a)
-> (forall a. Num a => GCombInfo a -> a)
-> (forall a. Num a => GCombInfo a -> a)
-> Foldable GCombInfo
forall a. Eq a => a -> GCombInfo a -> Bool
forall a. Num a => GCombInfo a -> a
forall a. Ord a => GCombInfo a -> a
forall m. Monoid m => GCombInfo m -> m
forall a. GCombInfo a -> Bool
forall a. GCombInfo a -> Int
forall a. GCombInfo a -> [a]
forall a. (a -> a -> a) -> GCombInfo a -> a
forall m a. Monoid m => (a -> m) -> GCombInfo a -> m
forall b a. (b -> a -> b) -> b -> GCombInfo a -> b
forall a b. (a -> b -> b) -> b -> GCombInfo a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => GCombInfo m -> m
fold :: forall m. Monoid m => GCombInfo m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> GCombInfo a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> GCombInfo a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> GCombInfo a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> GCombInfo a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> GCombInfo a -> b
foldr :: forall a b. (a -> b -> b) -> b -> GCombInfo a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> GCombInfo a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> GCombInfo a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> GCombInfo a -> b
foldl :: forall b a. (b -> a -> b) -> b -> GCombInfo a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> GCombInfo a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> GCombInfo a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> GCombInfo a -> a
foldr1 :: forall a. (a -> a -> a) -> GCombInfo a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> GCombInfo a -> a
foldl1 :: forall a. (a -> a -> a) -> GCombInfo a -> a
$ctoList :: forall a. GCombInfo a -> [a]
toList :: forall a. GCombInfo a -> [a]
$cnull :: forall a. GCombInfo a -> Bool
null :: forall a. GCombInfo a -> Bool
$clength :: forall a. GCombInfo a -> Int
length :: forall a. GCombInfo a -> Int
$celem :: forall a. Eq a => a -> GCombInfo a -> Bool
elem :: forall a. Eq a => a -> GCombInfo a -> Bool
$cmaximum :: forall a. Ord a => GCombInfo a -> a
maximum :: forall a. Ord a => GCombInfo a -> a
$cminimum :: forall a. Ord a => GCombInfo a -> a
minimum :: forall a. Ord a => GCombInfo a -> a
$csum :: forall a. Num a => GCombInfo a -> a
sum :: forall a. Num a => GCombInfo a -> a
$cproduct :: forall a. Num a => GCombInfo a -> a
product :: forall a. Num a => GCombInfo a -> a
Foldable, Functor GCombInfo
Foldable GCombInfo
(Functor GCombInfo, Foldable GCombInfo) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> GCombInfo a -> f (GCombInfo b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    GCombInfo (f a) -> f (GCombInfo a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> GCombInfo a -> m (GCombInfo b))
-> (forall (m :: * -> *) a.
    Monad m =>
    GCombInfo (m a) -> m (GCombInfo a))
-> Traversable GCombInfo
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
GCombInfo (m a) -> m (GCombInfo a)
forall (f :: * -> *) a.
Applicative f =>
GCombInfo (f a) -> f (GCombInfo a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GCombInfo a -> m (GCombInfo b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GCombInfo a -> f (GCombInfo b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GCombInfo a -> f (GCombInfo b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GCombInfo a -> f (GCombInfo b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
GCombInfo (f a) -> f (GCombInfo a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
GCombInfo (f a) -> f (GCombInfo a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GCombInfo a -> m (GCombInfo b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GCombInfo a -> m (GCombInfo b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
GCombInfo (m a) -> m (GCombInfo a)
sequence :: forall (m :: * -> *) a.
Monad m =>
GCombInfo (m a) -> m (GCombInfo a)
Traversable)

-- | A native code cell (see unison-runtime/src/Unison/Runtime/JIT/design.md): the mutable part of a
-- combinator, 40 bytes outside the Haskell heap, never moved and never
-- freed, so generated code can refer to it by address. As a C struct:
--
-- > struct cell {
-- >   void    *code;    // offset 0: the compiled entry point, NULL until compiled
-- >   int64_t  count;   // offset 8: calls made while code was NULL
-- >   int64_t  state;   // offset 16: 0 not yet requested, 1 queued, 2 taken by the compile thread
-- >   int64_t  verdict; // offset 24: whether it is worth compiling (see readNativeVerdict)
-- >   void    *entry;   // offset 32: the register entry, for native callers in other modules
-- > };
--
-- The state only moves forward, so a combinator is asked for only once.
-- The layout is a contract between two readers: this module (the
-- @ and @ accessors below, at those offsets) and
-- the generated code, which loads @ at offset 0 or @ at
-- offset 32 to call through a cell and writes @ at offset 8
-- (JIT/Codegen.hs); nothing in the C runtime reads a cell. The register
-- entry is a function with the signature native code agrees on across
-- modules for the combinator's arity (design.md, "The register entry"):
-- null when the combinator is not compiled, or compiled without a worker.
--
-- The count starts at minus the JIT's compilation threshold when the JIT
-- compiles what gets hot, so that "hot" is the count reaching zero: the
-- interpreter's test is one comparison with a constant. A count that
-- starts at zero or above never gets there.
data NativeCell

nativeCellSize :: Int
nativeCellSize :: Int
nativeCellSize = Int
40

-- | The offset of the register entry in a cell, for the generated code.
nativeRegisterEntryOffset :: Int
nativeRegisterEntryOffset :: Int
nativeRegisterEntryOffset = Int
32

-- | Reads the compiled code pointer of a cell. Null means "interpret".
-- An atomic (acquire) load: the compile thread writes a module's pool
-- entries and exit and frame tables before it publishes the code pointer,
-- and an interpreter thread that sees the pointer must then see those too,
-- which on a weakly ordered machine (arm64) a plain load does not promise
-- (an @ldar@, a few cycles on an entry that costs tens of nanoseconds).
readNativeCode :: Ptr NativeCell -> IO (Ptr ())
readNativeCode :: Ptr NativeCell -> IO (Ptr ())
readNativeCode (Ptr Addr#
a) = (State# RealWorld -> (# State# RealWorld, Ptr () #)) -> IO (Ptr ())
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Ptr () #))
 -> IO (Ptr ()))
-> (State# RealWorld -> (# State# RealWorld, Ptr () #))
-> IO (Ptr ())
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case Addr# -> State# RealWorld -> (# State# RealWorld, Word# #)
forall d. Addr# -> State# d -> (# State# d, Word# #)
atomicReadWordAddr# Addr#
a State# RealWorld
s of
  (# State# RealWorld
s', Word#
w #) -> (# State# RealWorld
s', WordPtr -> Ptr ()
forall a. WordPtr -> Ptr a
wordPtrToPtr (Word -> WordPtr
WordPtr (Word# -> Word
W# Word#
w)) #)
{-# INLINE readNativeCode #-}

-- | The compiled code the interpreter should enter, if any. Null means
-- "interpret": there is no code, or the function is so small that getting
-- into native code and back costs more than interpreting it (verdict 3;
-- native callers still call it directly).
readNativeEntry :: Ptr NativeCell -> IO (Ptr ())
readNativeEntry :: Ptr NativeCell -> IO (Ptr ())
readNativeEntry Ptr NativeCell
cell = do
  Ptr ()
code <- Ptr NativeCell -> IO (Ptr ())
readNativeCode Ptr NativeCell
cell
  if Ptr ()
code Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr
    then Ptr () -> IO (Ptr ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ptr ()
code
    else do
      Int
verdict <- Ptr NativeCell -> Int -> IO Int
forall b. Ptr b -> Int -> IO Int
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr NativeCell
cell Int
24 :: IO Int
      pure (if Int
verdict Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 then Ptr ()
forall a. Ptr a
nullPtr else Ptr ()
code)
{-# INLINE readNativeEntry #-}

-- | Installs compiled code. A single atomic (release) pointer write:
-- readers on other threads see either the old value or the new one, and a
-- reader that sees the new one sees everything the compile thread wrote
-- before it (see 'readNativeCode').
writeNativeCode :: Ptr NativeCell -> Ptr () -> IO ()
writeNativeCode :: Ptr NativeCell -> Ptr () -> IO ()
writeNativeCode (Ptr Addr#
a) Ptr ()
code = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case Addr# -> Word# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Word# -> State# d -> State# d
atomicWriteWordAddr# Addr#
a Word#
w State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)
  where
    !(WordPtr (W# Word#
w)) = Ptr () -> WordPtr
forall a. Ptr a -> WordPtr
ptrToWordPtr Ptr ()
code

-- | Installs the register entry (null for none), the same way as the
-- code pointer; written before the code pointer, so that a thread which
-- sees the code sees the entry.
writeNativeRegisterEntry :: Ptr NativeCell -> Ptr () -> IO ()
writeNativeRegisterEntry :: Ptr NativeCell -> Ptr () -> IO ()
writeNativeRegisterEntry (Ptr Addr#
a) Ptr ()
code = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case Addr# -> Word# -> State# RealWorld -> State# RealWorld
forall d. Addr# -> Word# -> State# d -> State# d
atomicWriteWordAddr# (Addr# -> Int# -> Addr#
plusAddr# Addr#
a Int#
32#) Word#
w State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)
  where
    !(WordPtr (W# Word#
w)) = Ptr () -> WordPtr
forall a. Ptr a -> WordPtr
ptrToWordPtr Ptr ()
code

-- | Counts a call made while the cell had no compiled code, and says
-- whether that made it hot (the count reached zero). Not atomic; a lost
-- count under contention does not matter.
bumpNativeCount :: Ptr NativeCell -> IO Bool
bumpNativeCount :: Ptr NativeCell -> IO Bool
bumpNativeCount Ptr NativeCell
cell = do
  Int
n <- Ptr NativeCell -> Int -> IO Int
forall b. Ptr b -> Int -> IO Int
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr NativeCell
cell Int
8 :: IO Int
  Ptr NativeCell -> Int -> Int -> IO ()
forall b. Ptr b -> Int -> Int -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr NativeCell
cell Int
8 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  pure (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1)
{-# INLINE bumpNativeCount #-}

readNativeCount :: Ptr NativeCell -> IO Int
readNativeCount :: Ptr NativeCell -> IO Int
readNativeCount Ptr NativeCell
cell = Ptr NativeCell -> Int -> IO Int
forall b. Ptr b -> Int -> IO Int
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr NativeCell
cell Int
8

-- | Sets a cell's count: negative, to make it hot after that many more
-- calls.
writeNativeCount :: Ptr NativeCell -> Int -> IO ()
writeNativeCount :: Ptr NativeCell -> Int -> IO ()
writeNativeCount Ptr NativeCell
cell Int
n = Ptr NativeCell -> Int -> Int -> IO ()
forall b. Ptr b -> Int -> Int -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr NativeCell
cell Int
8 Int
n

-- | Marks the cell as requested (state 0 to 1), atomically, and says
-- whether this call was the one that did. Whoever does owns the request,
-- and queues it.
claimNativeCell :: Ptr NativeCell -> IO Bool
claimNativeCell :: Ptr NativeCell -> IO Bool
claimNativeCell Ptr NativeCell
cell = Ptr NativeCell -> Word# -> Word# -> IO Bool
casNativeState Ptr NativeCell
cell Word#
0## Word#
1##

-- | Puts the state back to 0: for a request that could not be queued.
releaseNativeCell :: Ptr NativeCell -> IO ()
releaseNativeCell :: Ptr NativeCell -> IO ()
releaseNativeCell Ptr NativeCell
cell = Ptr NativeCell -> Int -> Int -> IO ()
forall b. Ptr b -> Int -> Int -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr NativeCell
cell Int
16 (Int
0 :: Int)

-- | The compile thread takes the cell (state 2), whether it was requested
-- or not, and says whether this call was the one that did. A combinator
-- that is taken is being compiled, or has been, or can't be. A request
-- found already taken when it comes off the queue is dropped: its
-- combinator went into an earlier batch.
takeNativeCell :: Ptr NativeCell -> IO Bool
takeNativeCell :: Ptr NativeCell -> IO Bool
takeNativeCell Ptr NativeCell
cell = do
  Bool
wasRequested <- Ptr NativeCell -> Word# -> Word# -> IO Bool
casNativeState Ptr NativeCell
cell Word#
1## Word#
2##
  if Bool
wasRequested then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True else Ptr NativeCell -> Word# -> Word# -> IO Bool
casNativeState Ptr NativeCell
cell Word#
0## Word#
2##

casNativeState :: Ptr NativeCell -> Word# -> Word# -> IO Bool
casNativeState :: Ptr NativeCell -> Word# -> Word# -> IO Bool
casNativeState (Ptr Addr#
cell) Word#
from Word#
to = (State# RealWorld -> (# State# RealWorld, Bool #)) -> IO Bool
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Bool #)) -> IO Bool)
-> (State# RealWorld -> (# State# RealWorld, Bool #)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case Addr#
-> Word#
-> Word#
-> State# RealWorld
-> (# State# RealWorld, Word# #)
forall d.
Addr# -> Word# -> Word# -> State# d -> (# State# d, Word# #)
atomicCasWordAddr# (Addr# -> Int# -> Addr#
plusAddr# Addr#
cell Int#
16#) Word#
from Word#
to State# RealWorld
s of
    (# State# RealWorld
s', Word#
old #) -> (# State# RealWorld
s', Int# -> Bool
isTrue# (Word# -> Word# -> Int#
eqWord# Word#
old Word#
from) #)

-- | Whether a request for the cell is queued.
nativeCellRequested :: Ptr NativeCell -> IO Bool
nativeCellRequested :: Ptr NativeCell -> IO Bool
nativeCellRequested Ptr NativeCell
cell = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
1 :: Int)) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr NativeCell -> Int -> IO Int
forall b. Ptr b -> Int -> IO Int
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr NativeCell
cell Int
16

-- | What the JIT has decided about compiling the cell's combinator. Zero:
-- nothing yet. Otherwise the low two bits say: 1 worth compiling, 2 better
-- left to the interpreter, because native code for it would spend its time
-- leaving native code, 3 worth compiling for native callers but too small
-- to be worth entering from the interpreter. The bits above hold an
-- estimate the JIT keeps for judging callers (see JIT.Estimate). Only the thread that compiles writes
-- this; the interpreter reads it when it finds code in the cell.
readNativeVerdict :: Ptr NativeCell -> IO Int
readNativeVerdict :: Ptr NativeCell -> IO Int
readNativeVerdict Ptr NativeCell
cell = Ptr NativeCell -> Int -> IO Int
forall b. Ptr b -> Int -> IO Int
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr NativeCell
cell Int
24

writeNativeVerdict :: Ptr NativeCell -> Int -> IO ()
writeNativeVerdict :: Ptr NativeCell -> Int -> IO ()
writeNativeVerdict Ptr NativeCell
cell Int
v = Ptr NativeCell -> Int -> Int -> IO ()
forall b. Ptr b -> Int -> Int -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr NativeCell
cell Int
24 Int
v

-- | Allocates zeroed cells for @n@ combinators, as one block that is
-- never freed.
newNativeCells :: Int -> IO (Ptr NativeCell)
newNativeCells :: Int -> IO (Ptr NativeCell)
newNativeCells Int
n = Int -> IO (Ptr NativeCell)
forall a. Int -> IO (Ptr a)
callocBytes (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
nativeCellSize)

-- | The cell at index @i@ of a block from 'newNativeCells'.
nativeCellAt :: Ptr NativeCell -> Int -> Ptr NativeCell
nativeCellAt :: Ptr NativeCell -> Int -> Ptr NativeCell
nativeCellAt Ptr NativeCell
base Int
i = Ptr NativeCell
base Ptr NativeCell -> Int -> Ptr NativeCell
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
nativeCellSize)

-- | A shared cell for combinators that are never compiled: builtins,
-- and combinators that were not loaded through the code cache.
noNativeCell :: Ptr NativeCell
noNativeCell :: Ptr NativeCell
noNativeCell = IO (Ptr NativeCell) -> Ptr NativeCell
forall a. IO a -> a
unsafePerformIO (Int -> IO (Ptr NativeCell)
newNativeCells Int
1)
{-# NOINLINE noNativeCell #-}

-- | Cells are handed out from a pool, so that loading code (an STM
-- transaction) never has to allocate memory: a retried transaction
-- would leak it. The pool is a block of cells and a count of how many
-- are in use. When it runs out, a new block is allocated outside the
-- transaction with 'growNativeCellPool'. Old blocks stay in use, and
-- are never freed.
data NativeCellPool = NativeCellPool !(Ptr NativeCell) !Int !Int -- block, used, capacity

-- The first argument is the count every cell starts with: minus the
-- threshold in the JIT's @on@ mode, zero (never hot) otherwise
-- (JIT.initialNativeCount).
newNativeCellPool :: Int -> Int -> IO NativeCellPool
newNativeCellPool :: Int -> Int -> IO NativeCellPool
newNativeCellPool Int
initialNativeCount Int
capacity = do
  Ptr NativeCell
block <- Int -> IO (Ptr NativeCell)
newNativeCells Int
capacity
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
initialNativeCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
capacity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
      \Int
i -> Ptr NativeCell -> Int -> IO ()
writeNativeCount (Ptr NativeCell -> Int -> Ptr NativeCell
nativeCellAt Ptr NativeCell
block Int
i) Int
initialNativeCount
  pure (Ptr NativeCell -> Int -> Int -> NativeCellPool
NativeCellPool Ptr NativeCell
block Int
0 Int
capacity)

-- | Takes @n@ cells from the pool, or fails if it has fewer left.
takeNativeCells :: Int -> NativeCellPool -> Maybe (Ptr NativeCell, NativeCellPool)
takeNativeCells :: Int -> NativeCellPool -> Maybe (Ptr NativeCell, NativeCellPool)
takeNativeCells Int
n (NativeCellPool Ptr NativeCell
block Int
used Int
capacity)
  | Int
used Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
capacity = (Ptr NativeCell, NativeCellPool)
-> Maybe (Ptr NativeCell, NativeCellPool)
forall a. a -> Maybe a
Just (Ptr NativeCell -> Int -> Ptr NativeCell
nativeCellAt Ptr NativeCell
block Int
used, Ptr NativeCell -> Int -> Int -> NativeCellPool
NativeCellPool Ptr NativeCell
block (Int
used Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int
capacity)
  | Bool
otherwise = Maybe (Ptr NativeCell, NativeCellPool)
forall a. Maybe a
Nothing

-- | A fresh block with room for at least @n@ cells, and at least twice
-- the old capacity so that growing stays rare.
growNativeCellPool :: Int -> Int -> NativeCellPool -> IO NativeCellPool
growNativeCellPool :: Int -> Int -> NativeCellPool -> IO NativeCellPool
growNativeCellPool Int
initialNativeCount Int
n (NativeCellPool Ptr NativeCell
_ Int
_ Int
capacity) = Int -> Int -> IO NativeCellPool
newNativeCellPool Int
initialNativeCount (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
capacity))

-- | Gives every combinator in a group of freshly loaded code its own
-- cell from @base@, numbering them in order. Returns the count used.
attachNativeCells ::
  Ptr NativeCell -> EnumMap Word64 (GCombs val comb) -> (Int, EnumMap Word64 (GCombs val comb))
attachNativeCells :: forall val comb.
Ptr NativeCell
-> EnumMap Word64 (GCombs val comb)
-> (Int, EnumMap Word64 (GCombs val comb))
attachNativeCells Ptr NativeCell
base EnumMap Word64 (GCombs val comb)
groups = (Int
n, (GCombs val comb -> GCombs val comb)
-> EnumMap Word64 (GCombs val comb)
-> EnumMap Word64 (GCombs val comb)
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GCombs val comb -> GCombs val comb
forall {val} {comb}.
EnumMap Word64 (GComb val comb) -> EnumMap Word64 (GComb val comb)
attachLets EnumMap Word64 (GCombs val comb)
groups')
  where
    (EnumMap Word64 (GCombs val comb)
groups', Int
n) = State Int (EnumMap Word64 (GCombs val comb))
-> Int -> (EnumMap Word64 (GCombs val comb), Int)
forall s a. State s a -> s -> (a, s)
runState ((GCombs val comb -> StateT Int Identity (GCombs val comb))
-> EnumMap Word64 (GCombs val comb)
-> State Int (EnumMap Word64 (GCombs val comb))
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) -> EnumMap Word64 a -> f (EnumMap Word64 b)
traverse ((GComb val comb -> StateT Int Identity (GComb val comb))
-> GCombs val comb -> StateT Int Identity (GCombs val comb)
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) -> EnumMap Word64 a -> f (EnumMap Word64 b)
traverse GComb val comb -> StateT Int Identity (GComb val comb)
attach) EnumMap Word64 (GCombs val comb)
groups) Int
0
    attach :: GComb val comb -> StateT Int Identity (GComb val comb)
attach (Comb (LamI Int
a Int
f GSection comb
s Ptr NativeCell
_) FrameLayout
lay) = (Int -> (GComb val comb, Int))
-> StateT Int Identity (GComb val comb)
forall a. (Int -> (a, Int)) -> StateT Int Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state \Int
i -> (GCombInfo comb -> FrameLayout -> GComb val comb
forall val comb. GCombInfo comb -> FrameLayout -> GComb val comb
Comb (Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
forall comb.
Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
LamI Int
a Int
f GSection comb
s (Ptr NativeCell -> Int -> Ptr NativeCell
nativeCellAt Ptr NativeCell
base Int
i)) FrameLayout
lay, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    attach GComb val comb
c = GComb val comb -> StateT Int Identity (GComb val comb)
forall a. a -> StateT Int Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GComb val comb
c
    -- Every Let names its body's combinator, which is in the same group;
    -- the Let carries that combinator's cell so the interpreter can find
    -- the body's native code when it pops the Let's frame. That only
    -- works when the body combinator's arity is the depth of the frame the
    -- interpreter has at that point. Inside a Let binding it isn't: the
    -- binding runs in a fresh frame, but the combinator's arguments also
    -- include the enclosing function's slots below that frame. So a Let
    -- inside a binding gets no re-entry point and its body is interpreted.
    attachLets :: EnumMap Word64 (GComb val comb) -> EnumMap Word64 (GComb val comb)
attachLets EnumMap Word64 (GComb val comb)
combs = (GComb val comb -> GComb val comb)
-> EnumMap Word64 (GComb val comb)
-> EnumMap Word64 (GComb val comb)
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GComb val comb -> GComb val comb
attachComb EnumMap Word64 (GComb val comb)
combs
      where
        attachComb :: GComb val comb -> GComb val comb
attachComb (Comb (LamI Int
a Int
f GSection comb
s Ptr NativeCell
c) FrameLayout
lay) = GCombInfo comb -> FrameLayout -> GComb val comb
forall val comb. GCombInfo comb -> FrameLayout -> GComb val comb
Comb (Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
forall comb.
Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
LamI Int
a Int
f (Bool -> GSection comb -> GSection comb
setLets Bool
False GSection comb
s) Ptr NativeCell
c) FrameLayout
lay
        attachComb GComb val comb
c = GComb val comb
c
        cellOf :: Bool -> Word64 -> Ptr NativeCell
cellOf Bool
inBinding Word64
w
          | Bool
inBinding = Ptr NativeCell
noNativeCell
          | Bool
otherwise = case Word64 -> EnumMap Word64 (GComb val comb) -> Maybe (GComb val comb)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w EnumMap Word64 (GComb val comb)
combs of
              Just (Comb (LamI Int
_ Int
_ GSection comb
_ Ptr NativeCell
c) FrameLayout
_) -> Ptr NativeCell
c
              Maybe (GComb val comb)
_ -> Ptr NativeCell
noNativeCell
        setLets :: Bool -> GSection comb -> GSection comb
setLets Bool
inB GSection comb
section = case GSection comb
section of
          Let GSection comb
b cix :: CombIx
cix@(CIx Reference
_ Word64
_ Word64
w) Int
f GSection comb
bd Ptr NativeCell
_ -> GSection comb
-> CombIx
-> Int
-> GSection comb
-> Ptr NativeCell
-> GSection comb
forall comb.
GSection comb
-> CombIx
-> Int
-> GSection comb
-> Ptr NativeCell
-> GSection comb
Let (Bool -> GSection comb -> GSection comb
setLets Bool
True GSection comb
b) CombIx
cix Int
f (Bool -> GSection comb -> GSection comb
setLets Bool
inB GSection comb
bd) (Bool -> Word64 -> Ptr NativeCell
cellOf Bool
inB Word64
w)
          Ins GInstr comb
i GSection comb
nx -> GInstr comb -> GSection comb -> GSection comb
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins GInstr comb
i (Bool -> GSection comb -> GSection comb
setLets Bool
inB GSection comb
nx)
          Match Int
i GBranch comb
bs -> Int -> GBranch comb -> GSection comb
forall comb. Int -> GBranch comb -> GSection comb
Match Int
i (Bool -> GBranch comb -> GBranch comb
setLetsB Bool
inB GBranch comb
bs)
          DMatch Maybe Reference
i Int
j GBranch comb
bs -> Maybe Reference -> Int -> GBranch comb -> GSection comb
forall comb.
Maybe Reference -> Int -> GBranch comb -> GSection comb
DMatch Maybe Reference
i Int
j (Bool -> GBranch comb -> GBranch comb
setLetsB Bool
inB GBranch comb
bs)
          NMatch Maybe Reference
i Int
j GBranch comb
bs -> Maybe Reference -> Int -> GBranch comb -> GSection comb
forall comb.
Maybe Reference -> Int -> GBranch comb -> GSection comb
NMatch Maybe Reference
i Int
j (Bool -> GBranch comb -> GBranch comb
setLetsB Bool
inB GBranch comb
bs)
          RMatch Int
i GSection comb
s EnumMap Word64 (GBranch comb)
bs -> Int
-> GSection comb -> EnumMap Word64 (GBranch comb) -> GSection comb
forall comb.
Int
-> GSection comb -> EnumMap Word64 (GBranch comb) -> GSection comb
RMatch Int
i (Bool -> GSection comb -> GSection comb
setLets Bool
inB GSection comb
s) ((GBranch comb -> GBranch comb)
-> EnumMap Word64 (GBranch comb) -> EnumMap Word64 (GBranch comb)
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> GBranch comb -> GBranch comb
setLetsB Bool
inB) EnumMap Word64 (GBranch comb)
bs)
          App {} -> GSection comb
section
          Call {} -> GSection comb
section
          Jump {} -> GSection comb
section
          Yield {} -> GSection comb
section
          Die {} -> GSection comb
section
          GSection comb
Exit -> GSection comb
section
        setLetsA :: Bool -> Arm comb -> Arm comb
setLetsA Bool
inB (Arm Int
n GSection comb
s) = Int -> GSection comb -> Arm comb
forall comb. Int -> GSection comb -> Arm comb
Arm Int
n (Bool -> GSection comb -> GSection comb
setLets Bool
inB GSection comb
s)
        setLetsB :: Bool -> GBranch comb -> GBranch comb
setLetsB Bool
inB = \case
          Test1 Word64
i Arm comb
s GSection comb
d -> Word64 -> Arm comb -> GSection comb -> GBranch comb
forall comb. Word64 -> Arm comb -> GSection comb -> GBranch comb
Test1 Word64
i (Bool -> Arm comb -> Arm comb
setLetsA Bool
inB Arm comb
s) (Bool -> GSection comb -> GSection comb
setLets Bool
inB GSection comb
d)
          Test2 Word64
i Arm comb
s Word64
j Arm comb
t GSection comb
d -> Word64
-> Arm comb -> Word64 -> Arm comb -> GSection comb -> GBranch comb
forall comb.
Word64
-> Arm comb -> Word64 -> Arm comb -> GSection comb -> GBranch comb
Test2 Word64
i (Bool -> Arm comb -> Arm comb
setLetsA Bool
inB Arm comb
s) Word64
j (Bool -> Arm comb -> Arm comb
setLetsA Bool
inB Arm comb
t) (Bool -> GSection comb -> GSection comb
setLets Bool
inB GSection comb
d)
          TestW GSection comb
d EnumMap Word64 (Arm comb)
m -> GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
forall comb.
GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
TestW (Bool -> GSection comb -> GSection comb
setLets Bool
inB GSection comb
d) ((Arm comb -> Arm comb)
-> EnumMap Word64 (Arm comb) -> EnumMap Word64 (Arm comb)
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Arm comb -> Arm comb
setLetsA Bool
inB) EnumMap Word64 (Arm comb)
m)
          TestT GSection comb
d Map Text (GSection comb)
m -> GSection comb -> Map Text (GSection comb) -> GBranch comb
forall comb.
GSection comb -> Map Text (GSection comb) -> GBranch comb
TestT (Bool -> GSection comb -> GSection comb
setLets Bool
inB GSection comb
d) ((GSection comb -> GSection comb)
-> Map Text (GSection comb) -> Map Text (GSection comb)
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> GSection comb -> GSection comb
setLets Bool
inB) Map Text (GSection comb)
m)
          TestY GSection comb
d Map Bytes (GSection comb)
m -> GSection comb -> Map Bytes (GSection comb) -> GBranch comb
forall comb.
GSection comb -> Map Bytes (GSection comb) -> GBranch comb
TestY (Bool -> GSection comb -> GSection comb
setLets Bool
inB GSection comb
d) ((GSection comb -> GSection comb)
-> Map Bytes (GSection comb) -> Map Bytes (GSection comb)
forall a b. (a -> b) -> Map Bytes a -> Map Bytes b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> GSection comb -> GSection comb
setLets Bool
inB) Map Bytes (GSection comb)
m)

data GComb val comb
  = Comb
      {-# UNPACK #-} !(GCombInfo comb)
      -- | the frame layout, when this is the body of an indirect let: the
      -- value slot and width of each wide variable of the let's frame,
      -- counting from the top ('wideSlots'); empty for a top-level
      -- combinator, whose arguments are one slot each
      !FrameLayout
  | -- A pre-evaluated comb, typically a pure top-level const
    CachedVal !Word64 {- top level comb ix -} !val
  deriving stock (Int -> GComb val comb -> ShowS
[GComb val comb] -> ShowS
GComb val comb -> [Char]
(Int -> GComb val comb -> ShowS)
-> (GComb val comb -> [Char])
-> ([GComb val comb] -> ShowS)
-> Show (GComb val comb)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall val comb.
(Show comb, Show val) =>
Int -> GComb val comb -> ShowS
forall val comb. (Show comb, Show val) => [GComb val comb] -> ShowS
forall val comb. (Show comb, Show val) => GComb val comb -> [Char]
$cshowsPrec :: forall val comb.
(Show comb, Show val) =>
Int -> GComb val comb -> ShowS
showsPrec :: Int -> GComb val comb -> ShowS
$cshow :: forall val comb. (Show comb, Show val) => GComb val comb -> [Char]
show :: GComb val comb -> [Char]
$cshowList :: forall val comb. (Show comb, Show val) => [GComb val comb] -> ShowS
showList :: [GComb val comb] -> ShowS
Show, GComb val comb -> GComb val comb -> Bool
(GComb val comb -> GComb val comb -> Bool)
-> (GComb val comb -> GComb val comb -> Bool)
-> Eq (GComb val comb)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall val comb.
(Eq comb, Eq val) =>
GComb val comb -> GComb val comb -> Bool
$c== :: forall val comb.
(Eq comb, Eq val) =>
GComb val comb -> GComb val comb -> Bool
== :: GComb val comb -> GComb val comb -> Bool
$c/= :: forall val comb.
(Eq comb, Eq val) =>
GComb val comb -> GComb val comb -> Bool
/= :: GComb val comb -> GComb val comb -> Bool
Eq, Eq (GComb val comb)
Eq (GComb val comb) =>
(GComb val comb -> GComb val comb -> Ordering)
-> (GComb val comb -> GComb val comb -> Bool)
-> (GComb val comb -> GComb val comb -> Bool)
-> (GComb val comb -> GComb val comb -> Bool)
-> (GComb val comb -> GComb val comb -> Bool)
-> (GComb val comb -> GComb val comb -> GComb val comb)
-> (GComb val comb -> GComb val comb -> GComb val comb)
-> Ord (GComb val comb)
GComb val comb -> GComb val comb -> Bool
GComb val comb -> GComb val comb -> Ordering
GComb val comb -> GComb val comb -> GComb val comb
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
forall val comb. (Ord comb, Ord val) => Eq (GComb val comb)
forall val comb.
(Ord comb, Ord val) =>
GComb val comb -> GComb val comb -> Bool
forall val comb.
(Ord comb, Ord val) =>
GComb val comb -> GComb val comb -> Ordering
forall val comb.
(Ord comb, Ord val) =>
GComb val comb -> GComb val comb -> GComb val comb
$ccompare :: forall val comb.
(Ord comb, Ord val) =>
GComb val comb -> GComb val comb -> Ordering
compare :: GComb val comb -> GComb val comb -> Ordering
$c< :: forall val comb.
(Ord comb, Ord val) =>
GComb val comb -> GComb val comb -> Bool
< :: GComb val comb -> GComb val comb -> Bool
$c<= :: forall val comb.
(Ord comb, Ord val) =>
GComb val comb -> GComb val comb -> Bool
<= :: GComb val comb -> GComb val comb -> Bool
$c> :: forall val comb.
(Ord comb, Ord val) =>
GComb val comb -> GComb val comb -> Bool
> :: GComb val comb -> GComb val comb -> Bool
$c>= :: forall val comb.
(Ord comb, Ord val) =>
GComb val comb -> GComb val comb -> Bool
>= :: GComb val comb -> GComb val comb -> Bool
$cmax :: forall val comb.
(Ord comb, Ord val) =>
GComb val comb -> GComb val comb -> GComb val comb
max :: GComb val comb -> GComb val comb -> GComb val comb
$cmin :: forall val comb.
(Ord comb, Ord val) =>
GComb val comb -> GComb val comb -> GComb val comb
min :: GComb val comb -> GComb val comb -> GComb val comb
Ord, (forall a b. (a -> b) -> GComb val a -> GComb val b)
-> (forall a b. a -> GComb val b -> GComb val a)
-> Functor (GComb val)
forall a b. a -> GComb val b -> GComb val a
forall a b. (a -> b) -> GComb val a -> GComb val b
forall val a b. a -> GComb val b -> GComb val a
forall val a b. (a -> b) -> GComb val a -> GComb val b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall val a b. (a -> b) -> GComb val a -> GComb val b
fmap :: forall a b. (a -> b) -> GComb val a -> GComb val b
$c<$ :: forall val a b. a -> GComb val b -> GComb val a
<$ :: forall a b. a -> GComb val b -> GComb val a
Functor, (forall m. Monoid m => GComb val m -> m)
-> (forall m a. Monoid m => (a -> m) -> GComb val a -> m)
-> (forall m a. Monoid m => (a -> m) -> GComb val a -> m)
-> (forall a b. (a -> b -> b) -> b -> GComb val a -> b)
-> (forall a b. (a -> b -> b) -> b -> GComb val a -> b)
-> (forall b a. (b -> a -> b) -> b -> GComb val a -> b)
-> (forall b a. (b -> a -> b) -> b -> GComb val a -> b)
-> (forall a. (a -> a -> a) -> GComb val a -> a)
-> (forall a. (a -> a -> a) -> GComb val a -> a)
-> (forall a. GComb val a -> [a])
-> (forall a. GComb val a -> Bool)
-> (forall a. GComb val a -> Int)
-> (forall a. Eq a => a -> GComb val a -> Bool)
-> (forall a. Ord a => GComb val a -> a)
-> (forall a. Ord a => GComb val a -> a)
-> (forall a. Num a => GComb val a -> a)
-> (forall a. Num a => GComb val a -> a)
-> Foldable (GComb val)
forall a. Eq a => a -> GComb val a -> Bool
forall a. Num a => GComb val a -> a
forall a. Ord a => GComb val a -> a
forall m. Monoid m => GComb val m -> m
forall a. GComb val a -> Bool
forall a. GComb val a -> Int
forall a. GComb val a -> [a]
forall a. (a -> a -> a) -> GComb val a -> a
forall val a. Eq a => a -> GComb val a -> Bool
forall val a. Num a => GComb val a -> a
forall val a. Ord a => GComb val a -> a
forall val m. Monoid m => GComb val m -> m
forall m a. Monoid m => (a -> m) -> GComb val a -> m
forall val a. GComb val a -> Bool
forall val a. GComb val a -> Int
forall val a. GComb val a -> [a]
forall b a. (b -> a -> b) -> b -> GComb val a -> b
forall a b. (a -> b -> b) -> b -> GComb val a -> b
forall val a. (a -> a -> a) -> GComb val a -> a
forall val m a. Monoid m => (a -> m) -> GComb val a -> m
forall val b a. (b -> a -> b) -> b -> GComb val a -> b
forall val a b. (a -> b -> b) -> b -> GComb val a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall val m. Monoid m => GComb val m -> m
fold :: forall m. Monoid m => GComb val m -> m
$cfoldMap :: forall val m a. Monoid m => (a -> m) -> GComb val a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> GComb val a -> m
$cfoldMap' :: forall val m a. Monoid m => (a -> m) -> GComb val a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> GComb val a -> m
$cfoldr :: forall val a b. (a -> b -> b) -> b -> GComb val a -> b
foldr :: forall a b. (a -> b -> b) -> b -> GComb val a -> b
$cfoldr' :: forall val a b. (a -> b -> b) -> b -> GComb val a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> GComb val a -> b
$cfoldl :: forall val b a. (b -> a -> b) -> b -> GComb val a -> b
foldl :: forall b a. (b -> a -> b) -> b -> GComb val a -> b
$cfoldl' :: forall val b a. (b -> a -> b) -> b -> GComb val a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> GComb val a -> b
$cfoldr1 :: forall val a. (a -> a -> a) -> GComb val a -> a
foldr1 :: forall a. (a -> a -> a) -> GComb val a -> a
$cfoldl1 :: forall val a. (a -> a -> a) -> GComb val a -> a
foldl1 :: forall a. (a -> a -> a) -> GComb val a -> a
$ctoList :: forall val a. GComb val a -> [a]
toList :: forall a. GComb val a -> [a]
$cnull :: forall val a. GComb val a -> Bool
null :: forall a. GComb val a -> Bool
$clength :: forall val a. GComb val a -> Int
length :: forall a. GComb val a -> Int
$celem :: forall val a. Eq a => a -> GComb val a -> Bool
elem :: forall a. Eq a => a -> GComb val a -> Bool
$cmaximum :: forall val a. Ord a => GComb val a -> a
maximum :: forall a. Ord a => GComb val a -> a
$cminimum :: forall val a. Ord a => GComb val a -> a
minimum :: forall a. Ord a => GComb val a -> a
$csum :: forall val a. Num a => GComb val a -> a
sum :: forall a. Num a => GComb val a -> a
$cproduct :: forall val a. Num a => GComb val a -> a
product :: forall a. Num a => GComb val a -> a
Foldable, Functor (GComb val)
Foldable (GComb val)
(Functor (GComb val), Foldable (GComb val)) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> GComb val a -> f (GComb val b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    GComb val (f a) -> f (GComb val a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> GComb val a -> m (GComb val b))
-> (forall (m :: * -> *) a.
    Monad m =>
    GComb val (m a) -> m (GComb val a))
-> Traversable (GComb val)
forall val. Functor (GComb val)
forall val. Foldable (GComb val)
forall val (m :: * -> *) a.
Monad m =>
GComb val (m a) -> m (GComb val a)
forall val (f :: * -> *) a.
Applicative f =>
GComb val (f a) -> f (GComb val a)
forall val (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GComb val a -> m (GComb val b)
forall val (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GComb val a -> f (GComb val b)
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
GComb val (m a) -> m (GComb val a)
forall (f :: * -> *) a.
Applicative f =>
GComb val (f a) -> f (GComb val a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GComb val a -> m (GComb val b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GComb val a -> f (GComb val b)
$ctraverse :: forall val (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GComb val a -> f (GComb val b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GComb val a -> f (GComb val b)
$csequenceA :: forall val (f :: * -> *) a.
Applicative f =>
GComb val (f a) -> f (GComb val a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
GComb val (f a) -> f (GComb val a)
$cmapM :: forall val (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GComb val a -> m (GComb val b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GComb val a -> m (GComb val b)
$csequence :: forall val (m :: * -> *) a.
Monad m =>
GComb val (m a) -> m (GComb val a)
sequence :: forall (m :: * -> *) a.
Monad m =>
GComb val (m a) -> m (GComb val a)
Traversable)

-- | Matches any combinator, ignoring its native code cell. Building one
-- with this gives it the shared "never compiled" cell, so don't use it to
-- rebuild a combinator that already has a cell of its own.
pattern Lam ::
  Int -> Int -> GSection comb -> GComb val comb
pattern $mLam :: forall {r} {comb} {val}.
GComb val comb
-> (Int -> Int -> GSection comb -> r) -> ((# #) -> r) -> r
$bLam :: forall comb val. Int -> Int -> GSection comb -> GComb val comb
Lam a f sect <- Comb (LamI a f sect _) _
  where
    Lam Int
a Int
f GSection comb
sect = GCombInfo comb -> FrameLayout -> GComb val comb
forall val comb. GCombInfo comb -> FrameLayout -> GComb val comb
Comb (Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
forall comb.
Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
LamI Int
a Int
f GSection comb
sect Ptr NativeCell
noNativeCell) FrameLayout
emptyLayout

-- it seems GHC can't figure this out itself
{-# COMPLETE CachedVal, Lam #-}

instance Bifunctor GComb where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> GComb a c -> GComb b d
bimap = (a -> b) -> (c -> d) -> GComb a c -> GComb b d
forall (t :: * -> * -> *) a b c d.
Bitraversable t =>
(a -> b) -> (c -> d) -> t a c -> t b d
bimapDefault

instance Bifoldable GComb where
  bifoldMap :: forall m a b. Monoid m => (a -> m) -> (b -> m) -> GComb a b -> m
bifoldMap = (a -> m) -> (b -> m) -> GComb a b -> m
forall (t :: * -> * -> *) m a b.
(Bitraversable t, Monoid m) =>
(a -> m) -> (b -> m) -> t a b -> m
bifoldMapDefault

instance Bitraversable GComb where
  bitraverse :: forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> GComb a b -> f (GComb c d)
bitraverse a -> f c
f b -> f d
_ (CachedVal Word64
cix a
c) = Word64 -> c -> GComb c d
forall val comb. Word64 -> val -> GComb val comb
CachedVal Word64
cix (c -> GComb c d) -> f c -> f (GComb c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
c
  bitraverse a -> f c
_ b -> f d
f (Comb (LamI Int
a Int
fr GSection b
s Ptr NativeCell
cell) FrameLayout
lay) = (\GSection d
s' -> GCombInfo d -> FrameLayout -> GComb c d
forall val comb. GCombInfo comb -> FrameLayout -> GComb val comb
Comb (Int -> Int -> GSection d -> Ptr NativeCell -> GCombInfo d
forall comb.
Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
LamI Int
a Int
fr GSection d
s' Ptr NativeCell
cell) FrameLayout
lay) (GSection d -> GComb c d) -> f (GSection d) -> f (GComb c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (b -> f d) -> GSection b -> f (GSection d)
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) -> GSection a -> f (GSection b)
traverse b -> f d
f GSection b
s

type RCombs val = GCombs val (RComb val)

-- | The fixed point of a GComb where all references to a Comb are themselves Combs.
newtype RComb val = RComb {forall val. RComb val -> GComb val (RComb val)
unRComb :: GComb val (RComb val)}

type RCombInfo val = GCombInfo (RComb val)

instance Show (RComb val) where
  show :: RComb val -> [Char]
show RComb val
_ = [Char]
"<RCOMB>"

-- | Map of combinators, parameterized by comb reference type
type GCombs val comb = EnumMap Word64 (GComb val comb)

-- | A reference to a combinator, parameterized by comb
type Ref = GRef CombIx

type RRef val = GRef (RComb val)

data GRef comb
  = Stk !Int -- stack reference to a closure
  | Env !CombIx {- Lazy! Might be cyclic -} comb
  | Dyn !Word64 -- dynamic scope reference to a closure
  deriving (Int -> GRef comb -> ShowS
[GRef comb] -> ShowS
GRef comb -> [Char]
(Int -> GRef comb -> ShowS)
-> (GRef comb -> [Char])
-> ([GRef comb] -> ShowS)
-> Show (GRef comb)
forall comb. Show comb => Int -> GRef comb -> ShowS
forall comb. Show comb => [GRef comb] -> ShowS
forall comb. Show comb => GRef comb -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall comb. Show comb => Int -> GRef comb -> ShowS
showsPrec :: Int -> GRef comb -> ShowS
$cshow :: forall comb. Show comb => GRef comb -> [Char]
show :: GRef comb -> [Char]
$cshowList :: forall comb. Show comb => [GRef comb] -> ShowS
showList :: [GRef comb] -> ShowS
Show, (forall a b. (a -> b) -> GRef a -> GRef b)
-> (forall a b. a -> GRef b -> GRef a) -> Functor GRef
forall a b. a -> GRef b -> GRef a
forall a b. (a -> b) -> GRef a -> GRef b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> GRef a -> GRef b
fmap :: forall a b. (a -> b) -> GRef a -> GRef b
$c<$ :: forall a b. a -> GRef b -> GRef a
<$ :: forall a b. a -> GRef b -> GRef a
Functor, (forall m. Monoid m => GRef m -> m)
-> (forall m a. Monoid m => (a -> m) -> GRef a -> m)
-> (forall m a. Monoid m => (a -> m) -> GRef a -> m)
-> (forall a b. (a -> b -> b) -> b -> GRef a -> b)
-> (forall a b. (a -> b -> b) -> b -> GRef a -> b)
-> (forall b a. (b -> a -> b) -> b -> GRef a -> b)
-> (forall b a. (b -> a -> b) -> b -> GRef a -> b)
-> (forall a. (a -> a -> a) -> GRef a -> a)
-> (forall a. (a -> a -> a) -> GRef a -> a)
-> (forall a. GRef a -> [a])
-> (forall a. GRef a -> Bool)
-> (forall a. GRef a -> Int)
-> (forall a. Eq a => a -> GRef a -> Bool)
-> (forall a. Ord a => GRef a -> a)
-> (forall a. Ord a => GRef a -> a)
-> (forall a. Num a => GRef a -> a)
-> (forall a. Num a => GRef a -> a)
-> Foldable GRef
forall a. Eq a => a -> GRef a -> Bool
forall a. Num a => GRef a -> a
forall a. Ord a => GRef a -> a
forall m. Monoid m => GRef m -> m
forall a. GRef a -> Bool
forall a. GRef a -> Int
forall a. GRef a -> [a]
forall a. (a -> a -> a) -> GRef a -> a
forall m a. Monoid m => (a -> m) -> GRef a -> m
forall b a. (b -> a -> b) -> b -> GRef a -> b
forall a b. (a -> b -> b) -> b -> GRef a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => GRef m -> m
fold :: forall m. Monoid m => GRef m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> GRef a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> GRef a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> GRef a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> GRef a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> GRef a -> b
foldr :: forall a b. (a -> b -> b) -> b -> GRef a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> GRef a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> GRef a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> GRef a -> b
foldl :: forall b a. (b -> a -> b) -> b -> GRef a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> GRef a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> GRef a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> GRef a -> a
foldr1 :: forall a. (a -> a -> a) -> GRef a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> GRef a -> a
foldl1 :: forall a. (a -> a -> a) -> GRef a -> a
$ctoList :: forall a. GRef a -> [a]
toList :: forall a. GRef a -> [a]
$cnull :: forall a. GRef a -> Bool
null :: forall a. GRef a -> Bool
$clength :: forall a. GRef a -> Int
length :: forall a. GRef a -> Int
$celem :: forall a. Eq a => a -> GRef a -> Bool
elem :: forall a. Eq a => a -> GRef a -> Bool
$cmaximum :: forall a. Ord a => GRef a -> a
maximum :: forall a. Ord a => GRef a -> a
$cminimum :: forall a. Ord a => GRef a -> a
minimum :: forall a. Ord a => GRef a -> a
$csum :: forall a. Num a => GRef a -> a
sum :: forall a. Num a => GRef a -> a
$cproduct :: forall a. Num a => GRef a -> a
product :: forall a. Num a => GRef a -> a
Foldable, Functor GRef
Foldable GRef
(Functor GRef, Foldable GRef) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> GRef a -> f (GRef b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    GRef (f a) -> f (GRef a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> GRef a -> m (GRef b))
-> (forall (m :: * -> *) a. Monad m => GRef (m a) -> m (GRef a))
-> Traversable GRef
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => GRef (m a) -> m (GRef a)
forall (f :: * -> *) a. Applicative f => GRef (f a) -> f (GRef a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GRef a -> m (GRef b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GRef a -> f (GRef b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GRef a -> f (GRef b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GRef a -> f (GRef b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => GRef (f a) -> f (GRef a)
sequenceA :: forall (f :: * -> *) a. Applicative f => GRef (f a) -> f (GRef a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GRef a -> m (GRef b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GRef a -> m (GRef b)
$csequence :: forall (m :: * -> *) a. Monad m => GRef (m a) -> m (GRef a)
sequence :: forall (m :: * -> *) a. Monad m => GRef (m a) -> m (GRef a)
Traversable)

instance Eq (GRef comb) where
  GRef comb
a == :: GRef comb -> GRef comb -> Bool
== GRef comb
b = GRef comb -> GRef comb -> Ordering
forall a. Ord a => a -> a -> Ordering
compare GRef comb
a GRef comb
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance Ord (GRef comb) where
  compare :: GRef comb -> GRef comb -> Ordering
compare (Stk Int
a) (Stk Int
b) = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
a Int
b
  compare (Stk {}) GRef comb
_ = Ordering
LT
  compare GRef comb
_ (Stk {}) = Ordering
GT
  compare (Env CombIx
a comb
_) (Env CombIx
b comb
_) = CombIx -> CombIx -> Ordering
forall a. Ord a => a -> a -> Ordering
compare CombIx
a CombIx
b
  compare (Env {}) GRef comb
_ = Ordering
LT
  compare GRef comb
_ (Env {}) = Ordering
GT
  compare (Dyn Word64
a) (Dyn Word64
b) = Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word64
a Word64
b

type Branch = GBranch CombIx

type RBranch val = GBranch (RComb val)

-- | How many fields a match arm binds: the number of slots 'emitCase' lays
-- the arm's context out with. A data or request match's arm carries it
-- ('Arm'), because it is the one thing about an arm that the object being
-- matched cannot say: the interpreter pushes the object's own fields and
-- runs the arm only when their count is the arm's ('dataBranch'), and
-- native code reads the object's count (its pointer tag, or the lengths
-- of a wide constructor's arrays) and takes the arm only when the two
-- agree. The arms of a match on an unboxed value bind no fields (0).
type ConstructorArity = Int

-- | A case of a branch: the fields it binds and its code.
data Arm comb = Arm !ConstructorArity !(GSection comb)
  deriving stock (Int -> Arm comb -> ShowS
[Arm comb] -> ShowS
Arm comb -> [Char]
(Int -> Arm comb -> ShowS)
-> (Arm comb -> [Char]) -> ([Arm comb] -> ShowS) -> Show (Arm comb)
forall comb. Show comb => Int -> Arm comb -> ShowS
forall comb. Show comb => [Arm comb] -> ShowS
forall comb. Show comb => Arm comb -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall comb. Show comb => Int -> Arm comb -> ShowS
showsPrec :: Int -> Arm comb -> ShowS
$cshow :: forall comb. Show comb => Arm comb -> [Char]
show :: Arm comb -> [Char]
$cshowList :: forall comb. Show comb => [Arm comb] -> ShowS
showList :: [Arm comb] -> ShowS
Show, Arm comb -> Arm comb -> Bool
(Arm comb -> Arm comb -> Bool)
-> (Arm comb -> Arm comb -> Bool) -> Eq (Arm comb)
forall comb. Eq comb => Arm comb -> Arm comb -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall comb. Eq comb => Arm comb -> Arm comb -> Bool
== :: Arm comb -> Arm comb -> Bool
$c/= :: forall comb. Eq comb => Arm comb -> Arm comb -> Bool
/= :: Arm comb -> Arm comb -> Bool
Eq, Eq (Arm comb)
Eq (Arm comb) =>
(Arm comb -> Arm comb -> Ordering)
-> (Arm comb -> Arm comb -> Bool)
-> (Arm comb -> Arm comb -> Bool)
-> (Arm comb -> Arm comb -> Bool)
-> (Arm comb -> Arm comb -> Bool)
-> (Arm comb -> Arm comb -> Arm comb)
-> (Arm comb -> Arm comb -> Arm comb)
-> Ord (Arm comb)
Arm comb -> Arm comb -> Bool
Arm comb -> Arm comb -> Ordering
Arm comb -> Arm comb -> Arm comb
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
forall comb. Ord comb => Eq (Arm comb)
forall comb. Ord comb => Arm comb -> Arm comb -> Bool
forall comb. Ord comb => Arm comb -> Arm comb -> Ordering
forall comb. Ord comb => Arm comb -> Arm comb -> Arm comb
$ccompare :: forall comb. Ord comb => Arm comb -> Arm comb -> Ordering
compare :: Arm comb -> Arm comb -> Ordering
$c< :: forall comb. Ord comb => Arm comb -> Arm comb -> Bool
< :: Arm comb -> Arm comb -> Bool
$c<= :: forall comb. Ord comb => Arm comb -> Arm comb -> Bool
<= :: Arm comb -> Arm comb -> Bool
$c> :: forall comb. Ord comb => Arm comb -> Arm comb -> Bool
> :: Arm comb -> Arm comb -> Bool
$c>= :: forall comb. Ord comb => Arm comb -> Arm comb -> Bool
>= :: Arm comb -> Arm comb -> Bool
$cmax :: forall comb. Ord comb => Arm comb -> Arm comb -> Arm comb
max :: Arm comb -> Arm comb -> Arm comb
$cmin :: forall comb. Ord comb => Arm comb -> Arm comb -> Arm comb
min :: Arm comb -> Arm comb -> Arm comb
Ord, (forall a b. (a -> b) -> Arm a -> Arm b)
-> (forall a b. a -> Arm b -> Arm a) -> Functor Arm
forall a b. a -> Arm b -> Arm a
forall a b. (a -> b) -> Arm a -> Arm b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Arm a -> Arm b
fmap :: forall a b. (a -> b) -> Arm a -> Arm b
$c<$ :: forall a b. a -> Arm b -> Arm a
<$ :: forall a b. a -> Arm b -> Arm a
Functor, (forall m. Monoid m => Arm m -> m)
-> (forall m a. Monoid m => (a -> m) -> Arm a -> m)
-> (forall m a. Monoid m => (a -> m) -> Arm a -> m)
-> (forall a b. (a -> b -> b) -> b -> Arm a -> b)
-> (forall a b. (a -> b -> b) -> b -> Arm a -> b)
-> (forall b a. (b -> a -> b) -> b -> Arm a -> b)
-> (forall b a. (b -> a -> b) -> b -> Arm a -> b)
-> (forall a. (a -> a -> a) -> Arm a -> a)
-> (forall a. (a -> a -> a) -> Arm a -> a)
-> (forall a. Arm a -> [a])
-> (forall a. Arm a -> Bool)
-> (forall a. Arm a -> Int)
-> (forall a. Eq a => a -> Arm a -> Bool)
-> (forall a. Ord a => Arm a -> a)
-> (forall a. Ord a => Arm a -> a)
-> (forall a. Num a => Arm a -> a)
-> (forall a. Num a => Arm a -> a)
-> Foldable Arm
forall a. Eq a => a -> Arm a -> Bool
forall a. Num a => Arm a -> a
forall a. Ord a => Arm a -> a
forall m. Monoid m => Arm m -> m
forall a. Arm a -> Bool
forall a. Arm a -> Int
forall a. Arm a -> [a]
forall a. (a -> a -> a) -> Arm a -> a
forall m a. Monoid m => (a -> m) -> Arm a -> m
forall b a. (b -> a -> b) -> b -> Arm a -> b
forall a b. (a -> b -> b) -> b -> Arm a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Arm m -> m
fold :: forall m. Monoid m => Arm m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Arm a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Arm a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Arm a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Arm a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Arm a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Arm a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Arm a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Arm a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Arm a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Arm a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Arm a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Arm a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Arm a -> a
foldr1 :: forall a. (a -> a -> a) -> Arm a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Arm a -> a
foldl1 :: forall a. (a -> a -> a) -> Arm a -> a
$ctoList :: forall a. Arm a -> [a]
toList :: forall a. Arm a -> [a]
$cnull :: forall a. Arm a -> Bool
null :: forall a. Arm a -> Bool
$clength :: forall a. Arm a -> Int
length :: forall a. Arm a -> Int
$celem :: forall a. Eq a => a -> Arm a -> Bool
elem :: forall a. Eq a => a -> Arm a -> Bool
$cmaximum :: forall a. Ord a => Arm a -> a
maximum :: forall a. Ord a => Arm a -> a
$cminimum :: forall a. Ord a => Arm a -> a
minimum :: forall a. Ord a => Arm a -> a
$csum :: forall a. Num a => Arm a -> a
sum :: forall a. Num a => Arm a -> a
$cproduct :: forall a. Num a => Arm a -> a
product :: forall a. Num a => Arm a -> a
Foldable, Functor Arm
Foldable Arm
(Functor Arm, Foldable Arm) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Arm a -> f (Arm b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Arm (f a) -> f (Arm a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Arm a -> m (Arm b))
-> (forall (m :: * -> *) a. Monad m => Arm (m a) -> m (Arm a))
-> Traversable Arm
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Arm (m a) -> m (Arm a)
forall (f :: * -> *) a. Applicative f => Arm (f a) -> f (Arm a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Arm a -> m (Arm b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arm a -> f (Arm b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arm a -> f (Arm b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arm a -> f (Arm b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Arm (f a) -> f (Arm a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Arm (f a) -> f (Arm a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Arm a -> m (Arm b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Arm a -> m (Arm b)
$csequence :: forall (m :: * -> *) a. Monad m => Arm (m a) -> m (Arm a)
sequence :: forall (m :: * -> *) a. Monad m => Arm (m a) -> m (Arm a)
Traversable)

armSection :: Arm comb -> GSection comb
armSection :: forall comb. Arm comb -> GSection comb
armSection (Arm Int
_ GSection comb
s) = GSection comb
s
{-# INLINE armSection #-}

data GBranch comb
  = -- if tag == n then t else f
    Test1
      !Word64
      {-# UNPACK #-} !(Arm comb)
      !(GSection comb)
  | Test2
      !Word64
      {-# UNPACK #-} !(Arm comb) -- if tag == m then ...
      !Word64
      {-# UNPACK #-} !(Arm comb) -- else if tag == n then ...
      !(GSection comb) -- else ...
  | TestW
      !(GSection comb)
      !(EnumMap Word64 (Arm comb))
  | TestT
      !(GSection comb)
      !(M.Map Text (GSection comb))
  | TestY
      !(GSection comb)
      !(M.Map Bytes (GSection comb))
  deriving stock (Int -> GBranch comb -> ShowS
[GBranch comb] -> ShowS
GBranch comb -> [Char]
(Int -> GBranch comb -> ShowS)
-> (GBranch comb -> [Char])
-> ([GBranch comb] -> ShowS)
-> Show (GBranch comb)
forall comb. Show comb => Int -> GBranch comb -> ShowS
forall comb. Show comb => [GBranch comb] -> ShowS
forall comb. Show comb => GBranch comb -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall comb. Show comb => Int -> GBranch comb -> ShowS
showsPrec :: Int -> GBranch comb -> ShowS
$cshow :: forall comb. Show comb => GBranch comb -> [Char]
show :: GBranch comb -> [Char]
$cshowList :: forall comb. Show comb => [GBranch comb] -> ShowS
showList :: [GBranch comb] -> ShowS
Show, GBranch comb -> GBranch comb -> Bool
(GBranch comb -> GBranch comb -> Bool)
-> (GBranch comb -> GBranch comb -> Bool) -> Eq (GBranch comb)
forall comb. Eq comb => GBranch comb -> GBranch comb -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall comb. Eq comb => GBranch comb -> GBranch comb -> Bool
== :: GBranch comb -> GBranch comb -> Bool
$c/= :: forall comb. Eq comb => GBranch comb -> GBranch comb -> Bool
/= :: GBranch comb -> GBranch comb -> Bool
Eq, Eq (GBranch comb)
Eq (GBranch comb) =>
(GBranch comb -> GBranch comb -> Ordering)
-> (GBranch comb -> GBranch comb -> Bool)
-> (GBranch comb -> GBranch comb -> Bool)
-> (GBranch comb -> GBranch comb -> Bool)
-> (GBranch comb -> GBranch comb -> Bool)
-> (GBranch comb -> GBranch comb -> GBranch comb)
-> (GBranch comb -> GBranch comb -> GBranch comb)
-> Ord (GBranch comb)
GBranch comb -> GBranch comb -> Bool
GBranch comb -> GBranch comb -> Ordering
GBranch comb -> GBranch comb -> GBranch comb
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
forall comb. Ord comb => Eq (GBranch comb)
forall comb. Ord comb => GBranch comb -> GBranch comb -> Bool
forall comb. Ord comb => GBranch comb -> GBranch comb -> Ordering
forall comb.
Ord comb =>
GBranch comb -> GBranch comb -> GBranch comb
$ccompare :: forall comb. Ord comb => GBranch comb -> GBranch comb -> Ordering
compare :: GBranch comb -> GBranch comb -> Ordering
$c< :: forall comb. Ord comb => GBranch comb -> GBranch comb -> Bool
< :: GBranch comb -> GBranch comb -> Bool
$c<= :: forall comb. Ord comb => GBranch comb -> GBranch comb -> Bool
<= :: GBranch comb -> GBranch comb -> Bool
$c> :: forall comb. Ord comb => GBranch comb -> GBranch comb -> Bool
> :: GBranch comb -> GBranch comb -> Bool
$c>= :: forall comb. Ord comb => GBranch comb -> GBranch comb -> Bool
>= :: GBranch comb -> GBranch comb -> Bool
$cmax :: forall comb.
Ord comb =>
GBranch comb -> GBranch comb -> GBranch comb
max :: GBranch comb -> GBranch comb -> GBranch comb
$cmin :: forall comb.
Ord comb =>
GBranch comb -> GBranch comb -> GBranch comb
min :: GBranch comb -> GBranch comb -> GBranch comb
Ord, (forall a b. (a -> b) -> GBranch a -> GBranch b)
-> (forall a b. a -> GBranch b -> GBranch a) -> Functor GBranch
forall a b. a -> GBranch b -> GBranch a
forall a b. (a -> b) -> GBranch a -> GBranch b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> GBranch a -> GBranch b
fmap :: forall a b. (a -> b) -> GBranch a -> GBranch b
$c<$ :: forall a b. a -> GBranch b -> GBranch a
<$ :: forall a b. a -> GBranch b -> GBranch a
Functor, (forall m. Monoid m => GBranch m -> m)
-> (forall m a. Monoid m => (a -> m) -> GBranch a -> m)
-> (forall m a. Monoid m => (a -> m) -> GBranch a -> m)
-> (forall a b. (a -> b -> b) -> b -> GBranch a -> b)
-> (forall a b. (a -> b -> b) -> b -> GBranch a -> b)
-> (forall b a. (b -> a -> b) -> b -> GBranch a -> b)
-> (forall b a. (b -> a -> b) -> b -> GBranch a -> b)
-> (forall a. (a -> a -> a) -> GBranch a -> a)
-> (forall a. (a -> a -> a) -> GBranch a -> a)
-> (forall a. GBranch a -> [a])
-> (forall a. GBranch a -> Bool)
-> (forall a. GBranch a -> Int)
-> (forall a. Eq a => a -> GBranch a -> Bool)
-> (forall a. Ord a => GBranch a -> a)
-> (forall a. Ord a => GBranch a -> a)
-> (forall a. Num a => GBranch a -> a)
-> (forall a. Num a => GBranch a -> a)
-> Foldable GBranch
forall a. Eq a => a -> GBranch a -> Bool
forall a. Num a => GBranch a -> a
forall a. Ord a => GBranch a -> a
forall m. Monoid m => GBranch m -> m
forall a. GBranch a -> Bool
forall a. GBranch a -> Int
forall a. GBranch a -> [a]
forall a. (a -> a -> a) -> GBranch a -> a
forall m a. Monoid m => (a -> m) -> GBranch a -> m
forall b a. (b -> a -> b) -> b -> GBranch a -> b
forall a b. (a -> b -> b) -> b -> GBranch a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => GBranch m -> m
fold :: forall m. Monoid m => GBranch m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> GBranch a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> GBranch a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> GBranch a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> GBranch a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> GBranch a -> b
foldr :: forall a b. (a -> b -> b) -> b -> GBranch a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> GBranch a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> GBranch a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> GBranch a -> b
foldl :: forall b a. (b -> a -> b) -> b -> GBranch a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> GBranch a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> GBranch a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> GBranch a -> a
foldr1 :: forall a. (a -> a -> a) -> GBranch a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> GBranch a -> a
foldl1 :: forall a. (a -> a -> a) -> GBranch a -> a
$ctoList :: forall a. GBranch a -> [a]
toList :: forall a. GBranch a -> [a]
$cnull :: forall a. GBranch a -> Bool
null :: forall a. GBranch a -> Bool
$clength :: forall a. GBranch a -> Int
length :: forall a. GBranch a -> Int
$celem :: forall a. Eq a => a -> GBranch a -> Bool
elem :: forall a. Eq a => a -> GBranch a -> Bool
$cmaximum :: forall a. Ord a => GBranch a -> a
maximum :: forall a. Ord a => GBranch a -> a
$cminimum :: forall a. Ord a => GBranch a -> a
minimum :: forall a. Ord a => GBranch a -> a
$csum :: forall a. Num a => GBranch a -> a
sum :: forall a. Num a => GBranch a -> a
$cproduct :: forall a. Num a => GBranch a -> a
product :: forall a. Num a => GBranch a -> a
Foldable, Functor GBranch
Foldable GBranch
(Functor GBranch, Foldable GBranch) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> GBranch a -> f (GBranch b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    GBranch (f a) -> f (GBranch a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> GBranch a -> m (GBranch b))
-> (forall (m :: * -> *) a.
    Monad m =>
    GBranch (m a) -> m (GBranch a))
-> Traversable GBranch
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => GBranch (m a) -> m (GBranch a)
forall (f :: * -> *) a.
Applicative f =>
GBranch (f a) -> f (GBranch a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GBranch a -> m (GBranch b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GBranch a -> f (GBranch b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GBranch a -> f (GBranch b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GBranch a -> f (GBranch b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
GBranch (f a) -> f (GBranch a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
GBranch (f a) -> f (GBranch a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GBranch a -> m (GBranch b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GBranch a -> m (GBranch b)
$csequence :: forall (m :: * -> *) a. Monad m => GBranch (m a) -> m (GBranch a)
sequence :: forall (m :: * -> *) a. Monad m => GBranch (m a) -> m (GBranch a)
Traversable)

branchToEnumMap :: GBranch comb -> Maybe ((GSection comb), EnumMap Word64 (Arm comb))
branchToEnumMap :: forall comb.
GBranch comb -> Maybe (GSection comb, EnumMap Word64 (Arm comb))
branchToEnumMap = \case
  (Test1 Word64
k Arm comb
t GSection comb
d) -> (GSection comb, EnumMap Word64 (Arm comb))
-> Maybe (GSection comb, EnumMap Word64 (Arm comb))
forall a. a -> Maybe a
Just (GSection comb
d, Word64 -> Arm comb -> EnumMap Word64 (Arm comb)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
k Arm comb
t)
  (Test2 Word64
k1 Arm comb
s1 Word64
k2 Arm comb
s2 GSection comb
d) -> (GSection comb, EnumMap Word64 (Arm comb))
-> Maybe (GSection comb, EnumMap Word64 (Arm comb))
forall a. a -> Maybe a
Just (GSection comb
d, [(Word64, Arm comb)] -> EnumMap Word64 (Arm comb)
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
EC.mapFromList [(Word64
k1, Arm comb
s1), (Word64
k2, Arm comb
s2)])
  (TestW GSection comb
d EnumMap Word64 (Arm comb)
m) -> (GSection comb, EnumMap Word64 (Arm comb))
-> Maybe (GSection comb, EnumMap Word64 (Arm comb))
forall a. a -> Maybe a
Just (GSection comb
d, EnumMap Word64 (Arm comb)
m)
  GBranch comb
_ -> Maybe (GSection comb, EnumMap Word64 (Arm comb))
forall a. Maybe a
Nothing

-- Convenience patterns for matches used in the algorithms below.
pattern MatchW :: Int -> (GSection comb) -> EnumMap Word64 (GSection comb) -> (GSection comb)
pattern $mMatchW :: forall {r} {comb}.
GSection comb
-> (Int -> GSection comb -> EnumMap Word64 (GSection comb) -> r)
-> ((# #) -> r)
-> r
$bMatchW :: forall comb.
Int
-> GSection comb -> EnumMap Word64 (GSection comb) -> GSection comb
MatchW i d cs <- Match i (branchToEnumMap -> Just (d, fmap armSection -> cs))
  where
    MatchW Int
i GSection comb
d EnumMap Word64 (GSection comb)
cs = Int -> GBranch comb -> GSection comb
forall comb. Int -> GBranch comb -> GSection comb
Match Int
i (GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
forall comb.
GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
mkBranch GSection comb
d ((GSection comb -> Arm comb)
-> EnumMap Word64 (GSection comb) -> EnumMap Word64 (Arm comb)
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> GSection comb -> Arm comb
forall comb. Int -> GSection comb -> Arm comb
Arm Int
0) EnumMap Word64 (GSection comb)
cs))

pattern MatchT :: Int -> (GSection comb) -> M.Map Text (GSection comb) -> (GSection comb)
pattern $mMatchT :: forall {r} {comb}.
GSection comb
-> (Int -> GSection comb -> Map Text (GSection comb) -> r)
-> ((# #) -> r)
-> r
$bMatchT :: forall comb.
Int -> GSection comb -> Map Text (GSection comb) -> GSection comb
MatchT i d cs = Match i (TestT d cs)

pattern MatchY :: Int -> (GSection comb) -> M.Map Bytes (GSection comb) -> (GSection comb)
pattern $mMatchY :: forall {r} {comb}.
GSection comb
-> (Int -> GSection comb -> Map Bytes (GSection comb) -> r)
-> ((# #) -> r)
-> r
$bMatchY :: forall comb.
Int -> GSection comb -> Map Bytes (GSection comb) -> GSection comb
MatchY i d cs = Match i (TestY d cs)

pattern NMatchW ::
  Maybe Reference -> Int -> (GSection comb) -> EnumMap Word64 (GSection comb) -> (GSection comb)
pattern $mNMatchW :: forall {r} {comb}.
GSection comb
-> (Maybe Reference
    -> Int -> GSection comb -> EnumMap Word64 (GSection comb) -> r)
-> ((# #) -> r)
-> r
$bNMatchW :: forall comb.
Maybe Reference
-> Int
-> GSection comb
-> EnumMap Word64 (GSection comb)
-> GSection comb
NMatchW r i d cs <- NMatch r i (branchToEnumMap -> Just (d, fmap armSection -> cs))
  where
    NMatchW Maybe Reference
r Int
i GSection comb
d EnumMap Word64 (GSection comb)
cs = Maybe Reference -> Int -> GBranch comb -> GSection comb
forall comb.
Maybe Reference -> Int -> GBranch comb -> GSection comb
NMatch Maybe Reference
r Int
i (GBranch comb -> GSection comb) -> GBranch comb -> GSection comb
forall a b. (a -> b) -> a -> b
$ GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
forall comb.
GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
mkBranch GSection comb
d ((GSection comb -> Arm comb)
-> EnumMap Word64 (GSection comb) -> EnumMap Word64 (Arm comb)
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> GSection comb -> Arm comb
forall comb. Int -> GSection comb -> Arm comb
Arm Int
0) EnumMap Word64 (GSection comb)
cs)

mkBranch :: (GSection comb) -> (EnumMap Word64 (Arm comb)) -> GBranch comb
mkBranch :: forall comb.
GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
mkBranch GSection comb
d EnumMap Word64 (Arm comb)
m = case EnumMap Word64 (Arm comb) -> [(Word64, Arm comb)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (Arm comb)
m of
  [(Word64
k, Arm comb
v)] -> Word64 -> Arm comb -> GSection comb -> GBranch comb
forall comb. Word64 -> Arm comb -> GSection comb -> GBranch comb
Test1 Word64
k Arm comb
v GSection comb
d
  [(Word64
k1, Arm comb
v1), (Word64
k2, Arm comb
v2)] -> Word64
-> Arm comb -> Word64 -> Arm comb -> GSection comb -> GBranch comb
forall comb.
Word64
-> Arm comb -> Word64 -> Arm comb -> GSection comb -> GBranch comb
Test2 Word64
k1 Arm comb
v1 Word64
k2 Arm comb
v2 GSection comb
d
  [(Word64, Arm comb)]
_ -> GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
forall comb.
GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
TestW GSection comb
d EnumMap Word64 (Arm comb)
m

-- Representation of the variable context available in the current
-- frame. This tracks tags that have been dumped to the stack for
-- proper indexing. The `Block` constructor is used to mark when we
-- go into the first portion of a `Let`, to track the size of that
-- sub-frame.
data Ctx v
  = ECtx
  | -- | The boundary of a let's binding, which runs in a frame of its
    -- own: the index of the let's body section (the frame below is the
    -- let's, 'chainOf')
    Block !Word64 (Ctx v)
  | Tag (Ctx v)
  | Var v Mem (Ctx v)
  | -- | A wide variable (Unison.Runtime.Wide, a 'WD' binder): 'wideWidth'
    -- slots, the value slot on top, resolved to that slot.
    Wide v Mem (Ctx v)
  deriving (Int -> Ctx v -> ShowS
[Ctx v] -> ShowS
Ctx v -> [Char]
(Int -> Ctx v -> ShowS)
-> (Ctx v -> [Char]) -> ([Ctx v] -> ShowS) -> Show (Ctx v)
forall v. Show v => Int -> Ctx v -> ShowS
forall v. Show v => [Ctx v] -> ShowS
forall v. Show v => Ctx v -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall v. Show v => Int -> Ctx v -> ShowS
showsPrec :: Int -> Ctx v -> ShowS
$cshow :: forall v. Show v => Ctx v -> [Char]
show :: Ctx v -> [Char]
$cshowList :: forall v. Show v => [Ctx v] -> ShowS
showList :: [Ctx v] -> ShowS
Show)

-- Represents the context formed by the top-level let rec around a
-- set of definitions. Previous steps have normalized the term to
-- only contain a single recursive binding group. The variables in
-- this binding group are resolved to numbered combinators rather
-- than stack positions.
data RCtx v = RCtx
  { forall v. RCtx v -> Map v Word64
rctxCombs :: M.Map v Word64,
    -- | for a lambda the explosion rewrote: its unoptimized form, which
    -- the frames of a continuation are written out as ('deoptOf')
    forall v. RCtx v -> Maybe (BaseInfo v)
rctxBase :: Maybe (BaseInfo v)
  }

emptyRCtx :: RCtx v
emptyRCtx :: forall v. RCtx v
emptyRCtx = Map v Word64 -> Maybe (BaseInfo v) -> RCtx v
forall v. Map v Word64 -> Maybe (BaseInfo v) -> RCtx v
RCtx Map v Word64
forall k a. Map k a
M.empty Maybe (BaseInfo v)
forall a. Maybe a
Nothing

-- | What the emitter of a rewritten lambda knows about the unoptimized
-- lambda it stands for, for 'deoptOf': the unoptimized body's lets by
-- their binders, with the section index each got; the frames of each
-- unoptimized section ('chainOf', collected as the unoptimized lambda was
-- emitted); the products the unoptimized body builds, by variable
-- ('conLets'); where its variables went and which lets the rewrite
-- changed ('Prepared'); the rewritten body's own lets by section index;
-- and, for a join point (Unison.Runtime.MCode.Explode, 'Join'), the
-- binders of the unoptimized let whose binding its site was in, where
-- its frames stop, and the flag, since a variable a join point's frame
-- cannot rebuild is one the unoptimized code never reads there; and the
-- variables the rewrite found dead wherever a frame holds them
-- ('preparedDead').
data BaseInfo v = BaseInfo
  { forall v. BaseInfo v -> Map [v] Word64
baseLets :: M.Map [v] Word64,
    forall v. BaseInfo v -> EnumMap Word64 (Chain v)
baseChains :: EC.EnumMap Word64 (Chain v),
    forall v. BaseInfo v -> Map v (Built v)
baseCons :: M.Map v (Built v),
    forall v. BaseInfo v -> Sources v
baseSources :: Sources v,
    forall v. BaseInfo v -> Map [v] [v]
baseLetOf :: M.Map [v] [v],
    forall v. BaseInfo v -> EnumMap Word64 [v]
optLets :: EC.EnumMap Word64 [v],
    forall v. BaseInfo v -> Maybe [v]
baseCut :: Maybe [v],
    forall v. BaseInfo v -> Bool
baseJoin :: Bool,
    forall v. BaseInfo v -> Set v
baseDead :: Set v
  }

-- | The frames a context spans, innermost first, each as the index of
-- the let whose frame it is (none for the innermost, which is the frame
-- of the section being recorded) and its narrowed slots from the top: a
-- variable's, or the tag slot of an unboxed sum.
type Chain v = [(Maybe Word64, [Entry v])]

data Entry v = EVar v | ETag
  deriving (Entry v -> Entry v -> Bool
(Entry v -> Entry v -> Bool)
-> (Entry v -> Entry v -> Bool) -> Eq (Entry v)
forall v. Eq v => Entry v -> Entry v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall v. Eq v => Entry v -> Entry v -> Bool
== :: Entry v -> Entry v -> Bool
$c/= :: forall v. Eq v => Entry v -> Entry v -> Bool
/= :: Entry v -> Entry v -> Bool
Eq, Int -> Entry v -> ShowS
[Entry v] -> ShowS
Entry v -> [Char]
(Int -> Entry v -> ShowS)
-> (Entry v -> [Char]) -> ([Entry v] -> ShowS) -> Show (Entry v)
forall v. Show v => Int -> Entry v -> ShowS
forall v. Show v => [Entry v] -> ShowS
forall v. Show v => Entry v -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall v. Show v => Int -> Entry v -> ShowS
showsPrec :: Int -> Entry v -> ShowS
$cshow :: forall v. Show v => Entry v -> [Char]
show :: Entry v -> [Char]
$cshowList :: forall v. Show v => [Entry v] -> ShowS
showList :: [Entry v] -> ShowS
Show)

chainOf :: Ctx v -> Chain v
chainOf :: forall v. Ctx v -> Chain v
chainOf = Maybe Word64 -> [Entry v] -> Ctx v -> [(Maybe Word64, [Entry v])]
forall {v}.
Maybe Word64 -> [Entry v] -> Ctx v -> [(Maybe Word64, [Entry v])]
go Maybe Word64
forall a. Maybe a
Nothing []
  where
    go :: Maybe Word64 -> [Entry v] -> Ctx v -> [(Maybe Word64, [Entry v])]
go Maybe Word64
lbl [Entry v]
acc Ctx v
ECtx = [(Maybe Word64
lbl, [Entry v] -> [Entry v]
forall a. [a] -> [a]
reverse [Entry v]
acc)]
    go Maybe Word64
lbl [Entry v]
acc (Block Word64
w Ctx v
ctx) = (Maybe Word64
lbl, [Entry v] -> [Entry v]
forall a. [a] -> [a]
reverse [Entry v]
acc) (Maybe Word64, [Entry v])
-> [(Maybe Word64, [Entry v])] -> [(Maybe Word64, [Entry v])]
forall a. a -> [a] -> [a]
: Maybe Word64 -> [Entry v] -> Ctx v -> [(Maybe Word64, [Entry v])]
go (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
w) [] Ctx v
ctx
    go Maybe Word64
lbl [Entry v]
acc (Tag Ctx v
ctx) = Maybe Word64 -> [Entry v] -> Ctx v -> [(Maybe Word64, [Entry v])]
go Maybe Word64
lbl (Entry v
forall v. Entry v
ETag Entry v -> [Entry v] -> [Entry v]
forall a. a -> [a] -> [a]
: [Entry v]
acc) Ctx v
ctx
    go Maybe Word64
lbl [Entry v]
acc (Var v
v Mem
_ Ctx v
ctx) = Maybe Word64 -> [Entry v] -> Ctx v -> [(Maybe Word64, [Entry v])]
go Maybe Word64
lbl (v -> Entry v
forall v. v -> Entry v
EVar v
v Entry v -> [Entry v] -> [Entry v]
forall a. a -> [a] -> [a]
: [Entry v]
acc) Ctx v
ctx
    go Maybe Word64
lbl [Entry v]
acc (Wide v
v Mem
_ Ctx v
ctx) = Maybe Word64 -> [Entry v] -> Ctx v -> [(Maybe Word64, [Entry v])]
go Maybe Word64
lbl (v -> Entry v
forall v. v -> Entry v
EVar v
v Entry v -> [Entry v] -> [Entry v]
forall a. a -> [a] -> [a]
: [Entry v]
acc) Ctx v
ctx

-- Add a sequence of variables and corresponding calling conventions
-- to the context.
ctx :: [v] -> [Mem] -> Ctx v
ctx :: forall v. [v] -> [Mem] -> Ctx v
ctx [v]
vs [Mem]
cs = [(v, Mem)] -> Ctx v -> Ctx v
forall v. [(v, Mem)] -> Ctx v -> Ctx v
pushCtx ([v] -> [Mem] -> [(v, Mem)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
vs [Mem]
cs) Ctx v
forall v. Ctx v
ECtx

-- Look up a variable in the context, getting its position on the
-- relevant stack and its calling convention if it is there.
ctxResolve :: (Var v) => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve :: forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v = Int -> Ctx v -> Maybe (Int, Mem)
walk Int
0 Ctx v
ctx
  where
    walk :: Int -> Ctx v -> Maybe (Int, Mem)
walk Int
_ Ctx v
ECtx = Maybe (Int, Mem)
forall a. Maybe a
Nothing
    walk Int
i (Block Word64
_ Ctx v
ctx) = Int -> Ctx v -> Maybe (Int, Mem)
walk Int
i Ctx v
ctx
    walk Int
i (Tag Ctx v
ctx) = Int -> Ctx v -> Maybe (Int, Mem)
walk (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Ctx v
ctx
    walk Int
i (Var v
x Mem
m Ctx v
ctx)
      | v
v v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
x = (Int, Mem) -> Maybe (Int, Mem)
forall a. a -> Maybe a
Just (Int
i, Mem
m)
      | Bool
otherwise = Int -> Ctx v -> Maybe (Int, Mem)
walk (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Ctx v
ctx
    walk Int
i (Wide v
x Mem
m Ctx v
ctx)
      | v
v v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
x = (Int, Mem) -> Maybe (Int, Mem)
forall a. a -> Maybe a
Just (Int
i, Mem
m)
      | Bool
otherwise = Int -> Ctx v -> Maybe (Int, Mem)
walk (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wideWidth) Ctx v
ctx

-- | Whether a variable's nearest binding in the context is wide.
ctxWide :: (Var v) => Ctx v -> v -> Bool
ctxWide :: forall v. Var v => Ctx v -> v -> Bool
ctxWide Ctx v
ctx v
v = Ctx v -> Bool
walk Ctx v
ctx
  where
    walk :: Ctx v -> Bool
walk Ctx v
ECtx = Bool
False
    walk (Block Word64
_ Ctx v
ctx) = Ctx v -> Bool
walk Ctx v
ctx
    walk (Tag Ctx v
ctx) = Ctx v -> Bool
walk Ctx v
ctx
    walk (Var v
x Mem
_ Ctx v
ctx)
      | v
v v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
x = Bool
False
      | Bool
otherwise = Ctx v -> Bool
walk Ctx v
ctx
    walk (Wide v
x Mem
_ Ctx v
ctx)
      | v
v v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
x = Bool
True
      | Bool
otherwise = Ctx v -> Bool
walk Ctx v
ctx

-- | Add a sequence of variables and calling conventions to the context:
-- a 'WD' binder (Unison.Runtime.MCode.Wide) as a wide entry, boxed, the
-- others as one slot each.
pushCtx :: [(v, Mem)] -> Ctx v -> Ctx v
pushCtx :: forall v. [(v, Mem)] -> Ctx v -> Ctx v
pushCtx [(v, Mem)]
new Ctx v
old = ((v, Mem) -> Ctx v -> Ctx v) -> Ctx v -> [(v, Mem)] -> Ctx v
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (v, Mem) -> Ctx v -> Ctx v
forall {v}. (v, Mem) -> Ctx v -> Ctx v
push Ctx v
old [(v, Mem)]
new
  where
    push :: (v, Mem) -> Ctx v -> Ctx v
push (v
v, Mem
WD) = v -> Mem -> Ctx v -> Ctx v
forall v. v -> Mem -> Ctx v -> Ctx v
Wide v
v Mem
BX
    push (v
v, Mem
m) = v -> Mem -> Ctx v -> Ctx v
forall v. v -> Mem -> Ctx v -> Ctx v
Var v
v Mem
m

-- Concatenate two contexts
catCtx :: Ctx v -> Ctx v -> Ctx v
catCtx :: forall v. Ctx v -> Ctx v -> Ctx v
catCtx Ctx v
ECtx Ctx v
r = Ctx v
r
catCtx (Tag Ctx v
l) Ctx v
r = Ctx v -> Ctx v
forall v. Ctx v -> Ctx v
Tag (Ctx v -> Ctx v) -> Ctx v -> Ctx v
forall a b. (a -> b) -> a -> b
$ Ctx v -> Ctx v -> Ctx v
forall v. Ctx v -> Ctx v -> Ctx v
catCtx Ctx v
l Ctx v
r
catCtx (Block Word64
w Ctx v
l) Ctx v
r = Word64 -> Ctx v -> Ctx v
forall v. Word64 -> Ctx v -> Ctx v
Block Word64
w (Ctx v -> Ctx v) -> Ctx v -> Ctx v
forall a b. (a -> b) -> a -> b
$ Ctx v -> Ctx v -> Ctx v
forall v. Ctx v -> Ctx v -> Ctx v
catCtx Ctx v
l Ctx v
r
catCtx (Var v
v Mem
m Ctx v
l) Ctx v
r = v -> Mem -> Ctx v -> Ctx v
forall v. v -> Mem -> Ctx v -> Ctx v
Var v
v Mem
m (Ctx v -> Ctx v) -> Ctx v -> Ctx v
forall a b. (a -> b) -> a -> b
$ Ctx v -> Ctx v -> Ctx v
forall v. Ctx v -> Ctx v -> Ctx v
catCtx Ctx v
l Ctx v
r
catCtx (Wide v
v Mem
m Ctx v
l) Ctx v
r = v -> Mem -> Ctx v -> Ctx v
forall v. v -> Mem -> Ctx v -> Ctx v
Wide v
v Mem
m (Ctx v -> Ctx v) -> Ctx v -> Ctx v
forall a b. (a -> b) -> a -> b
$ Ctx v -> Ctx v -> Ctx v
forall v. Ctx v -> Ctx v -> Ctx v
catCtx Ctx v
l Ctx v
r

-- Split the context after a particular variable
breakAfter :: (Eq v) => (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
breakAfter :: forall v. Eq v => (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
breakAfter v -> Bool
_ Ctx v
ECtx = (Ctx v
forall v. Ctx v
ECtx, Ctx v
forall v. Ctx v
ECtx)
breakAfter v -> Bool
p (Tag Ctx v
vs) = (Ctx v -> Ctx v) -> (Ctx v, Ctx v) -> (Ctx v, Ctx v)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Ctx v -> Ctx v
forall v. Ctx v -> Ctx v
Tag ((Ctx v, Ctx v) -> (Ctx v, Ctx v))
-> (Ctx v, Ctx v) -> (Ctx v, Ctx v)
forall a b. (a -> b) -> a -> b
$ (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
forall v. Eq v => (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
breakAfter v -> Bool
p Ctx v
vs
breakAfter v -> Bool
p (Block Word64
w Ctx v
vs) = (Ctx v -> Ctx v) -> (Ctx v, Ctx v) -> (Ctx v, Ctx v)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Word64 -> Ctx v -> Ctx v
forall v. Word64 -> Ctx v -> Ctx v
Block Word64
w) ((Ctx v, Ctx v) -> (Ctx v, Ctx v))
-> (Ctx v, Ctx v) -> (Ctx v, Ctx v)
forall a b. (a -> b) -> a -> b
$ (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
forall v. Eq v => (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
breakAfter v -> Bool
p Ctx v
vs
breakAfter v -> Bool
p (Var v
v Mem
m Ctx v
vs) = (v -> Mem -> Ctx v -> Ctx v
forall v. v -> Mem -> Ctx v -> Ctx v
Var v
v Mem
m Ctx v
lvs, Ctx v
rvs)
  where
    (Ctx v
lvs, Ctx v
rvs)
      | v -> Bool
p v
v = (Ctx v
forall v. Ctx v
ECtx, Ctx v
vs)
      | Bool
otherwise = (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
forall v. Eq v => (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
breakAfter v -> Bool
p Ctx v
vs
breakAfter v -> Bool
p (Wide v
v Mem
m Ctx v
vs) = (v -> Mem -> Ctx v -> Ctx v
forall v. v -> Mem -> Ctx v -> Ctx v
Wide v
v Mem
m Ctx v
lvs, Ctx v
rvs)
  where
    (Ctx v
lvs, Ctx v
rvs)
      | v -> Bool
p v
v = (Ctx v
forall v. Ctx v
ECtx, Ctx v
vs)
      | Bool
otherwise = (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
forall v. Eq v => (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
breakAfter v -> Bool
p Ctx v
vs

-- | The wide variables of a frame: the index of each one's value slot,
-- counting from the top of the context, in increasing order, with the
-- variable's width in slots. This is what a serialized continuation needs
-- to map the frame's variables to its slots (reflectValue0 and reifyValue0
-- in Machine.hs). Every width is 'wideWidth' today; the table allows a
-- width per variable.
wideSlots :: Ctx v -> [(Int, Int)]
wideSlots :: forall v. Ctx v -> [(Int, Int)]
wideSlots = Int -> Ctx v -> [(Int, Int)]
forall {v}. Int -> Ctx v -> [(Int, Int)]
go Int
0
  where
    go :: Int -> Ctx v -> [(Int, Int)]
go !Int
_ Ctx v
ECtx = []
    go Int
i (Block Word64
_ Ctx v
ctx) = Int -> Ctx v -> [(Int, Int)]
go Int
i Ctx v
ctx
    go Int
i (Tag Ctx v
ctx) = Int -> Ctx v -> [(Int, Int)]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Ctx v
ctx
    go Int
i (Var v
_ Mem
_ Ctx v
ctx) = Int -> Ctx v -> [(Int, Int)]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Ctx v
ctx
    go Int
i (Wide v
_ Mem
_ Ctx v
ctx) = (Int
i, Int
wideWidth) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
: Int -> Ctx v -> [(Int, Int)]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wideWidth) Ctx v
ctx

-- | What a let body's combinator knows about the frame it is resumed
-- over: the wide variables of the frame, each as (the index of its value
-- slot from the top of the frame, its width in slots), in increasing
-- order; and, for a section the explosion rewrote, the frames the
-- unoptimized code has at this point, for a continuation written out
-- ('Deopt').
data FrameLayout = FrameLayout
  { FrameLayout -> [(Int, Int)]
wideVars :: [(Int, Int)],
    FrameLayout -> Maybe Deopt
baseFrames :: Maybe Deopt,
    -- | the depth of the context at the let, in slots, counting the
    -- enclosing frames when the let is inside a binding: the frame's slot
    -- @j@ from the top is offset @frameDepth - j@ in the liveness of the
    -- body ('Unison.Runtime.MCode.Live', used by the serializer)
    FrameLayout -> Int
frameDepth :: Int,
    -- | how many lets of the same function the let is inside the binding
    -- of: that many Push frames outward in a continuation are the frames
    -- of those lets, which this section's code reads into
    FrameLayout -> Int
enclosingLets :: Int
  }
  deriving (Int -> FrameLayout -> ShowS
[FrameLayout] -> ShowS
FrameLayout -> [Char]
(Int -> FrameLayout -> ShowS)
-> (FrameLayout -> [Char])
-> ([FrameLayout] -> ShowS)
-> Show FrameLayout
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FrameLayout -> ShowS
showsPrec :: Int -> FrameLayout -> ShowS
$cshow :: FrameLayout -> [Char]
show :: FrameLayout -> [Char]
$cshowList :: [FrameLayout] -> ShowS
showList :: [FrameLayout] -> ShowS
Show, FrameLayout -> FrameLayout -> Bool
(FrameLayout -> FrameLayout -> Bool)
-> (FrameLayout -> FrameLayout -> Bool) -> Eq FrameLayout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FrameLayout -> FrameLayout -> Bool
== :: FrameLayout -> FrameLayout -> Bool
$c/= :: FrameLayout -> FrameLayout -> Bool
/= :: FrameLayout -> FrameLayout -> Bool
Eq, Eq FrameLayout
Eq FrameLayout =>
(FrameLayout -> FrameLayout -> Ordering)
-> (FrameLayout -> FrameLayout -> Bool)
-> (FrameLayout -> FrameLayout -> Bool)
-> (FrameLayout -> FrameLayout -> Bool)
-> (FrameLayout -> FrameLayout -> Bool)
-> (FrameLayout -> FrameLayout -> FrameLayout)
-> (FrameLayout -> FrameLayout -> FrameLayout)
-> Ord FrameLayout
FrameLayout -> FrameLayout -> Bool
FrameLayout -> FrameLayout -> Ordering
FrameLayout -> FrameLayout -> FrameLayout
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 :: FrameLayout -> FrameLayout -> Ordering
compare :: FrameLayout -> FrameLayout -> Ordering
$c< :: FrameLayout -> FrameLayout -> Bool
< :: FrameLayout -> FrameLayout -> Bool
$c<= :: FrameLayout -> FrameLayout -> Bool
<= :: FrameLayout -> FrameLayout -> Bool
$c> :: FrameLayout -> FrameLayout -> Bool
> :: FrameLayout -> FrameLayout -> Bool
$c>= :: FrameLayout -> FrameLayout -> Bool
>= :: FrameLayout -> FrameLayout -> Bool
$cmax :: FrameLayout -> FrameLayout -> FrameLayout
max :: FrameLayout -> FrameLayout -> FrameLayout
$cmin :: FrameLayout -> FrameLayout -> FrameLayout
min :: FrameLayout -> FrameLayout -> FrameLayout
Ord)

emptyLayout :: FrameLayout
emptyLayout :: FrameLayout
emptyLayout = [(Int, Int)] -> Maybe Deopt -> Int -> Int -> FrameLayout
FrameLayout [] Maybe Deopt
forall a. Maybe a
Nothing Int
0 Int
0

-- | The slots a frame layout adds over one per variable, for a frame
-- that holds n variables. A section inside a let's binding lists the
-- wide variables of the enclosing frames too, below its own slots
-- ('wideSlots' walks the whole context), and those are not this frame's:
-- a wide variable at wide index i is the frame's when its narrow index,
-- i less the padding of the wide variables above it, is below n. (Until
-- 2026-11-02 every listed variable counted, so a frame inside a binding
-- with a wide variable in the enclosing frame came up short.)
layoutPadding :: Int -> FrameLayout -> Int
layoutPadding :: Int -> FrameLayout -> Int
layoutPadding Int
n FrameLayout
lay = Int -> [(Int, Int)] -> Int
go Int
0 (FrameLayout -> [(Int, Int)]
wideVars FrameLayout
lay)
  where
    go :: Int -> [(Int, Int)] -> Int
go Int
pad ((Int
i, Int
w) : [(Int, Int)]
ws) | Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pad Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = Int -> [(Int, Int)] -> Int
go (Int
pad Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [(Int, Int)]
ws
    go Int
pad [(Int, Int)]
_ = Int
pad

-- | The same for a frame of f slots, wide.
widePadding :: Int -> FrameLayout -> Int
widePadding :: Int -> FrameLayout -> Int
widePadding Int
f FrameLayout
lay = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 | (Int
i, Int
w) <- FrameLayout -> [(Int, Int)]
wideVars FrameLayout
lay, Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
f]

-- | How a continuation's frame for a section the explosion rewrote is
-- written out as the frames the unoptimized code has at that point
-- (design.md, "Continuations across processes"; built by 'deoptOf',
-- applied by 'Unison.Runtime.Machine.deoptCont'). The frames come
-- innermost first, each as the index of the unoptimized section it
-- resumes, in the group, and its slots from the top; a let whose binding
-- the rewrite moved into the enclosing frame ('sinkCalls') gives two, the
-- binding's and the let's, and the optimized frame's pending arguments go
-- with the last. A slot is copied from the optimized frames, by frame (0
-- this one, 1 the enclosing let's, counting the continuation's Push
-- frames outward) and narrowed index from the top, or is a product the
-- optimized code no longer holds, packed from such slots, or is dead, a
-- slot the unoptimized code never reads there, written as unit.
data Deopt = Deopt [BaseFrame]
  deriving (Int -> Deopt -> ShowS
[Deopt] -> ShowS
Deopt -> [Char]
(Int -> Deopt -> ShowS)
-> (Deopt -> [Char]) -> ([Deopt] -> ShowS) -> Show Deopt
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Deopt -> ShowS
showsPrec :: Int -> Deopt -> ShowS
$cshow :: Deopt -> [Char]
show :: Deopt -> [Char]
$cshowList :: [Deopt] -> ShowS
showList :: [Deopt] -> ShowS
Show, Deopt -> Deopt -> Bool
(Deopt -> Deopt -> Bool) -> (Deopt -> Deopt -> Bool) -> Eq Deopt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Deopt -> Deopt -> Bool
== :: Deopt -> Deopt -> Bool
$c/= :: Deopt -> Deopt -> Bool
/= :: Deopt -> Deopt -> Bool
Eq, Eq Deopt
Eq Deopt =>
(Deopt -> Deopt -> Ordering)
-> (Deopt -> Deopt -> Bool)
-> (Deopt -> Deopt -> Bool)
-> (Deopt -> Deopt -> Bool)
-> (Deopt -> Deopt -> Bool)
-> (Deopt -> Deopt -> Deopt)
-> (Deopt -> Deopt -> Deopt)
-> Ord Deopt
Deopt -> Deopt -> Bool
Deopt -> Deopt -> Ordering
Deopt -> Deopt -> Deopt
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 :: Deopt -> Deopt -> Ordering
compare :: Deopt -> Deopt -> Ordering
$c< :: Deopt -> Deopt -> Bool
< :: Deopt -> Deopt -> Bool
$c<= :: Deopt -> Deopt -> Bool
<= :: Deopt -> Deopt -> Bool
$c> :: Deopt -> Deopt -> Bool
> :: Deopt -> Deopt -> Bool
$c>= :: Deopt -> Deopt -> Bool
>= :: Deopt -> Deopt -> Bool
$cmax :: Deopt -> Deopt -> Deopt
max :: Deopt -> Deopt -> Deopt
$cmin :: Deopt -> Deopt -> Deopt
min :: Deopt -> Deopt -> Deopt
Ord)

data BaseFrame = BaseFrame !Word64 [Slot]
  deriving (Int -> BaseFrame -> ShowS
[BaseFrame] -> ShowS
BaseFrame -> [Char]
(Int -> BaseFrame -> ShowS)
-> (BaseFrame -> [Char])
-> ([BaseFrame] -> ShowS)
-> Show BaseFrame
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BaseFrame -> ShowS
showsPrec :: Int -> BaseFrame -> ShowS
$cshow :: BaseFrame -> [Char]
show :: BaseFrame -> [Char]
$cshowList :: [BaseFrame] -> ShowS
showList :: [BaseFrame] -> ShowS
Show, BaseFrame -> BaseFrame -> Bool
(BaseFrame -> BaseFrame -> Bool)
-> (BaseFrame -> BaseFrame -> Bool) -> Eq BaseFrame
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BaseFrame -> BaseFrame -> Bool
== :: BaseFrame -> BaseFrame -> Bool
$c/= :: BaseFrame -> BaseFrame -> Bool
/= :: BaseFrame -> BaseFrame -> Bool
Eq, Eq BaseFrame
Eq BaseFrame =>
(BaseFrame -> BaseFrame -> Ordering)
-> (BaseFrame -> BaseFrame -> Bool)
-> (BaseFrame -> BaseFrame -> Bool)
-> (BaseFrame -> BaseFrame -> Bool)
-> (BaseFrame -> BaseFrame -> Bool)
-> (BaseFrame -> BaseFrame -> BaseFrame)
-> (BaseFrame -> BaseFrame -> BaseFrame)
-> Ord BaseFrame
BaseFrame -> BaseFrame -> Bool
BaseFrame -> BaseFrame -> Ordering
BaseFrame -> BaseFrame -> BaseFrame
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 :: BaseFrame -> BaseFrame -> Ordering
compare :: BaseFrame -> BaseFrame -> Ordering
$c< :: BaseFrame -> BaseFrame -> Bool
< :: BaseFrame -> BaseFrame -> Bool
$c<= :: BaseFrame -> BaseFrame -> Bool
<= :: BaseFrame -> BaseFrame -> Bool
$c> :: BaseFrame -> BaseFrame -> Bool
> :: BaseFrame -> BaseFrame -> Bool
$c>= :: BaseFrame -> BaseFrame -> Bool
>= :: BaseFrame -> BaseFrame -> Bool
$cmax :: BaseFrame -> BaseFrame -> BaseFrame
max :: BaseFrame -> BaseFrame -> BaseFrame
$cmin :: BaseFrame -> BaseFrame -> BaseFrame
min :: BaseFrame -> BaseFrame -> BaseFrame
Ord)

data Slot
  = Copy !Int !Int
  | PackSlot !PackedTag [Slot]
  | RecSlot !RecordShape [Slot]
  | Dead
  deriving (Int -> Slot -> ShowS
[Slot] -> ShowS
Slot -> [Char]
(Int -> Slot -> ShowS)
-> (Slot -> [Char]) -> ([Slot] -> ShowS) -> Show Slot
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Slot -> ShowS
showsPrec :: Int -> Slot -> ShowS
$cshow :: Slot -> [Char]
show :: Slot -> [Char]
$cshowList :: [Slot] -> ShowS
showList :: [Slot] -> ShowS
Show, Slot -> Slot -> Bool
(Slot -> Slot -> Bool) -> (Slot -> Slot -> Bool) -> Eq Slot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Slot -> Slot -> Bool
== :: Slot -> Slot -> Bool
$c/= :: Slot -> Slot -> Bool
/= :: Slot -> Slot -> Bool
Eq, Eq Slot
Eq Slot =>
(Slot -> Slot -> Ordering)
-> (Slot -> Slot -> Bool)
-> (Slot -> Slot -> Bool)
-> (Slot -> Slot -> Bool)
-> (Slot -> Slot -> Bool)
-> (Slot -> Slot -> Slot)
-> (Slot -> Slot -> Slot)
-> Ord Slot
Slot -> Slot -> Bool
Slot -> Slot -> Ordering
Slot -> Slot -> Slot
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 :: Slot -> Slot -> Ordering
compare :: Slot -> Slot -> Ordering
$c< :: Slot -> Slot -> Bool
< :: Slot -> Slot -> Bool
$c<= :: Slot -> Slot -> Bool
<= :: Slot -> Slot -> Bool
$c> :: Slot -> Slot -> Bool
> :: Slot -> Slot -> Bool
$c>= :: Slot -> Slot -> Bool
>= :: Slot -> Slot -> Bool
$cmax :: Slot -> Slot -> Slot
max :: Slot -> Slot -> Slot
$cmin :: Slot -> Slot -> Slot
min :: Slot -> Slot -> Slot
Ord)

-- Modify the context to contain the variables introduced by an
-- unboxed sum
sumCtx :: (Var v) => Ctx v -> v -> [(v, Mem)] -> Ctx v
sumCtx :: forall v. Var v => Ctx v -> v -> [(v, Mem)] -> Ctx v
sumCtx Ctx v
ctx v
v [(v, Mem)]
vcs
  | (Ctx v
lctx, Ctx v
rctx) <- (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
forall v. Eq v => (v -> Bool) -> Ctx v -> (Ctx v, Ctx v)
breakAfter (v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v) Ctx v
ctx =
      Ctx v -> Ctx v -> Ctx v
forall v. Ctx v -> Ctx v -> Ctx v
catCtx Ctx v
lctx (Ctx v -> Ctx v) -> Ctx v -> Ctx v
forall a b. (a -> b) -> a -> b
$ [(v, Mem)] -> Ctx v -> Ctx v
forall v. [(v, Mem)] -> Ctx v -> Ctx v
pushCtx [(v, Mem)]
vcs Ctx v
rctx

-- Look up a variable in the top let rec context
rctxResolve :: (Var v) => RCtx v -> v -> Maybe Word64
rctxResolve :: forall v. Var v => RCtx v -> v -> Maybe Word64
rctxResolve RCtx v
ctx v
u = v -> Map v Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup v
u (RCtx v -> Map v Word64
forall v. RCtx v -> Map v Word64
rctxCombs RCtx v
ctx)

-- convenient alias for our most used type
type RNormal = ANormal Reference

-- Compile a top-level definition group to a collection of combinators.
-- The provided word refers to the numbering for the overall group,
-- and intra-group calls are numbered locally, with 0 specifying
-- the global entry point.

-- | The combinators of a group, under its number, and, when the explosion
-- rewrote any of its lambdas so that a frame differs, the group as the
-- unoptimized code has it, under the second number: what a continuation
-- written out by this process resumes in another, and what one from
-- another process resumes here (design.md, "Continuations across
-- processes").
emitCombs ::
  (Var v) =>
  RefNums ->
  Reference ->
  Word64 ->
  Word64 ->
  SuperGroup Reference v ->
  State RecordFieldMappings (EnumMap Word64 Comb, Maybe (EnumMap Word64 Comb))
emitCombs :: forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> Word64
-> SuperGroup Reference v
-> State
     RecordFieldMappings
     (EnumMap Word64 Comb, Maybe (EnumMap Word64 Comb))
emitCombs RefNums
rns Reference
grpr Word64
grpn Word64
grpnBase (Rec [(v, SuperNormal Reference v)]
grp SuperNormal Reference v
ent) = do
  -- the unoptimized form of every lambda first, with its binders named as
  -- the rewrite names them ('uniqueBody'), for the frames of each of its
  -- sections, which the rewritten lambdas' sections are written out as
  [(Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))]
bases <- ((Word64, SuperNormal Reference v)
 -> StateT
      RecordFieldMappings
      Identity
      (Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v))))
-> [(Word64, SuperNormal Reference v)]
-> StateT
     RecordFieldMappings
     Identity
     [(Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))]
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) -> [a] -> f [b]
traverse (\(Word64
ix, SuperNormal Reference v
lam) -> (Word64
ix,) ((EnumMap Word64 Comb, EnumMap Word64 (Chain v))
 -> (Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v))))
-> StateT
     RecordFieldMappings
     Identity
     (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
-> StateT
     RecordFieldMappings
     Identity
     (Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> StateT
     RecordFieldMappings
     Identity
     (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
emitComb RefNums
rns Reference
grpr Word64
grpnBase RCtx v
rec (Word64
ix, SuperNormal Reference v -> SuperNormal Reference v
forall {v}.
Var v =>
SuperNormal Reference v -> SuperNormal Reference v
uniqueLambda SuperNormal Reference v
lam)) [(Word64, SuperNormal Reference v)]
lams
  let baseInfo :: Word64 -> SuperNormal Reference v -> Prepared v -> BaseInfo v
baseInfo Word64
ix SuperNormal Reference v
lam Prepared v
p =
        let Lambda [Mem]
_ (TAbss [v]
_ Term (ANormalF Reference) v
bd) = SuperNormal Reference v -> SuperNormal Reference v
forall {v}.
Var v =>
SuperNormal Reference v -> SuperNormal Reference v
uniqueLambda SuperNormal Reference v
lam
            chains :: EnumMap Word64 (Chain v)
chains = EnumMap Word64 (Chain v)
-> Maybe (EnumMap Word64 (Chain v)) -> EnumMap Word64 (Chain v)
forall a. a -> Maybe a -> a
fromMaybe EnumMap Word64 (Chain v)
forall a. Monoid a => a
mempty (Word64
-> [(Word64, EnumMap Word64 (Chain v))]
-> Maybe (EnumMap Word64 (Chain v))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup Word64
ix [(Word64
i, EnumMap Word64 (Chain v)
cs) | (Word64
i, (EnumMap Word64 Comb
_, EnumMap Word64 (Chain v)
cs)) <- [(Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))]
bases])
         in BaseInfo
              { baseLets :: Map [v] Word64
baseLets = [([v], Word64)] -> Map [v] Word64
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [([v]
us, Word16 -> Word64 -> Word64
letIndex Word16
w Word64
ix) | TLets (Indirect Word16
w) [v]
us [Mem]
_ Term (ANormalF Reference) v
_ Term (ANormalF Reference) v
_ <- Term (ANormalF Reference) v -> [Term (ANormalF Reference) v]
forall v. ANormal Reference v -> [ANormal Reference v]
universe Term (ANormalF Reference) v
bd],
                baseChains :: EnumMap Word64 (Chain v)
baseChains = EnumMap Word64 (Chain v)
chains,
                baseCons :: Map v (Built v)
baseCons = Term (ANormalF Reference) v -> Map v (Built v)
forall v. Var v => ANormal Reference v -> ConLets v
conLets Term (ANormalF Reference) v
bd,
                baseSources :: Sources v
baseSources = Prepared v -> Sources v
forall v. Prepared v -> Sources v
preparedSources Prepared v
p,
                baseLetOf :: Map [v] [v]
baseLetOf = Prepared v -> Map [v] [v]
forall v. Prepared v -> Map [v] [v]
preparedLets Prepared v
p,
                optLets :: EnumMap Word64 [v]
optLets = EnumMap Word64 [v]
forall a. Monoid a => a
mempty,
                baseCut :: Maybe [v]
baseCut = Maybe [v]
forall a. Maybe a
Nothing,
                baseJoin :: Bool
baseJoin = Bool
False,
                baseDead :: Set v
baseDead = Prepared v -> Set v
forall v. Prepared v -> Set v
preparedDead Prepared v
p
              }
      recFor :: Word64 -> SuperNormal Reference v -> Prepared v -> RCtx v
recFor Word64
ix SuperNormal Reference v
lam Prepared v
p = RCtx v
rec {rctxBase = Just (baseInfo ix lam p)}
      recJoin :: Word64 -> SuperNormal Reference v -> Prepared v -> Join v -> RCtx v
recJoin Word64
ix SuperNormal Reference v
lam Prepared v
p Join v
jn =
        RCtx v
rec
          { rctxBase =
              Just
                (baseInfo ix lam p)
                  { baseSources = preparedSources p <> joinSources jn,
                    baseCut = joinCut jn,
                    baseJoin = True
                  }
          }
      -- a prepared form of the lambda at index bix, emitted at index ix
      -- (its own, or a worker's), and its join points at theirs
      emitPrepared :: Word64
-> Word64
-> SuperNormal Reference v
-> Prepared v
-> StateT RecordFieldMappings Identity (EnumMap Word64 Comb)
emitPrepared Word64
bix Word64
ix SuperNormal Reference v
lam Prepared v
p = do
        (EnumMap Word64 Comb
es, EnumMap Word64 (Chain v)
_) <- RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> StateT
     RecordFieldMappings
     Identity
     (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
emitComb RefNums
rns Reference
grpr Word64
grpn (Word64 -> SuperNormal Reference v -> Prepared v -> RCtx v
recFor Word64
bix SuperNormal Reference v
lam Prepared v
p) (Word64
ix, Prepared v -> SuperNormal Reference v
forall v. Prepared v -> SuperNormal Reference v
preparedLambda Prepared v
p)
        EnumMap Word64 Comb
joins <- ((Int, Join v)
 -> StateT RecordFieldMappings Identity (EnumMap Word64 Comb))
-> [(Int, Join v)]
-> StateT RecordFieldMappings Identity (EnumMap Word64 Comb)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM (\(Int
k, Join v
jn) -> (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
-> EnumMap Word64 Comb
forall a b. (a, b) -> a
fst ((EnumMap Word64 Comb, EnumMap Word64 (Chain v))
 -> EnumMap Word64 Comb)
-> StateT
     RecordFieldMappings
     Identity
     (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
-> StateT RecordFieldMappings Identity (EnumMap Word64 Comb)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> StateT
     RecordFieldMappings
     Identity
     (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
emitComb RefNums
rns Reference
grpr Word64
grpn (Word64 -> SuperNormal Reference v -> Prepared v -> Join v -> RCtx v
recJoin Word64
bix SuperNormal Reference v
lam Prepared v
p Join v
jn) (Word64 -> Int -> Word64
joinIndex Word64
ix Int
k, Join v -> SuperNormal Reference v
forall v. Join v -> SuperNormal Reference v
joinLambda Join v
jn)) ([Int] -> [Join v] -> [(Int, Join v)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] (Prepared v -> [Join v]
forall v. Prepared v -> [Join v]
preparedJoins Prepared v
p))
        pure (EnumMap Word64 Comb
es EnumMap Word64 Comb -> EnumMap Word64 Comb -> EnumMap Word64 Comb
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Comb
joins)
  -- every lambda is rewritten for the batch's workers first
  -- (Unison.Runtime.MCode.Explode, 'prepare'): the emitter sees calls of
  -- workers and yields of several values as forms of their own
  EnumMap Word64 Comb
es <- Word64
-> Word64
-> SuperNormal Reference v
-> Prepared v
-> StateT RecordFieldMappings Identity (EnumMap Word64 Comb)
emitPrepared Word64
0 Word64
0 SuperNormal Reference v
ent (Batch
-> Maybe (JoinSetting v) -> SuperNormal Reference v -> Prepared v
forall v.
Var v =>
Batch
-> Maybe (JoinSetting v) -> SuperNormal Reference v -> Prepared v
prepare Batch
b (Word64 -> Maybe (JoinSetting v)
setting Word64
0) SuperNormal Reference v
ent)
  -- a function that returns a product on every path also gets a
  -- product-return worker: the lambda with its tails yielding the
  -- product's leaves; the entry keeps the original body, as with a
  -- specialisation, so that a caller that doesn't take the result apart,
  -- the function's own recursion included, pays nothing
  EnumMap Word64 Comb
ret <- case RefNums -> Reference -> Maybe Shape
retOf RefNums
rns Reference
grpr of
    Just Shape
s -> let p :: Prepared v
p = Batch -> Shape -> SuperNormal Reference v -> Prepared v
forall v.
Var v =>
Batch -> Shape -> SuperNormal Reference v -> Prepared v
returnWorker Batch
b Shape
s SuperNormal Reference v
ent in (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
-> EnumMap Word64 Comb
forall a b. (a, b) -> a
fst ((EnumMap Word64 Comb, EnumMap Word64 (Chain v))
 -> EnumMap Word64 Comb)
-> StateT
     RecordFieldMappings
     Identity
     (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
-> StateT RecordFieldMappings Identity (EnumMap Word64 Comb)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> StateT
     RecordFieldMappings
     Identity
     (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
emitComb RefNums
rns Reference
grpr Word64
grpn (Word64 -> SuperNormal Reference v -> Prepared v -> RCtx v
recFor Word64
0 SuperNormal Reference v
ent Prepared v
p) (Word64
retIndex, Prepared v -> SuperNormal Reference v
forall v. Prepared v -> SuperNormal Reference v
preparedLambda Prepared v
p)
    Maybe Shape
Nothing -> EnumMap Word64 Comb
-> StateT RecordFieldMappings Identity (EnumMap Word64 Comb)
forall a. a -> StateT RecordFieldMappings Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumMap Word64 Comb
forall a. Monoid a => a
mempty
  -- a specialisation of the entry point per call pattern its callers in
  -- the batch build, each a combinator of its own
  EnumMap Word64 Comb
specs <- case RefNums -> Reference -> Maybe [Pattern]
explode RefNums
rns Reference
grpr of
    Just [Pattern]
pats -> ((Int, Pattern)
 -> StateT RecordFieldMappings Identity (EnumMap Word64 Comb))
-> [(Int, Pattern)]
-> StateT RecordFieldMappings Identity (EnumMap Word64 Comb)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM (\(Int
k, Pattern
pat) -> Word64
-> Word64
-> SuperNormal Reference v
-> Prepared v
-> StateT RecordFieldMappings Identity (EnumMap Word64 Comb)
emitPrepared Word64
0 (Int -> Word64
specIndex Int
k) SuperNormal Reference v
ent (Batch
-> Maybe (JoinSetting v)
-> Pattern
-> SuperNormal Reference v
-> Prepared v
forall v.
Var v =>
Batch
-> Maybe (JoinSetting v)
-> Pattern
-> SuperNormal Reference v
-> Prepared v
specialise Batch
b (Word64 -> Maybe (JoinSetting v)
setting (Int -> Word64
specIndex Int
k)) Pattern
pat SuperNormal Reference v
ent)) ([Int] -> [Pattern] -> [(Int, Pattern)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Pattern]
pats)
    Maybe [Pattern]
Nothing -> EnumMap Word64 Comb
-> StateT RecordFieldMappings Identity (EnumMap Word64 Comb)
forall a. a -> StateT RecordFieldMappings Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumMap Word64 Comb
forall a. Monoid a => a
mempty
  EnumMap Word64 Comb
auxEs <- ((Word64, SuperNormal Reference v)
 -> StateT RecordFieldMappings Identity (EnumMap Word64 Comb))
-> [(Word64, SuperNormal Reference v)]
-> StateT RecordFieldMappings Identity (EnumMap Word64 Comb)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM (\(Word64
ix, SuperNormal Reference v
lam) -> Word64
-> Word64
-> SuperNormal Reference v
-> Prepared v
-> StateT RecordFieldMappings Identity (EnumMap Word64 Comb)
emitPrepared Word64
ix Word64
ix SuperNormal Reference v
lam (Batch
-> Maybe (JoinSetting v) -> SuperNormal Reference v -> Prepared v
forall v.
Var v =>
Batch
-> Maybe (JoinSetting v) -> SuperNormal Reference v -> Prepared v
prepare Batch
b (Word64 -> Maybe (JoinSetting v)
setting Word64
ix) SuperNormal Reference v
lam)) ([Word64]
-> [SuperNormal Reference v] -> [(Word64, SuperNormal Reference v)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word64]
ixs [SuperNormal Reference v]
cmbs)
  -- the group needs its unoptimized form beside it when a frame or a
  -- section number of its own lambdas (not of the workers, which are
  -- extra) differs from the unoptimized code's: then a continuation from
  -- another process resumes in the copy, and this process's recipes name
  -- its sections. The copy is the unoptimized lambdas as emitted above,
  -- their binders renamed and their lets numbered as 'uniqueBody' does,
  -- which is what a process with every rewrite off emits for the group
  -- ('prepareBody'), so the two agree on every section's number.
  let rewritten :: Bool
rewritten = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Maybe Deopt -> Bool
forall a. Maybe a -> Bool
isJust (FrameLayout -> Maybe Deopt
baseFrames FrameLayout
lay) | (Word64
_, Comb GCombInfo CombIx
_ FrameLayout
lay) <- EnumMap Word64 Comb -> [(Word64, Comb)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList (EnumMap Word64 Comb
es EnumMap Word64 Comb -> EnumMap Word64 Comb -> EnumMap Word64 Comb
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Comb
auxEs)]
      base :: Maybe (EnumMap Word64 Comb)
base = if Bool
rewritten then EnumMap Word64 Comb -> Maybe (EnumMap Word64 Comb)
forall a. a -> Maybe a
Just (((Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))
 -> EnumMap Word64 Comb)
-> [(Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))]
-> EnumMap Word64 Comb
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((EnumMap Word64 Comb, EnumMap Word64 (Chain v))
-> EnumMap Word64 Comb
forall a b. (a, b) -> a
fst ((EnumMap Word64 Comb, EnumMap Word64 (Chain v))
 -> EnumMap Word64 Comb)
-> ((Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))
    -> (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))
-> (Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))
-> EnumMap Word64 Comb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))
-> (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
forall a b. (a, b) -> b
snd) [(Word64, (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))]
bases) else Maybe (EnumMap Word64 Comb)
forall a. Maybe a
Nothing
  -- with every rewrite off the group is its own unoptimized form, so a
  -- table means the emitter sees a difference the rewrites did not make
  Bool
-> StateT RecordFieldMappings Identity ()
-> StateT RecordFieldMappings Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
rewritten Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
rewritesOn) (StateT RecordFieldMappings Identity ()
 -> StateT RecordFieldMappings Identity ())
-> StateT RecordFieldMappings Identity ()
-> StateT RecordFieldMappings Identity ()
forall a b. (a -> b) -> a -> b
$
    [Word] -> [Char] -> StateT RecordFieldMappings Identity ()
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> StateT RecordFieldMappings Identity ())
-> [Char] -> StateT RecordFieldMappings Identity ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"emitCombs: a deoptimization table with every rewrite off, in group " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
grpr
  pure (EnumMap Word64 Comb
es EnumMap Word64 Comb -> EnumMap Word64 Comb -> EnumMap Word64 Comb
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Comb
ret EnumMap Word64 Comb -> EnumMap Word64 Comb -> EnumMap Word64 Comb
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Comb
specs EnumMap Word64 Comb -> EnumMap Word64 Comb -> EnumMap Word64 Comb
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Comb
auxEs, Maybe (EnumMap Word64 Comb)
base)
  where
    b :: Batch
b = RefNums -> Batch
batchOf RefNums
rns
    ([v]
rvs, [SuperNormal Reference v]
cmbs) = [(v, SuperNormal Reference v)] -> ([v], [SuperNormal Reference v])
forall a b. [(a, b)] -> ([a], [b])
unzip [(v, SuperNormal Reference v)]
grp
    ixs :: [Word64]
ixs = (Word64 -> Word64) -> [Word64] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) [Word64
1 ..]
    lams :: [(Word64, SuperNormal Reference v)]
lams = (Word64
0, SuperNormal Reference v
ent) (Word64, SuperNormal Reference v)
-> [(Word64, SuperNormal Reference v)]
-> [(Word64, SuperNormal Reference v)]
forall a. a -> [a] -> [a]
: [Word64]
-> [SuperNormal Reference v] -> [(Word64, SuperNormal Reference v)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word64]
ixs [SuperNormal Reference v]
cmbs
    rec :: RCtx v
rec = RCtx v
forall v. RCtx v
emptyRCtx {rctxCombs = M.fromList $ zip rvs ixs}
    uniqueLambda :: SuperNormal Reference v -> SuperNormal Reference v
uniqueLambda (Lambda [Mem]
ccs (TAbss [v]
vs Term (ANormalF Reference) v
bd)) = [Mem] -> Term (ANormalF Reference) v -> SuperNormal Reference v
forall ref v. [Mem] -> ANormal ref v -> SuperNormal ref v
Lambda [Mem]
ccs ([v] -> Term (ANormalF Reference) v -> Term (ANormalF Reference) v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
TAbss [v]
vs (Term (ANormalF Reference) v -> Term (ANormalF Reference) v
forall v. Var v => ANormal Reference v -> ANormal Reference v
uniqueBody Term (ANormalF Reference) v
bd))
    -- where a lambda's join points go (Unison.Runtime.MCode.Explode)
    setting :: Word64 -> Maybe (JoinSetting v)
setting Word64
ix = JoinSetting v -> Maybe (JoinSetting v)
forall a. a -> Maybe a
Just (Word64 -> Reference -> Set v -> JoinSetting v
forall v. Word64 -> Reference -> Set v -> JoinSetting v
JoinSetting Word64
ix Reference
grpr ([v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList [v]
rvs))

-- | What the explosion's rewrites know about the batch
-- (Unison.Runtime.MCode.Explode): the call patterns, the returned
-- products and the arities the loader found.
batchOf :: RefNums -> Batch
batchOf :: RefNums -> Batch
batchOf RefNums
rns = (Reference -> Maybe [Pattern])
-> (Reference -> Maybe Shape) -> (Reference -> Maybe Int) -> Batch
Batch (RefNums -> Reference -> Maybe [Pattern]
explode RefNums
rns) (RefNums -> Reference -> Maybe Shape
retOf RefNums
rns) (RefNums -> Reference -> Maybe Int
anum RefNums
rns)

-- | How many values a combinator of a function's group yields to a call:
-- one, or the leaves of the product for the product-return worker
-- (Unison.Runtime.MCode.Explode). A call of the worker of a function that
-- returns no product is a bug: no rewrite makes one.
combYields :: RefNums -> Reference -> Word64 -> Maybe Int
combYields :: RefNums -> Reference -> Word64 -> Maybe Int
combYields RefNums
rns Reference
r Word64
i
  | Word64
i Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
retIndex = case RefNums -> Reference -> Maybe Shape
retOf RefNums
rns Reference
r of
      Just Shape
s -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Shape -> Int
shapeLeaves Shape
s)
      Maybe Shape
Nothing -> [Word] -> [Char] -> Maybe Int
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Maybe Int) -> [Char] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Char]
"combYields: a call of the product-return worker of a function that returns no product: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r
  | Bool
otherwise = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1

-- | lazily replace all references to combinators with the combinators themselves,
-- tying the knot recursively when necessary.
resolveCombs ::
  -- Existing in-scope combs that might be referenced
  Maybe (EnumMap Word64 (RCombs val)) ->
  -- Combinators which need their knots tied.
  EnumMap Word64 (GCombs val CombIx) ->
  EnumMap Word64 (RCombs val)
resolveCombs :: forall val.
Maybe (EnumMap Word64 (RCombs val))
-> EnumMap Word64 (GCombs val CombIx)
-> EnumMap Word64 (RCombs val)
resolveCombs Maybe (EnumMap Word64 (RCombs val))
mayExisting EnumMap Word64 (GCombs val CombIx)
combs =
  -- Fixed point lookup;
  -- We make sure not to force resolved Combs or we'll loop forever.
  let ~EnumMap Word64 (RCombs val)
resolved =
        EnumMap Word64 (GCombs val CombIx)
combs
          EnumMap Word64 (GCombs val CombIx)
-> (GCombs val CombIx -> RCombs val) -> EnumMap Word64 (RCombs val)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((GComb val CombIx -> GComb val (RComb val))
-> GCombs val CombIx -> RCombs val
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GComb val CombIx -> GComb val (RComb val))
 -> GCombs val CombIx -> RCombs val)
-> ((CombIx -> RComb val)
    -> GComb val CombIx -> GComb val (RComb val))
-> (CombIx -> RComb val)
-> GCombs val CombIx
-> RCombs val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CombIx -> RComb val) -> GComb val CombIx -> GComb val (RComb val)
forall a b. (a -> b) -> GComb val a -> GComb val b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) \(CIx Reference
_ Word64
n Word64
i) ->
            let cmbs :: RCombs val
cmbs = case Maybe (EnumMap Word64 (RCombs val))
mayExisting Maybe (EnumMap Word64 (RCombs val))
-> (EnumMap Word64 (RCombs val) -> Maybe (RCombs val))
-> Maybe (RCombs val)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word64 -> EnumMap Word64 (RCombs val) -> Maybe (RCombs val)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
n of
                  Just RCombs val
cmbs -> RCombs val
cmbs
                  Maybe (RCombs val)
Nothing ->
                    case Word64 -> EnumMap Word64 (RCombs val) -> Maybe (RCombs val)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
n EnumMap Word64 (RCombs val)
resolved of
                      Just RCombs val
cmbs -> RCombs val
cmbs
                      Maybe (RCombs val)
Nothing -> [Char] -> RCombs val
forall a. HasCallStack => [Char] -> a
error ([Char] -> RCombs val) -> [Char] -> RCombs val
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown combinator `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`."
             in case Word64 -> RCombs val -> Maybe (GComb val (RComb val))
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
i RCombs val
cmbs of
                  Just GComb val (RComb val)
cmb -> GComb val (RComb val) -> RComb val
forall val. GComb val (RComb val) -> RComb val
RComb GComb val (RComb val)
cmb
                  Maybe (GComb val (RComb val))
Nothing ->
                    [Char] -> RComb val
forall a. HasCallStack => [Char] -> a
error ([Char] -> RComb val) -> [Char] -> RComb val
forall a b. (a -> b) -> a -> b
$
                      [Char]
"unknown section `"
                        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
i
                        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` of combinator `"
                        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n
                        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`."
   in EnumMap Word64 (RCombs val)
resolved

absurdCombs :: EnumMap Word64 (EnumMap Word64 (GComb Void cix)) -> EnumMap Word64 (GCombs any cix)
absurdCombs :: forall cix any.
EnumMap Word64 (EnumMap Word64 (GComb Void cix))
-> EnumMap Word64 (GCombs any cix)
absurdCombs = (EnumMap Word64 (GComb Void cix) -> GCombs any cix)
-> EnumMap Word64 (EnumMap Word64 (GComb Void cix))
-> EnumMap Word64 (GCombs any cix)
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((EnumMap Word64 (GComb Void cix) -> GCombs any cix)
 -> EnumMap Word64 (EnumMap Word64 (GComb Void cix))
 -> EnumMap Word64 (GCombs any cix))
-> ((Void -> any)
    -> EnumMap Word64 (GComb Void cix) -> GCombs any cix)
-> (Void -> any)
-> EnumMap Word64 (EnumMap Word64 (GComb Void cix))
-> EnumMap Word64 (GCombs any cix)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GComb Void cix -> GComb any cix)
-> EnumMap Word64 (GComb Void cix) -> GCombs any cix
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GComb Void cix -> GComb any cix)
 -> EnumMap Word64 (GComb Void cix) -> GCombs any cix)
-> ((Void -> any) -> GComb Void cix -> GComb any cix)
-> (Void -> any)
-> EnumMap Word64 (GComb Void cix)
-> GCombs any cix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Void -> any) -> GComb Void cix -> GComb any cix
forall a b c. (a -> b) -> GComb a c -> GComb b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Void -> any)
 -> EnumMap Word64 (EnumMap Word64 (GComb Void cix))
 -> EnumMap Word64 (GCombs any cix))
-> (Void -> any)
-> EnumMap Word64 (EnumMap Word64 (GComb Void cix))
-> EnumMap Word64 (GCombs any cix)
forall a b. (a -> b) -> a -> b
$ Void -> any
forall a. Void -> a
absurd

-- Type for aggregating the necessary stack frame size. First field is the
-- necessary size. The Applicative instance takes the
-- maximum, so that combining values from different branches
-- results in finding the maximum number of slots either side requires.
--
-- TODO: Now that we have a single stack, most of this counting can probably be simplified.
data Counted a = C !Int a
  deriving ((forall a b. (a -> b) -> Counted a -> Counted b)
-> (forall a b. a -> Counted b -> Counted a) -> Functor Counted
forall a b. a -> Counted b -> Counted a
forall a b. (a -> b) -> Counted a -> Counted b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Counted a -> Counted b
fmap :: forall a b. (a -> b) -> Counted a -> Counted b
$c<$ :: forall a b. a -> Counted b -> Counted a
<$ :: forall a b. a -> Counted b -> Counted a
Functor)

instance Applicative Counted where
  pure :: forall a. a -> Counted a
pure = Int -> a -> Counted a
forall a. Int -> a -> Counted a
C Int
0
  C Int
s0 a -> b
f <*> :: forall a b. Counted (a -> b) -> Counted a -> Counted b
<*> C Int
s1 a
x = Int -> b -> Counted b
forall a. Int -> a -> Counted a
C (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
s0 Int
s1) (a -> b
f a
x)

instance Monad Counted where
  C Int
s0 a
x >>= :: forall a b. Counted a -> (a -> Counted b) -> Counted b
>>= a -> Counted b
f =
    let C Int
s1 b
y = a -> Counted b
f a
x
     in Int -> b -> Counted b
forall a. Int -> a -> Counted a
C (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
s0 Int
s1) b
y

data RecordFieldMappings
  = RecordFieldMappings
      (FieldRef {- next unassigned ref -})
      (BiMap ANF.FieldName FieldRef {- mapping from field name to field ref -})
  deriving stock (Int -> RecordFieldMappings -> ShowS
[RecordFieldMappings] -> ShowS
RecordFieldMappings -> [Char]
(Int -> RecordFieldMappings -> ShowS)
-> (RecordFieldMappings -> [Char])
-> ([RecordFieldMappings] -> ShowS)
-> Show RecordFieldMappings
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecordFieldMappings -> ShowS
showsPrec :: Int -> RecordFieldMappings -> ShowS
$cshow :: RecordFieldMappings -> [Char]
show :: RecordFieldMappings -> [Char]
$cshowList :: [RecordFieldMappings] -> ShowS
showList :: [RecordFieldMappings] -> ShowS
Show, RecordFieldMappings -> RecordFieldMappings -> Bool
(RecordFieldMappings -> RecordFieldMappings -> Bool)
-> (RecordFieldMappings -> RecordFieldMappings -> Bool)
-> Eq RecordFieldMappings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecordFieldMappings -> RecordFieldMappings -> Bool
== :: RecordFieldMappings -> RecordFieldMappings -> Bool
$c/= :: RecordFieldMappings -> RecordFieldMappings -> Bool
/= :: RecordFieldMappings -> RecordFieldMappings -> Bool
Eq, Eq RecordFieldMappings
Eq RecordFieldMappings =>
(RecordFieldMappings -> RecordFieldMappings -> Ordering)
-> (RecordFieldMappings -> RecordFieldMappings -> Bool)
-> (RecordFieldMappings -> RecordFieldMappings -> Bool)
-> (RecordFieldMappings -> RecordFieldMappings -> Bool)
-> (RecordFieldMappings -> RecordFieldMappings -> Bool)
-> (RecordFieldMappings
    -> RecordFieldMappings -> RecordFieldMappings)
-> (RecordFieldMappings
    -> RecordFieldMappings -> RecordFieldMappings)
-> Ord RecordFieldMappings
RecordFieldMappings -> RecordFieldMappings -> Bool
RecordFieldMappings -> RecordFieldMappings -> Ordering
RecordFieldMappings -> RecordFieldMappings -> RecordFieldMappings
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 :: RecordFieldMappings -> RecordFieldMappings -> Ordering
compare :: RecordFieldMappings -> RecordFieldMappings -> Ordering
$c< :: RecordFieldMappings -> RecordFieldMappings -> Bool
< :: RecordFieldMappings -> RecordFieldMappings -> Bool
$c<= :: RecordFieldMappings -> RecordFieldMappings -> Bool
<= :: RecordFieldMappings -> RecordFieldMappings -> Bool
$c> :: RecordFieldMappings -> RecordFieldMappings -> Bool
> :: RecordFieldMappings -> RecordFieldMappings -> Bool
$c>= :: RecordFieldMappings -> RecordFieldMappings -> Bool
>= :: RecordFieldMappings -> RecordFieldMappings -> Bool
$cmax :: RecordFieldMappings -> RecordFieldMappings -> RecordFieldMappings
max :: RecordFieldMappings -> RecordFieldMappings -> RecordFieldMappings
$cmin :: RecordFieldMappings -> RecordFieldMappings -> RecordFieldMappings
min :: RecordFieldMappings -> RecordFieldMappings -> RecordFieldMappings
Ord)

-- | No field names assigned yet. The starting state for `emitCombs` and
-- friends, in the same spirit as `emptyRNs`.
emptyRecordFieldMappings :: RecordFieldMappings
emptyRecordFieldMappings :: RecordFieldMappings
emptyRecordFieldMappings = FieldRef -> BiMap FieldName FieldRef -> RecordFieldMappings
RecordFieldMappings (Word64 -> FieldRef
FieldRef Word64
0) BiMap FieldName FieldRef
forall a. Monoid a => a
mempty

-- | Note that the Ord instance for Field Refs is arbitrary and not tied to the field name Ord instance.
convertFieldNamesToRefs :: (MonadState RecordFieldMappings m, Traversable f) => f ANF.FieldName -> m (f FieldRef)
convertFieldNamesToRefs :: forall (m :: * -> *) (f :: * -> *).
(MonadState RecordFieldMappings m, Traversable f) =>
f FieldName -> m (f FieldRef)
convertFieldNamesToRefs f FieldName
names = f FieldName -> (FieldName -> m FieldRef) -> m (f FieldRef)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for f FieldName
names \FieldName
name -> do
  RecordFieldMappings FieldRef
next BiMap FieldName FieldRef
m <- m RecordFieldMappings
forall s (m :: * -> *). MonadState s m => m s
get
  case FieldName -> BiMap FieldName FieldRef -> Maybe FieldRef
forall k v. Ord k => k -> BiMap k v -> Maybe v
BiMap.lookupL FieldName
name BiMap FieldName FieldRef
m of
    Just FieldRef
fr -> FieldRef -> m FieldRef
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldRef
fr
    Maybe FieldRef
Nothing -> do
      RecordFieldMappings -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (RecordFieldMappings -> m ()) -> RecordFieldMappings -> m ()
forall a b. (a -> b) -> a -> b
$ FieldRef -> BiMap FieldName FieldRef -> RecordFieldMappings
RecordFieldMappings (FieldRef -> FieldRef
forall a. Enum a => a -> a
succ FieldRef
next) (FieldName
-> FieldRef -> BiMap FieldName FieldRef -> BiMap FieldName FieldRef
forall k v. (Ord k, Ord v) => k -> v -> BiMap k v -> BiMap k v
BiMap.insert FieldName
name FieldRef
next BiMap FieldName FieldRef
m)
      pure FieldRef
next

-- | The emitter of one combinator: the combinator's index, and what it
-- writes out: the sections recorded as combinators, the frame size
-- reached, and the frames of each section ('Chain', read when the
-- unoptimized form of a rewritten lambda is emitted, 'emitCombs').
newtype Emit v a
  = EM ((ReaderT Word64 (WriterT (EC.EnumMap Word64 Comb, Max Int, EC.EnumMap Word64 (Chain v)) (State RecordFieldMappings))) a)
  deriving newtype ((forall a b. (a -> b) -> Emit v a -> Emit v b)
-> (forall a b. a -> Emit v b -> Emit v a) -> Functor (Emit v)
forall a b. a -> Emit v b -> Emit v a
forall a b. (a -> b) -> Emit v a -> Emit v b
forall v a b. a -> Emit v b -> Emit v a
forall v a b. (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall v a b. (a -> b) -> Emit v a -> Emit v b
fmap :: forall a b. (a -> b) -> Emit v a -> Emit v b
$c<$ :: forall v a b. a -> Emit v b -> Emit v a
<$ :: forall a b. a -> Emit v b -> Emit v a
Functor, Functor (Emit v)
Functor (Emit v) =>
(forall a. a -> Emit v a)
-> (forall a b. Emit v (a -> b) -> Emit v a -> Emit v b)
-> (forall a b c.
    (a -> b -> c) -> Emit v a -> Emit v b -> Emit v c)
-> (forall a b. Emit v a -> Emit v b -> Emit v b)
-> (forall a b. Emit v a -> Emit v b -> Emit v a)
-> Applicative (Emit v)
forall v. Functor (Emit v)
forall a. a -> Emit v a
forall v a. a -> Emit v a
forall a b. Emit v a -> Emit v b -> Emit v a
forall a b. Emit v a -> Emit v b -> Emit v b
forall a b. Emit v (a -> b) -> Emit v a -> Emit v b
forall v a b. Emit v a -> Emit v b -> Emit v a
forall v a b. Emit v a -> Emit v b -> Emit v b
forall v a b. Emit v (a -> b) -> Emit v a -> Emit v b
forall a b c. (a -> b -> c) -> Emit v a -> Emit v b -> Emit v c
forall v a b c. (a -> b -> c) -> Emit v a -> Emit v b -> Emit v c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall v a. a -> Emit v a
pure :: forall a. a -> Emit v a
$c<*> :: forall v a b. Emit v (a -> b) -> Emit v a -> Emit v b
<*> :: forall a b. Emit v (a -> b) -> Emit v a -> Emit v b
$cliftA2 :: forall v a b c. (a -> b -> c) -> Emit v a -> Emit v b -> Emit v c
liftA2 :: forall a b c. (a -> b -> c) -> Emit v a -> Emit v b -> Emit v c
$c*> :: forall v a b. Emit v a -> Emit v b -> Emit v b
*> :: forall a b. Emit v a -> Emit v b -> Emit v b
$c<* :: forall v a b. Emit v a -> Emit v b -> Emit v a
<* :: forall a b. Emit v a -> Emit v b -> Emit v a
Applicative, Applicative (Emit v)
Applicative (Emit v) =>
(forall a b. Emit v a -> (a -> Emit v b) -> Emit v b)
-> (forall a b. Emit v a -> Emit v b -> Emit v b)
-> (forall a. a -> Emit v a)
-> Monad (Emit v)
forall v. Applicative (Emit v)
forall a. a -> Emit v a
forall v a. a -> Emit v a
forall a b. Emit v a -> Emit v b -> Emit v b
forall a b. Emit v a -> (a -> Emit v b) -> Emit v b
forall v a b. Emit v a -> Emit v b -> Emit v b
forall v a b. Emit v a -> (a -> Emit v b) -> Emit v b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall v a b. Emit v a -> (a -> Emit v b) -> Emit v b
>>= :: forall a b. Emit v a -> (a -> Emit v b) -> Emit v b
$c>> :: forall v a b. Emit v a -> Emit v b -> Emit v b
>> :: forall a b. Emit v a -> Emit v b -> Emit v b
$creturn :: forall v a. a -> Emit v a
return :: forall a. a -> Emit v a
Monad, MonadReader Word64, MonadWriter (EC.EnumMap Word64 Comb, Max Int, EC.EnumMap Word64 (Chain v)), MonadState RecordFieldMappings)

runEmit :: Word64 -> Emit v a -> State RecordFieldMappings (EC.EnumMap Word64 Comb, EC.EnumMap Word64 (Chain v))
runEmit :: forall v a.
Word64
-> Emit v a
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
runEmit Word64
w (EM ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
e) =
  ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
e
    ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
-> (ReaderT
      Word64
      (WriterT
         (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
         (StateT RecordFieldMappings Identity))
      a
    -> WriterT
         (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
         (StateT RecordFieldMappings Identity)
         a)
-> WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity)
     a
forall a b. a -> (a -> b) -> b
& (ReaderT
   Word64
   (WriterT
      (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
      (StateT RecordFieldMappings Identity))
   a
 -> Word64
 -> WriterT
      (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
      (StateT RecordFieldMappings Identity)
      a)
-> Word64
-> ReaderT
     Word64
     (WriterT
        (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
        (StateT RecordFieldMappings Identity))
     a
-> WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity)
     a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
-> Word64
-> WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity)
     a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Word64
w
    WriterT
  (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
  (StateT RecordFieldMappings Identity)
  a
-> (WriterT
      (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
      (StateT RecordFieldMappings Identity)
      a
    -> StateT
         RecordFieldMappings
         Identity
         (a, (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))))
-> StateT
     RecordFieldMappings
     Identity
     (a, (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v)))
forall a b. a -> (a -> b) -> b
& WriterT
  (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
  (StateT RecordFieldMappings Identity)
  a
-> StateT
     RecordFieldMappings
     Identity
     (a, (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v)))
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT
    StateT
  RecordFieldMappings
  Identity
  (a, (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v)))
-> ((a, (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v)))
    -> (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))
-> StateT
     RecordFieldMappings
     Identity
     (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(a
_a, (EnumMap Word64 Comb
ec, Max Int
_, EnumMap Word64 (Chain v)
chains)) -> (EnumMap Word64 Comb
ec, EnumMap Word64 (Chain v)
chains)

counted :: Counted a -> Emit v a
counted :: forall a v. Counted a -> Emit v a
counted (C Int
n a
a) = (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
-> Emit v ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (EnumMap Word64 Comb
forall a. Monoid a => a
mempty, Int -> Max Int
forall a. a -> Max a
Max Int
n, EnumMap Word64 (Chain v)
forall a. Monoid a => a
mempty) Emit v () -> Emit v a -> Emit v a
forall a b. Emit v a -> Emit v b -> Emit v b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> a -> Emit v a
forall a. a -> Emit v a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

letIndex :: Word16 -> Word64 -> Word64
letIndex :: Word16 -> Word64 -> Word64
letIndex Word16
l Word64
c = Word64
c Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
l

-- | Records the body of an indirect let as a combinator of its own: its
-- arity is the let's frame plus the yielded variables, and its frame layout
-- is the frame's wide variables, from the context of the let.
record :: (Var v) => RefNums -> RCtx v -> Ctx v -> [(v, Mem)] -> Word16 -> Emit v Section -> Emit v (Word64, Comb)
record :: forall v.
Var v =>
RefNums
-> RCtx v
-> Ctx v
-> [(v, Mem)]
-> Word16
-> Emit v Section
-> Emit v (Word64, Comb)
record RefNums
rns RCtx v
rec Ctx v
ctx [(v, Mem)]
vcs Word16
l Emit v Section
es = do
  Word64
c <- Emit v Word64
forall r (m :: * -> *). MonadReader r m => m r
ask
  (Section
s, (EnumMap Word64 Comb
_m, Max Int
sz, EnumMap Word64 (Chain v)
_)) <- Emit v Section
-> Emit
     v
     (Section, (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v)))
forall a.
Emit v a
-> Emit
     v (a, (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v)))
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen Emit v Section
es
  let na :: Int
na = Int -> Ctx v -> Int
forall v. Int -> Ctx v -> Int
countCtx0 Int
0 ([(v, Mem)] -> Ctx v -> Ctx v
forall v. [(v, Mem)] -> Ctx v -> Ctx v
pushCtx [(v, Mem)]
vcs Ctx v
ctx)
      n :: Word64
n = Word16 -> Word64 -> Word64
letIndex Word16
l Word64
c
      chain :: Chain v
chain = Ctx v -> Chain v
forall v. Ctx v -> Chain v
chainOf Ctx v
ctx
  Maybe Deopt
base <- case RCtx v -> Maybe (BaseInfo v)
forall v. RCtx v -> Maybe (BaseInfo v)
rctxBase RCtx v
rec of
    Just BaseInfo v
bi -> RefNums
-> BaseInfo v -> Word64 -> [v] -> Chain v -> Emit v (Maybe Deopt)
forall v.
Var v =>
RefNums
-> BaseInfo v -> Word64 -> [v] -> Chain v -> Emit v (Maybe Deopt)
deoptOf RefNums
rns BaseInfo v
bi Word64
n (((v, Mem) -> v) -> [(v, Mem)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, Mem) -> v
forall a b. (a, b) -> a
fst [(v, Mem)]
vcs) Chain v
chain
    Maybe (BaseInfo v)
Nothing -> Maybe Deopt -> Emit v (Maybe Deopt)
forall a. a -> Emit v a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Deopt
forall a. Maybe a
Nothing
  let comb :: Comb
comb = GCombInfo CombIx -> FrameLayout -> Comb
forall val comb. GCombInfo comb -> FrameLayout -> GComb val comb
Comb (Int -> Int -> Section -> Ptr NativeCell -> GCombInfo CombIx
forall comb.
Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
LamI Int
na Int
sz Section
s Ptr NativeCell
noNativeCell) ([(Int, Int)] -> Maybe Deopt -> Int -> Int -> FrameLayout
FrameLayout (Ctx v -> [(Int, Int)]
forall v. Ctx v -> [(Int, Int)]
wideSlots Ctx v
ctx) Maybe Deopt
base (Int -> Ctx v -> Int
forall v. Int -> Ctx v -> Int
countCtx0 Int
0 Ctx v
ctx) (Chain v -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Ctx v -> Chain v
forall v. Ctx v -> Chain v
chainOf Ctx v
ctx) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
-> Emit v ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Word64 -> Comb -> EnumMap Word64 Comb
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
n Comb
comb, Max Int
0, Word64 -> Chain v -> EnumMap Word64 (Chain v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
n Chain v
chain)
  pure $ (Word64
n, Comb
comb)

recordTop :: [v] -> Word16 -> Emit v Section -> Emit v ()
recordTop :: forall v. [v] -> Word16 -> Emit v Section -> Emit v ()
recordTop [v]
vs Word16
l (EM ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  Section
e) = ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  ()
-> Emit v ()
forall v a.
ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
-> Emit v a
EM do
  Word64
c <- ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  Word64
forall r (m :: * -> *). MonadReader r m => m r
ask
  (Section
s, (EnumMap Word64 Comb
_m, Max Int
sz, EnumMap Word64 (Chain v)
_)) <- ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  Section
-> ReaderT
     Word64
     (WriterT
        (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
        (StateT RecordFieldMappings Identity))
     (Section, (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v)))
forall a.
ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
-> ReaderT
     Word64
     (WriterT
        (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
        (StateT RecordFieldMappings Identity))
     (a, (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v)))
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  Section
e
  let na :: Int
na = [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
vs
      n :: Word64
n = Word16 -> Word64 -> Word64
letIndex Word16
l Word64
c
      lam :: Comb
lam = Int -> Int -> Section -> Comb
forall comb val. Int -> Int -> GSection comb -> GComb val comb
Lam Int
na Int
sz Section
s
  (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
-> ReaderT
     Word64
     (WriterT
        (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
        (StateT RecordFieldMappings Identity))
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Word64 -> Comb -> EnumMap Word64 Comb
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
n Comb
lam, Max Int
0, EnumMap Word64 (Chain v)
forall a. Monoid a => a
mempty)
  pure ()

-- | The frames the unoptimized code has where a rewritten section has
-- its frame ('Deopt'), from the section's index, the let's binders and
-- the frames of its context, against the unoptimized lambda
-- ('BaseInfo'); Nothing when they are the same frame, which is when the
-- section is its own unoptimized form. The unoptimized let is the one
-- binding the same names, or the let of the product for a let of a
-- result's leaves; its frames are taken up to the frame of the enclosing
-- optimized let's unoptimized section, which that let's own frame stands
-- for (for a join point, whose lambda has no enclosing let, up to the
-- frame of the let its site was in). A slot is the variable's own if the
-- optimized frames hold it, else what its source says ('Sources'), else
-- the product the unoptimized body built for it ('conLets'); in a join
-- point a variable that is none of these is dead where the unoptimized
-- code resumes, since a join point's parameters cover every variable the
-- unoptimized arm reads (Explode's 'caseSites'), and is written as unit.
deoptOf :: (Var v) => RefNums -> BaseInfo v -> Word64 -> [v] -> Chain v -> Emit v (Maybe Deopt)
deoptOf :: forall v.
Var v =>
RefNums
-> BaseInfo v -> Word64 -> [v] -> Chain v -> Emit v (Maybe Deopt)
deoptOf RefNums
rns BaseInfo v
bi Word64
n [v]
us Chain v
chain
  | Bool
identity = Maybe Deopt -> Emit v (Maybe Deopt)
forall a. a -> Emit v a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Deopt
forall a. Maybe a
Nothing
  | Bool
otherwise = Deopt -> Maybe Deopt
forall a. a -> Maybe a
Just (Deopt -> Maybe Deopt)
-> ([BaseFrame] -> Deopt) -> [BaseFrame] -> Maybe Deopt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BaseFrame] -> Deopt
Deopt ([BaseFrame] -> Maybe Deopt)
-> Emit v [BaseFrame] -> Emit v (Maybe Deopt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Word64, [Entry v]) -> Emit v BaseFrame)
-> [(Word64, [Entry v])] -> Emit v [BaseFrame]
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) -> [a] -> f [b]
traverse (Word64, [Entry v]) -> Emit v BaseFrame
frame [(Word64, [Entry v])]
labelled
  where
    bs :: [v]
bs = [v] -> [v] -> Map [v] [v] -> [v]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [v]
us [v]
us (BaseInfo v -> Map [v] [v]
forall v. BaseInfo v -> Map [v] [v]
baseLetOf BaseInfo v
bi)
    bidx :: Word64
bidx = Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe ([Word] -> [Char] -> Word64
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Word64) -> [Char] -> Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"deoptOf: no unoptimized let binds " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [v] -> [Char]
forall a. Show a => a -> [Char]
show [v]
bs) ([v] -> Map [v] Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [v]
bs (BaseInfo v -> Map [v] Word64
forall v. BaseInfo v -> Map [v] Word64
baseLets BaseInfo v
bi))
    bchain :: Chain v
bchain = Chain v -> Maybe (Chain v) -> Chain v
forall a. a -> Maybe a -> a
fromMaybe ([Word] -> [Char] -> Chain v
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Chain v) -> [Char] -> Chain v
forall a b. (a -> b) -> a -> b
$ [Char]
"deoptOf: no frames for unoptimized section " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
bidx) (Word64 -> EnumMap Word64 (Chain v) -> Maybe (Chain v)
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
bidx (BaseInfo v -> EnumMap Word64 (Chain v)
forall v. BaseInfo v -> EnumMap Word64 (Chain v)
baseChains BaseInfo v
bi))
    baseOf :: [v] -> Word64
baseOf [v]
us1 =
      let bs1 :: [v]
bs1 = [v] -> [v] -> Map [v] [v] -> [v]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [v]
us1 [v]
us1 (BaseInfo v -> Map [v] [v]
forall v. BaseInfo v -> Map [v] [v]
baseLetOf BaseInfo v
bi)
       in Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe ([Word] -> [Char] -> Word64
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Word64) -> [Char] -> Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"deoptOf: no unoptimized let binds " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [v] -> [Char]
forall a. Show a => a -> [Char]
show [v]
bs1) ([v] -> Map [v] Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [v]
bs1 (BaseInfo v -> Map [v] Word64
forall v. BaseInfo v -> Map [v] Word64
baseLets BaseInfo v
bi))
    enclosing :: Maybe Word64
enclosing = case Chain v
chain of
      ((Maybe Word64, [Entry v])
_ : (Just Word64
w1, [Entry v]
_) : Chain v
_) -> case Word64 -> EnumMap Word64 [v] -> Maybe [v]
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w1 (BaseInfo v -> EnumMap Word64 [v]
forall v. BaseInfo v -> EnumMap Word64 [v]
optLets BaseInfo v
bi) of
        Just [v]
us1 -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just ([v] -> Word64
baseOf [v]
us1)
        Maybe [v]
Nothing -> [Word] -> [Char] -> Maybe Word64
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Maybe Word64) -> [Char] -> Maybe Word64
forall a b. (a -> b) -> a -> b
$ [Char]
"deoptOf: no let has section " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
w1
      Chain v
_ -> [v] -> Word64
baseOf ([v] -> Word64) -> Maybe [v] -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseInfo v -> Maybe [v]
forall v. BaseInfo v -> Maybe [v]
baseCut BaseInfo v
bi
    produced :: Chain v
produced = case Maybe Word64
enclosing of
      Maybe Word64
Nothing -> Chain v
bchain
      Just Word64
b1
        | ((Maybe Word64, [Entry v]) -> Bool) -> Chain v -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Maybe Word64 -> Maybe Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
b1) (Maybe Word64 -> Bool)
-> ((Maybe Word64, [Entry v]) -> Maybe Word64)
-> (Maybe Word64, [Entry v])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Word64, [Entry v]) -> Maybe Word64
forall a b. (a, b) -> a
fst) Chain v
bchain -> ((Maybe Word64, [Entry v]) -> Bool) -> Chain v -> Chain v
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Maybe Word64 -> Maybe Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
b1) (Maybe Word64 -> Bool)
-> ((Maybe Word64, [Entry v]) -> Maybe Word64)
-> (Maybe Word64, [Entry v])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Word64, [Entry v]) -> Maybe Word64
forall a b. (a, b) -> a
fst) Chain v
bchain
        | Bool
otherwise -> [Word] -> [Char] -> Chain v
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Chain v) -> [Char] -> Chain v
forall a b. (a -> b) -> a -> b
$ [Char]
"deoptOf: the enclosing let's unoptimized section " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
b1 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is not among the frames of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
bidx
    labelled :: [(Word64, [Entry v])]
labelled = [Word64] -> [[Entry v]] -> [(Word64, [Entry v])]
forall a b. [a] -> [b] -> [(a, b)]
zip (Word64
bidx Word64 -> [Word64] -> [Word64]
forall a. a -> [a] -> [a]
: [Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe ([Word] -> [Char] -> Word64
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"deoptOf: an outer frame without a let") Maybe Word64
lbl | (Maybe Word64
lbl, [Entry v]
_) <- Int -> Chain v -> Chain v
forall a. Int -> [a] -> [a]
drop Int
1 Chain v
produced]) (((Maybe Word64, [Entry v]) -> [Entry v]) -> Chain v -> [[Entry v]]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Word64, [Entry v]) -> [Entry v]
forall a b. (a, b) -> b
snd Chain v
produced)
    -- the section is its own unoptimized form: its own frames (those
    -- above the enclosing let, which stands for the rest) are the base's,
    -- under the same numbers, and the enclosing let's section is the
    -- same section in both
    identity :: Bool
identity =
      Word64
bidx Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
n
        Bool -> Bool -> Bool
&& [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
us
        Bool -> Bool -> Bool
&& Chain v
produced Chain v -> Chain v -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Chain v -> Chain v
forall a. Int -> [a] -> [a]
take (Chain v -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Chain v
produced) Chain v
chain
        Bool -> Bool -> Bool
&& Maybe Word64
enclosing Maybe Word64 -> Maybe Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== case Int -> Chain v -> Chain v
forall a. Int -> [a] -> [a]
drop (Chain v -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Chain v
produced) Chain v
chain of
          [] -> Maybe Word64
forall a. Maybe a
Nothing
          (Maybe Word64
lbl, [Entry v]
_) : Chain v
_ -> Maybe Word64
lbl
    frame :: (Word64, [Entry v]) -> Emit v BaseFrame
frame (Word64
ix, [Entry v]
entries) = Word64 -> [Slot] -> BaseFrame
BaseFrame Word64
ix ([Slot] -> BaseFrame) -> Emit v [Slot] -> Emit v BaseFrame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Entry v -> Emit v Slot) -> [Entry v] -> Emit v [Slot]
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) -> [a] -> f [b]
traverse Entry v -> Emit v Slot
slot [Entry v]
entries
    slot :: Entry v -> Emit v Slot
slot Entry v
ETag = [Word] -> [Char] -> Emit v Slot
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"deoptOf: a tag slot in a frame the explosion rewrote"
    slot (EVar v
w)
      | v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
w (BaseInfo v -> Set v
forall v. BaseInfo v -> Set v
baseDead BaseInfo v
bi) = Slot -> Emit v Slot
forall a. a -> Emit v a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Slot
Dead
      | BaseInfo v -> Bool
forall v. BaseInfo v -> Bool
baseJoin BaseInfo v
bi, Bool -> Bool
not (Int -> v -> Bool
known (Int
0 :: Int) v
w) = Slot -> Emit v Slot
forall a. a -> Emit v a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Slot
Dead
      | Bool
otherwise = Int -> v -> Emit v Slot
var (Int
0 :: Int) v
w
    known :: Int -> v -> Bool
known Int
depth v
w
      | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
64 = Bool
False
      | Just (Int, Int)
_ <- v -> Maybe (Int, Int)
optSlot v
w = Bool
True
      | Just (Left v
u) <- v -> Map v (Either v (Built v)) -> Maybe (Either v (Built v))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup v
w (BaseInfo v -> Map v (Either v (Built v))
forall v. BaseInfo v -> Sources v
baseSources BaseInfo v
bi) = Int -> v -> Bool
known (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) v
u
      | Just (Right Built v
b) <- v -> Map v (Either v (Built v)) -> Maybe (Either v (Built v))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup v
w (BaseInfo v -> Map v (Either v (Built v))
forall v. BaseInfo v -> Sources v
baseSources BaseInfo v
bi) = (v -> Bool) -> [v] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> v -> Bool
known (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) (Built v -> [v]
forall v. Built v -> [v]
builtFields Built v
b)
      | Just Built v
b <- v -> Map v (Built v) -> Maybe (Built v)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup v
w (BaseInfo v -> Map v (Built v)
forall v. BaseInfo v -> Map v (Built v)
baseCons BaseInfo v
bi) = (v -> Bool) -> [v] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> v -> Bool
known (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) (Built v -> [v]
forall v. Built v -> [v]
builtFields Built v
b)
      | Bool
otherwise = Bool
False
    var :: Int -> v -> Emit v Slot
var Int
depth v
w
      | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
64 = [Word] -> [Char] -> Emit v Slot
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Slot) -> [Char] -> Emit v Slot
forall a b. (a -> b) -> a -> b
$ [Char]
"deoptOf: the source of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> [Char]
forall a. Show a => a -> [Char]
show v
w [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" refers back to itself"
      | Just (Int
d, Int
i) <- v -> Maybe (Int, Int)
optSlot v
w = Slot -> Emit v Slot
forall a. a -> Emit v a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Slot
Copy Int
d Int
i)
      | Just (Left v
u) <- v -> Map v (Either v (Built v)) -> Maybe (Either v (Built v))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup v
w (BaseInfo v -> Map v (Either v (Built v))
forall v. BaseInfo v -> Sources v
baseSources BaseInfo v
bi) = Int -> v -> Emit v Slot
var (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) v
u
      | Just (Right Built v
b) <- v -> Map v (Either v (Built v)) -> Maybe (Either v (Built v))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup v
w (BaseInfo v -> Map v (Either v (Built v))
forall v. BaseInfo v -> Sources v
baseSources BaseInfo v
bi) = Int -> Built v -> Emit v Slot
pack Int
depth Built v
b
      | Just Built v
b <- v -> Map v (Built v) -> Maybe (Built v)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup v
w (BaseInfo v -> Map v (Built v)
forall v. BaseInfo v -> Map v (Built v)
baseCons BaseInfo v
bi) = Int -> Built v -> Emit v Slot
pack Int
depth Built v
b
      | Bool
otherwise =
          [Word] -> [Char] -> Emit v Slot
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Slot) -> [Char] -> Emit v Slot
forall a b. (a -> b) -> a -> b
$
            [Char]
"deoptOf: no source for "
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> [Char]
forall a. Show a => a -> [Char]
show v
w
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" in the frames of "
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"; unoptimized let "
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [v] -> [Char]
forall a. Show a => a -> [Char]
show [v]
bs
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (section "
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
bidx
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
") with frames "
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Chain v -> [Char]
forall a. Show a => a -> [Char]
show Chain v
produced
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"; optimized let "
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [v] -> [Char]
forall a. Show a => a -> [Char]
show [v]
us
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" with frames "
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Chain v -> [Char]
forall a. Show a => a -> [Char]
show Chain v
chain
    pack :: Int -> Built v -> Emit v Slot
pack Int
depth (BuiltCon Reference
r CTag
t [v]
fs) = PackedTag -> [Slot] -> Slot
PackSlot (RTag -> CTag -> PackedTag
packTags (Int -> RTag
forall a. Enum a => Int -> a
toEnum (Int -> RTag) -> (Word64 -> Int) -> Word64 -> RTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> RTag) -> Word64 -> RTag
forall a b. (a -> b) -> a -> b
$ RefNums -> Reference -> Word64
dnum RefNums
rns Reference
r) CTag
t) ([Slot] -> Slot) -> Emit v [Slot] -> Emit v Slot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (v -> Emit v Slot) -> [v] -> Emit v [Slot]
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) -> [a] -> f [b]
traverse (Int -> v -> Emit v Slot
var (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [v]
fs
    pack Int
depth (BuiltRec RecordSchema
rs [v]
fs) = RecordShape -> [Slot] -> Slot
RecSlot (RecordShape -> [Slot] -> Slot)
-> Emit v RecordShape -> Emit v ([Slot] -> Slot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordRef -> RecordSchema -> Emit v RecordShape
forall (m :: * -> *).
MonadState RecordFieldMappings m =>
RecordRef -> RecordSchema -> m RecordShape
recordShape (RefNums -> RecordSchema -> RecordRef
recNum RefNums
rns RecordSchema
rs) RecordSchema
rs Emit v ([Slot] -> Slot) -> Emit v [Slot] -> Emit v Slot
forall a b. Emit v (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (v -> Emit v Slot) -> [v] -> Emit v [Slot]
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) -> [a] -> f [b]
traverse (Int -> v -> Emit v Slot
var (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [v]
fs
    optSlot :: v -> Maybe (Int, Int)
optSlot v
w = [(Int, Int)] -> Maybe (Int, Int)
forall a. [a] -> Maybe a
listToMaybe [(Int
d, Int
i) | (Int
d, (Maybe Word64
_, [Entry v]
es)) <- [Int] -> Chain v -> [(Int, (Maybe Word64, [Entry v]))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] Chain v
chain, (Int
i, EVar v
x) <- [Int] -> [Entry v] -> [(Int, Entry v)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Entry v]
es, v
x v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
w]

-- Counts the stack space used by a context and annotates a value
-- with it.
countCtx :: Ctx v -> a -> Emit v a
countCtx :: forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx = Counted a -> Emit v a
forall a v. Counted a -> Emit v a
counted (Counted a -> Emit v a) -> (a -> Counted a) -> a -> Emit v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> Counted a
forall a. Int -> a -> Counted a
C Int
i
  where
    i :: Int
i = Int -> Ctx v -> Int
forall v. Int -> Ctx v -> Int
countCtx0 Int
0 Ctx v
ctx

countCtx0 :: Int -> Ctx v -> Int
countCtx0 :: forall v. Int -> Ctx v -> Int
countCtx0 !Int
i (Var v
_ Mem
_ Ctx v
ctx) = Int -> Ctx v -> Int
forall v. Int -> Ctx v -> Int
countCtx0 (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Ctx v
ctx
countCtx0 !Int
i (Wide v
_ Mem
_ Ctx v
ctx) = Int -> Ctx v -> Int
forall v. Int -> Ctx v -> Int
countCtx0 (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wideWidth) Ctx v
ctx
countCtx0 Int
i (Tag Ctx v
ctx) = Int -> Ctx v -> Int
forall v. Int -> Ctx v -> Int
countCtx0 (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Ctx v
ctx
countCtx0 Int
i (Block Word64
_ Ctx v
ctx) = Int -> Ctx v -> Int
forall v. Int -> Ctx v -> Int
countCtx0 Int
i Ctx v
ctx
countCtx0 Int
i Ctx v
ECtx = Int
i

emitComb ::
  (Var v) =>
  RefNums ->
  Reference ->
  Word64 ->
  RCtx v ->
  (Word64, SuperNormal Reference v) ->
  State RecordFieldMappings (EC.EnumMap Word64 Comb, EC.EnumMap Word64 (Chain v))
emitComb :: forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
emitComb RefNums
rns Reference
grpr Word64
grpn RCtx v
rec0 (Word64
n, Lambda [Mem]
ccs (TAbss [v]
vs ANormal Reference v
bd0))
  -- a body yields one value, or the leaves of its product for a
  -- product-return worker (Unison.Runtime.MCode.Explode)
  | Just Int
k <- (Reference -> Word64 -> Maybe Int)
-> ANormal Reference v -> Maybe Int
forall v.
Var v =>
(Reference -> Word64 -> Maybe Int) -> RNormal v -> Maybe Int
resultCount (RefNums -> Reference -> Word64 -> Maybe Int
combYields RefNums
rns) ANormal Reference v
bd,
    Just Int
e <- RefNums -> Reference -> Word64 -> Maybe Int
combYields RefNums
rns Reference
grpr Word64
n,
    Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
e =
      [Word]
-> [Char]
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char]
 -> State
      RecordFieldMappings
      (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))
-> [Char]
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
forall a b. (a -> b) -> a -> b
$
        [Char]
"emitComb: a function body that yields " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
k [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" values where " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
e [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" are expected: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ANormal Reference v -> [Char]
forall a. Show a => a -> [Char]
show ANormal Reference v
bd
  | Bool
otherwise =
      Word64
-> Emit v ()
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
forall v a.
Word64
-> Emit v a
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
runEmit Word64
n
        (Emit v ()
 -> State
      RecordFieldMappings
      (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))
-> (Emit v Section -> Emit v ())
-> Emit v Section
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> Word16 -> Emit v Section -> Emit v ()
forall v. [v] -> Word16 -> Emit v Section -> Emit v ()
recordTop [v]
vs Word16
0
        (Emit v Section
 -> State
      RecordFieldMappings
      (EnumMap Word64 Comb, EnumMap Word64 (Chain v)))
-> Emit v Section
-> State
     RecordFieldMappings (EnumMap Word64 Comb, EnumMap Word64 (Chain v))
forall a b. (a -> b) -> a -> b
$ RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ANormal Reference v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec ([v] -> [Mem] -> Ctx v
forall v. [v] -> [Mem] -> Ctx v
ctx [v]
vs [Mem]
ccs) ANormal Reference v
bd
  where
    -- the wide binders marked and the boxes placed, last
    -- (Unison.Runtime.MCode.Wide)
    bd :: ANormal Reference v
bd = ANormal Reference v -> ANormal Reference v
forall v. Var v => ANormal Reference v -> ANormal Reference v
wideBody ANormal Reference v
bd0
    -- the lambda's own lets by section index, for 'deoptOf' to find the
    -- let enclosing a section
    rec :: RCtx v
rec = RCtx v
rec0 {rctxBase = fmap (\BaseInfo v
bi -> BaseInfo v
bi {optLets = EC.mapFromList [(letIndex w n, us) | TLets (Indirect w) us _ _ _ <- universe bd]}) (rctxBase rec0)}

-- | How many values a term yields when it is in tail position, or Nothing
-- for a term that never returns (an error call). Every term yields one
-- value, except a primitive, which yields whatever its instruction pushes
-- ('pushCount': two for a @LOAD@, none for a trace), a term that ends in
-- one, a discard or an update, which push nothing, and the explosion's
-- two forms (Unison.Runtime.MCode.Explode): a yield of several values,
-- and a call of a worker, which yields what the worker's combinator
-- does (the first argument).
--
-- The emitter lays a let's body out for as many slots as the let binds and
-- a function's caller for one, and nothing at run time counts what a yield
-- delivers: a body laid out for more values than arrive reads the slots
-- below its frame. So 'emitSection' refuses a let whose binding yields
-- other than the number of names it binds, 'emitComb' refuses a function
-- body that yields other than one value (which is what lets a call count
-- as one here, with no signature of the callee), and a handled block has
-- to yield one too, since a continuation captured inside it delivers the
-- block's result wherever it is resumed. Typechecked code satisfies all
-- three by construction (a let names one value, or none over a trace or a
-- discard; the two unboxed sums are matched in place, see 'sumFields');
-- code decoded from bytes is held to them here, before any machine code
-- exists for it.
resultCount :: (Var v) => (Reference -> Word64 -> Maybe Int) -> RNormal v -> Maybe Int
resultCount :: forall v.
Var v =>
(Reference -> Word64 -> Maybe Int) -> RNormal v -> Maybe Int
resultCount Reference -> Word64 -> Maybe Int
yields = ANormal Reference v -> Maybe Int
go
  where
    go :: ANormal Reference v -> Maybe Int
go = \case
      TLets Direction Word16
_ [v]
_ [Mem]
_ ANormal Reference v
_ ANormal Reference v
bo -> ANormal Reference v -> Maybe Int
go ANormal Reference v
bo
      TName v
_ Either Reference v
_ [v]
_ ANormal Reference v
bo -> ANormal Reference v -> Maybe Int
go ANormal Reference v
bo
      TLocal v
_ ANormal Reference v
bo -> ANormal Reference v -> Maybe Int
go ANormal Reference v
bo
      TShift Reference
_ v
_ ANormal Reference v
e -> ANormal Reference v -> Maybe Int
go ANormal Reference v
e
      THnd [Reference]
_ v
_ Maybe v
_ ANormal Reference v
b -> case ANormal Reference v -> Maybe Int
go ANormal Reference v
b of
        Just Int
n
          | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 ->
              [Word] -> [Char] -> Maybe Int
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Maybe Int) -> [Char] -> Maybe Int
forall a b. (a -> b) -> a -> b
$
                [Char]
"emitSection: a handled block that yields " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" values: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ANormal Reference v -> [Char]
forall a. Show a => a -> [Char]
show ANormal Reference v
b
        Maybe Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
      TPrm POp
p [v]
args -> (Args -> GInstr CombIx) -> [v] -> Maybe Int
forall {t :: * -> *} {comb} {a}.
(Foldable t, Show comb) =>
(Args -> GInstr comb) -> t a -> Maybe Int
primCount (POp -> Args -> GInstr CombIx
emitPOp POp
p) [v]
args
      TFOp ForeignFunc
p [v]
args -> (Args -> GInstr CombIx) -> [v] -> Maybe Int
forall {t :: * -> *} {comb} {a}.
(Foldable t, Show comb) =>
(Args -> GInstr comb) -> t a -> Maybe Int
primCount (ForeignFunc -> Args -> GInstr CombIx
emitFOp ForeignFunc
p) [v]
args
      TDiscard v
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
      TUpdate {} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
      TBox v
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
      TApp Func Reference v
FYield [v]
vs -> Int -> Maybe Int
forall a. a -> Maybe a
Just ([v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
vs)
      TApp (FWorker Reference
r Word64
i) [v]
_ -> Reference -> Word64 -> Maybe Int
yields Reference
r Word64
i
      tm :: ANormal Reference v
tm@(TMatch v
_ Branched Reference (ANormal Reference v)
bs) -> case [Int] -> [Int]
forall a. Ord a => [a] -> [a]
nubOrd ((ANormal Reference v -> Maybe Int)
-> [ANormal Reference v] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ANormal Reference v -> Maybe Int
armCount (Branched Reference (ANormal Reference v) -> [ANormal Reference v]
forall a. Branched Reference a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Branched Reference (ANormal Reference v)
bs)) of
        [] -> Maybe Int
forall a. Maybe a
Nothing
        [Int
n] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
        [Int]
ns ->
          [Word] -> [Char] -> Maybe Int
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Maybe Int) -> [Char] -> Maybe Int
forall a b. (a -> b) -> a -> b
$
            [Char]
"emitSection: the arms of a match yield " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show [Int]
ns [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" values: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ANormal Reference v -> [Char]
forall a. Show a => a -> [Char]
show ANormal Reference v
tm
      ANormal Reference v
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
    armCount :: ANormal Reference v -> Maybe Int
armCount (TAbss [v]
_ ANormal Reference v
bo) = ANormal Reference v -> Maybe Int
go ANormal Reference v
bo
    -- the instruction the primitive emits, given arguments of the right
    -- count (which slots they are in does not matter for the count); every
    -- instruction a primitive emits has a count (the ones without one, a
    -- capture, a discard and a sandboxing failure, come from elsewhere)
    primCount :: (Args -> GInstr comb) -> t a -> Maybe Int
primCount Args -> GInstr comb
emit t a
args = case Args -> GInstr comb
emit (Int -> Args
dummyArgs (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args)) of
      Prim2 Prim2
THRO Int
_ Int
_ -> Maybe Int
forall a. Maybe a
Nothing
      GInstr comb
instr -> case GInstr comb -> Maybe Int
forall comb. GInstr comb -> Maybe Int
pushCount GInstr comb
instr of
        Just Int
n -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
        Maybe Int
Nothing -> [Word] -> [Char] -> Maybe Int
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Maybe Int) -> [Char] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Char]
"resultCount: a primitive emitting an instruction without a push count: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ GInstr comb -> [Char]
forall a. Show a => a -> [Char]
show GInstr comb
instr
    dummyArgs :: Int -> Args
dummyArgs = \case
      Int
0 -> Args
ZArgs
      Int
1 -> Int -> Args
VArg1 Int
0
      Int
2 -> Int -> Int -> Args
VArg2 Int
0 Int
0
      Int
n -> PrimArray Int -> Args
VArgN ([Int] -> PrimArray Int
forall a. Prim a => [a] -> PrimArray a
PA.primArrayFromList (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
n Int
0))

-- | A record literal has to supply a value for every field of its shape:
-- a record's values are read by slot, with the slot taken from the shape
-- and no bound taken from the array (native code's record read; the
-- interpreter's indexing is checked and dies), so a short array would be
-- read past its end. Typechecked code never writes one; code decoded from
-- bytes is refused here.
recordArity :: RecordShape -> Int -> a -> a
recordArity :: forall a. RecordShape -> Int -> a -> a
recordArity RecordShape
shape Int
n a
a
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Vector FieldName -> Int
forall a. Vector a -> Int
V.length (RecordShape -> Vector FieldName
shapeFields RecordShape
shape) = a
a
  | Bool
otherwise =
      [Word] -> [Char] -> a
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$
        [Char]
"emitSection: a record literal of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" values for a shape of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Vector FieldName -> Int
forall a. Vector a -> Int
V.length (RecordShape -> Vector FieldName
shapeFields RecordShape
shape)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" fields: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Vector FieldName -> [Char]
forall a. Show a => a -> [Char]
show (RecordShape -> Vector FieldName
shapeFields RecordShape
shape)

addCount :: Int -> Emit v a -> Emit v a
addCount :: forall v a. Int -> Emit v a -> Emit v a
addCount Int
i (EM ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
m) = ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
-> Emit v a
forall v a.
ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
-> Emit v a
EM (ReaderT
   Word64
   (WriterT
      (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
      (StateT RecordFieldMappings Identity))
   a
 -> Emit v a)
-> ReaderT
     Word64
     (WriterT
        (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
        (StateT RecordFieldMappings Identity))
     a
-> Emit v a
forall a b. (a -> b) -> a -> b
$ do
  (a
a, (EnumMap Word64 Comb
_m, Max Int
n, EnumMap Word64 (Chain v)
_)) <- ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
-> ReaderT
     Word64
     (WriterT
        (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
        (StateT RecordFieldMappings Identity))
     (a, (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v)))
forall a.
ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
-> ReaderT
     Word64
     (WriterT
        (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
        (StateT RecordFieldMappings Identity))
     (a, (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v)))
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen ReaderT
  Word64
  (WriterT
     (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
     (StateT RecordFieldMappings Identity))
  a
m
  (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
-> ReaderT
     Word64
     (WriterT
        (EnumMap Word64 Comb, Max Int, EnumMap Word64 (Chain v))
        (StateT RecordFieldMappings Identity))
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (EnumMap Word64 Comb
forall a. Monoid a => a
mempty, Int -> Max Int
forall a. a -> Max a
Max (Int -> Max Int) -> Int -> Max Int
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i, EnumMap Word64 (Chain v)
forall a. Monoid a => a
mempty)
  pure a
a

-- Emit a machine code section from an ANF term
emitSection ::
  (Var v) =>
  RefNums ->
  Reference ->
  Word64 ->
  RCtx v ->
  Ctx v ->
  RNormal v ->
  Emit v Section
emitSection :: forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx (TLets Direction Word16
d [v]
us [Mem]
ms ANormal Reference v
bu ANormal Reference v
bo)
  -- An unboxed sum: the primitive pushes a tag over the fields of the case
  -- it took, the let names only the tag, and each arm binds the fields of
  -- its tag in place, below the tag ('sumCtx'). So the match has to be the
  -- body of a direct let of the one tag over a primitive that yields a
  -- sum, and an arm has to bind exactly the fields the primitive leaves
  -- for its tag ('sumFields'), or it would read slots the primitive never
  -- wrote. Only two primitives yield a sum, and both are matched this way
  -- in the builtins; a sum match anywhere else is refused.
  | TMatch v
v (MatchSum EnumMap Word64 ([Mem], ANormal Reference v)
cs) <- ANormal Reference v
bo =
      case (Direction Word16
d, [v]
us, ANormal Reference v
bu) of
        (Direction Word16
Direct, [v
u], TPrm POp
p [v]
_)
          | v
u v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v,
            Just (Int
i, Mem
UN) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ectx v
v,
            ((Word64, ([Mem], ANormal Reference v)) -> Bool)
-> [(Word64, ([Mem], ANormal Reference v))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Word64
t, ([Mem]
ccs, TAbss [v]
vs ANormal Reference v
_)) -> Int -> Maybe Int
forall a. a -> Maybe a
Just ([(v, Mem)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([v] -> [Mem] -> [(v, Mem)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
vs [Mem]
ccs)) Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== POp -> Word64 -> Maybe Int
sumFields POp
p Word64
t) (EnumMap Word64 ([Mem], ANormal Reference v)
-> [(Word64, ([Mem], ANormal Reference v))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 ([Mem], ANormal Reference v)
cs) ->
              RefNums
-> Reference
-> Word64
-> RCtx v
-> Direction Word16
-> [(v, Mem)]
-> Ctx v
-> ANormal Reference v
-> Emit v Section
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Direction Word16
-> [(v, Mem)]
-> Ctx v
-> RNormal v
-> Emit v Section
-> Emit v Section
emitLet RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Direction Word16
d ([v] -> [Mem] -> [(v, Mem)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
us [Mem]
ms) Ctx v
ctx ANormal Reference v
bu (Emit v Section -> Emit v Section)
-> Emit v Section -> Emit v Section
forall a b. (a -> b) -> a -> b
$
                RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> v
-> Int
-> EnumMap Word64 ([Mem], ANormal Reference v)
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> v
-> Int
-> EnumMap Word64 ([Mem], RNormal v)
-> Emit v Section
emitSumMatching RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ectx v
v Int
i EnumMap Word64 ([Mem], ANormal Reference v)
cs
        (Direction Word16, [v], ANormal Reference v)
_ ->
          [Word] -> [Char] -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Section) -> [Char] -> Emit v Section
forall a b. (a -> b) -> a -> b
$
            [Char]
"emitSection: an unboxed sum match that is not the body of a direct let of its tag over a primitive yielding that sum, with each arm binding the primitive's fields for its tag: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ANormal Reference v -> [Char]
forall a. Show a => a -> [Char]
show (Direction Word16
-> [v]
-> [Mem]
-> ANormal Reference v
-> ANormal Reference v
-> ANormal Reference v
forall v ref.
Var v =>
Direction Word16
-> [v] -> [Mem] -> ANormal ref v -> ANormal ref v -> ANormal ref v
TLets Direction Word16
d [v]
us [Mem]
ms ANormal Reference v
bu ANormal Reference v
bo)
  | Just Int
n <- (Reference -> Word64 -> Maybe Int)
-> ANormal Reference v -> Maybe Int
forall v.
Var v =>
(Reference -> Word64 -> Maybe Int) -> RNormal v -> Maybe Int
resultCount (RefNums -> Reference -> Word64 -> Maybe Int
combYields RefNums
rns) ANormal Reference v
bu,
    Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
us =
      [Word] -> [Char] -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Section) -> [Char] -> Emit v Section
forall a b. (a -> b) -> a -> b
$
        [Char]
"emitSection: a let of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
us) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" names whose binding yields " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" values: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ANormal Reference v -> [Char]
forall a. Show a => a -> [Char]
show ANormal Reference v
bu
  -- a wide binder is one variable whose binding yields or builds a small
  -- constructor (Unison.Runtime.MCode.Wide, 'wideBody')
  | Mem
WD Mem -> [Mem] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Mem]
ms,
    [Mem]
ms [Mem] -> [Mem] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Mem
WD] Bool -> Bool -> Bool
|| Bool -> Bool
not (ANormal Reference v -> Bool
forall v. Var v => ANormal Reference v -> Bool
letYields ANormal Reference v
bu Bool -> Bool -> Bool
|| ANormal Reference v -> Bool
forall v. Var v => ANormal Reference v -> Bool
wideCon ANormal Reference v
bu) =
      [Word] -> [Char] -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Section) -> [Char] -> Emit v Section
forall a b. (a -> b) -> a -> b
$ [Char]
"emitSection: a wide binder on a let that neither yields nor builds a small constructor: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ANormal Reference v -> [Char]
forall a. Show a => a -> [Char]
show (Direction Word16
-> [v]
-> [Mem]
-> ANormal Reference v
-> ANormal Reference v
-> ANormal Reference v
forall v ref.
Var v =>
Direction Word16
-> [v] -> [Mem] -> ANormal ref v -> ANormal ref v -> ANormal ref v
TLets Direction Word16
d [v]
us [Mem]
ms ANormal Reference v
bu ANormal Reference v
bo)
  -- a small constructor stays in its wide variable's slots, boxed where
  -- it escapes ('TBox'): a path on which it never escapes allocates
  -- nothing
  | [Mem
WD] <- [Mem]
ms,
    TApp (FCon Reference
r CTag
n) [v]
args <- ANormal Reference v
bu =
      let rt :: RTag
rt = Int -> RTag
forall a. Enum a => Int -> a
toEnum (Int -> RTag) -> (Word64 -> Int) -> Word64 -> RTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> RTag) -> Word64 -> RTag
forall a b. (a -> b) -> a -> b
$ RefNums -> Reference -> Word64
dnum RefNums
rns Reference
r
       in Int -> Emit v Section -> Emit v Section
forall v a. Int -> Emit v a -> Emit v a
addCount Int
wideWidth
            (Emit v Section -> Emit v Section)
-> (Emit v Section -> Emit v Section)
-> Emit v Section
-> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Section -> Section) -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (PackedTag -> Bool -> Args -> GInstr CombIx
forall comb. PackedTag -> Bool -> Args -> GInstr comb
PackWide (RTag -> CTag -> PackedTag
packTags RTag
rt CTag
n) Bool
False (Word64 -> Ctx v -> [v] -> Args
forall v. Var v => Word64 -> Ctx v -> [v] -> Args
emitArgs Word64
grpn Ctx v
ctx [v]
args)))
            (Emit v Section -> Emit v Section)
-> Emit v Section -> Emit v Section
forall a b. (a -> b) -> a -> b
$ RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ANormal Reference v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ectx ANormal Reference v
bo
  | Bool
otherwise =
      RefNums
-> Reference
-> Word64
-> RCtx v
-> Direction Word16
-> [(v, Mem)]
-> Ctx v
-> ANormal Reference v
-> Emit v Section
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Direction Word16
-> [(v, Mem)]
-> Ctx v
-> RNormal v
-> Emit v Section
-> Emit v Section
emitLet RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Direction Word16
d ([v] -> [Mem] -> [(v, Mem)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
us [Mem]
ms) Ctx v
ctx ANormal Reference v
bu (Emit v Section -> Emit v Section)
-> Emit v Section -> Emit v Section
forall a b. (a -> b) -> a -> b
$
        RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ANormal Reference v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ectx ANormal Reference v
bo
  where
    ectx :: Ctx v
ectx = [(v, Mem)] -> Ctx v -> Ctx v
forall v. [(v, Mem)] -> Ctx v -> Ctx v
pushCtx ([v] -> [Mem] -> [(v, Mem)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
us [Mem]
ms) Ctx v
ctx
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx (TName v
u (Left Reference
f) [v]
args ANormal Reference v
bo) =
  Reference
-> Word64
-> RCtx v
-> Ctx v
-> [v]
-> (Ctx v -> Args -> Emit v Section)
-> Emit v Section
forall v.
Var v =>
Reference
-> Word64
-> RCtx v
-> Ctx v
-> [v]
-> (Ctx v -> Args -> Emit v Section)
-> Emit v Section
emitClosures Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx [v]
args ((Ctx v -> Args -> Emit v Section) -> Emit v Section)
-> (Ctx v -> Args -> Emit v Section) -> Emit v Section
forall a b. (a -> b) -> a -> b
$ \Ctx v
ctx Args
as ->
    let cix :: CombIx
cix = (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
f (RefNums -> Reference -> Word64
cnum RefNums
rns Reference
f) Word64
0)
     in GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GRef CombIx -> Args -> GInstr CombIx
forall comb. GRef comb -> Args -> GInstr comb
Name (CombIx -> CombIx -> GRef CombIx
forall comb. CombIx -> comb -> GRef comb
Env CombIx
cix CombIx
cix) Args
as)
          (Section -> Section) -> Emit v Section -> Emit v Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ANormal Reference v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec (v -> Mem -> Ctx v -> Ctx v
forall v. v -> Mem -> Ctx v -> Ctx v
Var v
u Mem
BX Ctx v
ctx) ANormal Reference v
bo
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx (TName v
u (Right v
v) [v]
args ANormal Reference v
bo)
  | Just (Int
i, Mem
BX) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v =
      Reference
-> Word64
-> RCtx v
-> Ctx v
-> [v]
-> (Ctx v -> Args -> Emit v Section)
-> Emit v Section
forall v.
Var v =>
Reference
-> Word64
-> RCtx v
-> Ctx v
-> [v]
-> (Ctx v -> Args -> Emit v Section)
-> Emit v Section
emitClosures Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx [v]
args ((Ctx v -> Args -> Emit v Section) -> Emit v Section)
-> (Ctx v -> Args -> Emit v Section) -> Emit v Section
forall a b. (a -> b) -> a -> b
$ \Ctx v
ctx Args
as ->
        GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GRef CombIx -> Args -> GInstr CombIx
forall comb. GRef comb -> Args -> GInstr comb
Name (Int -> GRef CombIx
forall comb. Int -> GRef comb
Stk Int
i) Args
as)
          (Section -> Section) -> Emit v Section -> Emit v Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ANormal Reference v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec (v -> Mem -> Ctx v -> Ctx v
forall v. v -> Mem -> Ctx v -> Ctx v
Var v
u Mem
BX Ctx v
ctx) ANormal Reference v
bo
  | Just Word64
n <- RCtx v -> v -> Maybe Word64
forall v. Var v => RCtx v -> v -> Maybe Word64
rctxResolve RCtx v
rec v
v =
      Reference
-> Word64
-> RCtx v
-> Ctx v
-> [v]
-> (Ctx v -> Args -> Emit v Section)
-> Emit v Section
forall v.
Var v =>
Reference
-> Word64
-> RCtx v
-> Ctx v
-> [v]
-> (Ctx v -> Args -> Emit v Section)
-> Emit v Section
emitClosures Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx [v]
args ((Ctx v -> Args -> Emit v Section) -> Emit v Section)
-> (Ctx v -> Args -> Emit v Section) -> Emit v Section
forall a b. (a -> b) -> a -> b
$ \Ctx v
ctx Args
as ->
        let cix :: CombIx
cix = (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
grpr Word64
grpn Word64
n)
         in GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GRef CombIx -> Args -> GInstr CombIx
forall comb. GRef comb -> Args -> GInstr comb
Name (CombIx -> CombIx -> GRef CombIx
forall comb. CombIx -> comb -> GRef comb
Env CombIx
cix CombIx
cix) Args
as)
              (Section -> Section) -> Emit v Section -> Emit v Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ANormal Reference v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec (v -> Mem -> Ctx v -> Ctx v
forall v. v -> Mem -> Ctx v -> Ctx v
Var v
u Mem
BX Ctx v
ctx) ANormal Reference v
bo
  | Bool
otherwise = v -> Emit v Section
forall v a. (Var v, HasCallStack) => v -> a
emitSectionVErr v
v
emitSection RefNums
_ Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx (TVar v
v)
  -- a wide variable yields its slots
  | Just (Int
i, Mem
_) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v,
    Bool
wideOn,
    Ctx v -> v -> Bool
forall v. Var v => Ctx v -> v -> Bool
ctxWide Ctx v
ctx v
v =
      Ctx v -> Section -> Emit v Section
forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx (Section -> Emit v Section)
-> (Args -> Section) -> Args -> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Section
forall comb. Args -> GSection comb
Yield (Args -> Emit v Section) -> Args -> Emit v Section
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args
VArgR Int
i Int
wideWidth
  | Just (Int
i, Mem
_) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v = Ctx v -> Section -> Emit v Section
forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx (Section -> Emit v Section)
-> (Args -> Section) -> Args -> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Section
forall comb. Args -> GSection comb
Yield (Args -> Emit v Section) -> Args -> Emit v Section
forall a b. (a -> b) -> a -> b
$ Int -> Args
VArg1 Int
i
  | Just Word64
j <- RCtx v -> v -> Maybe Word64
forall v. Var v => RCtx v -> v -> Maybe Word64
rctxResolve RCtx v
rec v
v =
      let cix :: CombIx
cix = (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
grpr Word64
grpn Word64
j)
       in Ctx v -> Section -> Emit v Section
forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx (Section -> Emit v Section) -> Section -> Emit v Section
forall a b. (a -> b) -> a -> b
$ Bool -> GRef CombIx -> Args -> Section
forall comb. Bool -> GRef comb -> Args -> GSection comb
App Bool
False (CombIx -> CombIx -> GRef CombIx
forall comb. CombIx -> comb -> GRef comb
Env CombIx
cix CombIx
cix) (Args -> Section) -> Args -> Section
forall a b. (a -> b) -> a -> b
$ Args
ZArgs
  | Bool
otherwise = v -> Emit v Section
forall v a. (Var v, HasCallStack) => v -> a
emitSectionVErr v
v
emitSection RefNums
_ Reference
_ Word64
grpn RCtx v
_ Ctx v
ctx (TPrm POp
p [v]
args) =
  -- 3 is a conservative estimate of how many extra stack slots
  -- a prim op will need for its results.
  Int -> Emit v Section -> Emit v Section
forall v a. Int -> Emit v a -> Emit v a
addCount Int
3
    (Emit v Section -> Emit v Section)
-> (Int -> Emit v Section) -> Int -> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx v -> Section -> Emit v Section
forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx
    (Section -> Emit v Section)
-> (Int -> Section) -> Int -> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (POp -> Args -> GInstr CombIx
emitPOp POp
p (Args -> GInstr CombIx) -> Args -> GInstr CombIx
forall a b. (a -> b) -> a -> b
$ Word64 -> Ctx v -> [v] -> Args
forall v. Var v => Word64 -> Ctx v -> [v] -> Args
emitArgs Word64
grpn Ctx v
ctx [v]
args)
    (Section -> Section) -> (Int -> Section) -> Int -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Section
forall comb. Args -> GSection comb
Yield
    (Args -> Section) -> (Int -> Args) -> Int -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Args
VArgV
    (Int -> Emit v Section) -> Int -> Emit v Section
forall a b. (a -> b) -> a -> b
$ Ctx v -> Int
forall v. Ctx v -> Int
countBlock Ctx v
ctx
emitSection RefNums
_ Reference
_ Word64
grpn RCtx v
_ Ctx v
ctx (TFOp ForeignFunc
p [v]
args) =
  Int -> Emit v Section -> Emit v Section
forall v a. Int -> Emit v a -> Emit v a
addCount Int
3
    (Emit v Section -> Emit v Section)
-> (Int -> Emit v Section) -> Int -> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx v -> Section -> Emit v Section
forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx
    (Section -> Emit v Section)
-> (Int -> Section) -> Int -> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (ForeignFunc -> Args -> GInstr CombIx
emitFOp ForeignFunc
p (Args -> GInstr CombIx) -> Args -> GInstr CombIx
forall a b. (a -> b) -> a -> b
$ Word64 -> Ctx v -> [v] -> Args
forall v. Var v => Word64 -> Ctx v -> [v] -> Args
emitArgs Word64
grpn Ctx v
ctx [v]
args)
    (Section -> Section) -> (Int -> Section) -> Int -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Section
forall comb. Args -> GSection comb
Yield
    (Args -> Section) -> (Int -> Args) -> Int -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Args
VArgV
    (Int -> Emit v Section) -> Int -> Emit v Section
forall a b. (a -> b) -> a -> b
$ Ctx v -> Int
forall v. Ctx v -> Int
countBlock Ctx v
ctx
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx (TApp Func Reference v
f [v]
args) =
  Reference
-> Word64
-> RCtx v
-> Ctx v
-> [v]
-> (Ctx v -> Args -> Emit v Section)
-> Emit v Section
forall v.
Var v =>
Reference
-> Word64
-> RCtx v
-> Ctx v
-> [v]
-> (Ctx v -> Args -> Emit v Section)
-> Emit v Section
emitClosures Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx [v]
args ((Ctx v -> Args -> Emit v Section) -> Emit v Section)
-> (Ctx v -> Args -> Emit v Section) -> Emit v Section
forall a b. (a -> b) -> a -> b
$ \Ctx v
ctx Args
as -> do
    -- A record shape, or the reference for a field a record update replaces,
    -- has to be interned into a shared table, which is why these are resolved
    -- here rather than inside pure `emitFunction`.
    Maybe RecEmit
mrec <- case Func Reference v
f of
      FRec RecordSchema
rs -> RecEmit -> Maybe RecEmit
forall a. a -> Maybe a
Just (RecEmit -> Maybe RecEmit)
-> (RecordShape -> RecEmit) -> RecordShape -> Maybe RecEmit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordShape -> RecEmit
RecEmitShape (RecordShape -> Maybe RecEmit)
-> Emit v RecordShape -> Emit v (Maybe RecEmit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordRef -> RecordSchema -> Emit v RecordShape
forall (m :: * -> *).
MonadState RecordFieldMappings m =>
RecordRef -> RecordSchema -> m RecordShape
recordShape (RefNums -> RecordSchema -> RecordRef
recNum RefNums
rns RecordSchema
rs) RecordSchema
rs
      FRecSet FieldName
field -> RecEmit -> Maybe RecEmit
forall a. a -> Maybe a
Just (RecEmit -> Maybe RecEmit)
-> (Vector FieldRef -> RecEmit) -> Vector FieldRef -> Maybe RecEmit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldRef -> RecEmit
RecEmitSet (FieldRef -> RecEmit)
-> (Vector FieldRef -> FieldRef) -> Vector FieldRef -> RecEmit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector FieldRef -> FieldRef
forall a. Vector a -> a
V.head (Vector FieldRef -> Maybe RecEmit)
-> Emit v (Vector FieldRef) -> Emit v (Maybe RecEmit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector FieldName -> Emit v (Vector FieldRef)
forall (m :: * -> *) (f :: * -> *).
(MonadState RecordFieldMappings m, Traversable f) =>
f FieldName -> m (f FieldRef)
convertFieldNamesToRefs (FieldName -> Vector FieldName
forall a. a -> Vector a
V.singleton FieldName
field)
      Func Reference v
_ -> Maybe RecEmit -> Emit v (Maybe RecEmit)
forall a. a -> Emit v a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RecEmit
forall a. Maybe a
Nothing
    Ctx v -> Section -> Emit v Section
forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx (Section -> Emit v Section) -> Section -> Emit v Section
forall a b. (a -> b) -> a -> b
$ RefNums
-> Maybe RecEmit
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Func Reference v
-> Args
-> Section
forall v.
Var v =>
RefNums
-> Maybe RecEmit
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Func Reference v
-> Args
-> Section
emitFunction RefNums
rns Maybe RecEmit
mrec Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx Func Reference v
f Args
as
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx (TLocal v
v ANormal Reference v
bo)
  | Just (Int
i, Mem
BX) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v =
      GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (Int -> GInstr CombIx
forall comb. Int -> GInstr comb
InLocal Int
i)
        (Section -> Section) -> Emit v Section -> Emit v Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ANormal Reference v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx ANormal Reference v
bo
  | Bool
otherwise = v -> Emit v Section
forall v a. (Var v, HasCallStack) => v -> a
emitSectionVErr v
v
emitSection RefNums
_ Reference
_ Word64
_ RCtx v
_ Ctx v
ctx (TLit Lit Reference
l) =
  Emit v Section -> Emit v Section
c (Emit v Section -> Emit v Section)
-> (Args -> Emit v Section) -> Args -> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx v -> Section -> Emit v Section
forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx (Section -> Emit v Section)
-> (Args -> Section) -> Args -> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (Lit Reference -> GInstr CombIx
emitLit Lit Reference
l) (Section -> Section) -> (Args -> Section) -> Args -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Section
forall comb. Args -> GSection comb
Yield (Args -> Emit v Section) -> Args -> Emit v Section
forall a b. (a -> b) -> a -> b
$ Int -> Args
VArg1 Int
0
  where
    c :: Emit v Section -> Emit v Section
c
      | ANF.T {} <- Lit Reference
l = Int -> Emit v Section -> Emit v Section
forall v a. Int -> Emit v a -> Emit v a
addCount Int
1
      | ANF.LM {} <- Lit Reference
l = Int -> Emit v Section -> Emit v Section
forall v a. Int -> Emit v a -> Emit v a
addCount Int
1
      | ANF.LY {} <- Lit Reference
l = Int -> Emit v Section -> Emit v Section
forall v a. Int -> Emit v a -> Emit v a
addCount Int
1
      | Bool
otherwise = Int -> Emit v Section -> Emit v Section
forall v a. Int -> Emit v a -> Emit v a
addCount Int
1
emitSection RefNums
_ Reference
_ Word64
_ RCtx v
_ Ctx v
ctx (TBLit Lit Reference
l) =
  Int -> Emit v Section -> Emit v Section
forall v a. Int -> Emit v a -> Emit v a
addCount Int
1 (Emit v Section -> Emit v Section)
-> (Args -> Emit v Section) -> Args -> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx v -> Section -> Emit v Section
forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx (Section -> Emit v Section)
-> (Args -> Section) -> Args -> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (Lit Reference -> GInstr CombIx
emitLit Lit Reference
l) (Section -> Section) -> (Args -> Section) -> Args -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Section
forall comb. Args -> GSection comb
Yield (Args -> Emit v Section) -> Args -> Emit v Section
forall a b. (a -> b) -> a -> b
$ Int -> Args
VArg1 Int
0
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx (TMatch v
v Branched Reference (ANormal Reference v)
bs)
  | Just (Int
i, Mem
BX) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v,
    MatchData Reference
r EnumMap CTag ([Mem], ANormal Reference v)
cs Maybe (ANormal Reference v)
df <- Branched Reference (ANormal Reference v)
bs =
      Maybe Reference -> Int -> GBranch CombIx -> Section
forall comb.
Maybe Reference -> Int -> GBranch comb -> GSection comb
DMatch (Reference -> Maybe Reference
forall a. a -> Maybe a
Just Reference
r) Int
i
        (GBranch CombIx -> Section)
-> Emit v (GBranch CombIx) -> Emit v Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> EnumMap CTag ([Mem], ANormal Reference v)
-> Maybe (ANormal Reference v)
-> Emit v (GBranch CombIx)
forall v.
Var v =>
Reference
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> EnumMap CTag ([Mem], RNormal v)
-> Maybe (RNormal v)
-> Emit v (GBranch CombIx)
emitDataMatching Reference
r RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx EnumMap CTag ([Mem], ANormal Reference v)
cs Maybe (ANormal Reference v)
df
  | Just (Int
i, Mem
BX) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v,
    MatchRec (ANF.RecordSchema Set FieldName
fields) (TAbss [v]
vs ANormal Reference v
bd) <- Branched Reference (ANormal Reference v)
bs = do
      Vector FieldRef
fieldRefs <- Vector FieldName -> Emit v (Vector FieldRef)
forall (m :: * -> *) (f :: * -> *).
(MonadState RecordFieldMappings m, Traversable f) =>
f FieldName -> m (f FieldRef)
convertFieldNamesToRefs ([FieldName] -> Vector FieldName
forall a. [a] -> Vector a
V.fromList ([FieldName] -> Vector FieldName)
-> [FieldName] -> Vector FieldName
forall a b. (a -> b) -> a -> b
$ Set FieldName -> [FieldName]
forall a. Set a -> [a]
Set.toList Set FieldName
fields)
      let instr :: GInstr CombIx
instr = Vector FieldRef -> Int -> GInstr CombIx
forall comb. Vector FieldRef -> Int -> GInstr comb
RecUnpack Vector FieldRef
fieldRefs Int
i
      let newCtx :: Ctx v
newCtx = [(v, Mem)] -> Ctx v -> Ctx v
forall v. [(v, Mem)] -> Ctx v -> Ctx v
pushCtx ([v] -> [Mem] -> [(v, Mem)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
vs (Mem -> [Mem]
forall a. a -> [a]
repeat Mem
BX {- these are ignored -})) Ctx v
ctx
      GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins GInstr CombIx
instr (Section -> Section) -> Emit v Section -> Emit v Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ANormal Reference v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
newCtx ANormal Reference v
bd
  | Just (Int
i, Mem
BX) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v,
    MatchRequest [(Reference, EnumMap CTag ([Mem], ANormal Reference v))]
hs0 ANormal Reference v
df <- Branched Reference (ANormal Reference v)
bs,
    EnumMap Word64 (EnumMap CTag ([Mem], ANormal Reference v))
hs <- [(Word64, EnumMap CTag ([Mem], ANormal Reference v))]
-> EnumMap Word64 (EnumMap CTag ([Mem], ANormal Reference v))
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList ([(Word64, EnumMap CTag ([Mem], ANormal Reference v))]
 -> EnumMap Word64 (EnumMap CTag ([Mem], ANormal Reference v)))
-> [(Word64, EnumMap CTag ([Mem], ANormal Reference v))]
-> EnumMap Word64 (EnumMap CTag ([Mem], ANormal Reference v))
forall a b. (a -> b) -> a -> b
$ (Reference -> Word64)
-> (Reference, EnumMap CTag ([Mem], ANormal Reference v))
-> (Word64, EnumMap CTag ([Mem], ANormal Reference v))
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (RefNums -> Reference -> Word64
dnum RefNums
rns) ((Reference, EnumMap CTag ([Mem], ANormal Reference v))
 -> (Word64, EnumMap CTag ([Mem], ANormal Reference v)))
-> [(Reference, EnumMap CTag ([Mem], ANormal Reference v))]
-> [(Word64, EnumMap CTag ([Mem], ANormal Reference v))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, EnumMap CTag ([Mem], ANormal Reference v))]
hs0 =
      (Section -> EnumMap Word64 (GBranch CombIx) -> Section)
-> (Section, EnumMap Word64 (GBranch CombIx)) -> Section
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int -> Section -> EnumMap Word64 (GBranch CombIx) -> Section
forall comb.
Int
-> GSection comb -> EnumMap Word64 (GBranch comb) -> GSection comb
RMatch Int
i)
        ((Section, EnumMap Word64 (GBranch CombIx)) -> Section)
-> Emit v (Section, EnumMap Word64 (GBranch CombIx))
-> Emit v Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> EnumMap Word64 (EnumMap CTag ([Mem], ANormal Reference v))
-> ANormal Reference v
-> Emit v (Section, EnumMap Word64 (GBranch CombIx))
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> EnumMap Word64 (EnumMap CTag ([Mem], RNormal v))
-> RNormal v
-> Emit v (Section, EnumMap Word64 (GBranch CombIx))
emitRequestMatching RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx EnumMap Word64 (EnumMap CTag ([Mem], ANormal Reference v))
hs ANormal Reference v
df
  | Just (Int
i, Mem
UN) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v,
    MatchIntegral EnumMap Word64 (ANormal Reference v)
cs Maybe (ANormal Reference v)
df <- Branched Reference (ANormal Reference v)
bs =
      (Int -> Section -> EnumMap Word64 Section -> Section)
-> [Char]
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Int
-> EnumMap Word64 (ANormal Reference v)
-> Maybe (ANormal Reference v)
-> Emit v Section
forall v (f :: * -> *).
(Var v, Traversable f) =>
(Int -> Section -> f Section -> Section)
-> [Char]
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Int
-> f (RNormal v)
-> Maybe (RNormal v)
-> Emit v Section
emitLitMatching
        Int -> Section -> EnumMap Word64 Section -> Section
forall comb.
Int
-> GSection comb -> EnumMap Word64 (GSection comb) -> GSection comb
MatchW
        [Char]
"missing integral case"
        RefNums
rns
        Reference
grpr
        Word64
grpn
        RCtx v
rec
        Ctx v
ctx
        Int
i
        EnumMap Word64 (ANormal Reference v)
cs
        Maybe (ANormal Reference v)
df
  | Just (Int
i, Mem
BX) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v,
    MatchNumeric Reference
r EnumMap Word64 (ANormal Reference v)
cs Maybe (ANormal Reference v)
df <- Branched Reference (ANormal Reference v)
bs =
      (Int -> Section -> EnumMap Word64 Section -> Section)
-> [Char]
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Int
-> EnumMap Word64 (ANormal Reference v)
-> Maybe (ANormal Reference v)
-> Emit v Section
forall v (f :: * -> *).
(Var v, Traversable f) =>
(Int -> Section -> f Section -> Section)
-> [Char]
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Int
-> f (RNormal v)
-> Maybe (RNormal v)
-> Emit v Section
emitLitMatching
        (Maybe Reference
-> Int -> Section -> EnumMap Word64 Section -> Section
forall comb.
Maybe Reference
-> Int
-> GSection comb
-> EnumMap Word64 (GSection comb)
-> GSection comb
NMatchW (Reference -> Maybe Reference
forall a. a -> Maybe a
Just Reference
r))
        [Char]
"missing integral case"
        RefNums
rns
        Reference
grpr
        Word64
grpn
        RCtx v
rec
        Ctx v
ctx
        Int
i
        EnumMap Word64 (ANormal Reference v)
cs
        Maybe (ANormal Reference v)
df
  | Just (Int
i, Mem
BX) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v,
    MatchText Map Text (ANormal Reference v)
cs Maybe (ANormal Reference v)
df <- Branched Reference (ANormal Reference v)
bs =
      (Int -> Section -> Map Text Section -> Section)
-> [Char]
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Int
-> Map Text (ANormal Reference v)
-> Maybe (ANormal Reference v)
-> Emit v Section
forall v (f :: * -> *).
(Var v, Traversable f) =>
(Int -> Section -> f Section -> Section)
-> [Char]
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Int
-> f (RNormal v)
-> Maybe (RNormal v)
-> Emit v Section
emitLitMatching
        Int -> Section -> Map Text Section -> Section
forall comb.
Int -> GSection comb -> Map Text (GSection comb) -> GSection comb
MatchT
        [Char]
"missing text case"
        RefNums
rns
        Reference
grpr
        Word64
grpn
        RCtx v
rec
        Ctx v
ctx
        Int
i
        Map Text (ANormal Reference v)
cs
        Maybe (ANormal Reference v)
df
  | Just (Int
i, Mem
BX) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v,
    MatchBytes Map Bytes (ANormal Reference v)
cs Maybe (ANormal Reference v)
df <- Branched Reference (ANormal Reference v)
bs =
      (Int -> Section -> Map Bytes Section -> Section)
-> [Char]
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Int
-> Map Bytes (ANormal Reference v)
-> Maybe (ANormal Reference v)
-> Emit v Section
forall v (f :: * -> *).
(Var v, Traversable f) =>
(Int -> Section -> f Section -> Section)
-> [Char]
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Int
-> f (RNormal v)
-> Maybe (RNormal v)
-> Emit v Section
emitLitMatching
        Int -> Section -> Map Bytes Section -> Section
forall comb.
Int -> GSection comb -> Map Bytes (GSection comb) -> GSection comb
MatchY
        [Char]
"missing bytes case"
        RefNums
rns
        Reference
grpr
        Word64
grpn
        RCtx v
rec
        Ctx v
ctx
        Int
i
        Map Bytes (ANormal Reference v)
cs
        Maybe (ANormal Reference v)
df
  | MatchSum EnumMap Word64 ([Mem], ANormal Reference v)
_ <- Branched Reference (ANormal Reference v)
bs =
      -- accepted only as the body of the let that binds its tag, above
      [Word] -> [Char] -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Section) -> [Char] -> Emit v Section
forall a b. (a -> b) -> a -> b
$
        [Char]
"emitSection: an unboxed sum match away from the let that binds its tag: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ANormal Reference v -> [Char]
forall a. Show a => a -> [Char]
show (v
-> Branched Reference (ANormal Reference v) -> ANormal Reference v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
v Branched Reference (ANormal Reference v)
bs)
  | Just (Int
_, Mem
cc) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v =
      [Word] -> [Char] -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Section) -> [Char] -> Emit v Section
forall a b. (a -> b) -> a -> b
$
        [Char]
"emitSection: mismatched calling convention for match: "
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Mem -> Branched Reference (ANormal Reference v) -> [Char]
forall v. Mem -> Branched Reference v -> [Char]
matchCallingError Mem
cc Branched Reference (ANormal Reference v)
bs
  | Bool
otherwise =
      [Word] -> [Char] -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Section) -> [Char] -> Emit v Section
forall a b. (a -> b) -> a -> b
$
        [Char]
"emitSection: could not resolve match variable: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Ctx v, v) -> [Char]
forall a. Show a => a -> [Char]
show (Ctx v
ctx, v
v)
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx (THnd [Reference]
rs v
nh Maybe v
ah ANormal Reference v
b) =
  case Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
nh of
    Just (Int
i, Mem
BX) -> case (v -> Maybe (Int, Mem)) -> Maybe v -> Maybe (Maybe (Int, Mem))
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 (Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx) Maybe v
ah of
      Maybe (Maybe (Int, Mem))
Nothing -> case Maybe v
ah of
        Just v
v -> v -> Emit v Section
forall v a. (Var v, HasCallStack) => v -> a
emitSectionVErr v
v
        Maybe v
Nothing ->
          [Word] -> [Char] -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"emitSection: ctxResolve failed without variable"
      Just Maybe (Int, Mem)
mj ->
        GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (EnumSet Word64 -> Int -> Maybe Int -> GInstr CombIx
forall comb. EnumSet Word64 -> Int -> Maybe Int -> GInstr comb
Reset ([Word64] -> EnumSet Word64
forall k. EnumKey k => [k] -> EnumSet k
EC.setFromList [Word64]
ws) Int
i ((Int, Mem) -> Int
forall a b. (a, b) -> a
fst ((Int, Mem) -> Int) -> Maybe (Int, Mem) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, Mem)
mj))
          (Section -> Section) -> Emit v Section -> Emit v Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ANormal Reference v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx ANormal Reference v
b
    Maybe (Int, Mem)
_ -> v -> Emit v Section
forall v a. (Var v, HasCallStack) => v -> a
emitSectionVErr v
nh
  where
    ws :: [Word64]
ws = RefNums -> Reference -> Word64
dnum RefNums
rns (Reference -> Word64) -> [Reference] -> [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Reference]
rs
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx (TShift Reference
r v
v ANormal Reference v
e) =
  GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (Word64 -> GInstr CombIx
forall comb. Word64 -> GInstr comb
Capture (Word64 -> GInstr CombIx) -> Word64 -> GInstr CombIx
forall a b. (a -> b) -> a -> b
$ RefNums -> Reference -> Word64
dnum RefNums
rns Reference
r)
    (Section -> Section) -> Emit v Section -> Emit v Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ANormal Reference v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec (v -> Mem -> Ctx v -> Ctx v
forall v. v -> Mem -> Ctx v -> Ctx v
Var v
v Mem
BX Ctx v
ctx) ANormal Reference v
e
emitSection RefNums
_ Reference
_ Word64
_ RCtx v
_ Ctx v
ctx (TFrc v
v)
  | Just (Int
i, Mem
BX) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v =
      Ctx v -> Section -> Emit v Section
forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx (Section -> Emit v Section) -> Section -> Emit v Section
forall a b. (a -> b) -> a -> b
$ Bool -> GRef CombIx -> Args -> Section
forall comb. Bool -> GRef comb -> Args -> GSection comb
App Bool
False (Int -> GRef CombIx
forall comb. Int -> GRef comb
Stk Int
i) Args
ZArgs
  | Just (Int, Mem)
_ <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v =
      [Word] -> [Char] -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Section) -> [Char] -> Emit v Section
forall a b. (a -> b) -> a -> b
$
        [Char]
"emitSection: values to be forced must be boxed: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> [Char]
forall a. Show a => a -> [Char]
show v
v
  | Bool
otherwise = v -> Emit v Section
forall v a. (Var v, HasCallStack) => v -> a
emitSectionVErr v
v
emitSection RefNums
_ Reference
_ Word64
_ RCtx v
_ Ctx v
_ ANormal Reference v
tm =
  [Word] -> [Char] -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Section) -> [Char] -> Emit v Section
forall a b. (a -> b) -> a -> b
$ [Char]
"emitSection: unhandled code: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ANormal Reference v -> [Char]
forall a. Show a => a -> [Char]
show ANormal Reference v
tm

-- Emit the code for a function call

-- | What a record-related function needs from the surrounding emit. Both cases
-- intern a name into a shared table, which is why they can't be computed by
-- the pure `emitFunction`.
data RecEmit
  = -- | the shape for a record construction
    RecEmitShape RecordShape
  | -- | the field reference for a record update
    RecEmitSet FieldRef
  deriving (Int -> RecEmit -> ShowS
[RecEmit] -> ShowS
RecEmit -> [Char]
(Int -> RecEmit -> ShowS)
-> (RecEmit -> [Char]) -> ([RecEmit] -> ShowS) -> Show RecEmit
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecEmit -> ShowS
showsPrec :: Int -> RecEmit -> ShowS
$cshow :: RecEmit -> [Char]
show :: RecEmit -> [Char]
$cshowList :: [RecEmit] -> ShowS
showList :: [RecEmit] -> ShowS
Show)

emitFunction ::
  (Var v) =>
  RefNums ->
  -- | extra information, when emitting a record construction or update
  Maybe RecEmit ->
  Reference ->
  Word64 -> -- self combinator number
  RCtx v -> -- recursive binding group
  Ctx v -> -- local context
  Func Reference v ->
  Args ->
  Section
emitFunction :: forall v.
Var v =>
RefNums
-> Maybe RecEmit
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Func Reference v
-> Args
-> Section
emitFunction RefNums
_ Maybe RecEmit
_mshape Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx (FVar v
v) Args
as
  | Just (Int
i, Mem
BX) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v =
      Bool -> GRef CombIx -> Args -> Section
forall comb. Bool -> GRef comb -> Args -> GSection comb
App Bool
False (Int -> GRef CombIx
forall comb. Int -> GRef comb
Stk Int
i) Args
as
  | Just Word64
j <- RCtx v -> v -> Maybe Word64
forall v. Var v => RCtx v -> v -> Maybe Word64
rctxResolve RCtx v
rec v
v =
      let cix :: CombIx
cix = Reference -> Word64 -> Word64 -> CombIx
CIx Reference
grpr Word64
grpn Word64
j
       in Bool -> GRef CombIx -> Args -> Section
forall comb. Bool -> GRef comb -> Args -> GSection comb
App Bool
False (CombIx -> CombIx -> GRef CombIx
forall comb. CombIx -> comb -> GRef comb
Env CombIx
cix CombIx
cix) Args
as
  | Bool
otherwise = v -> Section
forall v a. (Var v, HasCallStack) => v -> a
emitSectionVErr v
v
emitFunction RefNums
rns Maybe RecEmit
_mshape Reference
_grpr Word64
_ RCtx v
_ Ctx v
_ (FComb Reference
r) Args
as
  | Just Int
k <- RefNums -> Reference -> Maybe Int
anum RefNums
rns Reference
r,
    Args -> Int
countArgs Args
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k -- exactly saturated call
    =
      Bool -> CombIx -> CombIx -> Args -> Section
forall comb. Bool -> CombIx -> comb -> Args -> GSection comb
Call Bool
False CombIx
cix CombIx
cix Args
as
  | Bool
otherwise -- slow path
    =
      Bool -> GRef CombIx -> Args -> Section
forall comb. Bool -> GRef comb -> Args -> GSection comb
App Bool
False (CombIx -> CombIx -> GRef CombIx
forall comb. CombIx -> comb -> GRef comb
Env CombIx
cix CombIx
cix) Args
as
  where
    n :: Word64
n = RefNums -> Reference -> Word64
cnum RefNums
rns Reference
r
    cix :: CombIx
cix = Reference -> Word64 -> Word64 -> CombIx
CIx Reference
r Word64
n Word64
0
emitFunction RefNums
rns Maybe RecEmit
_mshape Reference
_grpr Word64
_ RCtx v
_ Ctx v
_ (FCon Reference
r CTag
t) Args
as
  | Bool
wideOn,
    Args -> Int
countArgs Args
as Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
wideK =
      GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (PackedTag -> Bool -> Args -> GInstr CombIx
forall comb. PackedTag -> Bool -> Args -> GInstr comb
PackWide (RTag -> CTag -> PackedTag
packTags RTag
rt CTag
t) Bool
True Args
as)
        (Section -> Section) -> (Args -> Section) -> Args -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Section
forall comb. Args -> GSection comb
Yield
        (Args -> Section) -> Args -> Section
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Args
VArgR Int
0 Int
wideWidth
  | Bool
otherwise =
      GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (PackedTag -> Args -> GInstr CombIx
forall comb. PackedTag -> Args -> GInstr comb
Pack (RTag -> CTag -> PackedTag
packTags RTag
rt CTag
t) Args
as)
        (Section -> Section) -> (Args -> Section) -> Args -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Section
forall comb. Args -> GSection comb
Yield
        (Args -> Section) -> Args -> Section
forall a b. (a -> b) -> a -> b
$ Int -> Args
VArg1 Int
0
  where
    rt :: RTag
rt = Int -> RTag
forall a. Enum a => Int -> a
toEnum (Int -> RTag) -> (Word64 -> Int) -> Word64 -> RTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> RTag) -> Word64 -> RTag
forall a b. (a -> b) -> a -> b
$ RefNums -> Reference -> Word64
dnum RefNums
rns Reference
r
emitFunction RefNums
_ (Just (RecEmitShape RecordShape
shape)) Reference
_grpr Word64
_ RCtx v
_ Ctx v
_ (FRec RecordSchema
_rs) Args
as =
  RecordShape -> Int -> Section -> Section
forall a. RecordShape -> Int -> a -> a
recordArity RecordShape
shape (Args -> Int
countArgs Args
as)
    (Section -> Section) -> (Args -> Section) -> Args -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (RecordShape -> Args -> GInstr CombIx
forall comb. RecordShape -> Args -> GInstr comb
RecPack RecordShape
shape Args
as)
    (Section -> Section) -> (Args -> Section) -> Args -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Section
forall comb. Args -> GSection comb
Yield
    (Args -> Section) -> Args -> Section
forall a b. (a -> b) -> a -> b
$ Int -> Args
VArg1 Int
0
emitFunction RefNums
_ (Just (RecEmitSet FieldRef
field)) Reference
_grpr Word64
_ RCtx v
_ Ctx v
_ (FRecSet FieldName
_field) Args
as =
  GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (FieldRef -> Args -> GInstr CombIx
forall comb. FieldRef -> Args -> GInstr comb
RecSet FieldRef
field Args
as)
    (Section -> Section) -> (Args -> Section) -> Args -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Section
forall comb. Args -> GSection comb
Yield
    (Args -> Section) -> Args -> Section
forall a b. (a -> b) -> a -> b
$ Int -> Args
VArg1 Int
0
emitFunction RefNums
_ Maybe RecEmit
mrec Reference
_grpr Word64
_ RCtx v
_ Ctx v
_ f :: Func Reference v
f@(FRec RecordSchema
_rs) Args
_ =
  [Word] -> [Char] -> Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Section) -> [Char] -> Section
forall a b. (a -> b) -> a -> b
$ [Char]
"emitFunction: record construction without a shape: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Maybe RecEmit, Func Reference v) -> [Char]
forall a. Show a => a -> [Char]
show (Maybe RecEmit
mrec, Func Reference v
f)
emitFunction RefNums
_ Maybe RecEmit
mrec Reference
_grpr Word64
_ RCtx v
_ Ctx v
_ (FRecSet FieldName
field) Args
_ =
  [Word] -> [Char] -> Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Section) -> [Char] -> Section
forall a b. (a -> b) -> a -> b
$ [Char]
"emitFunction: record update of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> [Char]
forall a. Show a => a -> [Char]
show FieldName
field [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" without a field reference: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe RecEmit -> [Char]
forall a. Show a => a -> [Char]
show Maybe RecEmit
mrec
emitFunction RefNums
rns Maybe RecEmit
_mshape Reference
_grpr Word64
_ RCtx v
_ Ctx v
_ (FReq Reference
r CTag
e) Args
as =
  -- Currently implementing packed calling convention for abilities
  -- TODO ct is 16 bits, but a is 48 bits. This will be a problem if we have
  -- more than 2^16 types.
  GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (PackedTag -> Args -> GInstr CombIx
forall comb. PackedTag -> Args -> GInstr comb
Pack (RTag -> CTag -> PackedTag
packTags RTag
rt CTag
e) Args
as)
    (Section -> Section) -> (Args -> Section) -> Args -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> GRef CombIx -> Args -> Section
forall comb. Bool -> GRef comb -> Args -> GSection comb
App Bool
True (Word64 -> GRef CombIx
forall comb. Word64 -> GRef comb
Dyn Word64
a)
    (Args -> Section) -> Args -> Section
forall a b. (a -> b) -> a -> b
$ Int -> Args
VArg1 Int
0
  where
    a :: Word64
a = RefNums -> Reference -> Word64
dnum RefNums
rns Reference
r
    rt :: RTag
rt = Int -> RTag
forall a. Enum a => Int -> a
toEnum (Int -> RTag) -> (Word64 -> Int) -> Word64 -> RTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> RTag) -> Word64 -> RTag
forall a b. (a -> b) -> a -> b
$ Word64
a
emitFunction RefNums
_ Maybe RecEmit
_mshape Reference
_grpr Word64
_ RCtx v
_ Ctx v
ctx (FCont v
k) Args
as
  | Just (Int
i, Mem
BX) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
k = Int -> Args -> Section
forall comb. Int -> Args -> GSection comb
Jump Int
i Args
as
  | Maybe (Int, Mem)
Nothing <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
k = v -> Section
forall v a. (Var v, HasCallStack) => v -> a
emitFunctionVErr v
k
  | Bool
otherwise = [Word] -> [Char] -> Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Section) -> [Char] -> Section
forall a b. (a -> b) -> a -> b
$ [Char]
"emitFunction: continuations are boxed"
emitFunction RefNums
_ Maybe RecEmit
_mshape Reference
_grpr Word64
_ RCtx v
_ Ctx v
_ (FPrim Either POp ForeignFunc
_) Args
_ =
  [Word] -> [Char] -> Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"emitFunction: impossible"
-- the explosion's forms (Unison.Runtime.MCode.Explode): a call of a
-- worker of a function's group, always saturated, and a return of several
-- values, each boxed by 'emitClosures' if it was wide
emitFunction RefNums
rns Maybe RecEmit
_mshape Reference
_grpr Word64
_ RCtx v
_ Ctx v
_ (FWorker Reference
r Word64
i) Args
as =
  Bool -> CombIx -> CombIx -> Args -> Section
forall comb. Bool -> CombIx -> comb -> Args -> GSection comb
Call Bool
False CombIx
cix CombIx
cix Args
as
  where
    cix :: CombIx
cix = Reference -> Word64 -> Word64 -> CombIx
CIx Reference
r (RefNums -> Reference -> Word64
cnum RefNums
rns Reference
r) Word64
i
emitFunction RefNums
_ Maybe RecEmit
_mshape Reference
_grpr Word64
_ RCtx v
_ Ctx v
_ Func Reference v
FYield Args
as = Args -> Section
forall comb. Args -> GSection comb
Yield Args
as

countBlock :: Ctx v -> Int
countBlock :: forall v. Ctx v -> Int
countBlock = Int -> Ctx v -> Int
forall v. Int -> Ctx v -> Int
go Int
0
  where
    go :: Int -> Ctx v -> Int
go !Int
i (Var v
_ Mem
_ Ctx v
ctx) = Int -> Ctx v -> Int
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Ctx v
ctx
    go !Int
i (Wide v
_ Mem
_ Ctx v
ctx) = Int -> Ctx v -> Int
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wideWidth) Ctx v
ctx
    go Int
i (Tag Ctx v
ctx) = Int -> Ctx v -> Int
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Ctx v
ctx
    go Int
i Ctx v
_ = Int
i

matchCallingError :: Mem -> Branched Reference v -> String
matchCallingError :: forall v. Mem -> Branched Reference v -> [Char]
matchCallingError Mem
cc Branched Reference v
b = [Char]
"(" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Mem -> [Char]
forall a. Show a => a -> [Char]
show Mem
cc [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"," [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
brs [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
  where
    brs :: [Char]
brs
      | MatchData Reference
_ EnumMap CTag ([Mem], v)
_ Maybe v
_ <- Branched Reference v
b = [Char]
"MatchData"
      | Branched Reference v
MatchEmpty <- Branched Reference v
b = [Char]
"MatchEmpty"
      | MatchIntegral EnumMap Word64 v
_ Maybe v
_ <- Branched Reference v
b = [Char]
"MatchIntegral"
      | MatchNumeric Reference
_ EnumMap Word64 v
_ Maybe v
_ <- Branched Reference v
b = [Char]
"MatchNumeric"
      | MatchRequest [(Reference, EnumMap CTag ([Mem], v))]
_ v
_ <- Branched Reference v
b = [Char]
"MatchRequest"
      | MatchSum EnumMap Word64 ([Mem], v)
_ <- Branched Reference v
b = [Char]
"MatchSum"
      | MatchText Map Text v
_ Maybe v
_ <- Branched Reference v
b = [Char]
"MatchText"
      | MatchBytes Map Bytes v
_ Maybe v
_ <- Branched Reference v
b = [Char]
"MatchBytes"
      | MatchRec RecordSchema
_ v
_ <- Branched Reference v
b = [Char]
"MatchRec"

emitSectionVErr :: (Var v, HasCallStack) => v -> a
emitSectionVErr :: forall v a. (Var v, HasCallStack) => v -> a
emitSectionVErr v
v =
  [Word] -> [Char] -> a
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$
    [Char]
"emitSection: could not resolve function variable: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> [Char]
forall a. Show a => a -> [Char]
show v
v

emitFunctionVErr :: (Var v, HasCallStack) => v -> a
emitFunctionVErr :: forall v a. (Var v, HasCallStack) => v -> a
emitFunctionVErr v
v =
  [Word] -> [Char] -> a
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$
    [Char]
"emitFunction: could not resolve function variable: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> [Char]
forall a. Show a => a -> [Char]
show v
v

-- Emit machine code for a let expression. Some expressions do not
-- require a machine code Let, which uses more complicated stack
-- manipulation.
emitLet ::
  (Var v) =>
  RefNums ->
  Reference ->
  Word64 ->
  RCtx v ->
  Direction Word16 ->
  [(v, Mem)] ->
  Ctx v ->
  RNormal v ->
  Emit v Section ->
  Emit v Section
emitLet :: forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Direction Word16
-> [(v, Mem)]
-> Ctx v
-> RNormal v
-> Emit v Section
-> Emit v Section
emitLet RefNums
_ Reference
_ Word64
_ RCtx v
_ Direction Word16
_ [(v, Mem)]
_ Ctx v
_ (TLit Lit Reference
l) =
  (Section -> Section) -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GInstr CombIx -> Section -> Section)
-> GInstr CombIx -> Section -> Section
forall a b. (a -> b) -> a -> b
$ Lit Reference -> GInstr CombIx
emitLit Lit Reference
l)
emitLet RefNums
_ Reference
_ Word64
_ RCtx v
_ Direction Word16
_ [(v, Mem)]
_ Ctx v
_ (TBLit Lit Reference
l) =
  (Section -> Section) -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GInstr CombIx -> Section -> Section)
-> GInstr CombIx -> Section -> Section
forall a b. (a -> b) -> a -> b
$ Lit Reference -> GInstr CombIx
emitLit Lit Reference
l)
-- emitLet rns grp _   _ _   ctx (TApp (FComb r) args)
--   -- We should be able to tell if we are making a saturated call
--   -- or not here. We aren't carrying the information here yet, though.
--   | False -- not saturated
--   = fmap (Ins . Name (Env n 0) $ emitArgs grp ctx args)
--   where
--   n = cnum rns r
emitLet RefNums
rns Reference
_ Word64
grpn RCtx v
_ Direction Word16
_ [(v, Mem)]
_ Ctx v
ctx (TApp (FCon Reference
r CTag
n) [v]
args) =
  (Section -> Section) -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GInstr CombIx -> Section -> Section)
-> (Args -> GInstr CombIx) -> Args -> Section -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackedTag -> Args -> GInstr CombIx
forall comb. PackedTag -> Args -> GInstr comb
Pack (RTag -> CTag -> PackedTag
packTags RTag
rt CTag
n) (Args -> Section -> Section) -> Args -> Section -> Section
forall a b. (a -> b) -> a -> b
$ Word64 -> Ctx v -> [v] -> Args
forall v. Var v => Word64 -> Ctx v -> [v] -> Args
emitArgs Word64
grpn Ctx v
ctx [v]
args)
  where
    rt :: RTag
rt = Int -> RTag
forall a. Enum a => Int -> a
toEnum (Int -> RTag) -> (Word64 -> Int) -> Word64 -> RTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> RTag) -> Word64 -> RTag
forall a b. (a -> b) -> a -> b
$ RefNums -> Reference -> Word64
dnum RefNums
rns Reference
r
emitLet RefNums
rns Reference
_ Word64
grpn RCtx v
_ Direction Word16
_ [(v, Mem)]
_ Ctx v
ctx (TApp (FRec RecordSchema
rs) [v]
args) = \Emit v Section
es -> do
  RecordShape
shape <- RecordRef -> RecordSchema -> Emit v RecordShape
forall (m :: * -> *).
MonadState RecordFieldMappings m =>
RecordRef -> RecordSchema -> m RecordShape
recordShape (RefNums -> RecordSchema -> RecordRef
recNum RefNums
rns RecordSchema
rs) RecordSchema
rs
  RecordShape -> Int -> Emit v Section -> Emit v Section
forall a. RecordShape -> Int -> a -> a
recordArity RecordShape
shape ([v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
args) (Emit v Section -> Emit v Section)
-> Emit v Section -> Emit v Section
forall a b. (a -> b) -> a -> b
$
    (Section -> Section) -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GInstr CombIx -> Section -> Section)
-> (Args -> GInstr CombIx) -> Args -> Section -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordShape -> Args -> GInstr CombIx
forall comb. RecordShape -> Args -> GInstr comb
RecPack RecordShape
shape (Args -> Section -> Section) -> Args -> Section -> Section
forall a b. (a -> b) -> a -> b
$ Word64 -> Ctx v -> [v] -> Args
forall v. Var v => Word64 -> Ctx v -> [v] -> Args
emitArgs Word64
grpn Ctx v
ctx [v]
args) Emit v Section
es
-- A record update needs its field's reference interned, the same way a record literal
-- needs its shape interned. `emitSection` resolves it for a call position; a let needs
-- its own case because a chain of updates (`r@f1.set ..)@f2.set ..`) puts every update
-- but the last one in a let.
emitLet RefNums
_ Reference
_ Word64
grpn RCtx v
_ Direction Word16
_ [(v, Mem)]
_ Ctx v
ctx (TApp (FRecSet FieldName
field) [v]
args) = \Emit v Section
es -> do
  FieldRef
fieldRef <- Vector FieldRef -> FieldRef
forall a. Vector a -> a
V.head (Vector FieldRef -> FieldRef)
-> Emit v (Vector FieldRef) -> Emit v FieldRef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector FieldName -> Emit v (Vector FieldRef)
forall (m :: * -> *) (f :: * -> *).
(MonadState RecordFieldMappings m, Traversable f) =>
f FieldName -> m (f FieldRef)
convertFieldNamesToRefs (FieldName -> Vector FieldName
forall a. a -> Vector a
V.singleton FieldName
field)
  (Section -> Section) -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (FieldRef -> Args -> GInstr CombIx
forall comb. FieldRef -> Args -> GInstr comb
RecSet FieldRef
fieldRef (Word64 -> Ctx v -> [v] -> Args
forall v. Var v => Word64 -> Ctx v -> [v] -> Args
emitArgs Word64
grpn Ctx v
ctx [v]
args))) Emit v Section
es
emitLet RefNums
_ Reference
_ Word64
grpn RCtx v
_ Direction Word16
_ [(v, Mem)]
_ Ctx v
ctx (TApp (FPrim Either POp ForeignFunc
p) [v]
args) =
  (Section -> Section) -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GInstr CombIx -> Section -> Section)
-> (Args -> GInstr CombIx) -> Args -> Section -> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POp -> Args -> GInstr CombIx)
-> (ForeignFunc -> Args -> GInstr CombIx)
-> Either POp ForeignFunc
-> Args
-> GInstr CombIx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either POp -> Args -> GInstr CombIx
emitPOp ForeignFunc -> Args -> GInstr CombIx
emitFOp Either POp ForeignFunc
p (Args -> Section -> Section) -> Args -> Section -> Section
forall a b. (a -> b) -> a -> b
$ Word64 -> Ctx v -> [v] -> Args
forall v. Var v => Word64 -> Ctx v -> [v] -> Args
emitArgs Word64
grpn Ctx v
ctx [v]
args)
emitLet RefNums
_ Reference
_ Word64
_ RCtx v
_ Direction Word16
_ [(v, Mem)]
_ Ctx v
ctx (TDiscard v
v)
  | Just (Int
i, Mem
_) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v = (Section -> Section) -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GInstr CombIx -> Section -> Section)
-> GInstr CombIx -> Section -> Section
forall a b. (a -> b) -> a -> b
$ Int -> GInstr CombIx
forall comb. Int -> GInstr comb
Discard Int
i)
-- a wide variable boxed in place before it escapes
-- (Unison.Runtime.MCode.Wide)
emitLet RefNums
_ Reference
_ Word64
_ RCtx v
_ Direction Word16
_ [(v, Mem)]
_ Ctx v
ctx (TBox v
v)
  | Just (Int
i, Mem
_) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v,
    Ctx v -> v -> Bool
forall v. Var v => Ctx v -> v -> Bool
ctxWide Ctx v
ctx v
v =
      (Section -> Section) -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GInstr CombIx -> Section -> Section)
-> GInstr CombIx -> Section -> Section
forall a b. (a -> b) -> a -> b
$ Int -> GInstr CombIx
forall comb. Int -> GInstr comb
Box Int
i)
  | Bool
otherwise = [Word] -> [Char] -> Emit v Section -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Section -> Emit v Section)
-> [Char] -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> a -> b
$ [Char]
"emitLet: a box of a variable that is not wide: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> [Char]
forall a. Show a => a -> [Char]
show v
v
emitLet RefNums
_ Reference
_ Word64
_ RCtx v
_ Direction Word16
_ [(v, Mem)]
_ Ctx v
ctx (TUpdate Bool
ind v
r v
v)
  | Just (Int
i, Mem
_) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
r,
    Just (Int
j, Mem
_) <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
v =
      (Section -> Section) -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GInstr CombIx -> Section -> Section)
-> GInstr CombIx -> Section -> Section
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> Int -> GInstr CombIx
forall comb. Bool -> Int -> Int -> GInstr comb
SetAff Bool
ind Int
i Int
j)
emitLet RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Direction Word16
d [(v, Mem)]
vcs Ctx v
ctx RNormal v
bnd
  | Direction Word16
Direct <- Direction Word16
d =
      [Word] -> [Char] -> Emit v Section -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Section -> Emit v Section)
-> [Char] -> Emit v Section -> Emit v Section
forall a b. (a -> b) -> a -> b
$ [Char]
"unsupported compound direct let: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ RNormal v -> [Char]
forall a. Show a => a -> [Char]
show RNormal v
bnd
  | Indirect Word16
w <- Direction Word16
d =
      \Emit v Section
esect -> do
        Word64
c <- Emit v Word64
forall r (m :: * -> *). MonadReader r m => m r
ask
        Section -> (Word64, Comb) -> Section
f
          (Section -> (Word64, Comb) -> Section)
-> Emit v Section -> Emit v ((Word64, Comb) -> Section)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec (Word64 -> Ctx v -> Ctx v
forall v. Word64 -> Ctx v -> Ctx v
Block (Word16 -> Word64 -> Word64
letIndex Word16
w Word64
c) Ctx v
ctx) RNormal v
bnd
          Emit v ((Word64, Comb) -> Section)
-> Emit v (Word64, Comb) -> Emit v Section
forall a b. Emit v (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RefNums
-> RCtx v
-> Ctx v
-> [(v, Mem)]
-> Word16
-> Emit v Section
-> Emit v (Word64, Comb)
forall v.
Var v =>
RefNums
-> RCtx v
-> Ctx v
-> [(v, Mem)]
-> Word16
-> Emit v Section
-> Emit v (Word64, Comb)
record RefNums
rns RCtx v
rec Ctx v
ctx [(v, Mem)]
vcs Word16
w Emit v Section
esect
  where
    f :: Section -> (Word64, Comb) -> Section
f Section
s (Word64
w, Lam Int
_ Int
f Section
bd) =
      let cix :: CombIx
cix = (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
grpr Word64
grpn Word64
w)
       in Section -> CombIx -> Int -> Section -> Ptr NativeCell -> Section
forall comb.
GSection comb
-> CombIx
-> Int
-> GSection comb
-> Ptr NativeCell
-> GSection comb
Let Section
s CombIx
cix Int
f Section
bd Ptr NativeCell
noNativeCell

-- Translate from ANF prim ops to machine code operations. The
-- machine code operations are divided with respect to more detailed
-- information about expected number and types of arguments.
emitPOp :: ANF.POp -> Args -> Instr
-- Integral
emitPOp :: POp -> Args -> GInstr CombIx
emitPOp POp
ANF.ADDI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
ADDI
emitPOp POp
ANF.ADDN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
ADDN
emitPOp POp
ANF.SUBI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SUBI
emitPOp POp
ANF.SUBN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SUBN
emitPOp POp
ANF.DRPN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
DRPN
emitPOp POp
ANF.MULI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
MULI
emitPOp POp
ANF.MULN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
MULN
emitPOp POp
ANF.DIVI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
DIVI
emitPOp POp
ANF.DIVN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
DIVN
emitPOp POp
ANF.MODI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
MODI -- TODO: think about how these behave
emitPOp POp
ANF.MODN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
MODN -- TODO: think about how these behave
emitPOp POp
ANF.POWI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
POWI
emitPOp POp
ANF.POWN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
POWN
emitPOp POp
ANF.SHLI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SHLI
emitPOp POp
ANF.SHLN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SHLN -- Note: left shift behaves uniformly
emitPOp POp
ANF.SHRI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SHRI
emitPOp POp
ANF.SHRN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SHRN
emitPOp POp
ANF.LEQI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
LEQI
emitPOp POp
ANF.LESI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
LESI
emitPOp POp
ANF.LEQN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
LEQN
emitPOp POp
ANF.LESN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
LESN
emitPOp POp
ANF.EQLI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
EQLI
emitPOp POp
ANF.NEQI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
NEQI
emitPOp POp
ANF.EQLN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
EQLN
emitPOp POp
ANF.NEQN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
NEQN
emitPOp POp
ANF.SGNI = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
SGNI
emitPOp POp
ANF.NEGI = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
NEGI
emitPOp POp
ANF.INCI = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
INCI
emitPOp POp
ANF.INCN = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
INCN
emitPOp POp
ANF.DECI = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
DECI
emitPOp POp
ANF.DECN = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
DECN
emitPOp POp
ANF.TRNC = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
TRNC
emitPOp POp
ANF.TZRO = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
TZRO
emitPOp POp
ANF.LZRO = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
LZRO
emitPOp POp
ANF.POPC = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
POPC
emitPOp POp
ANF.ANDN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
ANDN
emitPOp POp
ANF.ANDI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
ANDI
emitPOp POp
ANF.IORN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
IORN
emitPOp POp
ANF.IORI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
IORI
emitPOp POp
ANF.XORI = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
XORI
emitPOp POp
ANF.XORN = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
XORN
emitPOp POp
ANF.COMN = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
COMN
emitPOp POp
ANF.COMI = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
COMI
-- Float
emitPOp POp
ANF.ADDF = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
ADDF
emitPOp POp
ANF.SUBF = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SUBF
emitPOp POp
ANF.MULF = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
MULF
emitPOp POp
ANF.DIVF = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
DIVF
emitPOp POp
ANF.LEQF = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
LEQF
emitPOp POp
ANF.LESF = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
LESF
emitPOp POp
ANF.EQLF = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
EQLF
emitPOp POp
ANF.NEQF = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
NEQF
emitPOp POp
ANF.MINF = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
MINF
emitPOp POp
ANF.MAXF = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
MAXF
emitPOp POp
ANF.POWF = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
POWF
emitPOp POp
ANF.EXPF = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
EXPF
emitPOp POp
ANF.ABSF = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
ABSF
emitPOp POp
ANF.SQRT = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
SQRT
emitPOp POp
ANF.LOGF = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
LOGF
emitPOp POp
ANF.LOGB = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
LOGB
emitPOp POp
ANF.CEIL = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
CEIL
emitPOp POp
ANF.FLOR = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
FLOR
emitPOp POp
ANF.TRNF = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
TRNF
emitPOp POp
ANF.RNDF = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
RNDF
emitPOp POp
ANF.COSF = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
COSF
emitPOp POp
ANF.SINF = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
SINF
emitPOp POp
ANF.TANF = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
TANF
emitPOp POp
ANF.COSH = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
COSH
emitPOp POp
ANF.SINH = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
SINH
emitPOp POp
ANF.TANH = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
TANH
emitPOp POp
ANF.ACOS = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
ACOS
emitPOp POp
ANF.ATAN = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
ATAN
emitPOp POp
ANF.ASIN = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
ASIN
emitPOp POp
ANF.ACSH = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
ACSH
emitPOp POp
ANF.ASNH = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
ASNH
emitPOp POp
ANF.ATNH = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
ATNH
emitPOp POp
ANF.ATN2 = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
ATN2
-- conversions
emitPOp POp
ANF.ITOF = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
ITOF
emitPOp POp
ANF.NTOF = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
NTOF
emitPOp POp
ANF.ITOT = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
ITOT
emitPOp POp
ANF.NTOT = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
NTOT
emitPOp POp
ANF.FTOT = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
FTOT
emitPOp POp
ANF.TTON = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
TTON
emitPOp POp
ANF.TTOI = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
TTOI
emitPOp POp
ANF.TTOF = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
TTOF
emitPOp POp
ANF.CAST = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
CAST
-- text
emitPOp POp
ANF.CATT = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
CATT
emitPOp POp
ANF.TAKT = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
TAKT
emitPOp POp
ANF.DRPT = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
DRPT
emitPOp POp
ANF.IXOT = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
IXOT
emitPOp POp
ANF.SIZT = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
SIZT
emitPOp POp
ANF.UCNS = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
UCNS
emitPOp POp
ANF.USNC = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
USNC
emitPOp POp
ANF.EQLT = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
EQLT
emitPOp POp
ANF.LEQT = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
LEQT
emitPOp POp
ANF.PAKT = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
PAKT
emitPOp POp
ANF.UPKT = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
UPKT
-- sequence
emitPOp POp
ANF.CATS = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
CATS
emitPOp POp
ANF.TAKS = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
TAKS
emitPOp POp
ANF.DRPS = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
DRPS
emitPOp POp
ANF.SIZS = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
SIZS
emitPOp POp
ANF.CONS = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
CONS
emitPOp POp
ANF.SNOC = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SNOC
emitPOp POp
ANF.IDXS = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
IDXS
emitPOp POp
ANF.VWLS = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
VWLS
emitPOp POp
ANF.VWRS = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
VWRS
emitPOp POp
ANF.SPLL = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SPLL
emitPOp POp
ANF.SPLR = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SPLR
-- bytes
emitPOp POp
ANF.PAKB = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
PAKB
emitPOp POp
ANF.UPKB = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
UPKB
emitPOp POp
ANF.TAKB = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
TAKB
emitPOp POp
ANF.DRPB = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
DRPB
emitPOp POp
ANF.IXOB = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
IXOB
emitPOp POp
ANF.IDXB = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
IDXB
emitPOp POp
ANF.SIZB = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
SIZB
emitPOp POp
ANF.FLTB = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
FLTB
emitPOp POp
ANF.CATB = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
CATB
-- universal comparison
emitPOp POp
ANF.EQLU = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
EQLU
emitPOp POp
ANF.LEQU = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
LEQU
emitPOp POp
ANF.LESU = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
LESU
emitPOp POp
ANF.CMPU = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
CMPU
-- code operations
emitPOp POp
ANF.MISS = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
MISS
emitPOp POp
ANF.CACH = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
CACH
emitPOp POp
ANF.LKUP = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
LKUP
emitPOp POp
ANF.TLTT = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
TLTT
emitPOp POp
ANF.CVLD = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
CVLD
emitPOp POp
ANF.LOAD = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
LOAD
emitPOp POp
ANF.VALU = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
VALU
emitPOp POp
ANF.SDBX = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SDBX
emitPOp POp
ANF.SDBL = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
SDBL
emitPOp POp
ANF.SDBV = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
SDBV
-- error call
emitPOp POp
ANF.EROR = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
THRO
emitPOp POp
ANF.TRCE = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
TRCE
emitPOp POp
ANF.DBTX = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
DBTX
-- Refs
emitPOp POp
ANF.REFN = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
REFN
emitPOp POp
ANF.REFR = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
REFR
emitPOp POp
ANF.REFW = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
REFW
emitPOp POp
ANF.RCAS = Args -> GInstr CombIx
refCAS
emitPOp POp
ANF.RRFC = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
RRFC
emitPOp POp
ANF.TIKR = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
TIKR
-- non-prim translations
emitPOp POp
ANF.BLDS = Args -> GInstr CombIx
forall comb. Args -> GInstr comb
Seq
-- Bools
emitPOp POp
ANF.NOTB = Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
NOTB
emitPOp POp
ANF.ANDB = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
ANDB
emitPOp POp
ANF.IORB = Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
IORB
emitPOp POp
ANF.FORK = \case
  VArg1 Int
i -> Int -> GInstr CombIx
forall comb. Int -> GInstr comb
Fork Int
i
  Args
_ -> [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"fork takes exactly one boxed argument"
emitPOp POp
ANF.ATOM = \case
  VArg1 Int
i -> Int -> GInstr CombIx
forall comb. Int -> GInstr comb
Atomically Int
i
  Args
_ -> [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"atomically takes exactly one boxed argument"
emitPOp POp
ANF.PRNT = \case
  VArg1 Int
i -> Int -> GInstr CombIx
forall comb. Int -> GInstr comb
Print Int
i
  Args
_ -> [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"print takes exactly one boxed argument"
emitPOp POp
ANF.INFO = \case
  Args
ZArgs -> [Char] -> GInstr CombIx
forall comb. [Char] -> GInstr comb
Info [Char]
"debug"
  Args
_ -> [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"info takes no arguments"
emitPOp POp
ANF.TFRC = \case
  VArg1 Int
i -> Int -> GInstr CombIx
forall comb. Int -> GInstr comb
TryForce Int
i
  Args
_ -> [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"tryEval takes exactly one boxed argument"
emitPOp POp
ANF.KEEP = \case
  VArg1 Int
i -> Int -> GInstr CombIx
forall comb. Int -> GInstr comb
KeepAlive Int
i
  Args
_ -> [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"keepAlive takes exactly one boxed argument"
emitPOp POp
ANF.FGNN = \case
  VArg2 Int
i Int
j -> Int -> Int -> GInstr CombIx
forall comb. Int -> Int -> GInstr comb
NewForeignPtr Int
i Int
j
  Args
_ -> [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"newForeignPtr takes exactly two boxed arguments"
emitPOp POp
ANF.FGNF = \case
  VArg2 Int
i Int
j -> Int -> Int -> GInstr CombIx
forall comb. Int -> Int -> GInstr comb
AddFinalizer Int
i Int
j
  Args
_ -> [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"addFinalizer takes exactly two boxed arguments"
emitPOp POp
ANF.MKCB = \case
  VArg2 Int
i Int
j -> Int -> Int -> GInstr CombIx
forall comb. Int -> Int -> GInstr comb
MkCallback Int
i Int
j
  Args
_ -> [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] [Char]
"mkCallback takes exactly two boxed arguments"

-- handled in emitSection because Die is not an instruction

-- Emit machine code for ANF IO operations. These are all translated
-- to 'foreing function' calls, but there is a special case for the
-- standard handle access function, because it does not yield an
-- explicit error.
emitFOp :: ForeignFunc -> Args -> Instr
emitFOp :: ForeignFunc -> Args -> GInstr CombIx
emitFOp ForeignFunc
fop = Bool -> ForeignFunc -> Args -> GInstr CombIx
forall comb. Bool -> ForeignFunc -> Args -> GInstr comb
ForeignCall Bool
True ForeignFunc
fop

-- Helper functions for packing the variable argument representation
-- into the indexes stored in prim op instructions
emitP1 :: Prim1 -> Args -> Instr
emitP1 :: Prim1 -> Args -> GInstr CombIx
emitP1 Prim1
p (VArg1 Int
i) = Prim1 -> Int -> GInstr CombIx
forall comb. Prim1 -> Int -> GInstr comb
Prim1 Prim1
p Int
i
emitP1 Prim1
p Args
a =
  [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> GInstr CombIx) -> [Char] -> GInstr CombIx
forall a b. (a -> b) -> a -> b
$
    [Char]
"wrong number of args for unary unboxed primop: "
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Prim1, Args) -> [Char]
forall a. Show a => a -> [Char]
show (Prim1
p, Args
a)

emitP2 :: Prim2 -> Args -> Instr
emitP2 :: Prim2 -> Args -> GInstr CombIx
emitP2 Prim2
p (VArg2 Int
i Int
j) = Prim2 -> Int -> Int -> GInstr CombIx
forall comb. Prim2 -> Int -> Int -> GInstr comb
Prim2 Prim2
p Int
i Int
j
emitP2 Prim2
p Args
a =
  [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> GInstr CombIx) -> [Char] -> GInstr CombIx
forall a b. (a -> b) -> a -> b
$
    [Char]
"wrong number of args for binary unboxed primop: "
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Prim2, Args) -> [Char]
forall a. Show a => a -> [Char]
show (Prim2
p, Args
a)

refCAS :: Args -> Instr
refCAS :: Args -> GInstr CombIx
refCAS (VArgN (PrimArray Int -> [Int]
forall a. Prim a => PrimArray a -> [a]
primArrayToList -> [Int
i, Int
j, Int
k])) = Int -> Int -> Int -> GInstr CombIx
forall comb. Int -> Int -> Int -> GInstr comb
RefCAS Int
i Int
j Int
k
refCAS Args
a =
  [Word] -> [Char] -> GInstr CombIx
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> GInstr CombIx) -> [Char] -> GInstr CombIx
forall a b. (a -> b) -> a -> b
$
    [Char]
"wrong number of args for refCAS: "
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Args -> [Char]
forall a. Show a => a -> [Char]
show Args
a

emitDataMatching ::
  (Var v) =>
  Reference ->
  RefNums ->
  Reference ->
  Word64 ->
  RCtx v ->
  Ctx v ->
  EnumMap CTag ([Mem], RNormal v) ->
  Maybe (RNormal v) ->
  Emit v Branch
emitDataMatching :: forall v.
Var v =>
Reference
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> EnumMap CTag ([Mem], RNormal v)
-> Maybe (RNormal v)
-> Emit v (GBranch CombIx)
emitDataMatching Reference
r RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx EnumMap CTag ([Mem], RNormal v)
cs Maybe (RNormal v)
df =
  Section -> EnumMap Word64 (Arm CombIx) -> GBranch CombIx
forall comb.
GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
mkBranch (Section -> EnumMap Word64 (Arm CombIx) -> GBranch CombIx)
-> Emit v Section
-> Emit v (EnumMap Word64 (Arm CombIx) -> GBranch CombIx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Emit v Section
edf Emit v (EnumMap Word64 (Arm CombIx) -> GBranch CombIx)
-> Emit v (EnumMap Word64 (Arm CombIx)) -> Emit v (GBranch CombIx)
forall a b. Emit v (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (([Mem], RNormal v) -> Emit v (Arm CombIx))
-> EnumMap Word64 ([Mem], RNormal v)
-> Emit v (EnumMap Word64 (Arm CombIx))
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) -> EnumMap Word64 a -> f (EnumMap Word64 b)
traverse (RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v (Arm CombIx)
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v (Arm CombIx)
emitArm RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx) (EnumMap CTag ([Mem], RNormal v)
-> EnumMap Word64 ([Mem], RNormal v)
forall a b. Coercible a b => a -> b
coerce EnumMap CTag ([Mem], RNormal v)
cs)
  where
    -- Note: this is not really accurate. A default data case needs
    -- stack space corresponding to the actual data that shows up there.
    -- However, we currently don't use default cases for data.
    edf :: Emit v Section
edf
      | Just RNormal v
co <- Maybe (RNormal v)
df = RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx RNormal v
co
      | Bool
otherwise = Ctx v -> Section -> Emit v Section
forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx (Section -> Emit v Section) -> Section -> Emit v Section
forall a b. (a -> b) -> a -> b
$ [Char] -> Section
forall comb. [Char] -> GSection comb
Die ([Char]
"missing data case for hash " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r)

-- Emits code corresponding to an unboxed sum match.
-- The match is against a tag on the stack, and cases introduce
-- variables to the middle of the context, because the fields were
-- already there, but it was unknown how many there were until
-- branching on the tag.
emitSumMatching ::
  (Var v) =>
  RefNums ->
  Reference ->
  Word64 ->
  RCtx v ->
  Ctx v ->
  v ->
  Int ->
  EnumMap Word64 ([Mem], RNormal v) ->
  Emit v Section
emitSumMatching :: forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> v
-> Int
-> EnumMap Word64 ([Mem], RNormal v)
-> Emit v Section
emitSumMatching RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx v
v Int
i EnumMap Word64 ([Mem], RNormal v)
cs =
  Int -> Section -> EnumMap Word64 Section -> Section
forall comb.
Int
-> GSection comb -> EnumMap Word64 (GSection comb) -> GSection comb
MatchW Int
i Section
forall {comb}. GSection comb
edf (EnumMap Word64 Section -> Section)
-> Emit v (EnumMap Word64 Section) -> Emit v Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Mem], RNormal v) -> Emit v Section)
-> EnumMap Word64 ([Mem], RNormal v)
-> Emit v (EnumMap Word64 Section)
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) -> EnumMap Word64 a -> f (EnumMap Word64 b)
traverse (RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> v
-> ([Mem], RNormal v)
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> v
-> ([Mem], RNormal v)
-> Emit v Section
emitSumCase RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx v
v) EnumMap Word64 ([Mem], RNormal v)
cs
  where
    edf :: GSection comb
edf = [Char] -> GSection comb
forall comb. [Char] -> GSection comb
Die [Char]
"uncovered unboxed sum case"

emitRequestMatching ::
  (Var v) =>
  RefNums ->
  Reference ->
  Word64 ->
  RCtx v ->
  Ctx v ->
  EnumMap Word64 (EnumMap CTag ([Mem], RNormal v)) ->
  RNormal v ->
  Emit v (Section, EnumMap Word64 Branch)
emitRequestMatching :: forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> EnumMap Word64 (EnumMap CTag ([Mem], RNormal v))
-> RNormal v
-> Emit v (Section, EnumMap Word64 (GBranch CombIx))
emitRequestMatching RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx EnumMap Word64 (EnumMap CTag ([Mem], RNormal v))
hs RNormal v
df = (,) (Section
 -> EnumMap Word64 (GBranch CombIx)
 -> (Section, EnumMap Word64 (GBranch CombIx)))
-> Emit v Section
-> Emit
     v
     (EnumMap Word64 (GBranch CombIx)
      -> (Section, EnumMap Word64 (GBranch CombIx)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Emit v Section
pur Emit
  v
  (EnumMap Word64 (GBranch CombIx)
   -> (Section, EnumMap Word64 (GBranch CombIx)))
-> Emit v (EnumMap Word64 (GBranch CombIx))
-> Emit v (Section, EnumMap Word64 (GBranch CombIx))
forall a b. Emit v (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Emit v (EnumMap Word64 (GBranch CombIx))
tops
  where
    pur :: Emit v Section
pur = RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v Section
emitCase RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx ([Mem
BX], RNormal v
df)
    tops :: Emit v (EnumMap Word64 (GBranch CombIx))
tops = (EnumMap Word64 ([Mem], RNormal v) -> Emit v (GBranch CombIx))
-> EnumMap Word64 (EnumMap Word64 ([Mem], RNormal v))
-> Emit v (EnumMap Word64 (GBranch CombIx))
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) -> EnumMap Word64 a -> f (EnumMap Word64 b)
traverse EnumMap Word64 ([Mem], RNormal v) -> Emit v (GBranch CombIx)
f (EnumMap Word64 (EnumMap CTag ([Mem], RNormal v))
-> EnumMap Word64 (EnumMap Word64 ([Mem], RNormal v))
forall a b. Coercible a b => a -> b
coerce EnumMap Word64 (EnumMap CTag ([Mem], RNormal v))
hs)
    f :: EnumMap Word64 ([Mem], RNormal v) -> Emit v (GBranch CombIx)
f EnumMap Word64 ([Mem], RNormal v)
cs = Section -> EnumMap Word64 (Arm CombIx) -> GBranch CombIx
forall comb.
GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
mkBranch Section
forall {comb}. GSection comb
edf (EnumMap Word64 (Arm CombIx) -> GBranch CombIx)
-> Emit v (EnumMap Word64 (Arm CombIx)) -> Emit v (GBranch CombIx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Mem], RNormal v) -> Emit v (Arm CombIx))
-> EnumMap Word64 ([Mem], RNormal v)
-> Emit v (EnumMap Word64 (Arm CombIx))
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) -> EnumMap Word64 a -> f (EnumMap Word64 b)
traverse (RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v (Arm CombIx)
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v (Arm CombIx)
emitArm RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx) EnumMap Word64 ([Mem], RNormal v)
cs
    edf :: GSection comb
edf = [Char] -> GSection comb
forall comb. [Char] -> GSection comb
Die [Char]
"unhandled ability"

emitLitMatching ::
  (Var v) =>
  (Traversable f) =>
  (Int -> Section -> f Section -> Section) ->
  String ->
  RefNums ->
  Reference ->
  Word64 ->
  RCtx v ->
  Ctx v ->
  Int ->
  f (RNormal v) ->
  Maybe (RNormal v) ->
  Emit v Section
emitLitMatching :: forall v (f :: * -> *).
(Var v, Traversable f) =>
(Int -> Section -> f Section -> Section)
-> [Char]
-> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> Int
-> f (RNormal v)
-> Maybe (RNormal v)
-> Emit v Section
emitLitMatching Int -> Section -> f Section -> Section
con [Char]
err RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx Int
i f (RNormal v)
cs Maybe (RNormal v)
df =
  Int -> Section -> f Section -> Section
con Int
i (Section -> f Section -> Section)
-> Emit v Section -> Emit v (f Section -> Section)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Emit v Section
edf Emit v (f Section -> Section)
-> Emit v (f Section) -> Emit v Section
forall a b. Emit v (a -> b) -> Emit v a -> Emit v b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (RNormal v -> Emit v Section)
-> f (RNormal v) -> Emit v (f Section)
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) -> f a -> f (f b)
traverse (RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v Section
emitCase RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx (([Mem], RNormal v) -> Emit v Section)
-> (RNormal v -> ([Mem], RNormal v)) -> RNormal v -> Emit v Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([],)) f (RNormal v)
cs
  where
    edf :: Emit v Section
edf
      | Just RNormal v
co <- Maybe (RNormal v)
df = RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx RNormal v
co
      | Bool
otherwise = Ctx v -> Section -> Emit v Section
forall v a. Ctx v -> a -> Emit v a
countCtx Ctx v
ctx (Section -> Emit v Section) -> Section -> Emit v Section
forall a b. (a -> b) -> a -> b
$ [Char] -> Section
forall comb. [Char] -> GSection comb
Die [Char]
err

emitCase ::
  (Var v) =>
  RefNums ->
  Reference ->
  Word64 ->
  RCtx v ->
  Ctx v ->
  ([Mem], RNormal v) ->
  Emit v Section
emitCase :: forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v Section
emitCase RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx ([Mem]
ccs, TAbss [v]
vs RNormal v
bo) =
  RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec ([(v, Mem)] -> Ctx v -> Ctx v
forall v. [(v, Mem)] -> Ctx v -> Ctx v
pushCtx ([v] -> [Mem] -> [(v, Mem)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
vs [Mem]
ccs) Ctx v
ctx) RNormal v
bo

-- | A data or request match arm: its code with the number of fields it
-- binds, the slots 'emitCase' lays its context out with (see 'Arm').
emitArm ::
  (Var v) =>
  RefNums ->
  Reference ->
  Word64 ->
  RCtx v ->
  Ctx v ->
  ([Mem], RNormal v) ->
  Emit v Branch'
emitArm :: forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v (Arm CombIx)
emitArm RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx c :: ([Mem], RNormal v)
c@([Mem]
ccs, TAbss [v]
vs RNormal v
_) =
  Int -> Section -> Arm CombIx
forall comb. Int -> GSection comb -> Arm comb
Arm ([(v, Mem)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([v] -> [Mem] -> [(v, Mem)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
vs [Mem]
ccs)) (Section -> Arm CombIx) -> Emit v Section -> Emit v (Arm CombIx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> ([Mem], RNormal v)
-> Emit v Section
emitCase RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx ([Mem], RNormal v)
c

type Branch' = Arm CombIx

emitSumCase ::
  (Var v) =>
  RefNums ->
  Reference ->
  Word64 ->
  RCtx v ->
  Ctx v ->
  v ->
  ([Mem], RNormal v) ->
  Emit v Section
emitSumCase :: forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> v
-> ([Mem], RNormal v)
-> Emit v Section
emitSumCase RefNums
rns Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx v
v ([Mem]
ccs, TAbss [v]
vs RNormal v
bo) =
  RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> Ctx v
-> RNormal v
-> Emit v Section
emitSection RefNums
rns Reference
grpr Word64
grpn RCtx v
rec (Ctx v -> v -> [(v, Mem)] -> Ctx v
forall v. Var v => Ctx v -> v -> [(v, Mem)] -> Ctx v
sumCtx Ctx v
ctx v
v ([(v, Mem)] -> Ctx v) -> [(v, Mem)] -> Ctx v
forall a b. (a -> b) -> a -> b
$ [v] -> [Mem] -> [(v, Mem)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
vs [Mem]
ccs) RNormal v
bo

litToMLit :: ANF.Lit Reference -> MLit
litToMLit :: Lit Reference -> MLit
litToMLit (ANF.I Int64
i) = Int -> MLit
MI (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
litToMLit (ANF.N Word64
n) = Word64 -> MLit
MN Word64
n
litToMLit (ANF.C Char
c) = Char -> MLit
MC Char
c
litToMLit (ANF.F Double
d) = Double -> MLit
MD Double
d
litToMLit (ANF.T Text
t) = Text -> MLit
MT Text
t
litToMLit (ANF.LM Referent
r) = Referent -> MLit
MM Referent
r
litToMLit (ANF.LY Reference
r) = Reference -> MLit
MY Reference
r

-- | Emit a literal as a machine literal of the correct boxed/unboxed format.
emitLit :: ANF.Lit Reference -> Instr
emitLit :: Lit Reference -> GInstr CombIx
emitLit = MLit -> GInstr CombIx
forall comb. MLit -> GInstr comb
Lit (MLit -> GInstr CombIx)
-> (Lit Reference -> MLit) -> Lit Reference -> GInstr CombIx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit Reference -> MLit
litToMLit

-- Emits some fix-up code for calling functions. Some of the
-- variables in scope come from the top-level let rec, but these
-- are definitions, not values on the stack. These definitions cannot
-- be passed directly as function arguments, and must have a
-- corresponding stack entry allocated first. So, this function inserts
-- these allocations and passes the appropriate context into the
-- provided continuation.
emitClosures ::
  (Var v) =>
  Reference ->
  Word64 ->
  RCtx v ->
  Ctx v ->
  [v] ->
  (Ctx v -> Args -> Emit v Section) ->
  Emit v Section
emitClosures :: forall v.
Var v =>
Reference
-> Word64
-> RCtx v
-> Ctx v
-> [v]
-> (Ctx v -> Args -> Emit v Section)
-> Emit v Section
emitClosures Reference
grpr Word64
grpn RCtx v
rec Ctx v
ctx [v]
args Ctx v -> Args -> Emit v Section
k =
  Ctx v -> [v] -> (Ctx v -> Emit v Section) -> Emit v Section
allocate Ctx v
ctx [v]
args ((Ctx v -> Emit v Section) -> Emit v Section)
-> (Ctx v -> Emit v Section) -> Emit v Section
forall a b. (a -> b) -> a -> b
$ \Ctx v
ctx -> Ctx v -> Args -> Emit v Section
k Ctx v
ctx (Args -> Emit v Section) -> Args -> Emit v Section
forall a b. (a -> b) -> a -> b
$ Word64 -> Ctx v -> [v] -> Args
forall v. Var v => Word64 -> Ctx v -> [v] -> Args
emitArgs Word64
grpn Ctx v
ctx [v]
args
  where
    allocate :: Ctx v -> [v] -> (Ctx v -> Emit v Section) -> Emit v Section
allocate Ctx v
ctx [] Ctx v -> Emit v Section
k = Ctx v -> Emit v Section
k Ctx v
ctx
    allocate Ctx v
ctx (v
a : [v]
as) Ctx v -> Emit v Section
k
      | Just (Int, Mem)
_ <- Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx v
a = Ctx v -> [v] -> (Ctx v -> Emit v Section) -> Emit v Section
allocate Ctx v
ctx [v]
as Ctx v -> Emit v Section
k
      | Just Word64
n <- RCtx v -> v -> Maybe Word64
forall v. Var v => RCtx v -> v -> Maybe Word64
rctxResolve RCtx v
rec v
a =
          let cix :: CombIx
cix = (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
grpr Word64
grpn Word64
n)
           in GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (GRef CombIx -> Args -> GInstr CombIx
forall comb. GRef comb -> Args -> GInstr comb
Name (CombIx -> CombIx -> GRef CombIx
forall comb. CombIx -> comb -> GRef comb
Env CombIx
cix CombIx
cix) Args
ZArgs) (Section -> Section) -> Emit v Section -> Emit v Section
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ctx v -> [v] -> (Ctx v -> Emit v Section) -> Emit v Section
allocate (v -> Mem -> Ctx v -> Ctx v
forall v. v -> Mem -> Ctx v -> Ctx v
Var v
a Mem
BX Ctx v
ctx) [v]
as Ctx v -> Emit v Section
k
      | Bool
otherwise =
          [Word] -> [Char] -> Emit v Section
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Emit v Section) -> [Char] -> Emit v Section
forall a b. (a -> b) -> a -> b
$ [Char]
"emitClosures: unknown reference: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> [Char]
forall a. Show a => a -> [Char]
show v
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
grpr

emitArgs :: (Var v) => Word64 -> Ctx v -> [v] -> Args
emitArgs :: forall v. Var v => Word64 -> Ctx v -> [v] -> Args
emitArgs Word64
grpn Ctx v
ctx [v]
args
  | Just [(Int, Mem)]
l <- (v -> Maybe (Int, Mem)) -> [v] -> Maybe [(Int, Mem)]
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) -> [a] -> f [b]
traverse (Ctx v -> v -> Maybe (Int, Mem)
forall v. Var v => Ctx v -> v -> Maybe (Int, Mem)
ctxResolve Ctx v
ctx) [v]
args = [(Int, Mem)] -> Args
demuxArgs [(Int, Mem)]
l
  | Bool
otherwise =
      [Word] -> [Char] -> Args
forall a. HasCallStack => [Word] -> [Char] -> a
internalBug [] ([Char] -> Args) -> [Char] -> Args
forall a b. (a -> b) -> a -> b
$
        [Char]
"emitArgs["
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
grpn
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"]: "
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"could not resolve argument variables: "
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [v] -> [Char]
forall a. Show a => a -> [Char]
show [v]
args

-- Turns a list of stack positions and calling conventions into the
-- argument format expected in the machine code.
demuxArgs :: [(Int, Mem)] -> Args
demuxArgs :: [(Int, Mem)] -> Args
demuxArgs = \case
  [] -> Args
ZArgs
  [(Int
i, Mem
_)] -> Int -> Args
VArg1 Int
i
  [(Int
i, Mem
_), (Int
j, Mem
_)] -> Int -> Int -> Args
VArg2 Int
i Int
j
  [(Int, Mem)]
args -> PrimArray Int -> Args
VArgN (PrimArray Int -> Args) -> PrimArray Int -> Args
forall a b. (a -> b) -> a -> b
$ [Int] -> PrimArray Int
forall a. Prim a => [a] -> PrimArray a
PA.primArrayFromList ((Int, Mem) -> Int
forall a b. (a, b) -> a
fst ((Int, Mem) -> Int) -> [(Int, Mem)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Mem)]
args)

combDeps :: GComb val comb -> [Word64]
combDeps :: forall val comb. GComb val comb -> [Word64]
combDeps (Lam Int
_ Int
_ GSection comb
s) = GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
s
combDeps (CachedVal {}) = []

combTypes :: GComb any comb -> [Word64]
combTypes :: forall val comb. GComb val comb -> [Word64]
combTypes (Lam Int
_ Int
_ GSection comb
s) = GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
s
combTypes (CachedVal {}) = []

sectionDeps :: GSection comb -> [Word64]
sectionDeps :: forall comb. GSection comb -> [Word64]
sectionDeps (App Bool
_ (Env (CIx Reference
_ Word64
w Word64
_) comb
_) Args
_) = [Word64
w]
sectionDeps (Call Bool
_ (CIx Reference
_ Word64
w Word64
_) comb
_ Args
_) = [Word64
w]
sectionDeps (Match Int
_ GBranch comb
br) = GBranch comb -> [Word64]
forall comb. GBranch comb -> [Word64]
branchDeps GBranch comb
br
sectionDeps (DMatch Maybe Reference
_ Int
_ GBranch comb
br) = GBranch comb -> [Word64]
forall comb. GBranch comb -> [Word64]
branchDeps GBranch comb
br
sectionDeps (RMatch Int
_ GSection comb
pu EnumMap Word64 (GBranch comb)
br) =
  GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
pu [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ (GBranch comb -> [Word64])
-> EnumMap Word64 (GBranch comb) -> [Word64]
forall m a. Monoid m => (a -> m) -> EnumMap Word64 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GBranch comb -> [Word64]
forall comb. GBranch comb -> [Word64]
branchDeps EnumMap Word64 (GBranch comb)
br
sectionDeps (NMatch Maybe Reference
_ Int
_ GBranch comb
br) = GBranch comb -> [Word64]
forall comb. GBranch comb -> [Word64]
branchDeps GBranch comb
br
sectionDeps (Ins GInstr comb
i GSection comb
s)
  | Name (Env (CIx Reference
_ Word64
w Word64
_) comb
_) Args
_ <- GInstr comb
i = Word64
w Word64 -> [Word64] -> [Word64]
forall a. a -> [a] -> [a]
: GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
s
  | Bool
otherwise = GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
s
sectionDeps (Let GSection comb
s (CIx Reference
_ Word64
w Word64
_) Int
_ GSection comb
b Ptr NativeCell
_) =
  Word64
w Word64 -> [Word64] -> [Word64]
forall a. a -> [a] -> [a]
: GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
s [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
b
sectionDeps GSection comb
_ = []

sectionTypes :: GSection comb -> [Word64]
sectionTypes :: forall comb. GSection comb -> [Word64]
sectionTypes (Ins GInstr comb
i GSection comb
s) = GInstr comb -> [Word64]
forall comb. GInstr comb -> [Word64]
instrTypes GInstr comb
i [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
s
sectionTypes (Let GSection comb
s CombIx
_ Int
_ GSection comb
b Ptr NativeCell
_) = GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
s [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
b
sectionTypes (Match Int
_ GBranch comb
br) = GBranch comb -> [Word64]
forall comb. GBranch comb -> [Word64]
branchTypes GBranch comb
br
sectionTypes (DMatch Maybe Reference
_ Int
_ GBranch comb
br) = GBranch comb -> [Word64]
forall comb. GBranch comb -> [Word64]
branchTypes GBranch comb
br
sectionTypes (NMatch Maybe Reference
_ Int
_ GBranch comb
br) = GBranch comb -> [Word64]
forall comb. GBranch comb -> [Word64]
branchTypes GBranch comb
br
sectionTypes (RMatch Int
_ GSection comb
pu EnumMap Word64 (GBranch comb)
br) =
  GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
pu [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ (GBranch comb -> [Word64])
-> EnumMap Word64 (GBranch comb) -> [Word64]
forall m a. Monoid m => (a -> m) -> EnumMap Word64 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GBranch comb -> [Word64]
forall comb. GBranch comb -> [Word64]
branchTypes EnumMap Word64 (GBranch comb)
br
sectionTypes GSection comb
_ = []

instrTypes :: GInstr comb -> [Word64]
instrTypes :: forall comb. GInstr comb -> [Word64]
instrTypes (Pack (PackedTag Word64
w) Args
_) = [Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16]
instrTypes (PackWide (PackedTag Word64
w) Bool
_ Args
_) = [Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16]
instrTypes (Reset EnumSet Word64
ws Int
_ Maybe Int
_) = EnumSet Word64 -> [Word64]
forall k. EnumKey k => EnumSet k -> [k]
setToList EnumSet Word64
ws
instrTypes (Capture Word64
w) = [Word64
w]
instrTypes GInstr comb
_ = []

branchDeps :: GBranch comb -> [Word64]
branchDeps :: forall comb. GBranch comb -> [Word64]
branchDeps (Test1 Word64
_ (Arm Int
_ GSection comb
s1) GSection comb
d) = GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
s1 [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
d
branchDeps (Test2 Word64
_ (Arm Int
_ GSection comb
s1) Word64
_ (Arm Int
_ GSection comb
s2) GSection comb
d) =
  GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
s1 [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
s2 [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
d
branchDeps (TestW GSection comb
d EnumMap Word64 (Arm comb)
m) =
  GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
d [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ (Arm comb -> [Word64]) -> EnumMap Word64 (Arm comb) -> [Word64]
forall m a. Monoid m => (a -> m) -> EnumMap Word64 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps (GSection comb -> [Word64])
-> (Arm comb -> GSection comb) -> Arm comb -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arm comb -> GSection comb
forall comb. Arm comb -> GSection comb
armSection) EnumMap Word64 (Arm comb)
m
branchDeps (TestT GSection comb
d Map Text (GSection comb)
m) =
  GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
d [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ (GSection comb -> [Word64]) -> Map Text (GSection comb) -> [Word64]
forall m a. Monoid m => (a -> m) -> Map Text a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps Map Text (GSection comb)
m
branchDeps (TestY GSection comb
d Map Bytes (GSection comb)
m) =
  GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps GSection comb
d [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ (GSection comb -> [Word64])
-> Map Bytes (GSection comb) -> [Word64]
forall m a. Monoid m => (a -> m) -> Map Bytes a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionDeps Map Bytes (GSection comb)
m

branchTypes :: GBranch comb -> [Word64]
branchTypes :: forall comb. GBranch comb -> [Word64]
branchTypes (Test1 Word64
_ (Arm Int
_ GSection comb
s1) GSection comb
d) = GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
s1 [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
d
branchTypes (Test2 Word64
_ (Arm Int
_ GSection comb
s1) Word64
_ (Arm Int
_ GSection comb
s2) GSection comb
d) =
  GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
s1 [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
s2 [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
d
branchTypes (TestW GSection comb
d EnumMap Word64 (Arm comb)
m) =
  GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
d [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ (Arm comb -> [Word64]) -> EnumMap Word64 (Arm comb) -> [Word64]
forall m a. Monoid m => (a -> m) -> EnumMap Word64 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes (GSection comb -> [Word64])
-> (Arm comb -> GSection comb) -> Arm comb -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arm comb -> GSection comb
forall comb. Arm comb -> GSection comb
armSection) EnumMap Word64 (Arm comb)
m
branchTypes (TestT GSection comb
d Map Text (GSection comb)
m) =
  GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
d [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ (GSection comb -> [Word64]) -> Map Text (GSection comb) -> [Word64]
forall m a. Monoid m => (a -> m) -> Map Text a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes Map Text (GSection comb)
m
branchTypes (TestY GSection comb
d Map Bytes (GSection comb)
m) =
  GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes GSection comb
d [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ (GSection comb -> [Word64])
-> Map Bytes (GSection comb) -> [Word64]
forall m a. Monoid m => (a -> m) -> Map Bytes a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GSection comb -> [Word64]
forall comb. GSection comb -> [Word64]
sectionTypes Map Bytes (GSection comb)
m

indent :: Int -> ShowS
indent :: Int -> ShowS
indent Int
ind = [Char] -> ShowS
showString (Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' ')

-- | The frames a section is written out as, when they are not its own
-- ('Deopt'): one line per frame, the section it resumes and its slots.
prettyBase :: FrameLayout -> ShowS
prettyBase :: FrameLayout -> ShowS
prettyBase FrameLayout
lay = case FrameLayout -> Maybe Deopt
baseFrames FrameLayout
lay of
  Maybe Deopt
Nothing -> ShowS
forall a. a -> a
id
  Just (Deopt [BaseFrame]
frames) -> (BaseFrame -> ShowS -> ShowS) -> ShowS -> [BaseFrame] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(BaseFrame Word64
ix [Slot]
slots) ShowS
r -> [Char] -> ShowS
showString [Char]
"  base " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Word64
ix ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
": " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Slot] -> ShowS
showList' [Slot]
slots ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"\n" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
r) ShowS
forall a. a -> a
id [BaseFrame]
frames
  where
    showList' :: [Slot] -> ShowS
showList' [Slot]
slots = [Char] -> ShowS
showString [Char]
"[" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id (ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse ([Char] -> ShowS
showString [Char]
", ") ((Slot -> ShowS) -> [Slot] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map Slot -> ShowS
slot [Slot]
slots)) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"]"
    slot :: Slot -> ShowS
slot = \case
      Copy Int
d Int
i -> Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
d ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"." ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
i
      PackSlot PackedTag
t [Slot]
ss -> [Char] -> ShowS
showString [Char]
"pack " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackedTag -> ShowS
forall a. Show a => a -> ShowS
shows PackedTag
t ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Slot] -> ShowS
showList' [Slot]
ss
      RecSlot RecordShape
sh [Slot]
ss -> [Char] -> ShowS
showString [Char]
"record " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordRef -> ShowS
forall a. Show a => a -> ShowS
shows (RecordShape -> RecordRef
shapeRef RecordShape
sh) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Slot] -> ShowS
showList' [Slot]
ss
      Slot
Dead -> [Char] -> ShowS
showString [Char]
"dead"

prettyCombs ::
  Word64 ->
  EnumMap Word64 Comb ->
  ShowS
prettyCombs :: Word64 -> EnumMap Word64 Comb -> ShowS
prettyCombs Word64
w EnumMap Word64 Comb
es =
  ((Word64, Comb) -> ShowS -> ShowS)
-> ShowS -> [(Word64, Comb)] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    (\(Word64
i, Comb
c) ShowS
r -> Word64 -> Word64 -> Comb -> ShowS
forall val comb.
(Show val, Show comb) =>
Word64 -> Word64 -> GComb val comb -> ShowS
prettyComb Word64
w Word64
i Comb
c ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"\n" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
r)
    ShowS
forall a. a -> a
id
    (EnumMap Word64 Comb -> [(Word64, Comb)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList EnumMap Word64 Comb
es)

prettyComb :: (Show val, Show comb) => Word64 -> Word64 -> GComb val comb -> ShowS
prettyComb :: forall val comb.
(Show val, Show comb) =>
Word64 -> Word64 -> GComb val comb -> ShowS
prettyComb Word64
w Word64
i = \case
  (Comb (LamI Int
a Int
_ GSection comb
s Ptr NativeCell
_) FrameLayout
lay) ->
    Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Word64
w
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
":"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Word64
i
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
":"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
a
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"\n"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameLayout -> ShowS
prettyBase FrameLayout
lay
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GSection comb -> ShowS
forall comb. Show comb => Int -> GSection comb -> ShowS
prettySection Int
2 GSection comb
s
  (CachedVal Word64
a val
b) ->
    Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Word64
w
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
":"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Word64
i
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
":"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Word64
a
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"\n"
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. val -> ShowS
forall a. Show a => a -> ShowS
shows val
b

prettySection :: (Show comb) => Int -> GSection comb -> ShowS
prettySection :: forall comb. Show comb => Int -> GSection comb -> ShowS
prettySection Int
ind GSection comb
sec =
  Int -> ShowS
indent Int
ind ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case GSection comb
sec of
    App Bool
_ GRef comb
r Args
as ->
      [Char] -> ShowS
showString [Char]
"App "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GRef comb -> ShowS
forall comb. Int -> GRef comb -> ShowS
prettyGRef Int
12 GRef comb
r
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> ShowS
prettyArgs Args
as
    Call Bool
_ CombIx
i comb
_ Args
as ->
      [Char] -> ShowS
showString [Char]
"Call " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CombIx -> ShowS
prettyCIx CombIx
i ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> ShowS
prettyArgs Args
as
    Jump Int
i Args
as ->
      [Char] -> ShowS
showString [Char]
"Jump " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
i ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> ShowS
prettyArgs Args
as
    Match Int
i GBranch comb
bs ->
      [Char] -> ShowS
showString [Char]
"Match "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
i
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"\n"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GBranch comb -> ShowS
forall comb. Show comb => Int -> GBranch comb -> ShowS
prettyBranches (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) GBranch comb
bs
    Yield Args
as -> [Char] -> ShowS
showString [Char]
"Yield " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> ShowS
prettyArgs Args
as
    Ins GInstr comb
i GSection comb
nx ->
      GInstr comb -> ShowS
forall comb. Show comb => GInstr comb -> ShowS
prettyIns GInstr comb
i ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"\n" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GSection comb -> ShowS
forall comb. Show comb => Int -> GSection comb -> ShowS
prettySection Int
ind GSection comb
nx
    Let GSection comb
s CombIx
_ Int
_ GSection comb
b Ptr NativeCell
_ ->
      [Char] -> ShowS
showString [Char]
"Let\n"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GSection comb -> ShowS
forall comb. Show comb => Int -> GSection comb -> ShowS
prettySection (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) GSection comb
s
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"\n"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GSection comb -> ShowS
forall comb. Show comb => Int -> GSection comb -> ShowS
prettySection Int
ind GSection comb
b
    Die [Char]
s -> [Char] -> ShowS
showString ([Char] -> ShowS) -> [Char] -> ShowS
forall a b. (a -> b) -> a -> b
$ [Char]
"Die " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s
    GSection comb
Exit -> [Char] -> ShowS
showString [Char]
"Exit"
    DMatch Maybe Reference
_ Int
i GBranch comb
bs ->
      [Char] -> ShowS
showString [Char]
"DMatch "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
i
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"\n"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GBranch comb -> ShowS
forall comb. Show comb => Int -> GBranch comb -> ShowS
prettyBranches (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) GBranch comb
bs
    NMatch Maybe Reference
_ Int
i GBranch comb
bs ->
      [Char] -> ShowS
showString [Char]
"NMatch "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
i
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"\n"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GBranch comb -> ShowS
forall comb. Show comb => Int -> GBranch comb -> ShowS
prettyBranches (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) GBranch comb
bs
    RMatch Int
i GSection comb
pu EnumMap Word64 (GBranch comb)
bs ->
      [Char] -> ShowS
showString [Char]
"RMatch "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
i
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"\nPUR ->\n"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GSection comb -> ShowS
forall comb. Show comb => Int -> GSection comb -> ShowS
prettySection (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) GSection comb
pu
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word64, GBranch comb) -> ShowS -> ShowS)
-> ShowS -> [(Word64, GBranch comb)] -> ShowS
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 comb)
p ShowS
r -> (Word64, GBranch comb) -> ShowS
rqc (Word64, GBranch comb)
p ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
r) ShowS
forall a. a -> a
id (EnumMap Word64 (GBranch comb) -> [(Word64, GBranch comb)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList EnumMap Word64 (GBranch comb)
bs)
      where
        rqc :: (Word64, GBranch comb) -> ShowS
rqc (Word64
i, GBranch comb
e) =
          [Char] -> ShowS
showString [Char]
"\n"
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Word64
i
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" ->\n"
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GBranch comb -> ShowS
forall comb. Show comb => Int -> GBranch comb -> ShowS
prettyBranches (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) GBranch comb
e

prettyCIx :: CombIx -> ShowS
prettyCIx :: CombIx -> ShowS
prettyCIx (CIx Reference
r Word64
_ Word64
n) =
  Reference -> ShowS
prettyRef Reference
r ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. if Word64
n Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 then ShowS
forall a. a -> a
id else [Char] -> ShowS
showString [Char]
"-" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Word64
n

prettyRef :: Reference -> ShowS
prettyRef :: Reference -> ShowS
prettyRef = [Char] -> ShowS
showString ([Char] -> ShowS) -> (Reference -> [Char]) -> Reference -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> [Char]
Text.unpack (FieldName -> [Char])
-> (Reference -> FieldName) -> Reference -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Reference -> FieldName
showShort Int
10

prettyGRef :: Int -> GRef comb -> ShowS
prettyGRef :: forall comb. Int -> GRef comb -> ShowS
prettyGRef Int
p GRef comb
r =
  Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ case GRef comb
r of
    Stk Int
i -> [Char] -> ShowS
showString [Char]
"Stk " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
i
    Dyn Word64
w -> [Char] -> ShowS
showString [Char]
"Dyn " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Word64
w
    Env CombIx
cix comb
_ -> [Char] -> ShowS
showString [Char]
"Env " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CombIx -> ShowS
prettyCIx CombIx
cix

prettyBranches :: forall comb. (Show comb) => Int -> GBranch comb -> ShowS
prettyBranches :: forall comb. Show comb => Int -> GBranch comb -> ShowS
prettyBranches Int
ind GBranch comb
bs =
  case GBranch comb
bs of
    Test1 Word64
i Arm comb
e GSection comb
df -> GSection comb -> ShowS
pdf GSection comb
df ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Arm comb -> ShowS
parm Word64
i Arm comb
e
    Test2 Word64
i Arm comb
ei Word64
j Arm comb
ej GSection comb
df -> GSection comb -> ShowS
pdf GSection comb
df ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Arm comb -> ShowS
parm Word64
i Arm comb
ei ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Arm comb -> ShowS
parm Word64
j Arm comb
ej
    TestW GSection comb
df EnumMap Word64 (Arm comb)
m ->
      GSection comb -> ShowS
pdf GSection comb
df ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word64, Arm comb) -> ShowS -> ShowS)
-> ShowS -> [(Word64, Arm comb)] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Word64
i, Arm comb
e) ShowS
r -> Word64 -> Arm comb -> ShowS
parm Word64
i Arm comb
e ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
r) ShowS
forall a. a -> a
id (EnumMap Word64 (Arm comb) -> [(Word64, Arm comb)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList EnumMap Word64 (Arm comb)
m)
    TestT GSection comb
df Map Text (GSection comb)
m ->
      GSection comb -> ShowS
pdf GSection comb
df ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, GSection comb) -> ShowS -> ShowS)
-> ShowS -> [(Text, GSection comb)] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Text
i, GSection comb
e) ShowS
r -> Text -> GSection comb -> ShowS
forall a. Show a => a -> GSection comb -> ShowS
pscase Text
i GSection comb
e ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
r) ShowS
forall a. a -> a
id (Map Text (GSection comb) -> [(Text, GSection comb)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text (GSection comb)
m)
    TestY GSection comb
df Map Bytes (GSection comb)
m ->
      GSection comb -> ShowS
pdf GSection comb
df ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bytes, GSection comb) -> ShowS -> ShowS)
-> ShowS -> [(Bytes, GSection comb)] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Bytes
i, GSection comb
e) ShowS
r -> Bytes -> GSection comb -> ShowS
forall a. Show a => a -> GSection comb -> ShowS
pscase Bytes
i GSection comb
e ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
r) ShowS
forall a. a -> a
id (Map Bytes (GSection comb) -> [(Bytes, GSection comb)]
forall k a. Map k a -> [(k, a)]
M.toList Map Bytes (GSection comb)
m)
  where
    -- a data or request arm with the field count it binds
    parm :: Word64 -> Arm comb -> ShowS
parm Word64
i (Arm Int
n GSection comb
e) =
      [Char] -> ShowS
showString [Char]
"\n"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
ind
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Word64
i
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString ([Char]
" [" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"] ->\n")
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GSection comb -> ShowS
forall comb. Show comb => Int -> GSection comb -> ShowS
prettySection (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) GSection comb
e
    pdf :: GSection comb -> ShowS
pdf GSection comb
e = Int -> ShowS
indent Int
ind ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"DFLT ->\n" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GSection comb -> ShowS
forall comb. Show comb => Int -> GSection comb -> ShowS
prettySection (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) GSection comb
e
    pscase :: (Show a) => a -> GSection comb -> ShowS
    pscase :: forall a. Show a => a -> GSection comb -> ShowS
pscase a
t GSection comb
e =
      [Char] -> ShowS
showString [Char]
"\n"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
ind
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
t
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" ->\n"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GSection comb -> ShowS
forall comb. Show comb => Int -> GSection comb -> ShowS
prettySection (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) GSection comb
e

prettyIns :: (Show comb) => GInstr comb -> ShowS
prettyIns :: forall comb. Show comb => GInstr comb -> ShowS
prettyIns (Pack PackedTag
i Args
as) =
  [Char] -> ShowS
showString [Char]
"Pack "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackedTag -> ShowS
forall a. Show a => a -> ShowS
shows PackedTag
i
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
:)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> ShowS
prettyArgs Args
as
prettyIns (PackWide PackedTag
i Bool
base Args
as) =
  [Char] -> ShowS
showString (if Bool
base then [Char]
"PackWideRet " else [Char]
"PackWide ")
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackedTag -> ShowS
forall a. Show a => a -> ShowS
shows PackedTag
i
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
:)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> ShowS
prettyArgs Args
as
prettyIns (Box Int
i) = [Char] -> ShowS
showString [Char]
"Box " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
i
prettyIns (Lit MLit
l) =
  [Char] -> ShowS
showString [Char]
"Lit " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> MLit -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 MLit
l
prettyIns (Name GRef comb
r Args
as) =
  [Char] -> ShowS
showString [Char]
"Name "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> GRef comb -> ShowS
forall comb. Int -> GRef comb -> ShowS
prettyGRef Int
12 GRef comb
r
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
:)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> ShowS
prettyArgs Args
as
prettyIns GInstr comb
i = GInstr comb -> ShowS
forall a. Show a => a -> ShowS
shows GInstr comb
i

prettyArgs :: Args -> ShowS
prettyArgs :: Args -> ShowS
prettyArgs Args
ZArgs = [Char] -> ShowS
showString [Char]
"ZArgs"
prettyArgs Args
v = Bool -> ShowS -> ShowS
showParen Bool
True (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Args -> ShowS
forall a. Show a => a -> ShowS
shows Args
v

-- | If running in a sandboxed environment, replace all restricted foreign functions with an error.
sanitizeCombsOfForeignFuncs :: Bool -> (Set ForeignFunc) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx))
sanitizeCombsOfForeignFuncs :: Bool
-> Set ForeignFunc
-> EnumMap Word64 (EnumMap Word64 Comb)
-> EnumMap Word64 (EnumMap Word64 Comb)
sanitizeCombsOfForeignFuncs Bool
sanitize Set ForeignFunc
sandboxedForeigns EnumMap Word64 (EnumMap Word64 Comb)
m
  | Bool
sanitize = ((EnumMap Word64 Comb -> EnumMap Word64 Comb)
-> EnumMap Word64 (EnumMap Word64 Comb)
-> EnumMap Word64 (EnumMap Word64 Comb)
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((EnumMap Word64 Comb -> EnumMap Word64 Comb)
 -> EnumMap Word64 (EnumMap Word64 Comb)
 -> EnumMap Word64 (EnumMap Word64 Comb))
-> ((Comb -> Comb) -> EnumMap Word64 Comb -> EnumMap Word64 Comb)
-> (Comb -> Comb)
-> EnumMap Word64 (EnumMap Word64 Comb)
-> EnumMap Word64 (EnumMap Word64 Comb)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comb -> Comb) -> EnumMap Word64 Comb -> EnumMap Word64 Comb
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Set ForeignFunc -> Comb -> Comb
sanitizeComb Set ForeignFunc
sandboxedForeigns) EnumMap Word64 (EnumMap Word64 Comb)
m
  | Bool
otherwise = EnumMap Word64 (EnumMap Word64 Comb)
m

sanitizeComb :: Set ForeignFunc -> GComb Void CombIx -> GComb Void CombIx
sanitizeComb :: Set ForeignFunc -> Comb -> Comb
sanitizeComb Set ForeignFunc
sandboxedForeigns = \case
  Comb (LamI Int
a Int
b Section
s Ptr NativeCell
c) FrameLayout
lay -> GCombInfo CombIx -> FrameLayout -> Comb
forall val comb. GCombInfo comb -> FrameLayout -> GComb val comb
Comb (Int -> Int -> Section -> Ptr NativeCell -> GCombInfo CombIx
forall comb.
Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
LamI Int
a Int
b (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
s) Ptr NativeCell
c) FrameLayout
lay

-- | Crawl the source code and statically replace all sandboxed foreign funcs with an error.
sanitizeSection :: Set ForeignFunc -> GSection CombIx -> GSection CombIx
sanitizeSection :: Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
section = case Section
section of
  Ins (ForeignCall Bool
_ ForeignFunc
f Args
as) Section
nx
    | ForeignFunc -> Set ForeignFunc -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ForeignFunc
f Set ForeignFunc
sandboxedForeigns -> GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (FieldName -> GInstr CombIx
forall comb. FieldName -> GInstr comb
SandboxingFailure (ForeignFunc -> FieldName
foreignFuncBuiltinName ForeignFunc
f)) (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
nx)
    | Bool
otherwise -> GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (Bool -> ForeignFunc -> Args -> GInstr CombIx
forall comb. Bool -> ForeignFunc -> Args -> GInstr comb
ForeignCall Bool
True ForeignFunc
f Args
as) (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
nx)
  Ins GInstr CombIx
i Section
nx -> GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins GInstr CombIx
i (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
nx)
  App {} -> Section
section
  Call {} -> Section
section
  Jump {} -> Section
section
  Match Int
i GBranch CombIx
bs -> Int -> GBranch CombIx -> Section
forall comb. Int -> GBranch comb -> GSection comb
Match Int
i (Set ForeignFunc -> GBranch CombIx -> GBranch CombIx
sanitizeBranches Set ForeignFunc
sandboxedForeigns GBranch CombIx
bs)
  Yield {} -> Section
section
  Let Section
s CombIx
i Int
f Section
b Ptr NativeCell
c -> Section -> CombIx -> Int -> Section -> Ptr NativeCell -> Section
forall comb.
GSection comb
-> CombIx
-> Int
-> GSection comb
-> Ptr NativeCell
-> GSection comb
Let (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
s) CombIx
i Int
f (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
b) Ptr NativeCell
c
  Die {} -> Section
section
  Section
Exit -> Section
section
  DMatch Maybe Reference
i Int
j GBranch CombIx
bs -> Maybe Reference -> Int -> GBranch CombIx -> Section
forall comb.
Maybe Reference -> Int -> GBranch comb -> GSection comb
DMatch Maybe Reference
i Int
j (Set ForeignFunc -> GBranch CombIx -> GBranch CombIx
sanitizeBranches Set ForeignFunc
sandboxedForeigns GBranch CombIx
bs)
  NMatch Maybe Reference
i Int
j GBranch CombIx
bs -> Maybe Reference -> Int -> GBranch CombIx -> Section
forall comb.
Maybe Reference -> Int -> GBranch comb -> GSection comb
NMatch Maybe Reference
i Int
j (Set ForeignFunc -> GBranch CombIx -> GBranch CombIx
sanitizeBranches Set ForeignFunc
sandboxedForeigns GBranch CombIx
bs)
  RMatch Int
i Section
s EnumMap Word64 (GBranch CombIx)
bs -> Int -> Section -> EnumMap Word64 (GBranch CombIx) -> Section
forall comb.
Int
-> GSection comb -> EnumMap Word64 (GBranch comb) -> GSection comb
RMatch Int
i (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
s) ((GBranch CombIx -> GBranch CombIx)
-> EnumMap Word64 (GBranch CombIx)
-> EnumMap Word64 (GBranch CombIx)
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Set ForeignFunc -> GBranch CombIx -> GBranch CombIx
sanitizeBranches Set ForeignFunc
sandboxedForeigns) EnumMap Word64 (GBranch CombIx)
bs)

sanitizeBranches :: Set ForeignFunc -> GBranch CombIx -> GBranch CombIx
sanitizeBranches :: Set ForeignFunc -> GBranch CombIx -> GBranch CombIx
sanitizeBranches Set ForeignFunc
sandboxedForeigns = \case
  Test1 Word64
i Arm CombIx
s Section
d -> Word64 -> Arm CombIx -> Section -> GBranch CombIx
forall comb. Word64 -> Arm comb -> GSection comb -> GBranch comb
Test1 Word64
i (Arm CombIx -> Arm CombIx
sanitizeArm Arm CombIx
s) (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
d)
  Test2 Word64
i Arm CombIx
s Word64
j Arm CombIx
t Section
d -> Word64
-> Arm CombIx -> Word64 -> Arm CombIx -> Section -> GBranch CombIx
forall comb.
Word64
-> Arm comb -> Word64 -> Arm comb -> GSection comb -> GBranch comb
Test2 Word64
i (Arm CombIx -> Arm CombIx
sanitizeArm Arm CombIx
s) Word64
j (Arm CombIx -> Arm CombIx
sanitizeArm Arm CombIx
t) (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
d)
  TestW Section
d EnumMap Word64 (Arm CombIx)
m -> Section -> EnumMap Word64 (Arm CombIx) -> GBranch CombIx
forall comb.
GSection comb -> EnumMap Word64 (Arm comb) -> GBranch comb
TestW (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
d) ((Arm CombIx -> Arm CombIx)
-> EnumMap Word64 (Arm CombIx) -> EnumMap Word64 (Arm CombIx)
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arm CombIx -> Arm CombIx
sanitizeArm EnumMap Word64 (Arm CombIx)
m)
  TestT Section
d Map Text Section
m -> Section -> Map Text Section -> GBranch CombIx
forall comb.
GSection comb -> Map Text (GSection comb) -> GBranch comb
TestT (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
d) ((Section -> Section) -> Map Text Section -> Map Text Section
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns) Map Text Section
m)
  TestY Section
d Map Bytes Section
m -> Section -> Map Bytes Section -> GBranch CombIx
forall comb.
GSection comb -> Map Bytes (GSection comb) -> GBranch comb
TestY (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
d) ((Section -> Section) -> Map Bytes Section -> Map Bytes Section
forall a b. (a -> b) -> Map Bytes a -> Map Bytes b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns) Map Bytes Section
m)
  where
    sanitizeArm :: Arm CombIx -> Arm CombIx
sanitizeArm (Arm Int
n Section
s) = Int -> Section -> Arm CombIx
forall comb. Int -> GSection comb -> Arm comb
Arm Int
n (Set ForeignFunc -> Section -> Section
sanitizeSection Set ForeignFunc
sandboxedForeigns Section
s)

-- | How many slots an instruction pushes onto the frame, or Nothing where
-- the interpreter takes over from here (a capture, a sandboxing failure).
-- The one account of an instruction's effect on the frame: the JIT's code
-- generator lays frames out by it and 'resultCount' counts a primitive's
-- results by it, so the two cannot disagree.
pushCount :: GInstr comb -> Maybe Int
pushCount :: forall comb. GInstr comb -> Maybe Int
pushCount = \case
  Prim1 Prim1
LOAD Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2 -- a tag and the value
  Prim1 Prim1
_ Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  Prim2 Prim2
TRCE Int
_ Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
  Prim2 Prim2
THRO Int
_ Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0 -- never returns
  Prim2 Prim2
_ Int
_ Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  RefCAS {} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  ForeignCall {} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  GInstr comb
DLLCall -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  SetAff {} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
  Capture Word64
_ -> Maybe Int
forall a. Maybe a
Nothing
  Discard Int
_ -> Maybe Int
forall a. Maybe a
Nothing
  Name GRef comb
_ Args
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  Info [Char]
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
  Pack {} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  PackWide {} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
wideWidth
  Box Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
  RecPack {} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  RecUnpack Vector FieldRef
fields Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Vector FieldRef -> Int
forall a. Vector a -> Int
V.length Vector FieldRef
fields)
  RecSet {} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  Lit MLit
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  Print Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
  Reset {} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
  InLocal Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
  Fork Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  Atomically Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  Seq Args
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  TryForce Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  SandboxingFailure FieldName
_ -> Maybe Int
forall a. Maybe a
Nothing
  KeepAlive Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
  NewForeignPtr Int
_ Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  AddFinalizer Int
_ Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
  MkCallback Int
_ Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1

-- | For the two primitives whose result is an unboxed sum, the fields the
-- interpreter leaves under the tag it pushes, by tag (its LOAD and
-- TryForce cases; 'pushCount' counts LOAD's as two, the tag and the one
-- field, and TryForce's as the one slot it reserves before the sum is
-- known). A match on the tag binds these in place, so an arm has to bind
-- exactly this many; the emitter holds it to that.
sumFields :: ANF.POp -> Word64 -> Maybe Int
sumFields :: POp -> Word64 -> Maybe Int
sumFields POp
ANF.LOAD Word64
0 = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1 -- the references that could not be resolved
sumFields POp
ANF.LOAD Word64
1 = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1 -- the value
sumFields POp
ANF.TFRC Word64
0 = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3 -- the exception's type link, message and payload
sumFields POp
ANF.TFRC Word64
1 = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1 -- the value
sumFields POp
_ Word64
_ = Maybe Int
forall a. Maybe a
Nothing