CCP: Optimization.

grin-compiler · Jul 1, 2018 · bb8e634 · bb8e634
1 parent 76324f0
commit bb8e634
Showing 1 changed file with 27 additions and 28 deletions.
diff --git a/grin/src/Transformations/Optimising/CaseCopyPropagation.hs b/grin/src/Transformations/Optimising/CaseCopyPropagation.hs
@@ -18,42 +18,43 @@ import Transformations.Util
 caseCopyPropagation :: Exp -> Exp
 caseCopyPropagation exp0 = neExp $ evalNameM exp0 $ paraM folder exp0
 
-data Changes = None | InChange | Final deriving (Eq, Show)
+data Changes = None | InChange Tag | Final deriving (Eq, Show)
 
 data NewExp = NE
   { neChanges :: Changes
   , neExp     :: Exp
-  , neTag     :: Maybe Tag
   } deriving Show
 
+neTag :: NewExp -> Maybe Tag
+neTag (NE (InChange t)_ ) = Just t
+neTag _                   = Nothing
+
 folder :: ExpF (Exp, NewExp) -> NameM NewExp
 folder = \case
-  ProgramF ds                         -> pure $ NE Final (Program $ map (neExp . snd) ds) Nothing
-  DefF n ps body@(b, NE InChange _ _) -> pure $ NE Final (Def n ps b) Nothing
-  DefF n ps body@(_, NE c e t)        -> pure $ NE c (Def n ps e) t
+  ProgramF ds                           -> pure $ NE Final (Program $ map (neExp . snd) ds)
+  DefF n ps body@(b, NE (InChange _) _) -> pure $ NE Final (Def n ps b)
+  DefF n ps body@(_, NE c e)            -> pure $ NE c (Def n ps e)
 
-  SReturnF (ConstTagNode tag [value]) -> pure $ NE InChange (SReturn value) (Just tag)
+  SReturnF (ConstTagNode tag [value]) -> pure $ NE (InChange tag) (SReturn value)
 
-  SBlockF (b, NE InChange _ _) -> pure $ NE None (SBlock b) Nothing
-  SBlockF (_, NE c e Nothing)  -> pure $ NE c    (SBlock e) Nothing
-  exp@SBlockF{}                -> error $ "Invalid Block:" ++ show exp
+  SBlockF (b, NE (InChange _) _) -> pure $ NE None (SBlock b)
+  SBlockF (_, NE c e)            -> pure $ NE c    (SBlock e)
 
-  exp | isPrimitiveExp (embed $ fmap fst exp) -> pure $ NE None (embed $ fmap (neExp . snd) exp) Nothing
+  exp | isPrimitiveExp (embed $ fmap fst exp) -> pure $ NE None (embed $ fmap (neExp . snd) exp)
 
-  EBindF (_, NE None  lhse Nothing) pat (_, NE None rhse Nothing)           -> pure $ NE None (EBind lhse pat rhse) Nothing
-  EBindF (_, NE None  lhse Nothing) pat (_, NE InChange rhse rtag@(Just _)) -> pure $ NE InChange (EBind lhse pat rhse) rtag
-  EBindF (_, NE None  lhse Nothing) pat (_, NE Final rhse Nothing)          -> pure $ NE Final (EBind lhse pat rhse) Nothing
-  EBindF (_, NE Final lhse Nothing) pat (_, NE None  rhse Nothing)          -> pure $ NE Final (EBind lhse pat rhse) Nothing
-  EBindF (_, NE Final lhse Nothing) pat (rhso, NE InChange _ (Just _))      -> pure $ NE Final (EBind lhse pat rhso) Nothing
-  EBindF (_, NE Final lhse Nothing) pat (_, NE Final rhse Nothing)          -> pure $ NE Final (EBind lhse pat rhse) Nothing
-  EBindF (lhso, _) pat (_, NE change rhse tag) | isPrimitiveExp lhso        -> pure $ NE change (EBind lhso pat rhse) tag
-  exp@EBindF{} -> error $ "Invalid Bind:" ++ show exp
+  EBindF (_, NE None  lhse) pat (_, NE None rhse)                -> pure $ NE None (EBind lhse pat rhse)
+  EBindF (_, NE None  lhse) pat (_, NE (InChange t) rhse)        -> pure $ NE (InChange t) (EBind lhse pat rhse)
+  EBindF (_, NE None  lhse) pat (_, NE Final rhse)               -> pure $ NE Final (EBind lhse pat rhse)
+  EBindF (_, NE Final lhse) pat (_, NE None  rhse)               -> pure $ NE Final (EBind lhse pat rhse)
+  EBindF (_, NE Final lhse) pat (rhso, NE (InChange _) _)        -> pure $ NE Final (EBind lhse pat rhso)
+  EBindF (_, NE Final lhse) pat (_, NE Final rhse)               -> pure $ NE Final (EBind lhse pat rhse)
+  EBindF (lhso, _) pat (_, NE change rhse) | isPrimitiveExp lhso -> pure $ NE change (EBind lhso pat rhse)
 
-  AltF cpat body@(_, NE c e t) -> pure $ NE c (Alt cpat e) t
+  AltF cpat body@(_, NE c e) -> pure $ NE c (Alt cpat e)
 
   exp@(ECaseF val alts)
-    | all ((&&) <$> hasChanges InChange <*> (isJust . neTag . snd)) alts
-      -> if allSame $ map (neTag . snd) alts
+    | tags <- map (neTag . snd) alts, all isJust tags
+      -> if allSame tags
           then do var <- deriveNewName "ccp"
                   let (Just tag) = neTag $ snd $ head alts
                   pure $ NE
@@ -62,17 +63,15 @@ folder = \case
                         (ECase val (map (neExp . snd) alts))
                         (Var var)
                         (SReturn (ConstTagNode tag [Var var]))))
-                    Nothing
-          else pure $ NE None (ECase val (map fst alts)) Nothing
+          else pure $ NE None (ECase val (map fst alts))
     | any (hasChanges Final) alts
-        -> pure $ NE Final (ECase val $ map getFinalExp alts) Nothing
+        -> pure $ NE Final (ECase val $ map getFinalExp alts)
     | all (hasChanges None) alts
-        -> pure $ NE None (ECase val $ map (neExp . snd) alts) Nothing
-    | otherwise -> error $ "Invalid ECase: " ++ show exp
+        -> pure $ NE None (ECase val $ map (neExp . snd) alts)
 
   where
-    hasChanges c0 (_, NE c _ _) = c == c0
-    getFinalExp (oe, NE c ne _) = case c of { Final -> ne; _ -> oe }
+    hasChanges c0 (_, NE c _) = c == c0
+    getFinalExp (oe, NE c ne) = case c of { Final -> ne; _ -> oe }
 
 allSame :: (Eq a) => [a] -> Bool
 allSame [] = False