Compare commits
1 Commits
main
...
gm-visuali
| Author | SHA1 | Date | |
|---|---|---|---|
|
f01164bf01 |
@@ -74,6 +74,11 @@ options = RLPCOptions
|
||||
<> metavar "rlp|core"
|
||||
<> help "the language to be compiled -- see README"
|
||||
)
|
||||
<*> flag False True
|
||||
( long "render"
|
||||
<> short 'r'
|
||||
<> help "render a diagram of each GM state"
|
||||
)
|
||||
<*> some (argument str $ metavar "FILES...")
|
||||
where
|
||||
infixr 9 #
|
||||
|
||||
@@ -22,6 +22,9 @@ library
|
||||
exposed-modules: Core
|
||||
, TI
|
||||
, GM
|
||||
, GM.Visual
|
||||
, GM.Types
|
||||
, GM.Print
|
||||
, Compiler.RLPC
|
||||
, Compiler.RlpcError
|
||||
, Compiler.JustRun
|
||||
@@ -73,6 +76,9 @@ library
|
||||
, effectful-core ^>=2.3.0.0
|
||||
, deriving-compat ^>=0.6.0
|
||||
, these >=0.2 && <2.0
|
||||
, diagrams
|
||||
, diagrams-lib
|
||||
, diagrams-cairo
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: GHC2021
|
||||
|
||||
@@ -120,6 +120,7 @@ data RLPCOptions = RLPCOptions
|
||||
, _rlpcEvaluator :: Evaluator
|
||||
, _rlpcHeapTrigger :: Int
|
||||
, _rlpcLanguage :: Maybe Language
|
||||
, _rlpcRender :: Bool
|
||||
, _rlpcInputFiles :: [FilePath]
|
||||
}
|
||||
deriving Show
|
||||
@@ -141,6 +142,7 @@ instance Default RLPCOptions where
|
||||
, _rlpcHeapTrigger = 200
|
||||
, _rlpcInputFiles = []
|
||||
, _rlpcLanguage = Nothing
|
||||
, _rlpcRender = False
|
||||
}
|
||||
|
||||
-- debug flags are passed with -dFLAG
|
||||
|
||||
311
src/GM.hs
311
src/GM.hs
@@ -11,6 +11,11 @@ module GM
|
||||
, evalProgR
|
||||
, GmState(..)
|
||||
, gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
|
||||
, stsReductions
|
||||
, stsPrimReductions
|
||||
, stsAllocations
|
||||
, stsDereferences
|
||||
, stsGCCycles
|
||||
, Node(..)
|
||||
, showState
|
||||
, gmEvalProg
|
||||
@@ -29,10 +34,9 @@ import Data.Tuple (swap)
|
||||
import Control.Lens
|
||||
import Data.Text.Lens (IsText, packed, unpacked)
|
||||
import Text.Printf
|
||||
import Text.PrettyPrint hiding ((<>))
|
||||
import Text.PrettyPrint.HughesPJ (maybeParens)
|
||||
import Data.Foldable (traverse_)
|
||||
import System.IO (Handle, hPutStrLn)
|
||||
import Text.PrettyPrint (render)
|
||||
-- TODO: an actual output system
|
||||
-- TODO: an actual output system
|
||||
-- TODO: an actual output system
|
||||
@@ -41,9 +45,12 @@ import System.IO.Unsafe (unsafePerformIO)
|
||||
import Data.String (IsString)
|
||||
import Data.Heap
|
||||
import Debug.Trace
|
||||
|
||||
import Compiler.RLPC
|
||||
import Core2Core
|
||||
import Core
|
||||
import GM.Types
|
||||
import GM.Print
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
tag_Unit_unit :: Int
|
||||
@@ -55,105 +62,19 @@ tag_Bool_True = 1
|
||||
tag_Bool_False :: Int
|
||||
tag_Bool_False = 0
|
||||
|
||||
{-}
|
||||
|
||||
hdbgProg = undefined
|
||||
evalProg = undefined
|
||||
|
||||
data Node = NNum Int
|
||||
| NAp Addr Addr
|
||||
| NInd Addr
|
||||
| NUninitialised
|
||||
| NConstr Tag [Addr] -- NConstr Tag Components
|
||||
| NMarked Node
|
||||
deriving (Show, Eq)
|
||||
|
||||
--}
|
||||
|
||||
data GmState = GmState
|
||||
{ _gmCode :: Code
|
||||
, _gmStack :: Stack
|
||||
, _gmDump :: Dump
|
||||
, _gmHeap :: GmHeap
|
||||
, _gmEnv :: Env
|
||||
, _gmStats :: Stats
|
||||
}
|
||||
deriving Show
|
||||
|
||||
type Code = [Instr]
|
||||
type Stack = [Addr]
|
||||
type Dump = [(Code, Stack)]
|
||||
type Env = [(Key, Addr)]
|
||||
type GmHeap = Heap Node
|
||||
|
||||
data Key = NameKey Name
|
||||
| ConstrKey Tag Int
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- >> [ref/Instr]
|
||||
data Instr = Unwind
|
||||
| PushGlobal Name
|
||||
| PushConstr Tag Int
|
||||
| PushInt Int
|
||||
| Push Int
|
||||
| MkAp
|
||||
| Slide Int
|
||||
| Update Int
|
||||
| Pop Int
|
||||
| Alloc Int
|
||||
| Eval
|
||||
-- arith
|
||||
| Neg | Add | Sub | Mul | Div
|
||||
-- comparison
|
||||
| Equals | Lesser | GreaterEq
|
||||
| Pack Tag Int -- Pack Tag Arity
|
||||
| CaseJump [(Tag, Code)]
|
||||
| Split Int
|
||||
| Print
|
||||
| Halt
|
||||
deriving (Show, Eq)
|
||||
-- << [ref/Instr]
|
||||
|
||||
data Node = NNum Int
|
||||
| NAp Addr Addr
|
||||
-- NGlobal is the GM equivalent of NSupercomb. rather than storing a
|
||||
-- template to be instantiated, NGlobal holds the global's arity and
|
||||
-- the pre-compiled code :3
|
||||
| NGlobal Int Code
|
||||
| NInd Addr
|
||||
| NUninitialised
|
||||
| NConstr Tag [Addr] -- NConstr Tag Components
|
||||
| NMarked Node
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- TODO: log executed instructions
|
||||
data Stats = Stats
|
||||
{ _stsReductions :: Int
|
||||
, _stsPrimReductions :: Int
|
||||
, _stsAllocations :: Int
|
||||
, _stsDereferences :: Int
|
||||
, _stsGCCycles :: Int
|
||||
}
|
||||
deriving Show
|
||||
|
||||
instance Default Stats where
|
||||
def = Stats 0 0 0 0 0
|
||||
|
||||
-- TODO: _gmGlobals should not have a setter
|
||||
makeLenses ''GmState
|
||||
makeLenses ''Stats
|
||||
pure []
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
evalProg :: Program' -> Maybe (Node, Stats)
|
||||
evalProg p = res <&> (,sts)
|
||||
where
|
||||
final = eval (compile p) & last
|
||||
h = final ^. gmHeap
|
||||
sts = final ^. gmStats
|
||||
resAddr = final ^. gmStack ^? _head
|
||||
res = resAddr >>= flip hLookup h
|
||||
evalProg :: Program' -> [GmState]
|
||||
evalProg = eval . compile
|
||||
|
||||
-- evalProg :: Program' -> Maybe (Node, Stats)
|
||||
-- evalProg p = res <&> (,sts)
|
||||
-- where
|
||||
-- final = eval (compile p) & last
|
||||
-- h = final ^. gmHeap
|
||||
-- sts = final ^. gmStats
|
||||
-- resAddr = final ^. gmStack ^? _head
|
||||
-- res = resAddr >>= flip hLookup h
|
||||
|
||||
hdbgProg :: Program' -> Handle -> IO GmState
|
||||
hdbgProg p hio = do
|
||||
@@ -815,185 +736,8 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
|
||||
argOffset :: Int -> Env -> Env
|
||||
argOffset n = each . _2 %~ (+n)
|
||||
|
||||
showCon :: (IsText a) => Tag -> Int -> a
|
||||
showCon t n = printf "Pack{%d %d}" t n ^. packed
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
pprTabstop :: Int
|
||||
pprTabstop = 4
|
||||
|
||||
qquotes :: Doc -> Doc
|
||||
qquotes d = "`" <> d <> "'"
|
||||
|
||||
showStats :: Stats -> Doc
|
||||
showStats sts = "==== Stats ============" $$ stats
|
||||
where
|
||||
stats = text $ printf
|
||||
"Reductions : %5d\n\
|
||||
\Prim Reductions : %5d\n\
|
||||
\Allocations : %5d\n\
|
||||
\GC Cycles : %5d"
|
||||
(sts ^. stsReductions)
|
||||
(sts ^. stsPrimReductions)
|
||||
(sts ^. stsAllocations)
|
||||
(sts ^. stsGCCycles)
|
||||
|
||||
showState :: GmState -> Doc
|
||||
showState st = vcat
|
||||
[ "==== GmState " <> int stnum <> " "
|
||||
<> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
|
||||
, "-- Next instructions -------"
|
||||
, info $ showCodeShort c
|
||||
, "-- Stack -------------------"
|
||||
, info $ showStack st
|
||||
, "-- Heap --------------------"
|
||||
, info $ showHeap st
|
||||
, "-- Dump --------------------"
|
||||
, info $ showDump st
|
||||
]
|
||||
where
|
||||
stnum = st ^. (gmStats . stsReductions)
|
||||
c = st ^. gmCode
|
||||
|
||||
-- indent data
|
||||
info = nest pprTabstop
|
||||
|
||||
showCodeShort :: Code -> Doc
|
||||
showCodeShort c = braces c'
|
||||
where
|
||||
c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
|
||||
| otherwise = list (showInstr <$> c)
|
||||
list = hcat . punctuate "; "
|
||||
|
||||
showStackShort :: Stack -> Doc
|
||||
showStackShort s = brackets s'
|
||||
where
|
||||
-- no access to heap, otherwise we'd use showNodeAt
|
||||
s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
|
||||
| otherwise = list (showEntry <$> s)
|
||||
list = hcat . punctuate ", "
|
||||
showEntry = text . show
|
||||
|
||||
showStack :: GmState -> Doc
|
||||
showStack st = vcat $ uncurry showEntry <$> si
|
||||
where
|
||||
h = st ^. gmHeap
|
||||
s = st ^. gmStack
|
||||
|
||||
-- stack with labeled indices
|
||||
si = [0..] `zip` s
|
||||
|
||||
w = maxWidth (addresses h)
|
||||
showIndex n = padInt w n <> ": "
|
||||
|
||||
showEntry :: Int -> Addr -> Doc
|
||||
showEntry n a = showIndex n <> showNodeAt st a
|
||||
|
||||
showDump :: GmState -> Doc
|
||||
showDump st = vcat $ uncurry showEntry <$> di
|
||||
where
|
||||
d = st ^. gmDump
|
||||
di = [0..] `zip` d
|
||||
|
||||
showIndex n = padInt w n <> ": "
|
||||
w = maxWidth (fst <$> di)
|
||||
|
||||
showEntry :: Int -> (Code, Stack) -> Doc
|
||||
showEntry n (c,s) = showIndex n <> nest pprTabstop entry
|
||||
where
|
||||
entry = ("Stack : " <> showCodeShort c)
|
||||
$$ ("Code : " <> showStackShort s)
|
||||
|
||||
padInt :: Int -> Int -> Doc
|
||||
padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
|
||||
|
||||
maxWidth :: [Int] -> Int
|
||||
maxWidth ns = digitalWidth $ maximum ns
|
||||
|
||||
digitalWidth :: Int -> Int
|
||||
digitalWidth = length . show
|
||||
|
||||
showHeap :: GmState -> Doc
|
||||
showHeap st = vcat $ showEntry <$> addrs
|
||||
where
|
||||
showAddr n = padInt w n <> ": "
|
||||
|
||||
w = maxWidth addrs
|
||||
h = st ^. gmHeap
|
||||
addrs = addresses h
|
||||
|
||||
showEntry :: Addr -> Doc
|
||||
showEntry a = showAddr a <> showNodeAt st a
|
||||
|
||||
showNodeAt :: GmState -> Addr -> Doc
|
||||
showNodeAt = showNodeAtP 0
|
||||
|
||||
showNodeAtP :: Int -> GmState -> Addr -> Doc
|
||||
showNodeAtP p st a = case hLookup a h of
|
||||
Just (NNum n) -> int n <> "#"
|
||||
Just (NGlobal _ _) -> textt name
|
||||
where
|
||||
g = st ^. gmEnv
|
||||
name = case lookup a (swap <$> g) of
|
||||
Just (NameKey n) -> n
|
||||
Just (ConstrKey t n) -> showCon t n
|
||||
_ -> errTxtInvalidAddress
|
||||
-- TODO: left-associativity
|
||||
Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f
|
||||
<+> showNodeAtP (p+1) st x
|
||||
Just (NInd a') -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
|
||||
Just (NConstr t as) -> pprec $ "NConstr"
|
||||
<+> int t
|
||||
<+> brackets (list $ showNodeAtP 0 st <$> as)
|
||||
where list = hcat . punctuate ", "
|
||||
Just NUninitialised -> "<uninitialised>"
|
||||
Nothing -> errTxtInvalidAddress
|
||||
where
|
||||
h = st ^. gmHeap
|
||||
pprec = maybeParens (p > 0)
|
||||
|
||||
showSc :: GmState -> (Name, Addr) -> Doc
|
||||
showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
|
||||
$$ code
|
||||
where
|
||||
code = case hLookup a (st ^. gmHeap) of
|
||||
Just (NGlobal _ c) -> showCode c
|
||||
Just _ -> errTxtInvalidObject
|
||||
Nothing -> errTxtInvalidAddress
|
||||
|
||||
errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
|
||||
errTxtInvalidObject = "<invalid object>"
|
||||
errTxtInvalidAddress = "<invalid address>"
|
||||
|
||||
showCode :: Code -> Doc
|
||||
showCode c = "Code" <+> braces instrs
|
||||
where instrs = vcat $ showInstr <$> c
|
||||
|
||||
showInstr :: Instr -> Doc
|
||||
showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
|
||||
where
|
||||
showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
|
||||
alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
|
||||
showInstr i = text $ show i
|
||||
|
||||
textt :: (IsText a) => a -> Doc
|
||||
textt t = t ^. unpacked & text
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
lookupN :: Name -> Env -> Maybe Addr
|
||||
lookupN k = lookup (NameKey k)
|
||||
|
||||
lookupC :: Tag -> Int -> Env -> Maybe Addr
|
||||
lookupC t n = lookup (ConstrKey t n)
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
gc :: GmState -> GmState
|
||||
gc st = (sweepNodes . markNodes $ st)
|
||||
& gmStats . stsGCCycles %~ succ
|
||||
|
||||
markNodes :: GmState -> GmState
|
||||
markNodes st = st & gmHeap %~ thread (markFrom <$> roots)
|
||||
where
|
||||
@@ -1036,6 +780,18 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h)
|
||||
thread :: [a -> a] -> (a -> a)
|
||||
thread = appEndo . foldMap Endo
|
||||
|
||||
gc :: GmState -> GmState
|
||||
gc st = (sweepNodes . markNodes $ st)
|
||||
& gmStats . stsGCCycles %~ succ
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
lookupN :: Name -> Env -> Maybe Addr
|
||||
lookupN k = lookup (NameKey k)
|
||||
|
||||
lookupC :: Tag -> Int -> Env -> Maybe Addr
|
||||
lookupC t n = lookup (ConstrKey t n)
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
gmEvalProg :: Program' -> GmState
|
||||
@@ -1047,8 +803,7 @@ finalStateOf f = f . gmEvalProg
|
||||
resultOf :: Program' -> Maybe Node
|
||||
resultOf p = do
|
||||
a <- res
|
||||
n <- hLookup a h
|
||||
pure n
|
||||
hLookup a h
|
||||
where
|
||||
res = st ^? gmStack . _head
|
||||
st = gmEvalProg p
|
||||
|
||||
186
src/GM/Print.hs
Normal file
186
src/GM/Print.hs
Normal file
@@ -0,0 +1,186 @@
|
||||
module GM.Print
|
||||
( showState
|
||||
, showStats
|
||||
, showNodeAt
|
||||
)
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import Data.Monoid
|
||||
import Data.String (IsString(..))
|
||||
import Data.Text.Lens (IsText, packed, unpacked)
|
||||
import Text.Printf
|
||||
|
||||
import Text.PrettyPrint hiding ((<>))
|
||||
import Text.PrettyPrint.HughesPJ (maybeParens)
|
||||
import Control.Lens
|
||||
|
||||
import Data.Heap
|
||||
import Core.Syntax
|
||||
import GM.Types
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
pprTabstop :: Int
|
||||
pprTabstop = 4
|
||||
|
||||
qquotes :: Doc -> Doc
|
||||
qquotes d = "`" <> d <> "'"
|
||||
|
||||
showStats :: Stats -> Doc
|
||||
showStats sts = "==== Stats ============" $$ stats
|
||||
where
|
||||
stats = text $ printf
|
||||
"Reductions : %5d\n\
|
||||
\Prim Reductions : %5d\n\
|
||||
\Allocations : %5d\n\
|
||||
\GC Cycles : %5d"
|
||||
(sts ^. stsReductions)
|
||||
(sts ^. stsPrimReductions)
|
||||
(sts ^. stsAllocations)
|
||||
(sts ^. stsGCCycles)
|
||||
|
||||
showState :: GmState -> Doc
|
||||
showState st = vcat
|
||||
[ "==== GmState " <> int stnum <> " "
|
||||
<> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
|
||||
, "-- Next instructions -------"
|
||||
, info $ showCodeShort c
|
||||
, "-- Stack -------------------"
|
||||
, info $ showStack st
|
||||
, "-- Heap --------------------"
|
||||
, info $ showHeap st
|
||||
, "-- Dump --------------------"
|
||||
, info $ showDump st
|
||||
]
|
||||
where
|
||||
stnum = st ^. (gmStats . stsReductions)
|
||||
c = st ^. gmCode
|
||||
|
||||
-- indent data
|
||||
info = nest pprTabstop
|
||||
|
||||
showCodeShort :: Code -> Doc
|
||||
showCodeShort c = braces c'
|
||||
where
|
||||
c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
|
||||
| otherwise = list (showInstr <$> c)
|
||||
list = hcat . punctuate "; "
|
||||
|
||||
showStackShort :: Stack -> Doc
|
||||
showStackShort s = brackets s'
|
||||
where
|
||||
-- no access to heap, otherwise we'd use showNodeAt
|
||||
s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
|
||||
| otherwise = list (showEntry <$> s)
|
||||
list = hcat . punctuate ", "
|
||||
showEntry = text . show
|
||||
|
||||
showStack :: GmState -> Doc
|
||||
showStack st = vcat $ uncurry showEntry <$> si
|
||||
where
|
||||
h = st ^. gmHeap
|
||||
s = st ^. gmStack
|
||||
|
||||
-- stack with labeled indices
|
||||
si = [0..] `zip` s
|
||||
|
||||
w = maxWidth (addresses h)
|
||||
showIndex n = padInt w n <> ": "
|
||||
|
||||
showEntry :: Int -> Addr -> Doc
|
||||
showEntry n a = showIndex n <> showNodeAt st a
|
||||
|
||||
showDump :: GmState -> Doc
|
||||
showDump st = vcat $ uncurry showEntry <$> di
|
||||
where
|
||||
d = st ^. gmDump
|
||||
di = [0..] `zip` d
|
||||
|
||||
showIndex n = padInt w n <> ": "
|
||||
w = maxWidth (fst <$> di)
|
||||
|
||||
showEntry :: Int -> (Code, Stack) -> Doc
|
||||
showEntry n (c,s) = showIndex n <> nest pprTabstop entry
|
||||
where
|
||||
entry = ("Stack : " <> showCodeShort c)
|
||||
$$ ("Code : " <> showStackShort s)
|
||||
|
||||
padInt :: Int -> Int -> Doc
|
||||
padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
|
||||
|
||||
maxWidth :: [Int] -> Int
|
||||
maxWidth ns = digitalWidth $ maximum ns
|
||||
|
||||
digitalWidth :: Int -> Int
|
||||
digitalWidth = length . show
|
||||
|
||||
showHeap :: GmState -> Doc
|
||||
showHeap st = vcat $ showEntry <$> addrs
|
||||
where
|
||||
showAddr n = padInt w n <> ": "
|
||||
|
||||
w = maxWidth addrs
|
||||
h = st ^. gmHeap
|
||||
addrs = addresses h
|
||||
|
||||
showEntry :: Addr -> Doc
|
||||
showEntry a = showAddr a <> showNodeAt st a
|
||||
|
||||
showNodeAt :: GmState -> Addr -> Doc
|
||||
showNodeAt = showNodeAtP 0
|
||||
|
||||
showNodeAtP :: Int -> GmState -> Addr -> Doc
|
||||
showNodeAtP p st a = case hLookup a h of
|
||||
Just (NNum n) -> int n <> "#"
|
||||
Just (NGlobal _ _) -> textt name
|
||||
where
|
||||
g = st ^. gmEnv
|
||||
name = case lookup a (view swapped <$> g) of
|
||||
Just (NameKey n) -> n
|
||||
Just (ConstrKey t n) -> showCon t n
|
||||
_ -> errTxtInvalidAddress
|
||||
-- TODO: left-associativity
|
||||
Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f
|
||||
<+> showNodeAtP (p+1) st x
|
||||
Just (NInd a') -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a'
|
||||
Just (NConstr t as) -> pprec $ "NConstr"
|
||||
<+> int t
|
||||
<+> brackets (list $ showNodeAtP 0 st <$> as)
|
||||
where list = hcat . punctuate ", "
|
||||
Just NUninitialised -> "<uninitialised>"
|
||||
Nothing -> errTxtInvalidAddress
|
||||
where
|
||||
h = st ^. gmHeap
|
||||
pprec = maybeParens (p > 0)
|
||||
|
||||
showSc :: GmState -> (Name, Addr) -> Doc
|
||||
showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
|
||||
$$ code
|
||||
where
|
||||
code = case hLookup a (st ^. gmHeap) of
|
||||
Just (NGlobal _ c) -> showCode c
|
||||
Just _ -> errTxtInvalidObject
|
||||
Nothing -> errTxtInvalidAddress
|
||||
|
||||
errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
|
||||
errTxtInvalidObject = "<invalid object>"
|
||||
errTxtInvalidAddress = "<invalid address>"
|
||||
|
||||
showCode :: Code -> Doc
|
||||
showCode c = "Code" <+> braces instrs
|
||||
where instrs = vcat $ showInstr <$> c
|
||||
|
||||
showInstr :: Instr -> Doc
|
||||
showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
|
||||
where
|
||||
showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
|
||||
alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
|
||||
showInstr i = text $ show i
|
||||
|
||||
textt :: (IsText a) => a -> Doc
|
||||
textt t = t ^. unpacked & text
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
showCon :: (IsText a) => Tag -> Int -> a
|
||||
showCon t n = printf "Pack{%d %d}" t n ^. packed
|
||||
|
||||
83
src/GM/Types.hs
Normal file
83
src/GM/Types.hs
Normal file
@@ -0,0 +1,83 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module GM.Types where
|
||||
--------------------------------------------------------------------------------
|
||||
import Control.Lens.Combinators
|
||||
import Data.Heap
|
||||
import Data.Default
|
||||
|
||||
import Core.Syntax
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data GmState = GmState
|
||||
{ _gmCode :: Code
|
||||
, _gmStack :: Stack
|
||||
, _gmDump :: Dump
|
||||
, _gmHeap :: GmHeap
|
||||
, _gmEnv :: Env
|
||||
, _gmStats :: Stats
|
||||
}
|
||||
deriving Show
|
||||
|
||||
type Code = [Instr]
|
||||
type Stack = [Addr]
|
||||
type Dump = [(Code, Stack)]
|
||||
type Env = [(Key, Addr)]
|
||||
type GmHeap = Heap Node
|
||||
|
||||
data Key = NameKey Name
|
||||
| ConstrKey Tag Int
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- >> [ref/Instr]
|
||||
data Instr = Unwind
|
||||
| PushGlobal Name
|
||||
| PushConstr Tag Int
|
||||
| PushInt Int
|
||||
| Push Int
|
||||
| MkAp
|
||||
| Slide Int
|
||||
| Update Int
|
||||
| Pop Int
|
||||
| Alloc Int
|
||||
| Eval
|
||||
-- arith
|
||||
| Neg | Add | Sub | Mul | Div
|
||||
-- comparison
|
||||
| Equals | Lesser | GreaterEq
|
||||
| Pack Tag Int -- Pack Tag Arity
|
||||
| CaseJump [(Tag, Code)]
|
||||
| Split Int
|
||||
| Print
|
||||
| Halt
|
||||
deriving (Show, Eq)
|
||||
-- << [ref/Instr]
|
||||
|
||||
data Node = NNum Int
|
||||
| NAp Addr Addr
|
||||
-- NGlobal is the GM equivalent of NSupercomb. rather than storing a
|
||||
-- template to be instantiated, NGlobal holds the global's arity and
|
||||
-- the pre-compiled code :3
|
||||
| NGlobal Int Code
|
||||
| NInd Addr
|
||||
| NUninitialised
|
||||
| NConstr Tag [Addr] -- NConstr Tag Components
|
||||
| NMarked Node
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- TODO: log executed instructions
|
||||
data Stats = Stats
|
||||
{ _stsReductions :: Int
|
||||
, _stsPrimReductions :: Int
|
||||
, _stsAllocations :: Int
|
||||
, _stsDereferences :: Int
|
||||
, _stsGCCycles :: Int
|
||||
}
|
||||
deriving Show
|
||||
|
||||
instance Default Stats where
|
||||
def = Stats 0 0 0 0 0
|
||||
|
||||
-- TODO: _gmGlobals should not have a setter
|
||||
makeLenses ''GmState
|
||||
makeLenses ''Stats
|
||||
|
||||
54
src/GM/Visual.hs
Normal file
54
src/GM/Visual.hs
Normal file
@@ -0,0 +1,54 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module GM.Visual
|
||||
( renderGmState
|
||||
)
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import Text.Printf
|
||||
import Data.Function ((&), on)
|
||||
import Text.PrettyPrint qualified as P
|
||||
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.Backend.Cairo
|
||||
|
||||
import GM.Types
|
||||
import GM.Print
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
renderGmState :: GmState -> IO ()
|
||||
renderGmState st = renderCairo path size (drawState st)
|
||||
where
|
||||
size = mkSizeSpec2D (Just 1000) (Just 1000)
|
||||
path = printf "/tmp/render/%04d.png" n
|
||||
n = st ^. gmStats . stsReductions
|
||||
|
||||
drawState :: GmState -> Diagram B
|
||||
drawState = drawStack
|
||||
|
||||
drawStack :: GmState -> Diagram B
|
||||
drawStack st = st & vcatOf (gmStack . each . to cell)
|
||||
where
|
||||
cell a = rect 10 5
|
||||
<> text (printf "%04x: %s" a (P.render . showNodeAt st $ a))
|
||||
|
||||
vcatOf :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a)
|
||||
=> Getting (Endo [a]) s a -> s -> a
|
||||
vcatOf l = vcat . (^.. l)
|
||||
|
||||
newtype Vap a = Vap { getVap :: a }
|
||||
|
||||
instance (InSpace V2 n a, Juxtaposable a, Semigroup a)
|
||||
=> Semigroup (Vap a) where (<>) = (Vap .) . ((===) `on` getVap)
|
||||
instance (InSpace V2 n a, Juxtaposable a, Monoid a)
|
||||
=> Monoid (Vap a) where mempty = Vap mempty
|
||||
|
||||
newtype Hap a = Hap { getHap :: a }
|
||||
|
||||
instance (InSpace V2 n a, Juxtaposable a, Semigroup a)
|
||||
=> Semigroup (Hap a) where (<>) = (Hap .) . ((|||) `on` getHap)
|
||||
instance (InSpace V2 n a, Juxtaposable a, Monoid a)
|
||||
=> Monoid (Hap a) where mempty = Hap mempty
|
||||
|
||||
Reference in New Issue
Block a user