love when writing d instead of d-1 causes hours of stress

cabal.project.local

@@ -1,5 +1,8 @@
+profiling: True
 ignore-project: False
 library-profiling: True
 executable-profiling: True
+profiling-detail: all-functions
 tests: True
 benchmarks: True
+

cabal.project.local~

@@ -1,4 +1,5 @@
 ignore-project: False
+library-profiling: True
+executable-profiling: True
 tests: True
-coverage: True
-library-coverage: True
+benchmarks: True

examples/rlp/Help.rl

@@ -0,0 +1,10 @@
+id x = x
+
+thing = Identity 3
+
+data Identity a = Identity a
+
+main = case thing of
+    Identity x -> let y = x
+                  in y
+

examples/rlp/QuickSort.rl

@@ -36,5 +36,5 @@ id x = x
 main = case list of
     Nil -> Nil
     Cons a as -> let lesser = filter (lt a) as
-                 in print# lesser
+                 in lesser
 

rlp.cabal

@@ -80,6 +80,9 @@ library
                     , deriving-compat ^>=0.6.0
                     , these >=0.2 && <2.0
 
+    ghc-options:
+        -fprof-auto
+
     hs-source-dirs:   src
     default-language: GHC2021
 

src/Data/Heap.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ImplicitParams #-}
 {-
 Module : Data.Heap
 Description : A model heap used by abstract machine
@@ -26,7 +27,10 @@ import Data.Map                     (Map, (!?))
 import Debug.Trace
 import Data.Map.Strict              qualified as M
 import Data.List                    (intersect)
-import GHC.Stack                    (HasCallStack)
+import Data.IORef
+import System.IO.Unsafe
+import Control.Monad
+import GHC.Stack
 import Control.Lens
 ----------------------------------------------------------------------------------
 
@@ -74,13 +78,19 @@ instance Traversable Heap where
 
 ----------------------------------------------------------------------------------
 
-alloc :: Heap a -> a -> (Heap a, Addr)
-alloc (Heap (u:us) m) v = (Heap us (M.insert u v m), u)
+godhelpme :: IORef Int
+godhelpme = unsafePerformIO $ newIORef 0
+
+alloc :: HasCallStack => Heap a -> a -> (Heap a, Addr)
+alloc (Heap (u:us) m) v = unsafePerformIO $ do
+    -- i <- readIORef godhelpme
+    -- when (i >= 60000) $ error "fuck"
+    -- modifyIORef godhelpme succ
+    pure (Heap us (M.insert u v m), u)
 alloc (Heap [] _)     _ = error "heap model ran out of memory..."
 
-update :: Addr -> a -> Heap a -> Heap a
+update :: HasCallStack => Addr -> a -> Heap a -> Heap a
 update k v (Heap u m) = Heap u (M.adjust (const v) k m)
--- update k v (Heap u m) = Heap u (M.adjust (undefined) k m)
 
 adjust :: Addr -> (a -> a) -> Heap a -> Heap a
 adjust k f (Heap u m) = Heap u (M.adjust f k m)

src/GM.hs

@@ -31,7 +31,9 @@ import Text.Printf
 import Text.PrettyPrint             hiding ((<>))
 import Text.PrettyPrint.HughesPJ    (maybeParens)
 import Data.Foldable                (traverse_)
-import System.IO                    (Handle, hPutStrLn)
+import Control.Concurrent
+import System.Exit
+import System.IO                    (Handle, hPutStrLn, stderr)
 -- TODO: an actual output system
 -- TODO: an actual output system
 -- TODO: an actual output system
@@ -173,8 +175,11 @@ hdbgProg p hio = do
         [resAddr] = final ^. gmStack
         res = hLookupUnsafe resAddr h
 
-evalProgR :: (Monad m) => Program' -> RLPCT m (Node, Stats)
+evalProgR :: Program' -> RLPCIO (Node, Stats)
 evalProgR p = do
+    -- me <- liftIO myThreadId
+    -- liftIO $ forkIO $ threadDelay (5 * 10^6) *> throwTo me ExitSuccess *> exitSuccess
+    -- states & traverseOf_ (each . gmCode) (liftIO . print)
     (renderOut . showState) `traverse_` states
     renderOut . showStats $ sts
     pure (res, sts)
@@ -193,11 +198,11 @@ eval st = st : rest
     where
         rest | isFinal st   = []
              | otherwise    = eval next
-        next = doAdmin (step st)
+        next = doAdmin (step . (\a -> (unsafePerformIO . hPutStrLn stderr . ('\n':) . render . showState $ a) `seq` a) $ st)
 
 doAdmin :: GmState -> GmState
 doAdmin st = st & gmStats . stsReductions %~ succ
-                & doGC
+                -- & doGC
     where
         -- TODO: use heapTrigger option in RLPCOptions
         heapTrigger = 50
@@ -407,7 +412,8 @@ step st = case head (st ^. gmCode) of
                 (e:s) = st ^. gmStack
                 an = s !! n
                 h = st ^. gmHeap
-                h' = h `seq` update an (NInd e) h
+                -- PROBLEM HERE:
+                h' = update an (NInd e) h
 
         popI :: Int -> GmState
         popI n = st
@@ -743,10 +749,10 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         compileE _ (Lit l) = compileEL l
         compileE g (Let NonRec bs e) =
                 -- we use compileE instead of compileC
-                mconcat binders <> compileE g' e <> [Slide d]
+                traceShowId $ mconcat binders <> compileE g' e <> [Slide d]
             where
                 d = length bs
-                (g',binders) = mapAccumL compileBinder (argOffset d g) addressed
+                (g',binders) = mapAccumL compileBinder (argOffset (d-1) g) addressed
                 -- kinda gross. revisit this
                 addressed = bs `zip` reverse [0 .. d-1]
 
@@ -755,7 +761,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
                     where
                         m' = (NameKey k, a) : m
                         -- make note that we use m rather than m'!
-                        c = compileC m v
+                        c = trace (printf "compileC %s %s" (show m) (show v)) $ compileC m v
 
         compileE g (Let Rec bs e) =
                 Alloc d : initialisers <> body <> [Slide d]