From 16c1271379490845b84ed3e6e94156cc04c62f8a Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 16:29:38 +0100 Subject: [PATCH 01/24] ES: added some tests to LintSpec --- grin/test/ExtendedSyntax/LintSpec.hs | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/grin/test/ExtendedSyntax/LintSpec.hs b/grin/test/ExtendedSyntax/LintSpec.hs index 999b1d14..9ed425d4 100644 --- a/grin/test/ExtendedSyntax/LintSpec.hs +++ b/grin/test/ExtendedSyntax/LintSpec.hs @@ -32,6 +32,19 @@ spec = do let (_, errors) = lint allWarnings Nothing program lintErrors errors `shouldBe` ["undefined variable: p3"] + it "keeps track of as-pattern-bound variables" $ do + let program = withPrimPrelude [prog| + grinMain = + k0 <- pure 0 + n0 <- pure (CInt k0) + (CInt k1) @ n1 <- pure n0 + _1 <- pure n1 + _2 <- pure k1 + pure () + |] + let (_, errors) = lint allWarnings Nothing program + lintErrors errors `shouldBe` [] + describe "Function call lint" $ do it "finds variable used as a function" $ do let program = [prog| @@ -166,6 +179,17 @@ spec = do let (_,errors) = lint allWarnings Nothing program lintErrors errors `shouldBe` ["case has more than one default alternatives"] + it "keeps track of alt-bound variables" $ do + let program = [prog| + main = + n <- pure 3 + case n of + 0 @ m1 -> pure m1 + #default @ m2 -> pure m2 + |] + let (_,errors) = lint allWarnings Nothing program + lintErrors errors `shouldBe` [] + describe "Store lint" $ do it "finds primitive value as argument." $ do let program = [prog| From b0fd9d72fa0225fd99cb2f2246009297894825b3 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 16:43:14 +0100 Subject: [PATCH 02/24] ES: fixed name def collection for as-patterns --- grin/src/Transformations/ExtendedSyntax/Util.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/grin/src/Transformations/ExtendedSyntax/Util.hs b/grin/src/Transformations/ExtendedSyntax/Util.hs index 06503e00..d0d8ae1d 100644 --- a/grin/src/Transformations/ExtendedSyntax/Util.hs +++ b/grin/src/Transformations/ExtendedSyntax/Util.hs @@ -47,6 +47,8 @@ foldNameUseExpF f = \case SFetchF p -> f p _ -> mempty +-- TODO: In the entire codebase, only FunName is used. +-- By used, I mean its value is consumed/pattern-matched on. data DefRole = FunName | FunParam | BindVar | AltVar deriving (Eq, Show) @@ -54,7 +56,9 @@ data DefRole = FunName | FunParam | BindVar | AltVar foldNameDefExpF :: (Monoid m) => (DefRole -> Name -> m) -> ExpF a -> m foldNameDefExpF f = \case DefF name args _ -> mconcat $ (f FunName name) : map (f FunParam) args - EBindF _ bPat _ -> f BindVar (_bPatVar bPat) + EBindF _ bPat _ -> case bPat of + VarPat v -> f BindVar v + AsPat _tag args asVarName -> f BindVar asVarName <> foldMap (f BindVar) args -- QUESTION: What should be the alt name's DefRole? Now it is BindVar, because it rebinds the scrutinee. AltF cpat n _ -> f BindVar n <> foldNames (f AltVar) cpat _ -> mempty From 500ebaa08a13e00ed43951b70d43683d6195e882 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 22:15:01 +0100 Subject: [PATCH 03/24] ES: added more CaseHoisting tests --- .../Optimising/CaseHoistingSpec.hs | 80 +++++++++++++++++-- 1 file changed, 72 insertions(+), 8 deletions(-) diff --git a/grin/test/Transformations/ExtendedSyntax/Optimising/CaseHoistingSpec.hs b/grin/test/Transformations/ExtendedSyntax/Optimising/CaseHoistingSpec.hs index f161b63f..2a9e5cf1 100644 --- a/grin/test/Transformations/ExtendedSyntax/Optimising/CaseHoistingSpec.hs +++ b/grin/test/Transformations/ExtendedSyntax/Optimising/CaseHoistingSpec.hs @@ -16,7 +16,7 @@ runTests = hspec spec spec :: Spec spec = do - it "last case" $ do + it "last case 1" $ do let before = [prog| grinMain = v <- pure (CNil) @@ -34,17 +34,81 @@ spec = do (CNil) @ alt1 -> u.0 <- do pure (CNil) - alt3.0 <- pure u.0 + (CNil) @ alt3.0 <- pure u.0 pure alt3.0 (CCons a1 b1) @ alt2 -> u.1 <- do pure (CCons a1 b1) - alt4.0 <- pure u.1 + (CCons a2.0 b2.0) @ alt4.0 <- pure u.1 + pure (CNil) + |] + caseHoisting (inferTypeEnv before) before `sameAs` (after, NewNames) + + it "last case 2" $ do + let before = [prog| + grinMain = + v <- pure (CNil) + u <- case v of + (CNil) @ alt1 -> + pure (CNil) + (CCons a1 b1) @ alt2 -> + pure (CCons a1 b1) + case u of + (CNil) @ alt3 -> + pure alt3 + (CCons a2 b2) @ alt4 -> + pure (CCons a2 b2) + |] + let after = [prog| + grinMain = + v <- pure (CNil) + case v of + (CNil) @ alt1 -> + u.0 <- do + pure (CNil) + (CNil) @ alt3.0 <- pure u.0 + pure alt3.0 + (CCons a1 b1) @ alt2 -> + u.1 <- do + pure (CCons a1 b1) + (CCons a2.0 b2.0) @ alt4.0 <- pure u.1 + pure (CCons a2.0 b2.0) + |] + caseHoisting (inferTypeEnv before) before `sameAs` (after, NewNames) + + it "middle case 1" $ do + let before = [prog| + grinMain = + v <- pure (CNil) + u <- case v of + (CNil) @ alt1 -> pure (CNil) + (CCons a1 b1) @ alt2 -> + pure (CCons a1 b1) + r <- case u of + (CNil) @ alt3 -> pure 1 + (CCons a2 b2) @ alt4 -> pure 2 + pure r + |] + let after = [prog| + grinMain = + v <- pure (CNil) + r <- case v of + (CNil) @ alt1 -> + u.0 <- do + pure (CNil) + (CNil) @ alt3.0 <- pure u.0 + pure 1 + (CCons a1 b1) @ alt2 -> + u.1 <- do + pure (CCons a1 b1) + (CCons a2.0 b2.0) @ alt4.0 <- pure u.1 + pure 2 + pure r |] caseHoisting (inferTypeEnv before) before `sameAs` (after, NewNames) - it "middle case" $ do + it "middle case 2" $ do let before = [prog| grinMain = v <- pure (CNil) @@ -63,12 +127,12 @@ spec = do (CNil) @ alt1 -> u.0 <- do pure (CNil) - alt3.0 <- pure u.0 + (CNil) @ alt3.0 <- pure u.0 pure 1 (CCons a1 b1) @ alt2 -> u.1 <- do pure (CCons a1 b1) - alt4.0 <- pure u.1 + (CCons a2.0 b2.0) @ alt4.0 <- pure u.1 pure 2 pure r |] @@ -93,7 +157,7 @@ spec = do (CNil) @ alt1 -> u.0 <- do pure (CNil) - alt3.0 <- pure u.0 + (CNil) @ alt3.0 <- pure u.0 pure (CNil) (CCons a1 b1) @ alt2 -> u.1 <- do @@ -130,7 +194,7 @@ spec = do 0 @ alt1 -> u.0 <- do pure (CNil) - alt3.0 <- pure u.0 + (CNil) @ alt3.0 <- pure u.0 pure (CEmpty) 1 @ alt2 -> u.1 <- do From fbf21bd9fc2195f52d709bc0249072e1553d92dd Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 22:15:10 +0100 Subject: [PATCH 04/24] ES: fixed CaseHoisting bug Prviously, CaseHoisting didn't introduce a binding for the CPat in the hoisted alternative. --- .../ExtendedSyntax/Optimising/CaseHoisting.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/grin/src/Transformations/ExtendedSyntax/Optimising/CaseHoisting.hs b/grin/src/Transformations/ExtendedSyntax/Optimising/CaseHoisting.hs index f29f1090..1ec1c532 100644 --- a/grin/src/Transformations/ExtendedSyntax/Optimising/CaseHoisting.hs +++ b/grin/src/Transformations/ExtendedSyntax/Optimising/CaseHoisting.hs @@ -15,6 +15,7 @@ import qualified Data.Vector as Vector import Data.Bifunctor (first) import Grin.ExtendedSyntax.Grin +import Grin.ExtendedSyntax.Pretty import Grin.ExtendedSyntax.TypeEnv import Transformations.ExtendedSyntax.Util import Transformations.ExtendedSyntax.Names @@ -80,8 +81,12 @@ hoistAlts :: Name -> (Alt, Alt) -> NameM Alt hoistAlts lpatName (Alt cpat1 altName1 alt1, Alt cpat2 altName2 alt2) = do freshLPatName <- deriveNewName lpatName let nameMap = Map.singleton lpatName freshLPatName - (freshAlt2, _) <- refreshNames nameMap $ - EBind (SReturn $ Var freshLPatName) (VarPat altName2) alt2 + (freshAlt2, _) <- case cpat2 of + DefaultPat -> refreshNames nameMap $ + EBind (SReturn $ Var freshLPatName) (VarPat altName2) alt2 + NodePat tag args -> refreshNames nameMap $ + EBind (SReturn $ Var freshLPatName) (AsPat tag args altName2) alt2 + LitPat _ -> error $ "CaseHoisting does not support literal CPats: " ++ show (PP altName2) pure . Alt cpat1 altName1 $ EBind (SBlock alt1) (VarPat freshLPatName) freshAlt2 disjointMatch :: [(Set Tag, Alt)] -> [Alt] -> Maybe [(Alt, Alt)] From 83622e5e49815f86a25fe839af7819c0f558ec96 Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 18 Feb 2020 00:40:27 +0100 Subject: [PATCH 05/24] ES: added more tests to ArityRaising --- .../Optimising/ArityRaisingSpec.hs | 40 +++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/grin/test/Transformations/ExtendedSyntax/Optimising/ArityRaisingSpec.hs b/grin/test/Transformations/ExtendedSyntax/Optimising/ArityRaisingSpec.hs index fba85c1f..f6c3a8e5 100644 --- a/grin/test/Transformations/ExtendedSyntax/Optimising/ArityRaisingSpec.hs +++ b/grin/test/Transformations/ExtendedSyntax/Optimising/ArityRaisingSpec.hs @@ -27,6 +27,46 @@ spec = do let tyEnv = inferTypeEnv testProgBefore arityRaising 0 tyEnv testProgBefore `sameAs` (testProgAfter, NewNames) + it "raises what can be raised, does not raise what cannot be reaised" $ do + let before = [prog| + grinMain = + k0 <- pure 0 + k1 <- pure 0 + n0 <- pure (CPair k0 k0) + n1 <- pure (CInt k1) + p1 <- store n0 + p2 <- store n1 + foo p1 p2 + + foo r q = + q' <- fetch q + r' <- fetch r + _0 <- pure r' + _1 <- pure q + foo r q + |] + let after = [prog| + grinMain = + k0 <- pure 0 + k1 <- pure 0 + n0 <- pure (CPair k0 k0) + n1 <- pure (CInt k1) + p1 <- store n0 + p2 <- store n1 + do + (CPair p1.0.0.arity.1 p1.0.0.arity.2) @ _2 <- fetch p1 + foo $ p1.0.0.arity.1 p1.0.0.arity.2 p2 + + foo r.0.arity.1 r.0.arity.2 q = + q' <- fetch q + r' <- pure (CPair r.0.arity.1 r.0.arity.2) + _0 <- pure r' + _1 <- pure q + foo $ r.0.arity.1 r.0.arity.2 q + |] + let tyEnv = inferTypeEnv before + arityRaising 0 tyEnv before `sameAs` (after, NewNames) + testProgBefore :: Exp testProgBefore = [prog| grinMain = From 470f1a3080f33bc537e88fc6a789487d43d4085e Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 18 Feb 2020 00:41:02 +0100 Subject: [PATCH 06/24] ES: fixed ArityRaising bugs Previously, ArityRaising collected invalid information about function application arguments, and it didn't handle properly unraisable arguments. --- .../ExtendedSyntax/Optimising/ArityRaising.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/grin/src/Transformations/ExtendedSyntax/Optimising/ArityRaising.hs b/grin/src/Transformations/ExtendedSyntax/Optimising/ArityRaising.hs index 7f2aa41a..5d930197 100644 --- a/grin/src/Transformations/ExtendedSyntax/Optimising/ArityRaising.hs +++ b/grin/src/Transformations/ExtendedSyntax/Optimising/ArityRaising.hs @@ -12,6 +12,8 @@ import Control.Monad.State.Strict import Grin.ExtendedSyntax.Grin (packName, unpackName) import Grin.ExtendedSyntax.Syntax +-- TODO: remove this +import Grin.ExtendedSyntax.Pretty import Grin.ExtendedSyntax.TypeEnv import Transformations.ExtendedSyntax.Names @@ -88,7 +90,7 @@ phase1 :: TypeEnv -> Exp -> ArityData phase1 te = pdArityData . cata collect where collect :: ExpF Phase1Data -> Phase1Data collect = \case - SAppF fn ps -> mempty { bdFunCall = map (fn,) ps, bdOther = ps } + SAppF fn ps -> mempty { bdFunCall = map (fn,) ps } SFetchF var -> mempty { bdFetch = Map.singleton var 1 } SUpdateF ptr var -> mempty { bdOther = [ptr, var] } SReturnF val -> mempty { bdOther = variableInNode val ++ variableInVar val } @@ -180,13 +182,12 @@ phase2 n arityData exp = evalVarM 0 exp $ cata change exp where | Just aritedParams <- Map.lookup f arityData -> do idx <- get let qsi = Map.fromList $ map (\(_,i,t) -> (i,t)) aritedParams - nsi = Map.fromList $ map (\(n,i,t) -> (n,t)) aritedParams + nsi = Map.fromList $ map (\(n,_,t) -> (n,t)) aritedParams psi = [1..] `zip` fps newPs = flip concatMap psi $ \case (_, n) | Just (t, jth) <- Map.lookup n nsi -> newParNames n jth (i, n) | Just (t, jth) <- Map.lookup i qsi -> fetchParNames n idx jth - -- (i, Undefined{}) | Just (_, jth) <- Map.lookup i qsi -> replicate jth (Undefined dead_t) - -- (_, other) -> [other] + (_, other) -> [other] fetches <- fmap catMaybes $ forM psi $ \case (_, n) | Just _ <- Map.lookup n nsi -> pure Nothing (i, n) | Just (t, jth) <- Map.lookup i qsi -> do From 6a8927b3f5f7ec24ffad5ae392ed7f3a988b7e17 Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 18 Feb 2020 00:57:30 +0100 Subject: [PATCH 07/24] ES: added optimized sum_simple test cases to reducers --- grin/test/Reducer/ExtendedSyntax/IOSpec.hs | 24 +++++++++++++++++++ grin/test/Reducer/ExtendedSyntax/PureSpec.hs | 25 ++++++++++++++++++++ 2 files changed, 49 insertions(+) diff --git a/grin/test/Reducer/ExtendedSyntax/IOSpec.hs b/grin/test/Reducer/ExtendedSyntax/IOSpec.hs index 31e0b57d..3947e918 100644 --- a/grin/test/Reducer/ExtendedSyntax/IOSpec.hs +++ b/grin/test/Reducer/ExtendedSyntax/IOSpec.hs @@ -125,6 +125,9 @@ spec = do it "sum_simple" $ do reduceFun sumSimple "grinMain" `shouldReturn` RT_Lit (LInt64 50005000) + it "sum_simple_opt" $ do + reduceFun sumSimpleOpt "grinMain" `shouldReturn` RT_Lit (LInt64 50005000) + sumSimple :: Exp sumSimple = withPrimPrelude [prog| grinMain = @@ -216,3 +219,24 @@ sumSimple = withPrimPrelude [prog| p.6 <- update q z pure z |] + +sumSimpleOpt :: Exp +sumSimpleOpt = withPrimPrelude [prog| + grinMain = + y.0 <- pure 1 + y.1 <- pure 10000 + sum.unboxed $ y.0 y.1 + + sum.unboxed l.75.arity.1.207.arity.1 l.75.arity.2.265.arity.1 = + b'.0 <- _prim_int_gt $ l.75.arity.1.207.arity.1 l.75.arity.2.265.arity.1 + case b'.0 of + #True @ alt.0.0 -> + y.10.0 <- pure 0 + pure y.10.0 + #False @ alt.1.0 -> + x.7.0 <- pure 1 + m1'.0 <- _prim_int_add $ l.75.arity.1.207.arity.1 x.7.0 + unboxed.CInt.3.0 <- sum.unboxed $ m1'.0 l.75.arity.2.265.arity.1 + ax'.0 <- _prim_int_add $ l.75.arity.1.207.arity.1 unboxed.CInt.3.0 + pure ax'.0 +|] diff --git a/grin/test/Reducer/ExtendedSyntax/PureSpec.hs b/grin/test/Reducer/ExtendedSyntax/PureSpec.hs index 59be2555..472f087b 100644 --- a/grin/test/Reducer/ExtendedSyntax/PureSpec.hs +++ b/grin/test/Reducer/ExtendedSyntax/PureSpec.hs @@ -122,6 +122,10 @@ spec = do it "sum_simple" $ do reduceFun sumSimple "grinMain" `shouldReturn` RT_Lit (LInt64 50005000) + it "sum_simple_opt" $ do + reduceFun sumSimpleOpt "grinMain" `shouldReturn` RT_Lit (LInt64 50005000) + + sumSimple :: Exp sumSimple = withPrimPrelude [prog| grinMain = @@ -213,3 +217,24 @@ sumSimple = withPrimPrelude [prog| p.6 <- update q z pure z |] + +sumSimpleOpt :: Exp +sumSimpleOpt = withPrimPrelude [prog| + grinMain = + y.0 <- pure 1 + y.1 <- pure 10000 + sum.unboxed $ y.0 y.1 + + sum.unboxed l.75.arity.1.207.arity.1 l.75.arity.2.265.arity.1 = + b'.0 <- _prim_int_gt $ l.75.arity.1.207.arity.1 l.75.arity.2.265.arity.1 + case b'.0 of + #True @ alt.0.0 -> + y.10.0 <- pure 0 + pure y.10.0 + #False @ alt.1.0 -> + x.7.0 <- pure 1 + m1'.0 <- _prim_int_add $ l.75.arity.1.207.arity.1 x.7.0 + unboxed.CInt.3.0 <- sum.unboxed $ m1'.0 l.75.arity.2.265.arity.1 + ax'.0 <- _prim_int_add $ l.75.arity.1.207.arity.1 unboxed.CInt.3.0 + pure ax'.0 +|] From f2aa066f77790ab7fe16e5ac360249e81960e7db Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 18 Feb 2020 00:58:05 +0100 Subject: [PATCH 08/24] ES: added optimization pipeline test case to SumListSpec --- .../Samples/ExtendedSyntax/SumListSpec.hs | 50 ++++++++----------- 1 file changed, 21 insertions(+), 29 deletions(-) diff --git a/grin/test/Samples/ExtendedSyntax/SumListSpec.hs b/grin/test/Samples/ExtendedSyntax/SumListSpec.hs index cc649d45..1f5ffca3 100644 --- a/grin/test/Samples/ExtendedSyntax/SumListSpec.hs +++ b/grin/test/Samples/ExtendedSyntax/SumListSpec.hs @@ -14,8 +14,7 @@ runTests = hspec spec spec :: Spec spec = do - -- TODO: Reenable before merge - it "lazy list sum - half pipeline" $ do + it "lazy list sum - fully optimize" $ do let before = withPrimPrelude [prog| grinMain = y.0 <- pure 1 @@ -81,35 +80,28 @@ spec = do p.6 <- update q z pure z |] - let after = [prog| - -- grinMain = - -- n13' <- sum 0 1 1000 - -- _prim_int_print n13' + let after = withPrimPrelude [prog| + grinMain = + y.0 <- pure 1 + y.1 <- pure 10000 + unboxed.CInt.2 <- sum.unboxed $ y.0 y.1 + _prim_int_print $ unboxed.CInt.2 - -- sum p10 p111 p112 = - -- b1' <- _prim_int_gt p111 p112 - -- case b1' of - -- #True -> - -- pure p10 - -- #False -> - -- n4' <- _prim_int_add p111 1 - -- n7'_2 <- _prim_int_add p10 p111 - -- sum n7'_2 n4' p112 + sum.unboxed l.75.arity.1.207.arity.1 l.75.arity.2.265.arity.1 = + b'.0 <- _prim_int_gt $ l.75.arity.1.207.arity.1 l.75.arity.2.265.arity.1 + case b'.0 of + #True @ alt.0.0 -> + y.10.0 <- pure 0 + pure y.10.0 + #False @ alt.1.0 -> + x.7.0 <- pure 1 + m1'.0 <- _prim_int_add $ l.75.arity.1.207.arity.1 x.7.0 + unboxed.CInt.3.0 <- sum.unboxed $ m1'.0 l.75.arity.2.265.arity.1 + ax'.0 <- _prim_int_add $ l.75.arity.1.207.arity.1 unboxed.CInt.3.0 + pure ax'.0 |] - let steps = map T - [ BindNormalisation - , ConstantPropagation - , BindNormalisation - , CommonSubExpressionElimination - , CopyPropagation - , DeadVariableElimination - , ArityRaising - , CopyPropagation - , DeadVariableElimination - , ArityRaising - , CopyPropagation - , DeadVariableElimination - ] + + let steps = [ Optimize ] transformed <- pipeline defaultOpts Nothing before steps transformed `sameAs` after From 6a2daceee591f5c07e99460387f705020ae765ee Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 18 Feb 2020 10:31:11 +0100 Subject: [PATCH 09/24] ES: added ArityFullRemoveSpec --- grin/grin.cabal | 1 + .../ExtendedSyntax/ArityFullRemoveSpec.hs | 71 +++++++++++++++++++ 2 files changed, 72 insertions(+) create mode 100644 grin/test/Samples/ExtendedSyntax/ArityFullRemoveSpec.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 9c6898ac..9574d669 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -382,6 +382,7 @@ test-suite grin-test Transformations.BindNormalisationSpec Transformations.ConfluenceSpec Transformations.MangleNamesSpec + Samples.ExtendedSyntax.ArityFullRemoveSpec Samples.ExtendedSyntax.SumListSpec Samples.SumListSpec Samples.ArityFullRemoveSpec diff --git a/grin/test/Samples/ExtendedSyntax/ArityFullRemoveSpec.hs b/grin/test/Samples/ExtendedSyntax/ArityFullRemoveSpec.hs new file mode 100644 index 00000000..09eab85b --- /dev/null +++ b/grin/test/Samples/ExtendedSyntax/ArityFullRemoveSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns #-} +module Samples.ExtendedSyntax.ArityFullRemoveSpec where + +import Pipeline.Pipeline + +import Test.Hspec +import Grin.TH +import Test.Test hiding (newVar) +import Test.Assertions + +runTests :: IO () +runTests = hspec spec + +spec :: Spec +spec = do + -- TODO: Reenable before merge + it "multi indirection - full remove" $ do + let before = [prog| + grinMain = + p2 <- store (CInt 1) + p3 <- store (CInt 1000) + p4 <- store (Fupto p2 p3) + n13' <- sum 0 p4 + _prim_int_print n13' + + sum p101 p11 = + (Fupto p17 p18) <- fetch p11 + (CInt n2') <- fetch p17 + (CInt n3') <- fetch p18 + b1' <- _prim_int_gt n2' n3' + case b1' of + #True -> + pure p101 + #False -> + n4' <- _prim_int_add n2' 1 + p8 <- store (CInt n4') + p9 <- store (Fupto p8 p18) + n7'_2 <- _prim_int_add p101 n2' + sum n7'_2 p9 + |] + let after = [prog| + grinMain = + n13' <- sum 0 1 1000 + _prim_int_print n13' + + sum p101 p11.1.arity.1.6.arity.1 p11.1.arity.2.6.arity.1 = + b1' <- _prim_int_gt p11.1.arity.1.6.arity.1 p11.1.arity.2.6.arity.1 + case b1' of + #True -> + pure p101 + #False -> + n4' <- _prim_int_add p11.1.arity.1.6.arity.1 1 + n7'_2 <- _prim_int_add p101 p11.1.arity.1.6.arity.1 + sum n7'_2 n4' p11.1.arity.2.6.arity.1 + |] + let steps = + [ T InlineEval + , T ArityRaising + , T BindNormalisation + , T CommonSubExpressionElimination + , T CopyPropagation + , T SimpleDeadVariableElimination + , T ArityRaising + , T BindNormalisation + , T CommonSubExpressionElimination + , T CopyPropagation + , T ConstantFolding + , T SimpleDeadVariableElimination + ] + transformed <- pipeline defaultOpts Nothing before steps + transformed `sameAs` after From 55241684b9d54104ecdc57e5b27b2ead79b6c7d8 Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 18 Feb 2020 10:39:45 +0100 Subject: [PATCH 10/24] ES: upgraded ArityFullRemoveSpec to new syntax --- .../ExtendedSyntax/ArityFullRemoveSpec.hs | 75 +++++++++++-------- 1 file changed, 43 insertions(+), 32 deletions(-) diff --git a/grin/test/Samples/ExtendedSyntax/ArityFullRemoveSpec.hs b/grin/test/Samples/ExtendedSyntax/ArityFullRemoveSpec.hs index 09eab85b..ecb82f07 100644 --- a/grin/test/Samples/ExtendedSyntax/ArityFullRemoveSpec.hs +++ b/grin/test/Samples/ExtendedSyntax/ArityFullRemoveSpec.hs @@ -1,57 +1,68 @@ {-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns #-} module Samples.ExtendedSyntax.ArityFullRemoveSpec where -import Pipeline.Pipeline +import Pipeline.ExtendedSyntax.Pipeline import Test.Hspec -import Grin.TH -import Test.Test hiding (newVar) -import Test.Assertions +import Grin.ExtendedSyntax.TH +import Test.ExtendedSyntax.Assertions runTests :: IO () runTests = hspec spec spec :: Spec spec = do - -- TODO: Reenable before merge it "multi indirection - full remove" $ do let before = [prog| grinMain = - p2 <- store (CInt 1) - p3 <- store (CInt 1000) - p4 <- store (Fupto p2 p3) - n13' <- sum 0 p4 + k0 <- pure 0 + k1 <- pure 1 + k2 <- pure 10000 + v0 <- pure (CInt k1) + v1 <- pure (CInt k2) + p2 <- store v0 + p3 <- store v1 + v2 <- pure (Fupto p2 p3) + p4 <- store v2 + n13' <- sum k0 p4 _prim_int_print n13' sum p101 p11 = - (Fupto p17 p18) <- fetch p11 - (CInt n2') <- fetch p17 - (CInt n3') <- fetch p18 + (Fupto p17 p18) @ _1 <- fetch p11 + (CInt n2') @ _2 <- fetch p17 + (CInt n3') @ _3 <- fetch p18 b1' <- _prim_int_gt n2' n3' case b1' of - #True -> + #True @ alt1 -> pure p101 - #False -> - n4' <- _prim_int_add n2' 1 - p8 <- store (CInt n4') - p9 <- store (Fupto p8 p18) + #False @ alt2 -> + k3 <- pure 1 + n4' <- _prim_int_add n2' k3 + v3 <- pure (CInt n4') + p8 <- store v3 + v4 <- pure (Fupto p8 p18) + p9 <- store v4 n7'_2 <- _prim_int_add p101 n2' sum n7'_2 p9 |] let after = [prog| - grinMain = - n13' <- sum 0 1 1000 - _prim_int_print n13' + grinMain = + k0 <- pure 0 + k1 <- pure 1 + k2 <- pure 10000 + n13' <- sum $ k0 k1 k2 + _prim_int_print $ n13' - sum p101 p11.1.arity.1.6.arity.1 p11.1.arity.2.6.arity.1 = - b1' <- _prim_int_gt p11.1.arity.1.6.arity.1 p11.1.arity.2.6.arity.1 - case b1' of - #True -> - pure p101 - #False -> - n4' <- _prim_int_add p11.1.arity.1.6.arity.1 1 - n7'_2 <- _prim_int_add p101 p11.1.arity.1.6.arity.1 - sum n7'_2 n4' p11.1.arity.2.6.arity.1 + sum p101 p11.1.arity.1.6.arity.1 p11.1.arity.2.6.arity.1 = + b1' <- _prim_int_gt $ p11.1.arity.1.6.arity.1 p11.1.arity.2.6.arity.1 + case b1' of + #True @ alt1 -> + pure p101 + #False @ alt2 -> + k3 <- pure 1 + n4' <- _prim_int_add $ p11.1.arity.1.6.arity.1 k3 + n7'_2 <- _prim_int_add $ p101 p11.1.arity.1.6.arity.1 + sum $ n7'_2 n4' p11.1.arity.2.6.arity.1 |] let steps = [ T InlineEval @@ -59,13 +70,13 @@ spec = do , T BindNormalisation , T CommonSubExpressionElimination , T CopyPropagation - , T SimpleDeadVariableElimination + , T DeadVariableElimination , T ArityRaising , T BindNormalisation , T CommonSubExpressionElimination , T CopyPropagation - , T ConstantFolding - , T SimpleDeadVariableElimination + -- , T ConstantFolding + , T DeadVariableElimination ] transformed <- pipeline defaultOpts Nothing before steps transformed `sameAs` after From c4323a27f1a07a717e85cbfcbf2f3e84bf2ac981 Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 18 Feb 2020 20:17:47 +0100 Subject: [PATCH 11/24] ES: added a test to LiveVariableSpec --- .../ExtendedSyntax/LiveVariableSpec.hs | 20 +++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/grin/test/AbstractInterpretation/ExtendedSyntax/LiveVariableSpec.hs b/grin/test/AbstractInterpretation/ExtendedSyntax/LiveVariableSpec.hs index 9df2d1e2..d395bbcb 100644 --- a/grin/test/AbstractInterpretation/ExtendedSyntax/LiveVariableSpec.hs +++ b/grin/test/AbstractInterpretation/ExtendedSyntax/LiveVariableSpec.hs @@ -109,6 +109,26 @@ spec = describe "Live Variable Analysis" $ do calculated `sameAs` variableAliasExpected it "as_pattern_with_node_2" $ do + let exp = withPrimPrelude [prog| + grinMain = + x0 <- pure 0 + (CInt x1) @ _v <- pure (CInt x0) + _prim_int_print x1 + |] + let variableAliasExpected = emptyLVAResult + { _memory = [] + , _registerLv = [ ("x0", liveVal) + , ("x1", liveVal) + , ("_v", nodeSet' [ (cInt, [dead, live]) ]) + ] + , _functionLv = mkFunctionLivenessMap + [ ("_prim_int_print", fun (liveVal, [liveVal])) + ] + } + calculated = (calcLiveness exp) { _registerEff = mempty, _functionEff = mempty } + calculated `sameAs` variableAliasExpected + + it "as_pattern_with_node_3" $ do let exp = withPrimPrelude [prog| grinMain = x0 <- pure 0 From 2351833ce01210bfba6284fb44c190b981525946 Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 18 Feb 2020 20:50:16 +0100 Subject: [PATCH 12/24] ES: simplifications in Pipeline --- grin/src/Pipeline/ExtendedSyntax/Pipeline.hs | 69 +++----------------- 1 file changed, 10 insertions(+), 59 deletions(-) diff --git a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs index d415e706..69be4fc9 100644 --- a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs +++ b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs @@ -752,7 +752,6 @@ randomPipeline seed opts exp randomPipelineM :: StdGen -> PipelineM [Transformation] randomPipelineM seed = do liftIO $ setStdGen seed - runBasicAnalyses go transformationWhitelist [] where go :: [Transformation] -> [Transformation] -> PipelineM [Transformation] @@ -764,25 +763,15 @@ randomPipelineM seed = do go available res = do exp <- use psExp t <- fmap ((available !!) . abs . (`mod` (length available))) $ liftIO $ randomIO - eff <- if needsCByLVA t - then do - runNameIntro - runCByLVA - pipelineStep (T t) - runCleanup - exp' <- use psExp - pure $ if exp == exp' then None else ExpChanged - else pipelineStep (T t) + eff <- pipelineStep (T t) case eff of None -> go (available Data.List.\\ [t]) res ExpChanged -> do lintGrin . Just $ show t - runBasicAnalyses go transformationWhitelist (t:res) transformationWhitelist :: [Transformation] transformationWhitelist = - -- Misc [ EvaluatedCaseElimination , TrivialCaseElimination , SparseCaseOptimisation @@ -803,49 +792,6 @@ randomPipelineM seed = do , LateInlining ] - runBasicAnalyses :: PipelineM () - runBasicAnalyses = mapM_ pipelineStep - [ Sharing Compile - , Sharing RunPure - , ET Compile - , ET RunPure - ] - - runCByLVA :: PipelineM () - runCByLVA = mapM_ pipelineStep - [ CBy Compile - , CBy RunPure - , LVA Compile - , LVA RunPure - , ET Compile - , ET RunPure - ] - - -- TODO: no longer needed - runNameIntro :: PipelineM () - runNameIntro = void . pipelineStep $ Pass - [ T BindNormalisation - , T BindNormalisation - ] - - -- cleanup after producer name intro - runCleanup :: PipelineM () - runCleanup = void . pipelineStep $ Pass - [ T CopyPropagation - , T DeadVariableElimination - ] - - needsCByLVA :: Transformation -> Bool - needsCByLVA = \case - InterproceduralDeadFunctionElimination -> True - InterproceduralDeadDataElimination -> True - DeadVariableElimination -> True - InterproceduralDeadParameterElimination -> True - _ -> False - - needsCleanup :: Transformation -> Bool - needsCleanup = needsCByLVA - confluenceTest :: PipelineM () confluenceTest = do pipelineLog "Confluence test" @@ -985,11 +931,17 @@ optimizeWithM pre trans post = do -- HPT LVA CBy is required -- Only run this phase when interprocedural transformations are required. - phase4 = if (null (trans `intersect` + phase4 = phaseLoop False $ trans `intersect` + [ InterproceduralDeadDataElimination + , InterproceduralDeadFunctionElimination + , InterproceduralDeadParameterElimination + ] + + -- TODO: remove + oldPhase4 = if (null (trans `intersect` [ InterproceduralDeadDataElimination , InterproceduralDeadFunctionElimination , InterproceduralDeadParameterElimination - , DeadVariableElimination ])) then pure False else phase4Loop False @@ -1014,7 +966,6 @@ optimizeWithM pre trans post = do [ CopyPropagation , DeadVariableElimination , BindNormalisation - , BindNormalisation ] , map T $ trans `intersect` [ InterproceduralDeadFunctionElimination @@ -1055,7 +1006,7 @@ runAnalysisFor t = do WithShr _ -> [sharing] WithTypeEnvEff _ -> [hpt, eff] WithLVA _ -> [hpt, lva] - WithLVACBy _ -> [hpt, cby, lva, sharing] + WithLVACBy _ -> [hpt, cby, lva] where analysis getter ann = do r <- use getter From b06feb1d1ff8f9c23b07ba7e03b07efb1ef6a66b Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 18 Feb 2020 21:28:56 +0100 Subject: [PATCH 13/24] ES: bugfixes in CBy --- .../AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs index 3ce4b7b9..f6c86ac6 100644 --- a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs @@ -227,6 +227,7 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where case lhsRes of Z -> error $ "pattern mismatch at CreatedBy bind codegen, expected Unit got " ++ show (PP $ ConstTagNode tag args) R r -> do + -- TODO: handle blocks here as well case lhs of SReturn val | producesNode val -> do addReg var r From 434dc3d11b5e94fd34ed8453378a943e5a34822c Mon Sep 17 00:00:00 2001 From: anabra Date: Thu, 27 Feb 2020 15:59:17 +0100 Subject: [PATCH 14/24] ES: added some new tests to SharingSpec --- .../ExtendedSyntax/SharingSpec.hs | 44 +++++++++++++++++-- 1 file changed, 40 insertions(+), 4 deletions(-) diff --git a/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs b/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs index 7ef9ff96..6b7a4b3b 100644 --- a/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs +++ b/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs @@ -91,7 +91,7 @@ spec = describe "Sharing analysis" $ do let expected = Set.fromList [0] result `shouldBe` expected - it "finds location inside shared node" $ do + it "finds location inside shared node - simple" $ do let code = [prog| grinMain = n1 <- pure (COne) @@ -109,6 +109,42 @@ spec = describe "Sharing analysis" $ do let expected = Set.fromList [0] result `shouldBe` expected + it "finds location inside shared node - realistic" $ do + let code = [prog| + grinMain = + n1 <- pure (FFoo) + p1 <- store n1 + n3 <- pure (CPtr p1) + (CPtr p2) @ _0 <- pure n3 + (CPtr p3) @ _1 <- pure n3 + v1 <- eval1 p2 + v2 <- eval2 p3 + pure () + + eval1 q.1 = + r.1 <- fetch q.1 + case r.1 of + (CTwo) @ alt1.1 -> + pure r.1 + (FFoo) @ alt2.1 -> + z.1 <- pure (CTwo) + _2.1 <- update q.1 z.1 + pure z.1 + + eval2 q.2 = + r.2 <- fetch q.2 + case r.2 of + (CTwo) @ alt1.2 -> + pure r.2 + (FFoo) @ alt2.2 -> + z.2 <- pure (CTwo) + _2.2 <- update q.2 z.2 + pure z.2 + |] + let result = calcSharedLocations code + let expected = Set.fromList [0] + result `shouldBe` expected + it "finds locations shared via as-pattern aliases" $ do let code = [prog| grinMain = @@ -209,11 +245,11 @@ testProgram = withPrimPrelude [prog| v <- fetch q case v of (CInt x'1) @ alt.4 -> - pure v + pure (CInt x'1) (CNil) @ alt.5 -> - pure v + pure (CNil) (CCons y ys) @ alt.6 -> - pure v + pure (CCons y ys) (Fupto a b) @ alt.7 -> w <- upto $ a b p.5 <- update q w From 979c30e4ebc6f33438e1344de0033955932bd5c2 Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 1 Mar 2020 00:47:09 +0100 Subject: [PATCH 15/24] ES: some name mangling --- grin/test/Samples/ExtendedSyntax/SumListSpec.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/grin/test/Samples/ExtendedSyntax/SumListSpec.hs b/grin/test/Samples/ExtendedSyntax/SumListSpec.hs index 1f5ffca3..e0c62982 100644 --- a/grin/test/Samples/ExtendedSyntax/SumListSpec.hs +++ b/grin/test/Samples/ExtendedSyntax/SumListSpec.hs @@ -87,17 +87,18 @@ spec = do unboxed.CInt.2 <- sum.unboxed $ y.0 y.1 _prim_int_print $ unboxed.CInt.2 - sum.unboxed l.75.arity.1.207.arity.1 l.75.arity.2.265.arity.1 = - b'.0 <- _prim_int_gt $ l.75.arity.1.207.arity.1 l.75.arity.2.265.arity.1 + sum.unboxed l.69.arity.1.217.arity.1 l.69.arity.2.269.arity.1 = + b'.0 <- _prim_int_gt $ l.69.arity.1.217.arity.1 l.69.arity.2.269.arity.1 case b'.0 of #True @ alt.0.0 -> y.10.0 <- pure 0 pure y.10.0 + #False @ alt.1.0 -> x.7.0 <- pure 1 - m1'.0 <- _prim_int_add $ l.75.arity.1.207.arity.1 x.7.0 - unboxed.CInt.3.0 <- sum.unboxed $ m1'.0 l.75.arity.2.265.arity.1 - ax'.0 <- _prim_int_add $ l.75.arity.1.207.arity.1 unboxed.CInt.3.0 + m1'.0 <- _prim_int_add $ l.69.arity.1.217.arity.1 x.7.0 + unboxed.CInt.3.0 <- sum.unboxed $ m1'.0 l.69.arity.2.269.arity.1 + ax'.0 <- _prim_int_add $ l.69.arity.1.217.arity.1 unboxed.CInt.3.0 pure ax'.0 |] From 85116da69742761b23ed0266a2e44b2178a85e3c Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 1 Mar 2020 00:55:14 +0100 Subject: [PATCH 16/24] ES: some changes in SharingSpec --- .../AbstractInterpretation/ExtendedSyntax/SharingSpec.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs b/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs index 6b7a4b3b..18f9983e 100644 --- a/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs +++ b/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs @@ -24,6 +24,7 @@ spec :: Spec spec = describe "Sharing analysis" $ do it "has not changed for sum simple." $ do let result = calcSharedLocations testProgram + -- TODO: improve precision, improve altName tracking let expected = Set.fromList [0,1,2,4,5] result `shouldBe` expected @@ -245,11 +246,11 @@ testProgram = withPrimPrelude [prog| v <- fetch q case v of (CInt x'1) @ alt.4 -> - pure (CInt x'1) + pure alt.4 (CNil) @ alt.5 -> - pure (CNil) + pure alt.5 (CCons y ys) @ alt.6 -> - pure (CCons y ys) + pure alt.6 (Fupto a b) @ alt.7 -> w <- upto $ a b p.5 <- update q w From 886f4460664c462db1d02ce544bc5623fa38aed3 Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 1 Mar 2020 01:21:51 +0100 Subject: [PATCH 17/24] ES: CBy now throws error on un(bind)normalized code --- .../ExtendedSyntax/CreatedBy/CodeGen.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs index f6c86ac6..709438cc 100644 --- a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs @@ -206,6 +206,11 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where R r -> emit IR.Move {srcReg = r, dstReg = funResultReg} pure Z + -- NOTE: + EBindF (SBlock{}, _) _ _ -> error $ + "CBy does not handle un(bind)normalized code. " ++ + "Possible fix: run BindNormalisation before CBy." + -- NOTE: variable patterns EBindF (lhs, cgLhs) (VarPat var) (_, cgRhs) -> do lhsRes <- cgLhs From 14c37e2a5ae2d274578bcade23cccdb53cec7619 Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 1 Mar 2020 02:03:51 +0100 Subject: [PATCH 18/24] ES: Sharing DOES calculate an accurate result for sumSimple --- grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs b/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs index 18f9983e..6652e5cf 100644 --- a/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs +++ b/grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs @@ -24,8 +24,7 @@ spec :: Spec spec = describe "Sharing analysis" $ do it "has not changed for sum simple." $ do let result = calcSharedLocations testProgram - -- TODO: improve precision, improve altName tracking - let expected = Set.fromList [0,1,2,4,5] + let expected = Set.fromList [0,1,4,5] result `shouldBe` expected it "finds non-transitive shared locations" $ do From 59e8165c9be7991f72634a0dbc27be4648a5042c Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 1 Mar 2020 02:11:12 +0100 Subject: [PATCH 19/24] ES: now BN runs before CBy --- .../ExtendedSyntax/CreatedBy/CodeGen.hs | 2 +- grin/src/Pipeline/ExtendedSyntax/Pipeline.hs | 9 ++++++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs index 709438cc..f421b46a 100644 --- a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs @@ -206,7 +206,7 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where R r -> emit IR.Move {srcReg = r, dstReg = funResultReg} pure Z - -- NOTE: + -- TODO: either fix this here, or run BN before CBy EBindF (SBlock{}, _) _ _ -> error $ "CBy does not handle un(bind)normalized code. " ++ "Possible fix: run BindNormalisation before CBy." diff --git a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs index 69be4fc9..a7d18f13 100644 --- a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs +++ b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs @@ -1017,9 +1017,16 @@ runAnalysisFor t = do hpt = analysis psHPTResult HPT lva = analysis psLVAResult LVA - cby = analysis psCByResult CBy et = analysis psETResult ET sharing = analysis psSharingResult Sharing + cby = do + r <- use psCByProgram + when (isNothing r) $ do + pipelineLog "" + pipelineLog $ "CBy requires bind-normalized code" + pipelineStep $ T BindNormalisation + pipelineLog $ "Analysis" + mapM_ pipelineStep $ (CBy <$> [Compile, RunPure]) eff :: PipelineM () eff = do From 4a4a41819ef1dc437c2118143c69bc6cbc17f906 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 2 Mar 2020 16:32:30 +0100 Subject: [PATCH 20/24] ES: now DVE keeps updates --- .../ExtendedSyntax/Optimising/DeadVariableElimination.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/grin/src/Transformations/ExtendedSyntax/Optimising/DeadVariableElimination.hs b/grin/src/Transformations/ExtendedSyntax/Optimising/DeadVariableElimination.hs index afca3dd1..bdcbed0d 100644 --- a/grin/src/Transformations/ExtendedSyntax/Optimising/DeadVariableElimination.hs +++ b/grin/src/Transformations/ExtendedSyntax/Optimising/DeadVariableElimination.hs @@ -19,7 +19,7 @@ import Transformations.ExtendedSyntax.Util -- TODO: consult EffectMap for side-effects --- QUESTION: should DVE use any interprocedural information? +-- QUESTION: should DVE use any interprocedural information? [1] deadVariableElimination :: EffectMap -> Exp -> Exp deadVariableElimination effMap e = cata folder e ^. _1 where @@ -37,8 +37,10 @@ deadVariableElimination effMap e = cata folder e ^. _1 where , all (flip Set.notMember rightRef) vars -- are not referred -> case left of SBlock{} -> embedExp exp + SUpdate{} -> embedExp exp _ -> right + -- QUESTION: Should we just keep all function calls? See [1] exp@(SAppF name _) -> embedExp exp & _3 .~ (hasPossibleSideEffect name effMap || Set.member name effectfulExternals) From 1f7b285a48d311a6a1d1ddecfb7774082df22474 Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 3 Mar 2020 18:32:35 +0100 Subject: [PATCH 21/24] ES: added a test case to DVE --- .../Optimising/DeadVariableEliminationSpec.hs | 22 +++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/grin/test/Transformations/ExtendedSyntax/Optimising/DeadVariableEliminationSpec.hs b/grin/test/Transformations/ExtendedSyntax/Optimising/DeadVariableEliminationSpec.hs index e28e386a..2a553bda 100644 --- a/grin/test/Transformations/ExtendedSyntax/Optimising/DeadVariableEliminationSpec.hs +++ b/grin/test/Transformations/ExtendedSyntax/Optimising/DeadVariableEliminationSpec.hs @@ -123,6 +123,28 @@ spec = do dveExp = deadVariableElimination effMap before dveExp `sameAs` after + it "keeps updates" $ do + let before = withPrimPrelude [prog| + grinMain = + n1 <- pure (COne) + n2 <- pure (CTwo) + p <- store n1 + _1 <- update p n2 + pure () + |] + let after = withPrimPrelude [prog| + grinMain = + n1 <- pure (COne) + n2 <- pure (CTwo) + p <- store n1 + _1 <- update p n2 + pure () + |] + let tyEnv = inferTypeEnv before + effMap = effectMap (tyEnv, before) + dveExp = deadVariableElimination effMap before + dveExp `sameAs` after + describe "Simple dead variable elimination works for" $ do it "simple" $ do From a714febc3f891976f5c3da2cbc7511a336068ad0 Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 3 Mar 2020 19:44:59 +0100 Subject: [PATCH 22/24] ES: modified sum_simple optimization test --- .../Samples/ExtendedSyntax/SumListSpec.hs | 106 ++++++++++++++++-- 1 file changed, 98 insertions(+), 8 deletions(-) diff --git a/grin/test/Samples/ExtendedSyntax/SumListSpec.hs b/grin/test/Samples/ExtendedSyntax/SumListSpec.hs index e0c62982..b3efc275 100644 --- a/grin/test/Samples/ExtendedSyntax/SumListSpec.hs +++ b/grin/test/Samples/ExtendedSyntax/SumListSpec.hs @@ -15,6 +15,10 @@ runTests = hspec spec spec :: Spec spec = do it "lazy list sum - fully optimize" $ do + pendingWith + ("The current implementation of sharing analysis is too inaccurate " + ++ "to eliminate the update in the Fupto alternative in eval. " + ++ "As a consquence the compiler can't optimize the code past that point.") let before = withPrimPrelude [prog| grinMain = y.0 <- pure 1 @@ -65,20 +69,16 @@ spec = do eval q = v <- fetch q case v of - (CInt x'1) @ alt.4 -> - pure v - (CNil) @ alt.5 -> - pure v - (CCons y ys) @ alt.6 -> - pure v - (Fupto a b) @ alt.7 -> + (Fupto a b) @ alt.4 -> w <- upto $ a b p.5 <- update q w pure w - (Fsum c) @ alt.8 -> + (Fsum c) @ alt.5 -> z <- sum $ c p.6 <- update q z pure z + #default @ alt.6 -> + pure alt.6 |] let after = withPrimPrelude [prog| grinMain = @@ -106,3 +106,93 @@ spec = do transformed <- pipeline defaultOpts Nothing before steps transformed `sameAs` after + + it "lazy list sum - fully optimize without Fupto update" $ do + let before = withPrimPrelude [prog| + grinMain = + y.0 <- pure 1 + v.0 <- pure (CInt y.0) + t1 <- store v.0 + y.1 <- pure 10000 + v.1 <- pure (CInt y.1) + t2 <- store v.1 + v.2 <- pure (Fupto t1 t2) + t3 <- store v.2 + v.3 <- pure (Fsum t3) + t4 <- store v.3 + (CInt r') @ p.0 <- eval $ t4 + _prim_int_print $ r' + + upto m n = + (CInt m') @ p.2 <- eval $ m + (CInt n') @ p.1 <- eval $ n + b' <- _prim_int_gt $ m' n' + case b' of + #True @ alt.0 -> + v.4 <- pure (CNil) + pure v.4 + #False @ alt.1 -> + x.7 <- pure 1 + m1' <- _prim_int_add $ m' x.7 + v.5 <- pure (CInt m1') + m1 <- store v.5 + v.6 <- pure (Fupto m1 n) + p <- store v.6 + v.7 <- pure (CCons m p) + pure v.7 + + sum l = + l2 <- eval $ l + case l2 of + (CNil) @ alt.2 -> + y.10 <- pure 0 + v.8 <- pure (CInt y.10) + pure v.8 + (CCons x xs) @ alt.3 -> + (CInt x') @ p.4 <- eval $ x + (CInt s') @ p.3 <- sum $ xs + ax' <- _prim_int_add $ x' s' + v.9 <- pure (CInt ax') + pure v.9 + + eval q = + v <- fetch q + case v of + (Fupto a b) @ alt.4 -> + w <- upto $ a b + -- p.5 <- update q w + pure w + (Fsum c) @ alt.5 -> + z <- sum $ c + p.6 <- update q z + pure z + #default @ alt.6 -> + pure alt.6 + |] + let after = withPrimPrelude [prog| + grinMain = + y.0 <- pure 1 + y.1 <- pure 10000 + unboxed.CInt.2 <- sum.unboxed $ y.0 y.1 + _prim_int_print $ unboxed.CInt.2 + + sum.unboxed l.69.arity.1.165.arity.1 l.69.arity.2.217.arity.1 = + b'.0 <- _prim_int_gt $ l.69.arity.1.165.arity.1 l.69.arity.2.217.arity.1 + case b'.0 of + #True @ alt.0.0 -> + y.10.0 <- pure 0 + pure y.10.0 + #False @ alt.1.0 -> + x.7.0 <- pure 1 + m1'.0 <- _prim_int_add $ l.69.arity.1.165.arity.1 x.7.0 + unboxed.CInt.3.0 <- sum.unboxed $ m1'.0 l.69.arity.2.217.arity.1 + ax'.0 <- _prim_int_add $ l.69.arity.1.165.arity.1 unboxed.CInt.3.0 + pure ax'.0 + + |] + + let steps = [ Optimize ] + + transformed <- pipeline defaultOpts Nothing before steps + transformed `sameAs` after + From 7751f95cb0d780294e2b170d8902dd65ad32d17d Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 3 Mar 2020 20:27:53 +0100 Subject: [PATCH 23/24] Revert "ES: now BN runs before CBy" This reverts commit 59e8165c9be7991f72634a0dbc27be4648a5042c. --- .../ExtendedSyntax/CreatedBy/CodeGen.hs | 2 +- grin/src/Pipeline/ExtendedSyntax/Pipeline.hs | 9 +-------- 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs index f421b46a..709438cc 100644 --- a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs @@ -206,7 +206,7 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where R r -> emit IR.Move {srcReg = r, dstReg = funResultReg} pure Z - -- TODO: either fix this here, or run BN before CBy + -- NOTE: EBindF (SBlock{}, _) _ _ -> error $ "CBy does not handle un(bind)normalized code. " ++ "Possible fix: run BindNormalisation before CBy." diff --git a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs index a7d18f13..69be4fc9 100644 --- a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs +++ b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs @@ -1017,16 +1017,9 @@ runAnalysisFor t = do hpt = analysis psHPTResult HPT lva = analysis psLVAResult LVA + cby = analysis psCByResult CBy et = analysis psETResult ET sharing = analysis psSharingResult Sharing - cby = do - r <- use psCByProgram - when (isNothing r) $ do - pipelineLog "" - pipelineLog $ "CBy requires bind-normalized code" - pipelineStep $ T BindNormalisation - pipelineLog $ "Analysis" - mapM_ pipelineStep $ (CBy <$> [Compile, RunPure]) eff :: PipelineM () eff = do From 42408b5a4df7ce63e7803591b5c6d6514c8658f0 Mon Sep 17 00:00:00 2001 From: anabra Date: Tue, 3 Mar 2020 20:47:13 +0100 Subject: [PATCH 24/24] ES: BN is run after transfromations in random pipeline --- grin/src/Pipeline/ExtendedSyntax/Pipeline.hs | 21 +++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs index 69be4fc9..f6d92635 100644 --- a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs +++ b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs @@ -17,6 +17,7 @@ module Pipeline.ExtendedSyntax.Pipeline , optimize , optimizeWith , randomPipeline + , silently ) where import Prelude @@ -752,23 +753,22 @@ randomPipeline seed opts exp randomPipelineM :: StdGen -> PipelineM [Transformation] randomPipelineM seed = do liftIO $ setStdGen seed - go transformationWhitelist [] + pipelineStep $ T BindNormalisation + go transformationWhitelist [BindNormalisation] where go :: [Transformation] -> [Transformation] -> PipelineM [Transformation] - go [] result = do - -- The final result must be normalised as, non-normalised and normalised - -- grin program is semantically the same. - pipelineStep $ T BindNormalisation - pure $ reverse result + go [] result = pure $ reverse result go available res = do exp <- use psExp - t <- fmap ((available !!) . abs . (`mod` (length available))) $ liftIO $ randomIO + t <- fmap ((available !!) . abs . (`mod` (length available))) $ liftIO $ randomIO eff <- pipelineStep (T t) case eff of - None -> go (available Data.List.\\ [t]) res + None -> + go (available Data.List.\\ [t]) res ExpChanged -> do + pipelineStep $ T BindNormalisation lintGrin . Just $ show t - go transformationWhitelist (t:res) + go transformationWhitelist (BindNormalisation:t:res) transformationWhitelist :: [Transformation] transformationWhitelist = @@ -1035,6 +1035,9 @@ inceaseIntendation = psIntendation %= succ decreateIntendation :: PipelineM () decreateIntendation = psIntendation %= pred +silently :: PipelineM a -> PipelineM a +silently = local $ \opts -> opts { _poLogging = False } + pipelineLog :: String -> PipelineM () pipelineLog str = do shouldLog <- view poLogging