{-# LANGUAGE QuasiQuotes #-}

{- |
The machine's state and every primitive that touches it: where code, data and
the two stacks sit in memory, the counted word\/byte accessors, and the
operand and control stacks -- the latter including the binary format of a
control record, since the format and the LIFO discipline that gives it meaning
are one thing.
-}
module Wrench.Isa.Wasm32.State (
    -- * The state
    Wasm32St (..),

    -- * Memory map
    defaultStackRoot,

    -- * Memory access
    getWord,
    setWord,
    fetchInstructionAt,
    getByte,
    setByte,
    setPc,
    nextPc,
    raiseInternalError,

    -- * Operand stack
    pushValue,
    popValue,

    -- * Locals
    localAddr,
    reserveLocals,

    -- * Scan cache
    cachedScan,

    -- * Branch cache
    BranchEntry (..),
    cachedBranch,
    rememberBranch,

    -- * Control stack
    Scope (..),
    pushScope,
    retireScopes,
    scopeAtDepth,
    scopeRecordAtDepth,
    innermostCall,
    ctrlCorruptedErr,

    -- * Control-record encoding
    scopeAddrs,
    scopeRecordBytes,
    scopeWordAddrs,
) where

import Data.Default (def)
import Data.List (lookup)
import Data.String.Interpolate (i)
import Relude
import Wrench.Isa.Wasm32.Instruction
import Wrench.Machine.BitPack
import Wrench.Machine.Memory
import Wrench.Machine.Types

-- | The machine state.
data Wasm32St w = Wasm32St
    { forall w. Wasm32St w -> Int
pc :: Int
    -- ^ Address of the next instruction.
    , forall w. Wasm32St w -> Int
sp :: Int
    -- ^ Address of the topmost operand.
    , forall w. Wasm32St w -> Int
frameBase :: Int
    -- ^ Address of local 0 of the current frame.
    , forall w. Wasm32St w -> Int
localCount :: Int
    -- ^ How many locals the current frame has: its parameters plus
    -- whatever @locals.reserve@ added.
    , forall w. Wasm32St w -> Int
ctrlSp :: Int
    -- ^ Top of the control stack.
    , forall w. Wasm32St w -> Int
stackRoot :: Int
    -- ^ Where both stacks start. Set by @sp.init@; by default three
    -- quarters of the way into memory.
    , forall w. Wasm32St w -> [(Int, Int)]
scanCache :: ![(Int, Int)]
    -- ^ The last 'scanCacheSize' scans for a matching @else@ or @end@, most
    -- recently used first: where each scan started and where it ended.
    , forall w. Wasm32St w -> Int
scanCacheSize :: Int
    -- ^ How many scans 'scanCache' keeps.
    , forall w. Wasm32St w -> [BranchEntry w]
branchCache :: ![BranchEntry w]
    -- ^ The last 'branchCacheSize' branches taken, most recently used first.
    , forall w. Wasm32St w -> Int
branchCacheSize :: Int
    -- ^ How many branches 'branchCache' keeps.
    , forall w. Wasm32St w -> [(Int, w)]
tosRegs :: ![(Int, w)]
    -- ^ The top-of-stack registers: copies of the last 'tosRegCount'
    -- values pushed and not yet popped, the last pushed first, each with
    -- the address of its slot.
    , forall w. Wasm32St w -> Int
tosRegCount :: Int
    -- ^ How many values 'tosRegs' holds.
    , forall w. Wasm32St w -> IoMem (Wasm32Isa w w) w
mem :: IoMem (Wasm32Isa w w) w
    -- ^ Memory, including the memory-mapped I\/O ports.
    , forall w. Wasm32St w -> [(Int, Wasm32Isa w w)]
ir :: [(Int, Wasm32Isa w w)]
    -- ^ Instruction register: the instructions of the last fetched words, by address.
    , forall w. Wasm32St w -> Bool
stopped :: Bool
    -- ^ Set by @halt@.
    , forall w. Wasm32St w -> Maybe Text
internalError :: Maybe Text
    -- ^ The error that stopped the machine, if any.
    }
    deriving (Int -> Wasm32St w -> ShowS
[Wasm32St w] -> ShowS
Wasm32St w -> String
(Int -> Wasm32St w -> ShowS)
-> (Wasm32St w -> String)
-> ([Wasm32St w] -> ShowS)
-> Show (Wasm32St w)
forall w. Show w => Int -> Wasm32St w -> ShowS
forall w. Show w => [Wasm32St w] -> ShowS
forall w. Show w => Wasm32St w -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall w. Show w => Int -> Wasm32St w -> ShowS
showsPrec :: Int -> Wasm32St w -> ShowS
$cshow :: forall w. Show w => Wasm32St w -> String
show :: Wasm32St w -> String
$cshowList :: forall w. Show w => [Wasm32St w] -> ShowS
showList :: [Wasm32St w] -> ShowS
Show)

type instance MemOf (Wasm32St w) = IoMem (Wasm32Isa w w) w

defaultStackRoot :: IoMem (Wasm32Isa w w) w -> Int
defaultStackRoot :: forall w. IoMem (Wasm32Isa w w) w -> Int
defaultStackRoot IoMem{mIoCells :: forall isa w. IoMem isa w -> Mem isa w
mIoCells = Mem{Int
memorySize :: Int
memorySize :: forall isa w. Mem isa w -> Int
memorySize}} = (Int
memorySize Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3

setPc :: Int -> State (Wasm32St w) ()
setPc :: forall w. Int -> State (Wasm32St w) ()
setPc Int
addr = (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ())
-> (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall a b. (a -> b) -> a -> b
$ \Wasm32St w
st -> Wasm32St w
st{pc = addr}

nextPc :: Wasm32Isa w w -> State (Wasm32St w) ()
nextPc :: forall w. Wasm32Isa w w -> State (Wasm32St w) ()
nextPc Wasm32Isa w w
instruction = do
    Wasm32St{pc} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    setPc (pc + byteSize instruction)

fetchInstructionAt :: (IsWord w) => Int -> State (Wasm32St w) (Either Text (Wasm32Isa w w))
fetchInstructionAt :: forall w.
IsWord w =>
Int -> State (Wasm32St w) (Either Text (Wasm32Isa w w))
fetchInstructionAt Int
addr = do
    st@Wasm32St{mem, ir} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    case lookup addr ir of
        Just Wasm32Isa w w
instruction -> Either Text (Wasm32Isa w w)
-> StateT (Wasm32St w) Identity (Either Text (Wasm32Isa w w))
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Wasm32Isa w w)
 -> StateT (Wasm32St w) Identity (Either Text (Wasm32Isa w w)))
-> Either Text (Wasm32Isa w w)
-> StateT (Wasm32St w) Identity (Either Text (Wasm32Isa w w))
forall a b. (a -> b) -> a -> b
$ Wasm32Isa w w -> Either Text (Wasm32Isa w w)
forall a b. b -> Either a b
Right Wasm32Isa w w
instruction
        Maybe (Wasm32Isa w w)
Nothing -> case IoMem (Wasm32Isa w w) w
-> Int
-> Either
     Text (IoMem (Wasm32Isa w w) w, NonEmpty (Int, Wasm32Isa w w))
forall isa w.
(ByteSize isa, IsWord w, Memory (Mem isa w) isa w) =>
IoMem isa w
-> Int -> Either Text (IoMem isa w, NonEmpty (Int, isa))
readInstructions IoMem (Wasm32Isa w w) w
mem Int
addr of
            Right (IoMem (Wasm32Isa w w) w
mem', fetched :: NonEmpty (Int, Wasm32Isa w w)
fetched@((Int
_, Wasm32Isa w w
instruction) :| [(Int, Wasm32Isa w w)]
_)) -> do
                Wasm32St w -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Wasm32St w
st{mem = mem', ir = toList fetched}
                Either Text (Wasm32Isa w w)
-> StateT (Wasm32St w) Identity (Either Text (Wasm32Isa w w))
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Wasm32Isa w w)
 -> StateT (Wasm32St w) Identity (Either Text (Wasm32Isa w w)))
-> Either Text (Wasm32Isa w w)
-> StateT (Wasm32St w) Identity (Either Text (Wasm32Isa w w))
forall a b. (a -> b) -> a -> b
$ Wasm32Isa w w -> Either Text (Wasm32Isa w w)
forall a b. b -> Either a b
Right Wasm32Isa w w
instruction
            Left Text
err -> Either Text (Wasm32Isa w w)
-> StateT (Wasm32St w) Identity (Either Text (Wasm32Isa w w))
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Wasm32Isa w w)
 -> StateT (Wasm32St w) Identity (Either Text (Wasm32Isa w w)))
-> Either Text (Wasm32Isa w w)
-> StateT (Wasm32St w) Identity (Either Text (Wasm32Isa w w))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Wasm32Isa w w)
forall a b. a -> Either a b
Left Text
err

raiseInternalError :: Text -> State (Wasm32St w) ()
raiseInternalError :: forall w. Text -> State (Wasm32St w) ()
raiseInternalError Text
msg = (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ())
-> (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall a b. (a -> b) -> a -> b
$ \Wasm32St w
st -> Wasm32St w
st{internalError = Just msg}

getWord :: (IsWord w) => Int -> State (Wasm32St w) w
getWord :: forall w. IsWord w => Int -> State (Wasm32St w) w
getWord Int
addr = do
    st@Wasm32St{mem} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    case readWord mem addr of
        Right (IoMem (Wasm32Isa w w) w
mem', w
w) -> Wasm32St w -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Wasm32St w
st{mem = mem'} StateT (Wasm32St w) Identity ()
-> StateT (Wasm32St w) Identity w -> StateT (Wasm32St w) Identity w
forall a b.
StateT (Wasm32St w) Identity a
-> StateT (Wasm32St w) Identity b -> StateT (Wasm32St w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> w -> StateT (Wasm32St w) Identity w
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return w
w
        Left Text
err -> do
            Text -> StateT (Wasm32St w) Identity ()
forall w. Text -> State (Wasm32St w) ()
raiseInternalError [i|memory access error: #{err}|]
            w -> StateT (Wasm32St w) Identity w
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return w
forall a. Default a => a
def

setWord :: forall w. (IsWord w) => Int -> w -> State (Wasm32St w) ()
setWord :: forall w. IsWord w => Int -> w -> State (Wasm32St w) ()
setWord Int
addr w
w = do
    st@Wasm32St{mem} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    case writeWord mem addr w of
        Right IoMem (Wasm32Isa w w) w
mem' -> Wasm32St w -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Wasm32St w
st{mem = mem'} StateT (Wasm32St w) Identity ()
-> StateT (Wasm32St w) Identity ()
-> StateT (Wasm32St w) Identity ()
forall a b.
StateT (Wasm32St w) Identity a
-> StateT (Wasm32St w) Identity b -> StateT (Wasm32St w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> Maybe w -> StateT (Wasm32St w) Identity ()
forall w.
IsWord w =>
Int -> Int -> Maybe w -> State (Wasm32St w) ()
forgetChangedBranches Int
addr (forall t. ByteSizeT t => Int
byteSizeT @w) (w -> Maybe w
forall a. a -> Maybe a
Just w
w) StateT (Wasm32St w) Identity ()
-> StateT (Wasm32St w) Identity ()
-> StateT (Wasm32St w) Identity ()
forall a b.
StateT (Wasm32St w) Identity a
-> StateT (Wasm32St w) Identity b -> StateT (Wasm32St w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> StateT (Wasm32St w) Identity ()
forall w. IsWord w => Int -> Int -> State (Wasm32St w) ()
forgetTos Int
addr (forall t. ByteSizeT t => Int
byteSizeT @w)
        Left Text
err -> Text -> StateT (Wasm32St w) Identity ()
forall w. Text -> State (Wasm32St w) ()
raiseInternalError [i|memory access error: #{err}|]

getByte :: (IsWord w) => Int -> State (Wasm32St w) Word8
getByte :: forall w. IsWord w => Int -> State (Wasm32St w) Word8
getByte Int
addr = do
    st@Wasm32St{mem} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    case readByte mem addr of
        Right (IoMem (Wasm32Isa w w) w
mem', Word8
b) -> Wasm32St w -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Wasm32St w
st{mem = mem'} StateT (Wasm32St w) Identity ()
-> StateT (Wasm32St w) Identity Word8
-> StateT (Wasm32St w) Identity Word8
forall a b.
StateT (Wasm32St w) Identity a
-> StateT (Wasm32St w) Identity b -> StateT (Wasm32St w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> StateT (Wasm32St w) Identity Word8
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
b
        Left Text
err -> do
            Text -> StateT (Wasm32St w) Identity ()
forall w. Text -> State (Wasm32St w) ()
raiseInternalError [i|memory access error: #{err}|]
            Word8 -> StateT (Wasm32St w) Identity Word8
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
0

setByte :: (IsWord w) => Int -> Word8 -> State (Wasm32St w) ()
setByte :: forall w. IsWord w => Int -> Word8 -> State (Wasm32St w) ()
setByte Int
addr Word8
b = do
    st@Wasm32St{mem} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    case writeByte mem addr b of
        Right IoMem (Wasm32Isa w w) w
mem' -> Wasm32St w -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Wasm32St w
st{mem = mem'} StateT (Wasm32St w) Identity ()
-> StateT (Wasm32St w) Identity ()
-> StateT (Wasm32St w) Identity ()
forall a b.
StateT (Wasm32St w) Identity a
-> StateT (Wasm32St w) Identity b -> StateT (Wasm32St w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> Maybe w -> StateT (Wasm32St w) Identity ()
forall w.
IsWord w =>
Int -> Int -> Maybe w -> State (Wasm32St w) ()
forgetChangedBranches Int
addr Int
1 Maybe w
forall a. Maybe a
Nothing StateT (Wasm32St w) Identity ()
-> StateT (Wasm32St w) Identity ()
-> StateT (Wasm32St w) Identity ()
forall a b.
StateT (Wasm32St w) Identity a
-> StateT (Wasm32St w) Identity b -> StateT (Wasm32St w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> StateT (Wasm32St w) Identity ()
forall w. IsWord w => Int -> Int -> State (Wasm32St w) ()
forgetTos Int
addr Int
1
        Left Text
err -> Text -> StateT (Wasm32St w) Identity ()
forall w. Text -> State (Wasm32St w) ()
raiseInternalError [i|memory access error: #{err}|]

evaluated :: [a] -> [a]
evaluated :: forall a. [a] -> [a]
evaluated [a]
xs = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> [a] -> [a]
forall a b. a -> b -> b
`seq` [a]
xs

-- * Data stack

pushValue :: forall w. (IsWord w) => w -> State (Wasm32St w) ()
pushValue :: forall w. IsWord w => w -> State (Wasm32St w) ()
pushValue w
value = do
    Wasm32St{sp} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    let sp' = Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- forall t. ByteSizeT t => Int
byteSizeT @w
    modify $ \Wasm32St w
st -> Wasm32St w
st{sp = sp'}
    setWord sp' value
    Wasm32St{mem} <- get
    unless (sp' `elem` ioPorts mem) $
        modify $
            \Wasm32St w
st -> Wasm32St w
st{tosRegs = evaluated $ take (tosRegCount st) ((sp', value) : tosRegs st)}

popValue :: forall w. (IsWord w) => State (Wasm32St w) w
popValue :: forall w. IsWord w => State (Wasm32St w) w
popValue = do
    Wasm32St{sp, tosRegs} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    value <- case listToMaybe [v | (addr, v) <- tosRegs, addr == sp] of
        Just w
v -> Int -> Int -> State (Wasm32St w) ()
forall w. IsWord w => Int -> Int -> State (Wasm32St w) ()
forgetTos Int
sp (forall t. ByteSizeT t => Int
byteSizeT @w) State (Wasm32St w) ()
-> StateT (Wasm32St w) Identity w -> StateT (Wasm32St w) Identity w
forall a b.
StateT (Wasm32St w) Identity a
-> StateT (Wasm32St w) Identity b -> StateT (Wasm32St w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> w -> StateT (Wasm32St w) Identity w
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return w
v
        Maybe w
Nothing -> Int -> StateT (Wasm32St w) Identity w
forall w. IsWord w => Int -> State (Wasm32St w) w
getWord Int
sp
    modify $ \Wasm32St w
st -> Wasm32St w
st{sp = sp + byteSizeT @w}
    return value

forgetTos :: forall w. (IsWord w) => Int -> Int -> State (Wasm32St w) ()
forgetTos :: forall w. IsWord w => Int -> Int -> State (Wasm32St w) ()
forgetTos Int
addr Int
size = (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ())
-> (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall a b. (a -> b) -> a -> b
$ \Wasm32St w
st -> Wasm32St w
st{tosRegs = evaluated $ filter (not . overlaps . fst) (tosRegs st)}
    where
        overlaps :: Int -> Bool
overlaps Int
slot = Int
slot Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size Bool -> Bool -> Bool
&& Int
addr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
slot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall t. ByteSizeT t => Int
byteSizeT @w

reserveLocals :: forall w. (IsWord w) => Int -> State (Wasm32St w) ()
reserveLocals :: forall w. IsWord w => Int -> State (Wasm32St w) ()
reserveLocals Int
n = do
    Wasm32St{sp} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    let sp' = Int
sp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall t. ByteSizeT t => Int
byteSizeT @w
    modify $ \Wasm32St w
st ->
        Wasm32St w
st
            { sp = sp'
            , localCount = localCount st + n
            }

localAddr :: forall w. (IsWord w) => Int -> State (Wasm32St w) Int
localAddr :: forall w. IsWord w => Int -> State (Wasm32St w) Int
localAddr Int
idx = do
    Wasm32St{frameBase} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    return $ frameBase - idx * byteSizeT @w

-- * Scan cache

cachedScan :: Int -> State (Wasm32St w) (Either Text Int) -> State (Wasm32St w) (Either Text Int)
cachedScan :: forall w.
Int
-> State (Wasm32St w) (Either Text Int)
-> State (Wasm32St w) (Either Text Int)
cachedScan Int
start State (Wasm32St w) (Either Text Int)
scan = do
    Wasm32St{scanCache} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    result <- maybe scan (return . Right) (listToMaybe [end | (s, end) <- scanCache, s == start])
    whenRight_ result $ \Int
end ->
        (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ())
-> (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall a b. (a -> b) -> a -> b
$ \Wasm32St w
st -> Wasm32St w
st{scanCache = evaluated $ take (scanCacheSize st) ((start, end) : filter ((/= start) . fst) scanCache)}
    return result

-- * Branch cache

-- | A taken @br@ or @br_if@: where it was, the control record it read and
-- that record's words, and where it went.
data BranchEntry w = BranchEntry
    { forall w. BranchEntry w -> Int
beFrom :: Int
    , forall w. BranchEntry w -> Int
beRecord :: Int
    , forall w. BranchEntry w -> [w]
beWords :: [w]
    , forall w. BranchEntry w -> Int
beTo :: Int
    , forall w. BranchEntry w -> Int
beCtrlSp :: Int
    }
    deriving (Int -> BranchEntry w -> ShowS
[BranchEntry w] -> ShowS
BranchEntry w -> String
(Int -> BranchEntry w -> ShowS)
-> (BranchEntry w -> String)
-> ([BranchEntry w] -> ShowS)
-> Show (BranchEntry w)
forall w. Show w => Int -> BranchEntry w -> ShowS
forall w. Show w => [BranchEntry w] -> ShowS
forall w. Show w => BranchEntry w -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall w. Show w => Int -> BranchEntry w -> ShowS
showsPrec :: Int -> BranchEntry w -> ShowS
$cshow :: forall w. Show w => BranchEntry w -> String
show :: BranchEntry w -> String
$cshowList :: forall w. Show w => [BranchEntry w] -> ShowS
showList :: [BranchEntry w] -> ShowS
Show)

cachedBranch :: (IsWord w) => Int -> Int -> State (Wasm32St w) (Maybe (BranchEntry w))
cachedBranch :: forall w.
IsWord w =>
Int -> Int -> State (Wasm32St w) (Maybe (BranchEntry w))
cachedBranch Int
from Int
record = do
    Wasm32St{branchCache} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    let hit = (BranchEntry w -> Bool) -> [BranchEntry w] -> Maybe (BranchEntry w)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\BranchEntry{Int
beFrom :: forall w. BranchEntry w -> Int
beFrom :: Int
beFrom, Int
beRecord :: forall w. BranchEntry w -> Int
beRecord :: Int
beRecord} -> Int
beFrom Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
from Bool -> Bool -> Bool
&& Int
beRecord Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
record) [BranchEntry w]
branchCache
    whenJust hit rememberBranch
    return hit

rememberBranch :: forall w. (IsWord w) => BranchEntry w -> State (Wasm32St w) ()
rememberBranch :: forall w. IsWord w => BranchEntry w -> State (Wasm32St w) ()
rememberBranch entry :: BranchEntry w
entry@BranchEntry{Int
beFrom :: forall w. BranchEntry w -> Int
beFrom :: Int
beFrom, Int
beRecord :: forall w. BranchEntry w -> Int
beRecord :: Int
beRecord} = do
    Wasm32St{mem} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    unless (any (`elem` ioPorts mem) (scopeWordAddrs @w beRecord)) $
        modify $
            \Wasm32St w
st -> Wasm32St w
st{branchCache = evaluated $ take (branchCacheSize st) (entry : filter (not . same) (branchCache st))}
    where
        same :: BranchEntry w -> Bool
same BranchEntry{beFrom :: forall w. BranchEntry w -> Int
beFrom = Int
f, beRecord :: forall w. BranchEntry w -> Int
beRecord = Int
r} = Int
f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
beFrom Bool -> Bool -> Bool
&& Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
beRecord

forgetChangedBranches :: forall w. (IsWord w) => Int -> Int -> Maybe w -> State (Wasm32St w) ()
forgetChangedBranches :: forall w.
IsWord w =>
Int -> Int -> Maybe w -> State (Wasm32St w) ()
forgetChangedBranches Int
addr Int
size Maybe w
value =
    (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ())
-> (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall a b. (a -> b) -> a -> b
$ \Wasm32St w
st -> Wasm32St w
st{branchCache = evaluated $ filter unchanged (branchCache st)}
    where
        unchanged :: BranchEntry w -> Bool
unchanged BranchEntry{Int
beRecord :: forall w. BranchEntry w -> Int
beRecord :: Int
beRecord, [w]
beWords :: forall w. BranchEntry w -> [w]
beWords :: [w]
beWords} = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (Int -> w -> Bool) -> [Int] -> [w] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> w -> Bool
keeps (forall w. IsWord w => Int -> [Int]
scopeWordAddrs @w Int
beRecord) [w]
beWords
        keeps :: Int -> w -> Bool
keeps Int
wordAddr w
old
            | Int
wordAddr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall t. ByteSizeT t => Int
byteSizeT @w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
addr Bool -> Bool -> Bool
|| Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
wordAddr = Bool
True
            | Bool
otherwise = Int
wordAddr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
addr Bool -> Bool -> Bool
&& Maybe w
value Maybe w -> Maybe w -> Bool
forall a. Eq a => a -> a -> Bool
== w -> Maybe w
forall a. a -> Maybe a
Just w
old

-- * Control stack

data Scope
    = LoopScope
        { Scope -> Int
csStart :: Int
        , Scope -> Int
csEnd :: Int
        }
    | BlockScope {csEnd :: Int}
    | CallScope
        { Scope -> Int
csCallerFrameBase :: Int
        , Scope -> Int
csCallerLocalCount :: Int
        , Scope -> Int
csReturnPc :: Int
        , Scope -> Int
csResultCount :: Int
        }
    deriving (Scope -> Scope -> Bool
(Scope -> Scope -> Bool) -> (Scope -> Scope -> Bool) -> Eq Scope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Scope -> Scope -> Bool
== :: Scope -> Scope -> Bool
$c/= :: Scope -> Scope -> Bool
/= :: Scope -> Scope -> Bool
Eq, Int -> Scope -> ShowS
[Scope] -> ShowS
Scope -> String
(Int -> Scope -> ShowS)
-> (Scope -> String) -> ([Scope] -> ShowS) -> Show Scope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Scope -> ShowS
showsPrec :: Int -> Scope -> ShowS
$cshow :: Scope -> String
show :: Scope -> String
$cshowList :: [Scope] -> ShowS
showList :: [Scope] -> ShowS
Show)

data ControlTag = LoopTag | BlockTag | CallTag
    deriving (ControlTag
ControlTag -> ControlTag -> Bounded ControlTag
forall a. a -> a -> Bounded a
$cminBound :: ControlTag
minBound :: ControlTag
$cmaxBound :: ControlTag
maxBound :: ControlTag
Bounded, Int -> ControlTag
ControlTag -> Int
ControlTag -> [ControlTag]
ControlTag -> ControlTag
ControlTag -> ControlTag -> [ControlTag]
ControlTag -> ControlTag -> ControlTag -> [ControlTag]
(ControlTag -> ControlTag)
-> (ControlTag -> ControlTag)
-> (Int -> ControlTag)
-> (ControlTag -> Int)
-> (ControlTag -> [ControlTag])
-> (ControlTag -> ControlTag -> [ControlTag])
-> (ControlTag -> ControlTag -> [ControlTag])
-> (ControlTag -> ControlTag -> ControlTag -> [ControlTag])
-> Enum ControlTag
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 :: ControlTag -> ControlTag
succ :: ControlTag -> ControlTag
$cpred :: ControlTag -> ControlTag
pred :: ControlTag -> ControlTag
$ctoEnum :: Int -> ControlTag
toEnum :: Int -> ControlTag
$cfromEnum :: ControlTag -> Int
fromEnum :: ControlTag -> Int
$cenumFrom :: ControlTag -> [ControlTag]
enumFrom :: ControlTag -> [ControlTag]
$cenumFromThen :: ControlTag -> ControlTag -> [ControlTag]
enumFromThen :: ControlTag -> ControlTag -> [ControlTag]
$cenumFromTo :: ControlTag -> ControlTag -> [ControlTag]
enumFromTo :: ControlTag -> ControlTag -> [ControlTag]
$cenumFromThenTo :: ControlTag -> ControlTag -> ControlTag -> [ControlTag]
enumFromThenTo :: ControlTag -> ControlTag -> ControlTag -> [ControlTag]
Enum, ControlTag -> ControlTag -> Bool
(ControlTag -> ControlTag -> Bool)
-> (ControlTag -> ControlTag -> Bool) -> Eq ControlTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ControlTag -> ControlTag -> Bool
== :: ControlTag -> ControlTag -> Bool
$c/= :: ControlTag -> ControlTag -> Bool
/= :: ControlTag -> ControlTag -> Bool
Eq, Int -> ControlTag -> ShowS
[ControlTag] -> ShowS
ControlTag -> String
(Int -> ControlTag -> ShowS)
-> (ControlTag -> String)
-> ([ControlTag] -> ShowS)
-> Show ControlTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ControlTag -> ShowS
showsPrec :: Int -> ControlTag -> ShowS
$cshow :: ControlTag -> String
show :: ControlTag -> String
$cshowList :: [ControlTag] -> ShowS
showList :: [ControlTag] -> ShowS
Show)

scopeAddrs :: forall w. (IsWord w) => Wasm32St w -> [Int]
scopeAddrs :: forall w. IsWord w => Wasm32St w -> [Int]
scopeAddrs Wasm32St{Int
ctrlSp :: forall w. Wasm32St w -> Int
ctrlSp :: Int
ctrlSp, Int
stackRoot :: forall w. Wasm32St w -> Int
stackRoot :: Int
stackRoot} =
    (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
stackRoot) [Int
ctrlSp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
stride, Int
ctrlSp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
stride ..]
    where
        stride :: Int
stride = forall w. IsWord w => Int
scopeRecordBytes @w

ctrlCorruptedErr :: Int -> Text -> Text
ctrlCorruptedErr :: Int -> Text -> Text
ctrlCorruptedErr Int
addr Text
err = [i|control stack corrupted at #{hexAddr 2 addr}: #{err}|]

pushScope :: forall w. (IsWord w) => Scope -> State (Wasm32St w) ()
pushScope :: forall w. IsWord w => Scope -> State (Wasm32St w) ()
pushScope Scope
scope = do
    Wasm32St{ctrlSp} <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    let step = forall t. ByteSizeT t => Int
byteSizeT @w
        ctrlSp' = Int
ctrlSp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall w. IsWord w => Int
scopeRecordBytes @w
    case packWords scope of
        Left Text
err -> Text -> StateT (Wasm32St w) Identity ()
forall w. Text -> State (Wasm32St w) ()
raiseInternalError [i|control record doesn't fit: #{err}|]
        Right [w]
words_ -> do
            [(Int, w)]
-> ((Int, w) -> StateT (Wasm32St w) Identity ())
-> StateT (Wasm32St w) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [w] -> [(Int, w)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [w]
words_) (((Int, w) -> StateT (Wasm32St w) Identity ())
 -> StateT (Wasm32St w) Identity ())
-> ((Int, w) -> StateT (Wasm32St w) Identity ())
-> StateT (Wasm32St w) Identity ()
forall a b. (a -> b) -> a -> b
$ \(Int
idx, w
w) -> Int -> w -> StateT (Wasm32St w) Identity ()
forall w. IsWord w => Int -> w -> State (Wasm32St w) ()
setWord (Int
ctrlSp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
step) w
w
            (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ())
-> (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall a b. (a -> b) -> a -> b
$ \Wasm32St w
st -> Wasm32St w
st{ctrlSp = ctrlSp'}

retireScopes :: forall w. (IsWord w) => Int -> State (Wasm32St w) ()
retireScopes :: forall w. IsWord w => Int -> State (Wasm32St w) ()
retireScopes Int
n = (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ())
-> (Wasm32St w -> Wasm32St w) -> StateT (Wasm32St w) Identity ()
forall a b. (a -> b) -> a -> b
$ \Wasm32St w
st ->
    Wasm32St w
st{ctrlSp = ctrlSp st - n * scopeRecordBytes @w}

scopeAtDepth :: forall w. (IsWord w) => Int -> State (Wasm32St w) (Maybe (Either Text Scope))
scopeAtDepth :: forall w.
IsWord w =>
Int -> State (Wasm32St w) (Maybe (Either Text Scope))
scopeAtDepth Int
depth = ((Int, [w]) -> Either Text Scope)
-> Maybe (Int, [w]) -> Maybe (Either Text Scope)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, [w]) -> Either Text Scope
forall {c} {w}.
(BitPack c, FiniteBits w, ByteSize w, Default w, Hashable w,
 Read w, WordParts w, FromSign w, Bounded w, Integral w, Show w) =>
(Int, [w]) -> Either Text c
decodeAt (Maybe (Int, [w]) -> Maybe (Either Text Scope))
-> StateT (Wasm32St w) Identity (Maybe (Int, [w]))
-> StateT (Wasm32St w) Identity (Maybe (Either Text Scope))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT (Wasm32St w) Identity (Maybe (Int, [w]))
forall w. IsWord w => Int -> State (Wasm32St w) (Maybe (Int, [w]))
scopeRecordAtDepth Int
depth
    where
        decodeAt :: (Int, [w]) -> Either Text c
decodeAt (Int
addr, [w]
words_) = (Text -> Text) -> Either Text c -> Either Text c
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Int -> Text -> Text
ctrlCorruptedErr Int
addr) ([w] -> Either Text c
forall a w. (BitPack a, IsWord w) => [w] -> Either Text a
unpackWords [w]
words_)

scopeRecordAtDepth :: forall w. (IsWord w) => Int -> State (Wasm32St w) (Maybe (Int, [w]))
scopeRecordAtDepth :: forall w. IsWord w => Int -> State (Wasm32St w) (Maybe (Int, [w]))
scopeRecordAtDepth Int
depth = do
    st <- StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get
    case drop depth (scopeAddrs st) of
        [] -> Maybe (Int, [w]) -> StateT (Wasm32St w) Identity (Maybe (Int, [w]))
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, [w])
forall a. Maybe a
Nothing
        Int
addr : [Int]
_ -> (Int, [w]) -> Maybe (Int, [w])
forall a. a -> Maybe a
Just ((Int, [w]) -> Maybe (Int, [w]))
-> ([w] -> (Int, [w])) -> [w] -> Maybe (Int, [w])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
addr,) ([w] -> Maybe (Int, [w]))
-> StateT (Wasm32St w) Identity [w]
-> StateT (Wasm32St w) Identity (Maybe (Int, [w]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> StateT (Wasm32St w) Identity w)
-> [Int] -> StateT (Wasm32St w) Identity [w]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Int -> StateT (Wasm32St w) Identity w
forall w. IsWord w => Int -> State (Wasm32St w) w
getWord (forall w. IsWord w => Int -> [Int]
scopeWordAddrs @w Int
addr)

innermostCall :: forall w. (IsWord w) => State (Wasm32St w) (Either Text (Int, Scope))
innermostCall :: forall w. IsWord w => State (Wasm32St w) (Either Text (Int, Scope))
innermostCall = StateT (Wasm32St w) Identity (Wasm32St w)
forall s (m :: * -> *). MonadState s m => m s
get StateT (Wasm32St w) Identity (Wasm32St w)
-> (Wasm32St w
    -> StateT (Wasm32St w) Identity (Either Text (Int, Scope)))
-> StateT (Wasm32St w) Identity (Either Text (Int, Scope))
forall a b.
StateT (Wasm32St w) Identity a
-> (a -> StateT (Wasm32St w) Identity b)
-> StateT (Wasm32St w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> StateT (Wasm32St w) Identity (Either Text (Int, Scope))
go ([Int] -> StateT (Wasm32St w) Identity (Either Text (Int, Scope)))
-> (Wasm32St w -> [Int])
-> Wasm32St w
-> StateT (Wasm32St w) Identity (Either Text (Int, Scope))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wasm32St w -> [Int]
forall w. IsWord w => Wasm32St w -> [Int]
scopeAddrs
    where
        go :: [Int] -> StateT (Wasm32St w) Identity (Either Text (Int, Scope))
go [] = Either Text (Int, Scope)
-> StateT (Wasm32St w) Identity (Either Text (Int, Scope))
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Int, Scope)
 -> StateT (Wasm32St w) Identity (Either Text (Int, Scope)))
-> Either Text (Int, Scope)
-> StateT (Wasm32St w) Identity (Either Text (Int, Scope))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Int, Scope)
forall a b. a -> Either a b
Left Text
"return without active function frame"
        go (Int
addr : [Int]
outer) = do
            result <- Int
-> BitGet w (Maybe Scope)
-> State (Wasm32St w) (Either Text (Maybe Scope))
forall w a.
IsWord w =>
Int -> BitGet w a -> State (Wasm32St w) (Either Text a)
readScope Int
addr BitGet w (Maybe Scope)
callGet
            case result of
                Left Text
err -> Either Text (Int, Scope)
-> StateT (Wasm32St w) Identity (Either Text (Int, Scope))
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Int, Scope)
 -> StateT (Wasm32St w) Identity (Either Text (Int, Scope)))
-> Either Text (Int, Scope)
-> StateT (Wasm32St w) Identity (Either Text (Int, Scope))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Int, Scope)
forall a b. a -> Either a b
Left (Text -> Either Text (Int, Scope))
-> Text -> Either Text (Int, Scope)
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
ctrlCorruptedErr Int
addr Text
err
                Right (Just Scope
scope) -> Either Text (Int, Scope)
-> StateT (Wasm32St w) Identity (Either Text (Int, Scope))
forall a. a -> StateT (Wasm32St w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Int, Scope)
 -> StateT (Wasm32St w) Identity (Either Text (Int, Scope)))
-> Either Text (Int, Scope)
-> StateT (Wasm32St w) Identity (Either Text (Int, Scope))
forall a b. (a -> b) -> a -> b
$ (Int, Scope) -> Either Text (Int, Scope)
forall a b. b -> Either a b
Right (Int
addr, Scope
scope)
                Right Maybe Scope
Nothing -> [Int] -> StateT (Wasm32St w) Identity (Either Text (Int, Scope))
go [Int]
outer
        callGet :: BitGet w (Maybe Scope)
callGet = do
            first_@(tag, _, _) <- BitGet w (ControlTag, Int, Int)
forall w. IsWord w => BitGet w (ControlTag, Int, Int)
getRecordHead
            if tag == CallTag then Just <$> getRecordTail first_ else return Nothing

readScope :: forall w a. (IsWord w) => Int -> BitGet w a -> State (Wasm32St w) (Either Text a)
readScope :: forall w a.
IsWord w =>
Int -> BitGet w a -> State (Wasm32St w) (Either Text a)
readScope Int
addr = (Int -> StateT (Wasm32St w) Identity w)
-> BitGet w a -> StateT (Wasm32St w) Identity (Either Text a)
forall w (m :: * -> *) a.
(IsWord w, Monad m) =>
(Int -> m w) -> BitGet w a -> m (Either Text a)
runBitGetWith (\Int
k -> Int -> StateT (Wasm32St w) Identity w
forall w. IsWord w => Int -> State (Wasm32St w) w
getWord (Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall t. ByteSizeT t => Int
byteSizeT @w))

scopeRecordWords :: Int
scopeRecordWords :: Int
scopeRecordWords = Int
2

scopeRecordBytes :: forall w. (IsWord w) => Int
scopeRecordBytes :: forall w. IsWord w => Int
scopeRecordBytes = Int
scopeRecordWords Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall t. ByteSizeT t => Int
byteSizeT @w

scopeWordAddrs :: forall w. (IsWord w) => Int -> [Int]
scopeWordAddrs :: forall w. IsWord w => Int -> [Int]
scopeWordAddrs Int
addr = [Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall t. ByteSizeT t => Int
byteSizeT @w | Int
idx <- [Int
0 .. Int
scopeRecordWords Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

tagBits, addrBits, countBits :: Int
tagBits :: Int
tagBits = Int
2
addrBits :: Int
addrBits = Int
22
countBits :: Int
countBits = Int
8

instance BitPack ControlTag where
    unpack :: forall w. IsWord w => BitGet w ControlTag
unpack = Int -> BitGet w ControlTag
forall e w. (Bounded e, Enum e, IsWord w) => Int -> BitGet w e
getEnum Int
tagBits BitGet w ControlTag -> Text -> BitGet w ControlTag
forall (f :: * -> *) a. Layout f => f a -> Text -> f a
<?> Text
"record kind"
    pack :: forall w. IsWord w => ControlTag -> BitPut w ()
pack ControlTag
tag = Int -> ControlTag -> BitPut w ()
forall e w. (Enum e, IsWord w) => Int -> e -> BitPut w ()
putEnum Int
tagBits ControlTag
tag BitPut w () -> Text -> BitPut w ()
forall (f :: * -> *) a. Layout f => f a -> Text -> f a
<?> Text
"record kind"

instance BitPack Scope where
    unpack :: forall w. IsWord w => BitGet w Scope
unpack = BitGet w (ControlTag, Int, Int)
forall w. IsWord w => BitGet w (ControlTag, Int, Int)
getRecordHead BitGet w (ControlTag, Int, Int)
-> ((ControlTag, Int, Int) -> BitGet w Scope) -> BitGet w Scope
forall a b. BitGet w a -> (a -> BitGet w b) -> BitGet w b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ControlTag, Int, Int) -> BitGet w Scope
forall w. IsWord w => (ControlTag, Int, Int) -> BitGet w Scope
getRecordTail
    pack :: forall w. IsWord w => Scope -> BitPut w ()
pack BlockScope{Int
csEnd :: Scope -> Int
csEnd :: Int
csEnd} = do
        BitPut w () -> BitPut w ()
forall a. BitPut w a -> BitPut w a
forall (f :: * -> *) a. Layout f => f a -> f a
word (BitPut w () -> BitPut w ()) -> BitPut w () -> BitPut w ()
forall a b. (a -> b) -> a -> b
$ do
            ControlTag -> BitPut w ()
forall w. IsWord w => ControlTag -> BitPut w ()
forall a w. (BitPack a, IsWord w) => a -> BitPut w ()
pack ControlTag
BlockTag
            Int -> BitPut w ()
forall w. IsWord w => Int -> BitPut w ()
putPad Int
countBits
            Int -> Int -> BitPut w ()
forall w. IsWord w => Int -> Int -> BitPut w ()
putField Int
addrBits Int
csEnd BitPut w () -> Text -> BitPut w ()
forall (f :: * -> *) a. Layout f => f a -> Text -> f a
<?> Text
"csEnd"
        BitPut w () -> BitPut w ()
forall a. BitPut w a -> BitPut w a
forall (f :: * -> *) a. Layout f => f a -> f a
word (BitPut w () -> BitPut w ()) -> BitPut w () -> BitPut w ()
forall a b. (a -> b) -> a -> b
$ Int -> BitPut w ()
forall w. IsWord w => Int -> BitPut w ()
putPad Int
32
    pack LoopScope{Int
csStart :: Scope -> Int
csStart :: Int
csStart, Int
csEnd :: Scope -> Int
csEnd :: Int
csEnd} = do
        BitPut w () -> BitPut w ()
forall a. BitPut w a -> BitPut w a
forall (f :: * -> *) a. Layout f => f a -> f a
word (BitPut w () -> BitPut w ()) -> BitPut w () -> BitPut w ()
forall a b. (a -> b) -> a -> b
$ do
            ControlTag -> BitPut w ()
forall w. IsWord w => ControlTag -> BitPut w ()
forall a w. (BitPack a, IsWord w) => a -> BitPut w ()
pack ControlTag
LoopTag
            Int -> BitPut w ()
forall w. IsWord w => Int -> BitPut w ()
putPad Int
countBits
            Int -> Int -> BitPut w ()
forall w. IsWord w => Int -> Int -> BitPut w ()
putField Int
addrBits Int
csStart BitPut w () -> Text -> BitPut w ()
forall (f :: * -> *) a. Layout f => f a -> Text -> f a
<?> Text
"csStart"
        BitPut w () -> BitPut w ()
forall a. BitPut w a -> BitPut w a
forall (f :: * -> *) a. Layout f => f a -> f a
word (BitPut w () -> BitPut w ()) -> BitPut w () -> BitPut w ()
forall a b. (a -> b) -> a -> b
$ do
            Int -> BitPut w ()
forall w. IsWord w => Int -> BitPut w ()
putPad Int
10
            Int -> Int -> BitPut w ()
forall w. IsWord w => Int -> Int -> BitPut w ()
putField Int
addrBits Int
csEnd BitPut w () -> Text -> BitPut w ()
forall (f :: * -> *) a. Layout f => f a -> Text -> f a
<?> Text
"csEnd"
    pack CallScope{Int
csCallerFrameBase :: Scope -> Int
csCallerFrameBase :: Int
csCallerFrameBase, Int
csCallerLocalCount :: Scope -> Int
csCallerLocalCount :: Int
csCallerLocalCount, Int
csReturnPc :: Scope -> Int
csReturnPc :: Int
csReturnPc, Int
csResultCount :: Scope -> Int
csResultCount :: Int
csResultCount} = do
        BitPut w () -> BitPut w ()
forall a. BitPut w a -> BitPut w a
forall (f :: * -> *) a. Layout f => f a -> f a
word (BitPut w () -> BitPut w ()) -> BitPut w () -> BitPut w ()
forall a b. (a -> b) -> a -> b
$ do
            ControlTag -> BitPut w ()
forall w. IsWord w => ControlTag -> BitPut w ()
forall a w. (BitPack a, IsWord w) => a -> BitPut w ()
pack ControlTag
CallTag
            Int -> Int -> BitPut w ()
forall w. IsWord w => Int -> Int -> BitPut w ()
putField Int
countBits Int
csCallerLocalCount BitPut w () -> Text -> BitPut w ()
forall (f :: * -> *) a. Layout f => f a -> Text -> f a
<?> Text
"csCallerLocalCount"
            Int -> Int -> BitPut w ()
forall w. IsWord w => Int -> Int -> BitPut w ()
putField Int
addrBits Int
csCallerFrameBase BitPut w () -> Text -> BitPut w ()
forall (f :: * -> *) a. Layout f => f a -> Text -> f a
<?> Text
"csCallerFrameBase"
        BitPut w () -> BitPut w ()
forall a. BitPut w a -> BitPut w a
forall (f :: * -> *) a. Layout f => f a -> f a
word (BitPut w () -> BitPut w ()) -> BitPut w () -> BitPut w ()
forall a b. (a -> b) -> a -> b
$ do
            Int -> BitPut w ()
forall w. IsWord w => Int -> BitPut w ()
putPad Int
2
            Int -> Int -> BitPut w ()
forall w. IsWord w => Int -> Int -> BitPut w ()
putField Int
countBits Int
csResultCount BitPut w () -> Text -> BitPut w ()
forall (f :: * -> *) a. Layout f => f a -> Text -> f a
<?> Text
"csResultCount"
            Int -> Int -> BitPut w ()
forall w. IsWord w => Int -> Int -> BitPut w ()
putField Int
addrBits Int
csReturnPc BitPut w () -> Text -> BitPut w ()
forall (f :: * -> *) a. Layout f => f a -> Text -> f a
<?> Text
"csReturnPc"

getRecordHead :: (IsWord w) => BitGet w (ControlTag, Int, Int)
getRecordHead :: forall w. IsWord w => BitGet w (ControlTag, Int, Int)
getRecordHead = BitGet w (ControlTag, Int, Int) -> BitGet w (ControlTag, Int, Int)
forall a. BitGet w a -> BitGet w a
forall (f :: * -> *) a. Layout f => f a -> f a
word (BitGet w (ControlTag, Int, Int)
 -> BitGet w (ControlTag, Int, Int))
-> BitGet w (ControlTag, Int, Int)
-> BitGet w (ControlTag, Int, Int)
forall a b. (a -> b) -> a -> b
$ do
    tag <- BitGet w ControlTag
forall w. IsWord w => BitGet w ControlTag
forall a w. (BitPack a, IsWord w) => BitGet w a
unpack
    count <- getField countBits
    addr <- getField addrBits
    return (tag, count, addr)

getRecordTail :: (IsWord w) => (ControlTag, Int, Int) -> BitGet w Scope
getRecordTail :: forall w. IsWord w => (ControlTag, Int, Int) -> BitGet w Scope
getRecordTail (ControlTag
tag, Int
count, Int
addr) = case ControlTag
tag of
    ControlTag
BlockTag -> do
        BitGet w () -> BitGet w ()
forall a. BitGet w a -> BitGet w a
forall (f :: * -> *) a. Layout f => f a -> f a
word (BitGet w () -> BitGet w ()) -> BitGet w () -> BitGet w ()
forall a b. (a -> b) -> a -> b
$ Int -> BitGet w ()
forall w. IsWord w => Int -> BitGet w ()
getPad Int
32
        Scope -> BitGet w Scope
forall a. a -> BitGet w a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockScope{csEnd :: Int
csEnd = Int
addr}
    ControlTag
LoopTag -> do
        csEnd <- BitGet w Int -> BitGet w Int
forall a. BitGet w a -> BitGet w a
forall (f :: * -> *) a. Layout f => f a -> f a
word (BitGet w Int -> BitGet w Int) -> BitGet w Int -> BitGet w Int
forall a b. (a -> b) -> a -> b
$ do
            Int -> BitGet w ()
forall w. IsWord w => Int -> BitGet w ()
getPad Int
10
            Int -> BitGet w Int
forall w. IsWord w => Int -> BitGet w Int
getField Int
addrBits
        return LoopScope{csStart = addr, csEnd}
    ControlTag
CallTag -> do
        (csResultCount, csReturnPc) <- BitGet w (Int, Int) -> BitGet w (Int, Int)
forall a. BitGet w a -> BitGet w a
forall (f :: * -> *) a. Layout f => f a -> f a
word (BitGet w (Int, Int) -> BitGet w (Int, Int))
-> BitGet w (Int, Int) -> BitGet w (Int, Int)
forall a b. (a -> b) -> a -> b
$ do
            Int -> BitGet w ()
forall w. IsWord w => Int -> BitGet w ()
getPad Int
2
            resultCount <- Int -> BitGet w Int
forall w. IsWord w => Int -> BitGet w Int
getField Int
countBits
            returnPc <- getField addrBits
            return (resultCount, returnPc)
        return CallScope{csCallerFrameBase = addr, csCallerLocalCount = count, csReturnPc, csResultCount}