diff --git a/app/Main.hs b/app/Main.hs index adc9158..e6b64f4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 # diff --git a/rlp.cabal b/rlp.cabal index e1a30be..6c60af7 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -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 diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index fb599fc..a2d0cb6 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -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 diff --git a/src/GM.hs b/src/GM.hs index a414ff7..9eb96a2 100644 --- a/src/GM.hs +++ b/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 -> "" - 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 = "" -errTxtInvalidAddress = "" - -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,12 +803,11 @@ finalStateOf f = f . gmEvalProg resultOf :: Program' -> Maybe Node resultOf p = do a <- res - n <- hLookup a h - pure n - where - res = st ^? gmStack . _head - st = gmEvalProg p - h = st ^. gmHeap + hLookup a h + where + res = st ^? gmStack . _head + st = gmEvalProg p + h = st ^. gmHeap resultOfExpr :: Expr' -> Maybe Node resultOfExpr e = resultOf $ diff --git a/src/GM/Print.hs b/src/GM/Print.hs new file mode 100644 index 0000000..30ff9e1 --- /dev/null +++ b/src/GM/Print.hs @@ -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 -> "" + 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 = "" +errTxtInvalidAddress = "" + +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 + diff --git a/src/GM/Types.hs b/src/GM/Types.hs new file mode 100644 index 0000000..5acb995 --- /dev/null +++ b/src/GM/Types.hs @@ -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 + diff --git a/src/GM/Visual.hs b/src/GM/Visual.hs new file mode 100644 index 0000000..fef0ca7 --- /dev/null +++ b/src/GM/Visual.hs @@ -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 +