Extended syntax: bugfixes

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

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
@@ -227,6 +232,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

grin/src/Pipeline/ExtendedSyntax/Pipeline.hs

@@ -17,6 +17,7 @@ module Pipeline.ExtendedSyntax.Pipeline
   , optimize
   , optimizeWith
   , randomPipeline
+  , silently
   ) where
 
 import Prelude
@@ -752,37 +753,25 @@ randomPipeline seed opts exp
 randomPipelineM :: StdGen -> PipelineM [Transformation]
 randomPipelineM seed = do
   liftIO $ setStdGen seed
-  runBasicAnalyses
-  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
-      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)
+      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
-          runBasicAnalyses
-          go transformationWhitelist (t:res)
+          go transformationWhitelist (BindNormalisation: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
@@ -1084,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

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

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)]

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)
 

grin/src/Transformations/ExtendedSyntax/Util.hs

@@ -47,14 +47,18 @@ 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)
 
 
 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

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

grin/test/AbstractInterpretation/ExtendedSyntax/SharingSpec.hs

@@ -24,7 +24,7 @@ spec :: Spec
 spec = describe "Sharing analysis" $ do
   it "has not changed for sum simple." $ do
     let result = calcSharedLocations testProgram
-    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
@@ -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 alt.4
       (CNil) @ alt.5 ->
-        pure v
+        pure alt.5
       (CCons y ys) @ alt.6 ->
-        pure v
+        pure alt.6
       (Fupto a b) @ alt.7 ->
         w <- upto $ a b
         p.5 <- update q w