git.iko.soy/rowtype-yoga/purescript-native
on 4eacd14 help sign in
rowtype-yoga/purescript-native/src/CodeGen/Cpp/Optimizer.hs
130 lines 5.4 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 -> m AST
23-- optimize = untilFixedPoint $ return . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . tco
24optimize cpp = do
25 cpp' <- untilFixedPoint (return . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) cpp
26 untilFixedPoint (return . tidyUp) . tco
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
69collapseIfChecks :: AST -> AST
70collapseIfChecks = everywhere collapse where
71 collapse :: AST -> AST
72 collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs
73 collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)
74 | prop == "otherwise" && val == "Data_Boolean" = exprs
75 collapse exprs = exprs
77magicDo :: AST -> AST
78magicDo = magicDo'' C.eff C.effDictionaries
80magicDo' :: AST -> AST
81magicDo' = magicDo'' C.effect C.effectDictionaries
83magicDo'' :: Text -> C.EffectDictionaries -> AST -> AST
84magicDo'' effectModule C.EffectDictionaries{..} = everywhereTopDown convert
85 where
86 -- Desugar monomorphic calls to >>= and return for the Eff monad
87 convert :: AST -> AST
88 -- Desugar pure
89 convert (App _ (App _ pure' [val]) []) | isPure pure' = val
90 -- Desugar discard
91 convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 cpp)]) | isDiscard bind && unused == unusedName =
92 Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns cpp )
93 -- Desugar bind
94 convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 cpp)]) | isBind bind =
95 Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns cpp)
96 -- Inline double applications
97 convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
98 App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
99 convert other = other
101 -- Check if an expression represents a monomorphic call to >>= for the Eff monad
102 isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
103 isBind _ = False
104 -- Check if an expression represents a call to @discard@
105 isDiscard (App _ (App _ fn [dict1]) [dict2])
106 | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
107 isDict (effectModule, edBindDict) dict2 &&
108 isDiscardPoly fn = True
109 isDiscard _ = False
110 -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
111 isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
112 isPure _ = False
113 -- Check if an expression represents the polymorphic >>= function
114 isBindPoly = isDict (C.controlBind, C.bind)
115 -- Check if an expression represents the polymorphic pure function
116 isPurePoly = isDict (C.controlApplicative, C.pure')
117 -- Check if an expression represents the polymorphic discard function
118 isDiscardPoly = isDict (C.controlBind, C.discard)
121 applyReturns :: AST -> AST
122 applyReturns (Return ss ret) = Return ss (App ss ret [])
123 applyReturns (Block ss cpps) = Block ss (map applyReturns cpps)
124 applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
125 applyReturns other = other
127 isDict :: (Text, PSString) -> AST -> Bool
128 isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
129 Just x == decodeString dictName && y == moduleName
130 isDict _ _ = False