From 066f883178d6aee7bd3ed57f657f3088a20f3398 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 29 Nov 2023 17:23:41 -0700 Subject: [PATCH] docs and gm pretty printer --- docs/src/commentary/gm.rst | 27 +++++++++ rlp.cabal | 1 + src/GM.hs | 120 ++++++++++++++++++++++++++++++++++++- 3 files changed, 147 insertions(+), 1 deletion(-) diff --git a/docs/src/commentary/gm.rst b/docs/src/commentary/gm.rst index 962c8b1..9794279 100644 --- a/docs/src/commentary/gm.rst +++ b/docs/src/commentary/gm.rst @@ -207,3 +207,30 @@ WIP. state transition rules & m } +********************************* +Compilation: How to Squash a Tree +********************************* + +WIP. + +Notice that we do not keep a (local) environment at run-time. The environment +only exists at compile-time to map local names to stack indices. When compiling +a supercombinator, the arguments are enumerated from zero (the top of the +stack), and passed to :code:`compileR` as an environment. + +.. literalinclude:: /../../src/GM.hs + :dedent: + :start-after: -- >> [ref/compileSc] + :end-before: -- << [ref/compileSc] + :caption: src/GM.hs + +Of course, variables being indexed relative to the top of the stack means that +they will become inaccurate the moment we push or pop the stack a single time. +The way around this is quite simple: simply offset the stack when w + +.. literalinclude:: /../../src/GM.hs + :dedent: + :start-after: -- >> [ref/compileC] + :end-before: -- << [ref/compileC] + :caption: src/GM.hs + diff --git a/rlp.cabal b/rlp.cabal index acff6e4..d909d49 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -46,6 +46,7 @@ library , data-default-class , unordered-containers , hashable + , pretty hs-source-dirs: src default-language: GHC2021 diff --git a/src/GM.hs b/src/GM.hs index 8a96a17..560ab16 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -4,16 +4,19 @@ Description : The G-Machine -} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module GM ( ) where ---------------------------------------------------------------------------------- import Data.Default.Class -import Data.List (mapAccumL) +import Data.List (mapAccumL, intersperse) import Data.Maybe (fromMaybe) import Lens.Micro import Lens.Micro.TH +import Text.PrettyPrint hiding ((<>)) +import Text.PrettyPrint.HughesPJ (maybeParens) import Data.Heap import Core ---------------------------------------------------------------------------------- @@ -186,11 +189,15 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiled allocateSc h (n,d,c) = (h', (n, a)) where (h',a) = alloc h $ NGlobal d c + -- >> [ref/compileSc] + -- type CompiledSC = (Name, Int, Code) + compileSc :: ScDef -> CompiledSC compileSc (ScDef n as b) = (n, d, compileR env b) where env = as `zip` [0..] d = length as + -- << [ref/compileSc] compileR :: Env -> Expr -> Code compileR g e = compileC g e <> [Slide (d+1), Unwind] @@ -206,11 +213,122 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiled domain = fmap fst g compileC g (IntE n) = [PushInt n] + + -- >> [ref/compileC] compileC g (App f x) = compileC g x <> compileC (argOffset 1 g) f <> [MkAp] + -- << [ref/compileC] -- | offset each address in the environment by n argOffset :: Int -> Env -> Env argOffset n = each . _2 %~ (+n) +---------------------------------------------------------------------------------- + +pprTabstop :: Int +pprTabstop = 4 + +qquotes :: Doc -> Doc +qquotes d = "`" <> d <> "'" + +showResults :: [GmState] -> String +showResults st = undefined + +showState :: GmState -> Doc +showState st = vcat + [ "==== GmState " <> int stnum <> " ====" + , "-- Next instructions -------" + , info $ showNextCode c + , "-- Stack -------------------" + , info $ showStack st + , "-- Heap --------------------" + , info $ showHeap st + ] + where + stnum = st ^. (gmStats . stsReductions) + c = st ^. gmCode + + -- indent data + info = nest pprTabstop + +showNextCode :: Code -> Doc +showNextCode c = brackets c' + where + c' | length c > 3 = list (showInstr <$> take 3 c) <> ", ..." + | otherwise = list (showInstr <$> c) + list = hcat . punctuate ", " + +showStack :: GmState -> Doc +showStack st = vcat $ uncurry showEntry <$> si + where + h = st ^. gmHeap + s = st ^. gmStack + + -- stack with labeled indices + si = [0..] `zip` s + + digitalWidth = length . show + maxWidth = digitalWidth $ maximum (addresses h) + showIndex n = pad <> int n <> ": " + where pad = text (replicate (maxWidth - digitalWidth n) ' ') + + showEntry :: Int -> Addr -> Doc + showEntry n a = showIndex n <> showNodeAt h a + +showHeap :: GmState -> Doc +showHeap st = vcat $ uncurry showEntry <$> assocs h + where + digitalWidth = length . show + maxWidth = digitalWidth $ maximum (addresses h) + showAddr n = pad <> int n <> ": " + where pad = text (replicate (maxWidth - digitalWidth n) ' ') + + h = st ^. gmHeap + + showEntry :: Addr -> Node -> Doc + showEntry a n = showAddr a <> showNode h n + +showNodeAt :: GmHeap -> Addr -> Doc +showNodeAt = showNodeAtP 0 + +showNodeAtP :: Int -> GmHeap -> Addr -> Doc +showNodeAtP p h a = case hLookup a h of + Just n -> showNodeP p h n + Nothing -> "" + +showNode :: GmHeap -> Node -> Doc +showNode = showNodeP 0 + +showNodeP :: Int -> GmHeap -> Node -> Doc +showNodeP _ h (NNum n) = int n <> "#" +showNodeP p h (NGlobal d c) = precp $ "NGlobal" <+> int d + where precp = maybeParens (p > 0) +showNodeP p h (NAp f x) = precp $ showNodeAtP (p+1) h f + <+> showNodeAtP (p+1) h x + where precp = maybeParens (p > 0) + +showSc :: GmState -> (Name, Addr) -> Doc +showSc st (k,a) = "Supercomb " <> qquotes (text k) <> colon + $$ code + where + code = case hLookup a (st ^. gmHeap) of + Just (NGlobal _ c) -> showCode c + Nothing -> "" + +showCode :: Code -> Doc +showCode c = "Code" <+> braces instrs + where instrs = vcat $ showInstr <$> c + +showInstr :: Instr -> Doc +showInstr i = text $ show i + +test = GmState c s h'' g sts + where + c = [Push 4, Push 5, Slide 2, Unwind] + s = [a0,a1,a2] + (h,a0) = alloc mempty $ NGlobal 2 [Push 2,Push 3,MkAp,Slide 2,Unwind] + (h',a1) = alloc h $ NNum 4 + (h'',a2) = alloc h' $ NAp a0 a1 + g = [] + sts = def