From 5484165ab58ff316e985576c58b76ff71b00c149 Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Thu, 30 Nov 2023 13:45:54 -0700
Subject: [PATCH] gm m2

---
 docs/src/commentary/gm.rst | 67 +++++++++++++++++++++++++++++++++++++-
 src/GM.hs                  | 33 +++++++++++++++++--
 2 files changed, 97 insertions(+), 3 deletions(-)

diff --git a/docs/src/commentary/gm.rst b/docs/src/commentary/gm.rst
index 29a9bd5..e7c38e8 100644
--- a/docs/src/commentary/gm.rst
+++ b/docs/src/commentary/gm.rst
@@ -210,6 +210,62 @@ Core Transition Rules
    & m
    }
 
+9. Pop the stack, and update the nth node to point to the popped address
+
+.. math::
+   \gmrule
+   { \mathtt{Update} \; n : i
+   & e : f : a_1 : \ldots : a_n : s
+   & h
+   \begin{bmatrix}
+        a_1 : \mathtt{NAp} \; f \; e \\
+        \vdots \\
+        a_n : \mathtt{NAp} \; a_{n-1} \; e_n
+   \end{bmatrix}
+   & m
+   }
+   { i
+   & f : a_1 : \ldots : a_n : s
+   & h
+   \begin{bmatrix}
+        a_n : \mathtt{NInd} \; e
+   \end{bmatrix}
+   & m
+   }
+
+10. Pop the stack.
+
+.. math::
+   \gmrule
+   { \mathtt{Pop} \; n : i
+   & a_1 : \ldots : a_n : s
+   & h
+   & m
+   }
+   { i
+   & s
+   & h
+   & m
+   }
+
+11. Follow indirections while unwinding
+
+.. math::
+   \gmrule
+   { \mathtt{Unwind} : \nillist
+   & a : s
+   & h
+   \begin{bmatrix}
+        a : \mathtt{NInd} \; a'
+   \end{bmatrix}
+   & m
+   }
+   { \mathtt{Unwind} : \nillist
+   & a' : s
+   & h
+   & m
+   }
+
 Extension Rules
 ---------------
 
@@ -221,7 +277,7 @@ Extension Rules
    (remember that the environment is intended for *globals*).
 
 .. math::
-   \transrule
+   \gmrule
    { \mathtt{PushInt} \; n : i
    & s
    & h
@@ -270,6 +326,13 @@ Evaluation: Slurping Vines
 
 WIP.
 
+Laziness
+--------
+
+WIP.
+
+* Instead of :code:`Slide (n+1); Unwind`, do :code:`Update n; Pop n; Unwind`
+
 ****************************
 Compilation: Squashing Trees
 ****************************
@@ -297,3 +360,5 @@ The way around this is quite simple: simply offset the stack when w
    :end-before: -- << [ref/compileC]
    :caption: src/GM.hs
 
+
+
diff --git a/src/GM.hs b/src/GM.hs
index de53d83..76d2dd4 100644
--- a/src/GM.hs
+++ b/src/GM.hs
@@ -45,6 +45,8 @@ data Instr = Unwind
            | Push Int
            | MkAp
            | Slide Int
+           | Update Int
+           | Pop Int
            deriving (Show, Eq)
 
 data Node = NNum Int
@@ -53,7 +55,8 @@ data Node = NNum Int
           -- template to be instantiated, NGlobal holds the global's arity and
           -- the pre-compiled code :3
           | NGlobal Int Code
-          deriving Show
+          | NInd Addr
+          deriving (Show, Eq)
 
 data Stats = Stats
     { _stsReductions     :: Int
@@ -118,6 +121,8 @@ step st = case head (st ^. gmCode) of
     Push       n -> push       n st
     MkAp         -> mkAp         st
     Slide      n -> slide      n st
+    Pop        n -> pop        n st
+    Update     n -> update     n st
     where
 
         pushGlobal :: Name -> GmState -> GmState
@@ -217,6 +222,22 @@ step st = case head (st ^. gmCode) of
                 (a:s) = st ^. gmStack
                 s' = a : drop n s
 
+        update :: Int -> GmState -> GmState
+        update n st = st
+                    & gmCode  %~ drop 1
+                    & gmStack .~ s
+                    & gmHeap  .~ h'
+            where
+                (e:s) = st ^. gmStack
+                an = s !! n
+                h' = st ^. gmHeap
+                    & Data.Heap.update an (NInd e)
+
+        pop :: Int -> GmState -> GmState
+        pop n st = st
+                 & gmCode  %~ drop 1
+                 & gmStack %~ drop n
+
         -- the complex heart of the G-machine
         unwind :: GmState -> GmState
         unwind st = case hLookupUnsafe a h of
@@ -231,6 +252,12 @@ step st = case head (st ^. gmCode) of
                          -- 'jump' to global's code by replacing our current
                          -- code with `c`
                          & gmCode .~ c
+            -- follow indirection
+            NInd a      -> st
+                         -- leave the Unwind instr; continue unwinding.
+                         -- follow the indirection; replace the address on the
+                         -- stack with the pointee
+                         & gmStack . _head .~ a
             where
                 s = st ^. gmStack
                 a = head s
@@ -269,7 +296,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiled
         -- << [ref/compileSc]
 
         compileR :: Env -> Expr -> Code
-        compileR g e = compileC g e <> [Slide (d+1), Unwind]
+        compileR g e = compileC g e <> [Update d, Pop d, Unwind]
             where
                 d = length g
 
@@ -381,6 +408,8 @@ showNodeAtP p st a = case hLookup a h of
             name = fromMaybe "<unknown>" $ lookup a (swap <$> g)
     Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x
         where pprec = maybeParens (p > 0)
+    Just (NInd a)        -> pprec $ "NInd -> " <> showNodeAtP (p+1) st a
+        where pprec = maybeParens (p > 0)
     Nothing              -> "<invalid address>"
     where h = st ^. gmHeap