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