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

cabal.project.local

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

cabal.project.local~

@@ -0,0 +1,5 @@
+ignore-project: False
+library-profiling: True
+executable-profiling: True
+tests: 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/MapList.rl

@@ -0,0 +1,13 @@
+data List a = Nil | Cons a (List a)
+
+map :: (a -> b) -> List a -> List b
+map f l = case l of
+    Nil -> Nil
+    Cons a as -> Cons (f a) (map f as)
+
+list = Cons 1 (Cons 2 (Cons 3 Nil))
+
+lam x = *# x x
+
+main = print# (map lam list)
+

examples/rlp/QuickSort.rl

@@ -0,0 +1,40 @@
+data List a = Nil | Cons a (List a)
+
+data Bool = False | True
+
+filter :: (a -> Bool) -> List a -> List a
+filter p l = case l of
+    Nil -> Nil
+    Cons a as ->
+        case p a of
+            True -> Cons a (filter p as)
+            False -> filter p as
+
+append :: List a -> List a -> List a
+append p q = case p of
+    Nil -> q
+    Cons a as -> Cons a (append as q)
+
+qsort :: List Int# -> List Int#
+qsort l = case l of
+    Nil -> Nil
+    Cons a as ->
+        let lesser = filter (>=# a) as
+            greater = filter (<# a) as
+        in append (append (qsort lesser) (Cons a Nil)) (qsort greater)
+
+list = Cons 9 (Cons 2 (Cons 3 (Cons 2
+            (Cons 5 (Cons 2 (Cons 12 (Cons 89 Nil)))))))
+
+list2 = Cons 2 (Cons 3 Nil)
+
+lt :: Int# -> Int# -> Bool
+lt a = (>=# a)
+
+id x = x
+
+main = case list of
+    Nil -> Nil
+    Cons a as -> let lesser = filter (lt a) as
+                 in lesser
+

examples/rlp/SumList.rl

@@ -7,5 +7,5 @@ foldr f z l = case l of
 
 list = Cons 1 (Cons 2 (Cons 3 Nil))
 
-main = foldr (+#) 0 list
+main = print# (foldr (+#) 0 list)
 

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/Core/Examples.hs

@@ -8,6 +8,7 @@ module Core.Examples where
 ----------------------------------------------------------------------------------
 import Core.Syntax
 import Core.TH
+import Rlp.TH
 ----------------------------------------------------------------------------------
 
 -- fac3 = undefined
@@ -244,3 +245,17 @@ namedConsCase = [coreProg|
 
 --}
 
+qsort = [rlpProg|
+    data List a = Nil | Cons a (List a)
+
+    list = Cons 9 (Cons 2 (Cons 3 (Cons 2
+                (Cons 5 (Cons 2 (Cons 12 (Cons 89 Nil)))))))
+
+    id x = x
+
+    main = case list of
+        Nil -> Nil
+        Cons a as -> let lesser = as
+                     in print# lesser
+|]
+

src/Core2Core.hs

@@ -20,6 +20,7 @@ import Control.Monad.State.Lazy
 import Control.Arrow            ((>>>))
 import Data.Text                qualified as T
 import Data.HashMap.Strict      (HashMap)
+import Debug.Trace
 import Numeric                  (showHex)
 
 import Data.Pretty
@@ -70,7 +71,7 @@ tagData p = let ?dt = p ^. programDataTags
     go x                = embed x
 
     tagAlts :: (?dt :: HashMap Name (Tag, Int)) => Alter' -> Alter'
-    tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs e
+    tagAlts (Alter (AltData c) bs e) = Alter (AltTag tag) bs (cata go e)
         where tag = case ?dt ^. at c of
                 Just (t,_) -> t
                 -- TODO: errorful

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
@@ -103,7 +105,7 @@ data Instr = Unwind
            -- arith
            | Neg | Add | Sub | Mul | Div
            -- comparison
-           | Equals | Lesser
+           | Equals | Lesser | GreaterEq
            | Pack Tag Int -- Pack Tag Arity
            | CaseJump [(Tag, Code)]
            | Split Int
@@ -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
@@ -228,6 +233,7 @@ step st = case head (st ^. gmCode) of
     Div            -> divI
     Equals         -> equalsI
     Lesser         -> lesserI
+    GreaterEq      -> greaterEqI
     Split      n   -> splitI        n
     Pack       t n -> packI       t n
     CaseJump    as -> caseJumpI    as
@@ -406,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
@@ -451,9 +458,10 @@ step st = case head (st ^. gmCode) of
         mulI = primitive2 boxInt unboxInt (*) st
         divI = primitive2 boxInt unboxInt div st
 
-        lesserI, equalsI :: GmState
+        lesserI, greaterEqI, equalsI :: GmState
         equalsI = primitive2 boxBool unboxInt (==) st
         lesserI = primitive2 boxBool unboxInt (<) st
+        greaterEqI = primitive2 boxBool unboxInt (>=) st
 
         splitI :: Int -> GmState
         splitI n = st
@@ -638,6 +646,7 @@ compiledPrims =
     , binop "/#" Div
     , binop "==#" Equals
     , binop "<#" Lesser
+    , binop ">=#" GreaterEq
     , ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1
                     , Unwind])
     ]
@@ -653,7 +662,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
 
         -- note that we don't count sc allocations in the stats
         allocateSc :: GmHeap -> CompiledSC -> (GmHeap, (Key, Addr))
-        allocateSc h (n,d,c) = (h', (NameKey n, a))
+        allocateSc h (n,d,c) = traceShow a (h', (NameKey n, a))
             where (h',a) = alloc h $ NGlobal d c
 
         -- >> [ref/compileSc]
@@ -740,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]
 
@@ -752,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]