@@ -13,23 +13,22 @@
1313-- and bind for the Eff monad, as well as some of its actions.
1414--
1515-----------------------------------------------------------------------------
16−
17−module Language.PureScript.CodeGen.Cpp.Optimizer.MagicDo (
18− magicDo
19−) where
16+module Language.PureScript.CodeGen.Cpp.Optimizer.MagicDo (magicDo) where
2017
2118import Prelude.Compat
2219
20+import Data.List (nub)
21+import Data.Maybe (fromJust, isJust)
22+
2323import Language.PureScript.CodeGen.Cpp.AST
24−import Language.PureScript.CodeGen.Cpp.Common
24+import Language.PureScript.CodeGen.Cpp.Optimizer.Common
2525import Language.PureScript.CodeGen.Cpp.Types
26−import Language.PureScript.Names
2726import Language.PureScript.Options
2827import qualified Language.PureScript.Constants as C
2928
3029magicDo :: Options -> Cpp -> Cpp
3130magicDo opts | optionsNoMagicDo opts = id
32− | otherwise = magicDo'
31+ | otherwise = inlineST . magicDo'
3332
3433-- |
3534-- Inline type class dictionaries for >>= and return for the Eff monad
@@ -54,63 +53,38 @@ magicDo' = everywhereOnCpp undo . everywhereOnCppTopDown convert
5453 fnName = "__do"
5554 -- Desugar monomorphic calls to >>= and return for the Eff monad
5655 convert :: Cpp -> Cpp
57− -- Desugar return
58− convert (CppApp (CppApp ret [effDict, val]) []) | isRetPoly ret && isEffDict C.monadEffDictionary effDict = val
59− convert (CppApp (CppApp ret [val]) []) | isReturn ret = val
60− -- Desugar pure
61− convert (CppApp (CppApp pure' [effDict, val]) []) | isPurePoly pure' && isEffDict C.applicativeEffDictionary effDict = val
56+ -- Desugar pure & return
6257 convert (CppApp (CppApp pure' [val]) []) | isPure pure' = val
6358 -- Desugar >>
64− convert (CppApp bind [effDict, m, CppLambda _ [] rty (CppBlock cpp)]) | isBindPoly bind && isEffDict C.bindEffDictionary effDict =
65− CppFunction fnName [] rty [] $ CppBlock (CppApp m [] : map applyReturns cpp )
6659 convert (CppApp (CppApp bind [m]) [CppLambda _ [] rty (CppBlock cpp)]) | isBind bind =
6760 CppFunction fnName [] rty [] $ CppBlock (CppApp m [] : map applyReturns cpp )
6861 -- Desugar >>=
69− convert (CppApp bind [effDict, m, CppLambda _ [arg] rty (CppBlock cpp)]) | isBindPoly bind && isEffDict C.bindEffDictionary effDict =
70− CppFunction fnName [] rty [] $ CppBlock (CppVariableIntroduction arg [] (Just (CppApp m [])) : map applyReturns cpp)
7162 convert (CppApp (CppApp bind [m]) [CppLambda _ [arg] rty (CppBlock cpp)]) | isBind bind =
7263 CppFunction fnName [] rty [] $ CppBlock (CppVariableIntroduction arg [] (Just (CppApp m [])) : map applyReturns cpp)
7364 -- Desugar untilE
7465 convert (CppApp (CppApp f [arg]) []) | isEffFunc C.untilE f =
75− CppApp (CppLambda [CppCaptureAll] [] (Just $ CppAny []) (CppBlock [ CppWhile (CppUnary CppNot (CppApp arg [])) (CppBlock []), CppReturn $ CppObjectLiteral []])) []
66+ CppApp (CppLambda [CppCaptureAll] [] Nothing (CppBlock [ CppWhile (CppUnary CppNot (CppApp arg [])) (CppBlock []), CppReturn $ CppObjectLiteral []])) []
7667 -- Desugar whileE
77− convert (CppApp (CppApp f [arg1, arg2]) []) | isEffFunc C.whileE f =
78− CppApp (CppLambda [CppCaptureAll] [] (Just $ CppAny []) (CppBlock [ CppWhile (CppApp arg1 []) (CppBlock [ CppApp arg2 [] ]), CppReturn $ CppObjectLiteral []])) []
7968 convert (CppApp (CppApp (CppApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
80− CppApp (CppLambda [CppCaptureAll] [] (Just $ CppAny []) (CppBlock [ CppWhile (CppApp arg1 []) (CppBlock [ CppApp arg2 [] ]), CppReturn $ CppObjectLiteral []])) []
69+ CppApp (CppLambda [CppCaptureAll] [] Nothing (CppBlock [ CppWhile (CppApp arg1 []) (CppBlock [ CppApp arg2 [] ]), CppReturn $ CppObjectLiteral []])) []
8170 convert other = other
8271 -- Check if an expression represents a monomorphic call to >>= for the Eff monad
83− isBind (CppApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True
72+ isBind (CppApp fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True
8473 isBind _ = False
85− -- Check if an expression represents a monomorphic call to return for the Eff monad
86− isReturn (CppApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
87− isReturn _ = False
88− -- Check if an expression represents a monomorphic call to pure for the Eff applicative
89− isPure (CppApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True
74+ -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
75+ isPure (CppApp fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True
9076 isPure _ = False
9177 -- Check if an expression represents the polymorphic >>= function
92− isBindPoly (CppAccessor (CppVar prop) (CppVar prelude)) = prelude == C.prelude && (prop `elem` map identToCpp [Ident C.bind, Op (C.>>=)])
93− isBindPoly (CppIndexer (CppStringLiteral bind) (CppVar prelude)) = prelude == C.prelude && (bind `elem` [C.bind, (C.>>=)])
94− isBindPoly _ = False
95− -- Check if an expression represents the polymorphic return function
96− isRetPoly (CppAccessor (CppVar returnEscaped) (CppVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
97− isRetPoly (CppIndexer (CppStringLiteral return') (CppVar prelude)) = prelude == C.prelude && return' == C.return
98− isRetPoly _ = False
99− -- Check if an expression represents the polymorphic pure function
100− isPurePoly (CppAccessor (CppVar pure') (CppVar prelude)) = prelude == C.prelude && pure' == C.pure'
101− isPurePoly (CppIndexer (CppStringLiteral pure') (CppVar prelude)) = prelude == C.prelude && pure' == C.pure'
102− isPurePoly _ = False
103− -- Check if an expression represents a function in the Ef module
78+ isBindPoly = isFn (C.controlBind, C.bind)
79+ -- Check if an expression represents the polymorphic pure or return function
80+ isPurePoly = isFn (C.controlApplicative, C.pure')
81+ -- Check if an expression represents a function in the Eff module
10482 isEffFunc name (CppAccessor (CppVar name') (CppVar eff)) = eff == C.eff && name == name'
10583 isEffFunc _ _ = False
106− -- Check if an expression represents the Monad Eff dictionary
107− isEffDict name (CppVar ident) | ident == name = True
108− isEffDict name (CppAccessor (CppVar prop) (CppVar eff)) = eff == C.eff && prop == name
109− isEffDict _ _ = False
84+
11085 -- Remove __do function applications which remain after desugaring
11186 undo :: Cpp -> Cpp
11287 undo (CppReturn (CppApp (CppFunction ident [] _ _ body) [])) | ident == fnName = body
113− undo (CppFunction ident [] rty _ body) | ident == fnName = CppLambda [CppCaptureAll] [] rty body
11488 undo other = other
11589
11690 applyReturns :: Cpp -> Cpp
@@ -123,5 +97,50 @@ magicDo' = everywhereOnCpp undo . everywhereOnCppTopDown convert
12397-- |
12498-- Inline functions in the ST module
12599--
126−-- TODO: various issues in C++ backend -- revisit later
127−--
100+inlineST :: Cpp -> Cpp
101+inlineST = everywhereOnCpp convertBlock
102+ where
103+ -- Look for runST blocks and inline the STRefs there.
104+ -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
105+ -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
106+ convertBlock (CppApp f [arg]) | isSTFunc C.runST f =
107+ let refs = nub . findSTRefsIn $ arg
108+ usages = findAllSTUsagesIn arg
109+ allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
110+ localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
111+ in everywhereOnCpp (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
112+ convertBlock other = other
113+ -- Convert a block in a safe way, preserving object wrappers of references,
114+ -- or in a more aggressive way, turning wrappers into local variables depending on the
115+ -- agg(ressive) parameter.
116+ convert agg (CppApp f [arg]) | isSTFunc C.newSTRef f =
117+ CppLambda [CppCaptureAll] [] Nothing (CppBlock [CppReturn $ if agg then arg else CppObjectLiteral [(C.stRefValue, arg)]])
118+ convert agg (CppApp (CppApp f [ref]) []) | isSTFunc C.readSTRef f =
119+ if agg then ref else CppAccessor (CppVar C.stRefValue) ref
120+ convert agg (CppApp (CppApp (CppApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
121+ if agg then CppAssignment ref arg else CppAssignment (CppAccessor (CppVar C.stRefValue) ref) arg
122+ convert agg (CppApp (CppApp (CppApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
123+ if agg then CppAssignment ref (CppApp func [ref]) else CppAssignment (CppAccessor (CppVar C.stRefValue) ref) (CppApp func [CppAccessor (CppVar C.stRefValue) ref])
124+ convert _ other = other
125+ -- Check if an expression represents a function in the ST module
126+ isSTFunc name (CppAccessor (CppVar name') (CppVar st)) = st == C.st && name == name'
127+ isSTFunc _ _ = False
128+ -- Find all ST Refs initialized in this block
129+ findSTRefsIn = everythingOnCpp (++) isSTRef
130+ where
131+ isSTRef (CppVariableIntroduction (ident, _) _ (Just (CppApp (CppApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]
132+ isSTRef _ = []
133+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
134+ findAllSTUsagesIn = everythingOnCpp (++) isSTUsage
135+ where
136+ isSTUsage (CppApp (CppApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]
137+ isSTUsage (CppApp (CppApp (CppApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
138+ isSTUsage _ = []
139+ -- Find all uses of a variable
140+ appearingIn ref = everythingOnCpp (++) isVar
141+ where
142+ isVar e@(CppVar v) | v == ref = [e]
143+ isVar _ = []
144+ -- Convert a Cpp value to a String if it is a CppVar
145+ toVar (CppVar v) = Just v
146+ toVar _ = Nothing