git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
C++: updates for 0.9 (get MagicDo building)
4e326f9Andy Arvanitis
src/Language/PureScript/CodeGen/Cpp/Optimizer/Common.hs+14
compare with golang
unifiedsplit
@@ -75,3 +75,17 @@ isUpdated var1 = everythingOnCpp (||) check
75removeFromBlock :: ([Cpp] -> [Cpp]) -> Cpp -> Cpp
75removeFromBlock :: ([Cpp] -> [Cpp]) -> Cpp -> Cpp
76removeFromBlock go (CppBlock sts) = CppBlock (go sts)
76removeFromBlock go (CppBlock sts) = CppBlock (go sts)
77removeFromBlock _ cpp = cpp
77removeFromBlock _ cpp = cpp
78+
79+isFn :: (String, String) -> Cpp -> Bool
80+isFn (moduleName, fnName) (CppAccessor (CppVar x) (CppVar y)) =
81+ x == fnName && y == moduleName
82+isFn (moduleName, fnName) (CppIndexer (CppStringLiteral x) (CppVar y)) =
83+ x == fnName && y == moduleName
84+isFn _ _ = False
85+
86+isDict :: (String, String) -> Cpp -> Bool
87+isDict (moduleName, dictName) (CppAccessor (CppVar x) (CppVar y)) = x == dictName && y == moduleName
88+isDict _ _ = False
89+
90+isDict' :: [(String, String)] -> Cpp -> Bool
91+isDict' xs cpp = any (`isDict` cpp) xs
src/Language/PureScript/CodeGen/Cpp/Optimizer/MagicDo.hs+64−45
@@ -13,23 +13,22 @@
13-- and bind for the Eff monad, as well as some of its actions.
13-- and bind for the Eff monad, as well as some of its actions.
14--
14--
15-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
16−
17−module Language.PureScript.CodeGen.Cpp.Optimizer.MagicDo (
16+module Language.PureScript.CodeGen.Cpp.Optimizer.MagicDo (magicDo) where
18− magicDo
19−) where
20
17
21import Prelude.Compat
18import Prelude.Compat
22
19
20+import Data.List (nub)
21+import Data.Maybe (fromJust, isJust)
22+
23import Language.PureScript.CodeGen.Cpp.AST
23import Language.PureScript.CodeGen.Cpp.AST
24−import Language.PureScript.CodeGen.Cpp.Common
24+import Language.PureScript.CodeGen.Cpp.Optimizer.Common
25import Language.PureScript.CodeGen.Cpp.Types
25import Language.PureScript.CodeGen.Cpp.Types
26−import Language.PureScript.Names
27import Language.PureScript.Options
26import Language.PureScript.Options
28import qualified Language.PureScript.Constants as C
27import qualified Language.PureScript.Constants as C
29
28
30magicDo :: Options -> Cpp -> Cpp
29magicDo :: Options -> Cpp -> Cpp
31magicDo opts | optionsNoMagicDo opts = id
30magicDo opts | optionsNoMagicDo opts = id
32− | otherwise = magicDo'
31+ | otherwise = inlineST . magicDo'
33
32
34-- |
33-- |
35-- Inline type class dictionaries for >>= and return for the Eff monad
34-- Inline type class dictionaries for >>= and return for the Eff monad
@@ -54,63 +53,38 @@ magicDo' = everywhereOnCpp undo . everywhereOnCppTopDown convert
54 fnName = "__do"
53 fnName = "__do"
55 -- Desugar monomorphic calls to >>= and return for the Eff monad
54 -- Desugar monomorphic calls to >>= and return for the Eff monad
56 convert :: Cpp -> Cpp
55 convert :: Cpp -> Cpp
57− -- Desugar return
56+ -- Desugar pure & 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
62 convert (CppApp (CppApp pure' [val]) []) | isPure pure' = val
57 convert (CppApp (CppApp pure' [val]) []) | isPure pure' = val
63 -- Desugar >>
58 -- 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 )
66 convert (CppApp (CppApp bind [m]) [CppLambda _ [] rty (CppBlock cpp)]) | isBind bind =
59 convert (CppApp (CppApp bind [m]) [CppLambda _ [] rty (CppBlock cpp)]) | isBind bind =
67 CppFunction fnName [] rty [] $ CppBlock (CppApp m [] : map applyReturns cpp )
60 CppFunction fnName [] rty [] $ CppBlock (CppApp m [] : map applyReturns cpp )
68 -- Desugar >>=
61 -- 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)
71 convert (CppApp (CppApp bind [m]) [CppLambda _ [arg] rty (CppBlock cpp)]) | isBind bind =
62 convert (CppApp (CppApp bind [m]) [CppLambda _ [arg] rty (CppBlock cpp)]) | isBind bind =
72 CppFunction fnName [] rty [] $ CppBlock (CppVariableIntroduction arg [] (Just (CppApp m [])) : map applyReturns cpp)
63 CppFunction fnName [] rty [] $ CppBlock (CppVariableIntroduction arg [] (Just (CppApp m [])) : map applyReturns cpp)
73 -- Desugar untilE
64 -- Desugar untilE
74 convert (CppApp (CppApp f [arg]) []) | isEffFunc C.untilE f =
65 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 []])) []
76 -- Desugar whileE
67 -- 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 []])) []
79 convert (CppApp (CppApp (CppApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
68 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 []])) []
81 convert other = other
70 convert other = other
82 -- Check if an expression represents a monomorphic call to >>= for the Eff monad
71 -- 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
84 isBind _ = False
73 isBind _ = False
85− -- Check if an expression represents a monomorphic call to return for the Eff monad
74+ -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
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
75+ isPure (CppApp fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True
90 isPure _ = False
76 isPure _ = False
91 -- Check if an expression represents the polymorphic >>= function
77 -- 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.>>=)])
78+ isBindPoly = isFn (C.controlBind, C.bind)
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
79+ -- Check if an expression represents the polymorphic pure or return function
96− isRetPoly (CppAccessor (CppVar returnEscaped) (CppVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
80+ isPurePoly = isFn (C.controlApplicative, C.pure')
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
81+ -- Check if an expression represents a function in the Eff module
104 isEffFunc name (CppAccessor (CppVar name') (CppVar eff)) = eff == C.eff && name == name'
82 isEffFunc name (CppAccessor (CppVar name') (CppVar eff)) = eff == C.eff && name == name'
105 isEffFunc _ _ = False
83 isEffFunc _ _ = False
106− -- Check if an expression represents the Monad Eff dictionary
84+
107− isEffDict name (CppVar ident) | ident == name = True
108− isEffDict name (CppAccessor (CppVar prop) (CppVar eff)) = eff == C.eff && prop == name
109− isEffDict _ _ = False
110 -- Remove __do function applications which remain after desugaring
85 -- Remove __do function applications which remain after desugaring
111 undo :: Cpp -> Cpp
86 undo :: Cpp -> Cpp
112 undo (CppReturn (CppApp (CppFunction ident [] _ _ body) [])) | ident == fnName = body
87 undo (CppReturn (CppApp (CppFunction ident [] _ _ body) [])) | ident == fnName = body
113− undo (CppFunction ident [] rty _ body) | ident == fnName = CppLambda [CppCaptureAll] [] rty body
114 undo other = other
88 undo other = other
115
89
116 applyReturns :: Cpp -> Cpp
90 applyReturns :: Cpp -> Cpp
@@ -123,5 +97,50 @@ magicDo' = everywhereOnCpp undo . everywhereOnCppTopDown convert
123-- |
97-- |
124-- Inline functions in the ST module
98-- Inline functions in the ST module
125--
99--
126−-- TODO: various issues in C++ backend -- revisit later
100+inlineST :: Cpp -> Cpp
127−--
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