ugh

cabal.project.local

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

cabal.project.local~

@@ -0,0 +1,4 @@
+ignore-project: False
+tests: True
+coverage: True
+library-coverage: True

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 print# 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)
 

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/GM.hs

@@ -103,7 +103,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
@@ -228,6 +228,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
@@ -451,9 +452,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 +640,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 +656,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]