From e2401cecb51a5ab6068abe7b177e2e7141a4ceca Mon Sep 17 00:00:00 2001 From: anabra Date: Sat, 1 Feb 2020 23:55:56 +0100 Subject: [PATCH 01/15] ES: added Reducer/Base --- grin/grin.cabal | 1 + grin/src/Reducer/ExtendedSyntax/Base.hs | 87 +++++++++++++++++++++++++ 2 files changed, 88 insertions(+) create mode 100644 grin/src/Reducer/ExtendedSyntax/Base.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 9a645a83..82b7441b 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -118,6 +118,7 @@ library Pipeline.Eval Pipeline.Optimizations Pipeline.Pipeline + Reducer.ExtendedSyntax.Base Reducer.Base Reducer.IO Reducer.LLVM.Base diff --git a/grin/src/Reducer/ExtendedSyntax/Base.hs b/grin/src/Reducer/ExtendedSyntax/Base.hs new file mode 100644 index 00000000..27d5ca37 --- /dev/null +++ b/grin/src/Reducer/ExtendedSyntax/Base.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE LambdaCase, TupleSections, BangPatterns #-} +module Reducer.ExtendedSyntax.Base where + +import Data.Map (Map) +import qualified Data.Map as Map + +import Text.PrettyPrint.ANSI.Leijen + +import Grin.Grin +import Grin.Pretty + +-- models cpu registers +type Env = Map Name RTVal + +type SimpleRTVal = RTVal +data RTVal + = RT_ConstTagNode Tag [SimpleRTVal] + | RT_VarTagNode Name [SimpleRTVal] + | RT_ValTag Tag + | RT_Unit + | RT_Lit Lit + | RT_Var Name + | RT_Loc Int + | RT_Undefined + deriving (Show, Eq, Ord) + + +instance Pretty RTVal where + pretty = \case + RT_ConstTagNode tag args -> parens $ hsep (pretty tag : map pretty args) + RT_VarTagNode name args -> parens $ hsep (pretty name : map pretty args) + RT_ValTag tag -> pretty tag + RT_Unit -> parens empty + RT_Lit lit -> pretty lit + RT_Var name -> pretty name + RT_Loc a -> keyword "loc" <+> int a + RT_Undefined -> keyword "undefined" + +keyword :: String -> Doc +keyword = yellow . text + +selectNodeItem :: Maybe Int -> RTVal -> RTVal +selectNodeItem Nothing val = val +selectNodeItem (Just 0) (RT_ConstTagNode tag args) = RT_ValTag tag +selectNodeItem (Just i) (RT_ConstTagNode tag args) = args !! (i - 1) + +bindPatMany :: Env -> [RTVal] -> [LPat] -> Env +bindPatMany env [] [] = env +bindPatMany env (val : vals) (lpat : lpats) = bindPatMany (bindPat env val lpat) vals lpats +bindPatMany env [] (lpat : lpats) = bindPatMany (bindPat env RT_Undefined lpat) [] lpats +bindPatMany _ vals lpats = error $ "bindPatMany - pattern mismatch: " ++ show (vals, lpats) + +bindPat :: Env -> RTVal -> LPat -> Env +bindPat env !val lpat = case lpat of + Var n -> case val of + RT_ValTag{} -> Map.insert n val env + RT_Unit -> Map.insert n val env + RT_Lit{} -> Map.insert n val env + RT_Loc{} -> Map.insert n val env + RT_Undefined -> Map.insert n val env + _ -> Map.insert n val env -- WTF???? + _ -> error $ "bindPat - illegal value: " ++ show val + ConstTagNode ptag pargs -> case val of + RT_ConstTagNode vtag vargs | ptag == vtag -> bindPatMany env vargs pargs + _ -> error $ "bindPat - illegal value for ConstTagNode: " ++ show val ++ " vs " ++ show (ConstTagNode ptag pargs) + VarTagNode varname pargs -> case val of + RT_ConstTagNode vtag vargs -> bindPatMany (Map.insert varname (RT_ValTag vtag) env) vargs pargs + _ -> error $ "bindPat - illegal value for ConstTagNode: " ++ show val + Unit -> env + _ -> error $ "bindPat - pattern mismatch" ++ show (val,lpat) + +lookupEnv :: Name -> Env -> RTVal +lookupEnv n env = Map.findWithDefault (error $ "missing variable: " ++ unpackName n) n env + +evalVal :: Env -> Val -> RTVal +evalVal env = \case + Lit lit -> RT_Lit lit + Var n -> lookupEnv n env + ConstTagNode t a -> RT_ConstTagNode t $ map (evalVal env) a + VarTagNode n a -> case lookupEnv n env of + RT_Var n -> RT_VarTagNode n $ map (evalVal env) a + RT_ValTag t -> RT_ConstTagNode t $ map (evalVal env) a + x -> error $ "evalVal - invalid VarTagNode tag: " ++ show x + ValTag tag -> RT_ValTag tag + Unit -> RT_Unit + Undefined t -> RT_Undefined + x -> error $ "evalVal: " ++ show x From abf6ebadfebd789eadf96c9bb07824d11376dfd7 Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 2 Feb 2020 00:30:24 +0100 Subject: [PATCH 02/15] ES: Reducer/Base compiles --- grin/src/Reducer/ExtendedSyntax/Base.hs | 59 ++++++++----------------- 1 file changed, 18 insertions(+), 41 deletions(-) diff --git a/grin/src/Reducer/ExtendedSyntax/Base.hs b/grin/src/Reducer/ExtendedSyntax/Base.hs index 27d5ca37..383fae4a 100644 --- a/grin/src/Reducer/ExtendedSyntax/Base.hs +++ b/grin/src/Reducer/ExtendedSyntax/Base.hs @@ -3,11 +3,12 @@ module Reducer.ExtendedSyntax.Base where import Data.Map (Map) import qualified Data.Map as Map +import Data.Foldable (fold) import Text.PrettyPrint.ANSI.Leijen -import Grin.Grin -import Grin.Pretty +import Grin.ExtendedSyntax.Grin +import Grin.ExtendedSyntax.Pretty -- models cpu registers type Env = Map Name RTVal @@ -15,8 +16,6 @@ type Env = Map Name RTVal type SimpleRTVal = RTVal data RTVal = RT_ConstTagNode Tag [SimpleRTVal] - | RT_VarTagNode Name [SimpleRTVal] - | RT_ValTag Tag | RT_Unit | RT_Lit Lit | RT_Var Name @@ -28,8 +27,6 @@ data RTVal instance Pretty RTVal where pretty = \case RT_ConstTagNode tag args -> parens $ hsep (pretty tag : map pretty args) - RT_VarTagNode name args -> parens $ hsep (pretty name : map pretty args) - RT_ValTag tag -> pretty tag RT_Unit -> parens empty RT_Lit lit -> pretty lit RT_Var name -> pretty name @@ -41,47 +38,27 @@ keyword = yellow . text selectNodeItem :: Maybe Int -> RTVal -> RTVal selectNodeItem Nothing val = val -selectNodeItem (Just 0) (RT_ConstTagNode tag args) = RT_ValTag tag selectNodeItem (Just i) (RT_ConstTagNode tag args) = args !! (i - 1) -bindPatMany :: Env -> [RTVal] -> [LPat] -> Env -bindPatMany env [] [] = env -bindPatMany env (val : vals) (lpat : lpats) = bindPatMany (bindPat env val lpat) vals lpats -bindPatMany env [] (lpat : lpats) = bindPatMany (bindPat env RT_Undefined lpat) [] lpats -bindPatMany _ vals lpats = error $ "bindPatMany - pattern mismatch: " ++ show (vals, lpats) - -bindPat :: Env -> RTVal -> LPat -> Env -bindPat env !val lpat = case lpat of - Var n -> case val of - RT_ValTag{} -> Map.insert n val env - RT_Unit -> Map.insert n val env - RT_Lit{} -> Map.insert n val env - RT_Loc{} -> Map.insert n val env - RT_Undefined -> Map.insert n val env - _ -> Map.insert n val env -- WTF???? - _ -> error $ "bindPat - illegal value: " ++ show val - ConstTagNode ptag pargs -> case val of - RT_ConstTagNode vtag vargs | ptag == vtag -> bindPatMany env vargs pargs - _ -> error $ "bindPat - illegal value for ConstTagNode: " ++ show val ++ " vs " ++ show (ConstTagNode ptag pargs) - VarTagNode varname pargs -> case val of - RT_ConstTagNode vtag vargs -> bindPatMany (Map.insert varname (RT_ValTag vtag) env) vargs pargs - _ -> error $ "bindPat - illegal value for ConstTagNode: " ++ show val - Unit -> env - _ -> error $ "bindPat - pattern mismatch" ++ show (val,lpat) +bindPat :: Env -> RTVal -> BPat -> Env +bindPat env !val bPat = case bPat of + VarPat var -> Map.insert var val env + p@(AsPat tag args var) -> case val of + RT_ConstTagNode vtag vargs + | tag == vtag + , env' <- Map.insert var val env + , newVars <- fold $ zipWith Map.singleton args vargs + -> env' <> newVars + _ -> error $ "bindPat - illegal value for ConstTagNode: " ++ show val ++ " vs " ++ show (PP p) lookupEnv :: Name -> Env -> RTVal lookupEnv n env = Map.findWithDefault (error $ "missing variable: " ++ unpackName n) n env evalVal :: Env -> Val -> RTVal evalVal env = \case - Lit lit -> RT_Lit lit - Var n -> lookupEnv n env - ConstTagNode t a -> RT_ConstTagNode t $ map (evalVal env) a - VarTagNode n a -> case lookupEnv n env of - RT_Var n -> RT_VarTagNode n $ map (evalVal env) a - RT_ValTag t -> RT_ConstTagNode t $ map (evalVal env) a - x -> error $ "evalVal - invalid VarTagNode tag: " ++ show x - ValTag tag -> RT_ValTag tag - Unit -> RT_Unit - Undefined t -> RT_Undefined + Lit lit -> RT_Lit lit + Var n -> lookupEnv n env + ConstTagNode t a -> RT_ConstTagNode t $ map (`lookupEnv` env) a + Unit -> RT_Unit + Undefined t -> RT_Undefined x -> error $ "evalVal: " ++ show x From 90f69ba375a957b4be16fc9d5c5ffb6879453631 Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 2 Feb 2020 00:43:49 +0100 Subject: [PATCH 03/15] ES: added KeyValueMap for pretty printing --- grin/src/Grin/ExtendedSyntax/Pretty.hs | 7 +++++++ grin/src/Test/ExtendedSyntax/Assertions.hs | 8 ++++++++ 2 files changed, 15 insertions(+) diff --git a/grin/src/Grin/ExtendedSyntax/Pretty.hs b/grin/src/Grin/ExtendedSyntax/Pretty.hs index 2cd5c8a6..063b06e7 100644 --- a/grin/src/Grin/ExtendedSyntax/Pretty.hs +++ b/grin/src/Grin/ExtendedSyntax/Pretty.hs @@ -15,6 +15,7 @@ module Grin.ExtendedSyntax.Pretty , showName , showWidth , showWide + , KeyValueMap(..) ) where import Data.Char @@ -227,3 +228,9 @@ prettyFunction (name, (ret, args)) = pretty name <> align (encloseSep (text " :: prettyLocSet :: Set Loc -> Doc prettyLocSet = semiBraces . map (cyan . int) . Set.toList + +newtype KeyValueMap k v = KV (Map k v) + deriving (Eq, Ord, Show) + +instance (Pretty k, Pretty v) => Pretty (KeyValueMap k v) where + pretty (KV m) = prettyKeyValue $ Map.toList m diff --git a/grin/src/Test/ExtendedSyntax/Assertions.hs b/grin/src/Test/ExtendedSyntax/Assertions.hs index a6b14a72..61f5e59f 100644 --- a/grin/src/Test/ExtendedSyntax/Assertions.hs +++ b/grin/src/Test/ExtendedSyntax/Assertions.hs @@ -6,6 +6,8 @@ import Grin.ExtendedSyntax.Grin import Grin.ExtendedSyntax.Pretty import Grin.ExtendedSyntax.TypeEnv +import Reducer.ExtendedSyntax.Base (RTVal(..)) + -- import AbstractInterpretation.CreatedBy.Pretty -- import AbstractInterpretation.CreatedBy.Result (ProducerMap,ProducerGraph(..)) import AbstractInterpretation.ExtendedSyntax.LiveVariable.Pretty @@ -50,3 +52,9 @@ instance SameAs Exp where -- | Check if the two expression are the same, if not renders them -- in a pretty printed form. sameAs found expected = (PP found) `shouldBe` (PP expected) + +instance (Pretty k, Pretty v, Eq k, Eq v) => SameAs (KeyValueMap k v) where + sameAs found expected = (PP found) `shouldBe` (PP expected) + +instance SameAs RTVal where + sameAs found expected = (PP found) `shouldBe` (PP expected) From 7cc277afd692829143f098b477dc12e0bc96fb94 Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 2 Feb 2020 01:29:19 +0100 Subject: [PATCH 04/15] ES: added Reducer/Base tests --- grin/grin.cabal | 2 + grin/test/Reducer/ExtendedSyntax/BaseSpec.hs | 85 ++++++++++++++++++++ 2 files changed, 87 insertions(+) create mode 100644 grin/test/Reducer/ExtendedSyntax/BaseSpec.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 82b7441b..84554fb3 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -389,6 +389,8 @@ test-suite grin-test AbstractInterpretation.SharingSpec AbstractInterpretation.CreatedBySpec Test.Hspec.PipelineExample + + Reducer.ExtendedSyntax.BaseSpec default-language: Haskell2010 benchmark grin-benchmark diff --git a/grin/test/Reducer/ExtendedSyntax/BaseSpec.hs b/grin/test/Reducer/ExtendedSyntax/BaseSpec.hs new file mode 100644 index 00000000..2c71abf2 --- /dev/null +++ b/grin/test/Reducer/ExtendedSyntax/BaseSpec.hs @@ -0,0 +1,85 @@ +module Reducer.ExtendedSyntax.BaseSpec where + +import Reducer.ExtendedSyntax.Base + +import Data.Text +import qualified Data.Map as Map + +import Test.Hspec + +import Test.ExtendedSyntax.Assertions +import Grin.ExtendedSyntax.TH +import Grin.ExtendedSyntax.Syntax +import Grin.ExtendedSyntax.TypeEnvDefs +import Grin.ExtendedSyntax.Pretty (KeyValueMap(..)) + + +runTests :: IO () +runTests = hspec spec + +spec :: Spec +spec = do + describe "Basic reducer" $ do + it "interprets literals correctly" $ do + let lit = LBool True + + let result = evalVal mempty (Lit lit) + expected = RT_Lit lit + + result `sameAs` expected + + it "interprets variables correctly" $ do + let varName = "v" + rtVal = RT_Lit $ LInt64 42 + initEnv = Map.singleton varName rtVal + + let result = evalVal initEnv (Var varName) + expected = rtVal + + result `sameAs` expected + + it "interprets nodes correctly" $ do + let varName = "v" + rtVal = RT_Lit $ LString "asd" + tag = Tag C "Int" + initEnv = Map.singleton varName rtVal + + let result = evalVal initEnv (ConstTagNode tag [varName]) + expected = RT_ConstTagNode tag [rtVal] + + result `sameAs` expected + + it "interprets unit correctly" $ do + let result = evalVal mempty Unit + expected = RT_Unit + + result `sameAs` expected + + it "interprets undefined correctly" $ do + let result = evalVal mempty (Undefined $ T_SimpleType T_Dead) + expected = RT_Undefined + + result `sameAs` expected + + it "interprets variables patterns correctly" $ do + let varName = "v" + rtVal = RT_Lit $ LChar 'c' + initEnv = Map.singleton "w" RT_Unit + + let result = KV $ bindPat initEnv rtVal (VarPat varName) + expected = KV $ Map.insert varName rtVal initEnv + + result `sameAs` expected + + it "interprets as-patterns correctly" $ do + let varName = "v" + argName = "a" + tag = Tag C "Float" + argRtVal = RT_Lit $ LFloat 42 + nodeRtVal = RT_ConstTagNode tag [argRtVal] + initEnv = Map.singleton "w" RT_Unit + + let result = KV $ bindPat initEnv nodeRtVal (AsPat tag [argName] varName) + expected = KV $ initEnv <> Map.fromList [(varName, nodeRtVal), (argName, argRtVal)] + + result `sameAs` expected From 536987bf8af18175104f2b44fa5849932690cde2 Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 11 Feb 2020 18:54:30 +0100 Subject: [PATCH 05/15] ES: added Reducer/PrimOps --- grin/grin.cabal | 1 + grin/src/Reducer/ExtendedSyntax/PrimOps.hs | 185 +++++++++++++++++++++ 2 files changed, 186 insertions(+) create mode 100644 grin/src/Reducer/ExtendedSyntax/PrimOps.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 84554fb3..e6f1687d 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -119,6 +119,7 @@ library Pipeline.Optimizations Pipeline.Pipeline Reducer.ExtendedSyntax.Base + Reducer.ExtendedSyntax.PrimOps Reducer.Base Reducer.IO Reducer.LLVM.Base diff --git a/grin/src/Reducer/ExtendedSyntax/PrimOps.hs b/grin/src/Reducer/ExtendedSyntax/PrimOps.hs new file mode 100644 index 00000000..6f9a7e26 --- /dev/null +++ b/grin/src/Reducer/ExtendedSyntax/PrimOps.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +module Reducer.ExtendedSyntax.PrimOps (evalPrimOp) where + +import Foreign.C.Types +import qualified Language.C.Inline as C +import qualified Language.C.Inline.Unsafe as CU +import Foreign.Marshal.Alloc +import Foreign.C.String + +import Reducer.Base + +import Data.Bits (shift) +import Data.Char (chr, ord) +import Grin.Grin +import Data.Map.Strict as Map +import Data.String (fromString) +import Data.Functor.Infix ((<$$>)) +import Data.Text as Text +import Control.Monad.IO.Class + +import Control.Concurrent (threadDelay) +import Data.Bits +import System.IO (hIsEOF, stdin) +import System.IO.Unsafe + +C.include "" +C.include "" + +-- primitive functions +primLiteralPrint _ _ [RT_Lit (LInt64 a)] = liftIO (print a) >> pure RT_Unit +primLiteralPrint _ _ [RT_Lit (LString a)] = liftIO (putStr (Text.unpack a)) >> pure RT_Unit +primLiteralPrint ctx ps x = error $ Prelude.unwords ["primLiteralPrint", ctx, "- invalid arguments:", show ps, " - ", show x] + + +evalPrimOp :: MonadIO m => Name -> [Val] -> [RTVal] -> m RTVal +evalPrimOp name params args = case name of + "_prim_int_print" -> primLiteralPrint "int" params args + "_prim_string_print" -> primLiteralPrint "string" params args + "_prim_read_string" -> primReadString + "_prim_usleep" -> primUSleep + "_prim_error" -> primError + -- Conversion + "_prim_int_str" -> int_str + "_prim_str_int" -> str_int + "_prim_int_float" -> int_float + "_prim_float_string" -> float_str + "_prim_char_int" -> char_int + -- String + "_prim_string_reverse" -> string_un_op string Text.reverse + "_prim_string_head" -> string_un_op int (fromIntegral . ord . Text.head) + "_prim_string_tail" -> string_un_op string Text.tail + "_prim_string_len" -> string_un_op int (fromIntegral . Text.length) + "_prim_string_concat" -> string_bin_op string (\t1 t2 -> Text.concat [t1, t2]) + "_prim_string_lt" -> string_bin_op int (boolean 0 1 <$$> (<)) + "_prim_string_eq" -> string_bin_op int (boolean 0 1 <$$> (==)) + "_prim_string_cons" -> string_cons + + -- Int + "_prim_int_shr" -> int_un_op int (`shiftR` 1) + "_prim_int_add" -> int_bin_op int (+) + "_prim_int_sub" -> int_bin_op int (-) + "_prim_int_mul" -> int_bin_op int (*) + "_prim_int_div" -> int_bin_op int div + "_prim_int_ashr" -> int_bin_op int (\v h -> shift v ((-1) * fromIntegral h)) + "_prim_int_eq" -> int_bin_op bool (==) + "_prim_int_ne" -> int_bin_op bool (/=) + "_prim_int_gt" -> int_bin_op bool (>) + "_prim_int_ge" -> int_bin_op bool (>=) + "_prim_int_lt" -> int_bin_op bool (<) + "_prim_int_le" -> int_bin_op bool (<=) + -- Word + "_prim_word_add" -> word_bin_op word (+) + "_prim_word_sub" -> word_bin_op word (-) + "_prim_word_mul" -> word_bin_op word (*) + "_prim_word_div" -> word_bin_op word div + "_prim_word_eq" -> word_bin_op bool (==) + "_prim_word_ne" -> word_bin_op bool (/=) + "_prim_word_gt" -> word_bin_op bool (>) + "_prim_word_ge" -> word_bin_op bool (>=) + "_prim_word_lt" -> word_bin_op bool (<) + "_prim_word_le" -> word_bin_op bool (<=) + -- Float + "_prim_float_add" -> float_bin_op float (+) + "_prim_float_sub" -> float_bin_op float (-) + "_prim_float_mul" -> float_bin_op float (*) + "_prim_float_div" -> float_bin_op float (/) + "_prim_float_eq" -> float_bin_op bool (==) + "_prim_float_ne" -> float_bin_op bool (/=) + "_prim_float_gt" -> float_bin_op bool (>) + "_prim_float_ge" -> float_bin_op bool (>=) + "_prim_float_lt" -> float_bin_op bool (<) + "_prim_float_le" -> float_bin_op bool (<=) + -- Bool + "_prim_bool_eq" -> bool_bin_op bool (==) + "_prim_bool_ne" -> bool_bin_op bool (/=) + -- FFI - TODO: Handle FFI appropiatey + "_prim_ffi_file_eof" -> file_eof + + _ -> error $ "unknown primitive operation: " ++ unpackName name + where + int x = pure . RT_Lit . LInt64 $ x + word x = pure . RT_Lit . LWord64 $ x + float x = pure . RT_Lit . LFloat $ x + bool x = pure . RT_Lit . LBool $ x + string x = pure . RT_Lit . LString $ x +-- char x = pure . RT_Lit . LChar $ x + + int_un_op retTy fn = case args of + [RT_Lit (LInt64 a)] -> retTy $ fn a + _ -> error $ "invalid arguments: " ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + int_bin_op retTy fn = case args of + [RT_Lit (LInt64 a), RT_Lit (LInt64 b)] -> retTy $ fn a b + _ -> error $ "invalid arguments: " ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + word_bin_op retTy fn = case args of + [RT_Lit (LWord64 a), RT_Lit (LWord64 b)] -> retTy $ fn a b + _ -> error $ "invalid arguments: " ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + float_bin_op retTy fn = case args of + [RT_Lit (LFloat a), RT_Lit (LFloat b)] -> retTy $ fn a b + _ -> error $ "invalid arguments: " ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + bool_bin_op retTy fn = case args of + [RT_Lit (LBool a), RT_Lit (LBool b)] -> retTy $ fn a b + _ -> error $ "invalid arguments: " ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + string_bin_op retTy fn = case args of + [RT_Lit (LString a), RT_Lit (LString b)] -> retTy $ fn a b + _ -> error $ "invalid arguments: " ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + string_un_op retTy fn = case args of + [RT_Lit (LString a)] -> retTy $ fn a + _ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + string_cons = case args of + [RT_Lit (LInt64 a), RT_Lit (LString b)] -> string $ Text.cons (chr (fromIntegral a)) b + _ -> error $ "invalid arguments: " ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + int_str = case args of + [RT_Lit (LInt64 a)] -> string $ fromString $ show a + _ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + str_int = case args of + [RT_Lit (LString a)] -> int $ read $ Text.unpack a + _ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + int_float = case args of + [RT_Lit (LInt64 a)] -> float $ fromIntegral a + _ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + char_int = case args of + [RT_Lit (LChar a)] -> int . fromIntegral . ord $ a + _ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + float_str = case args of + [RT_Lit (LFloat a)] -> liftIO $ allocaBytes 32 $ \buf -> do + let cf = CFloat a + [C.exp| void { snprintf($(char* buf), 32, "%.16g", $(float cf)) } |] + string . fromString =<< peekCString buf + + _ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + file_eof = case args of + [RT_Lit (LInt64 0)] -> (fmap (\case { False -> 0; _ -> 1}) (liftIO (hIsEOF stdin))) >>= int + _ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + primReadString = case args of + [] -> liftIO getLine >>= (string . fromString) + _ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + primUSleep = case args of + [RT_Lit (LInt64 us)] -> liftIO $ threadDelay (fromIntegral us) >> pure RT_Unit + _ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + primError = case args of + [RT_Lit (LString msg)] -> liftIO (ioError $ userError $ Text.unpack msg) >> pure RT_Unit + _ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name + + boolean f t x = if x then t else f From a7cdbf85d59d88dcae4a00c8211eb1ec2b0fe8ba Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 11 Feb 2020 18:59:07 +0100 Subject: [PATCH 06/15] ES: added Reducer/Pure --- grin/grin.cabal | 1 + grin/src/Reducer/ExtendedSyntax/Pure.hs | 115 ++++++++++++++++++++++++ 2 files changed, 116 insertions(+) create mode 100644 grin/src/Reducer/ExtendedSyntax/Pure.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index e6f1687d..605f8027 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -119,6 +119,7 @@ library Pipeline.Optimizations Pipeline.Pipeline Reducer.ExtendedSyntax.Base + Reducer.ExtendedSyntax.Pure Reducer.ExtendedSyntax.PrimOps Reducer.Base Reducer.IO diff --git a/grin/src/Reducer/ExtendedSyntax/Pure.hs b/grin/src/Reducer/ExtendedSyntax/Pure.hs new file mode 100644 index 00000000..c6023e75 --- /dev/null +++ b/grin/src/Reducer/ExtendedSyntax/Pure.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE LambdaCase, TupleSections, BangPatterns, OverloadedStrings #-} +module Reducer.ExtendedSyntax.Pure (reduceFun) where + +import Text.Printf +import Text.PrettyPrint.ANSI.Leijen + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Control.Monad.State +import Control.Monad.Reader +import Text.Printf + +import Reducer.Base +import Reducer.PrimOps +import Grin.Grin +import Grin.Pretty + +prettyDebug :: Pretty a => a -> String +prettyDebug = show . plain . pretty + +-- models computer memory +data StoreMap + = StoreMap + { storeMap :: IntMap RTVal + , storeSize :: !Int + } + +emptyStore = StoreMap mempty 0 + +type Prog = Map Name Def +type GrinM = ReaderT Prog (StateT StoreMap IO) + +lookupStore :: Int -> StoreMap -> RTVal +lookupStore i s = IntMap.findWithDefault (error $ printf "missing location: %d" i) i $ storeMap s + +debug :: Bool +debug = False + +evalSimpleExp :: [External] -> Env -> SimpleExp -> GrinM RTVal +evalSimpleExp exts env s = do + when debug $ do + liftIO $ print s + void $ liftIO $ getLine + case s of + SApp n a -> do + let args = map (evalVal env) a + go a [] [] = a + go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys + go _ x y = error $ printf "invalid pattern for function: %s %s %s" n (prettyDebug x) (prettyDebug y) + if isExternalName exts n + then evalPrimOp n a args + else do + Def _ vars body <- reader $ Map.findWithDefault (error $ printf "unknown function: %s" n) n + evalExp exts (go env vars args) body + SReturn v -> pure $ evalVal env v + SStore v -> do + l <- gets storeSize + let v' = evalVal env v + modify' (\(StoreMap m s) -> StoreMap (IntMap.insert l v' m) (s+1)) + pure $ RT_Loc l + SFetchI n index -> case lookupEnv n env of + RT_Loc l -> gets $ (selectNodeItem index . lookupStore l) + x -> error $ printf "evalSimpleExp - Fetch expected location, got: %s" (prettyDebug x) + -- | FetchI Name Int -- fetch node component + SUpdate n v -> do + let v' = evalVal env v + case lookupEnv n env of + RT_Loc l -> get >>= \(StoreMap m _) -> case IntMap.member l m of + False -> error $ printf "evalSimpleExp - Update unknown location: %d" l + True -> modify' (\(StoreMap m s) -> StoreMap (IntMap.insert l v' m) s) >> pure RT_Unit + x -> error $ printf "evalSimpleExp - Update expected location, got: %s" (prettyDebug x) + SBlock a -> evalExp exts env a + + e@ECase{} -> evalExp exts env e -- FIXME: this should not be here!!! please investigate. + + x -> error $ printf "invalid simple expression %s" (prettyDebug x) + +evalExp :: [External] -> Env -> Exp -> GrinM RTVal +evalExp exts env = \case + EBind op pat exp -> do + v <- evalSimpleExp exts env op + when debug $ do + liftIO $ putStrLn $ unwords [show pat,":=",show v] + evalExp exts (bindPat env v pat) exp + ECase v alts -> + let defaultAlts = [exp | Alt DefaultPat exp <- alts] + defaultAlt = if length defaultAlts > 1 + then error "multiple default case alternative" + else take 1 defaultAlts + in case evalVal env v of + RT_ConstTagNode t l -> + let (vars,exp) = head $ [(b,exp) | Alt (NodePat a b) exp <- alts, a == t] ++ map ([],) defaultAlt ++ error (printf "evalExp - missing Case Node alternative for: %s" (prettyDebug t)) + go a [] [] = a + go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys + go _ x y = error $ printf "invalid pattern and constructor: %s %s %s" (prettyDebug t) (prettyDebug x) (prettyDebug y) + in evalExp + exts + (case vars of -- TODO: Better error check: If not default then parameters must match + [] -> {-defualt-} env + _ -> go env vars l) + exp + RT_ValTag t -> evalExp exts env $ head $ [exp | Alt (TagPat a) exp <- alts, a == t] ++ defaultAlt ++ error (printf "evalExp - missing Case Tag alternative for: %s" (prettyDebug t)) + RT_Lit l -> evalExp exts env $ head $ [exp | Alt (LitPat a) exp <- alts, a == l] ++ defaultAlt ++ error (printf "evalExp - missing Case Lit alternative for: %s" (prettyDebug l)) + x -> error $ printf "evalExp - invalid Case dispatch value: %s" (prettyDebug x) + exp -> evalSimpleExp exts env exp + +reduceFun :: Program -> Name -> IO RTVal +reduceFun (Program exts l) n = evalStateT (runReaderT (evalExp exts mempty e) m) emptyStore where + m = Map.fromList [(n,d) | d@(Def n _ _) <- l] + e = case Map.lookup n m of + Nothing -> error $ printf "missing function: %s" n + Just (Def _ [] a) -> a + _ -> error $ printf "function %s has arguments" n From 68129a84f1f7e181de7ca7dfee9fcf531452c40c Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 11 Feb 2020 19:49:08 +0100 Subject: [PATCH 07/15] ES: fixed Reducer/Pure + additional modifications --- grin/src/Reducer/ExtendedSyntax/Base.hs | 8 +-- grin/src/Reducer/ExtendedSyntax/PrimOps.hs | 7 ++- grin/src/Reducer/ExtendedSyntax/Pure.hs | 72 ++++++++++++---------- 3 files changed, 46 insertions(+), 41 deletions(-) diff --git a/grin/src/Reducer/ExtendedSyntax/Base.hs b/grin/src/Reducer/ExtendedSyntax/Base.hs index 383fae4a..757d66f1 100644 --- a/grin/src/Reducer/ExtendedSyntax/Base.hs +++ b/grin/src/Reducer/ExtendedSyntax/Base.hs @@ -51,14 +51,14 @@ bindPat env !val bPat = case bPat of -> env' <> newVars _ -> error $ "bindPat - illegal value for ConstTagNode: " ++ show val ++ " vs " ++ show (PP p) -lookupEnv :: Name -> Env -> RTVal -lookupEnv n env = Map.findWithDefault (error $ "missing variable: " ++ unpackName n) n env +evalVar :: Env -> Name -> RTVal +evalVar env n = Map.findWithDefault (error $ "missing variable: " ++ unpackName n) n env evalVal :: Env -> Val -> RTVal evalVal env = \case Lit lit -> RT_Lit lit - Var n -> lookupEnv n env - ConstTagNode t a -> RT_ConstTagNode t $ map (`lookupEnv` env) a + Var n -> evalVar env n + ConstTagNode t a -> RT_ConstTagNode t $ map (evalVar env) a Unit -> RT_Unit Undefined t -> RT_Undefined x -> error $ "evalVal: " ++ show x diff --git a/grin/src/Reducer/ExtendedSyntax/PrimOps.hs b/grin/src/Reducer/ExtendedSyntax/PrimOps.hs index 6f9a7e26..126e560d 100644 --- a/grin/src/Reducer/ExtendedSyntax/PrimOps.hs +++ b/grin/src/Reducer/ExtendedSyntax/PrimOps.hs @@ -12,11 +12,9 @@ import qualified Language.C.Inline.Unsafe as CU import Foreign.Marshal.Alloc import Foreign.C.String -import Reducer.Base import Data.Bits (shift) import Data.Char (chr, ord) -import Grin.Grin import Data.Map.Strict as Map import Data.String (fromString) import Data.Functor.Infix ((<$$>)) @@ -28,6 +26,9 @@ import Data.Bits import System.IO (hIsEOF, stdin) import System.IO.Unsafe +import Grin.ExtendedSyntax.Grin +import Reducer.ExtendedSyntax.Base + C.include "" C.include "" @@ -37,7 +38,7 @@ primLiteralPrint _ _ [RT_Lit (LString a)] = liftIO (putStr (Text.unpack a)) >> p primLiteralPrint ctx ps x = error $ Prelude.unwords ["primLiteralPrint", ctx, "- invalid arguments:", show ps, " - ", show x] -evalPrimOp :: MonadIO m => Name -> [Val] -> [RTVal] -> m RTVal +evalPrimOp :: MonadIO m => Name -> [Name] -> [RTVal] -> m RTVal evalPrimOp name params args = case name of "_prim_int_print" -> primLiteralPrint "int" params args "_prim_string_print" -> primLiteralPrint "string" params args diff --git a/grin/src/Reducer/ExtendedSyntax/Pure.hs b/grin/src/Reducer/ExtendedSyntax/Pure.hs index c6023e75..59f83a5f 100644 --- a/grin/src/Reducer/ExtendedSyntax/Pure.hs +++ b/grin/src/Reducer/ExtendedSyntax/Pure.hs @@ -8,14 +8,15 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap +import Data.Foldable (fold) import Control.Monad.State import Control.Monad.Reader import Text.Printf -import Reducer.Base -import Reducer.PrimOps -import Grin.Grin -import Grin.Pretty +import Reducer.ExtendedSyntax.Base +import Reducer.ExtendedSyntax.PrimOps +import Grin.ExtendedSyntax.Grin +import Grin.ExtendedSyntax.Pretty prettyDebug :: Pretty a => a -> String prettyDebug = show . plain . pretty @@ -45,28 +46,27 @@ evalSimpleExp exts env s = do void $ liftIO $ getLine case s of SApp n a -> do - let args = map (evalVal env) a - go a [] [] = a - go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys - go _ x y = error $ printf "invalid pattern for function: %s %s %s" n (prettyDebug x) (prettyDebug y) - if isExternalName exts n - then evalPrimOp n a args - else do - Def _ vars body <- reader $ Map.findWithDefault (error $ printf "unknown function: %s" n) n - evalExp exts (go env vars args) body + let args = map (evalVar env) a + go a [] [] = a + go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys + go _ x y = error $ printf "invalid pattern for function: %s %s %s" n (prettyDebug x) (prettyDebug y) + if isExternalName exts n + then evalPrimOp n a args + else do + Def _ vars body <- reader $ Map.findWithDefault (error $ printf "unknown function: %s" n) n + evalExp exts (go env vars args) body SReturn v -> pure $ evalVal env v SStore v -> do l <- gets storeSize - let v' = evalVal env v + let v' = evalVar env v modify' (\(StoreMap m s) -> StoreMap (IntMap.insert l v' m) (s+1)) pure $ RT_Loc l - SFetchI n index -> case lookupEnv n env of - RT_Loc l -> gets $ (selectNodeItem index . lookupStore l) + SFetch ptr -> case evalVar env ptr of + RT_Loc l -> gets $ lookupStore l x -> error $ printf "evalSimpleExp - Fetch expected location, got: %s" (prettyDebug x) - -- | FetchI Name Int -- fetch node component SUpdate n v -> do - let v' = evalVal env v - case lookupEnv n env of + let v' = evalVar env v + case evalVar env n of RT_Loc l -> get >>= \(StoreMap m _) -> case IntMap.member l m of False -> error $ printf "evalSimpleExp - Update unknown location: %d" l True -> modify' (\(StoreMap m s) -> StoreMap (IntMap.insert l v' m) s) >> pure RT_Unit @@ -84,25 +84,29 @@ evalExp exts env = \case when debug $ do liftIO $ putStrLn $ unwords [show pat,":=",show v] evalExp exts (bindPat env v pat) exp - ECase v alts -> - let defaultAlts = [exp | Alt DefaultPat exp <- alts] + ECase scrut alts -> do + let defaultAlts = [exp | Alt DefaultPat _ exp <- alts] defaultAlt = if length defaultAlts > 1 then error "multiple default case alternative" else take 1 defaultAlts - in case evalVal env v of + + altNames = [ name | Alt _ name _ <- alts ] + scrutVal = evalVar env scrut + boundAltNames = fold $ map (`Map.singleton` scrutVal) altNames + env' = env <> boundAltNames + case scrutVal of RT_ConstTagNode t l -> - let (vars,exp) = head $ [(b,exp) | Alt (NodePat a b) exp <- alts, a == t] ++ map ([],) defaultAlt ++ error (printf "evalExp - missing Case Node alternative for: %s" (prettyDebug t)) - go a [] [] = a - go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys - go _ x y = error $ printf "invalid pattern and constructor: %s %s %s" (prettyDebug t) (prettyDebug x) (prettyDebug y) - in evalExp - exts - (case vars of -- TODO: Better error check: If not default then parameters must match - [] -> {-defualt-} env - _ -> go env vars l) - exp - RT_ValTag t -> evalExp exts env $ head $ [exp | Alt (TagPat a) exp <- alts, a == t] ++ defaultAlt ++ error (printf "evalExp - missing Case Tag alternative for: %s" (prettyDebug t)) - RT_Lit l -> evalExp exts env $ head $ [exp | Alt (LitPat a) exp <- alts, a == l] ++ defaultAlt ++ error (printf "evalExp - missing Case Lit alternative for: %s" (prettyDebug l)) + let (vars,exp) = head $ [(b,exp) | Alt (NodePat a b) _ exp <- alts, a == t] ++ map ([],) defaultAlt ++ error (printf "evalExp - missing Case Node alternative for: %s" (prettyDebug t)) + go a [] [] = a + go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys + go _ x y = error $ printf "invalid pattern and constructor: %s %s %s" (prettyDebug t) (prettyDebug x) (prettyDebug y) + in evalExp + exts + (case vars of -- TODO: Better error check: If not default then parameters must match + [] -> {-default-} env' + _ -> go env' vars l) + exp + RT_Lit l -> evalExp exts env $ head $ [exp | Alt (LitPat a) _ exp <- alts, a == l] ++ defaultAlt ++ error (printf "evalExp - missing Case Lit alternative for: %s" (prettyDebug l)) x -> error $ printf "evalExp - invalid Case dispatch value: %s" (prettyDebug x) exp -> evalSimpleExp exts env exp From 5cbe74db9b43e5cd48276e86d12e8c12cb34b359 Mon Sep 17 00:00:00 2001 From: anabra Date: Wed, 12 Feb 2020 17:13:05 +0100 Subject: [PATCH 08/15] ES: added Reducer/Pure tests --- grin/grin.cabal | 1 + grin/test/Reducer/ExtendedSyntax/PureSpec.hs | 194 +++++++++++++++++++ 2 files changed, 195 insertions(+) create mode 100644 grin/test/Reducer/ExtendedSyntax/PureSpec.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 605f8027..3051dc58 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -393,6 +393,7 @@ test-suite grin-test Test.Hspec.PipelineExample Reducer.ExtendedSyntax.BaseSpec + Reducer.ExtendedSyntax.PureSpec default-language: Haskell2010 benchmark grin-benchmark diff --git a/grin/test/Reducer/ExtendedSyntax/PureSpec.hs b/grin/test/Reducer/ExtendedSyntax/PureSpec.hs new file mode 100644 index 00000000..f0a179be --- /dev/null +++ b/grin/test/Reducer/ExtendedSyntax/PureSpec.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE QuasiQuotes #-} +module Reducer.ExtendedSyntax.PureSpec where + +import Reducer.ExtendedSyntax.Base +import Reducer.ExtendedSyntax.Pure + +import Data.Text +import qualified Data.Map as Map + +import Test.Hspec + +import Test.ExtendedSyntax.Assertions +import Grin.ExtendedSyntax.TH +import Grin.ExtendedSyntax.Syntax +import Grin.ExtendedSyntax.TypeEnvDefs +import Grin.ExtendedSyntax.PrimOpsPrelude +import Grin.ExtendedSyntax.Pretty (KeyValueMap(..)) + +runTests :: IO () +runTests = hspec spec + +spec :: Spec +spec = do + describe "Pure reducer" $ do + + describe "some primops" $ do + it "int add & int gt" $ do + let program = withPrimPrelude [prog| + grinMain = + n <- pure 2 + m <- pure 5 + k <- _prim_int_add m n + b <- _prim_int_gt m n + case b of + #True @ alt1 -> pure k + #False @ alt2 -> pure 0 + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 7) + + describe "case expressions" $ do + it "literal scrutinee" $ do + let program = [prog| + grinMain = + n <- pure #True + case n of + #True @ alt1 -> pure alt1 + #False @ alt2 -> pure alt2 + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LBool True) + + it "node scrutinee" $ do + let program = [prog| + grinMain = + n <- pure (COne) + case n of + (COne) @ alt1 -> pure 1 + #default @ alt2 -> pure 0 + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 1) + + describe "scoping" $ do + it "multiple independent calls" $ do + let program = [prog| + grinMain = + one <- pure 1 + two <- pure 2 + n1 <- pure (CInt one) + n2 <- pure (CInt two) + _1 <- foo n1 + foo n2 + + foo x = + (CInt k) @ _2 <- pure x + pure k + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 2) + + it "recursive calls" $ do + let program = [prog| + grinMain = + true <- pure #True + one <- pure 1 + n1 <- pure (CInt one) + foo true n1 + + foo b x = + (CInt k) @ _2 <- pure x + case b of + #True @ alt1 -> + false <- pure #False + two <- pure 2 + n2 <- pure (CInt two) + foo false n2 + #False @ alt2 -> + pure k + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 2) + + describe "complex" $ do + + it "sum_simple" $ do + reduceFun sumSimple "grinMain" `shouldReturn` RT_Lit (LInt64 50005000) + +sumSimple :: Exp +sumSimple = withPrimPrelude [prog| + grinMain = + y.0 <- pure 1 + v.0 <- pure (CInt y.0) + t1 <- store v.0 + y.1 <- pure 10000 + v.1 <- pure (CInt y.1) + t2 <- store v.1 + v.2 <- pure (Fupto t1 t2) + t3 <- store v.2 + v.3 <- pure (Fsum t3) + t4 <- store v.3 + (CInt r') @ p.0 <- eval $ t4 + pure r' + + grinMain2 = + c.1 <- pure 1 + c.2 <- pure 3 + c.3 <- pure 0 + j.1 <- pure (CInt c.1) + j.2 <- pure (CInt c.2) + j.3 <- pure (CInt c.3) + g.1 <- store j.1 + g.2 <- store j.2 + g.3 <- store j.3 + + k.0 <- pure (CNil) + t.0 <- store k.0 + k.1 <- pure (CCons g.1 t.0) + t.1 <- store k.1 + k.2 <- pure (CCons g.2 t.1) + t.2 <- store k.2 + k.3 <- pure (CCons g.3 t.2) + t.3 <- store k.3 + + w.1 <- pure (Fsum t.2) + t.4 <- store w.1 + r.1 <- eval t.4 + pure r.1 + + upto m n = + (CInt m') @ p.2 <- eval $ m + (CInt n') @ p.1 <- eval $ n + b' <- _prim_int_gt $ m' n' + case b' of + #True @ alt.0 -> + v.4 <- pure (CNil) + pure v.4 + #False @ alt.1 -> + x.7 <- pure 1 + m1' <- _prim_int_add $ m' x.7 + v.5 <- pure (CInt m1') + m1 <- store v.5 + v.6 <- pure (Fupto m1 n) + p <- store v.6 + v.7 <- pure (CCons m p) + pure v.7 + + sum l = + l2 <- eval $ l + case l2 of + (CNil) @ alt.2 -> + y.10 <- pure 0 + v.8 <- pure (CInt y.10) + pure v.8 + (CCons x xs) @ alt.3 -> + (CInt x') @ p.4 <- eval $ x + (CInt s') @ p.3 <- sum $ xs + ax' <- _prim_int_add $ x' s' + v.9 <- pure (CInt ax') + pure v.9 + + eval q = + v <- fetch q + case v of + (CInt x'1) @ alt.4 -> + pure v + (CNil) @ alt.5 -> + pure v + (CCons y ys) @ alt.6 -> + pure v + (Fupto a b) @ alt.7 -> + w <- upto $ a b + p.5 <- update q w + pure w + (Fsum c) @ alt.8 -> + z <- sum $ c + p.6 <- update q z + pure z + |] From ea884d62b6682bf3ddf06eb1e044417a2357b06e Mon Sep 17 00:00:00 2001 From: anabra Date: Wed, 12 Feb 2020 17:23:05 +0100 Subject: [PATCH 09/15] ES: improved Reducer/Base tests --- grin/test/Reducer/ExtendedSyntax/BaseSpec.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/grin/test/Reducer/ExtendedSyntax/BaseSpec.hs b/grin/test/Reducer/ExtendedSyntax/BaseSpec.hs index 2c71abf2..0628b6f6 100644 --- a/grin/test/Reducer/ExtendedSyntax/BaseSpec.hs +++ b/grin/test/Reducer/ExtendedSyntax/BaseSpec.hs @@ -83,3 +83,18 @@ spec = do expected = KV $ initEnv <> Map.fromList [(varName, nodeRtVal), (argName, argRtVal)] result `sameAs` expected + + it "interprets scoped as-patterns correctly" $ do + let varName = "v" + argName = "a" + tag = Tag C "Float" + argRtVal = RT_Lit $ LFloat 0 + argRtVal' = RT_Lit $ LFloat 42 + nodeRtVal = RT_ConstTagNode tag [argRtVal] + nodeRtVal' = RT_ConstTagNode tag [argRtVal'] + initEnv = Map.singleton "a" nodeRtVal + + let result = KV $ bindPat initEnv nodeRtVal' (AsPat tag [argName] varName) + expected = KV $ Map.fromList [(varName, nodeRtVal'), (argName, argRtVal')] <> initEnv + + result `sameAs` expected From dc07497449cc05664f5c27c53b02bddd9270bd86 Mon Sep 17 00:00:00 2001 From: anabra Date: Wed, 12 Feb 2020 17:23:49 +0100 Subject: [PATCH 10/15] ES: fixed Base and Pure reducers --- grin/src/Reducer/ExtendedSyntax/Base.hs | 3 +-- grin/src/Reducer/ExtendedSyntax/Pure.hs | 4 ++-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/grin/src/Reducer/ExtendedSyntax/Base.hs b/grin/src/Reducer/ExtendedSyntax/Base.hs index 757d66f1..4c34d1dc 100644 --- a/grin/src/Reducer/ExtendedSyntax/Base.hs +++ b/grin/src/Reducer/ExtendedSyntax/Base.hs @@ -48,7 +48,7 @@ bindPat env !val bPat = case bPat of | tag == vtag , env' <- Map.insert var val env , newVars <- fold $ zipWith Map.singleton args vargs - -> env' <> newVars + -> newVars <> env' _ -> error $ "bindPat - illegal value for ConstTagNode: " ++ show val ++ " vs " ++ show (PP p) evalVar :: Env -> Name -> RTVal @@ -61,4 +61,3 @@ evalVal env = \case ConstTagNode t a -> RT_ConstTagNode t $ map (evalVar env) a Unit -> RT_Unit Undefined t -> RT_Undefined - x -> error $ "evalVal: " ++ show x diff --git a/grin/src/Reducer/ExtendedSyntax/Pure.hs b/grin/src/Reducer/ExtendedSyntax/Pure.hs index 59f83a5f..b2a6c384 100644 --- a/grin/src/Reducer/ExtendedSyntax/Pure.hs +++ b/grin/src/Reducer/ExtendedSyntax/Pure.hs @@ -93,7 +93,7 @@ evalExp exts env = \case altNames = [ name | Alt _ name _ <- alts ] scrutVal = evalVar env scrut boundAltNames = fold $ map (`Map.singleton` scrutVal) altNames - env' = env <> boundAltNames + env' = boundAltNames <> env case scrutVal of RT_ConstTagNode t l -> let (vars,exp) = head $ [(b,exp) | Alt (NodePat a b) _ exp <- alts, a == t] ++ map ([],) defaultAlt ++ error (printf "evalExp - missing Case Node alternative for: %s" (prettyDebug t)) @@ -106,7 +106,7 @@ evalExp exts env = \case [] -> {-default-} env' _ -> go env' vars l) exp - RT_Lit l -> evalExp exts env $ head $ [exp | Alt (LitPat a) _ exp <- alts, a == l] ++ defaultAlt ++ error (printf "evalExp - missing Case Lit alternative for: %s" (prettyDebug l)) + RT_Lit l -> evalExp exts env' $ head $ [exp | Alt (LitPat a) _ exp <- alts, a == l] ++ defaultAlt ++ error (printf "evalExp - missing Case Lit alternative for: %s" (prettyDebug l)) x -> error $ printf "evalExp - invalid Case dispatch value: %s" (prettyDebug x) exp -> evalSimpleExp exts env exp From c1baeadcc88edea44eb0ee5f3613cfe95373242d Mon Sep 17 00:00:00 2001 From: anabra Date: Wed, 12 Feb 2020 21:19:47 +0100 Subject: [PATCH 11/15] ES: added Reducer/IO --- grin/grin.cabal | 1 + grin/src/Reducer/ExtendedSyntax/IO.hs | 130 ++++++++++++++++++++++++++ 2 files changed, 131 insertions(+) create mode 100644 grin/src/Reducer/ExtendedSyntax/IO.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 3051dc58..a3ba96ca 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -119,6 +119,7 @@ library Pipeline.Optimizations Pipeline.Pipeline Reducer.ExtendedSyntax.Base + Reducer.ExtendedSyntax.IO Reducer.ExtendedSyntax.Pure Reducer.ExtendedSyntax.PrimOps Reducer.Base diff --git a/grin/src/Reducer/ExtendedSyntax/IO.hs b/grin/src/Reducer/ExtendedSyntax/IO.hs new file mode 100644 index 00000000..861eaa97 --- /dev/null +++ b/grin/src/Reducer/ExtendedSyntax/IO.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE LambdaCase, TupleSections, BangPatterns, OverloadedStrings #-} +{-# LANGUAGE Strict #-} +module Reducer.ExtendedSyntax.IO (reduceFun) where + +import Debug.Trace + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Control.Monad.State +import Control.Monad.Reader + +import Data.Vector.Mutable as Vector +import Data.IORef +import Control.Monad.RWS.Strict hiding (Alt) + +import Reducer.Base +import Reducer.PrimOps +import Grin.Grin + +-- models computer memory +data IOStore = IOStore + { sVector :: IOVector RTVal + , sLast :: IORef Int + } + +emptyStore1 :: IO IOStore +emptyStore1 = IOStore <$> new (10 * 1024 * 1024) <*> newIORef 0 + +type Prog = Map Name Def +type GrinS a = RWST Prog () IOStore IO a + +getProg :: GrinS Prog +getProg = reader id + +getStore :: GrinS IOStore +getStore = get + +-- TODO: Resize +insertStore :: RTVal -> GrinS Int +insertStore x = do + (IOStore v l) <- getStore + lift $ do + n <- readIORef l + Vector.write v n x + writeIORef l (n + 1) + pure n + +lookupStore :: Int -> GrinS RTVal +lookupStore n = do + (IOStore v _) <- getStore + lift $ do + Vector.read v n + +updateStore :: Int -> RTVal -> GrinS () +updateStore n x = do + (IOStore v _) <- getStore + lift $ do + Vector.write v n x + +pprint exp = trace (f exp) exp where + f = \case + EBind a b _ -> unwords ["Bind", "{",show a,"} to {", show b, "}"] + ECase a _ -> unwords ["Case", show a] + SBlock {} -> "Block" + a -> show a + + +evalExp :: [External] -> Env -> Exp -> GrinS RTVal +evalExp exts env exp = case {-pprint-} exp of + EBind op pat exp -> evalSimpleExp exts env op >>= \v -> evalExp exts (bindPat env v pat) exp + ECase v alts -> + let defaultAlts = [exp | Alt DefaultPat exp <- alts] + defaultAlt = if Prelude.length defaultAlts > 1 + then error "multiple default case alternative" + else Prelude.take 1 defaultAlts + in case evalVal env v of + RT_ConstTagNode t l -> + let (vars,exp) = head $ [(b,exp) | Alt (NodePat a b) exp <- alts, a == t] ++ map ([],) defaultAlt ++ error ("evalExp - missing Case Node alternative for: " ++ show t) + go a [] [] = a + go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys + go _ x y = error $ "invalid pattern and constructor: " ++ show (t,x,y) + in evalExp exts (go env vars l) exp + RT_ValTag t -> evalExp exts env $ head $ [exp | Alt (TagPat a) exp <- alts, a == t] ++ defaultAlt ++ error ("evalExp - missing Case Tag alternative for: " ++ show t) + RT_Lit l -> evalExp exts env $ head $ [exp | Alt (LitPat a) exp <- alts, a == l] ++ defaultAlt ++ error ("evalExp - missing Case Lit alternative for: " ++ show l) + x -> error $ "evalExp - invalid Case dispatch value: " ++ show x + exp -> evalSimpleExp exts env exp + +evalSimpleExp :: [External] -> Env -> SimpleExp -> GrinS RTVal +evalSimpleExp exts env = \case + SApp n a -> do + let args = map (evalVal env) a + go a [] [] = a + go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys + go _ x y = error $ "invalid pattern for function: " ++ show (n,x,y) + if isExternalName exts n + then evalPrimOp n [] args + else do + Def _ vars body <- (Map.findWithDefault (error $ "unknown function: " ++ unpackName n) n) <$> getProg + evalExp exts (go env vars args) body + SReturn v -> pure $ evalVal env v + SStore v -> do + let v' = evalVal env v + l <- insertStore v' + -- modify' (\(StoreMap m s) -> StoreMap (IntMap.insert l v' m) (s+1)) + pure $ RT_Loc l + SFetchI n index -> case lookupEnv n env of + RT_Loc l -> selectNodeItem index <$> lookupStore l + x -> error $ "evalSimpleExp - Fetch expected location, got: " ++ show x +-- | FetchI Name Int -- fetch node component + SUpdate n v -> do + let v' = evalVal env v + case lookupEnv n env of + RT_Loc l -> updateStore l v' >> pure v' + x -> error $ "evalSimpleExp - Update expected location, got: " ++ show x + SBlock a -> evalExp exts env a + x -> error $ "evalSimpleExp: " ++ show x + +reduceFun :: Program -> Name -> IO RTVal +reduceFun (Program exts l) n = do + store <- emptyStore1 + (val, _, _) <- runRWST (evalExp exts mempty e) m store + pure val + where + m = Map.fromList [(n,d) | d@(Def n _ _) <- l] + e = case Map.lookup n m of + Nothing -> error $ "missing function: " ++ unpackName n + Just (Def _ [] a) -> a + _ -> error $ "function " ++ unpackName n ++ " has arguments" From 7c896c596cceb551960a8da57dac66fa2e63ff4e Mon Sep 17 00:00:00 2001 From: anabra Date: Wed, 12 Feb 2020 21:51:35 +0100 Subject: [PATCH 12/15] ES: fixed Reducer/IO --- grin/src/Reducer/ExtendedSyntax/IO.hs | 54 ++++++++++++++------------- 1 file changed, 28 insertions(+), 26 deletions(-) diff --git a/grin/src/Reducer/ExtendedSyntax/IO.hs b/grin/src/Reducer/ExtendedSyntax/IO.hs index 861eaa97..032d85e2 100644 --- a/grin/src/Reducer/ExtendedSyntax/IO.hs +++ b/grin/src/Reducer/ExtendedSyntax/IO.hs @@ -4,20 +4,17 @@ module Reducer.ExtendedSyntax.IO (reduceFun) where import Debug.Trace +import Control.Monad.RWS.Strict hiding (Alt) + +import Data.Foldable (fold) import Data.Map (Map) import qualified Data.Map as Map -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IntMap -import Control.Monad.State -import Control.Monad.Reader - import Data.Vector.Mutable as Vector import Data.IORef -import Control.Monad.RWS.Strict hiding (Alt) -import Reducer.Base -import Reducer.PrimOps -import Grin.Grin +import Reducer.ExtendedSyntax.Base +import Reducer.ExtendedSyntax.PrimOps +import Grin.ExtendedSyntax.Grin -- models computer memory data IOStore = IOStore @@ -70,27 +67,32 @@ pprint exp = trace (f exp) exp where evalExp :: [External] -> Env -> Exp -> GrinS RTVal evalExp exts env exp = case {-pprint-} exp of EBind op pat exp -> evalSimpleExp exts env op >>= \v -> evalExp exts (bindPat env v pat) exp - ECase v alts -> - let defaultAlts = [exp | Alt DefaultPat exp <- alts] + -- TODO: + ECase scrut alts -> + let defaultAlts = [exp | Alt DefaultPat _ exp <- alts] defaultAlt = if Prelude.length defaultAlts > 1 then error "multiple default case alternative" else Prelude.take 1 defaultAlts - in case evalVal env v of + + altNames = [ name | Alt _ name _ <- alts ] + scrutVal = evalVar env scrut + boundAltNames = fold $ map (`Map.singleton` scrutVal) altNames + env' = boundAltNames <> env + in case evalVar env scrut of RT_ConstTagNode t l -> - let (vars,exp) = head $ [(b,exp) | Alt (NodePat a b) exp <- alts, a == t] ++ map ([],) defaultAlt ++ error ("evalExp - missing Case Node alternative for: " ++ show t) - go a [] [] = a - go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys - go _ x y = error $ "invalid pattern and constructor: " ++ show (t,x,y) - in evalExp exts (go env vars l) exp - RT_ValTag t -> evalExp exts env $ head $ [exp | Alt (TagPat a) exp <- alts, a == t] ++ defaultAlt ++ error ("evalExp - missing Case Tag alternative for: " ++ show t) - RT_Lit l -> evalExp exts env $ head $ [exp | Alt (LitPat a) exp <- alts, a == l] ++ defaultAlt ++ error ("evalExp - missing Case Lit alternative for: " ++ show l) + let (vars,exp) = head $ [(b,exp) | Alt (NodePat a b) _ exp <- alts, a == t] ++ map ([],) defaultAlt ++ error ("evalExp - missing Case Node alternative for: " ++ show t) + go a [] [] = a + go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys + go _ x y = error $ "invalid pattern and constructor: " ++ show (t,x,y) + in evalExp exts (go env' vars l) exp + RT_Lit l -> evalExp exts env' $ head $ [exp | Alt (LitPat a) _ exp <- alts, a == l] ++ defaultAlt ++ error ("evalExp - missing Case Lit alternative for: " ++ show l) x -> error $ "evalExp - invalid Case dispatch value: " ++ show x exp -> evalSimpleExp exts env exp evalSimpleExp :: [External] -> Env -> SimpleExp -> GrinS RTVal evalSimpleExp exts env = \case SApp n a -> do - let args = map (evalVal env) a + let args = map (evalVar env) a go a [] [] = a go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys go _ x y = error $ "invalid pattern for function: " ++ show (n,x,y) @@ -101,17 +103,17 @@ evalSimpleExp exts env = \case evalExp exts (go env vars args) body SReturn v -> pure $ evalVal env v SStore v -> do - let v' = evalVal env v + let v' = evalVar env v l <- insertStore v' -- modify' (\(StoreMap m s) -> StoreMap (IntMap.insert l v' m) (s+1)) pure $ RT_Loc l - SFetchI n index -> case lookupEnv n env of - RT_Loc l -> selectNodeItem index <$> lookupStore l + SFetch ptr -> case evalVar env ptr of + RT_Loc l -> lookupStore l x -> error $ "evalSimpleExp - Fetch expected location, got: " ++ show x -- | FetchI Name Int -- fetch node component - SUpdate n v -> do - let v' = evalVal env v - case lookupEnv n env of + SUpdate ptr var -> do + let v' = evalVar env var + case evalVar env ptr of RT_Loc l -> updateStore l v' >> pure v' x -> error $ "evalSimpleExp - Update expected location, got: " ++ show x SBlock a -> evalExp exts env a From 3c053de918557f163901b1e1cd823a98fc708433 Mon Sep 17 00:00:00 2001 From: anabra Date: Wed, 12 Feb 2020 22:04:06 +0100 Subject: [PATCH 13/15] ES: added some more tests to Reducer/Base --- grin/test/Reducer/ExtendedSyntax/PureSpec.hs | 27 +++++++++++++++++--- 1 file changed, 24 insertions(+), 3 deletions(-) diff --git a/grin/test/Reducer/ExtendedSyntax/PureSpec.hs b/grin/test/Reducer/ExtendedSyntax/PureSpec.hs index f0a179be..59be2555 100644 --- a/grin/test/Reducer/ExtendedSyntax/PureSpec.hs +++ b/grin/test/Reducer/ExtendedSyntax/PureSpec.hs @@ -9,12 +9,9 @@ import qualified Data.Map as Map import Test.Hspec -import Test.ExtendedSyntax.Assertions import Grin.ExtendedSyntax.TH import Grin.ExtendedSyntax.Syntax -import Grin.ExtendedSyntax.TypeEnvDefs import Grin.ExtendedSyntax.PrimOpsPrelude -import Grin.ExtendedSyntax.Pretty (KeyValueMap(..)) runTests :: IO () runTests = hspec spec @@ -37,6 +34,30 @@ spec = do |] reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 7) + describe "as-patterns" $ do + it "pure" $ do + let program = withPrimPrelude [prog| + grinMain = + k0 <- pure 0 + v0 <- pure (CInt k0) + (CInt k1) @ v1 <- pure v0 + (CInt k2) @ _1 <- pure v1 + pure k2 + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 0) + + it "fetch" $ do + let program = withPrimPrelude [prog| + grinMain = + k0 <- pure 0 + v0 <- pure (CInt k0) + p0 <- store v0 + (CInt k1) @ v1 <- fetch p0 + (CInt k2) @ _1 <- pure v1 + pure k2 + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 0) + describe "case expressions" $ do it "literal scrutinee" $ do let program = [prog| From 8117956873279d9ec05a1be889efac09885ceb10 Mon Sep 17 00:00:00 2001 From: anabra Date: Wed, 12 Feb 2020 22:08:06 +0100 Subject: [PATCH 14/15] ES: added tests to Reducer/IO --- grin/grin.cabal | 1 + grin/test/Reducer/ExtendedSyntax/IOSpec.hs | 218 +++++++++++++++++++++ 2 files changed, 219 insertions(+) create mode 100644 grin/test/Reducer/ExtendedSyntax/IOSpec.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index a3ba96ca..01c8fd8c 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -394,6 +394,7 @@ test-suite grin-test Test.Hspec.PipelineExample Reducer.ExtendedSyntax.BaseSpec + Reducer.ExtendedSyntax.IOSpec Reducer.ExtendedSyntax.PureSpec default-language: Haskell2010 diff --git a/grin/test/Reducer/ExtendedSyntax/IOSpec.hs b/grin/test/Reducer/ExtendedSyntax/IOSpec.hs new file mode 100644 index 00000000..31e0b57d --- /dev/null +++ b/grin/test/Reducer/ExtendedSyntax/IOSpec.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE QuasiQuotes #-} +module Reducer.ExtendedSyntax.IOSpec where + +import Reducer.ExtendedSyntax.Base +import Reducer.ExtendedSyntax.IO + +import Data.Text +import qualified Data.Map as Map + +import Test.Hspec + +import Grin.ExtendedSyntax.TH +import Grin.ExtendedSyntax.Syntax +import Grin.ExtendedSyntax.PrimOpsPrelude + +runTests :: IO () +runTests = hspec spec + +-- TODO: We could implement a parametric reducer test suite. +-- It would reduce the GRIN program with a user-supplied function. + +spec :: Spec +spec = do + describe "Pure reducer" $ do + + describe "some primops" $ do + it "int add & int gt" $ do + let program = withPrimPrelude [prog| + grinMain = + n <- pure 2 + m <- pure 5 + k <- _prim_int_add m n + b <- _prim_int_gt m n + case b of + #True @ alt1 -> pure k + #False @ alt2 -> pure 0 + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 7) + + describe "as-patterns" $ do + it "pure" $ do + let program = withPrimPrelude [prog| + grinMain = + k0 <- pure 0 + v0 <- pure (CInt k0) + (CInt k1) @ v1 <- pure v0 + (CInt k2) @ _1 <- pure v1 + pure k2 + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 0) + + it "fetch" $ do + let program = withPrimPrelude [prog| + grinMain = + k0 <- pure 0 + v0 <- pure (CInt k0) + p0 <- store v0 + (CInt k1) @ v1 <- fetch p0 + (CInt k2) @ _1 <- pure v1 + pure k2 + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 0) + + describe "case expressions" $ do + it "literal scrutinee" $ do + let program = [prog| + grinMain = + n <- pure #True + case n of + #True @ alt1 -> pure alt1 + #False @ alt2 -> pure alt2 + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LBool True) + + it "node scrutinee" $ do + let program = [prog| + grinMain = + n <- pure (COne) + case n of + (COne) @ alt1 -> pure 1 + #default @ alt2 -> pure 0 + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 1) + + describe "scoping" $ do + it "multiple independent calls" $ do + let program = [prog| + grinMain = + one <- pure 1 + two <- pure 2 + n1 <- pure (CInt one) + n2 <- pure (CInt two) + _1 <- foo n1 + foo n2 + + foo x = + (CInt k) @ _2 <- pure x + pure k + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 2) + + it "recursive calls" $ do + let program = [prog| + grinMain = + true <- pure #True + one <- pure 1 + n1 <- pure (CInt one) + foo true n1 + + foo b x = + (CInt k) @ _2 <- pure x + case b of + #True @ alt1 -> + false <- pure #False + two <- pure 2 + n2 <- pure (CInt two) + foo false n2 + #False @ alt2 -> + pure k + |] + reduceFun program "grinMain" `shouldReturn` RT_Lit (LInt64 2) + + describe "complex" $ do + + it "sum_simple" $ do + reduceFun sumSimple "grinMain" `shouldReturn` RT_Lit (LInt64 50005000) + +sumSimple :: Exp +sumSimple = withPrimPrelude [prog| + grinMain = + y.0 <- pure 1 + v.0 <- pure (CInt y.0) + t1 <- store v.0 + y.1 <- pure 10000 + v.1 <- pure (CInt y.1) + t2 <- store v.1 + v.2 <- pure (Fupto t1 t2) + t3 <- store v.2 + v.3 <- pure (Fsum t3) + t4 <- store v.3 + (CInt r') @ p.0 <- eval $ t4 + pure r' + + grinMain2 = + c.1 <- pure 1 + c.2 <- pure 3 + c.3 <- pure 0 + j.1 <- pure (CInt c.1) + j.2 <- pure (CInt c.2) + j.3 <- pure (CInt c.3) + g.1 <- store j.1 + g.2 <- store j.2 + g.3 <- store j.3 + + k.0 <- pure (CNil) + t.0 <- store k.0 + k.1 <- pure (CCons g.1 t.0) + t.1 <- store k.1 + k.2 <- pure (CCons g.2 t.1) + t.2 <- store k.2 + k.3 <- pure (CCons g.3 t.2) + t.3 <- store k.3 + + w.1 <- pure (Fsum t.2) + t.4 <- store w.1 + r.1 <- eval t.4 + pure r.1 + + upto m n = + (CInt m') @ p.2 <- eval $ m + (CInt n') @ p.1 <- eval $ n + b' <- _prim_int_gt $ m' n' + case b' of + #True @ alt.0 -> + v.4 <- pure (CNil) + pure v.4 + #False @ alt.1 -> + x.7 <- pure 1 + m1' <- _prim_int_add $ m' x.7 + v.5 <- pure (CInt m1') + m1 <- store v.5 + v.6 <- pure (Fupto m1 n) + p <- store v.6 + v.7 <- pure (CCons m p) + pure v.7 + + sum l = + l2 <- eval $ l + case l2 of + (CNil) @ alt.2 -> + y.10 <- pure 0 + v.8 <- pure (CInt y.10) + pure v.8 + (CCons x xs) @ alt.3 -> + (CInt x') @ p.4 <- eval $ x + (CInt s') @ p.3 <- sum $ xs + ax' <- _prim_int_add $ x' s' + v.9 <- pure (CInt ax') + pure v.9 + + eval q = + v <- fetch q + case v of + (CInt x'1) @ alt.4 -> + pure v + (CNil) @ alt.5 -> + pure v + (CCons y ys) @ alt.6 -> + pure v + (Fupto a b) @ alt.7 -> + w <- upto $ a b + p.5 <- update q w + pure w + (Fsum c) @ alt.8 -> + z <- sum $ c + p.6 <- update q z + pure z + |] From 4b2ea5d9008a09a0e95b5a2f57f95f4d3d0adae0 Mon Sep 17 00:00:00 2001 From: anabra Date: Wed, 12 Feb 2020 22:23:00 +0100 Subject: [PATCH 15/15] ES: added LLVM JIT --- grin/grin.cabal | 1 + grin/src/Reducer/ExtendedSyntax/LLVM/JIT.hs | 82 +++++++++++++++++++++ 2 files changed, 83 insertions(+) create mode 100644 grin/src/Reducer/ExtendedSyntax/LLVM/JIT.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 01c8fd8c..83b2d861 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -122,6 +122,7 @@ library Reducer.ExtendedSyntax.IO Reducer.ExtendedSyntax.Pure Reducer.ExtendedSyntax.PrimOps + Reducer.ExtendedSyntax.LLVM.JIT Reducer.Base Reducer.IO Reducer.LLVM.Base diff --git a/grin/src/Reducer/ExtendedSyntax/LLVM/JIT.hs b/grin/src/Reducer/ExtendedSyntax/LLVM/JIT.hs new file mode 100644 index 00000000..6802820d --- /dev/null +++ b/grin/src/Reducer/ExtendedSyntax/LLVM/JIT.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Reducer.ExtendedSyntax.LLVM.JIT where + +import Grin.ExtendedSyntax.Grin (Val(..)) +import Reducer.ExtendedSyntax.Base (RTVal(..)) +import Data.String + +import LLVM.Target +import LLVM.Context +import LLVM.Module +import qualified LLVM.AST as AST + +import LLVM.OrcJIT +import qualified LLVM.Internal.OrcJIT.CompileLayer as CL + +import Control.Monad.Except +import qualified Data.ByteString.Char8 as BS + +import Data.Int +import Data.IORef +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Alloc +import qualified Data.Map.Strict as Map + +foreign import ccall "dynamic" + mkMain :: FunPtr (IO Int64) -> IO Int64 + +foreign import ccall "wrapper" + wrapIntPrint :: (Int64 -> IO ()) -> IO (FunPtr (Int64 -> IO ())) + +withTestModule :: AST.Module -> (LLVM.Module.Module -> IO a) -> IO a +withTestModule mod f = withContext $ \context -> withModuleFromAST context mod f + +myIntPrintImpl :: Int64 -> IO () +myIntPrintImpl i = print i + +resolver :: CompileLayer l => MangledSymbol -> l -> MangledSymbol -> IO (Either JITSymbolError JITSymbol) +resolver intPrint compileLayer symbol + | symbol == intPrint = do + funPtr <- wrapIntPrint myIntPrintImpl + let addr = ptrToWordPtr (castFunPtrToPtr funPtr) + pure $ Right (JITSymbol addr defaultJITSymbolFlags) + | otherwise = CL.findSymbol compileLayer symbol True + +nullResolver :: MangledSymbol -> IO (Either JITSymbolError JITSymbol) +nullResolver s = putStrLn "nullresolver" >> pure (Left (JITSymbolError "unknown symbol")) + +failInIO :: ExceptT String IO a -> IO a +failInIO = either fail pure <=< runExceptT + +grinHeapSize :: Int +grinHeapSize = 100 * 1024 * 1024 + +eagerJit :: AST.Module -> String -> IO RTVal +eagerJit amod mainName = do + resolvers <- newIORef Map.empty + withTestModule amod $ \mod -> + withHostTargetMachine $ \tm -> + withExecutionSession $ \es -> + withObjectLinkingLayer es (\k -> fmap (\rs -> rs Map.! k) (readIORef resolvers)) $ \linkingLayer -> + withIRCompileLayer linkingLayer tm $ \compileLayer -> do + intPrint <- mangleSymbol compileLayer "_prim_int_print" + withModuleKey es $ \k -> + withSymbolResolver es (SymbolResolver (resolver intPrint compileLayer)) $ \resolver -> do + modifyIORef' resolvers (Map.insert k resolver) + withModule compileLayer k mod $ do + mainSymbol <- mangleSymbol compileLayer (fromString mainName) + Right (JITSymbol mainFn _) <- CL.findSymbol compileLayer mainSymbol True + heapSymbol <- mangleSymbol compileLayer (fromString "_heap_ptr_") + Right (JITSymbol heapWordPtr _) <- CL.findSymbol compileLayer heapSymbol True + -- allocate GRIN heap + heapPointer <- callocBytes grinHeapSize :: IO (Ptr Int8) + poke (wordPtrToPtr heapWordPtr :: Ptr Int64) (fromIntegral $ minusPtr heapPointer nullPtr) + -- run function + result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) + -- TODO: read back the result and build the haskell value represenation + -- free GRIN heap + free heapPointer + pure RT_Unit