mirror of
https://github.com/grin-compiler/grin.git
synced 2024-10-26 16:51:12 +03:00
add missing file: Dataflow IR binary serializer
This commit is contained in:
parent
ab18051a83
commit
332d12fd65
242
grin/src/AbstractInterpretation/BinaryIR.hs
Normal file
242
grin/src/AbstractInterpretation/BinaryIR.hs
Normal file
@ -0,0 +1,242 @@
|
||||
{-# LANGUAGE LambdaCase, RecordWildCards #-}
|
||||
module AbstractInterpretation.BinaryIR (encodeAbstractProgram) where
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.ByteString.Builder
|
||||
|
||||
import AbstractInterpretation.IR
|
||||
|
||||
data Env
|
||||
= Env
|
||||
{ envTagSets :: ![Set Tag]
|
||||
, envTagSetCount :: !Int
|
||||
, envInstCount :: !Int -- program / if has effect on this
|
||||
, envBlocks :: ![(Int,Int)]
|
||||
, envBlockCount :: !Int
|
||||
, envBuilder :: !Builder
|
||||
, envBuilderSuffix :: !Builder
|
||||
}
|
||||
|
||||
emptyEnv = Env
|
||||
{ envTagSets = []
|
||||
, envTagSetCount = 0
|
||||
, envInstCount = 0
|
||||
, envBlocks = []
|
||||
, envBlockCount = 0
|
||||
, envBuilder = mempty
|
||||
, envBuilderSuffix = mempty
|
||||
}
|
||||
|
||||
type W = State Env
|
||||
|
||||
emit :: Builder -> W ()
|
||||
emit b = modify' $ \env@Env{..} -> env {envBuilder = envBuilder <> b}
|
||||
|
||||
writeI32 :: Int32 -> W ()
|
||||
writeI32 i = emit $ int32LE i
|
||||
|
||||
writeW32 :: Word32 -> W ()
|
||||
writeW32 w = emit $ word32LE w
|
||||
|
||||
writeReg :: Reg -> W ()
|
||||
writeReg (Reg r) = writeW32 r
|
||||
|
||||
writeMem :: Mem -> W ()
|
||||
writeMem (Mem m) = writeW32 m
|
||||
|
||||
writeTagSet :: Set Tag -> W ()
|
||||
writeTagSet s = do
|
||||
idx <- gets envTagSetCount
|
||||
modify' $ \env@Env{..} -> env {envTagSets = envTagSets ++ [s], envTagSetCount = succ idx}
|
||||
writeI32 $ fromIntegral idx
|
||||
|
||||
writeBlock :: [Instruction] -> W ()
|
||||
writeBlock il = do
|
||||
let size = length il
|
||||
iCount <- gets envInstCount
|
||||
bCount <- gets envBlockCount
|
||||
modify' $ \env@Env{..} -> env {envInstCount = iCount + size, envBlockCount = succ bCount, envBlocks = envBlocks ++ [(iCount, size)]}
|
||||
writeI32 $ fromIntegral bCount
|
||||
currentBuilder <- gets envBuilder
|
||||
modify' $ \env@Env{..} -> env {envBuilder = mempty}
|
||||
mapM_ writeInstruction il
|
||||
blockBuilder <- gets envBuilder
|
||||
modify' $ \env@Env{..} -> env {envBuilder = currentBuilder, envBuilderSuffix = envBuilderSuffix <> blockBuilder}
|
||||
|
||||
-----------------------------------
|
||||
|
||||
writeRange :: Range -> W ()
|
||||
writeRange Range{..} = do
|
||||
writeI32 from
|
||||
writeI32 to
|
||||
|
||||
writeType :: Int32 -> W ()
|
||||
writeType = writeI32
|
||||
|
||||
writeTag :: Tag -> W ()
|
||||
writeTag (Tag w) = writeW32 w
|
||||
|
||||
writePredicate :: Predicate -> W ()
|
||||
writePredicate = \case
|
||||
TagIn s -> do
|
||||
writeType 100
|
||||
writeTagSet s
|
||||
TagNotIn s -> do
|
||||
writeType 101
|
||||
writeTagSet s
|
||||
ValueIn r -> do
|
||||
writeType 102
|
||||
writeRange r
|
||||
ValueNotIn r -> do
|
||||
writeType 103
|
||||
writeRange r
|
||||
|
||||
writeCondition :: Condition -> W ()
|
||||
writeCondition = \case
|
||||
NodeTypeExists t -> do
|
||||
writeType 200
|
||||
writeTag t
|
||||
SimpleTypeExists st -> do
|
||||
writeType 201
|
||||
writeI32 st
|
||||
AnyNotIn s -> do
|
||||
writeType 202
|
||||
writeTagSet s
|
||||
Any p -> do
|
||||
writeType 203
|
||||
writePredicate p
|
||||
|
||||
writeSelector :: Selector -> W ()
|
||||
writeSelector = \case
|
||||
NodeItem t i -> do
|
||||
writeType 300
|
||||
writeTag t
|
||||
writeI32 $ fromIntegral i
|
||||
ConditionAsSelector c -> do
|
||||
writeType 301
|
||||
writeCondition c
|
||||
AllFields -> do
|
||||
writeType 302
|
||||
|
||||
writeConstant :: Constant -> W ()
|
||||
writeConstant = \case
|
||||
CSimpleType st -> do
|
||||
writeType 400
|
||||
writeI32 st
|
||||
CHeapLocation m -> do
|
||||
writeType 401
|
||||
writeMem m
|
||||
CNodeType t a -> do
|
||||
writeType 402
|
||||
writeTag t
|
||||
writeI32 $ fromIntegral a
|
||||
CNodeItem t i v -> do
|
||||
writeType 403
|
||||
writeTag t
|
||||
writeI32 $ fromIntegral i
|
||||
writeI32 v
|
||||
|
||||
writeInstruction :: Instruction -> W ()
|
||||
writeInstruction = \case
|
||||
If {..} -> do
|
||||
writeType 500
|
||||
writeCondition condition
|
||||
writeReg srcReg
|
||||
writeBlock instructions
|
||||
Project {..} -> do
|
||||
writeType 501
|
||||
writeSelector srcSelector
|
||||
writeReg srcReg
|
||||
writeReg dstReg
|
||||
Extend {..} -> do
|
||||
writeType 502
|
||||
writeReg srcReg
|
||||
writeSelector dstSelector
|
||||
writeReg dstReg
|
||||
Move {..} -> do
|
||||
writeType 503
|
||||
writeReg srcReg
|
||||
writeReg dstReg
|
||||
RestrictedMove {..} -> do
|
||||
writeType 504
|
||||
writeReg srcReg
|
||||
writeReg dstReg
|
||||
ConditionalMove {..} -> do
|
||||
writeType 505
|
||||
writeReg srcReg
|
||||
writePredicate predicate
|
||||
writeReg dstReg
|
||||
Fetch {..} -> do
|
||||
writeType 506
|
||||
writeReg addressReg
|
||||
writeReg dstReg
|
||||
Store {..} -> do
|
||||
writeType 507
|
||||
writeReg srcReg
|
||||
writeMem address
|
||||
Update {..} -> do
|
||||
writeType 508
|
||||
writeReg srcReg
|
||||
writeReg addressReg
|
||||
RestrictedUpdate {..} -> do
|
||||
writeType 509
|
||||
writeReg srcReg
|
||||
writeReg addressReg
|
||||
ConditionalUpdate {..} -> do
|
||||
writeType 510
|
||||
writeReg srcReg
|
||||
writePredicate predicate
|
||||
writeReg addressReg
|
||||
Set {..} -> do
|
||||
writeType 511
|
||||
writeReg dstReg
|
||||
writeConstant constant
|
||||
|
||||
{-
|
||||
memory count i32
|
||||
register count i32
|
||||
start block id i32
|
||||
cmd count i32
|
||||
cmds ...
|
||||
block count i32
|
||||
blocks (ranges) ...
|
||||
intset count i32
|
||||
set size i32
|
||||
set elems ... [i32]
|
||||
-}
|
||||
|
||||
encodeAbstractProgram :: AbstractProgram -> LBS.ByteString
|
||||
encodeAbstractProgram AbstractProgram {..} = toLazyByteString (envBuilder env) where
|
||||
env = flip execState emptyEnv $ do
|
||||
writeW32 _absMemoryCounter
|
||||
writeW32 _absRegisterCounter
|
||||
|
||||
-- start block id
|
||||
writeBlock _absInstructions
|
||||
|
||||
-- commands
|
||||
cmdCount <- gets envInstCount
|
||||
writeI32 $ fromIntegral cmdCount
|
||||
cmdsBin <- gets envBuilderSuffix
|
||||
emit cmdsBin
|
||||
|
||||
-- bocks
|
||||
blkCount <- gets envBlockCount
|
||||
writeI32 $ fromIntegral blkCount
|
||||
blocks <- gets envBlocks
|
||||
forM_ blocks $ \(a,b) -> do
|
||||
writeI32 $ fromIntegral a
|
||||
writeI32 $ fromIntegral b
|
||||
|
||||
-- intsets
|
||||
setCount <- gets envTagSetCount
|
||||
writeI32 $ fromIntegral setCount
|
||||
sets <- gets envTagSets
|
||||
forM_ sets $ \s -> do
|
||||
writeI32 $ fromIntegral $ Set.size s
|
||||
forM_ (Set.toList s) (\(Tag t) -> writeI32 $ fromIntegral t)
|
Loading…
Reference in New Issue
Block a user