Update optimizer (issue #34); improve generated names

Author: andyarvanitis

src/CodeGen/IL.hs

@@ -325,9 +325,7 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =
         genGuard (cond, val) = do
           cond' <- valueToIL cond
           val'   <- valueToIL val
-          return
-            (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
-              (AST.Block Nothing [AST.Return Nothing val']) Nothing)
+          return $ AST.IfElse Nothing (unbox' bool cond') (AST.Block Nothing [AST.Return Nothing val']) Nothing
 
       guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v
 
@@ -366,16 +364,15 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =
 
   literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
   literalToBinderIL varName done (NumericLiteral num) =
-    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
+    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (unbox' int $ AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
   literalToBinderIL varName done (CharLiteral c) =
-    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
+    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (unbox' string $ AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
   literalToBinderIL varName done (StringLiteral str) =
-    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
+    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (unbox' string $ AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
   literalToBinderIL varName done (BooleanLiteral True) =
-    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
+    return [AST.IfElse Nothing (unbox' bool $ AST.Var Nothing varName) (AST.Block Nothing done) Nothing]
   literalToBinderIL varName done (BooleanLiteral False) =
-    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
-    -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
+    return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (unbox' bool $ AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
   literalToBinderIL varName done (ObjectLiteral bs) = go done bs
     where
     go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
@@ -406,7 +403,5 @@ emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
 arrayLength :: AST -> AST
 arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
 
-freshName' :: MonadSupply m => m Text
-freshName' = do
-    name <- freshName
-    return $ T.replace "$" "_Local_" name
+unbox' :: Text -> AST -> AST
+unbox' ty e = AST.App Nothing (AST.StringLiteral Nothing $ mkString ty) [e]

src/CodeGen/IL/Common.hs

@@ -3,6 +3,7 @@ module CodeGen.IL.Common where
 
 import Prelude.Compat
 
+import Control.Monad.Supply.Class (MonadSupply, freshName)
 import Data.Char
 import Data.Monoid ((<>))
 import Data.Text (Text)
@@ -14,7 +15,7 @@ import Language.PureScript.Names
 moduleNameToIL :: ModuleName -> Text
 moduleNameToIL (ModuleName pns) =
   let name = T.intercalate "_" (runProperName `map` pns)
-  in if nameIsILBuiltIn name then ("_" <> name <> "_") else name
+  in if nameIsILBuiltIn name then (name <> "_") else name
 
 -- | Convert an 'Ident' into a valid C++ identifier:
 --
@@ -29,11 +30,11 @@ identToIL (Ident name) = properToIL name
 identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
 
 unusedName :: Text
-unusedName = "_Unused_"
+unusedName = "_"
 
 properToIL :: Text -> Text
 properToIL name
-  | nameIsILReserved name || nameIsILBuiltIn name || prefixIsReserved name = "_" <> name <> "_"
+  | nameIsILReserved name || nameIsILBuiltIn name || prefixIsReserved name = name <> "_"
   | otherwise = T.concatMap identCharToText name
 
 -- | Test if a string is a valid AST identifier without escaping.
@@ -45,9 +46,9 @@ identNeedsEscaping s = s /= properToIL s || T.null s
 identCharToText :: Char -> Text
 identCharToText c | isAlphaNum c = T.singleton c
 identCharToText '_' = "_"
-identCharToText '\'' = "_Prime_"
+identCharToText '\'' = "Prime_"
 identCharToText '$' = "$"
-identCharToText c = "_Code_Point_" <> T.pack (show (ord c))
+identCharToText c = "_code_point_" <> T.pack (show (ord c))
 
 -- | Checks whether an identifier name is reserved in C++.
 nameIsILReserved :: Text -> Bool
@@ -209,14 +210,19 @@ bool = "bool"
 string :: Text
 string = "string"
 
+auto :: Text
+auto = "const auto"
+
 unbox :: Text -> Text
 unbox t = "unbox<" <> t <> ">"
 
 arrayLengthFn :: Text
 arrayLengthFn = "array_length"
 
 unretainedSuffix :: Text
-unretainedSuffix = "_Weak_"
+unretainedSuffix = "_weak_"
 
-tcoLoop :: Text
-tcoLoop = "_TCO_Loop_"
+freshName' :: MonadSupply m => m Text
+freshName' = do
+    name <- freshName
+    return $ T.replace "$" "_" name

src/CodeGen/IL/Optimizer.hs

@@ -8,31 +8,29 @@ import Data.Text (Text)
 import Language.PureScript.CoreImp.AST
 import Language.PureScript.CoreImp.Optimizer.Blocks
 import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
-import Language.PureScript.CoreImp.Optimizer.Inliner hiding (inlineUnsafeCoerce, inlineUnsafePartial)
+import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)
 import Language.PureScript.CoreImp.Optimizer.Unused
-import Language.PureScript.PSString (PSString, decodeString)
 
 import CodeGen.IL.Common (unusedName)
+import CodeGen.IL.Optimizer.Inliner
+import CodeGen.IL.Optimizer.MagicDo
 import CodeGen.IL.Optimizer.TCO
 
 import qualified Language.PureScript.Constants as C
 
-
--- | Apply a series of optimizer passes to simplified C++ code
+-- | Apply a series of optimizer passes to simplified IL code
 optimize :: MonadSupply m => AST -> AST -> m AST
--- optimize = untilFixedPoint $ return . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . tco
 optimize mn il = do
-    il' <- untilFixedPoint (return . inlineApply . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
-    untilFixedPoint (return . tidyUp) . tco mn
-      =<< untilFixedPoint (return . magicDo')
-      =<< untilFixedPoint (return . magicDo) il'
-
-
+    il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
+    untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST
+      =<< untilFixedPoint (return . magicDoST)
+      =<< untilFixedPoint (return . magicDoEff)
+      =<< untilFixedPoint (return . magicDoEffect) il'
   where
     tidyUp :: AST -> AST
     tidyUp = applyAll
       [ collapseNestedBlocks
-      -- , collapseNestedIfs
+      , collapseNestedIfs
       , collapseIfChecks
       , removeCodeAfterReturnStatements
       , unThunk
@@ -48,34 +46,6 @@ untilFixedPoint f = go
    a' <- f a
    if a' == a then return a' else go a'
 
--- | Overridden from CoreImp
-
-inlineUnsafePartial :: AST -> AST
-inlineUnsafePartial = everywhereTopDown convert where
-  convert (App ss (Indexer _ (Var _ unsafePartial) (Var _ partialUnsafe)) [ comp ])
-    | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe
-    -- Apply to undefined here, the application should be optimized away
-    -- if it is safe to do so
-    = App ss comp [ Var ss C.undefined ]
-  convert other = other
-
-inlineUnsafeCoerce :: AST -> AST
-inlineUnsafeCoerce = everywhereTopDown convert where
-  convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
-    | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
-    = comp
-  convert other = other
-
-inlineApply :: AST -> AST
-inlineApply = everywhereTopDown convert where
-  convert (App ss (App _ (Indexer _ (Var _ apply) (Var _ dataFunction)) [ f ]) [ arg ])
-    | apply == C.apply && dataFunction == C.dataFunction
-    = App ss f [ arg ]
-  convert (App ss (App _ (Indexer _ (Var _ applyFlipped) (Var _ dataFunction)) [ arg ]) [ f ])
-    | applyFlipped == C.applyFlipped && dataFunction == C.dataFunction
-    = App ss f [ arg ]
-  convert other = other
-
 collapseIfChecks :: AST -> AST
 collapseIfChecks = everywhere collapse where
   collapse :: AST -> AST
@@ -84,57 +54,14 @@ collapseIfChecks = everywhere collapse where
     | prop == "otherwise" && val == "Data_Boolean" = exprs
   collapse exprs = exprs
 
-magicDo :: AST -> AST
-magicDo = magicDo'' C.eff C.effDictionaries
-
-magicDo' :: AST -> AST
-magicDo' = magicDo'' C.effect C.effectDictionaries
-
-magicDo'' :: Text -> C.EffectDictionaries -> AST -> AST
-magicDo'' effectModule C.EffectDictionaries{..} = everywhereTopDown convert
+ignoreUnusedResults :: AST -> AST
+ignoreUnusedResults = everywhere $ removeFromBlock go
   where
-  -- Desugar monomorphic calls to >>= and return for the Eff monad
-  convert :: AST -> AST
-  -- Desugar pure
-  convert (App _ (App _ pure' [val]) []) | isPure pure' = val
-  -- Desugar discard
-  convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =
-    Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )
-  -- Desugar bind
-  convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =
-    Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)
-  -- Inline double applications
-  convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
-    App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
-  convert other = other
-
-  -- Check if an expression represents a monomorphic call to >>= for the Eff monad
-  isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
-  isBind _ = False
-  -- Check if an expression represents a call to @discard@
-  isDiscard (App _ (App _ fn [dict1]) [dict2])
-    | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
-      isDict (effectModule, edBindDict) dict2 &&
-      isDiscardPoly fn = True
-  isDiscard _ = False
-  -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
-  isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
-  isPure _ = False
-  -- Check if an expression represents the polymorphic >>= function
-  isBindPoly = isDict (C.controlBind, C.bind)
-  -- Check if an expression represents the polymorphic pure function
-  isPurePoly = isDict (C.controlApplicative, C.pure')
-  -- Check if an expression represents the polymorphic discard function
-  isDiscardPoly = isDict (C.controlBind, C.discard)
-
-
-  applyReturns :: AST -> AST
-  applyReturns (Return ss ret) = Return ss (App ss ret [])
-  applyReturns (Block ss ils) = Block ss (map applyReturns ils)
-  applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
-  applyReturns other = other
-
-  isDict :: (Text, PSString) -> AST -> Bool
-  isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
-    Just x == decodeString dictName && y == moduleName
-  isDict _ _ = False
+  go :: [AST] -> [AST]
+  go [] = []
+  go (VariableIntroduction ss var (Just s) : sts)
+    | not $ any (everything (||) (isUsed var)) sts = sts'
+    where
+    sts' | App{} <- s = s : (go sts)
+         | otherwise = go sts
+  go (s:sts) = s : go sts

src/CodeGen/IL/Optimizer/Common.hs

@@ -0,0 +1,18 @@
+-- | Common functions used by the various optimizer phases
+module CodeGen.IL.Optimizer.Common where
+
+import Prelude.Compat
+
+import Data.Text (Text)
+
+import Language.PureScript.CoreImp.AST
+import Language.PureScript.PSString (PSString, decodeString)
+
+isDict :: (Text, PSString) -> AST -> Bool
+isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
+  Just x == decodeString dictName && y == moduleName
+isDict _ _ = False
+
+isDict' :: [(Text, PSString)] -> AST -> Bool
+isDict' xs il = any (`isDict` il) xs
+