git.iko.soy/rowtype-yoga/purescript-native
on 65dc4fc help sign in
rowtype-yoga/purescript-native/src/CodeGen/Cpp/Optimizer.hs
148 lines 5.8 kB history raw
1-- | This module optimizes code in the simplified-Objective-C intermediate representation.
2--
3-- The following optimizations are supported:
4--
5-- * Collapsing nested blocks
6--
7-- * Tail call elimination
8--
9-- * Inlining of (>>=) and ret for the Eff monad
10--
11-- * Removal of unnecessary thunks
12--
13-- * Eta conversion
14--
15-- * Inlining variables
16--
17-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
18--
19-- * Inlining primitive Objective-C operators
20module CodeGen.Cpp.Optimizer (optimize) where
22import Prelude.Compat
24import Control.Monad.Supply.Class (MonadSupply)
25import Data.Text (Text)
26import Language.PureScript.CoreImp.AST
27import Language.PureScript.CoreImp.Optimizer.Blocks
28import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
29import Language.PureScript.CoreImp.Optimizer.Inliner hiding (inlineUnsafeCoerce, inlineUnsafePartial)
30import Language.PureScript.CoreImp.Optimizer.Unused
31import Language.PureScript.PSString (PSString, decodeString)
33import CodeGen.Cpp.Common (unusedName)
34import CodeGen.Cpp.Optimizer.TCO
36import qualified Language.PureScript.Constants as C
39-- | Apply a series of optimizer passes to simplified Objective-C code
40optimize :: MonadSupply m => AST -> m AST
41-- optimize = untilFixedPoint $ return . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . tco
42optimize cpp = do
43 cpp' <- untilFixedPoint (return . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) cpp
44 untilFixedPoint (return . tidyUp) . tco
45 =<< untilFixedPoint (return . magicDo')
46 =<< untilFixedPoint (return . magicDo) cpp'
49 where
50 tidyUp :: AST -> AST
51 tidyUp = applyAll
52 [ collapseNestedBlocks
53 -- , collapseNestedIfs
54 , collapseIfChecks
55 , removeCodeAfterReturnStatements
56 , unThunk
57 , etaConvert
58 , evaluateIifes
59 , inlineVariables
60 ]
62untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
63untilFixedPoint f = go
64 where
65 go a = do
66 a' <- f a
67 if a' == a then return a' else go a'
69-- | Overridden from CoreImp
71inlineUnsafePartial :: AST -> AST
72inlineUnsafePartial = everywhereTopDown convert where
73 convert (App ss (Indexer _ (Var _ unsafePartial) (Var _ partialUnsafe)) [ comp ])
74 | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe
75 -- Apply to undefined here, the application should be optimized away
76 -- if it is safe to do so
77 = App ss comp [ Var ss C.undefined ]
78 convert other = other
80inlineUnsafeCoerce :: AST -> AST
81inlineUnsafeCoerce = everywhereTopDown convert where
82 convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
83 | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
84 = comp
85 convert other = other
87collapseIfChecks :: AST -> AST
88collapseIfChecks = everywhere collapse where
89 collapse :: AST -> AST
90 collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs
91 collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)
92 | prop == "otherwise" && val == "Data_Boolean" = exprs
93 collapse exprs = exprs
95magicDo :: AST -> AST
96magicDo = magicDo'' C.eff C.effDictionaries
98magicDo' :: AST -> AST
99magicDo' = magicDo'' C.effect C.effectDictionaries
101magicDo'' :: Text -> C.EffectDictionaries -> AST -> AST
102magicDo'' effectModule C.EffectDictionaries{..} = everywhereTopDown convert
103 where
104 -- Desugar monomorphic calls to >>= and return for the Eff monad
105 convert :: AST -> AST
106 -- Desugar pure
107 convert (App _ (App _ pure' [val]) []) | isPure pure' = val
108 -- Desugar discard
109 convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 cpp)]) | isDiscard bind && unused == unusedName =
110 Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns cpp )
111 -- Desugar bind
112 convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 cpp)]) | isBind bind =
113 Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns cpp)
114 -- Inline double applications
115 convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
116 App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
117 convert other = other
119 -- Check if an expression represents a monomorphic call to >>= for the Eff monad
120 isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
121 isBind _ = False
122 -- Check if an expression represents a call to @discard@
123 isDiscard (App _ (App _ fn [dict1]) [dict2])
124 | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
125 isDict (effectModule, edBindDict) dict2 &&
126 isDiscardPoly fn = True
127 isDiscard _ = False
128 -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
129 isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
130 isPure _ = False
131 -- Check if an expression represents the polymorphic >>= function
132 isBindPoly = isDict (C.controlBind, C.bind)
133 -- Check if an expression represents the polymorphic pure function
134 isPurePoly = isDict (C.controlApplicative, C.pure')
135 -- Check if an expression represents the polymorphic discard function
136 isDiscardPoly = isDict (C.controlBind, C.discard)
139 applyReturns :: AST -> AST
140 applyReturns (Return ss ret) = Return ss (App ss ret [])
141 applyReturns (Block ss cpps) = Block ss (map applyReturns cpps)
142 applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
143 applyReturns other = other
145 isDict :: (Text, PSString) -> AST -> Bool
146 isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
147 Just x == decodeString dictName && y == moduleName
148 isDict _ _ = False