diff --git a/rlp.cabal b/rlp.cabal index b3483f1..33c4d95 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -23,13 +23,13 @@ library , GM , Compiler.RLPC , Core.Syntax + , Core.Examples , Core.Utils + , Core.TH other-modules: Data.Heap , Data.Pretty , Core.Parse - , Core.TH - , Core.Examples , Core.Lex , Control.Monad.Errorful , Core2Core @@ -83,5 +83,8 @@ test-suite rlp-test build-depends: base ^>=4.18.0.0 , rlp , QuickCheck + , hspec ==2.* other-modules: Arith + , GMSpec + build-tool-depends: hspec-discover:hspec-discover diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index b775a8f..3717331 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -4,7 +4,10 @@ Description : Core examples (may eventually be unit tests) -} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -module Core.Examples where +module Core.Examples + ( fac3 + , sumList + ) where ---------------------------------------------------------------------------------- import Core.Syntax import Core.TH @@ -12,6 +15,7 @@ import Core.TH -- TODO: my shitty lexer isn't inserting semicolons +letrecExample :: Program' letrecExample = [coreProg| pair x y f = f x y; @@ -27,18 +31,22 @@ letrecExample = [coreProg| main = f 3 4; |] +idExample :: Program' idExample = [coreProg| main = id 3; |] +indExample1 :: Program' indExample1 = [coreProg| main = twice twice id 3; |] +indExample2 :: Program' indExample2 = [coreProg| main = twice twice twice id 3; |] +indExample3 :: Program' indExample3 = [coreProg| main = letrec { x = 2 @@ -49,51 +57,63 @@ indExample3 = [coreProg| g a b = a; |] +negExample1 :: Program' negExample1 = [coreProg| main = negate# (id 3); |] +negExample2 :: Program' negExample2 = [coreProg| main = negate# 3; |] +negExample3 :: Program' negExample3 = [coreProg| main = twice negate# 3; |] +arithExample1 :: Program' arithExample1 = [coreProg| main = (+#) 3 (negate# 2); |] +arithExample2 :: Program' arithExample2 = [coreProg| main = negate# ((+#) 2 ((*#) 5 3)); |] +ifExample1 :: Program' ifExample1 = [coreProg| main = if# True 2 3; |] +ifExample2 :: Program' ifExample2 = [coreProg| main = if# (id True) 2 3; |] +facExample :: Program' facExample = [coreProg| fac n = if# ((==#) n 0) 1 ((*#) n (fac ((-#) n 1))); main = fac 3; |] +pairExample1 :: Program' pairExample1 = [coreProg| main = fst (snd (fst (MkPair (MkPair 1 (MkPair 2 3)) 4))); |] +pairExample2 :: Program' pairExample2 = [coreProg| main = (if# False fst snd) (MkPair 2 3); |] +listExample1 :: Program' listExample1 = [coreProg| main = caseList# (Cons 2 Nil) 3 k; |] +listExample2 :: Program' listExample2 = [coreProg| cc f x xs = Cons (f x) (map f xs); map f l = caseList# l Nil (cc f); @@ -101,6 +121,7 @@ listExample2 = [coreProg| main = map negate# list; |] +listExample3 :: Program' listExample3 = [coreProg| cc f z x xs = f x (foldr f z xs); foldr f z l = caseList# l z (cc f z); @@ -108,6 +129,7 @@ listExample3 = [coreProg| main = foldr (+#) 0 list; |] +simple1 :: Program' simple1 = [coreProg| k a b = a; s f g x = f x (g x); @@ -115,6 +137,7 @@ simple1 = [coreProg| main = s k k 3; |] +caseBool1 :: Program' caseBool1 = [coreProg| _if c x y = case c of { 1 -> x @@ -127,7 +150,8 @@ caseBool1 = [coreProg| main = _if false ((+#) 2 3) ((*#) 4 5); |] -factorialGM = [coreProg| +fac3 :: Program' +fac3 = [coreProg| fac n = case (==#) n 0 of { 1 -> 1 ; 0 -> (*#) n (fac ((-#) n 1)) @@ -136,6 +160,20 @@ factorialGM = [coreProg| main = fac 3; |] +-- TODO: paramaterised examples? eg. sumList could take a haskell list of ints +-- as an input, translate it to a rl' list, and run the example on that? +sumList :: Program' +sumList = [coreProg| + nil = Pack{0 0}; + cons x y = Pack{1 2} x y; + list = cons 1 (cons 2 (cons 3 nil)); + sum l = case l of + { 0 -> 0 + ; 1 x xs -> (+#) x (sum xs) + }; + main = sum list; + |] + corePrelude :: Module Name corePrelude = Module (Just ("Prelude", [])) $ -- non-primitive defs diff --git a/src/GM.hs b/src/GM.hs index b973a54..a29e158 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -9,6 +9,10 @@ module GM ( hdbgProg , evalProg , Node(..) + , gmEvalProg + , finalStateOf + , resultOf + , resultOfExpr ) where ---------------------------------------------------------------------------------- @@ -701,17 +705,12 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs compileBinder (_ := v, a) = compileC g' v <> [Update a] -- special cases for prim functions; essentially inlining - compileE g ("negate#" :$ a) = compileE g a <> [Neg] - compileE g ("+#" :$ a :$ b) = compileE g a <> compileE g b <> [Add] - -- note that we only bother offsetting the environment and evaluationg - -- in the "correct" order with non-commutative operations. if we - -- implemented Sub the same way as Add, (-#) 3 2 would evaluate to -1. - compileE g ("-#" :$ a :$ b) = compileE g b <> compileE g' a <> [Sub] - where g' = argOffset 1 g - compileE g ("*#" :$ a :$ b) = compileE g a <> compileE g b <> [Mul] - compileE g ("/#" :$ a :$ b) = compileE g a <> compileE g' b <> [Div] - where g' = argOffset 1 g - compileE g ("==#" :$ a :$ b) = compileE g a <> compileE g b <> [Equals] + compileE g ("negate#" :$ a) = inlineOp1 g Neg a + compileE g ("+#" :$ a :$ b) = inlineOp2 g Add a b + compileE g ("-#" :$ a :$ b) = inlineOp2 g Sub a b + compileE g ("*#" :$ a :$ b) = inlineOp2 g Mul a b + compileE g ("/#" :$ a :$ b) = inlineOp2 g Div a b + compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)] @@ -728,6 +727,13 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs g' = binds ++ argOffset n g c = compileE g' e + inlineOp1 :: Env -> Instr -> Expr' -> Code + inlineOp1 g i a = compileE g a <> [i] + + inlineOp2 :: Env -> Instr -> Expr' -> Expr' -> Code + inlineOp2 g i a b = compileE g b <> compileE g' a <> [i] + where g' = argOffset 1 g + -- | offset each address in the environment by n argOffset :: Int -> Env -> Env argOffset n = each . _2 %~ (+n) @@ -855,7 +861,7 @@ showNodeAtP p st a = case hLookup a h of name = case lookup a (swap <$> g) of Just (NameKey n) -> n Just (ConstrKey t n) -> idPack t n - _ -> errTxtInvalidAddress + _ -> errTxtInvalidAddress -- TODO: left-associativity Just (NAp f x) -> pprec $ showNodeAtP (p+1) st f <+> showNodeAtP (p+1) st x @@ -950,4 +956,26 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h) thread :: [a -> a] -> (a -> a) thread = appEndo . foldMap Endo ---} +---------------------------------------------------------------------------------- + +gmEvalProg :: Program' -> GmState +gmEvalProg p = compile p & eval & last + +finalStateOf :: (GmState -> r) -> Program' -> r +finalStateOf f = f . gmEvalProg + +resultOf :: Program' -> Maybe Node +resultOf p = do + a <- res + n <- hLookup a h + pure n + where + res = st ^? gmStack . _head + st = gmEvalProg p + h = st ^. gmHeap + +resultOfExpr :: Expr' -> Maybe Node +resultOfExpr e = resultOf $ Program + [ ScDef "main" [] e + ] + diff --git a/tst/Arith.hs b/tst/Arith.hs index d1a648e..3cf3554 100644 --- a/tst/Arith.hs +++ b/tst/Arith.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Arith - ( runTestsArith + ( evalCore + , evalArith ) where ---------------------------------------------------------------------------------- import Data.Functor.Classes (eq1) @@ -27,16 +28,16 @@ data ArithExpr = IntA Int | ArithExpr ::- ArithExpr deriving Show -evalA :: ArithExpr -> Int -evalA (IntA n) = n -evalA (IdA e) = evalA e -evalA (NegateA a) = negate (evalA a) -evalA (a :+ b) = evalA a + evalA b -evalA (a :* b) = evalA a * evalA b -evalA (a :- b) = evalA a - evalA b -evalA (a ::+ b) = evalA a + evalA b -evalA (a ::* b) = evalA a * evalA b -evalA (a ::- b) = evalA a - evalA b +evalArith :: ArithExpr -> Int +evalArith (IntA n) = n +evalArith (IdA e) = evalArith e +evalArith (NegateA a) = negate (evalArith a) +evalArith (a :+ b) = evalArith a + evalArith b +evalArith (a :* b) = evalArith a * evalArith b +evalArith (a :- b) = evalArith a - evalArith b +evalArith (a ::+ b) = evalArith a + evalArith b +evalArith (a ::* b) = evalArith a * evalArith b +evalArith (a ::- b) = evalArith a - evalArith b instance Arbitrary ArithExpr where arbitrary = gen 4 @@ -47,7 +48,7 @@ instance Arbitrary ArithExpr where -- i don't feel like dealing with division at the moment [ IntA <$> int , NegateA <$> arbitrary - , IdA <$> arbitrary + -- , IdA <$> arbitrary , b (:+) , b (:-) , b (:*) @@ -62,11 +63,11 @@ instance Arbitrary ArithExpr where -- int = chooseInt (minBound,maxBound) int = chooseInt (-500,500) -prop_ArithExprEqCoreExpr :: ArithExpr -> Bool -prop_ArithExprEqCoreExpr e = arithResult `eq1` coreResult - where - arithResult = Just (evalA e) - coreResult = evalCore (toCore e) +-- prop_ArithExprEqCoreExpr :: ArithExpr -> Bool +-- prop_ArithExprEqCoreExpr e = arithResult `eq1` coreResult +-- where +-- arithResult = Just (evalArith e) +-- coreResult = evalCore (toCore e) toCore :: ArithExpr -> Program' toCore expr = Program @@ -87,15 +88,18 @@ toCore expr = Program f n a b = n :$ go a :$ go b -evalCore :: Program' -> Maybe Int -evalCore p = do +evalProgram :: Program' -> Maybe Int +evalProgram p = do a <- fst <$> evalProg p case a of (NNum n) -> Just n _ -> Nothing -pure [] +evalCore :: ArithExpr -> Maybe Int +evalCore = evalProgram . toCore -runTestsArith :: IO Bool -runTestsArith = $quickCheckAll +-- pure [] + +-- runTestsArith :: IO Bool +-- runTestsArith = $quickCheckAll diff --git a/tst/GMSpec.hs b/tst/GMSpec.hs new file mode 100644 index 0000000..befa76b --- /dev/null +++ b/tst/GMSpec.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +module GMSpec + ( spec + ) + where +---------------------------------------------------------------------------------- +import Test.Hspec +import Arith +import Test.QuickCheck +import GM (Node(..), resultOf, resultOfExpr) +import Core.TH +import Core.Examples qualified as Ex +---------------------------------------------------------------------------------- + +spec :: Spec +spec = do + it "should correctly evaluate 3-2 with inlining" $ do + resultOf [coreProg|main = (-#) 3 2;|] `shouldBe` Just (NNum 1) + + it "should correctly evaluate 3-2 without inlining" $ do + resultOf [coreProg|id x = x; main = (id (-#)) 3 2;|] `shouldBe` Just (NNum 1) + + it "should correctly evaluate arbitrary arithmetic" $ do + property $ \e -> + let arithRes = Just (evalArith e) + coreRes = evalCore e + in coreRes `shouldBe` arithRes + + describe "test programs" $ do + it "fac 3" $ do + resultOf Ex.fac3 `shouldBe` Just (NNum 6) + + it "sum [1,2,3]" $ do + resultOf Ex.sumList `shouldBe` Just (NNum 6) + diff --git a/tst/Main.hs b/tst/Main.hs index 3ddb275..a824f8c 100644 --- a/tst/Main.hs +++ b/tst/Main.hs @@ -1,18 +1 @@ -module Main (main) where ----------------------------------------------------------------------------------- -import Control.Monad -import System.Exit -import Test.QuickCheck -import Arith ----------------------------------------------------------------------------------- - -runTests :: IO Bool -runTests = runTestsArith - -main :: IO () -main = do - good <- runTests - if good - then exitSuccess - else exitFailure - +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}