Merge branch '32-extended-syntax' into 32-trf-dfe

grin/grin.cabal

@@ -146,10 +146,23 @@ library
     Transformations.ExtendedSyntax.GenerateEval
     Transformations.ExtendedSyntax.MangleNames
     Transformations.ExtendedSyntax.StaticSingleAssignment
+    Transformations.ExtendedSyntax.Optimising.ArityRaising
+    Transformations.ExtendedSyntax.Optimising.CaseCopyPropagation
+    Transformations.ExtendedSyntax.Optimising.CaseHoisting
     Transformations.ExtendedSyntax.Optimising.CopyPropagation
+    Transformations.ExtendedSyntax.Optimising.ConstantPropagation
     Transformations.ExtendedSyntax.Optimising.CSE
+    Transformations.ExtendedSyntax.Optimising.DeadDataElimination
     Transformations.ExtendedSyntax.Optimising.DeadFunctionElimination
+    Transformations.ExtendedSyntax.Optimising.DeadParameterElimination
     Transformations.ExtendedSyntax.Optimising.EvaluatedCaseElimination
+    Transformations.ExtendedSyntax.Optimising.Inlining
+    Transformations.ExtendedSyntax.Optimising.GeneralizedUnboxing
+    Transformations.ExtendedSyntax.Optimising.NonSharedElimination
+    Transformations.ExtendedSyntax.Optimising.SimpleDeadFunctionElimination
+    Transformations.ExtendedSyntax.Optimising.SimpleDeadParameterElimination
+    Transformations.ExtendedSyntax.Optimising.SimpleDeadVariableElimination
+    Transformations.ExtendedSyntax.Optimising.SparseCaseOptimisation
     Transformations.ExtendedSyntax.Optimising.TrivialCaseElimination
 
     Transformations.BindNormalisation
@@ -302,10 +315,22 @@ test-suite grin-test
                      Transformations.ExtendedSyntax.ConversionSpec
                      Transformations.ExtendedSyntax.MangleNamesSpec
                      Transformations.ExtendedSyntax.StaticSingleAssignmentSpec
+                     Transformations.ExtendedSyntax.Optimising.ArityRaisingSpec
+                     Transformations.ExtendedSyntax.Optimising.CaseCopyPropagationSpec
+                     Transformations.ExtendedSyntax.Optimising.CaseHoistingSpec
                      Transformations.ExtendedSyntax.Optimising.CopyPropagationSpec
                      Transformations.ExtendedSyntax.Optimising.CSESpec
+                     Transformations.ExtendedSyntax.Optimising.DeadDataEliminationSpec
                      Transformations.ExtendedSyntax.Optimising.DeadFunctionEliminationSpec
+                     Transformations.ExtendedSyntax.Optimising.DeadParameterEliminationSpec
                      Transformations.ExtendedSyntax.Optimising.EvaluatedCaseEliminationSpec
+                     Transformations.ExtendedSyntax.Optimising.InliningSpec
+                     Transformations.ExtendedSyntax.Optimising.GeneralizedUnboxingSpec
+                     Transformations.ExtendedSyntax.Optimising.NonSharedEliminationSpec
+                     Transformations.ExtendedSyntax.Optimising.SimpleDeadFunctionEliminationSpec
+                     Transformations.ExtendedSyntax.Optimising.SimpleDeadParameterEliminationSpec
+                     Transformations.ExtendedSyntax.Optimising.SimpleDeadVariableEliminationSpec
+                     Transformations.ExtendedSyntax.Optimising.SparseCaseOptimisationSpec
                      Transformations.ExtendedSyntax.Optimising.TrivialCaseEliminationSpec
 
                      Transformations.Simplifying.RegisterIntroductionSpec

grin/src/Transformations/ExtendedSyntax/Conversion.hs

@@ -198,7 +198,7 @@ instance Convertible Exp New.Exp where
       <rhs>
     -}
     (EBind lhs (ConstTagNode tag args) rhs) -> do
-      asPatName  <- deriveNewName "a"
+      asPatName  <- deriveNewName "conv"
       newNodePat <- oldNodePatToAsPat tag args asPatName
       pure $ New.EBindF lhs newNodePat rhs
     (EBind lhs (Var var) rhs)

grin/src/Transformations/ExtendedSyntax/Optimising/ArityRaising.hs

@@ -0,0 +1,207 @@
+{-# LANGUAGE LambdaCase, TupleSections #-}
+module Transformations.ExtendedSyntax.Optimising.ArityRaising where
+
+import Data.List (nub)
+import Data.Maybe (fromJust, isJust, mapMaybe, catMaybes)
+import Data.Functor.Foldable
+import qualified Data.Set        as Set;    import Data.Set    (Set)
+import qualified Data.Map.Strict as Map;    import Data.Map    (Map)
+import qualified Data.Vector     as Vector; import Data.Vector (Vector)
+
+import Control.Monad.State.Strict
+
+import Grin.ExtendedSyntax.Grin (packName, unpackName)
+import Grin.ExtendedSyntax.Syntax
+import Grin.ExtendedSyntax.TypeEnv
+import Transformations.ExtendedSyntax.Names
+
+
+{-
+1. Select one function which has a parameter of a pointer to one constructor only.
+2. If the parameter is linear and fetched in the function body then this is a good function for
+   arity raising
+
+How to raise arity?
+1. Change the function parameters: replace the parameter with the parameters in the constructor
+2. Change the function body: remove the fectch and use the variables as parameters
+3. Change the caller sides: instead of passing the pointer fetch the pointer and pass the values are parameters
+
+How to handle self recursion?
+1. If a function is self recursive, the paramter that is fetched originaly in the function body
+   must be passed as normal parameters in the same function call.
+
+Phase 1: Select a function and a parameter to transform.
+Phase 2: Transform the parameter and the function body.
+Phase 3: Transform the callers.
+
+This way the fetches propagates slowly to the caller side to the creational point.
+
+Parameters:
+ - Used only in fetch or in recursive calls for the same function.
+ - Its value points to a location, which location has only one Node with at least one parameter
+-}
+
+-- TODO: True is reported even if exp stayed the same. Investigate why exp stay the same
+-- for non-null arity data.
+arityRaising :: Int -> TypeEnv -> Exp -> (Exp, ExpChanges)
+arityRaising n te exp = if Map.null arityData then (exp, NoChange) else (phase2 n arityData exp, NewNames)
+  where
+    arityData = phase1 te exp
+
+-- | ArityData maps a function name to its arguments that can be arity raised.
+-- 1st: Name of the argument
+-- 2nd: The index of the argument
+-- 3rd: The tag and one possible locaition where the parameter can point to.
+type ArityData = Map Name [(Name, Int, (Tag, Int))]
+
+type ParameterInfo = Map Name (Int, (Tag, Int))
+
+data Phase1Data
+  = ProgramData { pdArityData :: ArityData }
+  | FunData { fdArityData :: ArityData }
+  | BodyData { bdFunCall :: [(Name, Name)]
+             , bdFetch   :: Map Name Int
+             , bdOther   :: [Name]
+             }
+  deriving (Show)
+
+instance Semigroup Phase1Data where
+  (ProgramData ad0) <> (ProgramData ad1) = ProgramData (Map.unionWith mappend ad0 ad1)
+  (FunData fd0) <> (FunData fd1) = FunData (mappend fd0 fd1)
+  (BodyData c0 f0 o0) <> (BodyData c1 f1 o1) = BodyData (c0 ++ c1) (Map.unionWith (+) f0 f1) (o0 ++ o1)
+
+instance Monoid Phase1Data where
+  mempty = BodyData mempty mempty mempty
+
+variableInVar :: Val -> [Name]
+variableInVar (Var v) = [v]
+variableInVar _       = []
+
+variableInNode :: Val -> [Name]
+variableInNode (ConstTagNode _ vs) = vs
+variableInNode _ = []
+
+variableInNodes :: [Val] -> [Name]
+variableInNodes = concatMap variableInNode
+
+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 }
+    SFetchF var       -> mempty { bdFetch = Map.singleton var 1 }
+    SUpdateF ptr var  -> mempty { bdOther = [ptr, var] }
+    SReturnF val -> mempty { bdOther = variableInNode val ++ variableInVar val }
+    SStoreF v  -> mempty { bdOther = [v] }
+    SBlockF ad -> ad
+    AltF _ _ ad  -> ad
+    ECaseF scrut alts    -> mconcat alts <> mempty { bdOther = [scrut] }
+    EBindF lhs _ rhs -> lhs <> rhs
+
+    -- Keep the parameters that are locations and points to a single node with at least one parameters
+    -- - that are not appear in others
+    -- - that are not appear in other function calls
+    -- - that are fetched at least once
+    DefF fn ps body ->
+      let funData =
+            [ (p,i,(fromJust mtag))
+            | (p,i) <- ps `zip` [1..]
+            , Map.member p (bdFetch body)
+            , let mtag = pointsToOneNode te p
+            , isJust mtag
+            , p `notElem` (bdOther body)
+            , p `notElem` (snd <$> (filter ((/=fn) . fst) (bdFunCall body)))
+            ]
+      in FunData $ case funData of
+          [] -> Map.empty
+          _  -> Map.singleton fn funData
+
+    ProgramF exts defs -> ProgramData $ Map.unionsWith mappend (fdArityData <$> defs)
+
+pointsToOneNode :: TypeEnv -> Name -> Maybe (Tag, Int)
+pointsToOneNode te var = case Map.lookup var (_variable te) of
+  (Just (T_SimpleType (T_Location locs))) -> case nub $ concatMap Map.keys $ ((_location te) Vector.!) <$> locs of
+    [tag] -> Just (tag, Vector.length $ head $ Map.elems $ (_location te) Vector.! (head locs))
+    _ -> Nothing
+  _ -> Nothing
+
+type VarM a = StateT Int NameM a
+
+evalVarM :: Int -> Exp -> VarM a -> a
+evalVarM n exp = fst . evalNameM exp . flip evalStateT n
+
+{-
+Phase2 and Phase3 can be implemented in one go.
+
+Change only the functions which are in the ArityData map, left the others out.
+ * Change fetches to pure, using the tag information provided
+ * Change funcall parameters
+ * Change fundef parameters
+
+Use the original parameter name with new indices, thus we dont need a name generator.
+-}
+phase2 :: Int -> ArityData -> Exp -> Exp
+phase2 n arityData exp = evalVarM 0 exp $ cata change exp where
+  fetchParNames :: Name -> Int -> Int -> [Name]
+  fetchParNames nm idx i = (\j -> packName $ concat [unpackName nm,".",show n,".",show idx,".arity.",show j]) <$> [1..i]
+
+  newParNames :: Name -> Int -> [Name]
+  newParNames nm i = (\j -> packName $ concat [unpackName nm,".",show n,".arity.",show j]) <$> [1..i]
+
+  parameterInfo :: ParameterInfo
+  parameterInfo = Map.fromList $ map (\(n,ith,tag) -> (n, (ith, tag))) $ concat $ Map.elems arityData
+
+  replace_parameters_with_new_ones = concatMap $ \case
+    p | Just (nth, (tag, ps)) <- Map.lookup p parameterInfo ->
+        newParNames p ps
+      | otherwise -> [p]
+
+  change :: ExpF (VarM Exp) -> (VarM Exp)
+  change = \case
+    {- Change only function bodies that are in the ArityData
+        from: (CNode c1 cn) <- fetch pi
+          to: (CNode c1 cn) <- pure (CNode pi1 pin)
+
+        from: funcall p1 pi pn
+          to: rec-funcall p1 pi1 pin pn
+          to: do (CNode c1 cn) <- fetch pi
+                 non-rec-funcall p1 c1 cn pn
+
+        from: fundef p1 pi pn
+          to: fundef p1 pi1 pin pn
+    -}
+    SFetchF var
+      | Just (nth, (tag, ps)) <- Map.lookup var parameterInfo ->
+        pure $ SReturn (ConstTagNode tag (newParNames var ps))
+      | otherwise ->
+        pure $ SFetch var
+
+    SAppF f fps
+      | 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
+            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]
+        fetches <- fmap catMaybes $ forM psi $ \case
+          (_, n) | Just _ <- Map.lookup n nsi -> pure Nothing
+          (i, n) | Just (t, jth) <- Map.lookup i qsi -> do
+            asPatName <- lift deriveWildCard
+            pure $ Just (AsPat t (fetchParNames n idx jth) asPatName, SFetch n)
+          _ -> pure Nothing
+        put (idx + 1)
+        pure $ case fetches of
+            [] -> SApp f newPs
+            _  -> SBlock $ foldr (\(pat, fetch) rest -> EBind fetch pat rest) (SApp f newPs) fetches
+      | otherwise ->
+        pure $ SApp f fps
+
+    DefF f ps new
+      | Map.member f arityData -> Def f (replace_parameters_with_new_ones ps) <$> new
+      | otherwise              -> Def f ps <$> new
+
+    rest -> embed <$> sequence rest

grin/src/Transformations/ExtendedSyntax/Optimising/CaseCopyPropagation.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE LambdaCase #-}
+module Transformations.ExtendedSyntax.Optimising.CaseCopyPropagation where
+
+import Data.Map (Map)
+import Data.Functor.Foldable
+
+import qualified Data.Map as Map
+
+import Control.Monad.State
+
+import Grin.ExtendedSyntax.Grin
+import Transformations.ExtendedSyntax.Names
+import Transformations.ExtendedSyntax.Util (cataM)
+
+
+-- NOTE: ~ Maybe Tag
+data TagInfo = Unknown | Known Tag
+  deriving (Eq, Ord, Show)
+
+-- | Maps alt names to TagInfo
+type InfoTable = Map Name TagInfo
+
+-- NOTE: Case Copy Propagtion ~ Case Unboxing
+caseCopyPropagation :: Exp -> (Exp, ExpChanges)
+caseCopyPropagation e = rebindCases infoTable e where
+  infoTable = collectTagInfo e
+
+-- | Collects tag information about case alternatives.
+collectTagInfo :: Exp -> InfoTable
+collectTagInfo = flip execState mempty . cataM alg where
+
+  alg :: ExpF TagInfo -> State InfoTable TagInfo
+  alg = \case
+    SBlockF tagInfo                   -> pure tagInfo
+    EBindF _ _ rhsTagInfo             -> pure rhsTagInfo
+    ECaseF scrut altTagInfo           -> pure $ commonTag altTagInfo
+    SReturnF (ConstTagNode tag [arg]) -> pure $ Known tag
+
+    AltF _ name tagInfo -> do
+      modify (Map.insert name tagInfo)
+      pure tagInfo
+
+    _ -> pure Unknown
+
+-- | Rebinds unboxable case expressions, and unboxes
+-- the corresponding alternatives' last return expressions.
+rebindCases :: InfoTable -> Exp -> (Exp, ExpChanges)
+rebindCases infoTable e = evalNameM e $ cataM alg e where
+
+  alg :: ExpF Exp -> NameM Exp
+  alg = \case
+    ECaseF scrut alts
+      | Known tag <- lookupCommonTag [ name | Alt _ name _ <- alts ]
+      , alts'     <- [ Alt cpat name (unboxLastReturn body) | Alt cpat name body <- alts ]
+      , case'     <- ECase scrut alts'
+      -> do
+        res <- deriveNewName "ccp"
+        pure $ SBlock $ EBind case' (VarPat res) (SReturn $ ConstTagNode tag [res])
+    e -> pure $ embed e
+
+  -- | Determine the common tag for a set of alternatives (if it exists).
+  lookupCommonTag :: [Name] -> TagInfo
+  lookupCommonTag =
+    commonTag
+    . map (\alt -> Map.findWithDefault Unknown alt infoTable)
+
+-- | Unboxes the last node-returning expression in a binding sequence.
+unboxLastReturn :: Exp -> Exp
+unboxLastReturn = apo coAlg where
+
+  coAlg :: Exp -> ExpF (Either Exp Exp)
+  coAlg = \case
+    SReturn (ConstTagNode _ [arg]) -> SReturnF (Var arg)
+    EBind lhs bPat rhs -> EBindF (Left lhs) bPat (Right rhs)
+    SBlock body -> SBlockF (Right body)
+    e -> Left <$> project e
+
+commonTag :: [TagInfo] -> TagInfo
+commonTag (t : ts)
+  | all (==t) ts = t
+commonTag _ = Unknown