bump

Merge branch 'main' into dev
rc (#13 )
2024-04-15 10:02:36 -06:00 · 2024-02-16 13:12:14 -07:00 · 2024-02-13 13:22:23 -07:00
7 changed files with 286 additions and 377 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -74,11 +74,6 @@ 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 #
--- a/rlp.cabal
+++ b/rlp.cabal
@@ -22,9 +22,6 @@ library
    exposed-modules:  Core
                    , TI
                    , GM
-                    , GM.Visual
-                    , GM.Types
-                    , GM.Print
                    , Compiler.RLPC
                    , Compiler.RlpcError
                    , Compiler.JustRun
@@ -53,17 +50,17 @@ library
    build-tool-depends: happy:happy, alex:alex

    -- other-extensions:
-    build-depends:    base >=4.17 && <4.20
+    build-depends:    base >=4.17 && <4.21
                    -- required for happy
                    , array >= 0.5.5 && < 0.6
                    , containers >= 0.6.7 && < 0.7
-                    , template-haskell >= 2.20.0 && < 2.21
+                    , template-haskell >= 2.20.0 && < 2.23
                    , pretty >= 1.1.3 && < 1.2
                    , data-default >= 0.7.1 && < 0.8
                    , data-default-class >= 0.1.2 && < 0.2
                    , hashable >= 1.4.3 && < 1.5
                    , mtl >= 2.3.1 && < 2.4
-                    , text >= 2.0.2 && < 2.1
+                    , text >= 2.0.2 && < 2.3
                    , unordered-containers >= 0.2.20 && < 0.3
                    , recursion-schemes >= 5.2.2 && < 5.3
                    , data-fix >= 0.3.2 && < 0.4
@@ -76,9 +73,6 @@ 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
@@ -105,7 +99,7 @@ executable rlpc
                 , mtl >= 2.3.1 && < 2.4
                 , unordered-containers >= 0.2.20 && < 0.3
                 , lens >=5.2.3 && <6.0
-                 , text >= 2.0.2 && < 2.1
+                 , text >= 2.0.2 && < 2.3

    hs-source-dirs:   app
    default-language: GHC2021
--- a/src/Compiler/RLPC.hs
+++ b/src/Compiler/RLPC.hs
@@ -120,7 +120,6 @@ data RLPCOptions = RLPCOptions
    , _rlpcEvaluator   :: Evaluator
    , _rlpcHeapTrigger :: Int
    , _rlpcLanguage    :: Maybe Language
-    , _rlpcRender      :: Bool
    , _rlpcInputFiles  :: [FilePath]
    }
    deriving Show
@@ -142,7 +141,6 @@ instance Default RLPCOptions where
        , _rlpcHeapTrigger = 200
        , _rlpcInputFiles = []
        , _rlpcLanguage = Nothing
-        , _rlpcRender = False
        }

 -- debug flags are passed with -dFLAG
--- a/src/GM.hs
+++ b/src/GM.hs
@@ -11,11 +11,6 @@ module GM
    , evalProgR
    , GmState(..)
    , gmCode, gmStack, gmDump, gmHeap, gmEnv, gmStats
-    , stsReductions
-    , stsPrimReductions
-    , stsAllocations
-    , stsDereferences
-    , stsGCCycles
    , Node(..)
    , showState
    , gmEvalProg
@@ -34,9 +29,10 @@ 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
@@ -45,12 +41,9 @@ 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
@@ -62,19 +55,105 @@ 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' -> [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
+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
@@ -736,8 +815,185 @@ 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
@@ -780,18 +1036,6 @@ 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
@@ -803,11 +1047,12 @@ finalStateOf f = f . gmEvalProg
 resultOf :: Program' -> Maybe Node
 resultOf p = do
    a <- res
-    hLookup a h
-  where
-    res = st ^? gmStack . _head
-    st = gmEvalProg p
-    h = st ^. gmHeap
+    n <- hLookup a h
+    pure n
+    where
+        res = st ^? gmStack . _head
+        st = gmEvalProg p
+        h = st ^. gmHeap

 resultOfExpr :: Expr' -> Maybe Node
 resultOfExpr e = resultOf $
--- a/src/GM/Print.hs
+++ b/src/GM/Print.hs
@@ -1,186 +0,0 @@
-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
-
--- a/src/GM/Types.hs
+++ b/src/GM/Types.hs
@@ -1,83 +0,0 @@
-{-# 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
-
--- a/src/GM/Visual.hs
+++ b/src/GM/Visual.hs
@@ -1,54 +0,0 @@
-{-# 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
-