From 0df767a8950779ab2e7b83051d23b274622559c2 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Sun, 20 Jun 2021 05:59:30 +0900 Subject: [PATCH 01/56] refactor(rpython): Introduces utilities for constant exprs --- src/Jikka/Python/Language/Util.hs | 9 ++ src/Jikka/RestrictedPython/Language/Util.hs | 10 ++ test/Jikka/Python/Parse/HappySpec.hs | 7 +- test/Jikka/Python/ParseSpec.hs | 3 +- .../RestrictedPython/Convert/AlphaSpec.hs | 107 +++++++++--------- .../Convert/RemoveUnbalancedIfSpec.hs | 21 ++-- .../Convert/RemoveUnreachableSpec.hs | 19 ++-- .../Convert/SplitLoopsSpec.hs | 15 +-- test/Jikka/RestrictedPython/EvaluateSpec.hs | 11 +- .../RestrictedPython/Language/UtilSpec.hs | 10 +- 10 files changed, 119 insertions(+), 93 deletions(-) create mode 100644 src/Jikka/Python/Language/Util.hs diff --git a/src/Jikka/Python/Language/Util.hs b/src/Jikka/Python/Language/Util.hs new file mode 100644 index 00000000..9c62cff9 --- /dev/null +++ b/src/Jikka/Python/Language/Util.hs @@ -0,0 +1,9 @@ +module Jikka.Python.Language.Util where + +import Jikka.Python.Language.Expr + +constIntExp :: Integer -> Expr +constIntExp = Constant . ConstInt + +constBoolExp :: Bool -> Expr +constBoolExp = Constant . ConstBool diff --git a/src/Jikka/RestrictedPython/Language/Util.hs b/src/Jikka/RestrictedPython/Language/Util.hs index d413bf55..ffe28508 100644 --- a/src/Jikka/RestrictedPython/Language/Util.hs +++ b/src/Jikka/RestrictedPython/Language/Util.hs @@ -6,6 +6,10 @@ module Jikka.RestrictedPython.Language.Util genType, genVarName, + -- * constants + constIntExp, + constBoolExp, + -- * free variables freeTyVars, freeVars, @@ -63,6 +67,12 @@ genVarName x = do let base = if unVarName x == "_" then "" else takeWhile (/= '$') (unVarName x) return $ VarName (base ++ '$' : show i) +constIntExp :: Integer -> Expr +constIntExp = Constant . ConstInt + +constBoolExp :: Bool -> Expr +constBoolExp = Constant . ConstBool + freeTyVars :: Type -> [TypeName] freeTyVars = nub . go where diff --git a/test/Jikka/Python/Parse/HappySpec.hs b/test/Jikka/Python/Parse/HappySpec.hs index 76b3fcb0..34b4ed93 100644 --- a/test/Jikka/Python/Parse/HappySpec.hs +++ b/test/Jikka/Python/Parse/HappySpec.hs @@ -8,6 +8,7 @@ where import Jikka.Common.Error (Error) import Jikka.Common.Location import Jikka.Python.Language.Expr +import Jikka.Python.Language.Util import Jikka.Python.Parse.Happy import qualified Jikka.Python.Parse.Token as L import Test.Hspec @@ -26,7 +27,7 @@ spec = describe "run" $ do [L.Indent, L.Return, L.Int 42, L.Newline], [L.Dedent] ] - let parsed = [FunctionDef ("solve" `at` (1, 2)) emptyArguments [Return (Just (Constant (ConstInt 42) `at` (2, 3))) `at` (2, 2)] [] (Just $ Name ("int" `at` (1, 6)) `at` (1, 6)) `at` (1, 1)] + let parsed = [FunctionDef ("solve" `at` (1, 2)) emptyArguments [Return (Just (constIntExp 42 `at` (2, 3))) `at` (2, 2)] [] (Just $ Name ("int" `at` (1, 6)) `at` (1, 6)) `at` (1, 1)] run' input `shouldBe` Right parsed it "works on a small fun def" $ do let input = @@ -39,10 +40,10 @@ spec = describe "run" $ do [L.Dedent] ] let parsed = - [FunctionDef ("solve" `at` (1, 2)) (emptyArguments {argsArgs = [("p" `at` (1, 4), Nothing)]}) [If (Name ("p" `at` (2, 3)) `at` (2, 3)) [Return (Just (Constant (ConstInt 0) `at` (3, 3))) `at` (3, 2)] [Return (Just (Constant (ConstInt 1) `at` (5, 3))) `at` (5, 2)] `at` (2, 2)] [] Nothing `at` (1, 1)] + [FunctionDef ("solve" `at` (1, 2)) (emptyArguments {argsArgs = [("p" `at` (1, 4), Nothing)]}) [If (Name ("p" `at` (2, 3)) `at` (2, 3)) [Return (Just (constIntExp 0 `at` (3, 3))) `at` (3, 2)] [Return (Just (constIntExp 1 `at` (5, 3))) `at` (5, 2)] `at` (2, 2)] [] Nothing `at` (1, 1)] run' input `shouldBe` Right parsed it "works on a simple constant def" $ do let input = [[L.Ident "MOD", L.Colon, L.Ident "int", L.Equal, L.Int 1000000007, L.Newline]] let parsed = - [AnnAssign (Name ("MOD" `at` (1, 1)) `at` (1, 1)) (Name ("int" `at` (1, 3)) `at` (1, 3)) (Just (Constant (ConstInt 1000000007) `at` (1, 5))) `at` (1, 1)] + [AnnAssign (Name ("MOD" `at` (1, 1)) `at` (1, 1)) (Name ("int" `at` (1, 3)) `at` (1, 3)) (Just (constIntExp 1000000007 `at` (1, 5))) `at` (1, 1)] run' input `shouldBe` Right parsed diff --git a/test/Jikka/Python/ParseSpec.hs b/test/Jikka/Python/ParseSpec.hs index 442a8508..f16dbad4 100644 --- a/test/Jikka/Python/ParseSpec.hs +++ b/test/Jikka/Python/ParseSpec.hs @@ -9,6 +9,7 @@ import Data.Text (pack) import Jikka.Common.Error (Error) import Jikka.Common.Location import Jikka.Python.Language.Expr +import Jikka.Python.Language.Util import Jikka.Python.Parse import Test.Hspec @@ -25,5 +26,5 @@ spec = describe "run" $ do [ "def solve() -> int:", " return 42" ] - let parsed = [FunctionDef ("solve" `at` (1, 5, 5)) emptyArguments [Return (Just (Constant (ConstInt 42) `at` (2, 12, 2))) `at` (2, 5, 6)] [] (Just (Name ("int" `at` (1, 16, 3)) `at` (1, 16, 3))) `at` (1, 1, 3)] + let parsed = [FunctionDef ("solve" `at` (1, 5, 5)) emptyArguments [Return (Just (constIntExp 42 `at` (2, 12, 2))) `at` (2, 5, 6)] [] (Just (Name ("int" `at` (1, 16, 3)) `at` (1, 16, 3))) `at` (1, 1, 3)] run' input `shouldBe` Right parsed diff --git a/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs b/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs index 9d0e2b08..3d891848 100644 --- a/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs @@ -9,6 +9,7 @@ import Jikka.Common.Alpha import Jikka.Common.Error import Jikka.RestrictedPython.Convert.Alpha (run) import Jikka.RestrictedPython.Language.Expr +import Jikka.RestrictedPython.Language.Util import Test.Hspec run' :: Program -> Either Error Program @@ -106,10 +107,10 @@ spec = describe "run" $ do "a" (ListTy IntTy) ( ListComp - (Constant (ConstInt 0)) + (constIntExp 0) ( Comprehension (NameTrg "_") - (Call (Name "range") [Constant (ConstInt 10)]) + (Call (Name "range") [constIntExp 10]) Nothing ) ) @@ -119,10 +120,10 @@ spec = describe "run" $ do "a" (ListTy IntTy) ( ListComp - (Constant (ConstInt 0)) + (constIntExp 0) ( Comprehension (NameTrg "$0") - (Call (Name "range") [Constant (ConstInt 10)]) + (Call (Name "range") [constIntExp 10]) Nothing ) ) @@ -170,11 +171,11 @@ spec = describe "run" $ do "main" [] IntTy - [ AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x"), - AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x"), - AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x") ] ] @@ -183,11 +184,11 @@ spec = describe "run" $ do "main" [] IntTy - [ AnnAssign (NameTrg "x$0") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x$0") IntTy (constIntExp 0), AnnAssign (NameTrg "x$1") IntTy (Name "x$0"), - AnnAssign (NameTrg "x$2") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x$2") IntTy (constIntExp 0), AnnAssign (NameTrg "x$3") IntTy (Name "x$2"), - AnnAssign (NameTrg "x$4") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x$4") IntTy (constIntExp 0), AnnAssign (NameTrg "x$5") IntTy (Name "x$4") ] ] @@ -198,11 +199,11 @@ spec = describe "run" $ do "main" [] IntTy - [ AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x"), - AugAssign (NameTrg "x") Add (Constant (ConstInt 0)), + AugAssign (NameTrg "x") Add (constIntExp 0), AugAssign (NameTrg "x") Add (Name "x"), - AugAssign (NameTrg "x") Add (Constant (ConstInt 0)), + AugAssign (NameTrg "x") Add (constIntExp 0), AugAssign (NameTrg "x") Add (Name "x") ] ] @@ -211,11 +212,11 @@ spec = describe "run" $ do "main" [] IntTy - [ AnnAssign (NameTrg "x$0") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x$0") IntTy (constIntExp 0), AnnAssign (NameTrg "x$1") IntTy (Name "x$0"), - AugAssign (NameTrg "x$1") Add (Constant (ConstInt 0)), + AugAssign (NameTrg "x$1") Add (constIntExp 0), AugAssign (NameTrg "x$1") Add (Name "x$1"), - AugAssign (NameTrg "x$1") Add (Constant (ConstInt 0)), + AugAssign (NameTrg "x$1") Add (constIntExp 0), AugAssign (NameTrg "x$1") Add (Name "x$1") ] ] @@ -242,7 +243,7 @@ spec = describe "run" $ do "main" [] IntTy - [ AnnAssign (NameTrg "i") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "i") IntTy (constIntExp 0), For (NameTrg "i") (List IntTy []) @@ -259,8 +260,8 @@ spec = describe "run" $ do "main" [] IntTy - [ AnnAssign (NameTrg "i") IntTy (Constant (ConstInt 0)), - AnnAssign (NameTrg "a") (ListTy IntTy) (ListComp (Constant (ConstInt 0)) (Comprehension (NameTrg "i") (List IntTy []) Nothing)), + [ AnnAssign (NameTrg "i") IntTy (constIntExp 0), + AnnAssign (NameTrg "a") (ListTy IntTy) (ListComp (constIntExp 0) (Comprehension (NameTrg "i") (List IntTy []) Nothing)), Return (Name "i") ] ] @@ -269,8 +270,8 @@ spec = describe "run" $ do "main" [] IntTy - [ AnnAssign (NameTrg "i$0") IntTy (Constant (ConstInt 0)), - AnnAssign (NameTrg "a$2") (ListTy IntTy) (ListComp (Constant (ConstInt 0)) (Comprehension (NameTrg "i$1") (List IntTy []) Nothing)), + [ AnnAssign (NameTrg "i$0") IntTy (constIntExp 0), + AnnAssign (NameTrg "a$2") (ListTy IntTy) (ListComp (constIntExp 0) (Comprehension (NameTrg "i$1") (List IntTy []) Nothing)), Return (Name "i$0") ] ] @@ -281,22 +282,22 @@ spec = describe "run" $ do "main" [] IntTy - [ AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x"), - AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x"), If (Name "x") - [ AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x"), - AnnAssign (NameTrg "y") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "y") IntTy (constIntExp 0), AnnAssign (NameTrg "y") IntTy (Name "y"), - AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x") ] [], AnnAssign (NameTrg "x") IntTy (Name "x"), - AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x") ] ] @@ -305,22 +306,22 @@ spec = describe "run" $ do "main" [] IntTy - [ AnnAssign (NameTrg "x$0") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x$0") IntTy (constIntExp 0), AnnAssign (NameTrg "x$1") IntTy (Name "x$0"), - AnnAssign (NameTrg "x$2") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x$2") IntTy (constIntExp 0), AnnAssign (NameTrg "x$3") IntTy (Name "x$2"), If (Name "x$3") - [ AnnAssign (NameTrg "x$3") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x$3") IntTy (constIntExp 0), AnnAssign (NameTrg "x$3") IntTy (Name "x$3"), - AnnAssign (NameTrg "y$4") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "y$4") IntTy (constIntExp 0), AnnAssign (NameTrg "y$5") IntTy (Name "y$4"), - AnnAssign (NameTrg "x$3") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x$3") IntTy (constIntExp 0), AnnAssign (NameTrg "x$3") IntTy (Name "x$3") ] [], AnnAssign (NameTrg "x$6") IntTy (Name "x$3"), - AnnAssign (NameTrg "x$7") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x$7") IntTy (constIntExp 0), AnnAssign (NameTrg "x$8") IntTy (Name "x$7") ] ] @@ -331,22 +332,22 @@ spec = describe "run" $ do "main" [] IntTy - [ AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x"), - AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x"), For (NameTrg "i") (List IntTy []) - [ AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x"), - AnnAssign (NameTrg "y") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "y") IntTy (constIntExp 0), AnnAssign (NameTrg "y") IntTy (Name "y"), - AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x") ], AnnAssign (NameTrg "x") IntTy (Name "x"), - AnnAssign (NameTrg "x") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x") IntTy (constIntExp 0), AnnAssign (NameTrg "x") IntTy (Name "x") ] ] @@ -355,22 +356,22 @@ spec = describe "run" $ do "main" [] IntTy - [ AnnAssign (NameTrg "x$0") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x$0") IntTy (constIntExp 0), AnnAssign (NameTrg "x$1") IntTy (Name "x$0"), - AnnAssign (NameTrg "x$2") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x$2") IntTy (constIntExp 0), AnnAssign (NameTrg "x$3") IntTy (Name "x$2"), For (NameTrg "i$4") (List IntTy []) - [ AnnAssign (NameTrg "x$3") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "x$3") IntTy (constIntExp 0), AnnAssign (NameTrg "x$3") IntTy (Name "x$3"), - AnnAssign (NameTrg "y$5") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "y$5") IntTy (constIntExp 0), AnnAssign (NameTrg "y$6") IntTy (Name "y$5"), - AnnAssign (NameTrg "x$3") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x$3") IntTy (constIntExp 0), AnnAssign (NameTrg "x$3") IntTy (Name "x$3") ], AnnAssign (NameTrg "x$7") IntTy (Name "x$3"), - AnnAssign (NameTrg "x$8") IntTy (Constant (ConstInt 0)), + AnnAssign (NameTrg "x$8") IntTy (constIntExp 0), AnnAssign (NameTrg "x$9") IntTy (Name "x$8") ] ] @@ -382,10 +383,10 @@ spec = describe "run" $ do [] IntTy [ AnnAssign (NameTrg "a") (ListTy IntTy) (List IntTy []), - AnnAssign (SubscriptTrg (NameTrg "a") (Constant (ConstInt 0))) IntTy (Subscript (Name "a") (Constant (ConstInt 0))), - AnnAssign (SubscriptTrg (NameTrg "a") (Constant (ConstInt 0))) IntTy (Subscript (Name "a") (Constant (ConstInt 0))), - AnnAssign (SubscriptTrg (NameTrg "a") (Constant (ConstInt 0))) IntTy (Subscript (Name "a") (Constant (ConstInt 0))), - AnnAssign (SubscriptTrg (NameTrg "a") (Constant (ConstInt 0))) IntTy (Subscript (Name "a") (Constant (ConstInt 0))) + AnnAssign (SubscriptTrg (NameTrg "a") (constIntExp 0)) IntTy (Subscript (Name "a") (constIntExp 0)), + AnnAssign (SubscriptTrg (NameTrg "a") (constIntExp 0)) IntTy (Subscript (Name "a") (constIntExp 0)), + AnnAssign (SubscriptTrg (NameTrg "a") (constIntExp 0)) IntTy (Subscript (Name "a") (constIntExp 0)), + AnnAssign (SubscriptTrg (NameTrg "a") (constIntExp 0)) IntTy (Subscript (Name "a") (constIntExp 0)) ] ] let expected = @@ -394,10 +395,10 @@ spec = describe "run" $ do [] IntTy [ AnnAssign (NameTrg "a$0") (ListTy IntTy) (List IntTy []), - AnnAssign (SubscriptTrg (NameTrg "a$0") (Constant (ConstInt 0))) IntTy (Subscript (Name "a$0") (Constant (ConstInt 0))), - AnnAssign (SubscriptTrg (NameTrg "a$0") (Constant (ConstInt 0))) IntTy (Subscript (Name "a$0") (Constant (ConstInt 0))), - AnnAssign (SubscriptTrg (NameTrg "a$0") (Constant (ConstInt 0))) IntTy (Subscript (Name "a$0") (Constant (ConstInt 0))), - AnnAssign (SubscriptTrg (NameTrg "a$0") (Constant (ConstInt 0))) IntTy (Subscript (Name "a$0") (Constant (ConstInt 0))) + AnnAssign (SubscriptTrg (NameTrg "a$0") (constIntExp 0)) IntTy (Subscript (Name "a$0") (constIntExp 0)), + AnnAssign (SubscriptTrg (NameTrg "a$0") (constIntExp 0)) IntTy (Subscript (Name "a$0") (constIntExp 0)), + AnnAssign (SubscriptTrg (NameTrg "a$0") (constIntExp 0)) IntTy (Subscript (Name "a$0") (constIntExp 0)), + AnnAssign (SubscriptTrg (NameTrg "a$0") (constIntExp 0)) IntTy (Subscript (Name "a$0") (constIntExp 0)) ] ] run' parsed `shouldBe` Right expected diff --git a/test/Jikka/RestrictedPython/Convert/RemoveUnbalancedIfSpec.hs b/test/Jikka/RestrictedPython/Convert/RemoveUnbalancedIfSpec.hs index a80cfaed..7509cf61 100644 --- a/test/Jikka/RestrictedPython/Convert/RemoveUnbalancedIfSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/RemoveUnbalancedIfSpec.hs @@ -7,6 +7,7 @@ where import Jikka.RestrictedPython.Convert.RemoveUnbalancedIf (run) import Jikka.RestrictedPython.Language.Expr +import Jikka.RestrictedPython.Language.Util import Test.Hspec spec :: Spec @@ -18,13 +19,13 @@ spec = describe "run" $ do [] IntTy [ If - (Constant (ConstBool True)) - [ Return (Constant (ConstInt 0)) + (constBoolExp True) + [ Return (constIntExp 0) ] - [ AnnAssign (NameTrg "a") IntTy (Constant (ConstInt 0)) + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0) ], - AnnAssign (NameTrg "b") IntTy (Constant (ConstInt 1)), - Return (Constant (ConstInt 2)) + AnnAssign (NameTrg "b") IntTy (constIntExp 1), + Return (constIntExp 2) ] ] let expected = @@ -33,12 +34,12 @@ spec = describe "run" $ do [] IntTy [ If - (Constant (ConstBool True)) - [ Return (Constant (ConstInt 0)) + (constBoolExp True) + [ Return (constIntExp 0) ] - [ AnnAssign (NameTrg "a") IntTy (Constant (ConstInt 0)), - AnnAssign (NameTrg "b") IntTy (Constant (ConstInt 1)), - Return (Constant (ConstInt 2)) + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), + AnnAssign (NameTrg "b") IntTy (constIntExp 1), + Return (constIntExp 2) ] ] ] diff --git a/test/Jikka/RestrictedPython/Convert/RemoveUnreachableSpec.hs b/test/Jikka/RestrictedPython/Convert/RemoveUnreachableSpec.hs index 99834f7b..6bcef874 100644 --- a/test/Jikka/RestrictedPython/Convert/RemoveUnreachableSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/RemoveUnreachableSpec.hs @@ -7,6 +7,7 @@ where import Jikka.RestrictedPython.Convert.RemoveUnreachable (run) import Jikka.RestrictedPython.Language.Expr +import Jikka.RestrictedPython.Language.Util import Test.Hspec spec :: Spec @@ -17,16 +18,16 @@ spec = describe "run" $ do "solve" [] IntTy - [ AnnAssign (NameTrg "a") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), If - (Constant (ConstBool True)) - [ AnnAssign (NameTrg "b") IntTy (Constant (ConstInt 0)), + (constBoolExp True) + [ AnnAssign (NameTrg "b") IntTy (constIntExp 0), Return (Name "a"), AugAssign (NameTrg "b") Add (Name "1") ] - [ Return (Constant (ConstInt 1)) + [ Return (constIntExp 1) ], - AugAssign (NameTrg "a") Add (Constant (ConstInt 1)) + AugAssign (NameTrg "a") Add (constIntExp 1) ] ] let expected = @@ -34,13 +35,13 @@ spec = describe "run" $ do "solve" [] IntTy - [ AnnAssign (NameTrg "a") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), If - (Constant (ConstBool True)) - [ AnnAssign (NameTrg "b") IntTy (Constant (ConstInt 0)), + (constBoolExp True) + [ AnnAssign (NameTrg "b") IntTy (constIntExp 0), Return (Name "a") ] - [ Return (Constant (ConstInt 1)) + [ Return (constIntExp 1) ] ] ] diff --git a/test/Jikka/RestrictedPython/Convert/SplitLoopsSpec.hs b/test/Jikka/RestrictedPython/Convert/SplitLoopsSpec.hs index f7b3d241..3ff067b8 100644 --- a/test/Jikka/RestrictedPython/Convert/SplitLoopsSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/SplitLoopsSpec.hs @@ -7,6 +7,7 @@ where import Jikka.RestrictedPython.Convert.SplitLoops (run') import Jikka.RestrictedPython.Language.Expr +import Jikka.RestrictedPython.Language.Util import Test.Hspec spec :: Spec @@ -17,11 +18,11 @@ spec = describe "run" $ do "solve" [] IntTy - [ AnnAssign (NameTrg "a") IntTy (Constant (ConstInt 0)), - AnnAssign (NameTrg "b") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), + AnnAssign (NameTrg "b") IntTy (constIntExp 0), For (NameTrg "i") - (Call (Name "range") [Constant (ConstInt 10)]) + (Call (Name "range") [constIntExp 10]) [ AnnAssign (NameTrg "c") IntTy (Name "b"), AugAssign (NameTrg "a") Add (Name "i"), AugAssign (NameTrg "b") Add (Name "c") @@ -33,17 +34,17 @@ spec = describe "run" $ do "solve" [] IntTy - [ AnnAssign (NameTrg "a") IntTy (Constant (ConstInt 0)), - AnnAssign (NameTrg "b") IntTy (Constant (ConstInt 0)), + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), + AnnAssign (NameTrg "b") IntTy (constIntExp 0), For (NameTrg "i") - (Call (Name "range") [Constant (ConstInt 10)]) + (Call (Name "range") [constIntExp 10]) [ AnnAssign (NameTrg "c") IntTy (Name "b"), AugAssign (NameTrg "b") Add (Name "c") ], For (NameTrg "i") - (Call (Name "range") [Constant (ConstInt 10)]) + (Call (Name "range") [constIntExp 10]) [ AugAssign (NameTrg "a") Add (Name "i") ] ] diff --git a/test/Jikka/RestrictedPython/EvaluateSpec.hs b/test/Jikka/RestrictedPython/EvaluateSpec.hs index 6d042197..8271a1cf 100644 --- a/test/Jikka/RestrictedPython/EvaluateSpec.hs +++ b/test/Jikka/RestrictedPython/EvaluateSpec.hs @@ -4,6 +4,7 @@ module Jikka.RestrictedPython.EvaluateSpec (spec) where import Jikka.RestrictedPython.Evaluate import Jikka.RestrictedPython.Language.Expr +import Jikka.RestrictedPython.Language.Util import Jikka.RestrictedPython.Language.Value import Test.Hspec @@ -16,12 +17,12 @@ spec = describe "run" $ do [("n", IntTy)] IntTy [ If - (Compare (Name "n") Eq' (Constant (ConstInt 0))) - [Return (Constant (ConstInt 1))] - [Return (BinOp (Name "n") Mult (Call (Name "fact") [BinOp (Name "n") Sub (Constant (ConstInt 1))]))] + (Compare (Name "n") Eq' (constIntExp 0)) + [Return (constIntExp 1)] + [Return (BinOp (Name "n") Mult (Call (Name "fact") [BinOp (Name "n") Sub (constIntExp 1)]))] ] ] - let e = Call (Name "fact") [Constant (ConstInt 10)] + let e = Call (Name "fact") [constIntExp 10] let expected = IntVal 3628800 run prog e `shouldBe` Right expected it "works with for-loop and assignment" $ do @@ -39,6 +40,6 @@ spec = describe "run" $ do Return (Call (Name "sum") [Name "a"]) ] ] - let e = Call (Name "solve") [Constant (ConstInt 100)] + let e = Call (Name "solve") [constIntExp 100] let expected = IntVal 328350 run prog e `shouldBe` Right expected diff --git a/test/Jikka/RestrictedPython/Language/UtilSpec.hs b/test/Jikka/RestrictedPython/Language/UtilSpec.hs index e1e1206b..e5f37a00 100644 --- a/test/Jikka/RestrictedPython/Language/UtilSpec.hs +++ b/test/Jikka/RestrictedPython/Language/UtilSpec.hs @@ -12,7 +12,7 @@ import Test.Hspec spec :: Spec spec = describe "doesAlwaysReturn" $ do it "works" $ do - let stmt = AnnAssign (NameTrg "a") IntTy (Constant (ConstInt 0)) + let stmt = AnnAssign (NameTrg "a") IntTy (constIntExp 0) let expected = False doesAlwaysReturn stmt `shouldBe` expected it "works'" $ do @@ -22,16 +22,16 @@ spec = describe "doesAlwaysReturn" $ do it "returns true for an if-statement which both branches always return" $ do let stmt = If - (Constant (ConstBool True)) - [ AnnAssign (NameTrg "b") IntTy (Constant (ConstInt 0)), + (constBoolExp True) + [ AnnAssign (NameTrg "b") IntTy (constIntExp 0), Return (Name "a"), AugAssign (NameTrg "b") Add (Name "1") ] - [ Return (Constant (ConstInt 1)) + [ Return (constIntExp 1) ] let expected = True doesAlwaysReturn stmt `shouldBe` expected it "returns false for for-statement" $ do - let stmt = For (NameTrg "x") (List IntTy []) [Return (Constant (ConstInt 0))] + let stmt = For (NameTrg "x") (List IntTy []) [Return (constIntExp 0)] let expected = False doesAlwaysReturn stmt `shouldBe` expected From 13312b5f6de195b396164e4bf12bc6050d1315ba Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Sun, 20 Jun 2021 06:21:56 +0900 Subject: [PATCH 02/56] refactor(rpython): s/hasAssignToLoopIterators/hasAssignmentToLoopIterators/ --- src/Jikka/RestrictedPython/Language/Lint.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Jikka/RestrictedPython/Language/Lint.hs b/src/Jikka/RestrictedPython/Language/Lint.hs index 2418c1e2..b083bf94 100644 --- a/src/Jikka/RestrictedPython/Language/Lint.hs +++ b/src/Jikka/RestrictedPython/Language/Lint.hs @@ -79,7 +79,7 @@ doesntHaveAssignmentToLoopCounters = not . hasAssignmentToLoopCounters ensureDoesntHaveAssignmentToLoopCounters :: MonadError Error m => Program -> m () ensureDoesntHaveAssignmentToLoopCounters = makeEnsureProgram doesntHaveAssignmentToLoopCounters "there must not be assignments to loop counters" --- | `hasAssignToLoopIterators` checks that there are assignments to loop iterators of for-loops. +-- | `hasAssignmentToLoopIterators` checks that there are assignments to loop iterators of for-loops. -- For example, the followings have the assignments. -- -- > a = list(range(10)) @@ -89,8 +89,8 @@ ensureDoesntHaveAssignmentToLoopCounters = makeEnsureProgram doesntHaveAssignmen -- > a = 0 -- > for i in f(a): -- > a += i -hasAssignToLoopIterators :: Program -> Bool -hasAssignToLoopIterators prog = any check (listStatements prog) +hasAssignmentToLoopIterators :: Program -> Bool +hasAssignmentToLoopIterators prog = any check (listStatements prog) where check = \case For _ iter body -> @@ -100,7 +100,7 @@ hasAssignToLoopIterators prog = any check (listStatements prog) _ -> False doesntHaveAssignmentToLoopIterators :: Program -> Bool -doesntHaveAssignmentToLoopIterators = not . hasAssignToLoopIterators +doesntHaveAssignmentToLoopIterators = not . hasAssignmentToLoopIterators ensureDoesntHaveAssignmentToLoopIterators :: MonadError Error m => Program -> m () ensureDoesntHaveAssignmentToLoopIterators = makeEnsureProgram doesntHaveAssignmentToLoopIterators "there must not be assignments changing loop iterators" From fd7f790d31ec8132ab15574db2c45ea38a99464d Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Sun, 20 Jun 2021 06:23:57 +0900 Subject: [PATCH 03/56] test(rpython): Create test/Jikka/RestrictedPython/Language/LintSpec.hs --- .../RestrictedPython/Language/LintSpec.hs | 115 ++++++++++++++++++ 1 file changed, 115 insertions(+) create mode 100644 test/Jikka/RestrictedPython/Language/LintSpec.hs diff --git a/test/Jikka/RestrictedPython/Language/LintSpec.hs b/test/Jikka/RestrictedPython/Language/LintSpec.hs new file mode 100644 index 00000000..220f8a23 --- /dev/null +++ b/test/Jikka/RestrictedPython/Language/LintSpec.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Jikka.RestrictedPython.Language.LintSpec (spec) where + +import Jikka.RestrictedPython.Language.Expr +import Jikka.RestrictedPython.Language.Lint +import Jikka.RestrictedPython.Language.Util +import Test.Hspec + +spec :: Spec +spec = do + describe "hasSubscriptionInLoopCounters" $ do + it "works on for-statements" $ do + let prog = + [ ToplevelFunctionDef + "main" + [] + IntTy + [ For + (SubscriptTrg (NameTrg "a") (constIntExp 0)) + (Call (Name "range") [constIntExp 100]) + [] + ] + ] + let expected = True + hasSubscriptionInLoopCounters prog `shouldBe` expected + it "works on for-exprs" $ do + let prog = + [ ToplevelFunctionDef + "main" + [] + IntTy + [ Return (ListComp (constIntExp 0) (Comprehension (SubscriptTrg (NameTrg "a") (constIntExp 0)) (Call (Name "range") [constIntExp 100]) Nothing)) + ] + ] + let expected = True + hasSubscriptionInLoopCounters prog `shouldBe` expected + describe "hasAssignmentToLoopCounters" $ do + it "works" $ do + let prog = + [ ToplevelFunctionDef + "main" + [] + IntTy + [ For + (NameTrg "i") + (Call (Name "range") [constIntExp 100]) + [ AugAssign (NameTrg "i") Add (constIntExp 1) + ] + ] + ] + let expected = True + hasAssignmentToLoopCounters prog `shouldBe` expected + describe "hasAssignmentToLoopIterators" $ do + it "works" $ do + let prog = + [ ToplevelFunctionDef + "main" + [] + IntTy + [ AnnAssign (NameTrg "a") (ListTy IntTy) (Call (Name "range") [constIntExp 100]), + For + (NameTrg "i") + (Name "a") + [ AnnAssign (SubscriptTrg (NameTrg "a") (constIntExp 5)) IntTy (Name "i") + ] + ] + ] + let expected = True + hasAssignmentToLoopIterators prog `shouldBe` expected + it "works even if side effects are not trivial" $ do + let prog = + [ ToplevelFunctionDef + "main" + [] + IntTy + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), + For + (NameTrg "i") + (Call (Name "f") [Name "a"]) + [ AugAssign (NameTrg "a") Add (Name "i") + ] + ] + ] + let expected = True + hasAssignmentToLoopIterators prog `shouldBe` expected + describe "hasReturnInLoops" $ do + it "works" $ do + let prog = + [ ToplevelFunctionDef + "main" + [] + IntTy + [ AnnAssign (NameTrg "a") (ListTy IntTy) (Call (Name "range") [constIntExp 10]), + For + (NameTrg "i") + (Name "a") + [ Return (constIntExp 0) + ] + ] + ] + let expected = True + hasReturnInLoops prog `shouldBe` expected + describe "hasMixedAssignment" $ do + it "works" $ do + let prog = + [ ToplevelFunctionDef + "main" + [] + IntTy + [ AnnAssign (TupleTrg [NameTrg "a", SubscriptTrg (NameTrg "b") (constIntExp 0)]) (ListTy IntTy) (Call (Name "range") [constIntExp 10]) + ] + ] + let expected = True + hasMixedAssignment prog `shouldBe` expected From 4c99c60934d69b43d81bf19be79aa924b7e7ec5f Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Sun, 20 Jun 2021 06:31:01 +0900 Subject: [PATCH 04/56] refactor(rpython): Add a utility toplevelMainDef to reduce the lengths of tests --- src/Jikka/RestrictedPython/Language/Util.hs | 6 + .../Convert/RemoveUnbalancedIfSpec.hs | 48 +++----- .../Convert/RemoveUnreachableSpec.hs | 52 ++++---- .../Convert/SplitLoopsSpec.hs | 60 ++++----- .../RestrictedPython/Language/LintSpec.hs | 114 +++++++----------- 5 files changed, 117 insertions(+), 163 deletions(-) diff --git a/src/Jikka/RestrictedPython/Language/Util.hs b/src/Jikka/RestrictedPython/Language/Util.hs index ffe28508..e44b9e3b 100644 --- a/src/Jikka/RestrictedPython/Language/Util.hs +++ b/src/Jikka/RestrictedPython/Language/Util.hs @@ -43,6 +43,9 @@ module Jikka.RestrictedPython.Language.Util hasSubscriptTrg, hasBareNameTrg, + -- * programs + toplevelMainDef, + -- * IO readValueIO, ) @@ -293,6 +296,9 @@ hasBareNameTrg = \case NameTrg _ -> True TupleTrg xs -> any hasSubscriptTrg xs +toplevelMainDef :: [Statement] -> Program +toplevelMainDef body = [ToplevelFunctionDef (VarName "main") [] IntTy body] + readValueIO :: (MonadIO m, MonadError Error m) => Type -> m Expr readValueIO = \case VarTy _ -> throwRuntimeError "cannot read values of type variables" diff --git a/test/Jikka/RestrictedPython/Convert/RemoveUnbalancedIfSpec.hs b/test/Jikka/RestrictedPython/Convert/RemoveUnbalancedIfSpec.hs index 7509cf61..c0a2316e 100644 --- a/test/Jikka/RestrictedPython/Convert/RemoveUnbalancedIfSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/RemoveUnbalancedIfSpec.hs @@ -14,33 +14,25 @@ spec :: Spec spec = describe "run" $ do it "works" $ do let prog = - [ ToplevelFunctionDef - "solve" - [] - IntTy - [ If - (constBoolExp True) - [ Return (constIntExp 0) - ] - [ AnnAssign (NameTrg "a") IntTy (constIntExp 0) - ], - AnnAssign (NameTrg "b") IntTy (constIntExp 1), - Return (constIntExp 2) - ] - ] + toplevelMainDef + [ If + (constBoolExp True) + [ Return (constIntExp 0) + ] + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0) + ], + AnnAssign (NameTrg "b") IntTy (constIntExp 1), + Return (constIntExp 2) + ] let expected = - [ ToplevelFunctionDef - "solve" - [] - IntTy - [ If - (constBoolExp True) - [ Return (constIntExp 0) - ] - [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), - AnnAssign (NameTrg "b") IntTy (constIntExp 1), - Return (constIntExp 2) - ] - ] - ] + toplevelMainDef + [ If + (constBoolExp True) + [ Return (constIntExp 0) + ] + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), + AnnAssign (NameTrg "b") IntTy (constIntExp 1), + Return (constIntExp 2) + ] + ] run prog `shouldBe` expected diff --git a/test/Jikka/RestrictedPython/Convert/RemoveUnreachableSpec.hs b/test/Jikka/RestrictedPython/Convert/RemoveUnreachableSpec.hs index 6bcef874..6177360c 100644 --- a/test/Jikka/RestrictedPython/Convert/RemoveUnreachableSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/RemoveUnreachableSpec.hs @@ -14,35 +14,27 @@ spec :: Spec spec = describe "run" $ do it "works" $ do let prog = - [ ToplevelFunctionDef - "solve" - [] - IntTy - [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), - If - (constBoolExp True) - [ AnnAssign (NameTrg "b") IntTy (constIntExp 0), - Return (Name "a"), - AugAssign (NameTrg "b") Add (Name "1") - ] - [ Return (constIntExp 1) - ], - AugAssign (NameTrg "a") Add (constIntExp 1) - ] - ] + toplevelMainDef + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), + If + (constBoolExp True) + [ AnnAssign (NameTrg "b") IntTy (constIntExp 0), + Return (Name "a"), + AugAssign (NameTrg "b") Add (Name "1") + ] + [ Return (constIntExp 1) + ], + AugAssign (NameTrg "a") Add (constIntExp 1) + ] let expected = - [ ToplevelFunctionDef - "solve" - [] - IntTy - [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), - If - (constBoolExp True) - [ AnnAssign (NameTrg "b") IntTy (constIntExp 0), - Return (Name "a") - ] - [ Return (constIntExp 1) - ] - ] - ] + toplevelMainDef + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), + If + (constBoolExp True) + [ AnnAssign (NameTrg "b") IntTy (constIntExp 0), + Return (Name "a") + ] + [ Return (constIntExp 1) + ] + ] run prog `shouldBe` expected diff --git a/test/Jikka/RestrictedPython/Convert/SplitLoopsSpec.hs b/test/Jikka/RestrictedPython/Convert/SplitLoopsSpec.hs index 3ff067b8..67c3abc7 100644 --- a/test/Jikka/RestrictedPython/Convert/SplitLoopsSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/SplitLoopsSpec.hs @@ -14,39 +14,31 @@ spec :: Spec spec = describe "run" $ do it "works" $ do let prog = - [ ToplevelFunctionDef - "solve" - [] - IntTy - [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), - AnnAssign (NameTrg "b") IntTy (constIntExp 0), - For - (NameTrg "i") - (Call (Name "range") [constIntExp 10]) - [ AnnAssign (NameTrg "c") IntTy (Name "b"), - AugAssign (NameTrg "a") Add (Name "i"), - AugAssign (NameTrg "b") Add (Name "c") - ] - ] - ] + toplevelMainDef + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), + AnnAssign (NameTrg "b") IntTy (constIntExp 0), + For + (NameTrg "i") + (Call (Name "range") [constIntExp 10]) + [ AnnAssign (NameTrg "c") IntTy (Name "b"), + AugAssign (NameTrg "a") Add (Name "i"), + AugAssign (NameTrg "b") Add (Name "c") + ] + ] let expected = - [ ToplevelFunctionDef - "solve" - [] - IntTy - [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), - AnnAssign (NameTrg "b") IntTy (constIntExp 0), - For - (NameTrg "i") - (Call (Name "range") [constIntExp 10]) - [ AnnAssign (NameTrg "c") IntTy (Name "b"), - AugAssign (NameTrg "b") Add (Name "c") - ], - For - (NameTrg "i") - (Call (Name "range") [constIntExp 10]) - [ AugAssign (NameTrg "a") Add (Name "i") - ] - ] - ] + toplevelMainDef + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), + AnnAssign (NameTrg "b") IntTy (constIntExp 0), + For + (NameTrg "i") + (Call (Name "range") [constIntExp 10]) + [ AnnAssign (NameTrg "c") IntTy (Name "b"), + AugAssign (NameTrg "b") Add (Name "c") + ], + For + (NameTrg "i") + (Call (Name "range") [constIntExp 10]) + [ AugAssign (NameTrg "a") Add (Name "i") + ] + ] run' prog `shouldBe` expected diff --git a/test/Jikka/RestrictedPython/Language/LintSpec.hs b/test/Jikka/RestrictedPython/Language/LintSpec.hs index 220f8a23..ffd6d1ff 100644 --- a/test/Jikka/RestrictedPython/Language/LintSpec.hs +++ b/test/Jikka/RestrictedPython/Language/LintSpec.hs @@ -12,104 +12,76 @@ spec = do describe "hasSubscriptionInLoopCounters" $ do it "works on for-statements" $ do let prog = - [ ToplevelFunctionDef - "main" - [] - IntTy - [ For - (SubscriptTrg (NameTrg "a") (constIntExp 0)) - (Call (Name "range") [constIntExp 100]) - [] - ] - ] + toplevelMainDef + [ For + (SubscriptTrg (NameTrg "a") (constIntExp 0)) + (Call (Name "range") [constIntExp 100]) + [] + ] let expected = True hasSubscriptionInLoopCounters prog `shouldBe` expected it "works on for-exprs" $ do let prog = - [ ToplevelFunctionDef - "main" - [] - IntTy - [ Return (ListComp (constIntExp 0) (Comprehension (SubscriptTrg (NameTrg "a") (constIntExp 0)) (Call (Name "range") [constIntExp 100]) Nothing)) - ] - ] + toplevelMainDef + [ Return (ListComp (constIntExp 0) (Comprehension (SubscriptTrg (NameTrg "a") (constIntExp 0)) (Call (Name "range") [constIntExp 100]) Nothing)) + ] let expected = True hasSubscriptionInLoopCounters prog `shouldBe` expected describe "hasAssignmentToLoopCounters" $ do it "works" $ do let prog = - [ ToplevelFunctionDef - "main" - [] - IntTy - [ For - (NameTrg "i") - (Call (Name "range") [constIntExp 100]) - [ AugAssign (NameTrg "i") Add (constIntExp 1) - ] - ] - ] + toplevelMainDef + [ For + (NameTrg "i") + (Call (Name "range") [constIntExp 100]) + [ AugAssign (NameTrg "i") Add (constIntExp 1) + ] + ] let expected = True hasAssignmentToLoopCounters prog `shouldBe` expected describe "hasAssignmentToLoopIterators" $ do it "works" $ do let prog = - [ ToplevelFunctionDef - "main" - [] - IntTy - [ AnnAssign (NameTrg "a") (ListTy IntTy) (Call (Name "range") [constIntExp 100]), - For - (NameTrg "i") - (Name "a") - [ AnnAssign (SubscriptTrg (NameTrg "a") (constIntExp 5)) IntTy (Name "i") - ] - ] - ] + toplevelMainDef + [ AnnAssign (NameTrg "a") (ListTy IntTy) (Call (Name "range") [constIntExp 100]), + For + (NameTrg "i") + (Name "a") + [ AnnAssign (SubscriptTrg (NameTrg "a") (constIntExp 5)) IntTy (Name "i") + ] + ] let expected = True hasAssignmentToLoopIterators prog `shouldBe` expected it "works even if side effects are not trivial" $ do let prog = - [ ToplevelFunctionDef - "main" - [] - IntTy - [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), - For - (NameTrg "i") - (Call (Name "f") [Name "a"]) - [ AugAssign (NameTrg "a") Add (Name "i") - ] - ] - ] + toplevelMainDef + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0), + For + (NameTrg "i") + (Call (Name "f") [Name "a"]) + [ AugAssign (NameTrg "a") Add (Name "i") + ] + ] let expected = True hasAssignmentToLoopIterators prog `shouldBe` expected describe "hasReturnInLoops" $ do it "works" $ do let prog = - [ ToplevelFunctionDef - "main" - [] - IntTy - [ AnnAssign (NameTrg "a") (ListTy IntTy) (Call (Name "range") [constIntExp 10]), - For - (NameTrg "i") - (Name "a") - [ Return (constIntExp 0) - ] - ] - ] + toplevelMainDef + [ AnnAssign (NameTrg "a") (ListTy IntTy) (Call (Name "range") [constIntExp 10]), + For + (NameTrg "i") + (Name "a") + [ Return (constIntExp 0) + ] + ] let expected = True hasReturnInLoops prog `shouldBe` expected describe "hasMixedAssignment" $ do it "works" $ do let prog = - [ ToplevelFunctionDef - "main" - [] - IntTy - [ AnnAssign (TupleTrg [NameTrg "a", SubscriptTrg (NameTrg "b") (constIntExp 0)]) (ListTy IntTy) (Call (Name "range") [constIntExp 10]) - ] - ] + toplevelMainDef + [ AnnAssign (TupleTrg [NameTrg "a", SubscriptTrg (NameTrg "b") (constIntExp 0)]) (ListTy IntTy) (Call (Name "range") [constIntExp 10]) + ] let expected = True hasMixedAssignment prog `shouldBe` expected From 8bcbc0e4ef71d8df4b7888f7274cf5efce17d24a Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Sun, 20 Jun 2021 07:25:39 +0900 Subject: [PATCH 05/56] feat(rpython): Add hasNonTrivialSubscriptedAssignmentInForLoops --- src/Jikka/RestrictedPython/Convert/ToCore.hs | 4 +- src/Jikka/RestrictedPython/Language/Lint.hs | 81 ++++++++++++++++++++ 2 files changed, 83 insertions(+), 2 deletions(-) diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 29c5373e..6c241abb 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -18,7 +18,7 @@ import qualified Jikka.RestrictedPython.Language.Lint as X -- * `X.doesntHaveAssignmentToLoopCounters` -- * `X.doesntHaveAssignmentToLoopIterators` -- * `X.doesntHaveReturnInLoops` --- * `X.doesntHaveMixedAssignment` +-- * `X.doesntHaveNonTrivialSubscriptedAssignmentInForLoops` run :: MonadError Error m => X.Program -> m Y.Program run prog = do X.ensureDoesntHaveSubscriptionInLoopCounters prog @@ -26,5 +26,5 @@ run prog = do X.ensureDoesntHaveAssignmentToLoopCounters prog X.ensureDoesntHaveAssignmentToLoopIterators prog X.ensureDoesntHaveReturnInLoops prog - X.ensureDoesntHaveMixedAssignment prog + X.ensureDoesntHaveNonTrivialSubscriptedAssignmentInForLoops prog undefined diff --git a/src/Jikka/RestrictedPython/Language/Lint.hs b/src/Jikka/RestrictedPython/Language/Lint.hs index b083bf94..7e3bd9d6 100644 --- a/src/Jikka/RestrictedPython/Language/Lint.hs +++ b/src/Jikka/RestrictedPython/Language/Lint.hs @@ -145,3 +145,84 @@ doesntHaveMixedAssignment = not . hasMixedAssignment ensureDoesntHaveMixedAssignment :: MonadError Error m => Program -> m () ensureDoesntHaveMixedAssignment = makeEnsureProgram doesntHaveMixedAssignment "there must not be mixed assignments" + +-- | `hasNonTrivialSubscriptedAssignmentInForLoops` checks that there are assignments with non-trivial subscriptions in for-loops. +-- A trivial subscription is a sequence of subscriptions to a variable with constant indices and at most one trivial loop-counter indices for each loops. +-- A constant index is an expr which has a constant value in the loop. +-- A trivial loop-counter index is the loop counter from "range(n)", "range(n, m)" or "enumerate(a)" with optional post-addition with a int literal. +-- +-- For example, the followings have such assignments. +-- +-- > x = 0 +-- > for i in range(10): +-- > x += 1 +-- > a[x] += 1 +-- +-- > for i in range(10): +-- > j = i +-- > a[j] += 1 +-- +-- > for i in range(10): +-- > a[2 * i] += 1 +-- +-- > for i in range(10): +-- > a[1 + i] += 1 +-- +-- > c = 1 +-- > for i in range(10): +-- > a[i + c] += 1 +-- +-- > for i in range(10): +-- > a[i][i] += 1 +-- +-- > for i in [1, 2, 3]: +-- > a[i] += 1 +-- +-- > b = range(10) +-- > for i in b: +-- > a[i] += 1 +-- +-- > for i in range(0, 10, 2): +-- > a[i] += 1 +-- +-- > for i, b_i in enumerate(b): +-- > a[b_i] += i +-- +-- For example, the followings don't have such assignments. +-- +-- > c = 0 +-- > for i in range(10): +-- > a[c] += 1 +-- +-- > for i in range(10): +-- > a[i] += 1 +-- +-- > for i in range(10): +-- > a[i + 1] += 1 +-- +-- > for i in range(10): +-- > for j in range(10): +-- > a[i + 1][j] += 1 +-- +-- > for i in range(1, 10): +-- > a[i] += 1 +-- +-- > for i, b_i in enumerate(b): +-- > a[i] += b_i +hasNonTrivialSubscriptedAssignmentInForLoops :: Program -> Bool +hasNonTrivialSubscriptedAssignmentInForLoops prog = any check (listStatements prog) + where + check = \case + AugAssign x _ _ -> go x + AnnAssign x _ _ -> go x + _ -> False + go = \case + SubscriptTrg _ _ -> False -- TODO + NameTrg _ -> False + TupleTrg xs -> any go xs + +doesntHaveNonTrivialSubscriptedAssignmentInForLoops :: Program -> Bool +doesntHaveNonTrivialSubscriptedAssignmentInForLoops = not . hasMixedAssignment + +ensureDoesntHaveNonTrivialSubscriptedAssignmentInForLoops :: MonadError Error m => Program -> m () +ensureDoesntHaveNonTrivialSubscriptedAssignmentInForLoops = makeEnsureProgram doesntHaveNonTrivialSubscriptedAssignmentInForLoops "there must not be assignments with non-trivial subscriptions in for-loops" From 37f39d1aff726ffed7ddf76088a674f0d5a9f033 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Sun, 20 Jun 2021 07:59:03 +0900 Subject: [PATCH 06/56] refactor(rpython): s/hasNameLeakOfLoopCounters/hasLeakOfLoopCounters/ --- src/Jikka/RestrictedPython/Convert/Alpha.hs | 4 ++-- src/Jikka/RestrictedPython/Convert/ToCore.hs | 4 ++-- src/Jikka/RestrictedPython/Evaluate.hs | 6 +++--- src/Jikka/RestrictedPython/Language/Lint.hs | 14 +++++++------- 4 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Jikka/RestrictedPython/Convert/Alpha.hs b/src/Jikka/RestrictedPython/Convert/Alpha.hs index 21929d31..753858fa 100644 --- a/src/Jikka/RestrictedPython/Convert/Alpha.hs +++ b/src/Jikka/RestrictedPython/Convert/Alpha.hs @@ -234,7 +234,7 @@ runProgram = mapM runToplevelStatement -- > x3 = x3 + 1 -- > x5 = x3 + 1 -- --- * This blames leaks of loop counters of for-statements, i.e. `doesntHaveNameLeakOfLoopCounters`. +-- * This blames leaks of loop counters of for-statements, i.e. `doesntHaveLeakOfLoopCounters`. -- For example, the followings is not allowed. -- -- > for i in range(10): @@ -255,5 +255,5 @@ runProgram = mapM runToplevelStatement -- > return a # error run :: (MonadAlpha m, MonadError Error m) => Program -> m Program run prog = wrapError' "Jikka.RestrictedPython.Convert.Alpha" $ do - ensureDoesntHaveNameLeakOfLoopCounters prog + ensureDoesntHaveLeakOfLoopCounters prog evalStateT (runProgram prog) initialEnv diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 6c241abb..9668daf9 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -14,7 +14,7 @@ import qualified Jikka.RestrictedPython.Language.Lint as X -- This assumes the follwing conditions: -- -- * `X.doesntHaveSubscriptionInLoopCounters` --- * `X.doesntHaveNameLeakOfLoopCounters` +-- * `X.doesntHaveLeakOfLoopCounters` -- * `X.doesntHaveAssignmentToLoopCounters` -- * `X.doesntHaveAssignmentToLoopIterators` -- * `X.doesntHaveReturnInLoops` @@ -22,7 +22,7 @@ import qualified Jikka.RestrictedPython.Language.Lint as X run :: MonadError Error m => X.Program -> m Y.Program run prog = do X.ensureDoesntHaveSubscriptionInLoopCounters prog - X.ensureDoesntHaveNameLeakOfLoopCounters prog + X.ensureDoesntHaveLeakOfLoopCounters prog X.ensureDoesntHaveAssignmentToLoopCounters prog X.ensureDoesntHaveAssignmentToLoopIterators prog X.ensureDoesntHaveReturnInLoops prog diff --git a/src/Jikka/RestrictedPython/Evaluate.hs b/src/Jikka/RestrictedPython/Evaluate.hs index 0d9e82e2..bc44279e 100644 --- a/src/Jikka/RestrictedPython/Evaluate.hs +++ b/src/Jikka/RestrictedPython/Evaluate.hs @@ -350,7 +350,7 @@ evalCall' f actualArgs = case f of -- \qquad{(a \in \lbrace v, \mathbf{stop} \rbrace)} -- \] -- --- It assumes the program is properly alpha-converted, i.e. `doesntHaveNameLeakOfLoopCounters`. So it leaks loop counters to out of loops. +-- It assumes the program is properly alpha-converted, i.e. `doesntHaveLeakOfLoopCounters`. So it leaks loop counters to out of loops. -- -- === Rules for \(\mathbf{if}~ e \colon\quad \mathrm{stmt}; \mathrm{stmt}; \dots; \mathrm{stmt};\quad \mathbf{else}\colon\quad \mathrm{stmt}; \mathrm{stmt}; \dots; \mathrm{stmt}\) -- @@ -472,10 +472,10 @@ runWithGlobal :: MonadError Error m => Global -> Expr -> m Value runWithGlobal global e = runReaderT (evalStateT (evalExpr e) (Local M.empty)) global -- | `makeGlobal` packs toplevel definitions into `Global`. --- This assumes `doesntHaveNameLeakOfLoopCounters`. +-- This assumes `doesntHaveLeakOfLoopCounters`. makeGlobal :: MonadError Error m => Program -> m Global makeGlobal prog = do - ensureDoesntHaveNameLeakOfLoopCounters prog + ensureDoesntHaveLeakOfLoopCounters prog execStateT (mapM_ execToplevelStatement prog) initialGlobal run :: MonadError Error m => Program -> Expr -> m Value diff --git a/src/Jikka/RestrictedPython/Language/Lint.hs b/src/Jikka/RestrictedPython/Language/Lint.hs index 7e3bd9d6..1b820fbc 100644 --- a/src/Jikka/RestrictedPython/Language/Lint.hs +++ b/src/Jikka/RestrictedPython/Language/Lint.hs @@ -43,20 +43,20 @@ doesntHaveSubscriptionInLoopCounters = not . hasSubscriptionInLoopCounters ensureDoesntHaveSubscriptionInLoopCounters :: MonadError Error m => Program -> m () ensureDoesntHaveSubscriptionInLoopCounters = makeEnsureProgram doesntHaveSubscriptionInLoopCounters "there must not be subscription in loop counters" --- | `hasNameLeakOfLoopCounters` checks that there are leaks of loop counters of for-loops. +-- | `hasLeakOfLoopCounters` checks that there are leaks of loop counters of for-loops. -- For example, the following has a leak. -- -- > for i in range(100): -- > pass -- > return i # => 100 -hasNameLeakOfLoopCounters :: Program -> Bool -hasNameLeakOfLoopCounters _ = False -- TODO +hasLeakOfLoopCounters :: Program -> Bool +hasLeakOfLoopCounters _ = False -- TODO -doesntHaveNameLeakOfLoopCounters :: Program -> Bool -doesntHaveNameLeakOfLoopCounters = not . hasNameLeakOfLoopCounters +doesntHaveLeakOfLoopCounters :: Program -> Bool +doesntHaveLeakOfLoopCounters = not . hasLeakOfLoopCounters -ensureDoesntHaveNameLeakOfLoopCounters :: MonadError Error m => Program -> m () -ensureDoesntHaveNameLeakOfLoopCounters = makeEnsureProgram doesntHaveNameLeakOfLoopCounters "there must not be leaks of loop counters" +ensureDoesntHaveLeakOfLoopCounters :: MonadError Error m => Program -> m () +ensureDoesntHaveLeakOfLoopCounters = makeEnsureProgram doesntHaveLeakOfLoopCounters "there must not be leaks of loop counters" -- | `hasAssignmentToLoopCounters` checks that there are assignments to loop counters of for-loops. -- For example, the following has the assignment. From 58c895436693046bd27a9d95088c75e0233286a5 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Sun, 20 Jun 2021 10:29:16 +0900 Subject: [PATCH 07/56] feat(rpyhton): Partially implement src/Jikka/RestrictedPython/Convert/ToCore.hs --- src/Jikka/Core/Language/Util.hs | 15 +++ src/Jikka/RestrictedPython/Convert/ToCore.hs | 119 ++++++++++++++++++- src/Jikka/RestrictedPython/Language/Lint.hs | 5 +- src/Jikka/RestrictedPython/Language/Util.hs | 15 +++ 4 files changed, 151 insertions(+), 3 deletions(-) create mode 100644 src/Jikka/Core/Language/Util.hs diff --git a/src/Jikka/Core/Language/Util.hs b/src/Jikka/Core/Language/Util.hs new file mode 100644 index 00000000..cb808a75 --- /dev/null +++ b/src/Jikka/Core/Language/Util.hs @@ -0,0 +1,15 @@ +module Jikka.Core.Language.Util where + +import Jikka.Common.Alpha +import Jikka.Core.Language.Expr + +genType :: MonadAlpha m => m Type +genType = do + i <- nextCounter + return $ VarTy (TypeName ('$' : show i)) + +genVarName :: MonadAlpha m => VarName -> m VarName +genVarName x = do + i <- nextCounter + let base = if unVarName x == "_" then "" else takeWhile (/= '$') (unVarName x) + return $ VarName (base ++ '$' : show i) diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 9668daf9..fb970480 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -1,15 +1,130 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} module Jikka.RestrictedPython.Convert.ToCore ( run, ) where +import Control.Arrow ((***)) +import Jikka.Common.Alpha import Jikka.Common.Error import qualified Jikka.Core.Language.Expr as Y +import qualified Jikka.Core.Language.Util as Y import qualified Jikka.RestrictedPython.Language.Expr as X import qualified Jikka.RestrictedPython.Language.Lint as X +runVarName :: X.VarName -> Y.VarName +runVarName (X.VarName x) = Y.VarName x + +runType :: X.Type -> Y.Type +runType = \case + X.VarTy (X.TypeName x) -> Y.VarTy (Y.TypeName x) + X.IntTy -> Y.IntTy + X.BoolTy -> Y.BoolTy + X.ListTy t -> Y.ListTy (runType t) + X.TupleTy ts -> Y.TupleTy (map runType ts) + X.CallableTy args ret -> Y.FunTy (map runType args) (runType ret) + +runConstant :: X.Constant -> Y.Literal +runConstant = \case + X.ConstNone -> undefined -- TODO + X.ConstInt n -> Y.LitInt n + X.ConstBool p -> Y.LitBool p + +runBoolOp :: X.BoolOp -> Y.Builtin +runBoolOp = \case + X.And -> Y.And + X.Or -> Y.Or + X.Implies -> Y.Implies + +runUnaryOp :: X.UnaryOp -> Y.Builtin +runUnaryOp = \case + X.Invert -> Y.BitNot + X.Not -> Y.Not + X.UAdd -> undefined -- TODO + X.USub -> Y.Negate + +runOperator :: X.Operator -> Y.Builtin +runOperator = \case + X.Add -> Y.Plus + X.Sub -> Y.Minus + X.Mult -> Y.Mult + X.MatMult -> undefined -- TODO + X.Div -> undefined -- TODO + X.FloorDiv -> Y.FloorDiv + X.FloorMod -> Y.FloorMod + X.CeilDiv -> Y.CeilDiv + X.CeilMod -> Y.CeilMod + X.Pow -> Y.Pow + X.BitLShift -> Y.BitLeftShift + X.BitRShift -> Y.BitRightShift + X.BitOr -> Y.BitOr + X.BitXor -> Y.BitXor + X.BitAnd -> Y.BitAnd + X.Max -> Y.Max + X.Min -> Y.Min + +runCmpOp :: X.CmpOp -> Y.Builtin +runCmpOp = \case + X.Lt -> Y.LessThan + X.LtE -> Y.LessEqual + X.Gt -> Y.GreaterThan + X.GtE -> Y.GreaterEqual + X.Eq' -> Y.Equal undefined -- TODO + X.NotEq -> Y.NotEqual undefined -- TODO + X.Is -> undefined -- TODO + X.IsNot -> undefined -- TODO + X.In -> undefined -- TODO + X.NotIn -> undefined -- TODO + +makeList2 :: a -> a -> [a] +makeList2 x y = [x, y] + +runExpr :: (MonadAlpha m, MonadError Error m) => X.Expr -> m Y.Expr +runExpr = \case + X.BoolOp e1 op e2 -> Y.AppBuiltin (runBoolOp op) <$> (makeList2 <$> runExpr e1 <*> runExpr e2) + X.BinOp e1 op e2 -> Y.AppBuiltin (runOperator op) <$> (makeList2 <$> runExpr e1 <*> runExpr e2) + X.UnaryOp op e -> Y.AppBuiltin (runUnaryOp op) . (: []) <$> runExpr e + X.Lambda _ _ -> undefined -- TODO + X.IfExp e1 e2 e3 -> do + e1 <- runExpr e1 + e2 <- runExpr e2 + e3 <- runExpr e3 + t <- Y.genType + return $ Y.AppBuiltin (Y.If t) [e1, e2, e3] + X.ListComp _ (X.Comprehension _ _ _) -> undefined -- TODO + X.Compare e1 op e2 -> Y.AppBuiltin (runCmpOp op) <$> (makeList2 <$> runExpr e1 <*> runExpr e2) + X.Call f args -> Y.App <$> runExpr f <*> mapM runExpr args + X.Constant const -> return $ Y.Lit (runConstant const) + X.Subscript e1 e2 -> Y.AppBuiltin <$> (Y.At <$> Y.genType) <*> (makeList2 <$> runExpr e1 <*> runExpr e2) + X.Name x -> return $ Y.Var (runVarName x) + X.List _ _ -> undefined -- TODO + X.Tuple _ -> undefined -- TODO + X.SubscriptSlice _ _ _ _ -> undefined -- TODO + +runStatements :: (MonadAlpha m, MonadError Error m) => [X.Statement] -> m Y.Expr +runStatements [] = throwSemanticError "function may not return" +runStatements (stmt : stmts) = case stmt of + X.Return e -> runExpr e + X.AugAssign _ _ _ -> undefined -- TODO + X.AnnAssign _ _ _ -> undefined -- TODO + X.For _ _ _ -> undefined -- TODO + X.If e body1 body2 -> do + e <- runExpr e + body1 <- runStatements (body1 ++ stmts) + body2 <- runStatements (body2 ++ stmts) + t <- Y.genType + return $ Y.AppBuiltin (Y.If t) [e, body1, body2] + X.Assert _ -> runStatements stmts + +runToplevelStatements :: (MonadAlpha m, MonadError Error m) => [X.ToplevelStatement] -> m Y.ToplevelExpr +runToplevelStatements [] = return $ Y.ResultExpr (Y.Var (Y.VarName "solve")) +runToplevelStatements (stmt : stmts) = case stmt of + X.ToplevelAnnAssign _ _ _ -> undefined -- TODO + X.ToplevelFunctionDef f args ret body -> Y.ToplevelLet Y.Rec (runVarName f) (map (runVarName *** runType) args) (runType ret) <$> runStatements body <*> runToplevelStatements stmts + X.ToplevelAssert _ -> runToplevelStatements stmts -- TOOD: use assertions as hints + -- | `run` converts programs of our restricted Python-like language to programs of our core language. -- This assumes the follwing conditions: -- @@ -19,7 +134,7 @@ import qualified Jikka.RestrictedPython.Language.Lint as X -- * `X.doesntHaveAssignmentToLoopIterators` -- * `X.doesntHaveReturnInLoops` -- * `X.doesntHaveNonTrivialSubscriptedAssignmentInForLoops` -run :: MonadError Error m => X.Program -> m Y.Program +run :: (MonadAlpha m, MonadError Error m) => X.Program -> m Y.Program run prog = do X.ensureDoesntHaveSubscriptionInLoopCounters prog X.ensureDoesntHaveLeakOfLoopCounters prog @@ -27,4 +142,4 @@ run prog = do X.ensureDoesntHaveAssignmentToLoopIterators prog X.ensureDoesntHaveReturnInLoops prog X.ensureDoesntHaveNonTrivialSubscriptedAssignmentInForLoops prog - undefined + runToplevelStatements prog diff --git a/src/Jikka/RestrictedPython/Language/Lint.hs b/src/Jikka/RestrictedPython/Language/Lint.hs index 1b820fbc..63dc97b4 100644 --- a/src/Jikka/RestrictedPython/Language/Lint.hs +++ b/src/Jikka/RestrictedPython/Language/Lint.hs @@ -149,7 +149,7 @@ ensureDoesntHaveMixedAssignment = makeEnsureProgram doesntHaveMixedAssignment "t -- | `hasNonTrivialSubscriptedAssignmentInForLoops` checks that there are assignments with non-trivial subscriptions in for-loops. -- A trivial subscription is a sequence of subscriptions to a variable with constant indices and at most one trivial loop-counter indices for each loops. -- A constant index is an expr which has a constant value in the loop. --- A trivial loop-counter index is the loop counter from "range(n)", "range(n, m)" or "enumerate(a)" with optional post-addition with a int literal. +-- A trivial loop-counter index is the loop counter from "range(n)", "range(n, m)" or "enumerate(a)" with optional post-addition with a positive int literal. -- -- For example, the followings have such assignments. -- @@ -168,6 +168,9 @@ ensureDoesntHaveMixedAssignment = makeEnsureProgram doesntHaveMixedAssignment "t -- > for i in range(10): -- > a[1 + i] += 1 -- +-- > for i in range(10): +-- > a[i - 1] += 1 +-- -- > c = 1 -- > for i in range(10): -- > a[i + c] += 1 diff --git a/src/Jikka/RestrictedPython/Language/Util.hs b/src/Jikka/RestrictedPython/Language/Util.hs index e44b9e3b..8f0183aa 100644 --- a/src/Jikka/RestrictedPython/Language/Util.hs +++ b/src/Jikka/RestrictedPython/Language/Util.hs @@ -38,6 +38,10 @@ module Jikka.RestrictedPython.Language.Util mapExprM, listExprs, + -- * exprs + hasFunctionCall, + isSmallExpr, + -- * targets targetVars, hasSubscriptTrg, @@ -276,6 +280,17 @@ mapStatementsM f = mapM (mapStatementsToplevelStatementM f) mapStatements :: ([Statement] -> [Statement]) -> Program -> Program mapStatements f = runIdentity . mapStatementsM (return . f) +hasFunctionCall :: Expr -> Bool +hasFunctionCall = any check . listSubExprs + where + check = \case + Call _ _ -> True + _ -> False + +-- | `isSmallExpr` is true if the evaluation of a given expr trivially terminates. +isSmallExpr :: Expr -> Bool +isSmallExpr = not . hasFunctionCall + targetVars :: Target -> [VarName] targetVars = nub . go where From a617f3cb8afdf71cea308cff985b373a13a94dc7 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Sun, 20 Jun 2021 10:47:32 +0900 Subject: [PATCH 08/56] feat(rpython): Put types to CmpOp for let-polymorphism --- src/Jikka/Python/Convert/ToRestrictedPython.hs | 5 +++-- src/Jikka/RestrictedPython/Convert/ToCore.hs | 4 ++-- src/Jikka/RestrictedPython/Convert/TypeInfer.hs | 5 +++-- src/Jikka/RestrictedPython/Format.hs | 4 ++-- src/Jikka/RestrictedPython/Language/Expr.hs | 8 +++++++- test/Jikka/RestrictedPython/EvaluateSpec.hs | 2 +- 6 files changed, 18 insertions(+), 10 deletions(-) diff --git a/src/Jikka/Python/Convert/ToRestrictedPython.hs b/src/Jikka/Python/Convert/ToRestrictedPython.hs index 1fffa105..cc4f3ed8 100644 --- a/src/Jikka/Python/Convert/ToRestrictedPython.hs +++ b/src/Jikka/Python/Convert/ToRestrictedPython.hs @@ -99,11 +99,12 @@ runCompareExpr e1 ops = runExpr e1 >>= (`go` ops) go :: (MonadAlpha m, MonadError Error m) => Y.Expr -> [(X.CmpOp, X.Expr')] -> m Y.Expr go e1 = \case [] -> return $ Y.Constant (Y.ConstBool True) - [(op, e2)] -> Y.Compare e1 op <$> runExpr e2 + [(op, e2)] -> Y.Compare e1 <$> (Y.CmpOp' op <$> Y.genType) <*> runExpr e2 (op, e2) : ops -> do + t <- Y.genType e2 <- runExpr e2 cont <- go e2 ops - return $ Y.BoolOp (Y.Compare e1 op e2) Y.And cont + return $ Y.BoolOp (Y.Compare e1 (Y.CmpOp' op t) e2) Y.And cont runExpr :: (MonadAlpha m, MonadError Error m) => X.Expr' -> m Y.Expr runExpr e = case value e of diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index fb970480..2ced6792 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -65,8 +65,8 @@ runOperator = \case X.Max -> Y.Max X.Min -> Y.Min -runCmpOp :: X.CmpOp -> Y.Builtin -runCmpOp = \case +runCmpOp :: X.CmpOp' -> Y.Builtin +runCmpOp (X.CmpOp' op _) = case op of X.Lt -> Y.LessThan X.LtE -> Y.LessEqual X.Gt -> Y.GreaterThan diff --git a/src/Jikka/RestrictedPython/Convert/TypeInfer.hs b/src/Jikka/RestrictedPython/Convert/TypeInfer.hs index f60062af..c551402c 100644 --- a/src/Jikka/RestrictedPython/Convert/TypeInfer.hs +++ b/src/Jikka/RestrictedPython/Convert/TypeInfer.hs @@ -102,10 +102,11 @@ formularizeExpr = \case tpred <- formularizeExpr pred formularizeType tpred BoolTy return $ ListTy te - Compare e1 _ e2 -> do + Compare e1 (CmpOp' op t) e2 -> do t1 <- formularizeExpr e1 t2 <- formularizeExpr e2 - formularizeType t1 t2 + formularizeType t1 t + formularizeType t2 (if op == In || op == NotIn then ListTy t else t) return BoolTy Call f args -> do ts <- mapM formularizeExpr args diff --git a/src/Jikka/RestrictedPython/Format.hs b/src/Jikka/RestrictedPython/Format.hs index c74b75cb..52e5948a 100644 --- a/src/Jikka/RestrictedPython/Format.hs +++ b/src/Jikka/RestrictedPython/Format.hs @@ -69,8 +69,8 @@ formatUnaryOp = \case UAdd -> "+" USub -> "-" -formatCmpOp :: CmpOp -> String -formatCmpOp = \case +formatCmpOp :: CmpOp' -> String +formatCmpOp (CmpOp' op _) = case op of Eq' -> "==" NotEq -> "!=" Lt -> "<" diff --git a/src/Jikka/RestrictedPython/Language/Expr.hs b/src/Jikka/RestrictedPython/Language/Expr.hs index 507ac3bc..d01bc6ab 100644 --- a/src/Jikka/RestrictedPython/Language/Expr.hs +++ b/src/Jikka/RestrictedPython/Language/Expr.hs @@ -23,6 +23,7 @@ module Jikka.RestrictedPython.Language.Expr Program, BoolOp (..), CmpOp (..), + CmpOp' (..), Operator (..), UnaryOp (..), ) @@ -85,6 +86,11 @@ data Target | TupleTrg [Target] deriving (Eq, Ord, Show, Read) +-- | `CmpOp'` is a type for comparision operators. +-- This is annotated with its type as let-polymorphism. +data CmpOp' = CmpOp' CmpOp Type + deriving (Eq, Ord, Show, Read) + data Comprehension = Comprehension Target Expr (Maybe Expr) deriving (Eq, Ord, Show, Read) @@ -114,7 +120,7 @@ data Expr | Lambda [(VarName, Type)] Expr | IfExp Expr Expr Expr | ListComp Expr Comprehension - | Compare Expr CmpOp Expr + | Compare Expr CmpOp' Expr | Call Expr [Expr] | Constant Constant | Subscript Expr Expr diff --git a/test/Jikka/RestrictedPython/EvaluateSpec.hs b/test/Jikka/RestrictedPython/EvaluateSpec.hs index 8271a1cf..339f2fc5 100644 --- a/test/Jikka/RestrictedPython/EvaluateSpec.hs +++ b/test/Jikka/RestrictedPython/EvaluateSpec.hs @@ -17,7 +17,7 @@ spec = describe "run" $ do [("n", IntTy)] IntTy [ If - (Compare (Name "n") Eq' (constIntExp 0)) + (Compare (Name "n") (CmpOp' Eq' IntTy) (constIntExp 0)) [Return (constIntExp 1)] [Return (BinOp (Name "n") Mult (Call (Name "fact") [BinOp (Name "n") Sub (constIntExp 1)]))] ] From 81d7c82eccba099a45758af54db3252586942970 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Mon, 21 Jun 2021 03:52:50 +0900 Subject: [PATCH 09/56] feat(rpython): Use typed Builtin in Expr --- src/Jikka/Main/Subcommand/Execute.hs | 2 + src/Jikka/RestrictedPython/Convert/Alpha.hs | 6 +- .../Convert/ResolveBuiltin.hs | 34 +++ src/Jikka/RestrictedPython/Convert/ToCore.hs | 53 ++++- .../RestrictedPython/Convert/TypeInfer.hs | 2 + src/Jikka/RestrictedPython/Evaluate.hs | 94 +++----- src/Jikka/RestrictedPython/Format.hs | 9 +- .../RestrictedPython/Language/Builtin.hs | 208 ++++++++++++++++++ src/Jikka/RestrictedPython/Language/Expr.hs | 117 +++++++++- src/Jikka/RestrictedPython/Language/Lint.hs | 33 +++ src/Jikka/RestrictedPython/Language/Stdlib.hs | 102 --------- src/Jikka/RestrictedPython/Language/Util.hs | 4 + src/Jikka/RestrictedPython/Language/Value.hs | 132 +---------- .../RestrictedPython/Convert/AlphaSpec.hs | 29 +++ .../Convert/ResolveBuiltinSpec.hs | 33 +++ test/Jikka/RestrictedPython/EvaluateSpec.hs | 6 +- .../RestrictedPython/Language/ValueSpec.hs | 15 -- 17 files changed, 546 insertions(+), 333 deletions(-) create mode 100644 src/Jikka/RestrictedPython/Convert/ResolveBuiltin.hs create mode 100644 src/Jikka/RestrictedPython/Language/Builtin.hs delete mode 100644 src/Jikka/RestrictedPython/Language/Stdlib.hs create mode 100644 test/Jikka/RestrictedPython/Convert/ResolveBuiltinSpec.hs delete mode 100644 test/Jikka/RestrictedPython/Language/ValueSpec.hs diff --git a/src/Jikka/Main/Subcommand/Execute.hs b/src/Jikka/Main/Subcommand/Execute.hs index 98d01783..5a0b0734 100644 --- a/src/Jikka/Main/Subcommand/Execute.hs +++ b/src/Jikka/Main/Subcommand/Execute.hs @@ -11,6 +11,7 @@ import qualified Jikka.Python.Parse as FromPython import qualified Jikka.RestrictedPython.Convert.Alpha as Alpha import qualified Jikka.RestrictedPython.Convert.RemoveUnbalancedIf as RemoveUnbalancedIf import qualified Jikka.RestrictedPython.Convert.RemoveUnreachable as RemoveUnreachable +import qualified Jikka.RestrictedPython.Convert.ResolveBuiltin as ResolveBuiltin import qualified Jikka.RestrictedPython.Convert.SplitLoops as SplitLoops import qualified Jikka.RestrictedPython.Convert.TypeInfer as TypeInfer import qualified Jikka.RestrictedPython.Evaluate as Evaluate @@ -22,6 +23,7 @@ run path = flip evalAlphaT 0 $ do prog <- liftEither $ FromPython.run path prog prog <- ToRestrictedPython.run prog prog <- return $ RemoveUnreachable.run prog + prog <- ResolveBuiltin.run prog prog <- Alpha.run prog prog <- TypeInfer.run prog prog <- SplitLoops.run prog diff --git a/src/Jikka/RestrictedPython/Convert/Alpha.hs b/src/Jikka/RestrictedPython/Convert/Alpha.hs index 753858fa..8756fbd9 100644 --- a/src/Jikka/RestrictedPython/Convert/Alpha.hs +++ b/src/Jikka/RestrictedPython/Convert/Alpha.hs @@ -11,9 +11,9 @@ import Data.List (delete) import qualified Data.Set as S import Jikka.Common.Alpha import Jikka.Common.Error +import Jikka.RestrictedPython.Language.Builtin import Jikka.RestrictedPython.Language.Expr import Jikka.RestrictedPython.Language.Lint -import Jikka.RestrictedPython.Language.Stdlib import Jikka.RestrictedPython.Language.Util data Env = Env @@ -26,7 +26,7 @@ initialEnv :: Env initialEnv = Env { currentMapping = [], - parentMappings = [map (\x -> (x, x)) (S.toList builtinFunctions)] + parentMappings = [map (\x -> (x, x)) (S.toList builtinNames)] } withToplevelScope :: MonadState Env m => m a -> m a @@ -212,6 +212,7 @@ runProgram :: (MonadState Env m, MonadAlpha m, MonadError Error m) => Program -> runProgram = mapM runToplevelStatement -- | `run` renames variables. +-- This assumes `doesntHaveAssignmentToBuiltin`. -- -- * This introduce a new name for each assignment if possible. -- For example, the following @@ -256,4 +257,5 @@ runProgram = mapM runToplevelStatement run :: (MonadAlpha m, MonadError Error m) => Program -> m Program run prog = wrapError' "Jikka.RestrictedPython.Convert.Alpha" $ do ensureDoesntHaveLeakOfLoopCounters prog + ensureDoesntHaveAssignmentToBuiltin prog evalStateT (runProgram prog) initialEnv diff --git a/src/Jikka/RestrictedPython/Convert/ResolveBuiltin.hs b/src/Jikka/RestrictedPython/Convert/ResolveBuiltin.hs new file mode 100644 index 00000000..0dcedb1d --- /dev/null +++ b/src/Jikka/RestrictedPython/Convert/ResolveBuiltin.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} + +module Jikka.RestrictedPython.Convert.ResolveBuiltin + ( run, + ) +where + +import Jikka.Common.Alpha +import Jikka.Common.Error +import Jikka.RestrictedPython.Language.Builtin +import Jikka.RestrictedPython.Language.Expr +import Jikka.RestrictedPython.Language.Lint +import Jikka.RestrictedPython.Language.Util + +runExpr :: (MonadAlpha m, MonadError Error m) => Expr -> m Expr +runExpr = mapSubExprM go + where + go = \case + Name x -> resolveUniqueBuiltin x + Call (Name f) args -> Call <$> resolveBuiltin f (length args) <*> pure args + e -> return e + +-- | `run` resolves types of polymorphic builtin functions. +-- This assumes there are no assignments to builtin functions, i.e. `doesntHaveAssignmentToBuiltin`. +-- +-- For example, the "max" of "max(xs)" has a type \(\mathbf{list}(\alpha) \to \alpha\) but the "max" of "max(x, y, z)" has a type \(\alpha \times \alpha \times \alpha \to \alpha\). +-- So this function converts `Var "max"` to `BuiltinMax1 t`,`BuiltinMax t 2`, `BuiltinMax t 3`, etc.. +run :: (MonadAlpha m, MonadError Error m) => Program -> m Program +run prog = wrapError' "Jikka.RestrictedPython.Convert.ResolveBuiltin" $ do + ensureDoesntHaveAssignmentToBuiltin prog + prog <- mapExprM runExpr prog + ensureDoesntHaveNonResolvedBuiltin prog + return prog diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 2ced6792..47a9320d 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -26,11 +26,56 @@ runType = \case X.TupleTy ts -> Y.TupleTy (map runType ts) X.CallableTy args ret -> Y.FunTy (map runType args) (runType ret) -runConstant :: X.Constant -> Y.Literal +runConstant :: X.Constant -> Y.Expr runConstant = \case X.ConstNone -> undefined -- TODO - X.ConstInt n -> Y.LitInt n - X.ConstBool p -> Y.LitBool p + X.ConstInt n -> Y.Lit (Y.LitInt n) + X.ConstBool p -> Y.Lit (Y.LitBool p) + X.ConstBuiltin builtin -> runBuiltin builtin + +runBuiltin :: X.Builtin -> Y.Expr +runBuiltin builtin = + let f = Y.Lit . Y.LitBuiltin + in case builtin of + X.BuiltinAbs -> f Y.Abs + X.BuiltinPow -> f Y.Pow + X.BuiltinModPow -> undefined -- TODO + X.BuiltinDivMod -> undefined -- TODO + X.BuiltinCeilDiv -> f Y.CeilDiv + X.BuiltinCeilMod -> f Y.CeilMod + X.BuiltinFloorDiv -> f Y.FloorDiv + X.BuiltinFloorMod -> f Y.FloorMod + X.BuiltinGcd -> f Y.Gcd + X.BuiltinLcm -> f Y.Lcm + X.BuiltinInt _ -> undefined -- TODO + X.BuiltinBool _ -> undefined -- TODO + X.BuiltinList _ -> undefined -- TODO + X.BuiltinTuple _ -> undefined -- TODO + X.BuiltinLen t -> f $ Y.Len (runType t) + X.BuiltinMap _ _ -> undefined -- TODO + X.BuiltinSorted t -> f $ Y.Sorted (runType t) + X.BuiltinReversed t -> f $ Y.Reversed (runType t) + X.BuiltinEnumerate _ -> undefined -- TODO + X.BuiltinFilter _ -> undefined -- TODO + X.BuiltinZip _ -> undefined -- TODO + X.BuiltinAll -> undefined -- TODO + X.BuiltinAny -> undefined -- TODO + X.BuiltinSum -> f Y.Sum + X.BuiltinProduct -> f Y.Product + X.BuiltinRange1 -> f Y.Range1 + X.BuiltinRange2 -> f Y.Range2 + X.BuiltinRange3 -> f Y.Range1 + X.BuiltinMax1 _ -> undefined -- TODO + X.BuiltinMax _ _ -> undefined -- TODO + X.BuiltinMin1 _ -> undefined -- TODO + X.BuiltinMin _ _ -> undefined -- TODO + X.BuiltinArgMax _ -> undefined -- TODO + X.BuiltinArgMin _ -> undefined -- TODO + X.BuiltinFact -> f Y.Fact + X.BuiltinChoose -> f Y.Choose + X.BuiltinPermute -> f Y.Permute + X.BuiltinMultiChoose -> f Y.MultiChoose + X.BuiltinModInv -> f Y.Inv runBoolOp :: X.BoolOp -> Y.Builtin runBoolOp = \case @@ -96,7 +141,7 @@ runExpr = \case X.ListComp _ (X.Comprehension _ _ _) -> undefined -- TODO X.Compare e1 op e2 -> Y.AppBuiltin (runCmpOp op) <$> (makeList2 <$> runExpr e1 <*> runExpr e2) X.Call f args -> Y.App <$> runExpr f <*> mapM runExpr args - X.Constant const -> return $ Y.Lit (runConstant const) + X.Constant const -> return $ runConstant const X.Subscript e1 e2 -> Y.AppBuiltin <$> (Y.At <$> Y.genType) <*> (makeList2 <$> runExpr e1 <*> runExpr e2) X.Name x -> return $ Y.Var (runVarName x) X.List _ _ -> undefined -- TODO diff --git a/src/Jikka/RestrictedPython/Convert/TypeInfer.hs b/src/Jikka/RestrictedPython/Convert/TypeInfer.hs index c551402c..62e90608 100644 --- a/src/Jikka/RestrictedPython/Convert/TypeInfer.hs +++ b/src/Jikka/RestrictedPython/Convert/TypeInfer.hs @@ -32,6 +32,7 @@ import Control.Monad.Writer.Strict import qualified Data.Map.Strict as M import Jikka.Common.Alpha import Jikka.Common.Error +import Jikka.RestrictedPython.Language.Builtin import Jikka.RestrictedPython.Language.Expr import Jikka.RestrictedPython.Language.Util @@ -118,6 +119,7 @@ formularizeExpr = \case ConstNone -> TupleTy [] ConstInt _ -> IntTy ConstBool _ -> BoolTy + ConstBuiltin b -> typeBuiltin b Subscript e1 e2 -> do t <- genType formularizeExpr' e1 (ListTy t) diff --git a/src/Jikka/RestrictedPython/Evaluate.hs b/src/Jikka/RestrictedPython/Evaluate.hs index bc44279e..bca046d0 100644 --- a/src/Jikka/RestrictedPython/Evaluate.hs +++ b/src/Jikka/RestrictedPython/Evaluate.hs @@ -27,7 +27,6 @@ import Data.List (maximumBy, minimumBy, sortBy) import qualified Data.Map.Strict as M import qualified Data.Vector as V import Jikka.Common.Error -import Jikka.Common.Matrix import Jikka.RestrictedPython.Language.Expr import Jikka.RestrictedPython.Language.Lint import Jikka.RestrictedPython.Language.Value @@ -227,6 +226,7 @@ evalExpr = \case ConstNone -> TupleVal [] ConstInt v -> IntVal v ConstBool v -> BoolVal v + ConstBuiltin v -> BuiltinVal v Subscript e1 e2 -> do v1 <- evalExpr e1 v2 <- evalExpr e2 @@ -485,42 +485,13 @@ run prog e = do evalBinOp :: MonadError Error m => Value -> Operator -> Value -> m Value evalBinOp v1 op v2 = do - case (v1, op, v2) of - (IntVal v1, MatMult, ListVal v2) -> do - v2 <- toMatrix' v2 - return $ fromMatrix (matscalar v1 v2) - (ListVal v1, MatMult, ListVal v2) -> do - v1 <- toMatrix' v1 - let (_, w) = matsize v1 - case (toMatrix v2, toIntList v2) of - (Just v2, _) -> do - let (h, _) = matsize v2 - when (w /= h) $ do - throwRuntimeError "sizes of matrices mismatch" - return $ fromMatrix (matmul v1 v2) - (_, Just v2) -> do - let h = V.length v2 - when (w /= h) $ do - throwRuntimeError "sizes of a matrix and a vector mismatch" - return $ ListVal (V.map IntVal (matap v1 v2)) - (_, _) -> throwRuntimeError "not a matrix nor a vector" - (ListVal v1, Pow, IntVal v2) -> do - v1 <- toMatrix' v1 - when (v2 < 0) $ do - throwRuntimeError "cannot calculate a negative power of a matrix" - return $ fromMatrix (matpow v1 v2) - (ListVal v1, Add, ListVal v2) -> do - return $ ListVal (v1 V.++ v2) - (ListVal v1, Mult, IntVal v2) -> do - return $ ListVal (V.concat (replicate (fromInteger v2) v1)) - (IntVal v1, Mult, ListVal v2) -> do - return $ ListVal (V.concat (replicate (fromInteger v1) v2)) - (IntVal v1, _, IntVal v2) -> do + case (v1, v2) of + (IntVal v1, IntVal v2) -> do v <- case (op, v2) of (Add, _) -> return $ v1 + v2 (Sub, _) -> return $ v1 - v2 (Mult, _) -> return $ v1 * v2 - (MatMult, _) -> throwRuntimeError "type error" + (MatMult, _) -> throwRuntimeError "matmul operator ('@') is not supported" (Div, _) -> throwRuntimeError "floatdiv operator ('/') is not supported" (FloorDiv, 0) -> throwRuntimeError "division by zero" (FloorDiv, _) -> return $ v1 `div` v2 @@ -539,31 +510,33 @@ evalBinOp v1 op v2 = do (Max, _) -> return $ max v1 v2 (Min, _) -> return $ min v1 v2 return $ IntVal v - (_, _, _) -> throwRuntimeError "type error" + (_, _) -> throwRuntimeError "type error" evalBuiltin :: (MonadReader Global m, MonadState Local m, MonadError Error m) => Builtin -> [Value] -> m Value evalBuiltin b args = case (b, args) of (BuiltinAbs, [IntVal n]) -> return $ IntVal (abs n) + (BuiltinPow, [IntVal x, IntVal k]) -> return $ IntVal (x ^ k) + (BuiltinModPow, [IntVal x, IntVal k, IntVal m]) -> return $ IntVal ((x ^ k) `mod` m) (BuiltinAll, [ListVal xs]) -> BoolVal . minimum <$> toBoolList' xs - (BuiltinMin, [ListVal xs]) -> return $ V.minimumBy compareValues' xs - (BuiltinMin, xs@(_ : _ : _)) -> return $ minimumBy compareValues' xs + (BuiltinMin1 _, [ListVal xs]) -> return $ V.minimumBy compareValues' xs + (BuiltinMin _ _, xs@(_ : _ : _)) -> return $ minimumBy compareValues' xs (BuiltinAny, [ListVal xs]) -> BoolVal . maximum <$> toBoolList' xs (BuiltinDivMod, [IntVal _, IntVal 0]) -> throwRuntimeError "division by zero" (BuiltinDivMod, [IntVal a, IntVal b]) -> return $ TupleVal [IntVal (a `div` b), IntVal (a `mod` b)] - (BuiltinSorted, [ListVal xs]) -> + (BuiltinSorted _, [ListVal xs]) -> return $ ListVal (V.fromList (sortBy compareValues' (V.toList xs))) - (BuiltinEnumerate, [ListVal xs]) -> + (BuiltinEnumerate _, [ListVal xs]) -> return $ ListVal (V.fromList (zipWith (\i x -> TupleVal [IntVal i, x]) [0 ..] (V.toList xs))) - (BuiltinBool, [IntVal n]) -> return $ BoolVal (n /= 0) - (BuiltinBool, [BoolVal p]) -> return $ BoolVal p - (BuiltinBool, [ListVal xs]) -> return $ BoolVal (not (V.null xs)) - (BuiltinBool, [TupleVal xs]) -> return $ BoolVal (not (null xs)) - (BuiltinInt, [IntVal n]) -> return $ IntVal n - (BuiltinInt, [BoolVal p]) -> return $ IntVal (if p then 1 else 0) + (BuiltinBool _, [IntVal n]) -> return $ BoolVal (n /= 0) + (BuiltinBool _, [BoolVal p]) -> return $ BoolVal p + (BuiltinBool _, [ListVal xs]) -> return $ BoolVal (not (V.null xs)) + (BuiltinBool _, [TupleVal xs]) -> return $ BoolVal (not (null xs)) + (BuiltinInt _, [IntVal n]) -> return $ IntVal n + (BuiltinInt _, [BoolVal p]) -> return $ IntVal (if p then 1 else 0) (BuiltinSum, [ListVal xs]) -> IntVal . sum <$> toIntList' xs - (BuiltinZip, [ListVal xs1, ListVal xs2]) -> return $ ListVal (V.zipWith (\x1 x2 -> TupleVal [x1, x2]) xs1 xs2) - (BuiltinZip, [ListVal xs1, ListVal xs2, ListVal xs3]) -> return $ ListVal (V.zipWith3 (\x1 x2 x3 -> TupleVal [x1, x2, x3]) xs1 xs2 xs3) - (BuiltinFilter, [f, ListVal xs]) -> do + (BuiltinZip _, [ListVal xs1, ListVal xs2]) -> return $ ListVal (V.zipWith (\x1 x2 -> TupleVal [x1, x2]) xs1 xs2) + (BuiltinZip _, [ListVal xs1, ListVal xs2, ListVal xs3]) -> return $ ListVal (V.zipWith3 (\x1 x2 x3 -> TupleVal [x1, x2, x3]) xs1 xs2 xs3) + (BuiltinFilter _, [f, ListVal xs]) -> do let go x = do pred <- evalCall' f [x] case pred of @@ -571,22 +544,22 @@ evalBuiltin b args = case (b, args) of BoolVal False -> return Nothing _ -> throwRuntimeError "type error" ListVal <$> V.mapMaybeM go xs - (BuiltinLen, [ListVal xs]) -> return $ IntVal (fromIntegral (V.length xs)) - (BuiltinList, [ListVal xs]) -> return $ ListVal xs - (BuiltinRange, [IntVal to]) -> return $ ListVal (V.fromList (map IntVal [0 .. to - 1])) - (BuiltinRange, [IntVal from, IntVal to]) -> return $ ListVal (V.fromList (map IntVal [from .. to - 1])) - (BuiltinRange, [IntVal from, IntVal to, IntVal step]) -> return $ ListVal (V.fromList (map IntVal [from, from + step .. to - 1])) - (BuiltinMap, [f, ListVal xs]) -> do + (BuiltinLen _, [ListVal xs]) -> return $ IntVal (fromIntegral (V.length xs)) + (BuiltinList _, [ListVal xs]) -> return $ ListVal xs + (BuiltinRange1, [IntVal to]) -> return $ ListVal (V.fromList (map IntVal [0 .. to - 1])) + (BuiltinRange2, [IntVal from, IntVal to]) -> return $ ListVal (V.fromList (map IntVal [from .. to - 1])) + (BuiltinRange3, [IntVal from, IntVal to, IntVal step]) -> return $ ListVal (V.fromList (map IntVal [from, from + step .. to - 1])) + (BuiltinMap _ _, [f, ListVal xs]) -> do let go x = evalCall' f [x] ListVal <$> V.mapM go xs - (BuiltinMap, [f, ListVal xs1, ListVal xs2]) -> do + (BuiltinMap _ _, [f, ListVal xs1, ListVal xs2]) -> do let go x1 x2 = evalCall' f [x1, x2] ListVal <$> V.zipWithM go xs1 xs2 - (BuiltinReversed, [ListVal xs]) -> return $ ListVal (V.reverse xs) - (BuiltinMax, [ListVal xs]) -> return $ V.maximumBy compareValues' xs - (BuiltinMax, xs@(_ : _ : _)) -> return $ maximumBy compareValues' xs - (BuiltinArgMax, [ListVal _]) -> throwRuntimeError "TODO evalBuiltin" - (BuiltinArgMin, [ListVal _]) -> throwRuntimeError "TODO evalBuiltin" + (BuiltinReversed _, [ListVal xs]) -> return $ ListVal (V.reverse xs) + (BuiltinMax1 _, [ListVal xs]) -> return $ V.maximumBy compareValues' xs + (BuiltinMax _ _, xs@(_ : _ : _)) -> return $ maximumBy compareValues' xs + (BuiltinArgMax _, [ListVal _]) -> throwRuntimeError "TODO evalBuiltin" + (BuiltinArgMin _, [ListVal _]) -> throwRuntimeError "TODO evalBuiltin" (BuiltinCeilDiv, [IntVal _, IntVal 0]) -> throwRuntimeError "division by zero" (BuiltinCeilDiv, [IntVal a, IntVal b]) -> return $ IntVal ((a + b - 1) `div` b) (BuiltinCeilMod, [IntVal _, IntVal 0]) -> throwRuntimeError "division by zero" @@ -598,10 +571,9 @@ evalBuiltin b args = case (b, args) of (BuiltinFloorMod, [IntVal _, IntVal 0]) -> throwRuntimeError "division by zero" (BuiltinFloorMod, [IntVal a, IntVal b]) -> return $ IntVal (a `mod` b) (BuiltinGcd, [IntVal a, IntVal b]) -> return $ IntVal (gcd a b) - (BuiltinInv, [IntVal _, IntVal _]) -> throwRuntimeError "TODO evalBuiltin" + (BuiltinModInv, [IntVal _, IntVal _]) -> throwRuntimeError "TODO evalBuiltin" (BuiltinLcm, [IntVal a, IntVal b]) -> return $ IntVal (lcm a b) (BuiltinMultiChoose, [IntVal _, IntVal _]) -> throwRuntimeError "TODO evalBuiltin" (BuiltinPermute, [IntVal _, IntVal _]) -> throwRuntimeError "TODO evalBuiltin" (BuiltinProduct, [ListVal xs]) -> IntVal . product <$> toIntList' xs - (BuiltinUnsupported, _) -> throwRuntimeError "unsupported builtin function" _ -> throwRuntimeError "type error on builtin function call" diff --git a/src/Jikka/RestrictedPython/Format.hs b/src/Jikka/RestrictedPython/Format.hs index 52e5948a..f84388e3 100644 --- a/src/Jikka/RestrictedPython/Format.hs +++ b/src/Jikka/RestrictedPython/Format.hs @@ -19,6 +19,7 @@ where import Data.List (intercalate) import Data.Text (Text, pack) import Jikka.Common.Format.AutoIndent +import Jikka.RestrictedPython.Language.Builtin import Jikka.RestrictedPython.Language.Expr formatType :: Type -> String @@ -32,9 +33,11 @@ formatType t = case t of CallableTy ts ret -> "Callable[[" ++ intercalate ", " (map formatType ts) ++ "], " ++ formatType ret ++ "]" formatConstant :: Constant -> String -formatConstant ConstNone = "None" -formatConstant (ConstInt n) = show n -formatConstant (ConstBool p) = show p +formatConstant = \case + ConstNone -> "None" + ConstInt n -> show n + ConstBool p -> show p + ConstBuiltin b -> formatBuiltin b formatBoolOp :: BoolOp -> String formatBoolOp = \case diff --git a/src/Jikka/RestrictedPython/Language/Builtin.hs b/src/Jikka/RestrictedPython/Language/Builtin.hs new file mode 100644 index 00000000..d44da425 --- /dev/null +++ b/src/Jikka/RestrictedPython/Language/Builtin.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Jikka.RestrictedPython.Language.Builtin where + +import qualified Data.Set as S +import Jikka.Common.Alpha +import Jikka.Common.Error +import Jikka.RestrictedPython.Language.Expr +import Jikka.RestrictedPython.Language.Util + +builtinNames :: S.Set VarName +builtinNames = S.union standardBuiltinNames additionalBuiltinNames + +standardBuiltinNames :: S.Set VarName +standardBuiltinNames = + S.fromList + [ "abs", + "all", + "any", + "bool", + "divmod", + "enumerate", + "filter", + "int", + "len", + "list", + "map", + "max", + "min", + "pow", + "range", + "reversed", + "sorted", + "sum", + "tuple", + "zip" + ] + +additionalBuiltinNames :: S.Set VarName +additionalBuiltinNames = + S.fromList + [ "argmax", + "argmin", + "ceildiv", + "ceilmod", + "choose", + "fact", + "floordiv", + "floormod", + "gcd", + "inv", + "lcm", + "multichoose", + "permute", + "product" + ] + +-- | `resolveUniqueBuiltin` makes a builtin function from a variable name. +-- However, this doesn't anything for ambiguous builtin functions. +-- For example, the builtin function "max" is kept as a variable because it may be \(\mathbf{list}(\alpha) \to \alpha\), \(\alpha \times \alpha \to \alpha\), etc. and this function cannot resolve it. +resolveUniqueBuiltin :: (MonadAlpha m, MonadError Error m) => VarName -> m Expr +resolveUniqueBuiltin x | x `S.notMember` builtinNames = return $ Name x +resolveUniqueBuiltin x = do + let f = return . Constant . ConstBuiltin + case x of + "abs" -> f BuiltinAbs + "all" -> f BuiltinAll + "any" -> f BuiltinAny + "bool" -> f . BuiltinBool =<< genType + "divmod" -> f BuiltinDivMod + "enumerate" -> f . BuiltinEnumerate =<< genType + "filter" -> f . BuiltinFilter =<< genType + "int" -> f . BuiltinInt =<< genType + "len" -> f . BuiltinLen =<< genType + "list" -> f . BuiltinList =<< genType + "reversed" -> f . BuiltinReversed =<< genType + "sorted" -> f . BuiltinSorted =<< genType + "sum" -> f BuiltinSum + "argmax" -> f . BuiltinArgMax =<< genType + "argmin" -> f . BuiltinArgMin =<< genType + "ceildiv" -> f BuiltinCeilDiv + "ceilmod" -> f BuiltinCeilMod + "choose" -> f BuiltinChoose + "fact" -> f BuiltinFact + "floordiv" -> f BuiltinFloorDiv + "floormod" -> f BuiltinFloorMod + "gcd" -> f BuiltinGcd + "inv" -> f BuiltinModInv + "lcm" -> f BuiltinLcm + "multichoose" -> f BuiltinMultiChoose + "permute" -> f BuiltinPermute + "product" -> f BuiltinProduct + _ -> return $ Name x + +resolveBuiltin :: (MonadAlpha m, MonadError Error m) => VarName -> Int -> m Expr +resolveBuiltin x _ | x `S.notMember` builtinNames = return $ Name x +resolveBuiltin x n = do + let f = return . Constant . ConstBuiltin + when (n < 0) $ do + throwInternalError "parseBuiltin with negative arity" + case x of + "map" -> f =<< (BuiltinMap <$> replicateM (n - 1) genType <*> genType) + "max" -> case n of + 1 -> f . BuiltinMax1 =<< genType + _ -> f =<< (BuiltinMax <$> genType <*> pure n) + "min" -> case n of + 1 -> f . BuiltinMin1 =<< genType + _ -> f =<< (BuiltinMin <$> genType <*> pure n) + "pow" -> + if n == 3 + then f BuiltinModPow + else f BuiltinPow + "range" -> case n of + 1 -> f BuiltinRange1 + 2 -> f BuiltinRange2 + 3 -> f BuiltinRange3 + _ -> throwTypeError $ "range expected 1, 2, or 3 arguments, got " ++ show n + _ -> do + e <- resolveUniqueBuiltin x + case e of + Constant (ConstBuiltin _) -> return e + _ -> throwInternalError "resolveBuiltin is not exhaustive" + +formatBuiltin :: Builtin -> String +formatBuiltin = \case + BuiltinAbs -> "abs" + BuiltinPow -> "pow" + BuiltinModPow -> "pow" + BuiltinAll -> "all" + BuiltinAny -> "any" + BuiltinDivMod -> "divmod" + BuiltinSorted _ -> "sorted" + BuiltinEnumerate _ -> "enumerate" + BuiltinBool _ -> "bool" + BuiltinInt _ -> "int" + BuiltinSum -> "sum" + BuiltinZip _ -> "zip" + BuiltinFilter _ -> "filter" + BuiltinTuple _ -> "tuple" + BuiltinLen _ -> "len" + BuiltinList _ -> "list" + BuiltinRange1 -> "range" + BuiltinRange2 -> "range" + BuiltinRange3 -> "range" + BuiltinMap _ _ -> "map" + BuiltinReversed _ -> "reversed" + BuiltinMax1 _ -> "max" + BuiltinMax _ _ -> "max" + BuiltinMin1 _ -> "min" + BuiltinMin _ _ -> "min" + BuiltinArgMax _ -> "argmax" + BuiltinArgMin _ -> "argmin" + BuiltinCeilDiv -> "ceildiv" + BuiltinCeilMod -> "ceilmod" + BuiltinFloorDiv -> "floordiv" + BuiltinFloorMod -> "floormod" + BuiltinChoose -> "choose" + BuiltinFact -> "fact" + BuiltinGcd -> "gcd" + BuiltinLcm -> "lcm" + BuiltinModInv -> "inv" + BuiltinMultiChoose -> "multichoose" + BuiltinPermute -> "permute" + BuiltinProduct -> "product" + +typeBuiltin :: Builtin -> Type +typeBuiltin = \case + BuiltinAbs -> CallableTy [IntTy] IntTy + BuiltinPow -> CallableTy [IntTy] IntTy + BuiltinModPow -> CallableTy [IntTy, IntTy] IntTy + BuiltinAll -> CallableTy [ListTy BoolTy] BoolTy + BuiltinAny -> CallableTy [ListTy BoolTy] BoolTy + BuiltinArgMax t -> CallableTy [ListTy t] IntTy + BuiltinArgMin t -> CallableTy [ListTy t] IntTy + BuiltinBool t -> CallableTy [t] BoolTy + BuiltinCeilDiv -> CallableTy [IntTy, IntTy] IntTy + BuiltinCeilMod -> CallableTy [IntTy, IntTy] IntTy + BuiltinChoose -> CallableTy [IntTy, IntTy] IntTy + BuiltinDivMod -> CallableTy [IntTy, IntTy] (TupleTy [IntTy, IntTy]) + BuiltinEnumerate t -> CallableTy [ListTy t] (ListTy (TupleTy [IntTy, t])) + BuiltinFact -> CallableTy [ListTy IntTy] IntTy + BuiltinFilter t -> CallableTy [CallableTy [t] BoolTy, ListTy t] (ListTy t) + BuiltinFloorDiv -> CallableTy [IntTy, IntTy] IntTy + BuiltinFloorMod -> CallableTy [IntTy, IntTy] IntTy + BuiltinGcd -> CallableTy [IntTy, IntTy] IntTy + BuiltinInt t -> CallableTy [t] IntTy + BuiltinModInv -> CallableTy [IntTy, IntTy] IntTy + BuiltinLcm -> CallableTy [IntTy, IntTy] IntTy + BuiltinLen t -> CallableTy [ListTy t] IntTy + BuiltinList t -> CallableTy [ListTy t] (ListTy t) + BuiltinMap args ret -> CallableTy (CallableTy args ret : map ListTy args) (ListTy ret) + BuiltinMax t n -> CallableTy (replicate n t) t + BuiltinMax1 t -> CallableTy [ListTy t] t + BuiltinMin t n -> CallableTy (replicate n t) t + BuiltinMin1 t -> CallableTy [ListTy t] t + BuiltinMultiChoose -> CallableTy [IntTy, IntTy] IntTy + BuiltinPermute -> CallableTy [IntTy, IntTy] IntTy + BuiltinProduct -> CallableTy [ListTy IntTy] IntTy + BuiltinRange1 -> CallableTy [IntTy] (ListTy IntTy) + BuiltinRange2 -> CallableTy [IntTy, IntTy] (ListTy IntTy) + BuiltinRange3 -> CallableTy [IntTy, IntTy, IntTy] (ListTy IntTy) + BuiltinReversed t -> CallableTy [ListTy t] (ListTy t) + BuiltinSorted t -> CallableTy [ListTy t] (ListTy t) + BuiltinSum -> CallableTy [ListTy IntTy] IntTy + BuiltinTuple ts -> CallableTy [TupleTy ts] (TupleTy ts) + BuiltinZip ts -> CallableTy (map ListTy ts) (TupleTy ts) diff --git a/src/Jikka/RestrictedPython/Language/Expr.hs b/src/Jikka/RestrictedPython/Language/Expr.hs index d01bc6ab..1307adc9 100644 --- a/src/Jikka/RestrictedPython/Language/Expr.hs +++ b/src/Jikka/RestrictedPython/Language/Expr.hs @@ -9,23 +9,31 @@ -- Stability : experimental -- Portability : portable module Jikka.RestrictedPython.Language.Expr - ( VarName (..), - unVarName, + ( -- * types TypeName (..), unTypeName, Type (..), + + -- * operators + UnaryOp (..), + Operator (..), + BoolOp (..), + CmpOp (..), + CmpOp' (..), Constant (..), - Target (..), - Comprehension (..), + Builtin (..), + + -- * exprs + VarName (..), + unVarName, Expr (..), + Comprehension (..), + + -- * statements + Target (..), Statement (..), ToplevelStatement (..), Program, - BoolOp (..), - CmpOp (..), - CmpOp' (..), - Operator (..), - UnaryOp (..), ) where @@ -45,11 +53,14 @@ unTypeName (TypeName x) = x -- | `Type` represents the types of our restricted Python-like language. -- -- \[ +-- \newcommand\int{\mathbf{int}} +-- \newcommand\bool{\mathbf{bool}} +-- \newcommand\list{\mathbf{list}} -- \begin{array}{rl} -- \tau ::= & \alpha \\ --- \vert & \mathbf{int} \\ --- \vert & \mathbf{bool} \\ --- \vert & \mathbf{list}(\tau) \\ +-- \vert & \int \\ +-- \vert & \bool \\ +-- \vert & \list(\tau) \\ -- \vert & \tau \times \tau \times \dots \times \tau \\ -- \vert & \tau \times \tau \times \dots \times \tau \to \tau -- \end{array} @@ -69,6 +80,88 @@ data Constant = ConstNone | ConstInt Integer | ConstBool Bool + | ConstBuiltin Builtin + deriving (Eq, Ord, Show, Read) + +data Builtin + = -- | "abs" \(: \int \to \int\) + BuiltinAbs + | -- | "pow" \((\lambda x k. x^k) : \int \times \int \to \int\) + BuiltinPow + | -- | modulo power "pow" \((\lambda x k m. x^k \bmod m): \int \times \int \to \int\) + BuiltinModPow + | -- | "divmod" \(: \int \times \int \to \int \times \int\) + BuiltinDivMod + | -- | ceil div \(: \int \times \int \to \int\) + BuiltinCeilDiv + | -- | ceil mod \(: \int \times \int \to \int\) + BuiltinCeilMod + | -- | floor div \(: \int \times \int \to \int\) + BuiltinFloorDiv + | -- | floor mod \(: \int \times \int \to \int\) + BuiltinFloorMod + | -- | \(\gcd: \int \times \int \to \int\) + BuiltinGcd + | -- | \(\mathbf{lcm}: \int \times \int \to \int\) + BuiltinLcm + | -- | "int" \(: \forall \alpha. \alpha \to \int\) + BuiltinInt Type + | -- | "bool" \(: \forall \alpha. \alpha \to \bool\) + BuiltinBool Type + | -- | "list" \(: \forall \alpha. \list(\alpha) \to \list(\alpha)\) + BuiltinList Type + | -- | "tuple" \(: \forall \alpha_0 \alpha_1 \dots \alpha _ {n - 1}. \tau \to \tau\) where \(\tau = \alpha_0 \times \dots \times \alpha _ {n - 1}\) + BuiltinTuple [Type] + | -- | "len" \(: \forall \alpha. \list(\alpha) \to \int\) + BuiltinLen Type + | -- | "map" \(: \forall \alpha_0 \alpha_1 \dots \alpha_n. (\alpha_0 \times \dots \times \alpha _ {n - 1} \to \alpha_n) \times \list(\alpha_0) \times \dots \list(\alpha _ {n - 1}) \to \list(\alpha_n)\) + BuiltinMap [Type] Type + | -- | "sorted" \(: \forall \alpha. \list(\alpha) \to \list(\alpha)\) + BuiltinSorted Type + | -- | "reversed" \(: \forall \alpha. \list(\alpha) \to \list(\alpha)\) + BuiltinReversed Type + | -- | "enumerate" \(: \forall \alpha. \list(\alpha) \to \list(\int \times \alpha)\) + BuiltinEnumerate Type + | -- | "filter" \(: \forall \alpha. (\alpha \to \bool) \times \list(\alpha) \to \list(\alpha)\) + BuiltinFilter Type + | -- | "zip" \(: \forall \alpha_0 \alpha_1 \dots \alpha _ {n - 1}. \list(\alpha_0) \times \dots \list(\alpha _ {n - 1}) \to \list(\alpha_0 \times \dots \times \alpha _ {n - 1})\) + BuiltinZip [Type] + | -- | "all" \(: \list(\bool) \to \bool\) + BuiltinAll + | -- | "any" \(: \list(\bool) \to \bool\) + BuiltinAny + | -- | "sum" \(: \list(\int) \to \int\) + BuiltinSum + | -- | product \(: \list(\int) \to \int\) + BuiltinProduct + | -- | "range" \(: \int \to \list(\int)\) + BuiltinRange1 + | -- | "range" \(: \int \times \int \to \list(\int)\) + BuiltinRange2 + | -- | "range" \(: \int \times \int \times \int \to \list(\int)\) + BuiltinRange3 + | -- | "max" \(: \forall \alpha. \list(\alpha) \to \alpha\) + BuiltinMax1 Type + | -- | "max" \(: \forall \alpha. \underbrace{\alpha \times \alpha \times \dots \times \alpha} _ {n ~\text{times}} \to \alpha\) + BuiltinMax Type Int + | -- | "min" \(: \forall \alpha. \list(\alpha) \to \alpha\) + BuiltinMin1 Type + | -- | "min" \(: \forall \alpha. \underbrace{\alpha \times \alpha \times \dots \times \alpha} _ {n ~\text{times}} \to \alpha\) + BuiltinMin Type Int + | -- | \(: \forall \alpha. \list(\alpha) \to \int\) + BuiltinArgMax Type + | -- | \(: \forall \alpha. \list(\alpha) \to \int\) + BuiltinArgMin Type + | -- | factorial \((\lambda n. n!): \int \to \int\) + BuiltinFact + | -- | \((\lambda n r. {} _ n C _ r): \int \times \int \to \int\) + BuiltinChoose + | -- | \((\lambda n r. {} _ n P _ r): \int \times \int \to \int\) + BuiltinPermute + | -- | \((\lambda n r. {} _ n H _ r): \int \times \int \to \int\) + BuiltinMultiChoose + | -- | modulo inverse \((\lambda x m. x^{-1} \bmod m): \int \times \int \to \int\) + BuiltinModInv deriving (Eq, Ord, Show, Read) -- | `Target` represents the lvalue of our restricted Python-like language. diff --git a/src/Jikka/RestrictedPython/Language/Lint.hs b/src/Jikka/RestrictedPython/Language/Lint.hs index 63dc97b4..b1acfa96 100644 --- a/src/Jikka/RestrictedPython/Language/Lint.hs +++ b/src/Jikka/RestrictedPython/Language/Lint.hs @@ -4,7 +4,9 @@ module Jikka.RestrictedPython.Language.Lint where import Control.Monad.Writer.Strict +import qualified Data.Set as S import Jikka.Common.Error +import Jikka.RestrictedPython.Language.Builtin (builtinNames) import Jikka.RestrictedPython.Language.Expr import Jikka.RestrictedPython.Language.Util import Jikka.RestrictedPython.Language.VariableAnalysis @@ -229,3 +231,34 @@ doesntHaveNonTrivialSubscriptedAssignmentInForLoops = not . hasMixedAssignment ensureDoesntHaveNonTrivialSubscriptedAssignmentInForLoops :: MonadError Error m => Program -> m () ensureDoesntHaveNonTrivialSubscriptedAssignmentInForLoops = makeEnsureProgram doesntHaveNonTrivialSubscriptedAssignmentInForLoops "there must not be assignments with non-trivial subscriptions in for-loops" + +-- | `hasAssginmentToBuiltin` checks that there are assignments to builtin functions. +-- For example, the followings have such assignments. +-- +-- > map = 3 +-- +-- > return [range for range in range(10)] +hasAssignmentToBuiltin :: Program -> Bool +hasAssignmentToBuiltin _ = False -- TODO + +doesntHaveAssignmentToBuiltin :: Program -> Bool +doesntHaveAssignmentToBuiltin = not . hasAssignmentToBuiltin + +ensureDoesntHaveAssignmentToBuiltin :: MonadError Error m => Program -> m () +ensureDoesntHaveAssignmentToBuiltin = makeEnsureProgram doesntHaveAssignmentToBuiltin "there must not be assignments to builtin functions" + +-- | `hasNonResolvedBuiltin` checks that there are not resolved builtin functions. +-- This always doesn't hold after `Jikka.RestrictedPython.Language.Convert.ResolveBuiltin`. +hasNonResolvedBuiltin :: Program -> Bool +hasNonResolvedBuiltin = any check . listExprs + where + check = any check' . listSubExprs + check' = \case + Name x | x `S.member` builtinNames -> True + _ -> False + +doesntHaveNonResolvedBuiltin :: Program -> Bool +doesntHaveNonResolvedBuiltin = not . hasAssignmentToBuiltin + +ensureDoesntHaveNonResolvedBuiltin :: MonadError Error m => Program -> m () +ensureDoesntHaveNonResolvedBuiltin = makeEnsureProgram doesntHaveNonResolvedBuiltin "there must not be assignments to builtin functions" diff --git a/src/Jikka/RestrictedPython/Language/Stdlib.hs b/src/Jikka/RestrictedPython/Language/Stdlib.hs deleted file mode 100644 index 3e18c281..00000000 --- a/src/Jikka/RestrictedPython/Language/Stdlib.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Jikka.RestrictedPython.Language.Stdlib where - -import qualified Data.Set as S -import Jikka.RestrictedPython.Language.Expr - -builtinFunctions :: S.Set VarName -builtinFunctions = S.union standardBuiltinFunctions additionalBuiltinFunctions - -standardBuiltinFunctions :: S.Set VarName -standardBuiltinFunctions = - S.fromList - [ "abs", - "delattr", - "hash", - "memoryview", - "set", - "all", - "dict", - "help", - "min", - "setattr", - "any", - "dir", - "hex", - "next", - "slice", - "ascii", - "divmod", - "id", - "object", - "sorted", - "bin", - "enumerate", - "input", - "oct", - "staticmethod", - "bool", - "eval", - "int", - "open", - "str", - "breakpoint", - "exec", - "isinstance", - "ord", - "sum", - "bytearray", - "filter", - "issubclass", - "pow", - "super", - "bytes", - "float", - "iter", - "print", - "tuple", - "callable", - "format", - "len", - "property", - "type", - "chr", - "frozenset", - "list", - "range", - "vars", - "classmethod", - "getattr", - "locals", - "repr", - "zip", - "compile", - "globals", - "map", - "reversed", - "__import__", - "complex", - "hasattr", - "max", - "round" - ] - -additionalBuiltinFunctions :: S.Set VarName -additionalBuiltinFunctions = - S.fromList - [ "argmax", - "argmin", - "ceildiv", - "ceilmod", - "choose", - "fact", - "floordiv", - "floormod", - "gcd", - "inv", - "lcm", - "multichoose", - "permute", - "product" - ] diff --git a/src/Jikka/RestrictedPython/Language/Util.hs b/src/Jikka/RestrictedPython/Language/Util.hs index 8f0183aa..b1a940a8 100644 --- a/src/Jikka/RestrictedPython/Language/Util.hs +++ b/src/Jikka/RestrictedPython/Language/Util.hs @@ -9,6 +9,7 @@ module Jikka.RestrictedPython.Language.Util -- * constants constIntExp, constBoolExp, + constBuiltinExp, -- * free variables freeTyVars, @@ -80,6 +81,9 @@ constIntExp = Constant . ConstInt constBoolExp :: Bool -> Expr constBoolExp = Constant . ConstBool +constBuiltinExp :: Builtin -> Expr +constBuiltinExp = Constant . ConstBuiltin + freeTyVars :: Type -> [TypeName] freeTyVars = nub . go where diff --git a/src/Jikka/RestrictedPython/Language/Value.hs b/src/Jikka/RestrictedPython/Language/Value.hs index 6981baf1..c80b0d54 100644 --- a/src/Jikka/RestrictedPython/Language/Value.hs +++ b/src/Jikka/RestrictedPython/Language/Value.hs @@ -39,136 +39,6 @@ newtype Local = Local } deriving (Eq, Ord, Show, Read) -data Builtin - = BuiltinUnsupported - | BuiltinAbs - | BuiltinAll - | BuiltinMin - | BuiltinAny - | BuiltinDivMod - | BuiltinSorted - | BuiltinEnumerate - | BuiltinBool - | BuiltinInt - | BuiltinSum - | BuiltinZip - | BuiltinFilter - | BuiltinTuple - | BuiltinLen - | BuiltinList - | BuiltinRange - | BuiltinMap - | BuiltinReversed - | BuiltinMax - | BuiltinArgMax - | BuiltinArgMin - | BuiltinCeilDiv - | BuiltinCeilMod - | BuiltinChoose - | BuiltinFact - | BuiltinFloorDiv - | BuiltinFloorMod - | BuiltinGcd - | BuiltinInv - | BuiltinLcm - | BuiltinMultiChoose - | BuiltinPermute - | BuiltinProduct - deriving (Eq, Ord, Show, Read) - -standardBuiltinFunctions :: M.Map VarName Builtin -standardBuiltinFunctions = - M.fromList - [ ("abs", BuiltinAbs), - ("delattr", BuiltinUnsupported), - ("hash", BuiltinUnsupported), - ("memoryview", BuiltinUnsupported), - ("set", BuiltinUnsupported), - ("all", BuiltinAll), - ("dict", BuiltinUnsupported), - ("help", BuiltinUnsupported), - ("min", BuiltinMin), - ("setattr", BuiltinUnsupported), - ("any", BuiltinAny), - ("dir", BuiltinUnsupported), - ("hex", BuiltinUnsupported), - ("next", BuiltinUnsupported), - ("slice", BuiltinUnsupported), - ("ascii", BuiltinUnsupported), - ("divmod", BuiltinDivMod), - ("id", BuiltinUnsupported), - ("object", BuiltinUnsupported), - ("sorted", BuiltinSorted), - ("bin", BuiltinUnsupported), - ("enumerate", BuiltinEnumerate), - ("input", BuiltinUnsupported), - ("oct", BuiltinUnsupported), - ("staticmethod", BuiltinUnsupported), - ("bool", BuiltinBool), - ("eval", BuiltinUnsupported), - ("int", BuiltinInt), - ("open", BuiltinUnsupported), - ("str", BuiltinUnsupported), - ("breakpoint", BuiltinUnsupported), - ("exec", BuiltinUnsupported), - ("isinstance", BuiltinUnsupported), - ("ord", BuiltinUnsupported), - ("sum", BuiltinSum), - ("bytearray", BuiltinUnsupported), - ("filter", BuiltinFilter), - ("issubclass", BuiltinUnsupported), - ("pow", BuiltinUnsupported), - ("super", BuiltinUnsupported), - ("bytes", BuiltinUnsupported), - ("float", BuiltinUnsupported), - ("iter", BuiltinUnsupported), - ("print", BuiltinUnsupported), - ("tuple", BuiltinUnsupported), - ("callable", BuiltinUnsupported), - ("format", BuiltinUnsupported), - ("len", BuiltinLen), - ("property", BuiltinUnsupported), - ("type", BuiltinUnsupported), - ("chr", BuiltinUnsupported), - ("frozenset", BuiltinUnsupported), - ("list", BuiltinList), - ("range", BuiltinRange), - ("vars", BuiltinUnsupported), - ("classmethod", BuiltinUnsupported), - ("getattr", BuiltinUnsupported), - ("locals", BuiltinUnsupported), - ("repr", BuiltinUnsupported), - ("zip", BuiltinZip), - ("compile", BuiltinUnsupported), - ("globals", BuiltinUnsupported), - ("map", BuiltinMap), - ("reversed", BuiltinReversed), - ("__import__", BuiltinUnsupported), - ("complex", BuiltinUnsupported), - ("hasattr", BuiltinUnsupported), - ("max", BuiltinMax), - ("round", BuiltinUnsupported) - ] - -additionalBuiltinFunctions :: M.Map VarName Builtin -additionalBuiltinFunctions = - M.fromList - [ ("argmax", BuiltinArgMax), - ("argmin", BuiltinArgMin), - ("ceildiv", BuiltinCeilDiv), - ("ceilmod", BuiltinCeilMod), - ("choose", BuiltinChoose), - ("fact", BuiltinFact), - ("floordiv", BuiltinFloorDiv), - ("floormod", BuiltinFloorMod), - ("gcd", BuiltinGcd), - ("inv", BuiltinInv), - ("lcm", BuiltinLcm), - ("multichoose", BuiltinMultiChoose), - ("permute", BuiltinPermute), - ("product", BuiltinProduct) - ] - toIntList :: V.Vector Value -> Maybe (V.Vector Integer) toIntList xs = mapM go xs where @@ -223,7 +93,7 @@ newtype Global = Global deriving (Eq, Ord, Show, Read) initialGlobal :: Global -initialGlobal = Global $ M.map BuiltinVal (M.union standardBuiltinFunctions additionalBuiltinFunctions) +initialGlobal = Global M.empty lookupGlobal :: MonadError Error m => VarName -> Global -> m Value lookupGlobal x global = diff --git a/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs b/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs index 3d891848..aa38bdf3 100644 --- a/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs @@ -35,6 +35,35 @@ spec = describe "run" $ do ] ] run' parsed `shouldBe` Right expected + it "fails with undefined variables" $ do + let parsed = + [ ToplevelFunctionDef + "solve" + [] + IntTy + [ Return (Name "y") + ] + ] + let expected = WithWrapped "Jikka.RestrictedPython.Convert.Alpha" (WithGroup SymbolError (Error "undefined identifier: y")) + run' parsed `shouldBe` Left expected + it "doesn't rename builtin functions " $ do + let parsed = + [ ToplevelFunctionDef + "solve" + [] + IntTy + [ Return (Name "range") + ] + ] + let expected = + [ ToplevelFunctionDef + "solve" + [] + IntTy + [ Return (Name "range") + ] + ] + run' parsed `shouldBe` Right expected it "distinguishes local variables in two diffrent functions" $ do let parsed = [ ToplevelFunctionDef diff --git a/test/Jikka/RestrictedPython/Convert/ResolveBuiltinSpec.hs b/test/Jikka/RestrictedPython/Convert/ResolveBuiltinSpec.hs new file mode 100644 index 00000000..0f6aa97a --- /dev/null +++ b/test/Jikka/RestrictedPython/Convert/ResolveBuiltinSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Jikka.RestrictedPython.Convert.ResolveBuiltinSpec + ( spec, + ) +where + +import Jikka.Common.Alpha +import Jikka.Common.Error +import Jikka.RestrictedPython.Convert.ResolveBuiltin (run) +import Jikka.RestrictedPython.Language.Expr +import Jikka.RestrictedPython.Language.Util +import Test.Hspec + +run' :: Program -> Either Error Program +run' = flip evalAlphaT 0 . run + +spec :: Spec +spec = describe "run" $ do + it "works" $ do + let prog = + toplevelMainDef + [ Return (Call (Name "max") [List IntTy [constIntExp 2, constIntExp 3]]), + Return (Call (Name "max") [constIntExp 2, constIntExp 3]), + Return (Call (Name "max") [constIntExp 2, constIntExp 3, constIntExp 4]) + ] + let expected = + toplevelMainDef + [ Return (Call (constBuiltinExp (BuiltinMax1 (VarTy "$0"))) [List IntTy [constIntExp 2, constIntExp 3]]), + Return (Call (constBuiltinExp (BuiltinMax (VarTy "$1") 2)) [constIntExp 2, constIntExp 3]), + Return (Call (constBuiltinExp (BuiltinMax (VarTy "$2") 3)) [constIntExp 2, constIntExp 3, constIntExp 4]) + ] + run' prog `shouldBe` Right expected diff --git a/test/Jikka/RestrictedPython/EvaluateSpec.hs b/test/Jikka/RestrictedPython/EvaluateSpec.hs index 339f2fc5..1de67a94 100644 --- a/test/Jikka/RestrictedPython/EvaluateSpec.hs +++ b/test/Jikka/RestrictedPython/EvaluateSpec.hs @@ -31,13 +31,13 @@ spec = describe "run" $ do "solve" [("n", IntTy)] IntTy - [ AnnAssign (NameTrg "a") (ListTy IntTy) (Call (Name "list") [Call (Name "range") [Name "n"]]), + [ AnnAssign (NameTrg "a") (ListTy IntTy) (Call (constBuiltinExp (BuiltinList IntTy)) [Call (constBuiltinExp BuiltinRange1) [Name "n"]]), For (TupleTrg [NameTrg "i", NameTrg "a_i"]) - (Call (Name "enumerate") [Name "a"]) + (Call (constBuiltinExp (BuiltinEnumerate IntTy)) [Name "a"]) [ AugAssign (SubscriptTrg (NameTrg "a") (Name "i")) Mult (Name "a_i") ], - Return (Call (Name "sum") [Name "a"]) + Return (Call (constBuiltinExp BuiltinSum) [Name "a"]) ] ] let e = Call (Name "solve") [constIntExp 100] diff --git a/test/Jikka/RestrictedPython/Language/ValueSpec.hs b/test/Jikka/RestrictedPython/Language/ValueSpec.hs deleted file mode 100644 index f2486258..00000000 --- a/test/Jikka/RestrictedPython/Language/ValueSpec.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Jikka.RestrictedPython.Language.ValueSpec (spec) where - -import qualified Data.Map.Strict as M -import qualified Jikka.RestrictedPython.Language.Stdlib as Stdlib -import Jikka.RestrictedPython.Language.Value -import Test.Hspec - -spec :: Spec -spec = do - describe "standardBuiltinFunctions" $ do - it "matches Jikka.RestrictedPython.Language.Stdlib.standardBuiltinFunctions" $ do - M.keysSet standardBuiltinFunctions `shouldBe` Stdlib.standardBuiltinFunctions - describe "additionalBuiltinFunctions" $ do - it "matches Jikka.RestrictedPython.Language.Stdlib.additionalBuiltinFunctions" $ do - M.keysSet additionalBuiltinFunctions `shouldBe` Stdlib.additionalBuiltinFunctions From 9dd8165ec1c6d2a824e599150ad28c68f534f8f2 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Mon, 21 Jun 2021 05:59:14 +0900 Subject: [PATCH 10/56] docs(core): Write types for builtins --- src/Jikka/Core/Language/Expr.hs | 167 ++++++++++++++++++++++---------- 1 file changed, 118 insertions(+), 49 deletions(-) diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index 35f45777..13d6798c 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -32,11 +32,14 @@ unTypeName (TypeName name) = name -- See also [commentary/compiler/type-type](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/type-type). -- -- \[ +-- \newcommand\int{\mathbf{int}} +-- \newcommand\bool{\mathbf{bool}} +-- \newcommand\list{\mathbf{list}} -- \begin{array}{rl} -- \tau ::= & \alpha \\ --- \vert & \mathbf{int} \\ --- \vert & \mathbf{bool} \\ --- \vert & \mathbf{list}(\tau) \\ +-- \vert & \int \\ +-- \vert & \bool \\ +-- \vert & \list(\tau) \\ -- \vert & \tau_0 \times \tau_1 \times \dots \times \tau_{n-1} \\ -- \vert & \tau_0 \times \tau_1 \times \dots \times \tau_{n-1} \to \tau_n -- \end{array} @@ -53,71 +56,137 @@ data Type data Builtin = -- arithmetical functions + + -- | \(: \int \to \int\) Negate - | Plus - | Minus - | Mult - | FloorDiv - | FloorMod - | CeilDiv - | CeilMod - | Pow + | -- | \(: \int \times \int \to \int\) + Plus + | -- | \(: \int \times \int \to \int\) + Minus + | -- | \(: \int \times \int \to \int\) + Mult + | -- | \(: \int \times \int \to \int\) + FloorDiv + | -- | \(: \int \times \int \to \int\) + FloorMod + | -- | \(: \int \times \int \to \int\) + CeilDiv + | -- | \(: \int \times \int \to \int\) + CeilMod + | -- | \(: \int \times \int \to \int\) + Pow | -- induction functions + + -- | natural induction \(: \forall \alpha. \alpha \times (\alpha \to \alpha) \times \int \to \alpha\) NatInd Type | -- advanced arithmetical functions + + -- | \(: \int \to \int\) Abs - | Gcd - | Lcm - | Min - | Max + | -- | \(: \int \times \int \to \int\) + Gcd + | -- | \(: \int \times \int \to \int\) + Lcm + | -- | \(: \int \times \int \to \int\) + Min + | -- | \(: \int \times \int \to \int\) + Max | -- logical functions + + -- | \(: \bool \to \bool\) Not - | And - | Or - | Implies - | If Type + | -- | \(: \bool \times \bool \to \bool\) + And + | -- | \(: \bool \times \bool \to \bool\) + Or + | -- | \(: \bool \times \bool \to \bool\) + Implies + | -- | \(: \forall \alpha. \bool \times \alpha \times \alpha \to \alpha\) + If Type | -- bitwise functions + + -- | \(: \int \to \int\) BitNot - | BitAnd - | BitOr - | BitXor - | BitLeftShift - | BitRightShift + | -- | \(: \int \times \int \to \int\) + BitAnd + | -- | \(: \int \times \int \to \int\) + BitOr + | -- | \(: \int \times \int \to \int\) + BitXor + | -- | \(: \int \times \int \to \int\) + BitLeftShift + | -- | \(: \int \times \int \to \int\) + BitRightShift | -- modular functions + + -- | \(: \int \times \int \to \int\) Inv - | PowMod + | -- | \(: \int \times \int \times \int \to \int\) + PowMod | -- list functions + + -- | \(: \forall \alpha. \list(\alpha) \to \int\) Len Type - | Tabulate Type - | Map Type Type - | At Type - | Sum - | Product - | Min1 - | Max1 - | ArgMin - | ArgMax - | All - | Any - | Sorted Type - | List Type - | Reversed Type - | Range1 - | Range2 - | Range3 + | -- | \(: \forall \alpha. \int \times (\int \to \alpha) \to \list(\alpha)\) + Tabulate Type + | -- | \(: \forall \alpha \beta. (\alpha \to \beta) \times \list(\alpha) \to \list(\beta)\) + Map Type Type + | -- | \(: \forall \alpha. \list(\alpha) \times \int \to \alpha\) + At Type + | -- | \(: \list(\int) \to \int\) + Sum + | -- | \(: \list(\int) \to \int\) + Product + | -- | \(: \list(\int) \to \int\) + Min1 + | -- | \(: \list(\int) \to \int\) + Max1 + | -- | \(: \list(\int) \to \int\) + ArgMin + | -- | \(: \list(\int) \to \int\) + ArgMax + | -- | \(: \list(\bool) \to \bool\) + All + | -- | \(: \list(\bool) \to \bool\) + Any + | -- | \(: \forall \alpha. \list(\alpha) \to \list(\alpha)\) + Sorted Type + | -- | \(: \forall \alpha. \list(\alpha) \to \list(\alpha)\) + List Type + | -- | \(: \forall \alpha. \list(\alpha) \to \list(\alpha)\) + Reversed Type + | -- | \(: \int \to \list(\int)\)1 + Range1 + | -- | \(: \int \times \int \to \list(\int)\)1 + Range2 + | -- | \(: \int \times \int \times \int \to \list(\int)\)1 + Range3 | -- arithmetical relations + + -- | \(: \int \times \int \to \int\) LessThan - | LessEqual - | GreaterThan - | GreaterEqual + | -- | \(: \int \times \int \to \int\) + LessEqual + | -- | \(: \int \times \int \to \int\) + GreaterThan + | -- | \(: \int \times \int \to \int\) + GreaterEqual | -- equality relations (polymorphic) + + -- | \(: \forall \alpha. \alpha \times \alpha \to \bool\) Equal Type - | NotEqual Type + | -- | \(: \forall \alpha. \alpha \times \alpha \to \bool\) + NotEqual Type | -- combinational functions + + -- | \(: \int \to \int\) Fact - | Choose - | Permute - | MultiChoose + | -- | \(: \int \times \int \to \int\) + Choose + | -- | \(: \int \times \int \to \int\) + Permute + | -- | \(: \int \times \int \to \int\) + MultiChoose deriving (Eq, Ord, Show, Read) data Literal From 0f266dc3dd91730cee5b985d9bf5c943471f7ad3 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Mon, 21 Jun 2021 06:12:54 +0900 Subject: [PATCH 11/56] refactor(core): Rename some builtins --- src/Jikka/CPlusPlus/Convert/FromCore.hs | 8 ++++---- src/Jikka/Core/Convert/StrengthReduction.hs | 14 +++++++------- src/Jikka/Core/Evaluate.hs | 8 ++++---- src/Jikka/Core/Format.hs | 8 ++++---- src/Jikka/Core/Language/BuiltinPatterns.hs | 8 ++++---- src/Jikka/Core/Language/Expr.hs | 8 ++++---- src/Jikka/Core/Language/Lint.hs | 8 ++++---- src/Jikka/RestrictedPython/Convert/ToCore.hs | 6 +++--- 8 files changed, 34 insertions(+), 34 deletions(-) diff --git a/src/Jikka/CPlusPlus/Convert/FromCore.hs b/src/Jikka/CPlusPlus/Convert/FromCore.hs index 9d658092..57249e3c 100644 --- a/src/Jikka/CPlusPlus/Convert/FromCore.hs +++ b/src/Jikka/CPlusPlus/Convert/FromCore.hs @@ -88,8 +88,8 @@ runAppBuiltin f args = case (f, args) of (X.Abs, [e]) -> return $ Y.Call (Y.Function "std::abs" []) [e] (X.Gcd, [e1, e2]) -> return $ Y.Call (Y.Function "std::gcd" []) [e1, e2] (X.Lcm, [e1, e2]) -> return $ Y.Call (Y.Function "std::lcm" []) [e1, e2] - (X.Min, [e1, e2]) -> return $ Y.Call (Y.Function "std::min" []) [e1, e2] - (X.Max, [e1, e2]) -> return $ Y.Call (Y.Function "std::max" []) [e1, e2] + (X.Min2, [e1, e2]) -> return $ Y.Call (Y.Function "std::min" []) [e1, e2] + (X.Max2, [e1, e2]) -> return $ Y.Call (Y.Function "std::max" []) [e1, e2] -- logical functions (X.Not, [e]) -> return $ Y.UnOp Y.Not e (X.And, [e1, e2]) -> return $ Y.BinOp Y.And e1 e2 @@ -104,8 +104,8 @@ runAppBuiltin f args = case (f, args) of (X.BitLeftShift, [e1, e2]) -> return $ Y.BinOp Y.BitLeftShift e1 e2 (X.BitRightShift, [e1, e2]) -> return $ Y.BinOp Y.BitRightShift e1 e2 -- modular functions - (X.Inv, [e1, e2]) -> return $ Y.Call (Y.Function "std::modinv" []) [e1, e2] - (X.PowMod, [e1, e2, e3]) -> return $ Y.Call (Y.Function "std::modpow" []) [e1, e2, e3] + (X.ModInv, [e1, e2]) -> return $ Y.Call (Y.Function "std::modinv" []) [e1, e2] + (X.ModPow, [e1, e2, e3]) -> return $ Y.Call (Y.Function "std::modpow" []) [e1, e2, e3] -- list functions (X.Len _, [e]) -> return $ Y.Cast Y.TyInt64 (Y.Call (Y.Method e "size") []) (X.Tabulate t, [n, f]) -> do diff --git a/src/Jikka/Core/Convert/StrengthReduction.hs b/src/Jikka/Core/Convert/StrengthReduction.hs index efb7555e..98b1e9d7 100644 --- a/src/Jikka/Core/Convert/StrengthReduction.hs +++ b/src/Jikka/Core/Convert/StrengthReduction.hs @@ -32,7 +32,7 @@ eliminateSomeBuiltins = \case -- arithmetical functions Minus' e1 e2 -> go $ Plus' e1 (Negate' e2) -- advanced arithmetical functions - Abs' e -> go $ Max' e (Negate' e) + Abs' e -> go $ Max2' e (Negate' e) Lcm' e1 e2 -> go $ FloorDiv' (Gcd' e1 e2) (Mult' e1 e2) -- logical functions Implies' e1 e2 -> Or' (Not' e1) e2 @@ -52,8 +52,8 @@ reduceNegate = \case Mult' (Negate' e1) e2 -> go $ Negate' (Mult' e1 e2) Mult' e1 (Negate' e2) -> go $ Negate' (Mult' e1 e2) -- `Abs` is already removed. - Min' (Negate' e1) (Negate' e2) -> go $ Negate' (Max' e1 e2) - Max' (Negate' e1) (Negate' e2) -> go $ Negate' (Min' e1 e2) + Min2' (Negate' e1) (Negate' e2) -> go $ Negate' (Max2' e1 e2) + Max2' (Negate' e1) (Negate' e2) -> go $ Negate' (Min2' e1 e2) e -> e -- | `reduceNot` brings `Not` to the root. @@ -83,8 +83,8 @@ reduceAssoc = \case Plus' (Plus' e1 e2) e3 -> Plus' e1 (Plus' e2 e3) Minus' (Minus' e1 e2) e3 -> Minus' e1 (Minus' e2 e3) Mult' (Mult' e1 e2) e3 -> Mult' e1 (Mult' e2 e3) - Max' (Max' e1 e2) e3 -> Max' e1 (Max' e2 e3) - Min' (Min' e1 e2) e3 -> Min' e1 (Min' e2 e3) + Max2' (Max2' e1 e2) e3 -> Max2' e1 (Max2' e2 e3) + Min2' (Min2' e1 e2) e3 -> Min2' e1 (Min2' e2 e3) And' (And' e1 e2) e3 -> And' e1 (And' e2 e3) Or' (Or' e1 e2) e3 -> Or' e1 (Or' e2 e3) BitAnd' (BitAnd' e1 e2) e3 -> BitAnd' e1 (BitAnd' e2 e3) @@ -157,12 +157,12 @@ reduceFoldMap = \case Product' (Map' t1 t2 (Lam1 x t (Negate' e)) xs) -> go $ Mult' (Pow' (Negate' Lit0) (Len' t1 xs)) (Product' (Map' t1 t2 (Lam1 x t e) xs)) Product' (Map' t1 t2 (Lam1 x t (Mult' e1 e2)) xs) -> go $ Mult' (Product' (Map' t1 t2 (Lam1 x t e1) xs)) (Product' (Map' t1 t2 (Lam1 x t e2) xs)) Max1' (Map' _ _ (Lam1 x _ e) _) | x `isUnusedVar` e -> e - Max1' (Map' t1 t2 (Lam1 x t (Max' e1 e2)) xs) -> go $ Max' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) + Max1' (Map' t1 t2 (Lam1 x t (Max2' e1 e2)) xs) -> go $ Max2' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) Max1' (Map' t1 t2 (Lam1 x t (Negate' e)) xs) -> go $ Negate' (Min1' (Map' t1 t2 (Lam1 x t e) xs)) Max1' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ Plus' e1 (Max1' (Map' t1 t2 (Lam1 x t e2) xs)) Max1' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ Plus' (Max1' (Map' t1 t2 (Lam1 x t e1) xs)) e1 Min1' (Map' _ _ (Lam1 x _ e) _) | x `isUnusedVar` e -> e - Min1' (Map' t1 t2 (Lam1 x t (Min' e1 e2)) xs) -> go $ Min' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) + Min1' (Map' t1 t2 (Lam1 x t (Min2' e1 e2)) xs) -> go $ Min2' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) Min1' (Map' t1 t2 (Lam1 x t (Negate' e)) xs) -> go $ Negate' (Max1' (Map' t1 t2 (Lam1 x t e) xs)) Min1' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ Plus' e1 (Min1' (Map' t1 t2 (Lam1 x t e2) xs)) Min1' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ Plus' (Min1' (Map' t1 t2 (Lam1 x t e1) xs)) e1 diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index 84bf72b8..76e16e10 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -251,8 +251,8 @@ callBuiltin builtin args = case (builtin, args) of (Abs, [ValInt n]) -> return $ ValInt (abs n) (Gcd, [ValInt a, ValInt b]) -> return $ ValInt (gcd a b) (Lcm, [ValInt a, ValInt b]) -> return $ ValInt (lcm a b) - (Min, [ValInt a, ValInt b]) -> return $ ValInt (min a b) - (Max, [ValInt a, ValInt b]) -> return $ ValInt (max a b) + (Min2, [ValInt a, ValInt b]) -> return $ ValInt (min a b) + (Max2, [ValInt a, ValInt b]) -> return $ ValInt (max a b) -- logical functions (Not, [ValBool p]) -> return $ ValBool (not p) (And, [ValBool p, ValBool q]) -> return $ ValBool (p && q) @@ -267,8 +267,8 @@ callBuiltin builtin args = case (builtin, args) of (BitLeftShift, [ValInt a, ValInt b]) -> return $ ValInt (a `shift` fromInteger b) (BitRightShift, [ValInt a, ValInt b]) -> return $ ValInt (a `shift` fromInteger (- b)) -- modular functions - (Inv, [ValInt a, ValInt b]) -> ValInt <$> inv a b - (PowMod, [ValInt a, ValInt b, ValInt c]) -> ValInt <$> powmod a b c + (ModInv, [ValInt a, ValInt b]) -> ValInt <$> inv a b + (ModPow, [ValInt a, ValInt b, ValInt c]) -> ValInt <$> powmod a b c -- list functions (Len _, [ValList a]) -> return $ ValInt (lengthArray a) (Tabulate _, [ValInt n, f]) -> ValList <$> tabulate n f diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index 22c6b01e..5d3c4c7e 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -65,8 +65,8 @@ analyzeBuiltin = \case Abs -> fun "abs" Gcd -> fun "gcd" Lcm -> fun "lcm" - Min -> fun "min" - Max -> fun "max" + Min2 -> fun "min" + Max2 -> fun "max" -- logical functions Not -> PrefixOp "not" And -> infixOp "and" @@ -81,8 +81,8 @@ analyzeBuiltin = \case BitLeftShift -> infixOp "<<" BitRightShift -> infixOp ">>" -- modular functions - Inv -> fun "inv" - PowMod -> fun "powmod" + ModInv -> fun "modinv" + ModPow -> fun "modpow" -- list functions Len t -> Fun [t] "len" Tabulate t -> Fun [t] "tabulate" diff --git a/src/Jikka/Core/Language/BuiltinPatterns.hs b/src/Jikka/Core/Language/BuiltinPatterns.hs index d23b6ebd..a686edc9 100644 --- a/src/Jikka/Core/Language/BuiltinPatterns.hs +++ b/src/Jikka/Core/Language/BuiltinPatterns.hs @@ -44,9 +44,9 @@ pattern Gcd' e1 e2 = AppBuiltin Gcd [e1, e2] pattern Lcm' e1 e2 = AppBuiltin Lcm [e1, e2] -pattern Min' e1 e2 = AppBuiltin Min [e1, e2] +pattern Min2' e1 e2 = AppBuiltin Min2 [e1, e2] -pattern Max' e1 e2 = AppBuiltin Max [e1, e2] +pattern Max2' e1 e2 = AppBuiltin Max2 [e1, e2] -- logical functions pattern Not' e = AppBuiltin Not [e] @@ -73,9 +73,9 @@ pattern BitLeftShift' e1 e2 = AppBuiltin BitLeftShift [e1, e2] pattern BitRightShift' e1 e2 = AppBuiltin BitRightShift [e1, e2] -- modular functions -pattern Inv' e1 e2 = AppBuiltin Inv [e1, e2] +pattern ModInv' e1 e2 = AppBuiltin ModInv [e1, e2] -pattern PowMod' e1 e2 e3 = AppBuiltin PowMod [e1, e2, e3] +pattern ModPow' e1 e2 e3 = AppBuiltin ModPow [e1, e2, e3] -- list functions pattern Len' t e = AppBuiltin (Len t) [e] diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index 13d6798c..3363f259 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -88,9 +88,9 @@ data Builtin | -- | \(: \int \times \int \to \int\) Lcm | -- | \(: \int \times \int \to \int\) - Min + Min2 | -- | \(: \int \times \int \to \int\) - Max + Max2 | -- logical functions -- | \(: \bool \to \bool\) @@ -120,9 +120,9 @@ data Builtin | -- modular functions -- | \(: \int \times \int \to \int\) - Inv + ModInv | -- | \(: \int \times \int \times \int \to \int\) - PowMod + ModPow | -- list functions -- | \(: \forall \alpha. \list(\alpha) \to \int\) diff --git a/src/Jikka/Core/Language/Lint.hs b/src/Jikka/Core/Language/Lint.hs index 15601cde..fdbcf668 100644 --- a/src/Jikka/Core/Language/Lint.hs +++ b/src/Jikka/Core/Language/Lint.hs @@ -34,8 +34,8 @@ builtinToType = \case Abs -> Fun1Ty IntTy Gcd -> Fun2Ty IntTy Lcm -> Fun2Ty IntTy - Min -> Fun2Ty IntTy - Max -> Fun2Ty IntTy + Min2 -> Fun2Ty IntTy + Max2 -> Fun2Ty IntTy -- logical functions Not -> Fun1Ty BoolTy And -> Fun2Ty BoolTy @@ -50,8 +50,8 @@ builtinToType = \case BitLeftShift -> Fun2Ty IntTy BitRightShift -> Fun2Ty IntTy -- modular functions - Inv -> Fun2Ty IntTy - PowMod -> Fun3Ty IntTy + ModInv -> Fun2Ty IntTy + ModPow -> Fun3Ty IntTy -- list functions Len t -> FunTy [ListTy t] IntTy Tabulate t -> FunTy [IntTy, FunTy [IntTy] t] (ListTy t) diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 47a9320d..df2b4ade 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -75,7 +75,7 @@ runBuiltin builtin = X.BuiltinChoose -> f Y.Choose X.BuiltinPermute -> f Y.Permute X.BuiltinMultiChoose -> f Y.MultiChoose - X.BuiltinModInv -> f Y.Inv + X.BuiltinModInv -> f Y.ModInv runBoolOp :: X.BoolOp -> Y.Builtin runBoolOp = \case @@ -107,8 +107,8 @@ runOperator = \case X.BitOr -> Y.BitOr X.BitXor -> Y.BitXor X.BitAnd -> Y.BitAnd - X.Max -> Y.Max - X.Min -> Y.Min + X.Max -> Y.Max2 + X.Min -> Y.Min2 runCmpOp :: X.CmpOp' -> Y.Builtin runCmpOp (X.CmpOp' op _) = case op of From 2d428717105f335cc7ac56b9fd9d1e031f0c6311 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Mon, 21 Jun 2021 06:31:23 +0900 Subject: [PATCH 12/56] feat(core): Generalize some builtins --- src/Jikka/CPlusPlus/Convert/FromCore.hs | 27 +++++---- src/Jikka/Core/Convert/StrengthReduction.hs | 59 ++++++++++---------- src/Jikka/Core/Evaluate.hs | 19 +++---- src/Jikka/Core/Format.hs | 19 +++---- src/Jikka/Core/Language/BuiltinPatterns.hs | 16 +++--- src/Jikka/Core/Language/Expr.hs | 40 +++++++------ src/Jikka/Core/Language/Lint.hs | 19 +++---- src/Jikka/RestrictedPython/Convert/ToCore.hs | 10 ++-- 8 files changed, 105 insertions(+), 104 deletions(-) diff --git a/src/Jikka/CPlusPlus/Convert/FromCore.hs b/src/Jikka/CPlusPlus/Convert/FromCore.hs index 57249e3c..7f62db2d 100644 --- a/src/Jikka/CPlusPlus/Convert/FromCore.hs +++ b/src/Jikka/CPlusPlus/Convert/FromCore.hs @@ -118,10 +118,18 @@ runAppBuiltin f args = case (f, args) of (X.At _, [e1, e2]) -> return $ Y.At e1 e2 (X.Sum, [e]) -> return $ Y.Call (Y.Function "jikka::sum" []) [e] (X.Product, [e]) -> return $ Y.Call (Y.Function "jikka::product" []) [e] - (X.Min1, [e]) -> return $ Y.Call (Y.Function "jikka::minimum" []) [e] - (X.Max1, [e]) -> return $ Y.Call (Y.Function "jikka::maximum" []) [e] - (X.ArgMin, [e]) -> return $ Y.Call (Y.Function "jikka::argmin" []) [e] - (X.ArgMax, [e]) -> return $ Y.Call (Y.Function "jikka::argmax" []) [e] + (X.Min1 t, [e]) -> do + t <- runType t + return $ Y.Call (Y.Function "jikka::minimum" [t]) [e] + (X.Max1 t, [e]) -> do + t <- runType t + return $ Y.Call (Y.Function "jikka::maximum" [t]) [e] + (X.ArgMin t, [e]) -> do + t <- runType t + return $ Y.Call (Y.Function "jikka::argmin" [t]) [e] + (X.ArgMax t, [e]) -> do + t <- runType t + return $ Y.Call (Y.Function "jikka::argmax" [t]) [e] (X.All, [e]) -> return $ Y.Call (Y.Function "jikka::all" []) [e] (X.Any, [e]) -> return $ Y.Call (Y.Function "jikka::any" []) [e] (X.Sorted t, [e]) -> do @@ -134,12 +142,11 @@ runAppBuiltin f args = case (f, args) of (X.Range1, [e]) -> return $ Y.Call (Y.Function "jikka::range" []) [e] (X.Range2, [e1, e2]) -> return $ Y.Call (Y.Function "jikka::range" []) [e1, e2] (X.Range3, [e1, e2, e3]) -> return $ Y.Call (Y.Function "jikka::range" []) [e1, e2, e3] - -- arithmetical relations - (X.LessThan, [e1, e2]) -> return $ Y.BinOp Y.LessThan e1 e2 - (X.LessEqual, [e1, e2]) -> return $ Y.BinOp Y.LessEqual e1 e2 - (X.GreaterThan, [e1, e2]) -> return $ Y.BinOp Y.GreaterThan e1 e2 - (X.GreaterEqual, [e1, e2]) -> return $ Y.BinOp Y.GreaterEqual e1 e2 - -- equality relations (polymorphic) + -- comparison + (X.LessThan _, [e1, e2]) -> return $ Y.BinOp Y.LessThan e1 e2 + (X.LessEqual _, [e1, e2]) -> return $ Y.BinOp Y.LessEqual e1 e2 + (X.GreaterThan _, [e1, e2]) -> return $ Y.BinOp Y.GreaterThan e1 e2 + (X.GreaterEqual _, [e1, e2]) -> return $ Y.BinOp Y.GreaterEqual e1 e2 (X.Equal _, [e1, e2]) -> return $ Y.BinOp Y.Equal e1 e2 (X.NotEqual _, [e1, e2]) -> return $ Y.BinOp Y.NotEqual e1 e2 -- combinational functions diff --git a/src/Jikka/Core/Convert/StrengthReduction.hs b/src/Jikka/Core/Convert/StrengthReduction.hs index 98b1e9d7..950a585f 100644 --- a/src/Jikka/Core/Convert/StrengthReduction.hs +++ b/src/Jikka/Core/Convert/StrengthReduction.hs @@ -36,10 +36,9 @@ eliminateSomeBuiltins = \case Lcm' e1 e2 -> go $ FloorDiv' (Gcd' e1 e2) (Mult' e1 e2) -- logical functions Implies' e1 e2 -> Or' (Not' e1) e2 - -- arithmetical relations - GreaterThan' e1 e2 -> LessThan' e2 e1 - GreaterEqual' e1 e2 -> LessEqual' e2 e1 - -- equality relations (polymorphic) + -- comparison + GreaterThan' t e1 e2 -> LessThan' t e2 e1 + GreaterEqual' t e1 e2 -> LessEqual' t e2 e1 NotEqual' t e1 e2 -> Not' (Equal' t e1 e2) e -> e @@ -131,18 +130,18 @@ reduceFoldMap = \case At' t (Reversed' _ xs) i -> go $ At' t xs (Minus' (Minus' (Len' t xs) i) Lit1) Sum' (Reversed' _ xs) -> go $ Sum' xs Product' (Reversed' _ xs) -> go $ Product' xs - Max1' (Reversed' _ xs) -> go $ Max1' xs - Min1' (Reversed' _ xs) -> go $ Min1' xs - ArgMin' (Reversed' _ xs) -> go $ ArgMin' xs - ArgMax' (Reversed' _ xs) -> go $ ArgMax' xs + Max1' t (Reversed' _ xs) -> go $ Max1' t xs + Min1' t (Reversed' _ xs) -> go $ Min1' t xs + ArgMin' t (Reversed' _ xs) -> go $ ArgMin' t xs + ArgMax' t (Reversed' _ xs) -> go $ ArgMax' t xs All' (Reversed' _ xs) -> go $ All' xs Any' (Reversed' _ xs) -> go $ Any' xs -- reduce `Sorted` Len' t (Sorted' _ xs) -> go $ Len' t xs Sum' (Sorted' _ xs) -> go $ Sum' xs Product' (Sorted' _ xs) -> go $ Product' xs - Max1' (Sorted' _ xs) -> go $ Max1' xs - Min1' (Sorted' _ xs) -> go $ Min1' xs + Max1' t (Sorted' _ xs) -> go $ Max1' t xs + Min1' t (Sorted' _ xs) -> go $ Min1' t xs All' (Sorted' _ xs) -> go $ All' xs Any' (Sorted' _ xs) -> go $ Any' xs -- reduce `Map` @@ -156,22 +155,22 @@ reduceFoldMap = \case Product' (Map' t1 _ (Lam1 x _ e) xs) | x `isUnusedVar` e -> go $ Pow' e (Len' t1 xs) Product' (Map' t1 t2 (Lam1 x t (Negate' e)) xs) -> go $ Mult' (Pow' (Negate' Lit0) (Len' t1 xs)) (Product' (Map' t1 t2 (Lam1 x t e) xs)) Product' (Map' t1 t2 (Lam1 x t (Mult' e1 e2)) xs) -> go $ Mult' (Product' (Map' t1 t2 (Lam1 x t e1) xs)) (Product' (Map' t1 t2 (Lam1 x t e2) xs)) - Max1' (Map' _ _ (Lam1 x _ e) _) | x `isUnusedVar` e -> e - Max1' (Map' t1 t2 (Lam1 x t (Max2' e1 e2)) xs) -> go $ Max2' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) - Max1' (Map' t1 t2 (Lam1 x t (Negate' e)) xs) -> go $ Negate' (Min1' (Map' t1 t2 (Lam1 x t e) xs)) - Max1' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ Plus' e1 (Max1' (Map' t1 t2 (Lam1 x t e2) xs)) - Max1' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ Plus' (Max1' (Map' t1 t2 (Lam1 x t e1) xs)) e1 - Min1' (Map' _ _ (Lam1 x _ e) _) | x `isUnusedVar` e -> e - Min1' (Map' t1 t2 (Lam1 x t (Min2' e1 e2)) xs) -> go $ Min2' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) - Min1' (Map' t1 t2 (Lam1 x t (Negate' e)) xs) -> go $ Negate' (Max1' (Map' t1 t2 (Lam1 x t e) xs)) - Min1' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ Plus' e1 (Min1' (Map' t1 t2 (Lam1 x t e2) xs)) - Min1' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ Plus' (Min1' (Map' t1 t2 (Lam1 x t e1) xs)) e1 - ArgMax' (Map' _ _ (Lam1 x t e) xs) | x `isUnusedVar` e -> go $ Minus' (Len' t xs) Lit1 - ArgMax' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ ArgMax' (Map' t1 t2 (Lam1 x t e2) xs) - ArgMax' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ ArgMax' (Map' t1 t2 (Lam1 x t e1) xs) - ArgMin' (Map' _ _ (Lam1 x _ e) _) | x `isUnusedVar` e -> Lit0 - ArgMin' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ ArgMin' (Map' t1 t2 (Lam1 x t e2) xs) - ArgMin' (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ ArgMin' (Map' t1 t2 (Lam1 x t e1) xs) + Max1' _ (Map' _ _ (Lam1 x _ e) _) | x `isUnusedVar` e -> e + Max1' _ (Map' t1 t2 (Lam1 x t (Max2' e1 e2)) xs) -> go $ Max2' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) + Max1' _ (Map' t1 t2 (Lam1 x t (Negate' e)) xs) -> go $ Negate' (Min1' t2 (Map' t1 t2 (Lam1 x t e) xs)) + Max1' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ Plus' e1 (Max1' t2 (Map' t1 t2 (Lam1 x t e2) xs)) + Max1' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ Plus' (Max1' t2 (Map' t1 t2 (Lam1 x t e1) xs)) e1 + Min1' _ (Map' _ _ (Lam1 x _ e) _) | x `isUnusedVar` e -> e + Min1' _ (Map' t1 t2 (Lam1 x t (Min2' e1 e2)) xs) -> go $ Min2' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) + Min1' _ (Map' t1 t2 (Lam1 x t (Negate' e)) xs) -> go $ Negate' (Max1' t2 (Map' t1 t2 (Lam1 x t e) xs)) + Min1' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ Plus' e1 (Min1' t2 (Map' t1 t2 (Lam1 x t e2) xs)) + Min1' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ Plus' (Min1' t2 (Map' t1 t2 (Lam1 x t e1) xs)) e1 + ArgMax' _ (Map' _ _ (Lam1 x t e) xs) | x `isUnusedVar` e -> go $ Minus' (Len' t xs) Lit1 + ArgMax' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ ArgMax' t2 (Map' t1 t2 (Lam1 x t e2) xs) + ArgMax' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ ArgMax' t2 (Map' t1 t2 (Lam1 x t e1) xs) + ArgMin' _ (Map' _ _ (Lam1 x _ e) _) | x `isUnusedVar` e -> Lit0 + ArgMin' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ ArgMin' t2 (Map' t1 t2 (Lam1 x t e2) xs) + ArgMin' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ ArgMin' t2 (Map' t1 t2 (Lam1 x t e1) xs) e -> e reduceFoldBuild :: Expr -> Expr @@ -182,10 +181,10 @@ reduceFoldBuild = \case Sum' (Map' _ _ (Lam1 x _ (Mult' x' x'')) (Range1' n)) | x' == Var x && x'' == Var x -> go $ FloorDiv' (Mult' n (Mult' (Minus' n Lit1) (Minus' (Mult' Lit2 n) Lit1))) (Lit (LitInt 6)) Sum' (Map' _ _ (Lam1 x _ (Mult' x' (Mult' x'' x'''))) (Range1' n)) | x' == Var x && x'' == Var x && x''' == Var x -> go $ FloorDiv' (Mult' n (Mult' n (Mult' (Minus' n Lit1) (Minus' n Lit1)))) (Lit (LitInt 4)) Product' (Range1' n) -> go $ If' IntTy (Equal' IntTy n Lit0) Lit1 Lit0 - Max1' (Range1' n) -> go $ Minus' n Lit1 - Min1' (Range1' _) -> Lit0 - ArgMax' (Range1' n) -> go $ Minus' n Lit1 - ArgMin' (Range1' _) -> Lit0 + Max1' _ (Range1' n) -> go $ Minus' n Lit1 + Min1' _ (Range1' _) -> Lit0 + ArgMax' _ (Range1' n) -> go $ Minus' n Lit1 + ArgMin' _ (Range1' _) -> Lit0 e -> e reduceList :: Expr -> Expr diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index 76e16e10..04478de4 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -276,10 +276,10 @@ callBuiltin builtin args = case (builtin, args) of (At _, [ValList a, ValInt n]) -> atEither a n (Sum, [ValList a]) -> ValInt . sum <$> valueToIntList a (Product, [ValList a]) -> ValInt . product <$> valueToIntList a - (Min1, [ValList a]) -> ValInt <$> (minimumEither =<< valueToIntList a) - (Max1, [ValList a]) -> ValInt <$> (maximumEither =<< valueToIntList a) - (ArgMin, [ValList a]) -> ValInt <$> (argminEither =<< valueToIntList a) - (ArgMax, [ValList a]) -> ValInt <$> (argmaxEither =<< valueToIntList a) + (Min1 IntTy, [ValList a]) -> ValInt <$> (minimumEither =<< valueToIntList a) -- TODO: allow non-integers + (Max1 IntTy, [ValList a]) -> ValInt <$> (maximumEither =<< valueToIntList a) -- TODO: allow non-integers + (ArgMin IntTy, [ValList a]) -> ValInt <$> (argminEither =<< valueToIntList a) -- TODO: allow non-integers + (ArgMax IntTy, [ValList a]) -> ValInt <$> (argmaxEither =<< valueToIntList a) -- TODO: allow non-integers (All, [ValList a]) -> ValBool . and <$> valueToBoolList a (Any, [ValList a]) -> ValBool . or <$> valueToBoolList a (Sorted _, [ValList a]) -> return $ ValList (sortArray a) @@ -288,12 +288,11 @@ callBuiltin builtin args = case (builtin, args) of (Range1, [ValInt n]) -> ValList <$> range1 n (Range2, [ValInt l, ValInt r]) -> ValList <$> range2 l r (Range3, [ValInt l, ValInt r, ValInt step]) -> ValList <$> range3 l r step - -- arithmetical relations - (LessThan, [ValInt a, ValInt b]) -> return $ ValBool (a < b) - (LessEqual, [ValInt a, ValInt b]) -> return $ ValBool (a <= b) - (GreaterThan, [ValInt a, ValInt b]) -> return $ ValBool (a > b) - (GreaterEqual, [ValInt a, ValInt b]) -> return $ ValBool (a >= b) - -- equality relations (polymorphic) + -- comparison + (LessThan IntTy, [ValInt a, ValInt b]) -> return $ ValBool (a < b) -- TODO: allow non-integers + (LessEqual IntTy, [ValInt a, ValInt b]) -> return $ ValBool (a <= b) -- TODO: allow non-integers + (GreaterThan IntTy, [ValInt a, ValInt b]) -> return $ ValBool (a > b) -- TODO: allow non-integers + (GreaterEqual IntTy, [ValInt a, ValInt b]) -> return $ ValBool (a >= b) -- TODO: allow non-integers (Equal _, [a, b]) -> return $ ValBool (a == b) (NotEqual _, [a, b]) -> return $ ValBool (a /= b) -- combinational functions diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index 5d3c4c7e..d34b6964 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -90,10 +90,10 @@ analyzeBuiltin = \case At t -> At' t Sum -> fun "sum" Product -> fun "product" - Min1 -> fun "min1" - Max1 -> fun "max1" - ArgMin -> fun "argmin" - ArgMax -> fun "argmax" + Min1 t -> Fun [t] "min1" + Max1 t -> Fun [t] "max1" + ArgMin t -> Fun [t] "argmin" + ArgMax t -> Fun [t] "argmax" All -> fun "all" Any -> fun "any" Sorted t -> Fun [t] "sort" @@ -102,12 +102,11 @@ analyzeBuiltin = \case Range1 -> fun "range1" Range2 -> fun "range2" Range3 -> fun "range3" - -- arithmetical relations - LessThan -> infixOp "<" - LessEqual -> infixOp "<=" - GreaterThan -> infixOp ">" - GreaterEqual -> infixOp ">=" - -- equality relations (polymorphic) + -- comparison + LessThan t -> InfixOp [t] "<" + LessEqual t -> InfixOp [t] "<=" + GreaterThan t -> InfixOp [t] ">" + GreaterEqual t -> InfixOp [t] ">=" Equal t -> InfixOp [t] "==" NotEqual t -> InfixOp [t] "!=" -- combinational functions diff --git a/src/Jikka/Core/Language/BuiltinPatterns.hs b/src/Jikka/Core/Language/BuiltinPatterns.hs index a686edc9..7efbe200 100644 --- a/src/Jikka/Core/Language/BuiltinPatterns.hs +++ b/src/Jikka/Core/Language/BuiltinPatterns.hs @@ -90,13 +90,13 @@ pattern Sum' e = AppBuiltin Sum [e] pattern Product' e = AppBuiltin Product [e] -pattern Min1' e = AppBuiltin Min1 [e] +pattern Min1' t e = AppBuiltin (Min1 t) [e] -pattern Max1' e = AppBuiltin Max1 [e] +pattern Max1' t e = AppBuiltin (Max1 t) [e] -pattern ArgMin' e = AppBuiltin ArgMin [e] +pattern ArgMin' t e = AppBuiltin (ArgMin t) [e] -pattern ArgMax' e = AppBuiltin ArgMax [e] +pattern ArgMax' t e = AppBuiltin (ArgMax t) [e] pattern All' e = AppBuiltin All [e] @@ -115,13 +115,13 @@ pattern Range2' e1 e2 = AppBuiltin Range2 [e1, e2] pattern Range3' e1 e2 e3 = AppBuiltin Range3 [e1, e2, e3] -- arithmetical relations -pattern LessThan' e1 e2 = AppBuiltin LessThan [e1, e2] +pattern LessThan' t e1 e2 = AppBuiltin (LessThan t) [e1, e2] -pattern LessEqual' e1 e2 = AppBuiltin LessEqual [e1, e2] +pattern LessEqual' t e1 e2 = AppBuiltin (LessEqual t) [e1, e2] -pattern GreaterThan' e1 e2 = AppBuiltin GreaterThan [e1, e2] +pattern GreaterThan' t e1 e2 = AppBuiltin (GreaterThan t) [e1, e2] -pattern GreaterEqual' e1 e2 = AppBuiltin GreaterEqual [e1, e2] +pattern GreaterEqual' t e1 e2 = AppBuiltin (GreaterEqual t) [e1, e2] -- equality relations (polymorphic) pattern Equal' t e1 e2 = AppBuiltin (Equal t) [e1, e2] diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index 3363f259..4c4ec272 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -137,14 +137,14 @@ data Builtin Sum | -- | \(: \list(\int) \to \int\) Product - | -- | \(: \list(\int) \to \int\) - Min1 - | -- | \(: \list(\int) \to \int\) - Max1 - | -- | \(: \list(\int) \to \int\) - ArgMin - | -- | \(: \list(\int) \to \int\) - ArgMax + | -- | \(: \forall \alpha. \list(\alpha) \to \alpha\) + Min1 Type + | -- | \(: \forall \alpha. \list(\alpha) \to \alpha\) + Max1 Type + | -- | \(: \forall \alpha. \list(\alpha) \to \alpha\) + ArgMin Type + | -- | \(: \forall \alpha. \list(\alpha) \to \alpha\) + ArgMax Type | -- | \(: \list(\bool) \to \bool\) All | -- | \(: \list(\bool) \to \bool\) @@ -161,19 +161,17 @@ data Builtin Range2 | -- | \(: \int \times \int \times \int \to \list(\int)\)1 Range3 - | -- arithmetical relations - - -- | \(: \int \times \int \to \int\) - LessThan - | -- | \(: \int \times \int \to \int\) - LessEqual - | -- | \(: \int \times \int \to \int\) - GreaterThan - | -- | \(: \int \times \int \to \int\) - GreaterEqual - | -- equality relations (polymorphic) - - -- | \(: \forall \alpha. \alpha \times \alpha \to \bool\) + | -- comparison + + -- | \(: \forall \alpha. \alpha \times \alpha \to \alpha\) + LessThan Type + | -- | \(: \forall \alpha. \alpha \times \alpha \to \alpha\) + LessEqual Type + | -- | \(: \forall \alpha. \alpha \times \alpha \to \alpha\) + GreaterThan Type + | -- | \(: \forall \alpha. \alpha \times \alpha \to \alpha\) + GreaterEqual Type + | -- | \(: \forall \alpha. \alpha \times \alpha \to \bool\) Equal Type | -- | \(: \forall \alpha. \alpha \times \alpha \to \bool\) NotEqual Type diff --git a/src/Jikka/Core/Language/Lint.hs b/src/Jikka/Core/Language/Lint.hs index fdbcf668..ddee0205 100644 --- a/src/Jikka/Core/Language/Lint.hs +++ b/src/Jikka/Core/Language/Lint.hs @@ -59,10 +59,10 @@ builtinToType = \case At t -> FunTy [ListTy t, IntTy] t Sum -> FunLTy IntTy Product -> FunLTy IntTy - Min1 -> FunLTy IntTy - Max1 -> FunLTy IntTy - ArgMin -> FunLTy IntTy - ArgMax -> FunLTy IntTy + Min1 t -> FunLTy t + Max1 t -> FunLTy t + ArgMin t -> FunTy [ListTy t] IntTy + ArgMax t -> FunTy [ListTy t] IntTy All -> FunLTy BoolTy Any -> FunLTy BoolTy Sorted t -> Fun1Ty (ListTy t) @@ -71,12 +71,11 @@ builtinToType = \case Range1 -> FunTy [IntTy] (ListTy IntTy) Range2 -> FunTy [IntTy, IntTy] (ListTy IntTy) Range3 -> FunTy [IntTy, IntTy, IntTy] (ListTy IntTy) - -- arithmetical relations - LessThan -> FunTy [IntTy, IntTy] BoolTy - LessEqual -> FunTy [IntTy, IntTy] BoolTy - GreaterThan -> FunTy [IntTy, IntTy] BoolTy - GreaterEqual -> FunTy [IntTy, IntTy] BoolTy - -- equality relations (polymorphic) + -- comparison + LessThan t -> FunTy [t, t] BoolTy + LessEqual t -> FunTy [t, t] BoolTy + GreaterThan t -> FunTy [t, t] BoolTy + GreaterEqual t -> FunTy [t, t] BoolTy Equal t -> FunTy [t, t] BoolTy NotEqual t -> FunTy [t, t] BoolTy -- combinational functions diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index df2b4ade..43fcac16 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -111,11 +111,11 @@ runOperator = \case X.Min -> Y.Min2 runCmpOp :: X.CmpOp' -> Y.Builtin -runCmpOp (X.CmpOp' op _) = case op of - X.Lt -> Y.LessThan - X.LtE -> Y.LessEqual - X.Gt -> Y.GreaterThan - X.GtE -> Y.GreaterEqual +runCmpOp (X.CmpOp' op t) = case op of + X.Lt -> Y.LessThan (runType t) + X.LtE -> Y.LessEqual (runType t) + X.Gt -> Y.GreaterThan (runType t) + X.GtE -> Y.GreaterEqual (runType t) X.Eq' -> Y.Equal undefined -- TODO X.NotEq -> Y.NotEqual undefined -- TODO X.Is -> undefined -- TODO From abe9726e9df42083fd8a0b96fb76e85abc2d85e6 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Mon, 21 Jun 2021 06:41:38 +0900 Subject: [PATCH 13/56] feat(core): Add Elem as a new builtin --- src/Jikka/Core/Format.hs | 1 + src/Jikka/Core/Language/BuiltinPatterns.hs | 2 ++ src/Jikka/Core/Language/Expr.hs | 2 ++ src/Jikka/Core/Language/Lint.hs | 1 + 4 files changed, 6 insertions(+) diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index d34b6964..ec99762e 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -88,6 +88,7 @@ analyzeBuiltin = \case Tabulate t -> Fun [t] "tabulate" Map t1 t2 -> Fun [t1, t2] "map" At t -> At' t + Elem t -> Fun [t] "elem" Sum -> fun "sum" Product -> fun "product" Min1 t -> Fun [t] "min1" diff --git a/src/Jikka/Core/Language/BuiltinPatterns.hs b/src/Jikka/Core/Language/BuiltinPatterns.hs index 7efbe200..b8e57298 100644 --- a/src/Jikka/Core/Language/BuiltinPatterns.hs +++ b/src/Jikka/Core/Language/BuiltinPatterns.hs @@ -86,6 +86,8 @@ pattern Map' t1 t2 f e = AppBuiltin (Map t1 t2) [f, e] pattern At' t e1 e2 = AppBuiltin (At t) [e1, e2] +pattern Elem' t e1 e2 = AppBuiltin (Elem t) [e1, e2] + pattern Sum' e = AppBuiltin Sum [e] pattern Product' e = AppBuiltin Product [e] diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index 4c4ec272..6661fd15 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -133,6 +133,8 @@ data Builtin Map Type Type | -- | \(: \forall \alpha. \list(\alpha) \times \int \to \alpha\) At Type + | -- | \(: \forall \alpha. \alpha \times \list(\alpha) \to \bool\) + Elem Type | -- | \(: \list(\int) \to \int\) Sum | -- | \(: \list(\int) \to \int\) diff --git a/src/Jikka/Core/Language/Lint.hs b/src/Jikka/Core/Language/Lint.hs index ddee0205..d09466c2 100644 --- a/src/Jikka/Core/Language/Lint.hs +++ b/src/Jikka/Core/Language/Lint.hs @@ -57,6 +57,7 @@ builtinToType = \case Tabulate t -> FunTy [IntTy, FunTy [IntTy] t] (ListTy t) Map t1 t2 -> FunTy [FunTy [t1] t2, ListTy t1] (ListTy t2) At t -> FunTy [ListTy t, IntTy] t + Elem t -> FunTy [t, ListTy t] BoolTy Sum -> FunLTy IntTy Product -> FunLTy IntTy Min1 t -> FunLTy t From e7b96ea37785064a3c97e0ab89ca13c2fc6d5c60 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Mon, 21 Jun 2021 07:10:20 +0900 Subject: [PATCH 14/56] feat(core): Generalize Max2 and Min2 --- src/Jikka/CPlusPlus/Convert/FromCore.hs | 8 ++++++-- src/Jikka/Core/Convert/StrengthReduction.hs | 14 +++++++------- src/Jikka/Core/Evaluate.hs | 4 ++-- src/Jikka/Core/Format.hs | 4 ++-- src/Jikka/Core/Language/BuiltinPatterns.hs | 4 ++-- src/Jikka/Core/Language/Expr.hs | 8 ++++---- src/Jikka/Core/Language/Lint.hs | 4 ++-- src/Jikka/RestrictedPython/Convert/ToCore.hs | 4 ++-- 8 files changed, 27 insertions(+), 23 deletions(-) diff --git a/src/Jikka/CPlusPlus/Convert/FromCore.hs b/src/Jikka/CPlusPlus/Convert/FromCore.hs index 7f62db2d..8ea8aaf6 100644 --- a/src/Jikka/CPlusPlus/Convert/FromCore.hs +++ b/src/Jikka/CPlusPlus/Convert/FromCore.hs @@ -88,8 +88,12 @@ runAppBuiltin f args = case (f, args) of (X.Abs, [e]) -> return $ Y.Call (Y.Function "std::abs" []) [e] (X.Gcd, [e1, e2]) -> return $ Y.Call (Y.Function "std::gcd" []) [e1, e2] (X.Lcm, [e1, e2]) -> return $ Y.Call (Y.Function "std::lcm" []) [e1, e2] - (X.Min2, [e1, e2]) -> return $ Y.Call (Y.Function "std::min" []) [e1, e2] - (X.Max2, [e1, e2]) -> return $ Y.Call (Y.Function "std::max" []) [e1, e2] + (X.Min2 t, [e1, e2]) -> do + t <- runType t + return $ Y.Call (Y.Function "std::min" [t]) [e1, e2] + (X.Max2 t, [e1, e2]) -> do + t <- runType t + return $ Y.Call (Y.Function "std::max" [t]) [e1, e2] -- logical functions (X.Not, [e]) -> return $ Y.UnOp Y.Not e (X.And, [e1, e2]) -> return $ Y.BinOp Y.And e1 e2 diff --git a/src/Jikka/Core/Convert/StrengthReduction.hs b/src/Jikka/Core/Convert/StrengthReduction.hs index 950a585f..778e88b7 100644 --- a/src/Jikka/Core/Convert/StrengthReduction.hs +++ b/src/Jikka/Core/Convert/StrengthReduction.hs @@ -32,7 +32,7 @@ eliminateSomeBuiltins = \case -- arithmetical functions Minus' e1 e2 -> go $ Plus' e1 (Negate' e2) -- advanced arithmetical functions - Abs' e -> go $ Max2' e (Negate' e) + Abs' e -> go $ Max2' IntTy e (Negate' e) Lcm' e1 e2 -> go $ FloorDiv' (Gcd' e1 e2) (Mult' e1 e2) -- logical functions Implies' e1 e2 -> Or' (Not' e1) e2 @@ -51,8 +51,8 @@ reduceNegate = \case Mult' (Negate' e1) e2 -> go $ Negate' (Mult' e1 e2) Mult' e1 (Negate' e2) -> go $ Negate' (Mult' e1 e2) -- `Abs` is already removed. - Min2' (Negate' e1) (Negate' e2) -> go $ Negate' (Max2' e1 e2) - Max2' (Negate' e1) (Negate' e2) -> go $ Negate' (Min2' e1 e2) + Min2' IntTy (Negate' e1) (Negate' e2) -> go $ Negate' (Max2' IntTy e1 e2) + Max2' IntTy (Negate' e1) (Negate' e2) -> go $ Negate' (Min2' IntTy e1 e2) e -> e -- | `reduceNot` brings `Not` to the root. @@ -82,8 +82,8 @@ reduceAssoc = \case Plus' (Plus' e1 e2) e3 -> Plus' e1 (Plus' e2 e3) Minus' (Minus' e1 e2) e3 -> Minus' e1 (Minus' e2 e3) Mult' (Mult' e1 e2) e3 -> Mult' e1 (Mult' e2 e3) - Max2' (Max2' e1 e2) e3 -> Max2' e1 (Max2' e2 e3) - Min2' (Min2' e1 e2) e3 -> Min2' e1 (Min2' e2 e3) + Max2' t1 (Max2' t2 e1 e2) e3 -> Max2' t1 e1 (Max2' t2 e2 e3) + Min2' t1 (Min2' t2 e1 e2) e3 -> Min2' t1 e1 (Min2' t2 e2 e3) And' (And' e1 e2) e3 -> And' e1 (And' e2 e3) Or' (Or' e1 e2) e3 -> Or' e1 (Or' e2 e3) BitAnd' (BitAnd' e1 e2) e3 -> BitAnd' e1 (BitAnd' e2 e3) @@ -156,12 +156,12 @@ reduceFoldMap = \case Product' (Map' t1 t2 (Lam1 x t (Negate' e)) xs) -> go $ Mult' (Pow' (Negate' Lit0) (Len' t1 xs)) (Product' (Map' t1 t2 (Lam1 x t e) xs)) Product' (Map' t1 t2 (Lam1 x t (Mult' e1 e2)) xs) -> go $ Mult' (Product' (Map' t1 t2 (Lam1 x t e1) xs)) (Product' (Map' t1 t2 (Lam1 x t e2) xs)) Max1' _ (Map' _ _ (Lam1 x _ e) _) | x `isUnusedVar` e -> e - Max1' _ (Map' t1 t2 (Lam1 x t (Max2' e1 e2)) xs) -> go $ Max2' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) + Max1' _ (Map' t1 t2 (Lam1 x t (Max2' t' e1 e2)) xs) -> go $ Max2' t' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) Max1' _ (Map' t1 t2 (Lam1 x t (Negate' e)) xs) -> go $ Negate' (Min1' t2 (Map' t1 t2 (Lam1 x t e) xs)) Max1' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ Plus' e1 (Max1' t2 (Map' t1 t2 (Lam1 x t e2) xs)) Max1' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ Plus' (Max1' t2 (Map' t1 t2 (Lam1 x t e1) xs)) e1 Min1' _ (Map' _ _ (Lam1 x _ e) _) | x `isUnusedVar` e -> e - Min1' _ (Map' t1 t2 (Lam1 x t (Min2' e1 e2)) xs) -> go $ Min2' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) + Min1' _ (Map' t1 t2 (Lam1 x t (Min2' t' e1 e2)) xs) -> go $ Min2' t' (Map' t1 t2 (Lam1 x t e1) xs) (Map' t1 t2 (Lam1 x t e2) xs) Min1' _ (Map' t1 t2 (Lam1 x t (Negate' e)) xs) -> go $ Negate' (Max1' t2 (Map' t1 t2 (Lam1 x t e) xs)) Min1' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e1 -> go $ Plus' e1 (Min1' t2 (Map' t1 t2 (Lam1 x t e2) xs)) Min1' _ (Map' t1 t2 (Lam1 x t (Plus' e1 e2)) xs) | x `isUnusedVar` e2 -> go $ Plus' (Min1' t2 (Map' t1 t2 (Lam1 x t e1) xs)) e1 diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index 04478de4..6244ff4c 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -251,8 +251,8 @@ callBuiltin builtin args = case (builtin, args) of (Abs, [ValInt n]) -> return $ ValInt (abs n) (Gcd, [ValInt a, ValInt b]) -> return $ ValInt (gcd a b) (Lcm, [ValInt a, ValInt b]) -> return $ ValInt (lcm a b) - (Min2, [ValInt a, ValInt b]) -> return $ ValInt (min a b) - (Max2, [ValInt a, ValInt b]) -> return $ ValInt (max a b) + (Min2 IntTy, [ValInt a, ValInt b]) -> return $ ValInt (min a b) -- TODO: allow non-integers + (Max2 IntTy, [ValInt a, ValInt b]) -> return $ ValInt (max a b) -- TODO: allow non-integers -- logical functions (Not, [ValBool p]) -> return $ ValBool (not p) (And, [ValBool p, ValBool q]) -> return $ ValBool (p && q) diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index ec99762e..789b9113 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -65,8 +65,8 @@ analyzeBuiltin = \case Abs -> fun "abs" Gcd -> fun "gcd" Lcm -> fun "lcm" - Min2 -> fun "min" - Max2 -> fun "max" + Min2 t -> Fun [t] "min" + Max2 t -> Fun [t] "max" -- logical functions Not -> PrefixOp "not" And -> infixOp "and" diff --git a/src/Jikka/Core/Language/BuiltinPatterns.hs b/src/Jikka/Core/Language/BuiltinPatterns.hs index b8e57298..937838c7 100644 --- a/src/Jikka/Core/Language/BuiltinPatterns.hs +++ b/src/Jikka/Core/Language/BuiltinPatterns.hs @@ -44,9 +44,9 @@ pattern Gcd' e1 e2 = AppBuiltin Gcd [e1, e2] pattern Lcm' e1 e2 = AppBuiltin Lcm [e1, e2] -pattern Min2' e1 e2 = AppBuiltin Min2 [e1, e2] +pattern Min2' t e1 e2 = AppBuiltin (Min2 t) [e1, e2] -pattern Max2' e1 e2 = AppBuiltin Max2 [e1, e2] +pattern Max2' t e1 e2 = AppBuiltin (Max2 t) [e1, e2] -- logical functions pattern Not' e = AppBuiltin Not [e] diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index 6661fd15..7b38fb9d 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -87,10 +87,10 @@ data Builtin Gcd | -- | \(: \int \times \int \to \int\) Lcm - | -- | \(: \int \times \int \to \int\) - Min2 - | -- | \(: \int \times \int \to \int\) - Max2 + | -- | \(: \forall \alpha. \alpha \times \alpha \to \alpha\) + Min2 Type + | -- | \(: \forall \alpha. \alpha \times \alpha \to \alpha\) + Max2 Type | -- logical functions -- | \(: \bool \to \bool\) diff --git a/src/Jikka/Core/Language/Lint.hs b/src/Jikka/Core/Language/Lint.hs index d09466c2..fa183668 100644 --- a/src/Jikka/Core/Language/Lint.hs +++ b/src/Jikka/Core/Language/Lint.hs @@ -34,8 +34,8 @@ builtinToType = \case Abs -> Fun1Ty IntTy Gcd -> Fun2Ty IntTy Lcm -> Fun2Ty IntTy - Min2 -> Fun2Ty IntTy - Max2 -> Fun2Ty IntTy + Min2 t -> Fun2Ty t + Max2 t -> Fun2Ty t -- logical functions Not -> Fun1Ty BoolTy And -> Fun2Ty BoolTy diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 43fcac16..c26f5159 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -107,8 +107,8 @@ runOperator = \case X.BitOr -> Y.BitOr X.BitXor -> Y.BitXor X.BitAnd -> Y.BitAnd - X.Max -> Y.Max2 - X.Min -> Y.Min2 + X.Max -> Y.Max2 Y.IntTy + X.Min -> Y.Min2 Y.IntTy runCmpOp :: X.CmpOp' -> Y.Builtin runCmpOp (X.CmpOp' op t) = case op of From 0c0f84d52a75103bebc6ff08c19db4b805d948b4 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Mon, 21 Jun 2021 07:23:27 +0900 Subject: [PATCH 15/56] feat(rpython): Update src/Jikka/RestrictedPython/Convert/ToCore.hs --- src/Jikka/RestrictedPython/Convert/ToCore.hs | 132 +++++++++++-------- 1 file changed, 76 insertions(+), 56 deletions(-) diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index c26f5159..0c58ddcb 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Jikka.RestrictedPython.Convert.ToCore ( run, @@ -9,6 +11,7 @@ where import Control.Arrow ((***)) import Jikka.Common.Alpha import Jikka.Common.Error +import qualified Jikka.Core.Language.BuiltinPatterns as Y import qualified Jikka.Core.Language.Expr as Y import qualified Jikka.Core.Language.Util as Y import qualified Jikka.RestrictedPython.Language.Expr as X @@ -26,20 +29,20 @@ runType = \case X.TupleTy ts -> Y.TupleTy (map runType ts) X.CallableTy args ret -> Y.FunTy (map runType args) (runType ret) -runConstant :: X.Constant -> Y.Expr +runConstant :: MonadError Error m => X.Constant -> m Y.Expr runConstant = \case X.ConstNone -> undefined -- TODO - X.ConstInt n -> Y.Lit (Y.LitInt n) - X.ConstBool p -> Y.Lit (Y.LitBool p) + X.ConstInt n -> return $ Y.Lit (Y.LitInt n) + X.ConstBool p -> return $ Y.Lit (Y.LitBool p) X.ConstBuiltin builtin -> runBuiltin builtin -runBuiltin :: X.Builtin -> Y.Expr +runBuiltin :: MonadError Error m => X.Builtin -> m Y.Expr runBuiltin builtin = - let f = Y.Lit . Y.LitBuiltin + let f = return . Y.Lit . Y.LitBuiltin in case builtin of X.BuiltinAbs -> f Y.Abs X.BuiltinPow -> f Y.Pow - X.BuiltinModPow -> undefined -- TODO + X.BuiltinModPow -> f Y.ModPow X.BuiltinDivMod -> undefined -- TODO X.BuiltinCeilDiv -> f Y.CeilDiv X.BuiltinCeilMod -> f Y.CeilMod @@ -58,19 +61,31 @@ runBuiltin builtin = X.BuiltinEnumerate _ -> undefined -- TODO X.BuiltinFilter _ -> undefined -- TODO X.BuiltinZip _ -> undefined -- TODO - X.BuiltinAll -> undefined -- TODO - X.BuiltinAny -> undefined -- TODO + X.BuiltinAll -> f Y.All + X.BuiltinAny -> f Y.Any X.BuiltinSum -> f Y.Sum X.BuiltinProduct -> f Y.Product X.BuiltinRange1 -> f Y.Range1 X.BuiltinRange2 -> f Y.Range2 X.BuiltinRange3 -> f Y.Range1 - X.BuiltinMax1 _ -> undefined -- TODO - X.BuiltinMax _ _ -> undefined -- TODO - X.BuiltinMin1 _ -> undefined -- TODO - X.BuiltinMin _ _ -> undefined -- TODO - X.BuiltinArgMax _ -> undefined -- TODO - X.BuiltinArgMin _ -> undefined -- TODO + X.BuiltinMax1 t -> f $ Y.Max1 (runType t) + X.BuiltinMax t n -> + if n < 2 + then throwTypeError $ "max expected 2 or more arguments, got " ++ show n + else + let t' = runType t + args = map (\i -> Y.VarName ('x' : show i)) [0 .. n -1] + in return $ Y.Lam (map (,t') args) (foldr1 (Y.Max2' t') (map Y.Var args)) + X.BuiltinMin1 t -> f $ Y.Min1 (runType t) + X.BuiltinMin t n -> + if n < 2 + then throwTypeError $ "max min 2 or more arguments, got " ++ show n + else + let t' = runType t + args = map (\i -> Y.VarName ('x' : show i)) [0 .. n -1] + in return $ Y.Lam (map (,t') args) (foldr1 (Y.Min2' t') (map Y.Var args)) + X.BuiltinArgMax t -> f $ Y.ArgMax (runType t) + X.BuiltinArgMin t -> f $ Y.ArgMin (runType t) X.BuiltinFact -> f Y.Fact X.BuiltinChoose -> f Y.Choose X.BuiltinPermute -> f Y.Permute @@ -83,45 +98,50 @@ runBoolOp = \case X.Or -> Y.Or X.Implies -> Y.Implies -runUnaryOp :: X.UnaryOp -> Y.Builtin -runUnaryOp = \case - X.Invert -> Y.BitNot - X.Not -> Y.Not - X.UAdd -> undefined -- TODO - X.USub -> Y.Negate +runUnaryOp :: X.UnaryOp -> Y.Expr +runUnaryOp = + let f = Y.Lit . Y.LitBuiltin + in \case + X.Invert -> f Y.BitNot + X.Not -> f Y.Not + X.UAdd -> Y.Lam [("x", Y.IntTy)] (Y.Var "x") + X.USub -> f Y.Negate -runOperator :: X.Operator -> Y.Builtin +runOperator :: MonadError Error m => X.Operator -> m Y.Builtin runOperator = \case - X.Add -> Y.Plus - X.Sub -> Y.Minus - X.Mult -> Y.Mult - X.MatMult -> undefined -- TODO - X.Div -> undefined -- TODO - X.FloorDiv -> Y.FloorDiv - X.FloorMod -> Y.FloorMod - X.CeilDiv -> Y.CeilDiv - X.CeilMod -> Y.CeilMod - X.Pow -> Y.Pow - X.BitLShift -> Y.BitLeftShift - X.BitRShift -> Y.BitRightShift - X.BitOr -> Y.BitOr - X.BitXor -> Y.BitXor - X.BitAnd -> Y.BitAnd - X.Max -> Y.Max2 Y.IntTy - X.Min -> Y.Min2 Y.IntTy + X.Add -> return Y.Plus + X.Sub -> return Y.Minus + X.Mult -> return Y.Mult + X.MatMult -> throwSemanticError "matmul operator ('@') is not supported" + X.Div -> throwSemanticError "floatdiv operator ('/') is not supported" + X.FloorDiv -> return Y.FloorDiv + X.FloorMod -> return Y.FloorMod + X.CeilDiv -> return Y.CeilDiv + X.CeilMod -> return Y.CeilMod + X.Pow -> return Y.Pow + X.BitLShift -> return Y.BitLeftShift + X.BitRShift -> return Y.BitRightShift + X.BitOr -> return Y.BitOr + X.BitXor -> return Y.BitXor + X.BitAnd -> return Y.BitAnd + X.Max -> return $ Y.Max2 Y.IntTy + X.Min -> return $ Y.Min2 Y.IntTy -runCmpOp :: X.CmpOp' -> Y.Builtin -runCmpOp (X.CmpOp' op t) = case op of - X.Lt -> Y.LessThan (runType t) - X.LtE -> Y.LessEqual (runType t) - X.Gt -> Y.GreaterThan (runType t) - X.GtE -> Y.GreaterEqual (runType t) - X.Eq' -> Y.Equal undefined -- TODO - X.NotEq -> Y.NotEqual undefined -- TODO - X.Is -> undefined -- TODO - X.IsNot -> undefined -- TODO - X.In -> undefined -- TODO - X.NotIn -> undefined -- TODO +runCmpOp :: X.CmpOp' -> Y.Expr +runCmpOp (X.CmpOp' op t) = + let t' = runType t + f = Y.Lit . Y.LitBuiltin + in case op of + X.Lt -> f $ Y.LessThan t' + X.LtE -> f $ Y.LessEqual t' + X.Gt -> f $ Y.GreaterThan t' + X.GtE -> f $ Y.GreaterEqual t' + X.Eq' -> f $ Y.Equal t' + X.NotEq -> f $ Y.NotEqual t' + X.Is -> f $ Y.Equal t' + X.IsNot -> f $ Y.NotEqual t' + X.In -> f $ Y.Elem t' + X.NotIn -> Y.Lam [("x", t'), ("xs", Y.ListTy t')] (Y.Not' (Y.Elem' t' (Y.Var "x") (Y.Var "xs"))) makeList2 :: a -> a -> [a] makeList2 x y = [x, y] @@ -129,9 +149,9 @@ makeList2 x y = [x, y] runExpr :: (MonadAlpha m, MonadError Error m) => X.Expr -> m Y.Expr runExpr = \case X.BoolOp e1 op e2 -> Y.AppBuiltin (runBoolOp op) <$> (makeList2 <$> runExpr e1 <*> runExpr e2) - X.BinOp e1 op e2 -> Y.AppBuiltin (runOperator op) <$> (makeList2 <$> runExpr e1 <*> runExpr e2) - X.UnaryOp op e -> Y.AppBuiltin (runUnaryOp op) . (: []) <$> runExpr e - X.Lambda _ _ -> undefined -- TODO + X.BinOp e1 op e2 -> Y.AppBuiltin <$> runOperator op <*> (makeList2 <$> runExpr e1 <*> runExpr e2) + X.UnaryOp op e -> Y.App (runUnaryOp op) . (: []) <$> runExpr e + X.Lambda args body -> Y.Lam (map (runVarName *** runType) args) <$> runExpr body X.IfExp e1 e2 e3 -> do e1 <- runExpr e1 e2 <- runExpr e2 @@ -139,9 +159,9 @@ runExpr = \case t <- Y.genType return $ Y.AppBuiltin (Y.If t) [e1, e2, e3] X.ListComp _ (X.Comprehension _ _ _) -> undefined -- TODO - X.Compare e1 op e2 -> Y.AppBuiltin (runCmpOp op) <$> (makeList2 <$> runExpr e1 <*> runExpr e2) + X.Compare e1 op e2 -> Y.App (runCmpOp op) <$> (makeList2 <$> runExpr e1 <*> runExpr e2) X.Call f args -> Y.App <$> runExpr f <*> mapM runExpr args - X.Constant const -> return $ runConstant const + X.Constant const -> runConstant const X.Subscript e1 e2 -> Y.AppBuiltin <$> (Y.At <$> Y.genType) <*> (makeList2 <$> runExpr e1 <*> runExpr e2) X.Name x -> return $ Y.Var (runVarName x) X.List _ _ -> undefined -- TODO @@ -164,7 +184,7 @@ runStatements (stmt : stmts) = case stmt of X.Assert _ -> runStatements stmts runToplevelStatements :: (MonadAlpha m, MonadError Error m) => [X.ToplevelStatement] -> m Y.ToplevelExpr -runToplevelStatements [] = return $ Y.ResultExpr (Y.Var (Y.VarName "solve")) +runToplevelStatements [] = return $ Y.ResultExpr (Y.Var "solve") runToplevelStatements (stmt : stmts) = case stmt of X.ToplevelAnnAssign _ _ _ -> undefined -- TODO X.ToplevelFunctionDef f args ret body -> Y.ToplevelLet Y.Rec (runVarName f) (map (runVarName *** runType) args) (runType ret) <$> runStatements body <*> runToplevelStatements stmts From ba7d405c04b1ad8b2e5dc3e750327357036de000 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Mon, 21 Jun 2021 07:51:53 +0900 Subject: [PATCH 16/56] refactor(core): Use Data.Vector instead of Data.Array --- src/Jikka/Core/Evaluate.hs | 66 +++++++++++++++----------------------- 1 file changed, 26 insertions(+), 40 deletions(-) diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index 6244ff4c..638e85d6 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -26,9 +26,9 @@ where import Control.Monad.Except import Control.Monad.State.Strict -import qualified Data.Array as A import Data.Bits import Data.List (sort) +import qualified Data.Vector as V import Jikka.Common.Error import Jikka.Core.Language.Expr import Jikka.Core.Language.Lint (builtinToType) @@ -40,7 +40,7 @@ import Text.Read (readEither) data Value = ValInt Integer | ValBool Bool - | ValList (A.Array Int Value) + | ValList (V.Vector Value) | ValTuple [Value] | ValBuiltin Builtin | ValLambda Env [(VarName, Type)] Expr @@ -57,16 +57,16 @@ valueToInt = \case ValInt n -> return n val -> throwRuntimeError $ "Internal Error: not int: " ++ show val -valueToIntList :: MonadError Error m => A.Array Int Value -> m [Integer] -valueToIntList = mapM valueToInt . A.elems +valueToIntList :: MonadError Error m => V.Vector Value -> m [Integer] +valueToIntList = mapM valueToInt . V.toList valueToBool :: MonadError Error m => Value -> m Bool valueToBool = \case ValBool p -> return p val -> throwRuntimeError $ "Internal Error: not bool: " ++ show val -valueToBoolList :: MonadError Error m => A.Array Int Value -> m [Bool] -valueToBoolList = mapM valueToBool . A.elems +valueToBoolList :: MonadError Error m => V.Vector Value -> m [Bool] +valueToBoolList = mapM valueToBool . V.toList -- ----------------------------------------------------------------------------- -- inputs @@ -112,8 +112,7 @@ readInput t tokens = case (t, tokens) of (ListTy t, token : tokens) -> do n <- readToken token (a, tokens) <- readInputList t n tokens - let a' = A.listArray (0, n - 1) a - return (ValList a', tokens) + return (ValList (V.fromList a), tokens) (TupleTy ts, _) -> do let readInput' :: MonadError Error m => Type -> StateT [Token] m Value readInput' t = StateT (readInput t) @@ -172,44 +171,31 @@ powmod :: MonadError Error m => Integer -> Integer -> Integer -> m Integer powmod _ _ m | m <= 0 = throwRuntimeError $ "invalid argument for powmod: MOD = " ++ show m powmod a b m = return $ (a ^ b) `mod` m -listToArray :: [a] -> A.Array Int a -listToArray xs = A.listArray (0, length xs) xs +tabulate :: MonadError Error m => Integer -> Value -> m (V.Vector Value) +tabulate n f = V.fromList <$> mapM (\i -> callValue f [ValInt i]) [0 .. n - 1] -lengthArray :: A.Array Int a -> Integer -lengthArray a = - let (l, r) = A.bounds a - in toInteger (r - l + 1) +map' :: MonadError Error m => Value -> V.Vector Value -> m (V.Vector Value) +map' f a = V.fromList <$> mapM (\val -> callValue f [val]) (V.toList a) -tabulate :: MonadError Error m => Integer -> Value -> m (A.Array Int Value) -tabulate n f = listToArray <$> mapM (\i -> callValue f [ValInt i]) [0 .. n - 1] +atEither :: MonadError Error m => V.Vector a -> Integer -> m a +atEither xs i = case xs V.!? fromInteger i of + Just x -> return x + Nothing -> throwRuntimeError $ "out of bounds: " ++ show (V.length xs, i) -map' :: MonadError Error m => Value -> A.Array Int Value -> m (A.Array Int Value) -map' f a = listToArray <$> mapM (\val -> callValue f [val]) (A.elems a) +sortVector :: Ord a => V.Vector a -> V.Vector a +sortVector = V.fromList . sort . V.toList -atEither :: MonadError Error m => A.Array Int a -> Integer -> m a -atEither a n = - let (l, r) = A.bounds a - in if toInteger l <= n && n <= toInteger r - then return (a A.! fromInteger n) - else throwRuntimeError $ "out of bounds: " ++ show (l, r, n) - -sortArray :: Ord a => A.Array Int a -> A.Array Int a -sortArray = listToArray . sort . A.elems - -reverseArray :: A.Array Int a -> A.Array Int a -reverseArray = listToArray . reverse . A.elems - -range1 :: MonadError Error m => Integer -> m (A.Array Int Value) +range1 :: MonadError Error m => Integer -> m (V.Vector Value) range1 n | n < 0 = throwRuntimeError $ "invalid argument for range1: " ++ show n -range1 n = return $ listToArray (map ValInt [0 .. n - 1]) +range1 n = return $ V.fromList (map ValInt [0 .. n - 1]) -range2 :: MonadError Error m => Integer -> Integer -> m (A.Array Int Value) +range2 :: MonadError Error m => Integer -> Integer -> m (V.Vector Value) range2 l r | l > r = throwRuntimeError $ "invalid argument for range2: " ++ show (l, r) -range2 l r = return $ listToArray (map ValInt [l .. r - 1]) +range2 l r = return $ V.fromList (map ValInt [l .. r - 1]) -range3 :: MonadError Error m => Integer -> Integer -> Integer -> m (A.Array Int Value) +range3 :: MonadError Error m => Integer -> Integer -> Integer -> m (V.Vector Value) range3 l r step | not (l <= r && step >= 0) = throwRuntimeError $ "invalid argument for range3: " ++ show (l, r, step) -range3 l r step = return $ listToArray (map ValInt [l, l + step .. r]) +range3 l r step = return $ V.fromList (map ValInt [l, l + step .. r]) fact :: MonadError Error m => Integer -> m Integer fact n | n < 0 = throwRuntimeError $ "invalid argument for fact: " ++ show n @@ -270,7 +256,7 @@ callBuiltin builtin args = case (builtin, args) of (ModInv, [ValInt a, ValInt b]) -> ValInt <$> inv a b (ModPow, [ValInt a, ValInt b, ValInt c]) -> ValInt <$> powmod a b c -- list functions - (Len _, [ValList a]) -> return $ ValInt (lengthArray a) + (Len _, [ValList a]) -> return $ ValInt (fromIntegral (V.length a)) (Tabulate _, [ValInt n, f]) -> ValList <$> tabulate n f (Map _ _, [f, ValList a]) -> ValList <$> map' f a (At _, [ValList a, ValInt n]) -> atEither a n @@ -282,9 +268,9 @@ callBuiltin builtin args = case (builtin, args) of (ArgMax IntTy, [ValList a]) -> ValInt <$> (argmaxEither =<< valueToIntList a) -- TODO: allow non-integers (All, [ValList a]) -> ValBool . and <$> valueToBoolList a (Any, [ValList a]) -> ValBool . or <$> valueToBoolList a - (Sorted _, [ValList a]) -> return $ ValList (sortArray a) + (Sorted _, [ValList a]) -> return $ ValList (sortVector a) (List _, [ValList a]) -> return $ ValList a - (Reversed _, [ValList a]) -> return $ ValList (reverseArray a) + (Reversed _, [ValList a]) -> return $ ValList (V.reverse a) (Range1, [ValInt n]) -> ValList <$> range1 n (Range2, [ValInt l, ValInt r]) -> ValList <$> range2 l r (Range3, [ValInt l, ValInt r, ValInt step]) -> ValList <$> range3 l r step From 3afc51b3cfb4cdd5a967c577c2e8eb9075eae7a5 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Mon, 21 Jun 2021 07:56:29 +0900 Subject: [PATCH 17/56] feat(core): Add constructors of lists and tuples --- src/Jikka/CPlusPlus/Convert/FromCore.hs | 11 +++++++---- src/Jikka/Core/Evaluate.hs | 5 +++++ src/Jikka/Core/Format.hs | 5 +++++ src/Jikka/Core/Language/BuiltinPatterns.hs | 7 +++++++ src/Jikka/Core/Language/Expr.hs | 18 +++++++++++++++--- src/Jikka/Core/Language/Lint.hs | 5 +++++ 6 files changed, 44 insertions(+), 7 deletions(-) diff --git a/src/Jikka/CPlusPlus/Convert/FromCore.hs b/src/Jikka/CPlusPlus/Convert/FromCore.hs index 8ea8aaf6..501309a8 100644 --- a/src/Jikka/CPlusPlus/Convert/FromCore.hs +++ b/src/Jikka/CPlusPlus/Convert/FromCore.hs @@ -62,11 +62,14 @@ runType = \case X.TupleTy ts -> Y.TyTuple <$> mapM runType ts t@X.FunTy {} -> throwInternalError $ "function type appears at invalid place: " ++ show t -runLiteral :: MonadError Error m => X.Literal -> m Y.Literal +runLiteral :: MonadError Error m => X.Literal -> m Y.Expr runLiteral = \case X.LitBuiltin builtin -> throwInternalError $ "cannot use builtin functaions as values: " ++ show builtin - X.LitInt n -> return $ Y.LitInt64 n - X.LitBool p -> return $ Y.LitBool p + X.LitInt n -> return $ Y.Lit (Y.LitInt64 n) + X.LitBool p -> return $ Y.Lit (Y.LitBool p) + X.LitNil t -> do + t <- runType t + return $ Y.Call (Y.Function "std::vector" [t]) [] runAppBuiltin :: MonadError Error m => X.Builtin -> [Y.Expr] -> m Y.Expr runAppBuiltin f args = case (f, args) of @@ -163,7 +166,7 @@ runAppBuiltin f args = case (f, args) of runExpr :: (MonadAlpha m, MonadError Error m) => Env -> X.Expr -> m Y.Expr runExpr env = \case X.Var x -> Y.Var <$> lookupVarName env x - X.Lit lit -> Y.Lit <$> runLiteral lit + X.Lit lit -> runLiteral lit X.App f args -> do args <- mapM (runExpr env) args case f of diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index 638e85d6..1c9dc366 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -51,6 +51,7 @@ literalToValue = \case LitBuiltin builtin -> ValBuiltin builtin LitInt n -> ValInt n LitBool p -> ValBool p + LitNil _ -> ValList V.empty valueToInt :: MonadError Error m => Value -> m Integer valueToInt = \case @@ -256,6 +257,7 @@ callBuiltin builtin args = case (builtin, args) of (ModInv, [ValInt a, ValInt b]) -> ValInt <$> inv a b (ModPow, [ValInt a, ValInt b, ValInt c]) -> ValInt <$> powmod a b c -- list functions + (Cons _, [x, ValList xs]) -> return $ ValList (V.cons x xs) (Len _, [ValList a]) -> return $ ValInt (fromIntegral (V.length a)) (Tabulate _, [ValInt n, f]) -> ValList <$> tabulate n f (Map _ _, [f, ValList a]) -> ValList <$> map' f a @@ -274,6 +276,9 @@ callBuiltin builtin args = case (builtin, args) of (Range1, [ValInt n]) -> ValList <$> range1 n (Range2, [ValInt l, ValInt r]) -> ValList <$> range2 l r (Range3, [ValInt l, ValInt r, ValInt step]) -> ValList <$> range3 l r step + -- tuple functions + (Tuple _, xs) -> return $ ValTuple xs + (Proj _ n, [ValTuple xs]) -> return $ xs !! n -- comparison (LessThan IntTy, [ValInt a, ValInt b]) -> return $ ValBool (a < b) -- TODO: allow non-integers (LessEqual IntTy, [ValInt a, ValInt b]) -> return $ ValBool (a <= b) -- TODO: allow non-integers diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index 789b9113..7de13b0d 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -84,6 +84,7 @@ analyzeBuiltin = \case ModInv -> fun "modinv" ModPow -> fun "modpow" -- list functions + Cons t -> Fun [t] "cons" Len t -> Fun [t] "len" Tabulate t -> Fun [t] "tabulate" Map t1 t2 -> Fun [t1, t2] "map" @@ -103,6 +104,9 @@ analyzeBuiltin = \case Range1 -> fun "range1" Range2 -> fun "range2" Range3 -> fun "range3" + -- tuple functions + Tuple ts -> Fun ts "tuple" + Proj ts n -> Fun ts ("proj" ++ show n) -- comparison LessThan t -> InfixOp [t] "<" LessEqual t -> InfixOp [t] "<=" @@ -146,6 +150,7 @@ formatLiteral = \case LitBuiltin builtin -> formatBuiltinIsolated (analyzeBuiltin builtin) LitInt n -> show n LitBool p -> show p + LitNil t -> "nil" ++ formatTemplate [t] formatFormalArgs :: [(VarName, Type)] -> String formatFormalArgs args = unwords $ map (\(x, t) -> paren (unVarName x ++ ": " ++ formatType t)) args diff --git a/src/Jikka/Core/Language/BuiltinPatterns.hs b/src/Jikka/Core/Language/BuiltinPatterns.hs index 937838c7..032e88b4 100644 --- a/src/Jikka/Core/Language/BuiltinPatterns.hs +++ b/src/Jikka/Core/Language/BuiltinPatterns.hs @@ -78,6 +78,8 @@ pattern ModInv' e1 e2 = AppBuiltin ModInv [e1, e2] pattern ModPow' e1 e2 e3 = AppBuiltin ModPow [e1, e2, e3] -- list functions +pattern Cons' t e1 e2 = AppBuiltin (Cons t) [e1, e2] + pattern Len' t e = AppBuiltin (Len t) [e] pattern Tabulate' t n f = AppBuiltin (Tabulate t) [n, f] @@ -116,6 +118,11 @@ pattern Range2' e1 e2 = AppBuiltin Range2 [e1, e2] pattern Range3' e1 e2 e3 = AppBuiltin Range3 [e1, e2, e3] +-- tuple functions +pattern Tuple' ts es = AppBuiltin (Tuple ts) es + +pattern Proj' ts n es = AppBuiltin (Proj ts n) es + -- arithmetical relations pattern LessThan' t e1 e2 = AppBuiltin (LessThan t) [e1, e2] diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index 7b38fb9d..c93e4240 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -54,6 +54,7 @@ data Type FunTy [Type] Type deriving (Eq, Ord, Show, Read) +-- | TODO: What is the difference between `Literal` and `Builtin`? data Builtin = -- arithmetical functions @@ -126,7 +127,8 @@ data Builtin | -- list functions -- | \(: \forall \alpha. \list(\alpha) \to \int\) - Len Type + Cons Type + | Len Type | -- | \(: \forall \alpha. \int \times (\int \to \alpha) \to \list(\alpha)\) Tabulate Type | -- | \(: \forall \alpha \beta. (\alpha \to \beta) \times \list(\alpha) \to \list(\beta)\) @@ -163,6 +165,12 @@ data Builtin Range2 | -- | \(: \int \times \int \times \int \to \list(\int)\)1 Range3 + | -- tuple functions + + -- | \(: \forall \alpha_0 \alpha_1 \dots \alpha _ {n - 1}. \alpha_0 \times \dots \times \alpha _ {n - 1} \to \alpha_0 \times \dots \times \alpha _ {n - 1}\) + Tuple [Type] + | -- | \(: \forall \alpha_0 \alpha_1 \dots \alpha _ {n - 1}. \alpha_0 \times \dots \times \alpha _ {n - 1} \to \alpha_i\) + Proj [Type] Int | -- comparison -- | \(: \forall \alpha. \alpha \times \alpha \to \alpha\) @@ -191,8 +199,12 @@ data Builtin data Literal = LitBuiltin Builtin - | LitInt Integer - | LitBool Bool + | -- | \(: \forall \alpha. \int\) + LitInt Integer + | -- | \(: \forall \alpha. \bool\) + LitBool Bool + | -- | \(: \forall \alpha. \list(\alpha)\) + LitNil Type deriving (Eq, Ord, Show, Read) -- | `Expr` represents the exprs of our core language. This is similar to the `Expr` of GHC Core. diff --git a/src/Jikka/Core/Language/Lint.hs b/src/Jikka/Core/Language/Lint.hs index fa183668..e2e2ce7f 100644 --- a/src/Jikka/Core/Language/Lint.hs +++ b/src/Jikka/Core/Language/Lint.hs @@ -53,6 +53,7 @@ builtinToType = \case ModInv -> Fun2Ty IntTy ModPow -> Fun3Ty IntTy -- list functions + Cons t -> FunTy [t, ListTy t] (ListTy t) Len t -> FunTy [ListTy t] IntTy Tabulate t -> FunTy [IntTy, FunTy [IntTy] t] (ListTy t) Map t1 t2 -> FunTy [FunTy [t1] t2, ListTy t1] (ListTy t2) @@ -72,6 +73,9 @@ builtinToType = \case Range1 -> FunTy [IntTy] (ListTy IntTy) Range2 -> FunTy [IntTy, IntTy] (ListTy IntTy) Range3 -> FunTy [IntTy, IntTy, IntTy] (ListTy IntTy) + -- tuple functions + Tuple ts -> FunTy ts (TupleTy ts) + Proj ts n -> FunTy [TupleTy ts] (ts !! n) -- comparison LessThan t -> FunTy [t, t] BoolTy LessEqual t -> FunTy [t, t] BoolTy @@ -90,6 +94,7 @@ literalToType = \case LitBuiltin builtin -> builtinToType builtin LitInt _ -> IntTy LitBool _ -> BoolTy + LitNil t -> ListTy t type TypeEnv = [(VarName, Type)] From ea52e853d0b03b5d60573a70a2ed31fdf04587aa Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Mon, 21 Jun 2021 08:38:46 +0900 Subject: [PATCH 18/56] feat(core): Add "filter" as a new builtin --- src/Jikka/Core/Format.hs | 1 + src/Jikka/Core/Language/BuiltinPatterns.hs | 2 ++ src/Jikka/Core/Language/Expr.hs | 2 ++ src/Jikka/Core/Language/Lint.hs | 1 + 4 files changed, 6 insertions(+) diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index 7de13b0d..74e76fa7 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -88,6 +88,7 @@ analyzeBuiltin = \case Len t -> Fun [t] "len" Tabulate t -> Fun [t] "tabulate" Map t1 t2 -> Fun [t1, t2] "map" + Filter t -> Fun [t] "filter" At t -> At' t Elem t -> Fun [t] "elem" Sum -> fun "sum" diff --git a/src/Jikka/Core/Language/BuiltinPatterns.hs b/src/Jikka/Core/Language/BuiltinPatterns.hs index 032e88b4..ddb095b1 100644 --- a/src/Jikka/Core/Language/BuiltinPatterns.hs +++ b/src/Jikka/Core/Language/BuiltinPatterns.hs @@ -86,6 +86,8 @@ pattern Tabulate' t n f = AppBuiltin (Tabulate t) [n, f] pattern Map' t1 t2 f e = AppBuiltin (Map t1 t2) [f, e] +pattern Filter' t f e = AppBuiltin (Filter t) [f, e] + pattern At' t e1 e2 = AppBuiltin (At t) [e1, e2] pattern Elem' t e1 e2 = AppBuiltin (Elem t) [e1, e2] diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index c93e4240..da688ab3 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -133,6 +133,8 @@ data Builtin Tabulate Type | -- | \(: \forall \alpha \beta. (\alpha \to \beta) \times \list(\alpha) \to \list(\beta)\) Map Type Type + | -- | \(: \forall \alpha \beta. (\alpha \to \bool) \times \list(\alpha) \to \list(\beta)\) + Filter Type | -- | \(: \forall \alpha. \list(\alpha) \times \int \to \alpha\) At Type | -- | \(: \forall \alpha. \alpha \times \list(\alpha) \to \bool\) diff --git a/src/Jikka/Core/Language/Lint.hs b/src/Jikka/Core/Language/Lint.hs index e2e2ce7f..8fffa505 100644 --- a/src/Jikka/Core/Language/Lint.hs +++ b/src/Jikka/Core/Language/Lint.hs @@ -57,6 +57,7 @@ builtinToType = \case Len t -> FunTy [ListTy t] IntTy Tabulate t -> FunTy [IntTy, FunTy [IntTy] t] (ListTy t) Map t1 t2 -> FunTy [FunTy [t1] t2, ListTy t1] (ListTy t2) + Filter t -> FunTy [FunTy [t] BoolTy, ListTy t] (ListTy t) At t -> FunTy [ListTy t, IntTy] t Elem t -> FunTy [t, ListTy t] BoolTy Sum -> FunLTy IntTy From 2ffc303982604f4090fbdb42568ae67f2cad3cb8 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Mon, 21 Jun 2021 08:39:21 +0900 Subject: [PATCH 19/56] feat(rpython): Update src/Jikka/RestrictedPython/Convert/ToCore.hs --- src/Jikka/RestrictedPython/Convert/ToCore.hs | 57 ++++++++++++++------ 1 file changed, 40 insertions(+), 17 deletions(-) diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 0c58ddcb..f90a0ae0 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -31,7 +31,7 @@ runType = \case runConstant :: MonadError Error m => X.Constant -> m Y.Expr runConstant = \case - X.ConstNone -> undefined -- TODO + X.ConstNone -> return $ Y.Tuple' [] [] X.ConstInt n -> return $ Y.Lit (Y.LitInt n) X.ConstBool p -> return $ Y.Lit (Y.LitBool p) X.ConstBuiltin builtin -> runBuiltin builtin @@ -43,24 +43,33 @@ runBuiltin builtin = X.BuiltinAbs -> f Y.Abs X.BuiltinPow -> f Y.Pow X.BuiltinModPow -> f Y.ModPow - X.BuiltinDivMod -> undefined -- TODO + X.BuiltinDivMod -> return $ Y.Lam [("a", Y.IntTy), ("b", Y.IntTy)] (Y.Tuple' [Y.IntTy, Y.IntTy] [Y.FloorDiv' (Y.Var "a") (Y.Var "b"), Y.FloorMod' (Y.Var "a") (Y.Var "b")]) X.BuiltinCeilDiv -> f Y.CeilDiv X.BuiltinCeilMod -> f Y.CeilMod X.BuiltinFloorDiv -> f Y.FloorDiv X.BuiltinFloorMod -> f Y.FloorMod X.BuiltinGcd -> f Y.Gcd X.BuiltinLcm -> f Y.Lcm - X.BuiltinInt _ -> undefined -- TODO - X.BuiltinBool _ -> undefined -- TODO - X.BuiltinList _ -> undefined -- TODO - X.BuiltinTuple _ -> undefined -- TODO + X.BuiltinInt t -> case t of + X.IntTy -> return $ Y.Lam [("x", Y.IntTy)] (Y.Var "x") + X.BoolTy -> return $ Y.Lam [("p", Y.BoolTy)] (Y.If' Y.IntTy (Y.Var "p") Y.Lit1 Y.Lit0) + _ -> throwTypeError "the argument of int must be int or bool" + X.BuiltinBool t -> case t of + X.IntTy -> return $ Y.Lam [("x", Y.IntTy)] (Y.If' Y.BoolTy (Y.Equal' Y.IntTy (Y.Var "x") Y.Lit0) Y.LitFalse Y.LitTrue) + X.BoolTy -> return $ Y.Lam [("p", Y.BoolTy)] (Y.Var "p") + X.ListTy t -> + let t' = runType t + in return $ Y.Lam [("xs", Y.ListTy t')] (Y.If' Y.BoolTy (Y.Equal' (Y.ListTy t') (Y.Var "xs") (Y.Lit (Y.LitNil t'))) Y.LitFalse Y.LitTrue) + _ -> throwTypeError "the argument of bool must be bool, int, or list(a)" + X.BuiltinList t -> return $ Y.Lam [("xs", Y.ListTy (runType t))] (Y.Var "xs") + X.BuiltinTuple ts -> f $ Y.Tuple (map runType ts) X.BuiltinLen t -> f $ Y.Len (runType t) - X.BuiltinMap _ _ -> undefined -- TODO + X.BuiltinMap _ _ -> throwInternalError "runBuiltin TODO" X.BuiltinSorted t -> f $ Y.Sorted (runType t) X.BuiltinReversed t -> f $ Y.Reversed (runType t) - X.BuiltinEnumerate _ -> undefined -- TODO - X.BuiltinFilter _ -> undefined -- TODO - X.BuiltinZip _ -> undefined -- TODO + X.BuiltinEnumerate _ -> throwInternalError "runBuiltin TODO" + X.BuiltinFilter _ -> throwInternalError "runBuiltin TODO" + X.BuiltinZip _ -> throwInternalError "runBuiltin TODO" X.BuiltinAll -> f Y.All X.BuiltinAny -> f Y.Any X.BuiltinSum -> f Y.Sum @@ -146,6 +155,9 @@ runCmpOp (X.CmpOp' op t) = makeList2 :: a -> a -> [a] makeList2 x y = [x, y] +runListComp :: (MonadAlpha m, MonadError Error m) => X.Expr -> X.Comprehension -> m Y.Expr +runListComp _ (X.Comprehension _ _ _) = undefined -- TODO + runExpr :: (MonadAlpha m, MonadError Error m) => X.Expr -> m Y.Expr runExpr = \case X.BoolOp e1 op e2 -> Y.AppBuiltin (runBoolOp op) <$> (makeList2 <$> runExpr e1 <*> runExpr e2) @@ -158,23 +170,34 @@ runExpr = \case e3 <- runExpr e3 t <- Y.genType return $ Y.AppBuiltin (Y.If t) [e1, e2, e3] - X.ListComp _ (X.Comprehension _ _ _) -> undefined -- TODO + X.ListComp x comp -> runListComp x comp X.Compare e1 op e2 -> Y.App (runCmpOp op) <$> (makeList2 <$> runExpr e1 <*> runExpr e2) X.Call f args -> Y.App <$> runExpr f <*> mapM runExpr args X.Constant const -> runConstant const X.Subscript e1 e2 -> Y.AppBuiltin <$> (Y.At <$> Y.genType) <*> (makeList2 <$> runExpr e1 <*> runExpr e2) X.Name x -> return $ Y.Var (runVarName x) - X.List _ _ -> undefined -- TODO - X.Tuple _ -> undefined -- TODO - X.SubscriptSlice _ _ _ _ -> undefined -- TODO + X.List t es -> do + let t' = runType t + foldr (Y.Cons' t') (Y.Lit (Y.LitNil t')) <$> mapM runExpr es + X.Tuple es -> Y.Tuple' <$> mapM (const Y.genType) es <*> mapM runExpr es + X.SubscriptSlice _ _ _ _ -> throwInternalError "runExpr TODO" + +runAugAssign :: (MonadAlpha m, MonadError Error m) => X.Target -> X.Operator -> X.Expr -> m Y.Expr +runAugAssign = undefined -- TODO + +runAnnAssign :: (MonadAlpha m, MonadError Error m) => X.Target -> X.Type -> X.Expr -> m Y.Expr +runAnnAssign = undefined -- TODO + +runForStatement :: (MonadAlpha m, MonadError Error m) => X.Target -> X.Expr -> [X.Statement] -> m Y.Expr +runForStatement = undefined -- TODO runStatements :: (MonadAlpha m, MonadError Error m) => [X.Statement] -> m Y.Expr runStatements [] = throwSemanticError "function may not return" runStatements (stmt : stmts) = case stmt of X.Return e -> runExpr e - X.AugAssign _ _ _ -> undefined -- TODO - X.AnnAssign _ _ _ -> undefined -- TODO - X.For _ _ _ -> undefined -- TODO + X.AugAssign x op e -> runAugAssign x op e + X.AnnAssign x t e -> runAnnAssign x t e + X.For x iter body -> runForStatement x iter body X.If e body1 body2 -> do e <- runExpr e body1 <- runStatements (body1 ++ stmts) From b6b59dcc59097680ca666027a937389ceb6ca51c Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Tue, 22 Jun 2021 09:03:36 +0900 Subject: [PATCH 20/56] feat(core): Add a new builtin SetAt --- src/Jikka/Core/Format.hs | 1 + src/Jikka/Core/Language/BuiltinPatterns.hs | 2 ++ src/Jikka/Core/Language/Expr.hs | 2 ++ src/Jikka/Core/Language/Lint.hs | 1 + 4 files changed, 6 insertions(+) diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index 74e76fa7..19f9e70b 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -90,6 +90,7 @@ analyzeBuiltin = \case Map t1 t2 -> Fun [t1, t2] "map" Filter t -> Fun [t] "filter" At t -> At' t + SetAt t -> Fun [t] "setAt" Elem t -> Fun [t] "elem" Sum -> fun "sum" Product -> fun "product" diff --git a/src/Jikka/Core/Language/BuiltinPatterns.hs b/src/Jikka/Core/Language/BuiltinPatterns.hs index ddb095b1..f5bbf5f1 100644 --- a/src/Jikka/Core/Language/BuiltinPatterns.hs +++ b/src/Jikka/Core/Language/BuiltinPatterns.hs @@ -90,6 +90,8 @@ pattern Filter' t f e = AppBuiltin (Filter t) [f, e] pattern At' t e1 e2 = AppBuiltin (At t) [e1, e2] +pattern SetAt' t e1 e2 e3 = AppBuiltin (SetAt t) [e1, e2, e3] + pattern Elem' t e1 e2 = AppBuiltin (Elem t) [e1, e2] pattern Sum' e = AppBuiltin Sum [e] diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index da688ab3..1806ae9c 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -137,6 +137,8 @@ data Builtin Filter Type | -- | \(: \forall \alpha. \list(\alpha) \times \int \to \alpha\) At Type + | -- | \(: \forall \alpha. \list(alpha) \times \int \times \alpha \to \list(\alpha)\) + SetAt Type | -- | \(: \forall \alpha. \alpha \times \list(\alpha) \to \bool\) Elem Type | -- | \(: \list(\int) \to \int\) diff --git a/src/Jikka/Core/Language/Lint.hs b/src/Jikka/Core/Language/Lint.hs index 8fffa505..dd0352c6 100644 --- a/src/Jikka/Core/Language/Lint.hs +++ b/src/Jikka/Core/Language/Lint.hs @@ -59,6 +59,7 @@ builtinToType = \case Map t1 t2 -> FunTy [FunTy [t1] t2, ListTy t1] (ListTy t2) Filter t -> FunTy [FunTy [t] BoolTy, ListTy t] (ListTy t) At t -> FunTy [ListTy t, IntTy] t + SetAt t -> FunTy [ListTy t, IntTy, t] (ListTy t) Elem t -> FunTy [t, ListTy t] BoolTy Sum -> FunLTy IntTy Product -> FunLTy IntTy From 968c5df84341b717f6857b3456085539b1307ca8 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Tue, 22 Jun 2021 09:20:35 +0900 Subject: [PATCH 21/56] fix(core): Fix Proj' --- src/Jikka/Core/Language/BuiltinPatterns.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Jikka/Core/Language/BuiltinPatterns.hs b/src/Jikka/Core/Language/BuiltinPatterns.hs index f5bbf5f1..5a178772 100644 --- a/src/Jikka/Core/Language/BuiltinPatterns.hs +++ b/src/Jikka/Core/Language/BuiltinPatterns.hs @@ -125,7 +125,7 @@ pattern Range3' e1 e2 e3 = AppBuiltin Range3 [e1, e2, e3] -- tuple functions pattern Tuple' ts es = AppBuiltin (Tuple ts) es -pattern Proj' ts n es = AppBuiltin (Proj ts n) es +pattern Proj' ts n e = AppBuiltin (Proj ts n) [e] -- arithmetical relations pattern LessThan' t e1 e2 = AppBuiltin (LessThan t) [e1, e2] From 08bab1241f67b3b2fb95431e0612a9c083a56df9 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Tue, 22 Jun 2021 09:41:05 +0900 Subject: [PATCH 22/56] feat(rpython): Update src/Jikka/RestrictedPython/Convert/ToCore.hs --- src/Jikka/Core/Language/Util.hs | 3 ++ src/Jikka/RestrictedPython/Convert/ToCore.hs | 37 +++++++++++++++----- 2 files changed, 31 insertions(+), 9 deletions(-) diff --git a/src/Jikka/Core/Language/Util.hs b/src/Jikka/Core/Language/Util.hs index cb808a75..bf47e860 100644 --- a/src/Jikka/Core/Language/Util.hs +++ b/src/Jikka/Core/Language/Util.hs @@ -13,3 +13,6 @@ genVarName x = do i <- nextCounter let base = if unVarName x == "_" then "" else takeWhile (/= '$') (unVarName x) return $ VarName (base ++ '$' : show i) + +genVarName' :: MonadAlpha m => m VarName +genVarName' = genVarName (VarName "_") diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index f90a0ae0..15c95e2e 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -155,8 +155,33 @@ runCmpOp (X.CmpOp' op t) = makeList2 :: a -> a -> [a] makeList2 x y = [x, y] +runTargetExpr :: (MonadAlpha m, MonadError Error m) => X.Target -> m Y.Expr +runTargetExpr = \case + X.SubscriptTrg x e -> Y.At' <$> Y.genType <*> runTargetExpr x <*> runExpr e + X.NameTrg x -> return $ Y.Var (runVarName x) + X.TupleTrg xs -> Y.Tuple' <$> replicateM (length xs) Y.genType <*> mapM runTargetExpr xs + +runAssign :: (MonadAlpha m, MonadError Error m) => X.Target -> Y.Expr -> Y.Expr -> m Y.Expr +runAssign x e cont = case x of + X.SubscriptTrg x index -> join $ runAssign x <$> (Y.SetAt' <$> Y.genType <*> runTargetExpr x <*> runExpr index <*> pure e) <*> pure cont + X.NameTrg x -> Y.Let (runVarName x) <$> Y.genType <*> pure e <*> pure cont + X.TupleTrg xs -> do + y <- Y.genVarName' + ts <- replicateM (length xs) Y.genType + cont <- foldM (\cont (i, x) -> runAssign x (Y.Proj' ts i (Y.Var y)) cont) cont (zip [0 ..] xs) + return $ Y.Let y (Y.TupleTy ts) e cont + runListComp :: (MonadAlpha m, MonadError Error m) => X.Expr -> X.Comprehension -> m Y.Expr -runListComp _ (X.Comprehension _ _ _) = undefined -- TODO +runListComp e (X.Comprehension x iter pred) = do + iter <- runExpr iter + iter <- case pred of + Nothing -> return iter + Just pred -> Y.Filter' <$> Y.genType <*> runExpr pred <*> pure iter + y <- Y.genVarName' + t1 <- Y.genType + t2 <- Y.genType + e <- runExpr e + Y.Map' t1 t2 <$> (Y.Lam [(y, t1)] <$> runAssign x (Y.Var y) e) <*> pure iter runExpr :: (MonadAlpha m, MonadError Error m) => X.Expr -> m Y.Expr runExpr = \case @@ -182,12 +207,6 @@ runExpr = \case X.Tuple es -> Y.Tuple' <$> mapM (const Y.genType) es <*> mapM runExpr es X.SubscriptSlice _ _ _ _ -> throwInternalError "runExpr TODO" -runAugAssign :: (MonadAlpha m, MonadError Error m) => X.Target -> X.Operator -> X.Expr -> m Y.Expr -runAugAssign = undefined -- TODO - -runAnnAssign :: (MonadAlpha m, MonadError Error m) => X.Target -> X.Type -> X.Expr -> m Y.Expr -runAnnAssign = undefined -- TODO - runForStatement :: (MonadAlpha m, MonadError Error m) => X.Target -> X.Expr -> [X.Statement] -> m Y.Expr runForStatement = undefined -- TODO @@ -195,8 +214,8 @@ runStatements :: (MonadAlpha m, MonadError Error m) => [X.Statement] -> m Y.Expr runStatements [] = throwSemanticError "function may not return" runStatements (stmt : stmts) = case stmt of X.Return e -> runExpr e - X.AugAssign x op e -> runAugAssign x op e - X.AnnAssign x t e -> runAnnAssign x t e + X.AugAssign x op e -> join $ runAssign x <$> (Y.App <$> (Y.Lit . Y.LitBuiltin <$> runOperator op) <*> (makeList2 <$> runTargetExpr x <*> runExpr e)) <*> runStatements stmts + X.AnnAssign x _ e -> join $ runAssign x <$> runExpr e <*> runStatements stmts X.For x iter body -> runForStatement x iter body X.If e body1 body2 -> do e <- runExpr e From f880bf353a7295208204d8ff33e8bb2f086c829c Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 01:26:27 +0900 Subject: [PATCH 23/56] fix(core): Fix documentation of Expr --- src/Jikka/Core/Language/Expr.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index 1806ae9c..cb0befac 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -126,9 +126,10 @@ data Builtin ModPow | -- list functions - -- | \(: \forall \alpha. \list(\alpha) \to \int\) + -- | \(: \forall \alpha. \alpha \times \list(\alpha) \to \list(\alpha)\) Cons Type - | Len Type + | -- | \(: \forall \alpha. \list(\alpha) \to \int\) + Len Type | -- | \(: \forall \alpha. \int \times (\int \to \alpha) \to \list(\alpha)\) Tabulate Type | -- | \(: \forall \alpha \beta. (\alpha \to \beta) \times \list(\alpha) \to \list(\beta)\) From 617378f321265c4affd046a5dca9f44b86fe4e17 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 01:37:39 +0900 Subject: [PATCH 24/56] feat(core): Add new builtins Foldl and Scanl --- src/Jikka/Core/Format.hs | 2 ++ src/Jikka/Core/Language/BuiltinPatterns.hs | 4 ++++ src/Jikka/Core/Language/Expr.hs | 4 ++++ src/Jikka/Core/Language/Lint.hs | 2 ++ 4 files changed, 12 insertions(+) diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index 19f9e70b..7e1f756b 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -85,6 +85,8 @@ analyzeBuiltin = \case ModPow -> fun "modpow" -- list functions Cons t -> Fun [t] "cons" + Foldl t1 t2 -> Fun [t1, t2] "foldl" + Scanl t1 t2 -> Fun [t1, t2] "scanl" Len t -> Fun [t] "len" Tabulate t -> Fun [t] "tabulate" Map t1 t2 -> Fun [t1, t2] "map" diff --git a/src/Jikka/Core/Language/BuiltinPatterns.hs b/src/Jikka/Core/Language/BuiltinPatterns.hs index 5a178772..88bdee1f 100644 --- a/src/Jikka/Core/Language/BuiltinPatterns.hs +++ b/src/Jikka/Core/Language/BuiltinPatterns.hs @@ -80,6 +80,10 @@ pattern ModPow' e1 e2 e3 = AppBuiltin ModPow [e1, e2, e3] -- list functions pattern Cons' t e1 e2 = AppBuiltin (Cons t) [e1, e2] +pattern Foldl' t1 t2 e1 e2 e3 = AppBuiltin (Foldl t1 t2) [e1, e2, e3] + +pattern Scanl' t1 t2 e1 e2 e3 = AppBuiltin (Scanl t1 t2) [e1, e2, e3] + pattern Len' t e = AppBuiltin (Len t) [e] pattern Tabulate' t n f = AppBuiltin (Tabulate t) [n, f] diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index cb0befac..454487ab 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -128,6 +128,10 @@ data Builtin -- | \(: \forall \alpha. \alpha \times \list(\alpha) \to \list(\alpha)\) Cons Type + | -- | \(: \foall \alpha \beta. (\beta \times \alpha \to \beta) \times \beta \times \list(\alpha) \to \beta\) + Foldl Type Type + | -- | \(: \foall \alpha \beta. (\beta \times \alpha \to \beta) \times \beta \times \list(\alpha) \to \list(\beta)\) + Scanl Type Type | -- | \(: \forall \alpha. \list(\alpha) \to \int\) Len Type | -- | \(: \forall \alpha. \int \times (\int \to \alpha) \to \list(\alpha)\) diff --git a/src/Jikka/Core/Language/Lint.hs b/src/Jikka/Core/Language/Lint.hs index dd0352c6..007986b3 100644 --- a/src/Jikka/Core/Language/Lint.hs +++ b/src/Jikka/Core/Language/Lint.hs @@ -54,6 +54,8 @@ builtinToType = \case ModPow -> Fun3Ty IntTy -- list functions Cons t -> FunTy [t, ListTy t] (ListTy t) + Foldl t1 t2 -> FunTy [FunTy [t2, t1] t2, t2, ListTy t1] t2 + Scanl t1 t2 -> FunTy [FunTy [t2, t1] t2, t2, ListTy t1] (ListTy t2) Len t -> FunTy [ListTy t] IntTy Tabulate t -> FunTy [IntTy, FunTy [IntTy] t] (ListTy t) Map t1 t2 -> FunTy [FunTy [t1] t2, ListTy t1] (ListTy t2) From 6bbb13990b070b3dca5418196d29f381c6e24746 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 02:09:27 +0900 Subject: [PATCH 25/56] feat(core): Split ToplevelLet and ToplevelLetRec --- src/Jikka/CPlusPlus/Convert/FromCore.hs | 12 ++++++----- src/Jikka/Core/Convert/ANormal.hs | 12 ++++++----- src/Jikka/Core/Convert/Alpha.hs | 13 +++++++----- src/Jikka/Core/Convert/MakeEager.hs | 3 ++- src/Jikka/Core/Convert/RemoveUnusedVars.hs | 12 +++++------ src/Jikka/Core/Convert/StrengthReduction.hs | 3 ++- src/Jikka/Core/Evaluate.hs | 9 ++++---- src/Jikka/Core/Format.hs | 21 +++++++------------ src/Jikka/Core/Language/Expr.hs | 16 ++++++++------ src/Jikka/Core/Language/Lint.hs | 12 ++++++----- src/Jikka/RestrictedPython/Convert/ToCore.hs | 2 +- test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs | 3 +-- .../Core/Convert/RemoveUnusedVarsSpec.hs | 9 +++----- test/Jikka/Core/EvaluateSpec.hs | 6 ++---- test/Jikka/Core/FormatSpec.hs | 3 +-- 15 files changed, 70 insertions(+), 66 deletions(-) diff --git a/src/Jikka/CPlusPlus/Convert/FromCore.hs b/src/Jikka/CPlusPlus/Convert/FromCore.hs index 501309a8..54901ac8 100644 --- a/src/Jikka/CPlusPlus/Convert/FromCore.hs +++ b/src/Jikka/CPlusPlus/Convert/FromCore.hs @@ -238,13 +238,15 @@ runToplevelExpr env = \case let body = [Y.Return (Y.Call (Y.Callable e) (map (Y.Var . snd) args))] return [Y.FunDef ret f args body] _ -> runToplevelVarDef env (Y.VarName "ans") t e - X.ToplevelLet rec f args ret body cont -> do + X.ToplevelLet x t e cont -> do + y <- renameVarName "c" x + stmt <- runToplevelVarDef env y t e + cont <- runToplevelExpr ((x, t, y) : env) cont + return $ stmt ++ cont + X.ToplevelLetRec f args ret body cont -> do g <- renameVarName "f" f let t = X.FunTy (map snd args) ret - stmt <- case (rec, args) of - (X.NonRec, []) -> runToplevelVarDef env g ret body - (X.NonRec, _) -> runToplevelFunDef env g args ret body - (X.Rec, _) -> runToplevelFunDef ((f, t, g) : env) g args ret body + stmt <- runToplevelFunDef ((f, t, g) : env) g args ret body cont <- runToplevelExpr ((f, t, g) : env) cont return $ stmt ++ cont diff --git a/src/Jikka/Core/Convert/ANormal.hs b/src/Jikka/Core/Convert/ANormal.hs index 49847589..f52a0052 100644 --- a/src/Jikka/Core/Convert/ANormal.hs +++ b/src/Jikka/Core/Convert/ANormal.hs @@ -72,13 +72,15 @@ runExpr env = \case runToplevelExpr :: (MonadAlpha m, MonadError Error m) => TypeEnv -> ToplevelExpr -> m ToplevelExpr runToplevelExpr env = \case ResultExpr e -> ResultExpr <$> runExpr env e - ToplevelLet rec f args ret body cont -> do + ToplevelLet x t e cont -> do + e <- runExpr env e + cont <- runToplevelExpr ((x, t) : env) cont + return $ ToplevelLet x t e cont + ToplevelLetRec f args ret body cont -> do let t = FunTy (map snd args) ret - body <- case rec of - NonRec -> runExpr (reverse args ++ env) body - Rec -> runExpr (reverse args ++ (f, t) : env) body + body <- runExpr (reverse args ++ (f, t) : env) body cont <- runToplevelExpr ((f, t) : env) cont - return $ ToplevelLet rec f args ret body cont + return $ ToplevelLetRec f args ret body cont run :: (MonadAlpha m, MonadError Error m) => Program -> m Program run prog = do diff --git a/src/Jikka/Core/Convert/Alpha.hs b/src/Jikka/Core/Convert/Alpha.hs index b870ae19..9223f331 100644 --- a/src/Jikka/Core/Convert/Alpha.hs +++ b/src/Jikka/Core/Convert/Alpha.hs @@ -57,18 +57,21 @@ runExpr env = \case runToplevelExpr :: (MonadAlpha m, MonadError Error m) => [(VarName, VarName)] -> ToplevelExpr -> m ToplevelExpr runToplevelExpr env = \case ResultExpr e -> ResultExpr <$> runExpr env e - ToplevelLet rec f args ret body cont -> do + ToplevelLet x t e cont -> do + y <- rename x + e <- runExpr env e + cont <- runToplevelExpr ((x, y) : env) cont + return $ ToplevelLet y t e cont + ToplevelLetRec f args ret body cont -> do g <- rename f args <- forM args $ \(x, t) -> do y <- rename x return (x, y, t) let args1 = map (\(x, y, _) -> (x, y)) args let args2 = map (\(_, y, t) -> (y, t)) args - body <- case rec of - NonRec -> runExpr (args1 ++ env) body - Rec -> runExpr (args1 ++ (f, g) : env) body + body <- runExpr (args1 ++ (f, g) : env) body cont <- runToplevelExpr ((f, g) : env) cont - return $ ToplevelLet rec g args2 ret body cont + return $ ToplevelLetRec g args2 ret body cont runProgram :: (MonadAlpha m, MonadError Error m) => Program -> m Program runProgram = runToplevelExpr [] diff --git a/src/Jikka/Core/Convert/MakeEager.hs b/src/Jikka/Core/Convert/MakeEager.hs index 30e64450..5bd9f7ce 100644 --- a/src/Jikka/Core/Convert/MakeEager.hs +++ b/src/Jikka/Core/Convert/MakeEager.hs @@ -34,7 +34,8 @@ makeEagerExpr = \case makeEagerToplevelExpr :: ToplevelExpr -> ToplevelExpr makeEagerToplevelExpr e = case e of ResultExpr e -> ResultExpr $ makeEagerExpr e - ToplevelLet rec x args ret body cont -> ToplevelLet rec x args ret (makeEagerExpr body) (makeEagerToplevelExpr cont) + ToplevelLet x t e cont -> ToplevelLet x t (makeEagerExpr e) (makeEagerToplevelExpr cont) + ToplevelLetRec x args ret body cont -> ToplevelLetRec x args ret (makeEagerExpr body) (makeEagerToplevelExpr cont) run :: MonadError Error m => Program -> m Program run = typecheckProgram' . makeEagerToplevelExpr diff --git a/src/Jikka/Core/Convert/RemoveUnusedVars.hs b/src/Jikka/Core/Convert/RemoveUnusedVars.hs index f28b2379..6d65267d 100644 --- a/src/Jikka/Core/Convert/RemoveUnusedVars.hs +++ b/src/Jikka/Core/Convert/RemoveUnusedVars.hs @@ -37,13 +37,13 @@ cleanExpr = \case cleanToplevelExpr :: ToplevelExpr -> ToplevelExpr cleanToplevelExpr = \case ResultExpr e -> ResultExpr $ cleanExpr e - ToplevelLet rec x args ret body cont -> - let rec' = case rec of - Rec | isUnusedVar x body -> NonRec - _ -> rec - body' = cleanExpr body + ToplevelLet x t e cont -> ToplevelLet x t (cleanExpr e) (cleanToplevelExpr cont) + ToplevelLetRec f args ret body cont -> + let body' = cleanExpr body cont' = cleanToplevelExpr cont - in ToplevelLet rec' x args ret body' cont' + in if isUnusedVar f body' + then ToplevelLet f (FunTy (map snd args) ret) (Lam args body') cont' + else ToplevelLetRec f args ret body' cont' run :: MonadError Error m => Program -> m Program run = typecheckProgram' . cleanToplevelExpr diff --git a/src/Jikka/Core/Convert/StrengthReduction.hs b/src/Jikka/Core/Convert/StrengthReduction.hs index 778e88b7..9a57f4c9 100644 --- a/src/Jikka/Core/Convert/StrengthReduction.hs +++ b/src/Jikka/Core/Convert/StrengthReduction.hs @@ -220,7 +220,8 @@ weakenExpr = \case weakenToplevelExpr :: ToplevelExpr -> ToplevelExpr weakenToplevelExpr e = case e of ResultExpr e -> ResultExpr $ weakenExpr e - ToplevelLet rec x args ret body cont -> ToplevelLet rec x args ret (weakenExpr body) (weakenToplevelExpr cont) + ToplevelLet x t e cont -> ToplevelLet x t (weakenExpr e) (weakenToplevelExpr cont) + ToplevelLetRec f args ret body cont -> ToplevelLetRec f args ret (weakenExpr body) (weakenToplevelExpr cont) run :: MonadError Error m => Program -> m Program run = typecheckProgram' . weakenToplevelExpr diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index 1c9dc366..81fde0f1 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -340,10 +340,11 @@ callLambdaWithTokens tokens env args body = case args of evaluateToplevelExpr :: (MonadFix m, MonadError Error m) => [Token] -> Env -> ToplevelExpr -> m (Value, [Token]) evaluateToplevelExpr tokens env = \case - ToplevelLet rec f args _ body cont -> do - val <- case rec of - NonRec -> evaluateExpr env (Lam args body) - Rec -> mfix $ \val -> evaluateExpr ((f, val) : env) (Lam args body) + ToplevelLet x _ e cont -> do + val <- evaluateExpr env e + evaluateToplevelExpr tokens ((x, val) : env) cont + ToplevelLetRec f args _ body cont -> do + val <- mfix $ \val -> evaluateExpr ((f, val) : env) (Lam args body) evaluateToplevelExpr tokens ((f, val) : env) cont ResultExpr e -> do val <- evaluateExpr env e diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index 7e1f756b..8239decf 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -170,22 +170,17 @@ formatExpr = \case Lam args e -> paren $ "fun " ++ formatFormalArgs args ++ " ->\n" ++ indent ++ "\n" ++ formatExpr e ++ "\n" ++ dedent ++ "\n" Let x t e1 e2 -> "let " ++ unVarName x ++ ": " ++ formatType t ++ " =\n" ++ indent ++ "\n" ++ formatExpr e1 ++ "\n" ++ dedent ++ "\nin " ++ formatExpr e2 -formatRecKind :: RecKind -> String -formatRecKind = \case - NonRec -> "let " - Rec -> "let rec " - formatToplevelExpr :: ToplevelExpr -> [String] formatToplevelExpr = \case ResultExpr e -> [formatExpr e] - ToplevelLet rec f args ret e cont -> - [ formatRecKind rec ++ unVarName f ++ " " ++ formatFormalArgs args ++ ": " ++ formatType ret ++ " =", - indent - ] - ++ lines (formatExpr e) - ++ [dedent] - ++ ["in"] - ++ formatToplevelExpr cont + ToplevelLet x t e cont -> let' (unVarName x) t e cont + ToplevelLetRec f args ret e cont -> let' ("rec " ++ unVarName f ++ " " ++ formatFormalArgs args) ret e cont + where + let' s t e cont = + ["let " ++ s ++ ": " ++ formatType t ++ " =", indent] + ++ lines (formatExpr e) + ++ [dedent, "in"] + ++ formatToplevelExpr cont formatProgram :: Program -> [String] formatProgram = formatToplevelExpr diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index 454487ab..205424ba 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -286,15 +286,19 @@ pattern LamId x t <- where LamId x t = Lam [(x, t)] (Var x) -data RecKind - = NonRec - | Rec - deriving (Eq, Ord, Show, Read) - -- | `ToplevelExpr` is the toplevel exprs. In our core, "let rec" is allowed only on the toplevel. +-- +-- \[ +-- \begin{array}{rl} +-- \mathrm{tle} ::= & e \\ +-- \vert & \mathbf{let}~ x: \tau = e ~\mathbf{in}~ \mathrm{tle} \\ +-- \vert & \mathbf{letrec}~ x(x: \tau, x: \tau, \dots, x: \tau): \tau = e ~\mathbf{in}~ \mathrm{tle} +-- \end{array} +-- \] data ToplevelExpr = ResultExpr Expr - | ToplevelLet RecKind VarName [(VarName, Type)] Type Expr ToplevelExpr + | ToplevelLet VarName Type Expr ToplevelExpr + | ToplevelLetRec VarName [(VarName, Type)] Type Expr ToplevelExpr deriving (Eq, Ord, Show, Read) type Program = ToplevelExpr diff --git a/src/Jikka/Core/Language/Lint.hs b/src/Jikka/Core/Language/Lint.hs index 007986b3..fd1698ed 100644 --- a/src/Jikka/Core/Language/Lint.hs +++ b/src/Jikka/Core/Language/Lint.hs @@ -125,14 +125,16 @@ typecheckExpr env = \case typecheckToplevelExpr :: MonadError Error m => TypeEnv -> ToplevelExpr -> m Type typecheckToplevelExpr env = \case ResultExpr e -> typecheckExpr env e - ToplevelLet rec x args ret body cont -> do + ToplevelLet x t e cont -> do + t' <- typecheckExpr env e + if t' == t then return () else throwInternalError "assigned type is not correct" + typecheckToplevelExpr ((x, t) : env) cont + ToplevelLetRec x args ret body cont -> do let t = case args of [] -> ret _ -> FunTy (map snd args) ret - ret' <- case rec of - NonRec -> typecheckExpr (reverse args ++ env) body - Rec -> typecheckExpr (reverse args ++ (x, t) : env) body - if ret' == ret then return () else throwInternalError "returned type is not corrent" + ret' <- typecheckExpr (reverse args ++ (x, t) : env) body + if ret' == ret then return () else throwInternalError "returned type is not correct" typecheckToplevelExpr ((x, t) : env) cont typecheckProgram :: MonadError Error m => Program -> m Type diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 15c95e2e..760d8bbc 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -229,7 +229,7 @@ runToplevelStatements :: (MonadAlpha m, MonadError Error m) => [X.ToplevelStatem runToplevelStatements [] = return $ Y.ResultExpr (Y.Var "solve") runToplevelStatements (stmt : stmts) = case stmt of X.ToplevelAnnAssign _ _ _ -> undefined -- TODO - X.ToplevelFunctionDef f args ret body -> Y.ToplevelLet Y.Rec (runVarName f) (map (runVarName *** runType) args) (runType ret) <$> runStatements body <*> runToplevelStatements stmts + X.ToplevelFunctionDef f args ret body -> Y.ToplevelLetRec (runVarName f) (map (runVarName *** runType) args) (runType ret) <$> runStatements body <*> runToplevelStatements stmts X.ToplevelAssert _ -> runToplevelStatements stmts -- TOOD: use assertions as hints -- | `run` converts programs of our restricted Python-like language to programs of our core language. diff --git a/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs b/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs index 107a3400..a1f6decc 100644 --- a/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs +++ b/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs @@ -20,8 +20,7 @@ spec :: Spec spec = describe "run" $ do it "works" $ do let prog = - X.ToplevelLet - X.Rec + X.ToplevelLetRec "f" [("n", X.IntTy)] X.IntTy diff --git a/test/Jikka/Core/Convert/RemoveUnusedVarsSpec.hs b/test/Jikka/Core/Convert/RemoveUnusedVarsSpec.hs index 92e6ab85..aa2b393b 100644 --- a/test/Jikka/Core/Convert/RemoveUnusedVarsSpec.hs +++ b/test/Jikka/Core/Convert/RemoveUnusedVarsSpec.hs @@ -8,8 +8,7 @@ spec :: Spec spec = describe "run" $ do it "works" $ do let input = - ToplevelLet - Rec + ToplevelLetRec (VarName "solve@0") [(VarName "x@1", BoolTy)] BoolTy @@ -17,10 +16,8 @@ spec = describe "run" $ do (ResultExpr (Var (VarName "solve@0"))) let expected = ToplevelLet - NonRec (VarName "solve@0") - [(VarName "x@1", BoolTy)] - BoolTy - (Var (VarName "x@1")) + (FunTy [BoolTy] BoolTy) + (Lam [(VarName "x@1", BoolTy)] (Var (VarName "x@1"))) (ResultExpr (Var (VarName "solve@0"))) run input `shouldBe` Right expected diff --git a/test/Jikka/Core/EvaluateSpec.hs b/test/Jikka/Core/EvaluateSpec.hs index 55bea7a2..e7a1508c 100644 --- a/test/Jikka/Core/EvaluateSpec.hs +++ b/test/Jikka/Core/EvaluateSpec.hs @@ -8,8 +8,7 @@ spec :: Spec spec = describe "run" $ do it "works" $ do let prog = - ToplevelLet - Rec + ToplevelLetRec (VarName "solve@0") [(VarName "xs@1", ListTy IntTy)] IntTy @@ -30,8 +29,7 @@ spec = describe "run" $ do run' tokens prog `shouldBe` Right expected it "works on a recursive function" $ do let prog = - ToplevelLet - Rec + ToplevelLetRec (VarName "fact@0") [(VarName "n@1", IntTy)] IntTy diff --git a/test/Jikka/Core/FormatSpec.hs b/test/Jikka/Core/FormatSpec.hs index 67b34168..dc46c02a 100644 --- a/test/Jikka/Core/FormatSpec.hs +++ b/test/Jikka/Core/FormatSpec.hs @@ -11,8 +11,7 @@ spec :: Spec spec = describe "run" $ do it "works" $ do let program = - ToplevelLet - Rec + ToplevelLetRec (VarName "solve@0") [(VarName "n@1", IntTy)] IntTy From fa451124ebdd097431fdecb8aeb92c9e58d40d23 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 02:11:55 +0900 Subject: [PATCH 26/56] refactor(core): Rename internal functions in src/Jikka/Core/Convert/RemoveUnusedVars.hs --- src/Jikka/Core/Convert/RemoveUnusedVars.hs | 28 +++++++++++----------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Jikka/Core/Convert/RemoveUnusedVars.hs b/src/Jikka/Core/Convert/RemoveUnusedVars.hs index 6d65267d..fe5d9744 100644 --- a/src/Jikka/Core/Convert/RemoveUnusedVars.hs +++ b/src/Jikka/Core/Convert/RemoveUnusedVars.hs @@ -21,29 +21,29 @@ import Jikka.Core.Language.Expr import Jikka.Core.Language.Lint (typecheckProgram') import Jikka.Core.Language.Vars (isUnusedVar) -cleanLet :: VarName -> Type -> Expr -> Expr -> Expr -cleanLet x t e1 e2 +runLet :: VarName -> Type -> Expr -> Expr -> Expr +runLet x t e1 e2 | isUnusedVar x e2 = e2 | otherwise = Let x t e1 e2 -cleanExpr :: Expr -> Expr -cleanExpr = \case +runExpr :: Expr -> Expr +runExpr = \case Var x -> Var x Lit lit -> Lit lit - App f args -> App (cleanExpr f) (map cleanExpr args) - Lam args e -> Lam args (cleanExpr e) - Let x t e1 e2 -> cleanLet x t (cleanExpr e1) (cleanExpr e2) + App f args -> App (runExpr f) (map runExpr args) + Lam args e -> Lam args (runExpr e) + Let x t e1 e2 -> runLet x t (runExpr e1) (runExpr e2) -cleanToplevelExpr :: ToplevelExpr -> ToplevelExpr -cleanToplevelExpr = \case - ResultExpr e -> ResultExpr $ cleanExpr e - ToplevelLet x t e cont -> ToplevelLet x t (cleanExpr e) (cleanToplevelExpr cont) +runToplevelExpr :: ToplevelExpr -> ToplevelExpr +runToplevelExpr = \case + ResultExpr e -> ResultExpr $ runExpr e + ToplevelLet x t e cont -> ToplevelLet x t (runExpr e) (runToplevelExpr cont) ToplevelLetRec f args ret body cont -> - let body' = cleanExpr body - cont' = cleanToplevelExpr cont + let body' = runExpr body + cont' = runToplevelExpr cont in if isUnusedVar f body' then ToplevelLet f (FunTy (map snd args) ret) (Lam args body') cont' else ToplevelLetRec f args ret body' cont' run :: MonadError Error m => Program -> m Program -run = typecheckProgram' . cleanToplevelExpr +run = typecheckProgram' . runToplevelExpr From c6dd7f1ef4e9ef95e7933ffb093fb59a958cc776 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 02:23:07 +0900 Subject: [PATCH 27/56] docs(core): Add documents to src/Jikka/Core/Convert/RemoveUnusedVars.hs --- src/Jikka/Core/Convert/RemoveUnusedVars.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/Jikka/Core/Convert/RemoveUnusedVars.hs b/src/Jikka/Core/Convert/RemoveUnusedVars.hs index fe5d9744..9472c089 100644 --- a/src/Jikka/Core/Convert/RemoveUnusedVars.hs +++ b/src/Jikka/Core/Convert/RemoveUnusedVars.hs @@ -45,5 +45,22 @@ runToplevelExpr = \case then ToplevelLet f (FunTy (map snd args) ret) (Lam args body') cont' else ToplevelLetRec f args ret body' cont' +-- | `run` removes unused variables in given programs. +-- +-- This also removes variables for recursion, i.e. "rec" flags. +-- `ToplevelLetRec` may becomes `ToplevelLet`. +-- +-- For example, this converts +-- +-- > let rec solve x = +-- > let y = 0 +-- > in x +-- > in solve +-- +-- to +-- +-- > let solve x = +-- > x +-- > in solve run :: MonadError Error m => Program -> m Program run = typecheckProgram' . runToplevelExpr From eb5c04897ad19b64bccdf72724a08b42d408de86 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 02:23:45 +0900 Subject: [PATCH 28/56] test(core): Update tests in test/Jikka/Core/Convert/RemoveUnusedVarsSpec.hs --- test/Jikka/Core/Convert/RemoveUnusedVarsSpec.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/test/Jikka/Core/Convert/RemoveUnusedVarsSpec.hs b/test/Jikka/Core/Convert/RemoveUnusedVarsSpec.hs index aa2b393b..6a066507 100644 --- a/test/Jikka/Core/Convert/RemoveUnusedVarsSpec.hs +++ b/test/Jikka/Core/Convert/RemoveUnusedVarsSpec.hs @@ -9,15 +9,15 @@ spec = describe "run" $ do it "works" $ do let input = ToplevelLetRec - (VarName "solve@0") - [(VarName "x@1", BoolTy)] + (VarName "solve") + [(VarName "x", BoolTy)] BoolTy - (Let (VarName "y@2") IntTy Lit0 (Var (VarName "x@1"))) - (ResultExpr (Var (VarName "solve@0"))) + (Let (VarName "y") IntTy Lit0 (Var (VarName "x"))) + (ResultExpr (Var (VarName "solve"))) let expected = ToplevelLet - (VarName "solve@0") + (VarName "solve") (FunTy [BoolTy] BoolTy) - (Lam [(VarName "x@1", BoolTy)] (Var (VarName "x@1"))) - (ResultExpr (Var (VarName "solve@0"))) + (Lam [(VarName "x", BoolTy)] (Var (VarName "x"))) + (ResultExpr (Var (VarName "solve"))) run input `shouldBe` Right expected From 8dc2452bfc7ca58514986ec212574f8c2c0b8ce4 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 02:29:09 +0900 Subject: [PATCH 29/56] refactor(core): Add `run'` in src/Jikka/Core/Convert/RemoveUnusedVars.hs --- src/Jikka/Core/Convert/RemoveUnusedVars.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Jikka/Core/Convert/RemoveUnusedVars.hs b/src/Jikka/Core/Convert/RemoveUnusedVars.hs index 9472c089..5165a277 100644 --- a/src/Jikka/Core/Convert/RemoveUnusedVars.hs +++ b/src/Jikka/Core/Convert/RemoveUnusedVars.hs @@ -13,6 +13,7 @@ -- `Jikka.Language.Core.RemoveUnusedVars` remove unused variables from exprs. module Jikka.Core.Convert.RemoveUnusedVars ( run, + run', ) where @@ -45,6 +46,9 @@ runToplevelExpr = \case then ToplevelLet f (FunTy (map snd args) ret) (Lam args body') cont' else ToplevelLetRec f args ret body' cont' +run' :: Program -> Program +run' = runToplevelExpr + -- | `run` removes unused variables in given programs. -- -- This also removes variables for recursion, i.e. "rec" flags. @@ -63,4 +67,4 @@ runToplevelExpr = \case -- > x -- > in solve run :: MonadError Error m => Program -> m Program -run = typecheckProgram' . runToplevelExpr +run = typecheckProgram' . run' From 84645a136ec7545b2f0864a2fa0436993858f3ea Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 02:41:38 +0900 Subject: [PATCH 30/56] refactor(core): Update src/Jikka/Core/Convert/MakeEager.hs --- src/Jikka/Core/Convert/MakeEager.hs | 54 ++++++++++++++++++++--------- 1 file changed, 38 insertions(+), 16 deletions(-) diff --git a/src/Jikka/Core/Convert/MakeEager.hs b/src/Jikka/Core/Convert/MakeEager.hs index 5bd9f7ce..c59a50d5 100644 --- a/src/Jikka/Core/Convert/MakeEager.hs +++ b/src/Jikka/Core/Convert/MakeEager.hs @@ -9,11 +9,9 @@ -- Maintainer : kimiyuki95@gmail.com -- Stability : experimental -- Portability : portable --- --- `Jikka.Language.Core.MakeEager` wraps some exprs with lambda redundant things from AST. --- Specifically, this converts @if p then a else b@ to @(if p then (lambda x. a) else (lambda x. b)) 0@. module Jikka.Core.Convert.MakeEager ( run, + run', ) where @@ -21,21 +19,45 @@ import Jikka.Common.Error import Jikka.Core.Language.Expr import Jikka.Core.Language.Lint (typecheckProgram') -makeEagerExpr :: Expr -> Expr -makeEagerExpr = \case +runExpr :: Expr -> Expr +runExpr = \case Var x -> Var x Lit lit -> Lit lit - App f args -> case (makeEagerExpr f, args) of - (Builtin (If t), [p, a, b]) -> App (AppBuiltin (If (FunTy [] t)) [makeEagerExpr p, Lam [] (makeEagerExpr a), Lam [] (makeEagerExpr b)]) [] - (f, _) -> App f (map makeEagerExpr args) - Lam args e -> Lam args (makeEagerExpr e) - Let x t e1 e2 -> Let x t (makeEagerExpr e1) (makeEagerExpr e2) + App f args -> case (runExpr f, args) of + (Builtin (If t), [p, a, b]) -> App (AppBuiltin (If (FunTy [] t)) [runExpr p, Lam [] (runExpr a), Lam [] (runExpr b)]) [] + (f, _) -> App f (map runExpr args) + Lam args e -> Lam args (runExpr e) + Let x t e1 e2 -> Let x t (runExpr e1) (runExpr e2) + +runToplevelExpr :: ToplevelExpr -> ToplevelExpr +runToplevelExpr e = case e of + ResultExpr e -> ResultExpr $ runExpr e + ToplevelLet x t e cont -> ToplevelLet x t (runExpr e) (runToplevelExpr cont) + ToplevelLetRec x args ret body cont -> ToplevelLetRec x args ret (runExpr body) (runToplevelExpr cont) -makeEagerToplevelExpr :: ToplevelExpr -> ToplevelExpr -makeEagerToplevelExpr e = case e of - ResultExpr e -> ResultExpr $ makeEagerExpr e - ToplevelLet x t e cont -> ToplevelLet x t (makeEagerExpr e) (makeEagerToplevelExpr cont) - ToplevelLetRec x args ret body cont -> ToplevelLetRec x args ret (makeEagerExpr body) (makeEagerToplevelExpr cont) +run' :: Program -> Program +run' = runToplevelExpr +-- | `run` wraps some exprs with lambda redundant things from AST. +-- Specifically, this converts @if p then a else b@ to something like @(if p then (lambda. a) else (lambda. b))()@. +-- +-- For example, this converts: +-- +-- > let rec fact n = +-- > if n == 0 then +-- > 1 +-- > else +-- > n * fact (n - 1) +-- > in fact 10 +-- +-- to: +-- +-- > let rec fact n = +-- > (if n == 0 then +-- > fun -> 1 +-- > else +-- > fun -> n * fact (n - 1) +-- > )() +-- > in fact 10 run :: MonadError Error m => Program -> m Program -run = typecheckProgram' . makeEagerToplevelExpr +run = typecheckProgram' . run' From 223818916f1b6ee8a3a6b09c14e7b6b14690b9a8 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 02:45:36 +0900 Subject: [PATCH 31/56] docs(rpython): Fix Haddock markup --- src/Jikka/RestrictedPython/Convert/ResolveBuiltin.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Jikka/RestrictedPython/Convert/ResolveBuiltin.hs b/src/Jikka/RestrictedPython/Convert/ResolveBuiltin.hs index 0dcedb1d..85e56aec 100644 --- a/src/Jikka/RestrictedPython/Convert/ResolveBuiltin.hs +++ b/src/Jikka/RestrictedPython/Convert/ResolveBuiltin.hs @@ -24,8 +24,8 @@ runExpr = mapSubExprM go -- | `run` resolves types of polymorphic builtin functions. -- This assumes there are no assignments to builtin functions, i.e. `doesntHaveAssignmentToBuiltin`. -- --- For example, the "max" of "max(xs)" has a type \(\mathbf{list}(\alpha) \to \alpha\) but the "max" of "max(x, y, z)" has a type \(\alpha \times \alpha \times \alpha \to \alpha\). --- So this function converts `Var "max"` to `BuiltinMax1 t`,`BuiltinMax t 2`, `BuiltinMax t 3`, etc.. +-- For example, the @max@ of @max(xs)@ has a type \(\mathbf{list}(\alpha) \to \alpha\) but the @max@ of @max(x, y, z)@ has a type \(\alpha \times \alpha \times \alpha \to \alpha\). +-- So this function converts @Var "max"@ to @BuiltinMax1 t@, @BuiltinMax t 2@, @BuiltinMax t 3@, etc.. run :: (MonadAlpha m, MonadError Error m) => Program -> m Program run prog = wrapError' "Jikka.RestrictedPython.Convert.ResolveBuiltin" $ do ensureDoesntHaveAssignmentToBuiltin prog From 5971e93d6282ea6f4765339c13d916b78925714d Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 04:59:18 +0900 Subject: [PATCH 32/56] feat(rpython): Implement Jikka.RestrictedPython.Convert.ToCore --- src/Jikka/RestrictedPython/Convert/ToCore.hs | 129 ++++++++++++++++-- .../RestrictedPython/Convert/AlphaSpec.hs | 16 +++ .../RestrictedPython/Convert/ToCoreSpec.hs | 95 ++++++++++++- 3 files changed, 225 insertions(+), 15 deletions(-) diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 760d8bbc..51655b8c 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -5,10 +5,12 @@ module Jikka.RestrictedPython.Convert.ToCore ( run, + runForStatement, ) where import Control.Arrow ((***)) +import Control.Monad.State.Strict import Jikka.Common.Alpha import Jikka.Common.Error import qualified Jikka.Core.Language.BuiltinPatterns as Y @@ -16,6 +18,23 @@ import qualified Jikka.Core.Language.Expr as Y import qualified Jikka.Core.Language.Util as Y import qualified Jikka.RestrictedPython.Language.Expr as X import qualified Jikka.RestrictedPython.Language.Lint as X +import qualified Jikka.RestrictedPython.Language.Util as X +import qualified Jikka.RestrictedPython.Language.VariableAnalysis as X + +type Env = [X.VarName] + +defineVar :: MonadState Env m => X.VarName -> m () +defineVar x = modify' (x :) + +isDefinedVar :: MonadState Env m => X.VarName -> m Bool +isDefinedVar x = gets (x `elem`) + +withScope :: MonadState Env m => m a -> m a +withScope f = do + env <- get + x <- f + put env + return x runVarName :: X.VarName -> Y.VarName runVarName (X.VarName x) = Y.VarName x @@ -161,14 +180,14 @@ runTargetExpr = \case X.NameTrg x -> return $ Y.Var (runVarName x) X.TupleTrg xs -> Y.Tuple' <$> replicateM (length xs) Y.genType <*> mapM runTargetExpr xs -runAssign :: (MonadAlpha m, MonadError Error m) => X.Target -> Y.Expr -> Y.Expr -> m Y.Expr +runAssign :: (MonadAlpha m, MonadError Error m) => X.Target -> Y.Expr -> m Y.Expr -> m Y.Expr runAssign x e cont = case x of X.SubscriptTrg x index -> join $ runAssign x <$> (Y.SetAt' <$> Y.genType <*> runTargetExpr x <*> runExpr index <*> pure e) <*> pure cont - X.NameTrg x -> Y.Let (runVarName x) <$> Y.genType <*> pure e <*> pure cont + X.NameTrg x -> Y.Let (runVarName x) <$> Y.genType <*> pure e <*> cont X.TupleTrg xs -> do y <- Y.genVarName' ts <- replicateM (length xs) Y.genType - cont <- foldM (\cont (i, x) -> runAssign x (Y.Proj' ts i (Y.Var y)) cont) cont (zip [0 ..] xs) + cont <- join $ foldM (\cont (i, x) -> return $ runAssign x (Y.Proj' ts i (Y.Var y)) cont) cont (zip [0 ..] xs) return $ Y.Let y (Y.TupleTy ts) e cont runListComp :: (MonadAlpha m, MonadError Error m) => X.Expr -> X.Comprehension -> m Y.Expr @@ -181,7 +200,7 @@ runListComp e (X.Comprehension x iter pred) = do t1 <- Y.genType t2 <- Y.genType e <- runExpr e - Y.Map' t1 t2 <$> (Y.Lam [(y, t1)] <$> runAssign x (Y.Var y) e) <*> pure iter + Y.Map' t1 t2 <$> (Y.Lam [(y, t1)] <$> runAssign x (Y.Var y) (pure e)) <*> pure iter runExpr :: (MonadAlpha m, MonadError Error m) => X.Expr -> m Y.Expr runExpr = \case @@ -207,29 +226,77 @@ runExpr = \case X.Tuple es -> Y.Tuple' <$> mapM (const Y.genType) es <*> mapM runExpr es X.SubscriptSlice _ _ _ _ -> throwInternalError "runExpr TODO" -runForStatement :: (MonadAlpha m, MonadError Error m) => X.Target -> X.Expr -> [X.Statement] -> m Y.Expr -runForStatement = undefined -- TODO +-- | `runForStatement` converts for-loops to `foldl`. +-- For example, this converts the following: +-- +-- > # a, b are defined +-- > for _ in range(n): +-- > c = a + b +-- > a = b +-- > b = c +-- > ... +-- +-- to: +-- +-- > let (a, b) = foldl (fun (a, b) i -> (b, a + b)) (a, b) (range n) +-- > in ... +runForStatement :: (MonadState Env m, MonadAlpha m, MonadError Error m) => X.Target -> X.Expr -> [X.Statement] -> [X.Statement] -> m Y.Expr +runForStatement x iter body cont = do + tx <- Y.genType + iter <- runExpr iter + z <- Y.genVarName' + let (_, X.WriteList w) = X.analyzeStatements body + ys <- filterM isDefinedVar w + ts <- replicateM (length ys) Y.genType + let init = Y.Tuple' ts (map (Y.Var . runVarName) ys) + let write cont = foldr (\(i, y, t) -> Y.Let (runVarName y) t (Y.Proj' ts i (Y.Var z))) cont (zip3 [0 ..] ys ts) + body <- runAssign x (Y.Var z) $ do + runStatements (body ++ [X.Return (X.Tuple (map X.Name ys))]) + let loop init = Y.Foldl' tx (Y.TupleTy ts) (Y.Lam [(z, Y.TupleTy ts)] (write body)) init iter + cont <- runStatements cont + return $ Y.Let z (Y.TupleTy ts) (loop init) (write cont) -runStatements :: (MonadAlpha m, MonadError Error m) => [X.Statement] -> m Y.Expr +runStatements :: (MonadState Env m, MonadAlpha m, MonadError Error m) => [X.Statement] -> m Y.Expr runStatements [] = throwSemanticError "function may not return" runStatements (stmt : stmts) = case stmt of X.Return e -> runExpr e - X.AugAssign x op e -> join $ runAssign x <$> (Y.App <$> (Y.Lit . Y.LitBuiltin <$> runOperator op) <*> (makeList2 <$> runTargetExpr x <*> runExpr e)) <*> runStatements stmts - X.AnnAssign x _ e -> join $ runAssign x <$> runExpr e <*> runStatements stmts - X.For x iter body -> runForStatement x iter body + X.AugAssign x op e -> do + y <- runTargetExpr x + op <- Y.Lit . Y.LitBuiltin <$> runOperator op + e <- runExpr e + runAssign x (Y.App op [y, e]) $ do + runStatements stmts + X.AnnAssign x _ e -> do + e <- runExpr e + runAssign x e $ do + withScope $ do + mapM_ defineVar (X.targetVars x) + runStatements stmts + X.For x iter body -> runForStatement x iter body stmts X.If e body1 body2 -> do e <- runExpr e + -- TODO: optimize cases when both statements doesn't return. The current implementation, it exponentially explodes. body1 <- runStatements (body1 ++ stmts) body2 <- runStatements (body2 ++ stmts) t <- Y.genType return $ Y.AppBuiltin (Y.If t) [e, body1, body2] X.Assert _ -> runStatements stmts -runToplevelStatements :: (MonadAlpha m, MonadError Error m) => [X.ToplevelStatement] -> m Y.ToplevelExpr +runToplevelStatements :: (MonadState Env m, MonadAlpha m, MonadError Error m) => [X.ToplevelStatement] -> m Y.ToplevelExpr runToplevelStatements [] = return $ Y.ResultExpr (Y.Var "solve") runToplevelStatements (stmt : stmts) = case stmt of - X.ToplevelAnnAssign _ _ _ -> undefined -- TODO - X.ToplevelFunctionDef f args ret body -> Y.ToplevelLetRec (runVarName f) (map (runVarName *** runType) args) (runType ret) <$> runStatements body <*> runToplevelStatements stmts + X.ToplevelAnnAssign x t e -> do + e <- runExpr e + defineVar x + cont <- runToplevelStatements stmts + return $ Y.ToplevelLet (runVarName x) (runType t) e cont + X.ToplevelFunctionDef f args ret body -> do + defineVar f + body <- withScope $ do + mapM_ (defineVar . fst) args + runStatements body + cont <- runToplevelStatements stmts + return $ Y.ToplevelLetRec (runVarName f) (map (runVarName *** runType) args) (runType ret) body cont X.ToplevelAssert _ -> runToplevelStatements stmts -- TOOD: use assertions as hints -- | `run` converts programs of our restricted Python-like language to programs of our core language. @@ -241,6 +308,40 @@ runToplevelStatements (stmt : stmts) = case stmt of -- * `X.doesntHaveAssignmentToLoopIterators` -- * `X.doesntHaveReturnInLoops` -- * `X.doesntHaveNonTrivialSubscriptedAssignmentInForLoops` +-- +-- For example, this converts the following: +-- +-- > def solve(n): +-- > if n == 0: +-- > return 1 +-- > else: +-- > return n * solve(n - 1) +-- +-- to: +-- +-- > let solve n = +-- > if n == 0 then +-- > 1 +-- > else: +-- > n * solve (n - 1) +-- > in solve +-- +-- Also, this converts the following: +-- +-- > def solve(n): +-- > a = 0 +-- > b = 1 +-- > for _ in range(n): +-- > c = a + b +-- > a = b +-- > b = c +-- > return a +-- +-- to: +-- +-- > let solve n = +-- > fst (foldl (fun (a, b) i -> (b, a + b)) (0, 1) [0 .. n - 1]) +-- > in solve run :: (MonadAlpha m, MonadError Error m) => X.Program -> m Y.Program run prog = do X.ensureDoesntHaveSubscriptionInLoopCounters prog @@ -249,4 +350,4 @@ run prog = do X.ensureDoesntHaveAssignmentToLoopIterators prog X.ensureDoesntHaveReturnInLoops prog X.ensureDoesntHaveNonTrivialSubscriptedAssignmentInForLoops prog - runToplevelStatements prog + evalStateT (runToplevelStatements prog) [] diff --git a/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs b/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs index aa38bdf3..bcdfa4c6 100644 --- a/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs @@ -283,6 +283,22 @@ spec = describe "run" $ do ] let expected = WithWrapped "Jikka.RestrictedPython.Convert.Alpha" (WithGroup SemanticError (Error "cannot redefine variable: i")) run' parsed `shouldBe` Left expected + it "blames undefined variables which will be defined in the rest of the same loop" $ do + let parsed = + [ ToplevelFunctionDef + "main" + [] + IntTy + [ For + (NameTrg "i") + (List IntTy []) + [ Return (Name "a"), + AnnAssign (NameTrg "a") IntTy (constIntExp 0) + ] + ] + ] + let expected = WithWrapped "Jikka.RestrictedPython.Convert.Alpha" (WithGroup SymbolError (Error "undefined identifier: a")) + run' parsed `shouldBe` Left expected it "doesn't leak loop counters of for-exprs" $ do let parsed = [ ToplevelFunctionDef diff --git a/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs b/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs index 46cff522..b88dcac8 100644 --- a/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs @@ -1,6 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} + module Jikka.RestrictedPython.Convert.ToCoreSpec (spec) where +import Jikka.Common.Alpha +import Jikka.Common.Error +import qualified Jikka.Core.Format as Y.Format +import qualified Jikka.Core.Language.BuiltinPatterns as Y +import qualified Jikka.Core.Language.Expr as Y +import Jikka.RestrictedPython.Convert.ToCore (run) +import qualified Jikka.RestrictedPython.Language.Expr as X +import qualified Jikka.RestrictedPython.Language.Util as X import Test.Hspec +run' :: X.Program -> Either Error Y.Program +run' = flip evalAlphaT 0 . run + spec :: Spec -spec = return () +spec = describe "run" $ do + it "works" $ do + let prog = + [ X.ToplevelFunctionDef + "solve" + [("n", X.IntTy)] + X.IntTy + [ X.If + (X.Compare (X.Name "n") (X.CmpOp' X.Eq' X.IntTy) (X.constIntExp 0)) + [ X.Return (X.constIntExp 1) + ] + [ X.Return (X.BinOp (X.Name "n") X.Mult (X.Call (X.Name "solve") [X.BinOp (X.Name "n") X.Sub (X.constIntExp 1)])) + ] + ] + ] + let expected = + Y.ToplevelLetRec + "solve" + [("n", Y.IntTy)] + Y.IntTy + ( Y.If' + (Y.VarTy "$0") + (Y.Equal' Y.IntTy (Y.Var "n") Y.Lit0) + Y.Lit1 + ( Y.Mult' + (Y.Var "n") + (Y.App (Y.Var "solve") [Y.Minus' (Y.Var "n") Y.Lit1]) + ) + ) + (Y.ResultExpr (Y.Var "solve")) + run' prog `shouldBe` Right expected + it "converts for-loops to foldl" $ do + let prog = + [ X.ToplevelFunctionDef + "solve" + [("n", X.IntTy)] + X.IntTy + [ X.AnnAssign (X.NameTrg "a") X.IntTy (X.constIntExp 0), + X.AnnAssign (X.NameTrg "b") X.IntTy (X.constIntExp 1), + X.For + (X.NameTrg "i") + (X.Call (X.Constant $ X.ConstBuiltin X.BuiltinRange1) [X.Name "n"]) + [ X.AnnAssign (X.NameTrg "c") X.IntTy (X.BinOp (X.Name "a") X.Add (X.Name "b")), + X.AnnAssign (X.NameTrg "a") X.IntTy (X.Name "b"), + X.AnnAssign (X.NameTrg "b") X.IntTy (X.Name "c") + ], + X.Return (X.Name "a") + ] + ] + let expected = + unlines + [ "let rec solve (n: int): int =", + " let a: $0 =", + " 0", + " in let b: $1 =", + " 1", + " in let $3: ($4 * $5) =", + " foldl((fun ($3: ($4 * $5)) ->", + " let b: $4 =", + " proj0($3)", + " in let a: $5 =", + " proj1($3)", + " in let i: $6 =", + " $3", + " in let c: $7 =", + " (a + b)", + " in let a: $8 =", + " b", + " in let b: $9 =", + " c", + " in tuple(b, a)", + " ), tuple(b, a), range1(n))", + " in let b: $4 =", + " proj0($3)", + " in let a: $5 =", + " proj1($3)", + " in a", + "in", + "solve" + ] + (Y.Format.run' <$> run' prog) `shouldBe` Right expected From 490b3a8e03fa43e721445e3bd625288eba77018c Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 05:20:21 +0900 Subject: [PATCH 33/56] refactor(rpython): Add analyzeStatementsMin --- .../RestrictedPython/Convert/SplitLoops.hs | 2 +- src/Jikka/RestrictedPython/Convert/ToCore.hs | 2 +- src/Jikka/RestrictedPython/Language/Lint.hs | 4 +- .../Language/VariableAnalysis.hs | 50 +++++++++++++++---- 4 files changed, 44 insertions(+), 14 deletions(-) diff --git a/src/Jikka/RestrictedPython/Convert/SplitLoops.hs b/src/Jikka/RestrictedPython/Convert/SplitLoops.hs index 4c127f43..9e2a20bf 100644 --- a/src/Jikka/RestrictedPython/Convert/SplitLoops.hs +++ b/src/Jikka/RestrictedPython/Convert/SplitLoops.hs @@ -27,7 +27,7 @@ runForLoop x iter body = go result (stmt : stmts) = let (same, diff) = partition (connected stmt) stmts in go (For x iter (map fst (stmt : same)) : result) diff - body' = map (\stmt -> (stmt, analyzeStatement stmt)) body + body' = map (\stmt -> (stmt, analyzeStatementMax stmt)) body in go [] body' -- | `run'` splits for-loops into many small for-loops as possible. diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 51655b8c..18d3081f 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -245,7 +245,7 @@ runForStatement x iter body cont = do tx <- Y.genType iter <- runExpr iter z <- Y.genVarName' - let (_, X.WriteList w) = X.analyzeStatements body + let (_, X.WriteList w) = X.analyzeStatementsMax body ys <- filterM isDefinedVar w ts <- replicateM (length ys) Y.genType let init = Y.Tuple' ts (map (Y.Var . runVarName) ys) diff --git a/src/Jikka/RestrictedPython/Language/Lint.hs b/src/Jikka/RestrictedPython/Language/Lint.hs index b1acfa96..6990d150 100644 --- a/src/Jikka/RestrictedPython/Language/Lint.hs +++ b/src/Jikka/RestrictedPython/Language/Lint.hs @@ -71,7 +71,7 @@ hasAssignmentToLoopCounters prog = any check (listStatements prog) check = \case For x _ body -> let r = ReadList $ targetVars x - (_, w) = analyzeStatements body + (_, w) = analyzeStatementsMax body in haveWriteReadIntersection w r _ -> False @@ -97,7 +97,7 @@ hasAssignmentToLoopIterators prog = any check (listStatements prog) check = \case For _ iter body -> let r = analyzeExpr iter - (_, w) = analyzeStatements body + (_, w) = analyzeStatementsMax body in haveWriteReadIntersection w r _ -> False diff --git a/src/Jikka/RestrictedPython/Language/VariableAnalysis.hs b/src/Jikka/RestrictedPython/Language/VariableAnalysis.hs index a92ea545..8338618c 100644 --- a/src/Jikka/RestrictedPython/Language/VariableAnalysis.hs +++ b/src/Jikka/RestrictedPython/Language/VariableAnalysis.hs @@ -24,8 +24,8 @@ analyzeTargetRead = ReadList . freeVarsTarget analyzeTargetWrite :: Target -> WriteList analyzeTargetWrite = WriteList . targetVars -analyzeStatement :: Statement -> (ReadList, WriteList) -analyzeStatement = \case +analyzeStatementGeneric :: Bool -> Statement -> (ReadList, WriteList) +analyzeStatementGeneric isMax = \case Return e -> (analyzeExpr e, WriteList []) AugAssign x _ e -> let w = analyzeTargetWrite x @@ -40,19 +40,49 @@ analyzeStatement = \case For x iter body -> let xs = targetVars x ReadList r = analyzeExpr iter - (ReadList r', WriteList w) = analyzeStatements body - in (ReadList (r ++ foldl (flip delete) r' xs), WriteList (foldl (flip delete) w xs)) + (ReadList r', WriteList w) = analyzeStatementsGeneric isMax body + in if isMax + then (ReadList (r ++ foldl (flip delete) r' xs), WriteList (foldl (flip delete) w xs)) + else (ReadList r, WriteList []) If e body1 body2 -> let ReadList r = analyzeExpr e - (ReadList r1, WriteList w1) = analyzeStatements body1 - (ReadList r2, WriteList w2) = analyzeStatements body2 - in (ReadList (r ++ r1 ++ r2), WriteList (w1 ++ w2)) + (ReadList r1, WriteList w1) = analyzeStatementsGeneric isMax body1 + (ReadList r2, WriteList w2) = analyzeStatementsGeneric isMax body2 + in if isMax + then (ReadList (r ++ r1 ++ r2), WriteList (w1 ++ w2)) + else (ReadList (r ++ intersect r1 r2), WriteList (w1 `intersect` w2)) Assert e -> (analyzeExpr e, WriteList []) -analyzeStatements :: [Statement] -> (ReadList, WriteList) -analyzeStatements = go [] [] +analyzeStatementsGeneric :: Bool -> [Statement] -> (ReadList, WriteList) +analyzeStatementsGeneric isMax = go [] [] where go r w [] = (ReadList (nub r), WriteList (nub w)) go r w (stmt : stmts) = - let (ReadList r', WriteList w') = analyzeStatement stmt + let (ReadList r', WriteList w') = analyzeStatementGeneric isMax stmt in go (r' ++ r) (w' ++ w) stmts + +-- | `analyzeStatementMax` returns lists of variables which are possibly read or written in given statements. +-- +-- >>> analyzeStatementMax (AnnAssign (NameTrg (VarName "y")) IntTy (Name (VarName "x"))) +-- (ReadList [VarName "x"],WriteList [VarName "y"]) +-- +-- >>> analyzeStatementMax (If (Constant (ConstBool True)) [AnnAssign (NameTrg (VarName "y")) IntTy (Name (VarName "x"))] []) +-- (ReadList [VarName "x"],WriteList [VarName "y"]) +analyzeStatementMax :: Statement -> (ReadList, WriteList) +analyzeStatementMax = analyzeStatementGeneric True + +analyzeStatementsMax :: [Statement] -> (ReadList, WriteList) +analyzeStatementsMax = analyzeStatementsGeneric True + +-- | `analyzeStatementMin` returns lists of variables which are always read or written in given statements. +-- +-- >>> analyzeStatementMin (AnnAssign (NameTrg (VarName "y")) IntTy (Name (VarName "x"))) +-- (ReadList [VarName "x"],WriteList [VarName "y"]) +-- +-- >>> analyzeStatementMin (If (Constant (ConstBool True)) [AnnAssign (NameTrg (VarName "y")) IntTy (Name (VarName "x"))] []) +-- (ReadList [],WriteList []) +analyzeStatementMin :: Statement -> (ReadList, WriteList) +analyzeStatementMin = analyzeStatementGeneric False + +analyzeStatementsMin :: [Statement] -> (ReadList, WriteList) +analyzeStatementsMin = analyzeStatementsGeneric False From add4cf17e86657d2b092f9e3faab969463310bfa Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 05:55:00 +0900 Subject: [PATCH 34/56] feat(rpython): Allow confluent of branches of if-statements --- src/Jikka/Core/Format.hs | 7 ++- src/Jikka/RestrictedPython/Convert/Alpha.hs | 8 +++- src/Jikka/RestrictedPython/Convert/ToCore.hs | 47 +++++++++++++++--- .../Language/VariableAnalysis.hs | 10 ++-- .../RestrictedPython/Convert/AlphaSpec.hs | 48 ++++++++++++++++++- .../RestrictedPython/Convert/ToCoreSpec.hs | 31 ++++++++++++ 6 files changed, 134 insertions(+), 17 deletions(-) diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index 8239decf..18e8d26e 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -16,6 +16,7 @@ module Jikka.Core.Format ) where +import Data.Char (toLower) import Data.List (intercalate) import Data.Text (Text, pack) import Jikka.Common.Format.AutoIndent @@ -30,7 +31,9 @@ formatType = \case IntTy -> "int" BoolTy -> "bool" ListTy t -> formatType t ++ " list" - TupleTy ts -> paren $ intercalate " * " (map formatType ts) + TupleTy ts -> case ts of + [t] -> paren $ formatType t ++ "," + _ -> paren $ intercalate " * " (map formatType ts) FunTy ts ret -> paren $ intercalate " * " (map formatType ts) ++ " -> " ++ formatType ret data Builtin' @@ -153,7 +156,7 @@ formatLiteral :: Literal -> String formatLiteral = \case LitBuiltin builtin -> formatBuiltinIsolated (analyzeBuiltin builtin) LitInt n -> show n - LitBool p -> show p + LitBool p -> map toLower $ show p LitNil t -> "nil" ++ formatTemplate [t] formatFormalArgs :: [(VarName, Type)] -> String diff --git a/src/Jikka/RestrictedPython/Convert/Alpha.hs b/src/Jikka/RestrictedPython/Convert/Alpha.hs index 8756fbd9..75514687 100644 --- a/src/Jikka/RestrictedPython/Convert/Alpha.hs +++ b/src/Jikka/RestrictedPython/Convert/Alpha.hs @@ -7,7 +7,7 @@ module Jikka.RestrictedPython.Convert.Alpha where import Control.Monad.State.Strict -import Data.List (delete) +import Data.List (delete, intersect) import qualified Data.Set as S import Jikka.Common.Alpha import Jikka.Common.Error @@ -15,6 +15,7 @@ import Jikka.RestrictedPython.Language.Builtin import Jikka.RestrictedPython.Language.Expr import Jikka.RestrictedPython.Language.Lint import Jikka.RestrictedPython.Language.Util +import Jikka.RestrictedPython.Language.VariableAnalysis data Env = Env { currentMapping :: [(VarName, VarName)], @@ -182,6 +183,9 @@ runStatement = \case return $ For y e body If e body1 body2 -> do e <- runExpr e + let (_, WriteList w1) = analyzeStatementsMin body1 + let (_, WriteList w2) = analyzeStatementsMin body2 + mapM_ renameNew (w1 `intersect` w2) -- introduce variables to the parent scope body1 <- withScope $ do runStatements body1 body2 <- withScope $ do @@ -248,7 +252,7 @@ runProgram = mapM runToplevelStatement -- > if True: -- > a = 0 -- > else: --- > a = 1 +-- > b = 1 -- > return a # error -- -- > for i in range(10): diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 18d3081f..d11bd26e 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -6,11 +6,13 @@ module Jikka.RestrictedPython.Convert.ToCore ( run, runForStatement, + runIfStatement, ) where import Control.Arrow ((***)) import Control.Monad.State.Strict +import Data.List (intersect) import Jikka.Common.Alpha import Jikka.Common.Error import qualified Jikka.Core.Language.BuiltinPatterns as Y @@ -256,6 +258,43 @@ runForStatement x iter body cont = do cont <- runStatements cont return $ Y.Let z (Y.TupleTy ts) (loop init) (write cont) +-- | `runIfStatement` converts if-loops to if-exprs. +-- +-- > # a, b are defined +-- > if True: +-- > a = 0 +-- > b = 1 +-- > c = 3 +-- > else: +-- > a = 1 +-- > c = 10 +-- > ... +-- +-- to: +-- +-- > let (a, c) = if true then (0, 3) else (1, 10) +-- > in ... +runIfStatement :: (MonadState Env m, MonadAlpha m, MonadError Error m) => X.Expr -> [X.Statement] -> [X.Statement] -> [X.Statement] -> m Y.Expr +runIfStatement e body1 body2 cont = do + e <- runExpr e + t <- Y.genType + case (any X.doesAlwaysReturn body1, any X.doesAlwaysReturn body2) of + (False, False) -> do + let (_, X.WriteList w1) = X.analyzeStatementsMin body1 + let (_, X.WriteList w2) = X.analyzeStatementsMin body2 + let w = w1 `intersect` w2 + let read = X.Tuple (map X.Name w) + ts <- replicateM (length w) Y.genType + z <- Y.genVarName' + let write value cont = Y.Let z (Y.TupleTy ts) value (foldr (\(i, y, t) -> Y.Let (runVarName y) t (Y.Proj' ts i (Y.Var z))) cont (zip3 [0 ..] w ts)) + body1 <- runStatements (body1 ++ [X.Return read]) + body2 <- runStatements (body2 ++ [X.Return read]) + cont <- runStatements cont + return $ write (Y.AppBuiltin (Y.If t) [e, body1, body2]) cont + (False, True) -> Y.If' t e <$> runStatements (body1 ++ cont) <*> runStatements body2 + (True, False) -> Y.If' t e <$> runStatements body1 <*> runStatements (body2 ++ cont) + (True, True) -> Y.If' t e <$> runStatements body1 <*> runStatements body2 + runStatements :: (MonadState Env m, MonadAlpha m, MonadError Error m) => [X.Statement] -> m Y.Expr runStatements [] = throwSemanticError "function may not return" runStatements (stmt : stmts) = case stmt of @@ -273,13 +312,7 @@ runStatements (stmt : stmts) = case stmt of mapM_ defineVar (X.targetVars x) runStatements stmts X.For x iter body -> runForStatement x iter body stmts - X.If e body1 body2 -> do - e <- runExpr e - -- TODO: optimize cases when both statements doesn't return. The current implementation, it exponentially explodes. - body1 <- runStatements (body1 ++ stmts) - body2 <- runStatements (body2 ++ stmts) - t <- Y.genType - return $ Y.AppBuiltin (Y.If t) [e, body1, body2] + X.If e body1 body2 -> runIfStatement e body1 body2 stmts X.Assert _ -> runStatements stmts runToplevelStatements :: (MonadState Env m, MonadAlpha m, MonadError Error m) => [X.ToplevelStatement] -> m Y.ToplevelExpr diff --git a/src/Jikka/RestrictedPython/Language/VariableAnalysis.hs b/src/Jikka/RestrictedPython/Language/VariableAnalysis.hs index 8338618c..abad3dc5 100644 --- a/src/Jikka/RestrictedPython/Language/VariableAnalysis.hs +++ b/src/Jikka/RestrictedPython/Language/VariableAnalysis.hs @@ -31,26 +31,26 @@ analyzeStatementGeneric isMax = \case let w = analyzeTargetWrite x (ReadList r) = analyzeTargetRead x (ReadList r') = analyzeExpr e - in (ReadList (r ++ r'), w) + in (ReadList (nub $ r ++ r'), w) AnnAssign x _ e -> let w = analyzeTargetWrite x (ReadList r) = analyzeTargetRead x (ReadList r') = analyzeExpr e - in (ReadList (r ++ r'), w) + in (ReadList (nub $ r ++ r'), w) For x iter body -> let xs = targetVars x ReadList r = analyzeExpr iter (ReadList r', WriteList w) = analyzeStatementsGeneric isMax body in if isMax - then (ReadList (r ++ foldl (flip delete) r' xs), WriteList (foldl (flip delete) w xs)) + then (ReadList (nub $ r ++ foldl (flip delete) r' xs), WriteList (nub $ foldl (flip delete) w xs)) else (ReadList r, WriteList []) If e body1 body2 -> let ReadList r = analyzeExpr e (ReadList r1, WriteList w1) = analyzeStatementsGeneric isMax body1 (ReadList r2, WriteList w2) = analyzeStatementsGeneric isMax body2 in if isMax - then (ReadList (r ++ r1 ++ r2), WriteList (w1 ++ w2)) - else (ReadList (r ++ intersect r1 r2), WriteList (w1 `intersect` w2)) + then (ReadList (nub $ r ++ r1 ++ r2), WriteList (nub $ w1 ++ w2)) + else (ReadList (nub $ r ++ intersect r1 r2), WriteList (nub $ w1 `intersect` w2)) Assert e -> (analyzeExpr e, WriteList []) analyzeStatementsGeneric :: Bool -> [Statement] -> (ReadList, WriteList) diff --git a/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs b/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs index bcdfa4c6..113f200e 100644 --- a/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/AlphaSpec.hs @@ -194,7 +194,7 @@ spec = describe "run" $ do ] ] run' parsed `shouldBe` Right expected - it "makes repeated assignments for the same variable to single-assignments" $ do + it "makes repeated assignments for the same variable to single-assignments for different variables" $ do let parsed = [ ToplevelFunctionDef "main" @@ -299,6 +299,52 @@ spec = describe "run" $ do ] let expected = WithWrapped "Jikka.RestrictedPython.Convert.Alpha" (WithGroup SymbolError (Error "undefined identifier: a")) run' parsed `shouldBe` Left expected + it "blames using variables which are defined in only one branch of if-statement" $ do + let parsed = + [ ToplevelFunctionDef + "main" + [] + IntTy + [ If + (constBoolExp True) + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0) + ] + [], + Return (Name "a") + ] + ] + let expected = WithWrapped "Jikka.RestrictedPython.Convert.Alpha" (WithGroup SymbolError (Error "undefined identifier: a")) + run' parsed `shouldBe` Left expected + it "works with variables which are defined in both branches of if-statement" $ do + let parsed = + [ ToplevelFunctionDef + "main" + [] + IntTy + [ If + (constBoolExp True) + [ AnnAssign (NameTrg "a") IntTy (constIntExp 0) + ] + [ AnnAssign (NameTrg "a") IntTy (constIntExp 1) + ], + Return (Name "a") + ] + ] + let expected = + [ ToplevelFunctionDef + "main" + [] + IntTy + [ If + (constBoolExp True) + [ AnnAssign (NameTrg "a$0") IntTy (constIntExp 0) + ] + [ AnnAssign (NameTrg "a$0") IntTy (constIntExp 1) + ], + Return (Name "a$0") + ] + ] + run' parsed `shouldBe` Right expected it "doesn't leak loop counters of for-exprs" $ do let parsed = [ ToplevelFunctionDef diff --git a/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs b/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs index b88dcac8..fa1f629c 100644 --- a/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs @@ -97,3 +97,34 @@ spec = describe "run" $ do "solve" ] (Y.Format.run' <$> run' prog) `shouldBe` Right expected + it "converts if-statements correctly" $ do + let prog = + [ X.ToplevelFunctionDef + "solve" + [] + X.IntTy + [ X.If + (X.constBoolExp True) + [ X.AnnAssign (X.NameTrg "x") X.IntTy (X.constIntExp 1) + ] + [ X.AnnAssign (X.NameTrg "x") X.IntTy (X.constIntExp 0) + ], + X.Return (X.Name "x") + ] + ] + let expected = + unlines + [ "let rec solve : int =", + " let $2: ($1,) =", + " (if true then let x: $3 =", + " 1", + " in tuple(x) else let x: $5 =", + " 0", + " in tuple(x))", + " in let x: $1 =", + " proj0($2)", + " in x", + "in", + "solve" + ] + (Y.Format.run' <$> run' prog) `shouldBe` Right expected From 22b2b9bf76ba3e4814a10d85ee2b6675c082f442 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 06:28:23 +0900 Subject: [PATCH 35/56] refactor: Update Jikka.Main modules --- src/Jikka/CPlusPlus/Convert.hs | 18 ++++++++++ src/Jikka/Core/{Convert => }/Optimize.hs | 8 +++-- src/Jikka/Main/Subcommand/Convert.hs | 12 ++----- src/Jikka/Main/Subcommand/Debug.hs | 46 ++++-------------------- src/Jikka/Main/Subcommand/Execute.hs | 15 ++------ src/Jikka/RestrictedPython/Convert.hs | 33 +++++++++++++++++ 6 files changed, 68 insertions(+), 64 deletions(-) create mode 100644 src/Jikka/CPlusPlus/Convert.hs rename src/Jikka/Core/{Convert => }/Optimize.hs (76%) create mode 100644 src/Jikka/RestrictedPython/Convert.hs diff --git a/src/Jikka/CPlusPlus/Convert.hs b/src/Jikka/CPlusPlus/Convert.hs new file mode 100644 index 00000000..3234d6e5 --- /dev/null +++ b/src/Jikka/CPlusPlus/Convert.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Jikka.CPlusPlus.Convert + ( run, + ) +where + +import qualified Jikka.CPlusPlus.Convert.FromCore as FromCore +import qualified Jikka.CPlusPlus.Language.Expr as Y +import Jikka.Common.Alpha +import Jikka.Common.Error +import qualified Jikka.Core.Convert.ANormal as ANormal +import qualified Jikka.Core.Language.Expr as X + +run :: (MonadAlpha m, MonadError Error m) => X.Program -> m Y.Program +run prog = do + prog <- ANormal.run prog + FromCore.run prog diff --git a/src/Jikka/Core/Convert/Optimize.hs b/src/Jikka/Core/Optimize.hs similarity index 76% rename from src/Jikka/Core/Convert/Optimize.hs rename to src/Jikka/Core/Optimize.hs index 2a72e3bc..3adeb3f7 100644 --- a/src/Jikka/Core/Convert/Optimize.hs +++ b/src/Jikka/Core/Optimize.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} -- | --- Module : Jikka.Core.Convert.Optimize +-- Module : Jikka.Core.Optimize -- Description : is a meta module to combine other optimizers. -- Copyright : (c) Kimiyuki Onaka, 2020 -- License : Apache License 2.0 @@ -9,19 +9,21 @@ -- Stability : experimental -- Portability : portable -- --- `Jikka.Language.Core.Optimize` is a module to combine other all optimizers. -module Jikka.Core.Convert.Optimize +-- `Jikka.Core.Optimize` is a module to combine other all optimizers. +module Jikka.Core.Optimize ( run, ) where import Jikka.Common.Alpha import Jikka.Common.Error +import qualified Jikka.Core.Convert.Alpha as Alpha import qualified Jikka.Core.Convert.RemoveUnusedVars as RemoveUnusedVars import qualified Jikka.Core.Convert.StrengthReduction as StrengthReduction import Jikka.Core.Language.Expr run :: (MonadAlpha m, MonadError Error m) => Program -> m Program run prog = do + prog <- Alpha.run prog prog <- RemoveUnusedVars.run prog StrengthReduction.run prog diff --git a/src/Jikka/Main/Subcommand/Convert.hs b/src/Jikka/Main/Subcommand/Convert.hs index f68ec72a..b87c0389 100644 --- a/src/Jikka/Main/Subcommand/Convert.hs +++ b/src/Jikka/Main/Subcommand/Convert.hs @@ -1,26 +1,20 @@ module Jikka.Main.Subcommand.Convert (run) where import Data.Text (Text) -import qualified Jikka.CPlusPlus.Convert.FromCore as FromCore +import qualified Jikka.CPlusPlus.Convert as FromCore import qualified Jikka.CPlusPlus.Format as FormatCPlusPlus import Jikka.Common.Alpha import Jikka.Common.Error -import qualified Jikka.Core.Convert.ANormal as ANormal -import qualified Jikka.Core.Convert.Optimize as Optimize +import qualified Jikka.Core.Optimize as Optimize import qualified Jikka.Python.Convert.ToRestrictedPython as ToRestrictedPython import qualified Jikka.Python.Parse as FromPython -import qualified Jikka.RestrictedPython.Convert.Alpha as Alpha -import qualified Jikka.RestrictedPython.Convert.ToCore as ToCore -import qualified Jikka.RestrictedPython.Convert.TypeInfer as TypeInfer +import qualified Jikka.RestrictedPython.Convert as ToCore run :: FilePath -> Text -> Either Error Text run path input = flip evalAlphaT 0 $ do prog <- FromPython.run path input prog <- ToRestrictedPython.run prog - prog <- Alpha.run prog - prog <- TypeInfer.run prog prog <- ToCore.run prog prog <- Optimize.run prog - prog <- ANormal.run prog prog <- FromCore.run prog FormatCPlusPlus.run prog diff --git a/src/Jikka/Main/Subcommand/Debug.hs b/src/Jikka/Main/Subcommand/Debug.hs index 04906ebc..4da1b403 100644 --- a/src/Jikka/Main/Subcommand/Debug.hs +++ b/src/Jikka/Main/Subcommand/Debug.hs @@ -1,52 +1,18 @@ module Jikka.Main.Subcommand.Debug (run) where -import Data.Text (unpack) import qualified Data.Text.IO as T (readFile) -import qualified Jikka.CPlusPlus.Convert.FromCore as FromCore -import qualified Jikka.CPlusPlus.Format as FormatCPlusPlus import Jikka.Common.Alpha import Jikka.Common.Error -import qualified Jikka.Core.Convert.ANormal as ANormal -import qualified Jikka.Core.Convert.RemoveUnusedVars as RemoveUnusedVars -import qualified Jikka.Core.Convert.StrengthReduction as StrengthReduction -import qualified Jikka.Core.Format as FormatCore import qualified Jikka.Python.Convert.ToRestrictedPython as ToRestrictedPython -import qualified Jikka.Python.Parse.Alex as PythonLexer -import qualified Jikka.Python.Parse.Happy as PythonParser -import qualified Jikka.RestrictedPython.Convert.Alpha as Alpha -import qualified Jikka.RestrictedPython.Convert.ToCore as ToCore -import qualified Jikka.RestrictedPython.Convert.TypeInfer as TypeInfer +import qualified Jikka.Python.Parse as FromPython +import qualified Jikka.RestrictedPython.Convert as Convert import qualified Jikka.RestrictedPython.Format as FormatRestrictedPython -put :: MonadIO m => String -> String -> m () -put title message = do - liftIO $ putStrLn (title ++ ":") - let indent = unlines . map (" " ++) . lines - liftIO $ putStrLn (indent message) - run :: FilePath -> ExceptT Error IO () run path = flip evalAlphaT 0 $ do - put "path" $ show path prog <- liftIO $ T.readFile path - put "input" $ unpack prog - prog <- PythonLexer.run (unpack prog) - put "tokens" $ unlines (map show prog) - prog <- PythonParser.run prog - put "parsed" $ show prog + prog <- FromPython.run path prog prog <- ToRestrictedPython.run prog - put "restricted" . unpack =<< FormatRestrictedPython.run prog - prog <- Alpha.run prog - put "alpha" . unpack =<< FormatRestrictedPython.run prog - prog <- TypeInfer.run prog - put "infered types" . unpack =<< FormatRestrictedPython.run prog - prog <- ToCore.run prog - put "core" . unpack =<< FormatCore.run prog - prog <- RemoveUnusedVars.run prog - put "core simplified" . unpack =<< FormatCore.run prog - prog <- StrengthReduction.run prog - put "core reduced" . unpack =<< FormatCore.run prog - prog <- ANormal.run prog - put "simplify for codgen" . unpack =<< FormatCore.run prog - prog <- FromCore.run prog - put "generated code" . unpack =<< FormatCPlusPlus.run prog - return () + prog <- Convert.run' prog + prog <- return $ FormatRestrictedPython.run' prog + liftIO $ putStrLn prog diff --git a/src/Jikka/Main/Subcommand/Execute.hs b/src/Jikka/Main/Subcommand/Execute.hs index 5a0b0734..c8e0db32 100644 --- a/src/Jikka/Main/Subcommand/Execute.hs +++ b/src/Jikka/Main/Subcommand/Execute.hs @@ -8,12 +8,7 @@ import Jikka.Common.Alpha import Jikka.Common.Error import qualified Jikka.Python.Convert.ToRestrictedPython as ToRestrictedPython import qualified Jikka.Python.Parse as FromPython -import qualified Jikka.RestrictedPython.Convert.Alpha as Alpha -import qualified Jikka.RestrictedPython.Convert.RemoveUnbalancedIf as RemoveUnbalancedIf -import qualified Jikka.RestrictedPython.Convert.RemoveUnreachable as RemoveUnreachable -import qualified Jikka.RestrictedPython.Convert.ResolveBuiltin as ResolveBuiltin -import qualified Jikka.RestrictedPython.Convert.SplitLoops as SplitLoops -import qualified Jikka.RestrictedPython.Convert.TypeInfer as TypeInfer +import qualified Jikka.RestrictedPython.Convert as Convert import qualified Jikka.RestrictedPython.Evaluate as Evaluate import qualified Jikka.RestrictedPython.Language.Value as Value @@ -22,12 +17,8 @@ run path = flip evalAlphaT 0 $ do prog <- liftIO $ T.readFile path prog <- liftEither $ FromPython.run path prog prog <- ToRestrictedPython.run prog - prog <- return $ RemoveUnreachable.run prog - prog <- ResolveBuiltin.run prog - prog <- Alpha.run prog - prog <- TypeInfer.run prog - prog <- SplitLoops.run prog - prog <- return $ RemoveUnbalancedIf.run prog + -- TODO: convert it to core + prog <- Convert.run' prog global <- Evaluate.makeGlobal prog entrypoint <- Value.makeEntryPointIO "solve" global value <- Evaluate.runWithGlobal global entrypoint diff --git a/src/Jikka/RestrictedPython/Convert.hs b/src/Jikka/RestrictedPython/Convert.hs new file mode 100644 index 00000000..2a7fc98e --- /dev/null +++ b/src/Jikka/RestrictedPython/Convert.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Jikka.RestrictedPython.Convert + ( run, + run', + ) +where + +import Jikka.Common.Alpha +import Jikka.Common.Error +import qualified Jikka.Core.Language.Expr as Y +import qualified Jikka.RestrictedPython.Convert.Alpha as Alpha +import qualified Jikka.RestrictedPython.Convert.RemoveUnbalancedIf as RemoveUnbalancedIf +import qualified Jikka.RestrictedPython.Convert.RemoveUnreachable as RemoveUnreachable +import qualified Jikka.RestrictedPython.Convert.ResolveBuiltin as ResolveBuiltin +import qualified Jikka.RestrictedPython.Convert.SplitLoops as SplitLoops +import qualified Jikka.RestrictedPython.Convert.ToCore as ToCore +import qualified Jikka.RestrictedPython.Convert.TypeInfer as TypeInfer +import qualified Jikka.RestrictedPython.Language.Expr as X + +run' :: (MonadAlpha m, MonadError Error m) => X.Program -> m X.Program +run' prog = do + prog <- return $ RemoveUnreachable.run prog + prog <- return $ RemoveUnbalancedIf.run prog + prog <- ResolveBuiltin.run prog + prog <- Alpha.run prog + prog <- TypeInfer.run prog + SplitLoops.run prog + +run :: (MonadAlpha m, MonadError Error m) => X.Program -> m Y.Program +run prog = do + prog <- run' prog + ToCore.run prog From 8ffd1e77d2a3672dda99b152392d19236592004d Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 06:35:25 +0900 Subject: [PATCH 36/56] feat: Improve error messages --- src/Jikka/Core/Convert/ANormal.hs | 2 +- src/Jikka/Core/Convert/Alpha.hs | 2 +- src/Jikka/Core/Convert/MakeEager.hs | 4 +++- src/Jikka/Core/Convert/RemoveUnusedVars.hs | 4 +++- src/Jikka/Core/Convert/StrengthReduction.hs | 4 +++- src/Jikka/RestrictedPython/Convert/SplitLoops.hs | 2 +- src/Jikka/RestrictedPython/Convert/ToCore.hs | 2 +- src/Jikka/RestrictedPython/Convert/TypeInfer.hs | 2 +- 8 files changed, 14 insertions(+), 8 deletions(-) diff --git a/src/Jikka/Core/Convert/ANormal.hs b/src/Jikka/Core/Convert/ANormal.hs index f52a0052..11eca278 100644 --- a/src/Jikka/Core/Convert/ANormal.hs +++ b/src/Jikka/Core/Convert/ANormal.hs @@ -83,7 +83,7 @@ runToplevelExpr env = \case return $ ToplevelLetRec f args ret body cont run :: (MonadAlpha m, MonadError Error m) => Program -> m Program -run prog = do +run prog = wrapError' "Jikka.Core.Convert.ANormal" $ do prog <- Alpha.runProgram prog prog <- runToplevelExpr [] prog typecheckProgram' prog diff --git a/src/Jikka/Core/Convert/Alpha.hs b/src/Jikka/Core/Convert/Alpha.hs index 9223f331..5a6c0d13 100644 --- a/src/Jikka/Core/Convert/Alpha.hs +++ b/src/Jikka/Core/Convert/Alpha.hs @@ -77,6 +77,6 @@ runProgram :: (MonadAlpha m, MonadError Error m) => Program -> m Program runProgram = runToplevelExpr [] run :: (MonadAlpha m, MonadError Error m) => Program -> m Program -run prog = do +run prog = wrapError' "Jikka.Core.Convert.Alpha" $ do prog <- runToplevelExpr [] prog typecheckProgram' prog diff --git a/src/Jikka/Core/Convert/MakeEager.hs b/src/Jikka/Core/Convert/MakeEager.hs index c59a50d5..840c860c 100644 --- a/src/Jikka/Core/Convert/MakeEager.hs +++ b/src/Jikka/Core/Convert/MakeEager.hs @@ -60,4 +60,6 @@ run' = runToplevelExpr -- > )() -- > in fact 10 run :: MonadError Error m => Program -> m Program -run = typecheckProgram' . run' +run prog = wrapError' "Jikka.Core.Convert.MakeEager" $ do + prog <- return $ run' prog + typecheckProgram' prog diff --git a/src/Jikka/Core/Convert/RemoveUnusedVars.hs b/src/Jikka/Core/Convert/RemoveUnusedVars.hs index 5165a277..70fa7107 100644 --- a/src/Jikka/Core/Convert/RemoveUnusedVars.hs +++ b/src/Jikka/Core/Convert/RemoveUnusedVars.hs @@ -67,4 +67,6 @@ run' = runToplevelExpr -- > x -- > in solve run :: MonadError Error m => Program -> m Program -run = typecheckProgram' . run' +run prog = wrapError' "Jikka.Core.Convert.RemoveUnusedVars" $ do + prog <- return $ run' prog + typecheckProgram' prog diff --git a/src/Jikka/Core/Convert/StrengthReduction.hs b/src/Jikka/Core/Convert/StrengthReduction.hs index 9a57f4c9..739bcf62 100644 --- a/src/Jikka/Core/Convert/StrengthReduction.hs +++ b/src/Jikka/Core/Convert/StrengthReduction.hs @@ -224,4 +224,6 @@ weakenToplevelExpr e = case e of ToplevelLetRec f args ret body cont -> ToplevelLetRec f args ret (weakenExpr body) (weakenToplevelExpr cont) run :: MonadError Error m => Program -> m Program -run = typecheckProgram' . weakenToplevelExpr +run prog = wrapError' "Jikka.Core.Convert.StrengthReduction" $ do + prog <- return $ weakenToplevelExpr prog + typecheckProgram' prog diff --git a/src/Jikka/RestrictedPython/Convert/SplitLoops.hs b/src/Jikka/RestrictedPython/Convert/SplitLoops.hs index 9e2a20bf..a69b1823 100644 --- a/src/Jikka/RestrictedPython/Convert/SplitLoops.hs +++ b/src/Jikka/RestrictedPython/Convert/SplitLoops.hs @@ -57,7 +57,7 @@ run' = mapLargeStatement (\e pred1 pred2 -> [If e pred1 pred2]) runForLoop -- | `run` does alpha conversion, check assumptions, and `run'`. run :: (MonadAlpha m, MonadError Error m) => Program -> m Program -run prog = do +run prog = wrapError' "Jikka.RestrictedPython.Convert.SplitLoops" $ do prog <- Alpha.run prog ensureDoesntHaveSubscriptionInLoopCounters prog ensureDoesntHaveAssignmentToLoopCounters prog diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index d11bd26e..5ef259a1 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -376,7 +376,7 @@ runToplevelStatements (stmt : stmts) = case stmt of -- > fst (foldl (fun (a, b) i -> (b, a + b)) (0, 1) [0 .. n - 1]) -- > in solve run :: (MonadAlpha m, MonadError Error m) => X.Program -> m Y.Program -run prog = do +run prog = wrapError' "Jikka.RestrictedPython.Convert.ToCore" $ do X.ensureDoesntHaveSubscriptionInLoopCounters prog X.ensureDoesntHaveLeakOfLoopCounters prog X.ensureDoesntHaveAssignmentToLoopCounters prog diff --git a/src/Jikka/RestrictedPython/Convert/TypeInfer.hs b/src/Jikka/RestrictedPython/Convert/TypeInfer.hs index 62e90608..3ef0fbb0 100644 --- a/src/Jikka/RestrictedPython/Convert/TypeInfer.hs +++ b/src/Jikka/RestrictedPython/Convert/TypeInfer.hs @@ -339,7 +339,7 @@ substProgram sigma gamma prog = map (substToplevelStatement sigma gamma) prog -- -- In its implementation, this function works like a Hindley-Milner type inference. run :: (MonadAlpha m, MonadError Error m) => Program -> m Program -run prog = do +run prog = wrapError' "Jikka.RestrictedPython.Convert.TypeInfer" $ do eqns <- formularizeProgram prog let (eqns', assertions) = sortEquations eqns let (gamma, eqns'') = makeGamma assertions From 8789cff0a85308cffac79b35da202db3577b7669 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 06:37:06 +0900 Subject: [PATCH 37/56] fix: Fix the usage --- src/Jikka/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Jikka/Main.hs b/src/Jikka/Main.hs index 3ba1514f..2342629b 100644 --- a/src/Jikka/Main.hs +++ b/src/Jikka/Main.hs @@ -29,7 +29,7 @@ defaultOptions = } header :: String -> String -header progName = "Usage: " ++ progName ++ " [convert | debug | exec] FILE" +header progName = "Usage: " ++ progName ++ " [convert | debug | execute] FILE" options :: [OptDescr Flag] options = From 7ba697c42f5ff93b122b6573ae4433b555f7d40d Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 07:45:29 +0900 Subject: [PATCH 38/56] feat: Add --target option --- examples/test.sh | 3 +- src/Jikka/Main.hs | 24 ++++++++++----- src/Jikka/Main/Subcommand/Convert.hs | 42 ++++++++++++++++++++++--- src/Jikka/Main/Subcommand/Execute.hs | 46 +++++++++++++++++++++------- src/Jikka/Main/Target.hs | 20 ++++++++++++ 5 files changed, 111 insertions(+), 24 deletions(-) create mode 100644 src/Jikka/Main/Target.hs diff --git a/examples/test.sh b/examples/test.sh index cf453c0c..7db630a6 100644 --- a/examples/test.sh +++ b/examples/test.sh @@ -1,5 +1,6 @@ #!/bin/bash set -ex for f in examples/*.in ; do - diff <(stack --system-ghc run execute ${f%.in}.py < $f) ${f%.in}.out + diff <(stack --system-ghc run -- execute --target rpython ${f%.in}.py < $f) ${f%.in}.out + # diff <(stack --system-ghc run -- execute --target core ${f%.in}.py < $f) ${f%.in}.out done diff --git a/src/Jikka/Main.hs b/src/Jikka/Main.hs index 2342629b..c4a7fc5e 100644 --- a/src/Jikka/Main.hs +++ b/src/Jikka/Main.hs @@ -1,5 +1,6 @@ module Jikka.Main where +import Data.Maybe (fromMaybe) import qualified Data.Text.IO as T import Data.Version (showVersion) import Jikka.Common.Error @@ -7,6 +8,7 @@ import Jikka.Common.Format.Error (prettyError, prettyErrorWithText) import qualified Jikka.Main.Subcommand.Convert as Convert import qualified Jikka.Main.Subcommand.Debug as Debug import qualified Jikka.Main.Subcommand.Execute as Execute +import Jikka.Main.Target import Paths_Jikka (version) import System.Console.GetOpt import System.Exit (ExitCode (..)) @@ -16,16 +18,20 @@ data Flag = Help | Verbose | Version + | Target String deriving (Eq, Ord, Show, Read) -newtype Options = Options - { verbose :: Bool +data Options = Options + { verbose :: Bool, + target :: Maybe Target } + deriving (Eq, Ord, Show, Read) defaultOptions :: Options defaultOptions = Options - { verbose = False + { verbose = False, + target = Nothing } header :: String -> String @@ -35,7 +41,8 @@ options :: [OptDescr Flag] options = [ Option ['h', '?'] ["help"] (NoArg Help) "", Option ['v'] ["verbose"] (NoArg Verbose) "", - Option [] ["version"] (NoArg Version) "" + Option [] ["version"] (NoArg Version) "", + Option [] ["target"] (ReqArg Target "TARGET") "\"python\", \"rpython\", \"core\" or \"cxx\"" ] main :: String -> [String] -> IO ExitCode @@ -79,13 +86,16 @@ parseFlags _ = go defaultOptions Help -> throwCommandLineError "parseFlags is not called when --help is specified" Version -> throwCommandLineError "parseFlags is not called when --version is specified" Verbose -> go (opts {verbose = True}) flags + Target target -> do + target <- parseTarget target + go (opts {target = Just target}) flags runSubcommand :: String -> Options -> FilePath -> ExceptT Error IO () -runSubcommand subcmd _ path = case subcmd of +runSubcommand subcmd opts path = case subcmd of "convert" -> do input <- liftIO $ T.readFile path - output <- liftEither $ Convert.run path input + output <- liftEither $ Convert.run (fromMaybe CPlusPlusTarget (target opts)) path input liftIO $ T.putStr output "debug" -> Debug.run path - "execute" -> Execute.run path + "execute" -> Execute.run (fromMaybe CoreTarget (target opts)) path _ -> throwCommandLineError $ "undefined subcommand: " ++ show subcmd diff --git a/src/Jikka/Main/Subcommand/Convert.hs b/src/Jikka/Main/Subcommand/Convert.hs index b87c0389..74afdd86 100644 --- a/src/Jikka/Main/Subcommand/Convert.hs +++ b/src/Jikka/Main/Subcommand/Convert.hs @@ -1,20 +1,52 @@ +{-# LANGUAGE LambdaCase #-} + module Jikka.Main.Subcommand.Convert (run) where -import Data.Text (Text) +import Data.Text (Text, pack) import qualified Jikka.CPlusPlus.Convert as FromCore import qualified Jikka.CPlusPlus.Format as FormatCPlusPlus import Jikka.Common.Alpha import Jikka.Common.Error +import qualified Jikka.Core.Format as FormatCore import qualified Jikka.Core.Optimize as Optimize +import Jikka.Main.Target import qualified Jikka.Python.Convert.ToRestrictedPython as ToRestrictedPython -import qualified Jikka.Python.Parse as FromPython +import qualified Jikka.Python.Parse as ParsePython import qualified Jikka.RestrictedPython.Convert as ToCore +import qualified Jikka.RestrictedPython.Format as FormatRestrictedPython + +runPython :: FilePath -> Text -> Either Error Text +runPython path input = flip evalAlphaT 0 $ do + prog <- ParsePython.run path input + return . pack $ show prog -- TODO -run :: FilePath -> Text -> Either Error Text -run path input = flip evalAlphaT 0 $ do - prog <- FromPython.run path input +runRestrictedPython :: FilePath -> Text -> Either Error Text +runRestrictedPython path input = flip evalAlphaT 0 $ do + prog <- ParsePython.run path input + prog <- ToRestrictedPython.run prog + prog <- ToCore.run' prog + FormatRestrictedPython.run prog + +runCore :: FilePath -> Text -> Either Error Text +runCore path input = flip evalAlphaT 0 $ do + prog <- ParsePython.run path input + prog <- ToRestrictedPython.run prog + prog <- ToCore.run prog + prog <- Optimize.run prog + FormatCore.run prog + +runCPlusPlus :: FilePath -> Text -> Either Error Text +runCPlusPlus path input = flip evalAlphaT 0 $ do + prog <- ParsePython.run path input prog <- ToRestrictedPython.run prog prog <- ToCore.run prog prog <- Optimize.run prog prog <- FromCore.run prog FormatCPlusPlus.run prog + +run :: Target -> FilePath -> Text -> Either Error Text +run = \case + PythonTarget -> runPython + RestrictedPythonTarget -> runRestrictedPython + CoreTarget -> runCore + CPlusPlusTarget -> runCPlusPlus diff --git a/src/Jikka/Main/Subcommand/Execute.hs b/src/Jikka/Main/Subcommand/Execute.hs index c8e0db32..8959817d 100644 --- a/src/Jikka/Main/Subcommand/Execute.hs +++ b/src/Jikka/Main/Subcommand/Execute.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Jikka.Main.Subcommand.Execute (run) where @@ -6,20 +7,43 @@ import Control.Monad.Except import qualified Data.Text.IO as T (readFile) import Jikka.Common.Alpha import Jikka.Common.Error +import qualified Jikka.Core.Evaluate as EvaluateCore +import Jikka.Main.Target import qualified Jikka.Python.Convert.ToRestrictedPython as ToRestrictedPython import qualified Jikka.Python.Parse as FromPython -import qualified Jikka.RestrictedPython.Convert as Convert -import qualified Jikka.RestrictedPython.Evaluate as Evaluate -import qualified Jikka.RestrictedPython.Language.Value as Value +import qualified Jikka.RestrictedPython.Convert as ToCore +import qualified Jikka.RestrictedPython.Evaluate as EvaluateRestrictedPython +import qualified Jikka.RestrictedPython.Language.Value as ValueRestrictedPythong -run :: FilePath -> ExceptT Error IO () -run path = flip evalAlphaT 0 $ do +runPython :: FilePath -> ExceptT Error IO () +runPython _ = throwCommandLineError "cannot execute Python" + +runRestrictedPython :: FilePath -> ExceptT Error IO () +runRestrictedPython path = flip evalAlphaT 0 $ do prog <- liftIO $ T.readFile path prog <- liftEither $ FromPython.run path prog prog <- ToRestrictedPython.run prog - -- TODO: convert it to core - prog <- Convert.run' prog - global <- Evaluate.makeGlobal prog - entrypoint <- Value.makeEntryPointIO "solve" global - value <- Evaluate.runWithGlobal global entrypoint - liftIO $ Value.writeValueIO value + prog <- ToCore.run' prog + global <- EvaluateRestrictedPython.makeGlobal prog + entrypoint <- ValueRestrictedPythong.makeEntryPointIO "solve" global + value <- EvaluateRestrictedPython.runWithGlobal global entrypoint + liftIO $ ValueRestrictedPythong.writeValueIO value + +runCore :: FilePath -> ExceptT Error IO () +runCore path = flip evalAlphaT 0 $ do + prog <- liftIO $ T.readFile path + prog <- liftEither $ FromPython.run path prog + prog <- ToRestrictedPython.run prog + prog <- ToCore.run prog + value <- EvaluateCore.run prog + liftIO $ print value + +runCPlusPlus :: FilePath -> ExceptT Error IO () +runCPlusPlus _ = throwCommandLineError "cannot execute C++" + +run :: Target -> FilePath -> ExceptT Error IO () +run = \case + PythonTarget -> runPython + RestrictedPythonTarget -> runRestrictedPython + CoreTarget -> runCore + CPlusPlusTarget -> runCPlusPlus diff --git a/src/Jikka/Main/Target.hs b/src/Jikka/Main/Target.hs new file mode 100644 index 00000000..7b8a4bcd --- /dev/null +++ b/src/Jikka/Main/Target.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE LambdaCase #-} + +module Jikka.Main.Target where + +import Jikka.Common.Error + +data Target + = PythonTarget + | RestrictedPythonTarget + | CoreTarget + | CPlusPlusTarget + deriving (Eq, Ord, Show, Read) + +parseTarget :: String -> Either Error Target +parseTarget = \case + "python" -> return PythonTarget + "rpython" -> return RestrictedPythonTarget + "core" -> return CoreTarget + "cxx" -> return CPlusPlusTarget + s -> throwCommandLineError $ "invalid target: " ++ s From 392c0fdd4d56d1ac118b70c56bfd8dbdae8bdb33 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 07:56:16 +0900 Subject: [PATCH 39/56] feat(core): Add formatValue for core --- src/Jikka/Core/Evaluate.hs | 38 +------------------- src/Jikka/Core/Language/Value.hs | 53 ++++++++++++++++++++++++++++ src/Jikka/Main/Subcommand/Execute.hs | 3 +- 3 files changed, 56 insertions(+), 38 deletions(-) create mode 100644 src/Jikka/Core/Language/Value.hs diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index 81fde0f1..54579d97 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -32,43 +32,9 @@ import qualified Data.Vector as V import Jikka.Common.Error import Jikka.Core.Language.Expr import Jikka.Core.Language.Lint (builtinToType) +import Jikka.Core.Language.Value import Text.Read (readEither) --- ----------------------------------------------------------------------------- --- values - -data Value - = ValInt Integer - | ValBool Bool - | ValList (V.Vector Value) - | ValTuple [Value] - | ValBuiltin Builtin - | ValLambda Env [(VarName, Type)] Expr - deriving (Eq, Ord, Show, Read) - -literalToValue :: Literal -> Value -literalToValue = \case - LitBuiltin builtin -> ValBuiltin builtin - LitInt n -> ValInt n - LitBool p -> ValBool p - LitNil _ -> ValList V.empty - -valueToInt :: MonadError Error m => Value -> m Integer -valueToInt = \case - ValInt n -> return n - val -> throwRuntimeError $ "Internal Error: not int: " ++ show val - -valueToIntList :: MonadError Error m => V.Vector Value -> m [Integer] -valueToIntList = mapM valueToInt . V.toList - -valueToBool :: MonadError Error m => Value -> m Bool -valueToBool = \case - ValBool p -> return p - val -> throwRuntimeError $ "Internal Error: not bool: " ++ show val - -valueToBoolList :: MonadError Error m => V.Vector Value -> m [Bool] -valueToBoolList = mapM valueToBool . V.toList - -- ----------------------------------------------------------------------------- -- inputs @@ -218,8 +184,6 @@ multichoose n r = choose (n + r - 1) r -- ----------------------------------------------------------------------------- -- evaluator -type Env = [(VarName, Value)] - callBuiltin :: MonadError Error m => Builtin -> [Value] -> m Value callBuiltin builtin args = case (builtin, args) of -- arithmetical functions diff --git a/src/Jikka/Core/Language/Value.hs b/src/Jikka/Core/Language/Value.hs new file mode 100644 index 00000000..a9b8285b --- /dev/null +++ b/src/Jikka/Core/Language/Value.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} + +module Jikka.Core.Language.Value where + +import Data.Char (toLower) +import Data.List (intercalate) +import qualified Data.Vector as V +import Jikka.Common.Error +import Jikka.Core.Language.Expr + +data Value + = ValInt Integer + | ValBool Bool + | ValList (V.Vector Value) + | ValTuple [Value] + | ValBuiltin Builtin + | ValLambda Env [(VarName, Type)] Expr + deriving (Eq, Ord, Show, Read) + +type Env = [(VarName, Value)] + +literalToValue :: Literal -> Value +literalToValue = \case + LitBuiltin builtin -> ValBuiltin builtin + LitInt n -> ValInt n + LitBool p -> ValBool p + LitNil _ -> ValList V.empty + +valueToInt :: MonadError Error m => Value -> m Integer +valueToInt = \case + ValInt n -> return n + val -> throwRuntimeError $ "Internal Error: not int: " ++ show val + +valueToIntList :: MonadError Error m => V.Vector Value -> m [Integer] +valueToIntList = mapM valueToInt . V.toList + +valueToBool :: MonadError Error m => Value -> m Bool +valueToBool = \case + ValBool p -> return p + val -> throwRuntimeError $ "Internal Error: not bool: " ++ show val + +valueToBoolList :: MonadError Error m => V.Vector Value -> m [Bool] +valueToBoolList = mapM valueToBool . V.toList + +formatValue :: Value -> String +formatValue = \case + ValInt n -> show n + ValBool p -> map toLower (show p) + ValList xs -> intercalate "\n" (map formatValue (V.toList xs)) + ValTuple xs -> intercalate "\n" (map formatValue xs) + ValBuiltin builtin -> show builtin + f@ValLambda {} -> show f diff --git a/src/Jikka/Main/Subcommand/Execute.hs b/src/Jikka/Main/Subcommand/Execute.hs index 8959817d..5c36321c 100644 --- a/src/Jikka/Main/Subcommand/Execute.hs +++ b/src/Jikka/Main/Subcommand/Execute.hs @@ -8,6 +8,7 @@ import qualified Data.Text.IO as T (readFile) import Jikka.Common.Alpha import Jikka.Common.Error import qualified Jikka.Core.Evaluate as EvaluateCore +import qualified Jikka.Core.Language.Value as ValueCore import Jikka.Main.Target import qualified Jikka.Python.Convert.ToRestrictedPython as ToRestrictedPython import qualified Jikka.Python.Parse as FromPython @@ -36,7 +37,7 @@ runCore path = flip evalAlphaT 0 $ do prog <- ToRestrictedPython.run prog prog <- ToCore.run prog value <- EvaluateCore.run prog - liftIO $ print value + liftIO $ putStrLn (ValueCore.formatValue value) runCPlusPlus :: FilePath -> ExceptT Error IO () runCPlusPlus _ = throwCommandLineError "cannot execute C++" From 61eccf4924cb22d4715298243c95f13866f36c30 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 08:00:08 +0900 Subject: [PATCH 40/56] docs(core): Fix documentation of Jikka.Core.Language.Expr --- src/Jikka/Core/Language/Expr.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs index 205424ba..a236830c 100644 --- a/src/Jikka/Core/Language/Expr.hs +++ b/src/Jikka/Core/Language/Expr.hs @@ -128,9 +128,9 @@ data Builtin -- | \(: \forall \alpha. \alpha \times \list(\alpha) \to \list(\alpha)\) Cons Type - | -- | \(: \foall \alpha \beta. (\beta \times \alpha \to \beta) \times \beta \times \list(\alpha) \to \beta\) + | -- | \(: \forall \alpha \beta. (\beta \times \alpha \to \beta) \times \beta \times \list(\alpha) \to \beta\) Foldl Type Type - | -- | \(: \foall \alpha \beta. (\beta \times \alpha \to \beta) \times \beta \times \list(\alpha) \to \list(\beta)\) + | -- | \(: \forall \alpha \beta. (\beta \times \alpha \to \beta) \times \beta \times \list(\alpha) \to \list(\beta)\) Scanl Type Type | -- | \(: \forall \alpha. \list(\alpha) \to \int\) Len Type @@ -292,7 +292,7 @@ pattern LamId x t <- -- \begin{array}{rl} -- \mathrm{tle} ::= & e \\ -- \vert & \mathbf{let}~ x: \tau = e ~\mathbf{in}~ \mathrm{tle} \\ --- \vert & \mathbf{letrec}~ x(x: \tau, x: \tau, \dots, x: \tau): \tau = e ~\mathbf{in}~ \mathrm{tle} +-- \vert & \mathbf{let~rec}~ x(x: \tau, x: \tau, \dots, x: \tau): \tau = e ~\mathbf{in}~ \mathrm{tle} -- \end{array} -- \] data ToplevelExpr From 2f6eb583b38a9d7da37cb43193aca1950d6c61ba Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 08:07:05 +0900 Subject: [PATCH 41/56] fix(core): Improve error messages from Jikka.Core.Language.Lint --- src/Jikka/Core/Language/Lint.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Jikka/Core/Language/Lint.hs b/src/Jikka/Core/Language/Lint.hs index fd1698ed..7afe4c1a 100644 --- a/src/Jikka/Core/Language/Lint.hs +++ b/src/Jikka/Core/Language/Lint.hs @@ -138,9 +138,10 @@ typecheckToplevelExpr env = \case typecheckToplevelExpr ((x, t) : env) cont typecheckProgram :: MonadError Error m => Program -> m Type -typecheckProgram = typecheckToplevelExpr [] +typecheckProgram prog = wrapError' "Jikka.Core.Language.Lint" $ do + typecheckToplevelExpr [] prog typecheckProgram' :: MonadError Error m => Program -> m Program -typecheckProgram' prog = do - typecheckProgram prog +typecheckProgram' prog = wrapError' "Jikka.Core.Language.Lint" $ do + typecheckToplevelExpr [] prog return prog From bf31ad279c33f258ce56497e52110e8880feb709 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 08:52:02 +0900 Subject: [PATCH 42/56] feat(core): Use '$' instead of '@' in alpha-conversion --- src/Jikka/Core/Convert/Alpha.hs | 4 ++-- test/Jikka/Core/Convert/ANormalSpec.hs | 10 +++++----- test/Jikka/Core/Convert/AlphaSpec.hs | 8 ++++---- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Jikka/Core/Convert/Alpha.hs b/src/Jikka/Core/Convert/Alpha.hs index 5a6c0d13..68ed322b 100644 --- a/src/Jikka/Core/Convert/Alpha.hs +++ b/src/Jikka/Core/Convert/Alpha.hs @@ -27,8 +27,8 @@ rename hint = rename' hint <$> nextCounter rename' :: VarName -> Int -> VarName rename' hint i = - let base = takeWhile (/= '@') (unVarName hint) - in VarName (base ++ "@" ++ show i) + let base = takeWhile (/= '$') (unVarName hint) + in VarName (base ++ "$" ++ show i) -- ----------------------------------------------------------------------------- -- run diff --git a/test/Jikka/Core/Convert/ANormalSpec.hs b/test/Jikka/Core/Convert/ANormalSpec.hs index 366b1a3a..d849bcdd 100644 --- a/test/Jikka/Core/Convert/ANormalSpec.hs +++ b/test/Jikka/Core/Convert/ANormalSpec.hs @@ -25,9 +25,9 @@ spec = describe "run" $ do (App (Lam1 "x" IntTy (Var "x")) [Lit1]) let expected = ResultExpr $ - Let "x@0" IntTy Lit1 $ - Let "@3" (Fun1Ty IntTy) (Lam1 "x@1" IntTy (Var "x@1")) $ - Let "@2" (Fun1Ty IntTy) (Var "@3") $ - Let "@4" IntTy (App (Var "@2") [Lit1]) $ - Plus' (Var "x@0") (Var "@4") + Let "x$0" IntTy Lit1 $ + Let "$3" (Fun1Ty IntTy) (Lam1 "x$1" IntTy (Var "x$1")) $ + Let "$2" (Fun1Ty IntTy) (Var "$3") $ + Let "$4" IntTy (App (Var "$2") [Lit1]) $ + Plus' (Var "x$0") (Var "$4") run' input `shouldBe` Right expected diff --git a/test/Jikka/Core/Convert/AlphaSpec.hs b/test/Jikka/Core/Convert/AlphaSpec.hs index 276bde90..1c40e06a 100644 --- a/test/Jikka/Core/Convert/AlphaSpec.hs +++ b/test/Jikka/Core/Convert/AlphaSpec.hs @@ -34,14 +34,14 @@ spec = describe "run" $ do let expected = ResultExpr ( Let - "x@0" + "x$0" IntTy Lit0 ( Let - "x@1" + "x$1" IntTy - (Plus' (Var "x@0") Lit1) - (Var "x@1") + (Plus' (Var "x$0") Lit1) + (Var "x$1") ) ) run' input `shouldBe` Right expected From 7dda1a599db43fc9d6fbfbb6adccbe46e8b43269 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 10:00:03 +0900 Subject: [PATCH 43/56] refactor(rpython): Simplify Jikka.RestrictedPython.Convert.TypeInfer --- .../RestrictedPython/Convert/TypeInfer.hs | 77 ++++++++----------- 1 file changed, 31 insertions(+), 46 deletions(-) diff --git a/src/Jikka/RestrictedPython/Convert/TypeInfer.hs b/src/Jikka/RestrictedPython/Convert/TypeInfer.hs index 3ef0fbb0..52d5c5db 100644 --- a/src/Jikka/RestrictedPython/Convert/TypeInfer.hs +++ b/src/Jikka/RestrictedPython/Convert/TypeInfer.hs @@ -13,14 +13,11 @@ module Jikka.RestrictedPython.Convert.TypeInfer ( run, Equation (..), formularizeProgram, - Env (..), sortEquations, - makeGamma, + mergeAssertions, Subst (..), subst, solveEquations, - substGamma, - substUnitGamma, substProgram, ) where @@ -195,9 +192,6 @@ formularizeToplevelStatement = \case formularizeProgram :: MonadAlpha m => Program -> m [Equation] formularizeProgram prog = getDual <$> execWriterT (mapM_ formularizeToplevelStatement prog) --- | `Env` is type environments. It's a mapping from variables to their types. -newtype Env = Env {unEnv :: M.Map VarName Type} - sortEquations :: [Equation] -> ([(Type, Type)], [(VarName, Type)]) sortEquations = go [] [] where @@ -206,10 +200,10 @@ sortEquations = go [] [] TypeEquation t1 t2 -> go ((t1, t2) : eqns') assertions eqns TypeAssertion x t -> go eqns' ((x, t) : assertions) eqns -makeGamma :: [(VarName, Type)] -> (Env, [(Type, Type)]) -makeGamma = go M.empty [] +mergeAssertions :: [(VarName, Type)] -> [(Type, Type)] +mergeAssertions = go M.empty [] where - go gamma eqns [] = (Env gamma, eqns) + go _ eqns [] = eqns go gamma eqns ((x, t) : assertions) = case M.lookup x gamma of Nothing -> go (M.insert x t gamma) eqns assertions Just t' -> go gamma ((t, t') : eqns) assertions @@ -264,9 +258,6 @@ solveEquations :: MonadError Error m => [(Type, Type)] -> m Subst solveEquations eqns = wrapError' "failed to solve type equations" $ do execStateT (mapM_ (uncurry unifyType) eqns) (Subst M.empty) -substGamma :: Subst -> Env -> Env -substGamma sigma gamma = Env (M.map (subst sigma) (unEnv gamma)) - -- | `substUnit` replaces all undetermined type variables with the unit type. substUnit :: Type -> Type substUnit = \case @@ -277,22 +268,18 @@ substUnit = \case TupleTy ts -> TupleTy (map substUnit ts) CallableTy ts ret -> CallableTy (map substUnit ts) (substUnit ret) --- | `substUnitGamma` replaces all undetermined type variables with the unit type. -substUnitGamma :: Env -> Env -substUnitGamma gamma = Env (M.map substUnit (unEnv gamma)) - --- | `subst'` replaces all undetermined type variables with the unit type. +-- | `subst'` does `subst` and replaces all undetermined type variables with the unit type. subst' :: Subst -> Type -> Type subst' sigma = substUnit . subst sigma -substTarget :: Subst -> Env -> Target -> Target -substTarget sigma gamma = \case - SubscriptTrg f index -> SubscriptTrg (substTarget sigma gamma f) (substExpr sigma gamma index) +substTarget :: Subst -> Target -> Target +substTarget sigma = \case + SubscriptTrg f index -> SubscriptTrg (substTarget sigma f) (substExpr sigma index) NameTrg x -> NameTrg x - TupleTrg xs -> TupleTrg (map (substTarget sigma gamma) xs) + TupleTrg xs -> TupleTrg (map (substTarget sigma) xs) -substExpr :: Subst -> Env -> Expr -> Expr -substExpr sigma gamma = go +substExpr :: Subst -> Expr -> Expr +substExpr sigma = go where go = \case BoolOp e1 op e2 -> BoolOp (go e1) op (go e2) @@ -300,7 +287,7 @@ substExpr sigma gamma = go UnaryOp op e -> UnaryOp op (go e) Lambda args body -> Lambda (map (second (subst' sigma)) args) (go body) IfExp e1 e2 e3 -> IfExp (go e1) (go e2) (go e3) - ListComp e (Comprehension x iter pred) -> ListComp (go e) (Comprehension (substTarget sigma gamma x) (go iter) (fmap go pred)) + ListComp e (Comprehension x iter pred) -> ListComp (go e) (Comprehension (substTarget sigma x) (go iter) (fmap go pred)) Compare e1 op e2 -> Compare (go e1) op (go e2) Call f args -> Call (go f) (map go args) Constant const -> Constant const @@ -310,40 +297,38 @@ substExpr sigma gamma = go Tuple es -> Tuple (map go es) SubscriptSlice e from to step -> SubscriptSlice (go e) (fmap go from) (fmap go to) (fmap go step) -substStatement :: Subst -> Env -> Statement -> Statement -substStatement sigma gamma = \case - Return e -> Return (substExpr sigma gamma e) - AugAssign x op e -> AugAssign (substTarget sigma gamma x) op (substExpr sigma gamma e) - AnnAssign x t e -> AnnAssign (substTarget sigma gamma x) (subst' sigma t) (substExpr sigma gamma e) - For x iter body -> For (substTarget sigma gamma x) (substExpr sigma gamma iter) (map (substStatement sigma gamma) body) - If pred body1 body2 -> If (substExpr sigma gamma pred) (map (substStatement sigma gamma) body1) (map (substStatement sigma gamma) body2) - Assert e -> Assert (substExpr sigma gamma e) +substStatement :: Subst -> Statement -> Statement +substStatement sigma = \case + Return e -> Return (substExpr sigma e) + AugAssign x op e -> AugAssign (substTarget sigma x) op (substExpr sigma e) + AnnAssign x t e -> AnnAssign (substTarget sigma x) (subst' sigma t) (substExpr sigma e) + For x iter body -> For (substTarget sigma x) (substExpr sigma iter) (map (substStatement sigma) body) + If pred body1 body2 -> If (substExpr sigma pred) (map (substStatement sigma) body1) (map (substStatement sigma) body2) + Assert e -> Assert (substExpr sigma e) -substToplevelStatement :: Subst -> Env -> ToplevelStatement -> ToplevelStatement -substToplevelStatement sigma gamma = \case - ToplevelAnnAssign x t e -> ToplevelAnnAssign x (subst' sigma t) (substExpr sigma gamma e) - ToplevelFunctionDef f args ret body -> ToplevelFunctionDef f (map (second (subst' sigma)) args) (subst' sigma ret) (map (substStatement sigma gamma) body) - ToplevelAssert e -> ToplevelAssert (substExpr sigma gamma e) +substToplevelStatement :: Subst -> ToplevelStatement -> ToplevelStatement +substToplevelStatement sigma = \case + ToplevelAnnAssign x t e -> ToplevelAnnAssign x (subst' sigma t) (substExpr sigma e) + ToplevelFunctionDef f args ret body -> ToplevelFunctionDef f (map (second (subst' sigma)) args) (subst' sigma ret) (map (substStatement sigma) body) + ToplevelAssert e -> ToplevelAssert (substExpr sigma e) -substProgram :: Subst -> Env -> Program -> Program -substProgram sigma gamma prog = map (substToplevelStatement sigma gamma) prog +substProgram :: Subst -> Program -> Program +substProgram sigma prog = map (substToplevelStatement sigma) prog -- | `run` infers types of given programs. -- -- There must be no name conflicts in given programs. They must be alpha-converted. -- --- As its interface, this function works as follows: +-- As the interface, you can understand this function does the following: -- -- 1. Finds a type environment \(\Gamma\) s.t. for all statement \(\mathrm{stmt}\) in the given program, \(\Gamma \vdash \mathrm{stmt}\) holds, and -- 2. Annotates each variable in the program using the \(\Gamma\). -- --- In its implementation, this function works like a Hindley-Milner type inference. +-- In its implementation, this is just something like a Hindley-Milner type inference. run :: (MonadAlpha m, MonadError Error m) => Program -> m Program run prog = wrapError' "Jikka.RestrictedPython.Convert.TypeInfer" $ do eqns <- formularizeProgram prog let (eqns', assertions) = sortEquations eqns - let (gamma, eqns'') = makeGamma assertions + let eqns'' = mergeAssertions assertions sigma <- solveEquations (eqns' ++ eqns'') - let gamma' = substGamma sigma gamma - let gamma'' = substUnitGamma gamma' - return $ substProgram sigma gamma'' prog + return $ substProgram sigma prog From 10942e70ad73213c03d18f11b6acde06df17561e Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 10:46:02 +0900 Subject: [PATCH 44/56] feat(core): Add Jikka.Core.Convert.TypeInfer --- src/Jikka/CPlusPlus/Convert/FromCore.hs | 2 +- src/Jikka/Core/Convert/ANormal.hs | 6 +- src/Jikka/Core/Convert/Alpha.hs | 4 +- src/Jikka/Core/Convert/MakeEager.hs | 5 +- src/Jikka/Core/Convert/RemoveUnusedVars.hs | 5 +- src/Jikka/Core/Convert/StrengthReduction.hs | 5 +- src/Jikka/Core/Convert/TypeInfer.hs | 279 ++++++++++++++++++ src/Jikka/Core/Evaluate.hs | 2 +- src/Jikka/Core/Language/Lint.hs | 135 +-------- src/Jikka/Core/Language/TypeCheck.hs | 49 +++ src/Jikka/Core/Language/Vars.hs | 9 + src/Jikka/Core/Optimize.hs | 2 + .../RestrictedPython/Convert/TypeInfer.hs | 2 + test/Jikka/Core/Convert/TypeInferSpec.hs | 79 +++++ 14 files changed, 441 insertions(+), 143 deletions(-) create mode 100644 src/Jikka/Core/Convert/TypeInfer.hs create mode 100644 src/Jikka/Core/Language/TypeCheck.hs create mode 100644 test/Jikka/Core/Convert/TypeInferSpec.hs diff --git a/src/Jikka/CPlusPlus/Convert/FromCore.hs b/src/Jikka/CPlusPlus/Convert/FromCore.hs index 54901ac8..3cc3ab58 100644 --- a/src/Jikka/CPlusPlus/Convert/FromCore.hs +++ b/src/Jikka/CPlusPlus/Convert/FromCore.hs @@ -24,7 +24,7 @@ import Jikka.Common.Error import qualified Jikka.Core.Language.Beta as X import qualified Jikka.Core.Language.BuiltinPatterns as X import qualified Jikka.Core.Language.Expr as X -import qualified Jikka.Core.Language.Lint as X +import qualified Jikka.Core.Language.TypeCheck as X -------------------------------------------------------------------------------- -- monad diff --git a/src/Jikka/Core/Convert/ANormal.hs b/src/Jikka/Core/Convert/ANormal.hs index 11eca278..aa08bb01 100644 --- a/src/Jikka/Core/Convert/ANormal.hs +++ b/src/Jikka/Core/Convert/ANormal.hs @@ -19,7 +19,8 @@ import Jikka.Common.Error import Jikka.Core.Convert.Alpha (gensym) import qualified Jikka.Core.Convert.Alpha as Alpha (runProgram) import Jikka.Core.Language.Expr -import Jikka.Core.Language.Lint (TypeEnv, typecheckExpr, typecheckProgram') +import Jikka.Core.Language.Lint +import Jikka.Core.Language.TypeCheck destruct :: (MonadAlpha m, MonadError Error m) => TypeEnv -> Expr -> m (TypeEnv, Expr -> Expr, Expr) destruct env = \case @@ -86,4 +87,5 @@ run :: (MonadAlpha m, MonadError Error m) => Program -> m Program run prog = wrapError' "Jikka.Core.Convert.ANormal" $ do prog <- Alpha.runProgram prog prog <- runToplevelExpr [] prog - typecheckProgram' prog + ensureWellTyped prog + return prog diff --git a/src/Jikka/Core/Convert/Alpha.hs b/src/Jikka/Core/Convert/Alpha.hs index 68ed322b..a08f036d 100644 --- a/src/Jikka/Core/Convert/Alpha.hs +++ b/src/Jikka/Core/Convert/Alpha.hs @@ -17,7 +17,6 @@ module Jikka.Core.Convert.Alpha where import Jikka.Common.Alpha import Jikka.Common.Error import Jikka.Core.Language.Expr -import Jikka.Core.Language.Lint (typecheckProgram') gensym :: MonadAlpha m => m VarName gensym = rename' (VarName "") <$> nextCounter @@ -78,5 +77,4 @@ runProgram = runToplevelExpr [] run :: (MonadAlpha m, MonadError Error m) => Program -> m Program run prog = wrapError' "Jikka.Core.Convert.Alpha" $ do - prog <- runToplevelExpr [] prog - typecheckProgram' prog + runToplevelExpr [] prog diff --git a/src/Jikka/Core/Convert/MakeEager.hs b/src/Jikka/Core/Convert/MakeEager.hs index 840c860c..b9da4378 100644 --- a/src/Jikka/Core/Convert/MakeEager.hs +++ b/src/Jikka/Core/Convert/MakeEager.hs @@ -17,7 +17,7 @@ where import Jikka.Common.Error import Jikka.Core.Language.Expr -import Jikka.Core.Language.Lint (typecheckProgram') +import Jikka.Core.Language.Lint runExpr :: Expr -> Expr runExpr = \case @@ -62,4 +62,5 @@ run' = runToplevelExpr run :: MonadError Error m => Program -> m Program run prog = wrapError' "Jikka.Core.Convert.MakeEager" $ do prog <- return $ run' prog - typecheckProgram' prog + ensureWellTyped prog + return prog diff --git a/src/Jikka/Core/Convert/RemoveUnusedVars.hs b/src/Jikka/Core/Convert/RemoveUnusedVars.hs index 70fa7107..8a5bd066 100644 --- a/src/Jikka/Core/Convert/RemoveUnusedVars.hs +++ b/src/Jikka/Core/Convert/RemoveUnusedVars.hs @@ -19,7 +19,7 @@ where import Jikka.Common.Error import Jikka.Core.Language.Expr -import Jikka.Core.Language.Lint (typecheckProgram') +import Jikka.Core.Language.Lint import Jikka.Core.Language.Vars (isUnusedVar) runLet :: VarName -> Type -> Expr -> Expr -> Expr @@ -69,4 +69,5 @@ run' = runToplevelExpr run :: MonadError Error m => Program -> m Program run prog = wrapError' "Jikka.Core.Convert.RemoveUnusedVars" $ do prog <- return $ run' prog - typecheckProgram' prog + ensureWellTyped prog + return prog diff --git a/src/Jikka/Core/Convert/StrengthReduction.hs b/src/Jikka/Core/Convert/StrengthReduction.hs index 739bcf62..655d915a 100644 --- a/src/Jikka/Core/Convert/StrengthReduction.hs +++ b/src/Jikka/Core/Convert/StrengthReduction.hs @@ -20,7 +20,7 @@ where import Jikka.Common.Error import Jikka.Core.Language.BuiltinPatterns import Jikka.Core.Language.Expr -import Jikka.Core.Language.Lint (typecheckProgram') +import Jikka.Core.Language.Lint import Jikka.Core.Language.Vars go :: Expr -> Expr @@ -226,4 +226,5 @@ weakenToplevelExpr e = case e of run :: MonadError Error m => Program -> m Program run prog = wrapError' "Jikka.Core.Convert.StrengthReduction" $ do prog <- return $ weakenToplevelExpr prog - typecheckProgram' prog + ensureWellTyped prog + return prog diff --git a/src/Jikka/Core/Convert/TypeInfer.hs b/src/Jikka/Core/Convert/TypeInfer.hs new file mode 100644 index 00000000..4fc74ba3 --- /dev/null +++ b/src/Jikka/Core/Convert/TypeInfer.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} + +module Jikka.Core.Convert.TypeInfer + ( builtinToType, + literalToType, + run, + + -- * internal types and functions + Equation (..), + formularizeProgram, + sortEquations, + mergeAssertions, + Subst (..), + subst, + solveEquations, + substProgram, + ) +where + +import Control.Arrow (second) +import Control.Monad.State.Strict +import Control.Monad.Writer.Strict (MonadWriter, execWriterT, tell) +import qualified Data.Map.Strict as M +import Data.Monoid (Dual (..)) +import Jikka.Common.Alpha +import Jikka.Common.Error +import Jikka.Core.Language.Expr +import Jikka.Core.Language.Util +import Jikka.Core.Language.Vars + +builtinToType :: Builtin -> Type +builtinToType = \case + -- arithmetical functions + Negate -> Fun1Ty IntTy + Plus -> Fun2Ty IntTy + Minus -> Fun2Ty IntTy + Mult -> Fun2Ty IntTy + FloorDiv -> Fun2Ty IntTy + FloorMod -> Fun2Ty IntTy + CeilDiv -> Fun2Ty IntTy + CeilMod -> Fun2Ty IntTy + Pow -> Fun2Ty IntTy + -- induction functions + NatInd t -> FunTy [t, FunTy [IntTy, t] t, IntTy] t + -- advanced arithmetical functions + Abs -> Fun1Ty IntTy + Gcd -> Fun2Ty IntTy + Lcm -> Fun2Ty IntTy + Min2 t -> Fun2Ty t + Max2 t -> Fun2Ty t + -- logical functions + Not -> Fun1Ty BoolTy + And -> Fun2Ty BoolTy + Or -> Fun2Ty BoolTy + Implies -> Fun2Ty BoolTy + If t -> FunTy [BoolTy, t, t] t + -- bitwise functions + BitNot -> Fun1Ty IntTy + BitAnd -> Fun2Ty IntTy + BitOr -> Fun2Ty IntTy + BitXor -> Fun2Ty IntTy + BitLeftShift -> Fun2Ty IntTy + BitRightShift -> Fun2Ty IntTy + -- modular functions + ModInv -> Fun2Ty IntTy + ModPow -> Fun3Ty IntTy + -- list functions + Cons t -> FunTy [t, ListTy t] (ListTy t) + Foldl t1 t2 -> FunTy [FunTy [t2, t1] t2, t2, ListTy t1] t2 + Scanl t1 t2 -> FunTy [FunTy [t2, t1] t2, t2, ListTy t1] (ListTy t2) + Len t -> FunTy [ListTy t] IntTy + Tabulate t -> FunTy [IntTy, FunTy [IntTy] t] (ListTy t) + Map t1 t2 -> FunTy [FunTy [t1] t2, ListTy t1] (ListTy t2) + Filter t -> FunTy [FunTy [t] BoolTy, ListTy t] (ListTy t) + At t -> FunTy [ListTy t, IntTy] t + SetAt t -> FunTy [ListTy t, IntTy, t] (ListTy t) + Elem t -> FunTy [t, ListTy t] BoolTy + Sum -> FunLTy IntTy + Product -> FunLTy IntTy + Min1 t -> FunLTy t + Max1 t -> FunLTy t + ArgMin t -> FunTy [ListTy t] IntTy + ArgMax t -> FunTy [ListTy t] IntTy + All -> FunLTy BoolTy + Any -> FunLTy BoolTy + Sorted t -> Fun1Ty (ListTy t) + List t -> Fun1Ty (ListTy t) + Reversed t -> Fun1Ty (ListTy t) + Range1 -> FunTy [IntTy] (ListTy IntTy) + Range2 -> FunTy [IntTy, IntTy] (ListTy IntTy) + Range3 -> FunTy [IntTy, IntTy, IntTy] (ListTy IntTy) + -- tuple functions + Tuple ts -> FunTy ts (TupleTy ts) + Proj ts n -> FunTy [TupleTy ts] (ts !! n) + -- comparison + LessThan t -> FunTy [t, t] BoolTy + LessEqual t -> FunTy [t, t] BoolTy + GreaterThan t -> FunTy [t, t] BoolTy + GreaterEqual t -> FunTy [t, t] BoolTy + Equal t -> FunTy [t, t] BoolTy + NotEqual t -> FunTy [t, t] BoolTy + -- combinational functions + Fact -> Fun1Ty IntTy + Choose -> Fun2Ty IntTy + Permute -> Fun2Ty IntTy + MultiChoose -> Fun2Ty IntTy + +literalToType :: Literal -> Type +literalToType = \case + LitBuiltin builtin -> builtinToType builtin + LitInt _ -> IntTy + LitBool _ -> BoolTy + LitNil t -> ListTy t + +data Equation + = TypeEquation Type Type + | TypeAssertion VarName Type + deriving (Eq, Ord, Show, Read) + +type Eqns = Dual [Equation] + +formularizeType :: MonadWriter Eqns m => Type -> Type -> m () +formularizeType t1 t2 = tell $ Dual [TypeEquation t1 t2] + +formularizeVarName :: MonadWriter Eqns m => VarName -> Type -> m () +formularizeVarName x t = tell $ Dual [TypeAssertion x t] + +formularizeExpr :: (MonadWriter Eqns m, MonadAlpha m) => Expr -> m Type +formularizeExpr = \case + Var x -> do + t <- genType + formularizeVarName x t + return t + Lit lit -> return $ literalToType lit + App f args -> do + ret <- genType + t <- formularizeExpr f + ts <- mapM formularizeExpr args + formularizeType (FunTy ts ret) t + return ret + Lam args body -> do + mapM_ (uncurry formularizeVarName) args + ret <- formularizeExpr body + return $ FunTy (map snd args) ret + Let x t e1 e2 -> do + formularizeVarName x t + formularizeExpr' e1 t + formularizeExpr e2 + +formularizeExpr' :: (MonadWriter Eqns m, MonadAlpha m) => Expr -> Type -> m () +formularizeExpr' e t = do + t' <- formularizeExpr e + formularizeType t t' + +formularizeToplevelExpr :: (MonadWriter Eqns m, MonadAlpha m) => ToplevelExpr -> m Type +formularizeToplevelExpr = \case + ResultExpr e -> formularizeExpr e + ToplevelLet x t e cont -> do + formularizeVarName x t + formularizeExpr' e t + formularizeToplevelExpr cont + ToplevelLetRec f args ret body cont -> do + formularizeVarName f (FunTy (map snd args) ret) + mapM_ (uncurry formularizeVarName) args + formularizeExpr' body ret + formularizeToplevelExpr cont + +formularizeProgram :: MonadAlpha m => Program -> m [Equation] +formularizeProgram prog = getDual <$> execWriterT (formularizeToplevelExpr prog) + +sortEquations :: [Equation] -> ([(Type, Type)], [(VarName, Type)]) +sortEquations = go [] [] + where + go eqns' assertions [] = (eqns', assertions) + go eqns' assertions (eqn : eqns) = case eqn of + TypeEquation t1 t2 -> go ((t1, t2) : eqns') assertions eqns + TypeAssertion x t -> go eqns' ((x, t) : assertions) eqns + +mergeAssertions :: [(VarName, Type)] -> [(Type, Type)] +mergeAssertions = go M.empty [] + where + go _ eqns [] = eqns + go gamma eqns ((x, t) : assertions) = case M.lookup x gamma of + Nothing -> go (M.insert x t gamma) eqns assertions + Just t' -> go gamma ((t, t') : eqns) assertions + +-- | `Subst` is type substituion. It's a mapping from type variables to their actual types. +newtype Subst = Subst {unSubst :: M.Map TypeName Type} + +subst :: Subst -> Type -> Type +subst sigma = \case + VarTy x -> + case M.lookup x (unSubst sigma) of + Nothing -> VarTy x + Just t -> subst sigma t + IntTy -> IntTy + BoolTy -> BoolTy + ListTy t -> ListTy (subst sigma t) + TupleTy ts -> TupleTy (map (subst sigma) ts) + FunTy ts ret -> FunTy (map (subst sigma) ts) (subst sigma ret) + +unifyTyVar :: (MonadState Subst m, MonadError Error m) => TypeName -> Type -> m () +unifyTyVar x t = + if x `elem` freeTyVars t + then throwInternalError $ "looped type equation " ++ show x ++ " = " ++ show t + else do + modify' (Subst . M.insert x t . unSubst) -- This doesn't introduce the loop. + +unifyType :: (MonadState Subst m, MonadError Error m) => Type -> Type -> m () +unifyType t1 t2 = wrapError' ("failed to unify " ++ show t1 ++ " and " ++ show t2) $ do + sigma <- get + t1 <- return $ subst sigma t1 -- shadowing + t2 <- return $ subst sigma t2 -- shadowing + case (t1, t2) of + _ | t1 == t2 -> return () + (VarTy x1, _) -> do + unifyTyVar x1 t2 + (_, VarTy x2) -> do + unifyTyVar x2 t1 + (ListTy t1, ListTy t2) -> do + unifyType t1 t2 + (TupleTy ts1, TupleTy ts2) -> do + if length ts1 == length ts2 + then mapM_ (uncurry unifyType) (zip ts1 ts2) + else throwInternalError $ "different types " ++ show t1 ++ " /= " ++ show t2 + (FunTy args1 ret1, FunTy args2 ret2) -> do + if length args1 == length args2 + then mapM_ (uncurry unifyType) (zip args1 args2) + else throwInternalError $ "different types " ++ show t1 ++ " /= " ++ show t2 + unifyType ret1 ret2 + _ -> throwInternalError $ "different types " ++ show t1 ++ " /= " ++ show t2 + +solveEquations :: MonadError Error m => [(Type, Type)] -> m Subst +solveEquations eqns = wrapError' "failed to solve type equations" $ do + execStateT (mapM_ (uncurry unifyType) eqns) (Subst M.empty) + +-- | `substUnit` replaces all undetermined type variables with the unit type. +substUnit :: Type -> Type +substUnit = \case + VarTy _ -> TupleTy [] + IntTy -> IntTy + BoolTy -> BoolTy + ListTy t -> ListTy (substUnit t) + TupleTy ts -> TupleTy (map substUnit ts) + FunTy ts ret -> FunTy (map substUnit ts) (substUnit ret) + +-- | `subst'` does `subst` and replaces all undetermined type variables with the unit type. +subst' :: Subst -> Type -> Type +subst' sigma = substUnit . subst sigma + +substExpr :: Subst -> Expr -> Expr +substExpr sigma = go + where + go = \case + Var x -> Var x + Lit lit -> Lit lit + App f args -> App (go f) (map go args) + Lam args body -> Lam (map (second (subst' sigma)) args) (go body) + Let x t e1 e2 -> Let x (subst sigma t) (go e1) (go e2) + +substToplevelExpr :: Subst -> ToplevelExpr -> ToplevelExpr +substToplevelExpr sigma = \case + ResultExpr e -> ResultExpr (substExpr sigma e) + ToplevelLet x t e cont -> ToplevelLet x (subst' sigma t) (substExpr sigma e) (substToplevelExpr sigma cont) + ToplevelLetRec f args ret body cont -> ToplevelLetRec f (map (second (subst' sigma)) args) (subst' sigma ret) (substExpr sigma body) (substToplevelExpr sigma cont) + +substProgram :: Subst -> Program -> Program +substProgram = substToplevelExpr + +-- | `run` does type inference. +-- This assumes that program has no name conflicts. +run :: (MonadAlpha m, MonadError Error m) => Program -> m Program +run prog = do + eqns <- formularizeProgram prog + let (eqns', assertions) = sortEquations eqns + let eqns'' = mergeAssertions assertions + sigma <- solveEquations (eqns' ++ eqns'') + return $ substProgram sigma prog diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index 54579d97..f41c43f4 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -30,8 +30,8 @@ import Data.Bits import Data.List (sort) import qualified Data.Vector as V import Jikka.Common.Error +import Jikka.Core.Convert.TypeInfer (builtinToType) import Jikka.Core.Language.Expr -import Jikka.Core.Language.Lint (builtinToType) import Jikka.Core.Language.Value import Text.Read (readEither) diff --git a/src/Jikka/Core/Language/Lint.hs b/src/Jikka/Core/Language/Lint.hs index 7afe4c1a..95527163 100644 --- a/src/Jikka/Core/Language/Lint.hs +++ b/src/Jikka/Core/Language/Lint.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -- | -- Module : Jikka.Core.Language.Lint @@ -15,133 +14,9 @@ module Jikka.Core.Language.Lint where import Jikka.Common.Error import Jikka.Core.Language.Expr +import Jikka.Core.Language.TypeCheck -builtinToType :: Builtin -> Type -builtinToType = \case - -- arithmetical functions - Negate -> Fun1Ty IntTy - Plus -> Fun2Ty IntTy - Minus -> Fun2Ty IntTy - Mult -> Fun2Ty IntTy - FloorDiv -> Fun2Ty IntTy - FloorMod -> Fun2Ty IntTy - CeilDiv -> Fun2Ty IntTy - CeilMod -> Fun2Ty IntTy - Pow -> Fun2Ty IntTy - -- induction functions - NatInd t -> FunTy [t, FunTy [IntTy, t] t, IntTy] t - -- advanced arithmetical functions - Abs -> Fun1Ty IntTy - Gcd -> Fun2Ty IntTy - Lcm -> Fun2Ty IntTy - Min2 t -> Fun2Ty t - Max2 t -> Fun2Ty t - -- logical functions - Not -> Fun1Ty BoolTy - And -> Fun2Ty BoolTy - Or -> Fun2Ty BoolTy - Implies -> Fun2Ty BoolTy - If t -> FunTy [BoolTy, t, t] t - -- bitwise functions - BitNot -> Fun1Ty IntTy - BitAnd -> Fun2Ty IntTy - BitOr -> Fun2Ty IntTy - BitXor -> Fun2Ty IntTy - BitLeftShift -> Fun2Ty IntTy - BitRightShift -> Fun2Ty IntTy - -- modular functions - ModInv -> Fun2Ty IntTy - ModPow -> Fun3Ty IntTy - -- list functions - Cons t -> FunTy [t, ListTy t] (ListTy t) - Foldl t1 t2 -> FunTy [FunTy [t2, t1] t2, t2, ListTy t1] t2 - Scanl t1 t2 -> FunTy [FunTy [t2, t1] t2, t2, ListTy t1] (ListTy t2) - Len t -> FunTy [ListTy t] IntTy - Tabulate t -> FunTy [IntTy, FunTy [IntTy] t] (ListTy t) - Map t1 t2 -> FunTy [FunTy [t1] t2, ListTy t1] (ListTy t2) - Filter t -> FunTy [FunTy [t] BoolTy, ListTy t] (ListTy t) - At t -> FunTy [ListTy t, IntTy] t - SetAt t -> FunTy [ListTy t, IntTy, t] (ListTy t) - Elem t -> FunTy [t, ListTy t] BoolTy - Sum -> FunLTy IntTy - Product -> FunLTy IntTy - Min1 t -> FunLTy t - Max1 t -> FunLTy t - ArgMin t -> FunTy [ListTy t] IntTy - ArgMax t -> FunTy [ListTy t] IntTy - All -> FunLTy BoolTy - Any -> FunLTy BoolTy - Sorted t -> Fun1Ty (ListTy t) - List t -> Fun1Ty (ListTy t) - Reversed t -> Fun1Ty (ListTy t) - Range1 -> FunTy [IntTy] (ListTy IntTy) - Range2 -> FunTy [IntTy, IntTy] (ListTy IntTy) - Range3 -> FunTy [IntTy, IntTy, IntTy] (ListTy IntTy) - -- tuple functions - Tuple ts -> FunTy ts (TupleTy ts) - Proj ts n -> FunTy [TupleTy ts] (ts !! n) - -- comparison - LessThan t -> FunTy [t, t] BoolTy - LessEqual t -> FunTy [t, t] BoolTy - GreaterThan t -> FunTy [t, t] BoolTy - GreaterEqual t -> FunTy [t, t] BoolTy - Equal t -> FunTy [t, t] BoolTy - NotEqual t -> FunTy [t, t] BoolTy - -- combinational functions - Fact -> Fun1Ty IntTy - Choose -> Fun2Ty IntTy - Permute -> Fun2Ty IntTy - MultiChoose -> Fun2Ty IntTy - -literalToType :: Literal -> Type -literalToType = \case - LitBuiltin builtin -> builtinToType builtin - LitInt _ -> IntTy - LitBool _ -> BoolTy - LitNil t -> ListTy t - -type TypeEnv = [(VarName, Type)] - --- | `typecheckExpr` checks that the given `Expr` has the correct types. -typecheckExpr :: MonadError Error m => TypeEnv -> Expr -> m Type -typecheckExpr env = \case - Var x -> case lookup x env of - Nothing -> throwInternalError $ "undefined variable: " ++ show (unVarName x) - Just t -> return t - Lit lit -> return $ literalToType lit - App e args -> do - t <- typecheckExpr env e - ts <- mapM (typecheckExpr env) args - case t of - FunTy ts' ret | ts' == ts -> return ret - _ -> throwInternalError $ "invalid funcall: " ++ show (App e args, t, ts) - Lam args e -> FunTy (map snd args) <$> typecheckExpr (reverse args ++ env) e - Let x t e1 e2 -> do - t' <- typecheckExpr env e1 - if t == t' - then typecheckExpr ((x, t) : env) e2 - else throwInternalError $ "wrong type binding: " ++ show (Let x t e1 e2) - -typecheckToplevelExpr :: MonadError Error m => TypeEnv -> ToplevelExpr -> m Type -typecheckToplevelExpr env = \case - ResultExpr e -> typecheckExpr env e - ToplevelLet x t e cont -> do - t' <- typecheckExpr env e - if t' == t then return () else throwInternalError "assigned type is not correct" - typecheckToplevelExpr ((x, t) : env) cont - ToplevelLetRec x args ret body cont -> do - let t = case args of - [] -> ret - _ -> FunTy (map snd args) ret - ret' <- typecheckExpr (reverse args ++ (x, t) : env) body - if ret' == ret then return () else throwInternalError "returned type is not correct" - typecheckToplevelExpr ((x, t) : env) cont - -typecheckProgram :: MonadError Error m => Program -> m Type -typecheckProgram prog = wrapError' "Jikka.Core.Language.Lint" $ do - typecheckToplevelExpr [] prog - -typecheckProgram' :: MonadError Error m => Program -> m Program -typecheckProgram' prog = wrapError' "Jikka.Core.Language.Lint" $ do - typecheckToplevelExpr [] prog - return prog +ensureWellTyped :: MonadError Error m => Program -> m () +ensureWellTyped prog = wrapError' "Jikka.Core.Language.Lint.ensureWellTyped" $ do + _ <- typecheckProgram prog + return () diff --git a/src/Jikka/Core/Language/TypeCheck.hs b/src/Jikka/Core/Language/TypeCheck.hs new file mode 100644 index 00000000..d370838c --- /dev/null +++ b/src/Jikka/Core/Language/TypeCheck.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} + +module Jikka.Core.Language.TypeCheck where + +import Jikka.Common.Error +import Jikka.Core.Convert.TypeInfer (literalToType) +import Jikka.Core.Language.Expr + +type TypeEnv = [(VarName, Type)] + +-- | `typecheckExpr` checks that the given `Expr` has the correct types. +typecheckExpr :: MonadError Error m => TypeEnv -> Expr -> m Type +typecheckExpr env = \case + Var x -> case lookup x env of + Nothing -> throwInternalError $ "undefined variable: " ++ show (unVarName x) + Just t -> return t + Lit lit -> return $ literalToType lit + App e args -> do + t <- typecheckExpr env e + ts <- mapM (typecheckExpr env) args + case t of + FunTy ts' ret | ts' == ts -> return ret + _ -> throwInternalError $ "invalid funcall: " ++ show (App e args, t, ts) + Lam args e -> FunTy (map snd args) <$> typecheckExpr (reverse args ++ env) e + Let x t e1 e2 -> do + t' <- typecheckExpr env e1 + if t == t' + then typecheckExpr ((x, t) : env) e2 + else throwInternalError $ "wrong type binding: " ++ show (Let x t e1 e2) + +typecheckToplevelExpr :: MonadError Error m => TypeEnv -> ToplevelExpr -> m Type +typecheckToplevelExpr env = \case + ResultExpr e -> typecheckExpr env e + ToplevelLet x t e cont -> do + t' <- typecheckExpr env e + if t' == t then return () else throwInternalError "assigned type is not correct" + typecheckToplevelExpr ((x, t) : env) cont + ToplevelLetRec x args ret body cont -> do + let t = case args of + [] -> ret + _ -> FunTy (map snd args) ret + ret' <- typecheckExpr (reverse args ++ (x, t) : env) body + if ret' == ret then return () else throwInternalError "returned type is not correct" + typecheckToplevelExpr ((x, t) : env) cont + +typecheckProgram :: MonadError Error m => Program -> m Type +typecheckProgram prog = wrapError' "Jikka.Core.Convert.TypeInfer.typecheckProgram" $ do + typecheckToplevelExpr [] prog diff --git a/src/Jikka/Core/Language/Vars.hs b/src/Jikka/Core/Language/Vars.hs index 1a466a74..fd834e6b 100644 --- a/src/Jikka/Core/Language/Vars.hs +++ b/src/Jikka/Core/Language/Vars.hs @@ -57,3 +57,12 @@ findFreshVar' es = head . filter pred $ map getAnonymousVar [0 ..] getAnonymousVar :: Int -> VarName getAnonymousVar i = VarName ("@" ++ show i) + +freeTyVars :: Type -> [TypeName] +freeTyVars = \case + VarTy x -> [x] + IntTy -> [] + BoolTy -> [] + ListTy t -> freeTyVars t + TupleTy ts -> concatMap freeTyVars ts + FunTy ts ret -> concatMap freeTyVars (ret : ts) diff --git a/src/Jikka/Core/Optimize.hs b/src/Jikka/Core/Optimize.hs index 3adeb3f7..d5870554 100644 --- a/src/Jikka/Core/Optimize.hs +++ b/src/Jikka/Core/Optimize.hs @@ -20,10 +20,12 @@ import Jikka.Common.Error import qualified Jikka.Core.Convert.Alpha as Alpha import qualified Jikka.Core.Convert.RemoveUnusedVars as RemoveUnusedVars import qualified Jikka.Core.Convert.StrengthReduction as StrengthReduction +import qualified Jikka.Core.Convert.TypeInfer as TypeInfer import Jikka.Core.Language.Expr run :: (MonadAlpha m, MonadError Error m) => Program -> m Program run prog = do prog <- Alpha.run prog + prog <- TypeInfer.run prog prog <- RemoveUnusedVars.run prog StrengthReduction.run prog diff --git a/src/Jikka/RestrictedPython/Convert/TypeInfer.hs b/src/Jikka/RestrictedPython/Convert/TypeInfer.hs index 52d5c5db..16a03041 100644 --- a/src/Jikka/RestrictedPython/Convert/TypeInfer.hs +++ b/src/Jikka/RestrictedPython/Convert/TypeInfer.hs @@ -11,6 +11,8 @@ -- Portability : portable module Jikka.RestrictedPython.Convert.TypeInfer ( run, + + -- * internal types and functions Equation (..), formularizeProgram, sortEquations, diff --git a/test/Jikka/Core/Convert/TypeInferSpec.hs b/test/Jikka/Core/Convert/TypeInferSpec.hs new file mode 100644 index 00000000..a00768bf --- /dev/null +++ b/test/Jikka/Core/Convert/TypeInferSpec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Jikka.Core.Convert.TypeInferSpec + ( spec, + ) +where + +import Jikka.Common.Alpha +import Jikka.Common.Error +import Jikka.Core.Convert.TypeInfer (run) +import Jikka.Core.Language.BuiltinPatterns +import Jikka.Core.Language.Expr +import Test.Hspec + +run' :: Program -> Either Error Program +run' = flip evalAlphaT 0 . run + +spec :: Spec +spec = describe "run" $ do + it "works" $ do + let prog = + ResultExpr + ( Let + "x" + (VarTy "t1") + Lit0 + ( Let + "y" + (VarTy "t2") + (Plus' (Var "x") Lit1) + (Var "y") + ) + ) + let expected = + ResultExpr + ( Let + "x" + IntTy + Lit0 + ( Let + "y" + IntTy + (Plus' (Var "x") Lit1) + (Var "y") + ) + ) + run' prog `shouldBe` Right expected + it "works on let-rec" $ do + let prog = + ToplevelLetRec + "f" + [("x", VarTy "t1")] + (VarTy "t2") + (Var "x") + (ResultExpr (App (Var "f") [Lit0])) + let expected = + ToplevelLetRec + "f" + [("x", IntTy)] + IntTy + (Var "x") + (ResultExpr (App (Var "f") [Lit0])) + run' prog `shouldBe` Right expected + it "replaces undetermined types with 0-tuples" $ do + let prog = + ToplevelLetRec + "f" + [("x", VarTy "t1")] + (VarTy "t2") + (Var "x") + (ResultExpr Lit0) + let expected = + ToplevelLetRec + "f" + [("x", TupleTy [])] + (TupleTy []) + (Var "x") + (ResultExpr Lit0) + run' prog `shouldBe` Right expected From 4dd0ae4664b0027fd2eb570a272b261f1b179fa6 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 10:51:10 +0900 Subject: [PATCH 45/56] feat(core): Add an assertion to Jikka.Core.Convert.TypeInfer --- src/Jikka/Core/Convert/TypeInfer.hs | 95 ++-------------------------- src/Jikka/Core/Evaluate.hs | 2 +- src/Jikka/Core/Language/TypeCheck.hs | 87 ++++++++++++++++++++++++- 3 files changed, 92 insertions(+), 92 deletions(-) diff --git a/src/Jikka/Core/Convert/TypeInfer.hs b/src/Jikka/Core/Convert/TypeInfer.hs index 4fc74ba3..1050b0ad 100644 --- a/src/Jikka/Core/Convert/TypeInfer.hs +++ b/src/Jikka/Core/Convert/TypeInfer.hs @@ -2,9 +2,7 @@ {-# LANGUAGE LambdaCase #-} module Jikka.Core.Convert.TypeInfer - ( builtinToType, - literalToType, - run, + ( run, -- * internal types and functions Equation (..), @@ -26,93 +24,10 @@ import Data.Monoid (Dual (..)) import Jikka.Common.Alpha import Jikka.Common.Error import Jikka.Core.Language.Expr +import Jikka.Core.Language.TypeCheck (literalToType, typecheckProgram) import Jikka.Core.Language.Util import Jikka.Core.Language.Vars -builtinToType :: Builtin -> Type -builtinToType = \case - -- arithmetical functions - Negate -> Fun1Ty IntTy - Plus -> Fun2Ty IntTy - Minus -> Fun2Ty IntTy - Mult -> Fun2Ty IntTy - FloorDiv -> Fun2Ty IntTy - FloorMod -> Fun2Ty IntTy - CeilDiv -> Fun2Ty IntTy - CeilMod -> Fun2Ty IntTy - Pow -> Fun2Ty IntTy - -- induction functions - NatInd t -> FunTy [t, FunTy [IntTy, t] t, IntTy] t - -- advanced arithmetical functions - Abs -> Fun1Ty IntTy - Gcd -> Fun2Ty IntTy - Lcm -> Fun2Ty IntTy - Min2 t -> Fun2Ty t - Max2 t -> Fun2Ty t - -- logical functions - Not -> Fun1Ty BoolTy - And -> Fun2Ty BoolTy - Or -> Fun2Ty BoolTy - Implies -> Fun2Ty BoolTy - If t -> FunTy [BoolTy, t, t] t - -- bitwise functions - BitNot -> Fun1Ty IntTy - BitAnd -> Fun2Ty IntTy - BitOr -> Fun2Ty IntTy - BitXor -> Fun2Ty IntTy - BitLeftShift -> Fun2Ty IntTy - BitRightShift -> Fun2Ty IntTy - -- modular functions - ModInv -> Fun2Ty IntTy - ModPow -> Fun3Ty IntTy - -- list functions - Cons t -> FunTy [t, ListTy t] (ListTy t) - Foldl t1 t2 -> FunTy [FunTy [t2, t1] t2, t2, ListTy t1] t2 - Scanl t1 t2 -> FunTy [FunTy [t2, t1] t2, t2, ListTy t1] (ListTy t2) - Len t -> FunTy [ListTy t] IntTy - Tabulate t -> FunTy [IntTy, FunTy [IntTy] t] (ListTy t) - Map t1 t2 -> FunTy [FunTy [t1] t2, ListTy t1] (ListTy t2) - Filter t -> FunTy [FunTy [t] BoolTy, ListTy t] (ListTy t) - At t -> FunTy [ListTy t, IntTy] t - SetAt t -> FunTy [ListTy t, IntTy, t] (ListTy t) - Elem t -> FunTy [t, ListTy t] BoolTy - Sum -> FunLTy IntTy - Product -> FunLTy IntTy - Min1 t -> FunLTy t - Max1 t -> FunLTy t - ArgMin t -> FunTy [ListTy t] IntTy - ArgMax t -> FunTy [ListTy t] IntTy - All -> FunLTy BoolTy - Any -> FunLTy BoolTy - Sorted t -> Fun1Ty (ListTy t) - List t -> Fun1Ty (ListTy t) - Reversed t -> Fun1Ty (ListTy t) - Range1 -> FunTy [IntTy] (ListTy IntTy) - Range2 -> FunTy [IntTy, IntTy] (ListTy IntTy) - Range3 -> FunTy [IntTy, IntTy, IntTy] (ListTy IntTy) - -- tuple functions - Tuple ts -> FunTy ts (TupleTy ts) - Proj ts n -> FunTy [TupleTy ts] (ts !! n) - -- comparison - LessThan t -> FunTy [t, t] BoolTy - LessEqual t -> FunTy [t, t] BoolTy - GreaterThan t -> FunTy [t, t] BoolTy - GreaterEqual t -> FunTy [t, t] BoolTy - Equal t -> FunTy [t, t] BoolTy - NotEqual t -> FunTy [t, t] BoolTy - -- combinational functions - Fact -> Fun1Ty IntTy - Choose -> Fun2Ty IntTy - Permute -> Fun2Ty IntTy - MultiChoose -> Fun2Ty IntTy - -literalToType :: Literal -> Type -literalToType = \case - LitBuiltin builtin -> builtinToType builtin - LitInt _ -> IntTy - LitBool _ -> BoolTy - LitNil t -> ListTy t - data Equation = TypeEquation Type Type | TypeAssertion VarName Type @@ -271,9 +186,11 @@ substProgram = substToplevelExpr -- | `run` does type inference. -- This assumes that program has no name conflicts. run :: (MonadAlpha m, MonadError Error m) => Program -> m Program -run prog = do +run prog = wrapError' "Jikka.Core.Convert.TypeInfer" $ do eqns <- formularizeProgram prog let (eqns', assertions) = sortEquations eqns let eqns'' = mergeAssertions assertions sigma <- solveEquations (eqns' ++ eqns'') - return $ substProgram sigma prog + prog <- return $ substProgram sigma prog + typecheckProgram prog + return prog diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index f41c43f4..9eec0a89 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -30,8 +30,8 @@ import Data.Bits import Data.List (sort) import qualified Data.Vector as V import Jikka.Common.Error -import Jikka.Core.Convert.TypeInfer (builtinToType) import Jikka.Core.Language.Expr +import Jikka.Core.Language.TypeCheck (builtinToType) import Jikka.Core.Language.Value import Text.Read (readEither) diff --git a/src/Jikka/Core/Language/TypeCheck.hs b/src/Jikka/Core/Language/TypeCheck.hs index d370838c..e94f03f3 100644 --- a/src/Jikka/Core/Language/TypeCheck.hs +++ b/src/Jikka/Core/Language/TypeCheck.hs @@ -4,9 +4,92 @@ module Jikka.Core.Language.TypeCheck where import Jikka.Common.Error -import Jikka.Core.Convert.TypeInfer (literalToType) import Jikka.Core.Language.Expr +builtinToType :: Builtin -> Type +builtinToType = \case + -- arithmetical functions + Negate -> Fun1Ty IntTy + Plus -> Fun2Ty IntTy + Minus -> Fun2Ty IntTy + Mult -> Fun2Ty IntTy + FloorDiv -> Fun2Ty IntTy + FloorMod -> Fun2Ty IntTy + CeilDiv -> Fun2Ty IntTy + CeilMod -> Fun2Ty IntTy + Pow -> Fun2Ty IntTy + -- induction functions + NatInd t -> FunTy [t, FunTy [IntTy, t] t, IntTy] t + -- advanced arithmetical functions + Abs -> Fun1Ty IntTy + Gcd -> Fun2Ty IntTy + Lcm -> Fun2Ty IntTy + Min2 t -> Fun2Ty t + Max2 t -> Fun2Ty t + -- logical functions + Not -> Fun1Ty BoolTy + And -> Fun2Ty BoolTy + Or -> Fun2Ty BoolTy + Implies -> Fun2Ty BoolTy + If t -> FunTy [BoolTy, t, t] t + -- bitwise functions + BitNot -> Fun1Ty IntTy + BitAnd -> Fun2Ty IntTy + BitOr -> Fun2Ty IntTy + BitXor -> Fun2Ty IntTy + BitLeftShift -> Fun2Ty IntTy + BitRightShift -> Fun2Ty IntTy + -- modular functions + ModInv -> Fun2Ty IntTy + ModPow -> Fun3Ty IntTy + -- list functions + Cons t -> FunTy [t, ListTy t] (ListTy t) + Foldl t1 t2 -> FunTy [FunTy [t2, t1] t2, t2, ListTy t1] t2 + Scanl t1 t2 -> FunTy [FunTy [t2, t1] t2, t2, ListTy t1] (ListTy t2) + Len t -> FunTy [ListTy t] IntTy + Tabulate t -> FunTy [IntTy, FunTy [IntTy] t] (ListTy t) + Map t1 t2 -> FunTy [FunTy [t1] t2, ListTy t1] (ListTy t2) + Filter t -> FunTy [FunTy [t] BoolTy, ListTy t] (ListTy t) + At t -> FunTy [ListTy t, IntTy] t + SetAt t -> FunTy [ListTy t, IntTy, t] (ListTy t) + Elem t -> FunTy [t, ListTy t] BoolTy + Sum -> FunLTy IntTy + Product -> FunLTy IntTy + Min1 t -> FunLTy t + Max1 t -> FunLTy t + ArgMin t -> FunTy [ListTy t] IntTy + ArgMax t -> FunTy [ListTy t] IntTy + All -> FunLTy BoolTy + Any -> FunLTy BoolTy + Sorted t -> Fun1Ty (ListTy t) + List t -> Fun1Ty (ListTy t) + Reversed t -> Fun1Ty (ListTy t) + Range1 -> FunTy [IntTy] (ListTy IntTy) + Range2 -> FunTy [IntTy, IntTy] (ListTy IntTy) + Range3 -> FunTy [IntTy, IntTy, IntTy] (ListTy IntTy) + -- tuple functions + Tuple ts -> FunTy ts (TupleTy ts) + Proj ts n -> FunTy [TupleTy ts] (ts !! n) + -- comparison + LessThan t -> FunTy [t, t] BoolTy + LessEqual t -> FunTy [t, t] BoolTy + GreaterThan t -> FunTy [t, t] BoolTy + GreaterEqual t -> FunTy [t, t] BoolTy + Equal t -> FunTy [t, t] BoolTy + NotEqual t -> FunTy [t, t] BoolTy + -- combinational functions + Fact -> Fun1Ty IntTy + Choose -> Fun2Ty IntTy + Permute -> Fun2Ty IntTy + MultiChoose -> Fun2Ty IntTy + +literalToType :: Literal -> Type +literalToType = \case + LitBuiltin builtin -> builtinToType builtin + LitInt _ -> IntTy + LitBool _ -> BoolTy + LitNil t -> ListTy t + type TypeEnv = [(VarName, Type)] -- | `typecheckExpr` checks that the given `Expr` has the correct types. @@ -45,5 +128,5 @@ typecheckToplevelExpr env = \case typecheckToplevelExpr ((x, t) : env) cont typecheckProgram :: MonadError Error m => Program -> m Type -typecheckProgram prog = wrapError' "Jikka.Core.Convert.TypeInfer.typecheckProgram" $ do +typecheckProgram prog = wrapError' "Jikka.Core.Language.TypeCheck.typecheckProgram" $ do typecheckToplevelExpr [] prog From 2f31933ec1376f58351a55af5b1f9a1650c4d103 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 11:28:24 +0900 Subject: [PATCH 46/56] fix(core): Fix Jikka.Core.Convert.TypeInfer --- src/Jikka/Core/Convert/TypeInfer.hs | 12 +++- src/Jikka/Core/Language/Util.hs | 79 ++++++++++++++++++++++++ test/Jikka/Core/Convert/TypeInferSpec.hs | 32 ++++++++++ 3 files changed, 122 insertions(+), 1 deletion(-) diff --git a/src/Jikka/Core/Convert/TypeInfer.hs b/src/Jikka/Core/Convert/TypeInfer.hs index 1050b0ad..838227cc 100644 --- a/src/Jikka/Core/Convert/TypeInfer.hs +++ b/src/Jikka/Core/Convert/TypeInfer.hs @@ -164,12 +164,22 @@ substUnit = \case subst' :: Subst -> Type -> Type subst' sigma = substUnit . subst sigma +substBuiltin :: Subst -> Builtin -> Builtin +substBuiltin sigma = mapTypeInBuiltin (subst' sigma) + +substLiteral :: Subst -> Literal -> Literal +substLiteral sigma = \case + LitBuiltin builtin -> LitBuiltin (substBuiltin sigma builtin) + LitInt n -> LitInt n + LitBool p -> LitBool p + LitNil t -> LitNil (subst' sigma t) + substExpr :: Subst -> Expr -> Expr substExpr sigma = go where go = \case Var x -> Var x - Lit lit -> Lit lit + Lit lit -> Lit (substLiteral sigma lit) App f args -> App (go f) (map go args) Lam args body -> Lam (map (second (subst' sigma)) args) (go body) Let x t e1 e2 -> Let x (subst sigma t) (go e1) (go e2) diff --git a/src/Jikka/Core/Language/Util.hs b/src/Jikka/Core/Language/Util.hs index bf47e860..d29989b5 100644 --- a/src/Jikka/Core/Language/Util.hs +++ b/src/Jikka/Core/Language/Util.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module Jikka.Core.Language.Util where import Jikka.Common.Alpha @@ -16,3 +18,80 @@ genVarName x = do genVarName' :: MonadAlpha m => m VarName genVarName' = genVarName (VarName "_") + +mapTypeInBuiltin :: (Type -> Type) -> Builtin -> Builtin +mapTypeInBuiltin f = \case + -- arithmetical functions + Negate -> Negate + Plus -> Plus + Minus -> Minus + Mult -> Mult + FloorDiv -> FloorDiv + FloorMod -> FloorMod + CeilDiv -> CeilDiv + CeilMod -> CeilMod + Pow -> Pow + -- induction functions + NatInd t -> NatInd (f t) + -- advanced arithmetical functions + Abs -> Abs + Gcd -> Gcd + Lcm -> Lcm + Min2 t -> Min2 (f t) + Max2 t -> Max2 (f t) + -- logical functionslogical + Not -> Not + And -> And + Or -> Or + Implies -> Implies + If t -> If (f t) + -- bitwise functionsbitwise + BitNot -> BitNot + BitAnd -> BitAnd + BitOr -> BitOr + BitXor -> BitXor + BitLeftShift -> BitLeftShift + BitRightShift -> BitRightShift + -- modular functionsmodular + ModInv -> ModInv + ModPow -> ModPow + -- list functionslist + Cons t -> Cons (f t) + Foldl t1 t2 -> Foldl (f t1) (f t2) + Scanl t1 t2 -> Scanl (f t1) (f t2) + Len t -> Len (f t) + Tabulate t -> Tabulate (f t) + Map t1 t2 -> Map (f t1) (f t2) + Filter t -> Filter (f t) + At t -> At (f t) + SetAt t -> SetAt (f t) + Elem t -> Elem (f t) + Sum -> Sum + Product -> Product + Min1 t -> Min1 (f t) + Max1 t -> Max1 (f t) + ArgMin t -> ArgMin (f t) + ArgMax t -> ArgMax (f t) + All -> All + Any -> Any + Sorted t -> Sorted (f t) + List t -> List (f t) + Reversed t -> Reversed (f t) + Range1 -> Range1 + Range2 -> Range2 + Range3 -> Range3 + -- tuple functions + Tuple ts -> Tuple (map f ts) + Proj ts n -> Proj (map f ts) n + -- comparison + LessThan t -> LessThan (f t) + LessEqual t -> LessEqual (f t) + GreaterThan t -> GreaterThan (f t) + GreaterEqual t -> GreaterEqual (f t) + Equal t -> Equal (f t) + NotEqual t -> NotEqual (f t) + -- combinational functions + Fact -> Fact + Choose -> Choose + Permute -> Permute + MultiChoose -> MultiChoose diff --git a/test/Jikka/Core/Convert/TypeInferSpec.hs b/test/Jikka/Core/Convert/TypeInferSpec.hs index a00768bf..a750e984 100644 --- a/test/Jikka/Core/Convert/TypeInferSpec.hs +++ b/test/Jikka/Core/Convert/TypeInferSpec.hs @@ -77,3 +77,35 @@ spec = describe "run" $ do (Var "x") (ResultExpr Lit0) run' prog `shouldBe` Right expected + it "works on fact" $ do + let prog = + ToplevelLetRec + "solve" + [("n", IntTy)] + IntTy + ( If' + (VarTy "$0") + (Equal' IntTy (Var "n") Lit0) + Lit1 + ( Mult' + (Var "n") + (App (Var "solve") [Minus' (Var "n") Lit1]) + ) + ) + (ResultExpr (Var "solve")) + let expected = + ToplevelLetRec + "solve" + [("n", IntTy)] + IntTy + ( If' + IntTy + (Equal' IntTy (Var "n") Lit0) + Lit1 + ( Mult' + (Var "n") + (App (Var "solve") [Minus' (Var "n") Lit1]) + ) + ) + (ResultExpr (Var "solve")) + run' prog `shouldBe` Right expected From 89eba10e3e6156fe2bbd58e801037763d8270270 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 11:29:41 +0900 Subject: [PATCH 47/56] refactor(core): Refactor utils to generate variable names --- src/Jikka/Core/Convert/ANormal.hs | 6 +++--- src/Jikka/Core/Convert/Alpha.hs | 16 ++++------------ 2 files changed, 7 insertions(+), 15 deletions(-) diff --git a/src/Jikka/Core/Convert/ANormal.hs b/src/Jikka/Core/Convert/ANormal.hs index aa08bb01..e79296bf 100644 --- a/src/Jikka/Core/Convert/ANormal.hs +++ b/src/Jikka/Core/Convert/ANormal.hs @@ -16,22 +16,22 @@ where import Jikka.Common.Alpha (MonadAlpha) import Jikka.Common.Error -import Jikka.Core.Convert.Alpha (gensym) import qualified Jikka.Core.Convert.Alpha as Alpha (runProgram) import Jikka.Core.Language.Expr import Jikka.Core.Language.Lint import Jikka.Core.Language.TypeCheck +import Jikka.Core.Language.Util destruct :: (MonadAlpha m, MonadError Error m) => TypeEnv -> Expr -> m (TypeEnv, Expr -> Expr, Expr) destruct env = \case e@Var {} -> return (env, id, e) e@Lit {} -> return (env, id, e) e@App {} -> do - x <- gensym + x <- genVarName' t <- typecheckExpr env e return ((x, t) : env, Let x t e, Var x) e@Lam {} -> do - x <- gensym + x <- genVarName' t <- typecheckExpr env e return ((x, t) : env, Let x t e, Var x) Let x t e1 e2 -> do diff --git a/src/Jikka/Core/Convert/Alpha.hs b/src/Jikka/Core/Convert/Alpha.hs index a08f036d..1ee222bd 100644 --- a/src/Jikka/Core/Convert/Alpha.hs +++ b/src/Jikka/Core/Convert/Alpha.hs @@ -18,19 +18,11 @@ import Jikka.Common.Alpha import Jikka.Common.Error import Jikka.Core.Language.Expr -gensym :: MonadAlpha m => m VarName -gensym = rename' (VarName "") <$> nextCounter - rename :: MonadAlpha m => VarName -> m VarName -rename hint = rename' hint <$> nextCounter - -rename' :: VarName -> Int -> VarName -rename' hint i = - let base = takeWhile (/= '$') (unVarName hint) - in VarName (base ++ "$" ++ show i) - --- ----------------------------------------------------------------------------- --- run +rename x = do + let base = takeWhile (/= '$') (unVarName x) + i <- nextCounter + return $ VarName (base ++ "$" ++ show i) runExpr :: (MonadAlpha m, MonadError Error m) => [(VarName, VarName)] -> Expr -> m Expr runExpr env = \case From 68c0ea8507c768d9d9cbf76a23ba66690ad71398 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 11:40:06 +0900 Subject: [PATCH 48/56] feat(cxx): Improve variable names in generated code --- src/Jikka/CPlusPlus/Convert/FromCore.hs | 44 +++++++++++++------- test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs | 14 +++---- 2 files changed, 37 insertions(+), 21 deletions(-) diff --git a/src/Jikka/CPlusPlus/Convert/FromCore.hs b/src/Jikka/CPlusPlus/Convert/FromCore.hs index 3cc3ab58..247f84ac 100644 --- a/src/Jikka/CPlusPlus/Convert/FromCore.hs +++ b/src/Jikka/CPlusPlus/Convert/FromCore.hs @@ -29,16 +29,32 @@ import qualified Jikka.Core.Language.TypeCheck as X -------------------------------------------------------------------------------- -- monad -newFreshName :: MonadAlpha m => String -> String -> m String -newFreshName base hint = do +data NameKind + = LocalNameKind + | LocalArgumentNameKind + | ConstantNameKind + | FunctionNameKind + | ArgumentNameKind + deriving (Eq, Ord, Show, Read) + +fromNameKind :: NameKind -> String +fromNameKind = \case + LocalNameKind -> "x" + LocalArgumentNameKind -> "b" + ConstantNameKind -> "c" + FunctionNameKind -> "f" + ArgumentNameKind -> "a" + +newFreshName :: MonadAlpha m => NameKind -> String -> m Y.VarName +newFreshName kind hint = do i <- nextCounter - let suffix = case takeWhile (\c -> isAlphaNum c || c == '_') hint of - "" -> "" - hint' -> "_" ++ hint' - return (base ++ show i ++ suffix) + let prefix = case takeWhile (\c -> isAlphaNum c || c == '_') hint of + "" -> fromNameKind kind + hint' -> hint' ++ "_" + return (Y.VarName (prefix ++ show i)) -renameVarName :: MonadAlpha m => String -> X.VarName -> m Y.VarName -renameVarName kind x = Y.VarName <$> newFreshName kind (X.unVarName x) +renameVarName :: MonadAlpha m => NameKind -> X.VarName -> m Y.VarName +renameVarName kind x = newFreshName kind (X.unVarName x) type Env = [(X.VarName, X.Type, Y.VarName)] @@ -176,7 +192,7 @@ runExpr env = \case return $ Y.Call (Y.Callable e) args X.Lam args e -> do args <- forM args $ \(x, t) -> do - y <- renameVarName "b" x + y <- renameVarName LocalArgumentNameKind x return (x, t, y) let env' = reverse args ++ env args <- forM args $ \(_, t, y) -> do @@ -190,7 +206,7 @@ runExpr env = \case runExprToStatements :: (MonadAlpha m, MonadError Error m) => Env -> X.Expr -> m [Y.Statement] runExprToStatements env = \case X.Let x t e1 e2 -> do - y <- renameVarName "x" x + y <- renameVarName LocalNameKind x t' <- runType t e1 <- runExpr env e1 e2 <- runExprToStatements ((x, t, y) : env) e2 @@ -208,7 +224,7 @@ runToplevelFunDef :: (MonadAlpha m, MonadError Error m) => Env -> Y.VarName -> [ runToplevelFunDef env f args ret body = do ret <- runType ret args <- forM args $ \(x, t) -> do - y <- renameVarName "a" x + y <- renameVarName ArgumentNameKind x return (x, t, y) body <- runExprToStatements (reverse args ++ env) body args <- forM args $ \(_, t, y) -> do @@ -231,7 +247,7 @@ runToplevelExpr env = \case let f = Y.VarName "solve" args <- forM ts $ \t -> do t <- runType t - y <- Y.VarName <$> newFreshName "a" "" + y <- newFreshName ArgumentNameKind "" return (t, y) ret <- runType ret e <- runExpr env e @@ -239,12 +255,12 @@ runToplevelExpr env = \case return [Y.FunDef ret f args body] _ -> runToplevelVarDef env (Y.VarName "ans") t e X.ToplevelLet x t e cont -> do - y <- renameVarName "c" x + y <- renameVarName ConstantNameKind x stmt <- runToplevelVarDef env y t e cont <- runToplevelExpr ((x, t, y) : env) cont return $ stmt ++ cont X.ToplevelLetRec f args ret body cont -> do - g <- renameVarName "f" f + g <- renameVarName FunctionNameKind f let t = X.FunTy (map snd args) ret stmt <- runToplevelFunDef ((f, t, g) : env) g args ret body cont <- runToplevelExpr ((f, t, g) : env) cont diff --git a/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs b/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs index a1f6decc..adfae70b 100644 --- a/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs +++ b/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs @@ -34,19 +34,19 @@ spec = describe "run" $ do let expectedF = Y.FunDef Y.TyInt64 - "f0_f" - [(Y.TyInt64, "a1_n")] + "f_0" + [(Y.TyInt64, "n_1")] [ Y.If - (Y.BinOp Y.Equal (Y.Var "a1_n") (Y.Lit (Y.LitInt64 0))) + (Y.BinOp Y.Equal (Y.Var "n_1") (Y.Lit (Y.LitInt64 0))) [Y.Return (Y.Lit (Y.LitInt64 1))] ( Just [ Y.Return ( Y.BinOp Y.Mul - (Y.Var "a1_n") + (Y.Var "n_1") ( Y.Call - (Y.Callable (Y.Var "f0_f")) - [Y.BinOp Y.Sub (Y.Var "a1_n") (Y.Lit (Y.LitInt64 1))] + (Y.Callable (Y.Var "f_0")) + [Y.BinOp Y.Sub (Y.Var "n_1") (Y.Lit (Y.LitInt64 1))] ) ) ] @@ -57,6 +57,6 @@ spec = describe "run" $ do Y.TyInt64 "solve" [(Y.TyInt64, "a2")] - [Y.Return (Y.Call (Y.Callable (Y.Var "f0_f")) [Y.Var "a2"])] + [Y.Return (Y.Call (Y.Callable (Y.Var "f_0")) [Y.Var "a2"])] let expected = Y.Program [expectedF, expectedSolve] run' prog `shouldBe` Right expected From 91eed45a42cd3740bed3cd6cf09dd19bbe0f9b03 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 11:54:45 +0900 Subject: [PATCH 49/56] fix(core): Fix execution of core --- src/Jikka/Core/Evaluate.hs | 6 ++++-- src/Jikka/Main/Subcommand/Execute.hs | 2 ++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index 9eec0a89..9f0937ca 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -14,7 +14,6 @@ -- `Jikka.Core.Evaluate` evaluates exprs to values. Also this recognizes users' inputs at once. -- -- The implementation assumes that all variable names don't conflict even when their scopes are distinct. --- Also this assumes that exprs allow the eager evaluation. Please use `Jikka.Core.Convert.MakeEager` if needed. module Jikka.Core.Evaluate ( run, run', @@ -30,6 +29,7 @@ import Data.Bits import Data.List (sort) import qualified Data.Vector as V import Jikka.Common.Error +import qualified Jikka.Core.Convert.MakeEager as MakeEager import Jikka.Core.Language.Expr import Jikka.Core.Language.TypeCheck (builtinToType) import Jikka.Core.Language.Value @@ -328,7 +328,9 @@ evaluateProgram tokens prog = do -- run run' :: (MonadFix m, MonadError Error m) => [Token] -> Program -> m Value -run' tokens prog = wrapError' "Jikka.Core.Evaluate.run' failed" $ evaluateProgram tokens prog +run' tokens prog = wrapError' "Jikka.Core.Evaluate.run' failed" $ do + prog <- MakeEager.run prog + evaluateProgram tokens prog run :: (MonadIO m, MonadFix m, MonadError Error m) => Program -> m Value run prog = do diff --git a/src/Jikka/Main/Subcommand/Execute.hs b/src/Jikka/Main/Subcommand/Execute.hs index 5c36321c..0e52c331 100644 --- a/src/Jikka/Main/Subcommand/Execute.hs +++ b/src/Jikka/Main/Subcommand/Execute.hs @@ -9,6 +9,7 @@ import Jikka.Common.Alpha import Jikka.Common.Error import qualified Jikka.Core.Evaluate as EvaluateCore import qualified Jikka.Core.Language.Value as ValueCore +import qualified Jikka.Core.Optimize as OptimizeCore import Jikka.Main.Target import qualified Jikka.Python.Convert.ToRestrictedPython as ToRestrictedPython import qualified Jikka.Python.Parse as FromPython @@ -36,6 +37,7 @@ runCore path = flip evalAlphaT 0 $ do prog <- liftEither $ FromPython.run path prog prog <- ToRestrictedPython.run prog prog <- ToCore.run prog + prog <- OptimizeCore.run prog value <- EvaluateCore.run prog liftIO $ putStrLn (ValueCore.formatValue value) From b5497d73acd6d9e83671732f8f91dd57e1d0a8b6 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 12:01:52 +0900 Subject: [PATCH 50/56] fix(core): Improve error messages from Jikka.Core.Convert.TypeInfer --- src/Jikka/Core/Convert/TypeInfer.hs | 11 ++++++----- src/Jikka/Core/Format.hs | 2 ++ 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Jikka/Core/Convert/TypeInfer.hs b/src/Jikka/Core/Convert/TypeInfer.hs index 838227cc..ce6182b2 100644 --- a/src/Jikka/Core/Convert/TypeInfer.hs +++ b/src/Jikka/Core/Convert/TypeInfer.hs @@ -23,6 +23,7 @@ import qualified Data.Map.Strict as M import Data.Monoid (Dual (..)) import Jikka.Common.Alpha import Jikka.Common.Error +import Jikka.Core.Format (formatType) import Jikka.Core.Language.Expr import Jikka.Core.Language.TypeCheck (literalToType, typecheckProgram) import Jikka.Core.Language.Util @@ -118,12 +119,12 @@ subst sigma = \case unifyTyVar :: (MonadState Subst m, MonadError Error m) => TypeName -> Type -> m () unifyTyVar x t = if x `elem` freeTyVars t - then throwInternalError $ "looped type equation " ++ show x ++ " = " ++ show t + then throwInternalError $ "looped type equation " ++ unTypeName x ++ " = " ++ formatType t else do modify' (Subst . M.insert x t . unSubst) -- This doesn't introduce the loop. unifyType :: (MonadState Subst m, MonadError Error m) => Type -> Type -> m () -unifyType t1 t2 = wrapError' ("failed to unify " ++ show t1 ++ " and " ++ show t2) $ do +unifyType t1 t2 = wrapError' ("failed to unify " ++ formatType t1 ++ " and " ++ formatType t2) $ do sigma <- get t1 <- return $ subst sigma t1 -- shadowing t2 <- return $ subst sigma t2 -- shadowing @@ -138,13 +139,13 @@ unifyType t1 t2 = wrapError' ("failed to unify " ++ show t1 ++ " and " ++ show t (TupleTy ts1, TupleTy ts2) -> do if length ts1 == length ts2 then mapM_ (uncurry unifyType) (zip ts1 ts2) - else throwInternalError $ "different types " ++ show t1 ++ " /= " ++ show t2 + else throwInternalError $ "different type ctors " ++ formatType t1 ++ " and " ++ formatType t2 (FunTy args1 ret1, FunTy args2 ret2) -> do if length args1 == length args2 then mapM_ (uncurry unifyType) (zip args1 args2) - else throwInternalError $ "different types " ++ show t1 ++ " /= " ++ show t2 + else throwInternalError $ "different type ctors " ++ formatType t1 ++ " and " ++ formatType t2 unifyType ret1 ret2 - _ -> throwInternalError $ "different types " ++ show t1 ++ " /= " ++ show t2 + _ -> throwInternalError $ "different type ctors " ++ formatType t1 ++ " and " ++ formatType t2 solveEquations :: MonadError Error m => [(Type, Type)] -> m Subst solveEquations eqns = wrapError' "failed to solve type equations" $ do diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index 18e8d26e..0183d799 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -13,6 +13,8 @@ module Jikka.Core.Format ( run, run', + formatType, + formatExpr, ) where From ff9c762892003edfca05e627a99b463e5e10403d Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 12:15:09 +0900 Subject: [PATCH 51/56] test(core): Fix a test name in Jikka.Core.Convert.TypeInferSpec --- test/Jikka/Core/Convert/TypeInferSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Jikka/Core/Convert/TypeInferSpec.hs b/test/Jikka/Core/Convert/TypeInferSpec.hs index a750e984..44bef749 100644 --- a/test/Jikka/Core/Convert/TypeInferSpec.hs +++ b/test/Jikka/Core/Convert/TypeInferSpec.hs @@ -77,7 +77,7 @@ spec = describe "run" $ do (Var "x") (ResultExpr Lit0) run' prog `shouldBe` Right expected - it "works on fact" $ do + it "works on builtin functions" $ do let prog = ToplevelLetRec "solve" From ce08e17500e94c2a2b65a3837e26f30d94ee2d76 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 12:33:59 +0900 Subject: [PATCH 52/56] feat(core): Improve error messages --- src/Jikka/Core/Evaluate.hs | 15 ++++++------- src/Jikka/Core/Format.hs | 22 +++++++++++++------- src/Jikka/Core/Language/Value.hs | 5 +++-- src/Jikka/RestrictedPython/Language/Value.hs | 12 +++++++++++ 4 files changed, 38 insertions(+), 16 deletions(-) diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index 9f0937ca..3628b4ff 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -26,10 +26,11 @@ where import Control.Monad.Except import Control.Monad.State.Strict import Data.Bits -import Data.List (sort) +import Data.List (intercalate, sort) import qualified Data.Vector as V import Jikka.Common.Error import qualified Jikka.Core.Convert.MakeEager as MakeEager +import Jikka.Core.Format (formatBuiltinIsolated) import Jikka.Core.Language.Expr import Jikka.Core.Language.TypeCheck (builtinToType) import Jikka.Core.Language.Value @@ -69,7 +70,7 @@ readInputMap ts tokens = case ts of readInput :: MonadError Error m => Type -> [Token] -> m (Value, [Token]) readInput t tokens = case (t, tokens) of - (VarTy a, _) -> throwInternalError $ "input type is undetermined: " ++ show a + (VarTy a, _) -> throwInternalError $ "input type is undetermined: type variable " ++ unTypeName a (IntTy, token : tokens) -> do n <- readToken token return (ValInt n, tokens) @@ -147,7 +148,7 @@ map' f a = V.fromList <$> mapM (\val -> callValue f [val]) (V.toList a) atEither :: MonadError Error m => V.Vector a -> Integer -> m a atEither xs i = case xs V.!? fromInteger i of Just x -> return x - Nothing -> throwRuntimeError $ "out of bounds: " ++ show (V.length xs, i) + Nothing -> throwRuntimeError $ "out of bounds: length = " ++ show (V.length xs) ++ ", index = " ++ show i sortVector :: Ord a => V.Vector a -> V.Vector a sortVector = V.fromList . sort . V.toList @@ -255,7 +256,7 @@ callBuiltin builtin args = case (builtin, args) of (Choose, [ValInt n, ValInt r]) -> ValInt <$> choose n r (Permute, [ValInt n, ValInt r]) -> ValInt <$> permute n r (MultiChoose, [ValInt n, ValInt r]) -> ValInt <$> multichoose n r - _ -> throwInternalError $ "invalid builtin call: " ++ show (builtin, args) + _ -> throwInternalError $ "invalid builtin call: " ++ formatBuiltinIsolated builtin ++ "(" ++ intercalate "," (map formatValue args) ++ ")" callLambda :: MonadError Error m => Env -> [(VarName, Type)] -> Expr -> [Value] -> m Value callLambda env formalArgs body actualArgs = case (formalArgs, actualArgs) of @@ -267,12 +268,12 @@ callValue :: MonadError Error m => Value -> [Value] -> m Value callValue f args = case f of ValBuiltin builtin -> callBuiltin builtin args ValLambda env args' body -> callLambda env args' body args - _ -> throwInternalError $ "call non-function: " ++ show f + _ -> throwInternalError $ "call non-function: " ++ formatValue f evaluateExpr :: MonadError Error m => Env -> Expr -> m Value evaluateExpr env = \case Var x -> case lookup x env of - Nothing -> throwRuntimeError $ "Internal Error: undefined variable: " ++ show (unVarName x) + Nothing -> throwRuntimeError $ "Internal Error: undefined variable: " ++ unVarName x Just val -> return val Lit lit -> return $ literalToValue lit App f args -> do @@ -322,7 +323,7 @@ evaluateProgram tokens prog = do (val, tokens) <- evaluateToplevelExpr tokens [] prog if null tokens then return val - else throwWrongInputError $ "evaluation succeeds, but unused inputs remain: " ++ show (val, tokens) + else throwWrongInputError $ "evaluation succeeds, but unused inputs remain: value = " ++ formatValue val ++ ", tokens = " ++ show tokens -- ----------------------------------------------------------------------------- -- run diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs index 0183d799..883ac274 100644 --- a/src/Jikka/Core/Format.hs +++ b/src/Jikka/Core/Format.hs @@ -13,6 +13,8 @@ module Jikka.Core.Format ( run, run', + formatBuiltinIsolated, + formatBuiltin, formatType, formatExpr, ) @@ -137,26 +139,32 @@ formatTemplate = \case formatFunCall :: String -> [Type] -> [Expr] -> String formatFunCall f _ args = f ++ "(" ++ intercalate ", " (map formatExpr args) ++ ")" -formatBuiltinIsolated :: Builtin' -> String -formatBuiltinIsolated = \case +formatBuiltinIsolated' :: Builtin' -> String +formatBuiltinIsolated' = \case Fun ts name -> name ++ formatTemplate ts PrefixOp op -> paren op InfixOp ts op -> paren $ op ++ formatTemplate ts At' t -> paren $ "at" ++ formatTemplate [t] If' t -> paren $ "if-then-else" ++ formatTemplate [t] -formatBuiltin :: Builtin' -> [Expr] -> String -formatBuiltin builtin args = case (builtin, args) of +formatBuiltinIsolated :: Builtin -> String +formatBuiltinIsolated = formatBuiltinIsolated' . analyzeBuiltin + +formatBuiltin' :: Builtin' -> [Expr] -> String +formatBuiltin' builtin args = case (builtin, args) of (Fun ts name, _) -> formatFunCall name ts args (PrefixOp op, [e1]) -> paren $ op ++ " " ++ formatExpr e1 (InfixOp _ op, [e1, e2]) -> paren $ formatExpr e1 ++ " " ++ op ++ " " ++ formatExpr e2 (At' _, [e1, e2]) -> paren $ formatExpr e1 ++ ")[" ++ formatExpr e2 ++ "]" (If' _, [e1, e2, e3]) -> paren $ "if" ++ " " ++ formatExpr e1 ++ " then " ++ formatExpr e2 ++ " else " ++ formatExpr e3 - _ -> formatFunCall (formatBuiltinIsolated builtin) [] args + _ -> formatFunCall (formatBuiltinIsolated' builtin) [] args + +formatBuiltin :: Builtin -> [Expr] -> String +formatBuiltin = formatBuiltin' . analyzeBuiltin formatLiteral :: Literal -> String formatLiteral = \case - LitBuiltin builtin -> formatBuiltinIsolated (analyzeBuiltin builtin) + LitBuiltin builtin -> formatBuiltinIsolated builtin LitInt n -> show n LitBool p -> map toLower $ show p LitNil t -> "nil" ++ formatTemplate [t] @@ -170,7 +178,7 @@ formatExpr = \case Lit lit -> formatLiteral lit App f args -> case f of Var x -> formatFunCall (unVarName x) [] args - Lit (LitBuiltin builtin) -> formatBuiltin (analyzeBuiltin builtin) args + Lit (LitBuiltin builtin) -> formatBuiltin builtin args _ -> formatFunCall (formatExpr f) [] args Lam args e -> paren $ "fun " ++ formatFormalArgs args ++ " ->\n" ++ indent ++ "\n" ++ formatExpr e ++ "\n" ++ dedent ++ "\n" Let x t e1 e2 -> "let " ++ unVarName x ++ ": " ++ formatType t ++ " =\n" ++ indent ++ "\n" ++ formatExpr e1 ++ "\n" ++ dedent ++ "\nin " ++ formatExpr e2 diff --git a/src/Jikka/Core/Language/Value.hs b/src/Jikka/Core/Language/Value.hs index a9b8285b..514e40d8 100644 --- a/src/Jikka/Core/Language/Value.hs +++ b/src/Jikka/Core/Language/Value.hs @@ -47,7 +47,8 @@ formatValue :: Value -> String formatValue = \case ValInt n -> show n ValBool p -> map toLower (show p) - ValList xs -> intercalate "\n" (map formatValue (V.toList xs)) - ValTuple xs -> intercalate "\n" (map formatValue xs) + ValList xs -> "[" ++ intercalate ", " (map formatValue (V.toList xs)) ++ "]" + ValTuple [x] -> "(" ++ formatValue x ++ ",)" + ValTuple xs -> "(" ++ intercalate ", " (map formatValue xs) ++ ")" ValBuiltin builtin -> show builtin f@ValLambda {} -> show f diff --git a/src/Jikka/RestrictedPython/Language/Value.hs b/src/Jikka/RestrictedPython/Language/Value.hs index c80b0d54..cef0607b 100644 --- a/src/Jikka/RestrictedPython/Language/Value.hs +++ b/src/Jikka/RestrictedPython/Language/Value.hs @@ -4,6 +4,8 @@ module Jikka.RestrictedPython.Language.Value where +import Data.Char (toLower) +import Data.List (intercalate) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) import qualified Data.Vector as V @@ -110,6 +112,16 @@ makeEntryPointIO f global = do return $ Call (Name f) args _ -> throwSymbolError $ "not a function: " ++ unVarName f +formatValue :: Value -> String +formatValue = \case + IntVal n -> show n + BoolVal p -> map toLower (show p) + ListVal xs -> "[" ++ intercalate ", " (map formatValue (V.toList xs)) ++ "]" + TupleVal [x] -> "(" ++ formatValue x ++ ",)" + TupleVal xs -> "(" ++ intercalate ", " (map formatValue xs) ++ ")" + f@ClosureVal {} -> show f + BuiltinVal b -> show b + writeValueIO :: Value -> IO () writeValueIO = \case IntVal n -> print n From 90068dd2d3e1aa5b9d5d2cb0d3bebe6e7e0dd808 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 13:08:16 +0900 Subject: [PATCH 53/56] fix(core): Define evaluation rules of all builtin functions --- src/Jikka/Core/Evaluate.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs index 3628b4ff..2850aae4 100644 --- a/src/Jikka/Core/Evaluate.hs +++ b/src/Jikka/Core/Evaluate.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -- | -- Module : Jikka.Core.Evaluate @@ -139,6 +140,11 @@ powmod :: MonadError Error m => Integer -> Integer -> Integer -> m Integer powmod _ _ m | m <= 0 = throwRuntimeError $ "invalid argument for powmod: MOD = " ++ show m powmod a b m = return $ (a ^ b) `mod` m +scanM :: Monad m => (a -> b -> m a) -> a -> V.Vector b -> m (V.Vector a) +scanM f y xs = do + (ys, y) <- V.foldM (\(ys, y) x -> (y : ys,) <$> f y x) ([], y) xs + return $ V.fromList (reverse (y : ys)) + tabulate :: MonadError Error m => Integer -> Value -> m (V.Vector Value) tabulate n f = V.fromList <$> mapM (\i -> callValue f [ValInt i]) [0 .. n - 1] @@ -150,6 +156,12 @@ atEither xs i = case xs V.!? fromInteger i of Just x -> return x Nothing -> throwRuntimeError $ "out of bounds: length = " ++ show (V.length xs) ++ ", index = " ++ show i +setAtEither :: MonadError Error m => V.Vector a -> Integer -> a -> m (V.Vector a) +setAtEither xs i x = + if 0 <= i && i < fromIntegral (V.length xs) + then return $ xs V.// [(fromInteger i, x)] + else throwRuntimeError $ "out of bounds: length = " ++ show (V.length xs) ++ ", index = " ++ show i + sortVector :: Ord a => V.Vector a -> V.Vector a sortVector = V.fromList . sort . V.toList @@ -223,10 +235,15 @@ callBuiltin builtin args = case (builtin, args) of (ModPow, [ValInt a, ValInt b, ValInt c]) -> ValInt <$> powmod a b c -- list functions (Cons _, [x, ValList xs]) -> return $ ValList (V.cons x xs) + (Foldl _ _, [f, x, ValList a]) -> V.foldM (\x y -> callValue f [x, y]) x a + (Scanl _ _, [f, x, ValList a]) -> ValList <$> scanM (\x y -> callValue f [x, y]) x a (Len _, [ValList a]) -> return $ ValInt (fromIntegral (V.length a)) (Tabulate _, [ValInt n, f]) -> ValList <$> tabulate n f (Map _ _, [f, ValList a]) -> ValList <$> map' f a + (Filter _, [f, ValList a]) -> ValList <$> V.filterM (\x -> (/= ValBool False) <$> callValue f [x]) a -- TODO (At _, [ValList a, ValInt n]) -> atEither a n + (SetAt _, [ValList a, ValInt n, x]) -> ValList <$> setAtEither a n x + (Elem _, [x, ValList a]) -> return $ ValBool (x `V.elem` a) (Sum, [ValList a]) -> ValInt . sum <$> valueToIntList a (Product, [ValList a]) -> ValInt . product <$> valueToIntList a (Min1 IntTy, [ValList a]) -> ValInt <$> (minimumEither =<< valueToIntList a) -- TODO: allow non-integers From 96433cb6eec88868361ea95bf9daa7b9a1b70fc6 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 13:09:03 +0900 Subject: [PATCH 54/56] fix(rpython): Fix Jikka.RestrictedPython.Covert.ToCore --- src/Jikka/RestrictedPython/Convert/ToCore.hs | 5 ++-- .../RestrictedPython/Convert/ToCoreSpec.hs | 28 +++++++++---------- 2 files changed, 17 insertions(+), 16 deletions(-) diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs index 5ef259a1..34c264ce 100644 --- a/src/Jikka/RestrictedPython/Convert/ToCore.hs +++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs @@ -246,15 +246,16 @@ runForStatement :: (MonadState Env m, MonadAlpha m, MonadError Error m) => X.Tar runForStatement x iter body cont = do tx <- Y.genType iter <- runExpr iter + x' <- Y.genVarName' z <- Y.genVarName' let (_, X.WriteList w) = X.analyzeStatementsMax body ys <- filterM isDefinedVar w ts <- replicateM (length ys) Y.genType let init = Y.Tuple' ts (map (Y.Var . runVarName) ys) let write cont = foldr (\(i, y, t) -> Y.Let (runVarName y) t (Y.Proj' ts i (Y.Var z))) cont (zip3 [0 ..] ys ts) - body <- runAssign x (Y.Var z) $ do + body <- runAssign x (Y.Var x') $ do runStatements (body ++ [X.Return (X.Tuple (map X.Name ys))]) - let loop init = Y.Foldl' tx (Y.TupleTy ts) (Y.Lam [(z, Y.TupleTy ts)] (write body)) init iter + let loop init = Y.Foldl' tx (Y.TupleTy ts) (Y.Lam [(z, Y.TupleTy ts), (x', tx)] (write body)) init iter cont <- runStatements cont return $ Y.Let z (Y.TupleTy ts) (loop init) (write cont) diff --git a/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs b/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs index fa1f629c..4aed088f 100644 --- a/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs +++ b/test/Jikka/RestrictedPython/Convert/ToCoreSpec.hs @@ -72,26 +72,26 @@ spec = describe "run" $ do " 0", " in let b: $1 =", " 1", - " in let $3: ($4 * $5) =", - " foldl((fun ($3: ($4 * $5)) ->", - " let b: $4 =", - " proj0($3)", - " in let a: $5 =", - " proj1($3)", - " in let i: $6 =", + " in let $4: ($5 * $6) =", + " foldl((fun ($4: ($5 * $6)) ($3: $2) ->", + " let b: $5 =", + " proj0($4)", + " in let a: $6 =", + " proj1($4)", + " in let i: $7 =", " $3", - " in let c: $7 =", + " in let c: $8 =", " (a + b)", - " in let a: $8 =", + " in let a: $9 =", " b", - " in let b: $9 =", + " in let b: $10 =", " c", " in tuple(b, a)", " ), tuple(b, a), range1(n))", - " in let b: $4 =", - " proj0($3)", - " in let a: $5 =", - " proj1($3)", + " in let b: $5 =", + " proj0($4)", + " in let a: $6 =", + " proj1($4)", " in a", "in", "solve" From 1f77ecbec86208a92dfbe7b3645268ed004aef7b Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 13:10:02 +0900 Subject: [PATCH 55/56] test: Now execution of core language works! --- examples/test.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/test.sh b/examples/test.sh index 7db630a6..356375bf 100644 --- a/examples/test.sh +++ b/examples/test.sh @@ -2,5 +2,5 @@ set -ex for f in examples/*.in ; do diff <(stack --system-ghc run -- execute --target rpython ${f%.in}.py < $f) ${f%.in}.out - # diff <(stack --system-ghc run -- execute --target core ${f%.in}.py < $f) ${f%.in}.out + diff <(stack --system-ghc run -- execute --target core ${f%.in}.py < $f) ${f%.in}.out done From 4a9b078c584945283baa6375c5270f7107a777d9 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Wed, 23 Jun 2021 13:16:36 +0900 Subject: [PATCH 56/56] chore: v5.0.3.0 --- CHANGELOG.md | 6 ++++++ package.yaml | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b6209a62..998e57b0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,13 @@ # Changelog for Jikka +## 2021-06-23: v5.0.3.0 + +Now the conversion from restricted Python to core works. + ## 2021-06-19: v5.0.2.0 +Most conversions in restricted Python are implemented. + ## 2020-12-03: v5.0.1.0 `v5.0.1.0` is the first version of the third prototype. diff --git a/package.yaml b/package.yaml index e6cfb2f6..e62eb11a 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: Jikka -version: 5.0.2.0 +version: 5.0.3.0 github: "kmyk/Jikka" license: Apache author: "Kimiyuki Onaka"