git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Many more inliner updates
commit52a6638d7967a8b3a2a6dac314ad20c59972c438 authorAndy Arvanitis <andyarvanitis@gmail.com> dateSun 30 Jun 2019, 18:09 (7 years ago) parent6c22121
7 files changed+739−231
compare with golang
unifiedsplit
src/CodeGen/IL.hs+1−6 src/CodeGen/IL/Common.hs+7−3 src/CodeGen/IL/Optimizer.hs+27−96 src/CodeGen/IL/Optimizer/Common.hs+20 src/CodeGen/IL/Optimizer/Inliner.hs+419 src/CodeGen/IL/Optimizer/MagicDo.hs+146 src/CodeGen/IL/Printer.hs+119−126
src/CodeGen/IL.hs+1−6
@@ -182,7 +182,7 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =
182182 updates <- mapM (sndM valueToIL) ps
183183 obj' <- freshName'
184184 let objVar = AST.Var Nothing obj'
185− copy = AST.VariableIntroduction Nothing obj' (Just $ AST.App Nothing (AST.Var Nothing (unbox dictType)) [obj])
185+ copy = AST.VariableIntroduction Nothing obj' (Just $ AST.App Nothing (AST.StringLiteral Nothing (mkString dictType)) [obj])
186186 assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
187187 sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
188188 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
@@ -361,8 +361,3 @@ emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
361361arrayLength :: AST -> AST
362362arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
363363-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")
364−
365−freshName' :: MonadSupply m => m Text
366−freshName' = do
367− name <- freshName
368− return $ T.replace "$" "ᵗ" name
src/CodeGen/IL/Common.hs+7−3
@@ -3,7 +3,9 @@ module CodeGen.IL.Common where
33
44import Prelude.Compat
55
6+import Control.Monad.Supply.Class (MonadSupply, freshName)
67import Data.Char
8+import Data.Maybe (maybe)
79import Data.Monoid ((<>))
810import Data.Text (Text)
911import qualified Data.Text as T
@@ -169,11 +171,13 @@ bool = "bool"
169171string :: Text
170172string = "string"
171173
172−unbox :: Text -> Text
173−unbox t = ".(" <> t <> ")"
174−
175174arrayLengthFn :: Text
176175arrayLengthFn = "Length"
177176
178177tcoLoop :: Text
179178tcoLoop = "ᵗᶜloop"
179+
180+freshName' :: MonadSupply m => m Text
181+freshName' = do
182+ name <- freshName
183+ return $ T.replace "$" "ᵗ" name
src/CodeGen/IL/Optimizer.hs+27−96
@@ -8,34 +8,36 @@ import Data.Text (Text)
88import Language.PureScript.CoreImp.AST
99import Language.PureScript.CoreImp.Optimizer.Blocks
1010import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
11−import Language.PureScript.CoreImp.Optimizer.Inliner hiding (inlineUnsafeCoerce, inlineUnsafePartial)
11+import Language.PureScript.CoreImp.Optimizer.Inliner hiding (inlineCommonOperators, inlineCommonValues, inlineUnsafeCoerce, inlineUnsafePartial)
1212import Language.PureScript.CoreImp.Optimizer.Unused
13−import Language.PureScript.PSString (PSString, decodeString)
1413
1514import CodeGen.IL.Common (moduleNameToIL', undefinedName, unusedName)
15+import CodeGen.IL.Optimizer.Inliner
16+import CodeGen.IL.Optimizer.MagicDo
1617import CodeGen.IL.Optimizer.TCO
1718
1819import qualified Language.PureScript.Constants as C
1920
20−
21−-- | Apply a series of optimizer passes to simplified C++ code
21+-- | Apply a series of optimizer passes to simplified IL code
2222optimize :: MonadSupply m => AST -> AST -> m AST
23−-- optimize = untilFixedPoint $ return . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . tco
2423optimize mn il = do
25− il' <- untilFixedPoint (return . inlineApply . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
26− untilFixedPoint (return . tidyUp) . tco mn
27− =<< untilFixedPoint (return . magicDo')
28− =<< untilFixedPoint (return . magicDo) il'
29−
30−
24+ il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . applyAll
25+ [ inlineCommonValues
26+ , inlineCommonOperators
27+ ]) il
28+ untilFixedPoint (return . tidyUp) . tco mn . inlineST
29+ =<< untilFixedPoint (return . magicDoST)
30+ =<< untilFixedPoint (return . magicDoEff)
31+ =<< untilFixedPoint (return . magicDoEffect) il'
3132 where
3233 tidyUp :: AST -> AST
3334 tidyUp = applyAll
34− [ ignoreUnusedResults
35− , collapseNestedBlocks
36− -- , collapseNestedIfs
35+ [ collapseNestedBlocks
36+ , collapseNestedIfs
3737 , collapseIfChecks
38+ , ignoreUnusedResults
3839 , removeCodeAfterReturnStatements
40+ -- , removeUndefinedApp
3941 , unThunk
4042 , etaConvert
4143 , evaluateIifes
@@ -51,31 +53,15 @@ untilFixedPoint f = go
5153
5254-- | Overridden from CoreImp
5355
54−inlineUnsafePartial :: AST -> AST
55−inlineUnsafePartial = everywhereTopDown convert where
56− convert (App ss (Indexer _ (Var _ unsafePartial) (Var _ partialUnsafe)) [ comp ])
57− | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe
58− -- Apply to undefined here, the application should be optimized away
59− -- if it is safe to do so
60− = App ss comp [ Var ss undefinedName ]
61− convert other = other
62−
63−inlineUnsafeCoerce :: AST -> AST
64−inlineUnsafeCoerce = everywhereTopDown convert where
65− convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
66− | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
67− = comp
68− convert other = other
69−
70−inlineApply :: AST -> AST
71−inlineApply = everywhereTopDown convert where
72− convert (App ss (App _ (Indexer _ (Var _ apply) (Var _ dataFunction)) [ f ]) [ arg ])
73− | apply == C.apply && dataFunction == C.dataFunction
74− = App ss f [ arg ]
75− convert (App ss (App _ (Indexer _ (Var _ applyFlipped) (Var _ dataFunction)) [ arg ]) [ f ])
76− | applyFlipped == C.applyFlipped && dataFunction == C.dataFunction
77− = App ss f [ arg ]
78− convert other = other
56+-- inlineApply :: AST -> AST
57+-- inlineApply = everywhereTopDown convert where
58+-- convert (App ss (App _ (Indexer _ (Var _ apply) (Var _ dataFunction)) [ f ]) [ arg ])
59+-- | apply == C.apply && dataFunction == C.dataFunction
60+-- = App ss f [ arg ]
61+-- convert (App ss (App _ (Indexer _ (Var _ applyFlipped) (Var _ dataFunction)) [ arg ]) [ f ])
62+-- | applyFlipped == C.applyFlipped && dataFunction == C.dataFunction
63+-- = App ss f [ arg ]
64+-- convert other = other
7965
8066collapseIfChecks :: AST -> AST
8167collapseIfChecks = everywhere collapse where
@@ -91,61 +77,6 @@ ignoreUnusedResults = everywhere $ removeFromBlock go
9177 where
9278 go :: [AST] -> [AST]
9379 go [] = []
94− go (VariableIntroduction ss var s'@(Just s) : sts)
95− | not $ any (everything (||) (isUsed var)) (s : sts) = (VariableIntroduction ss unusedName s') : sts
80+ go (VariableIntroduction ss var s@(Just _) : sts)
81+ | not $ any (everything (||) (isUsed var)) sts = (VariableIntroduction ss unusedName s) : sts
9682 go (s:sts) = s : go sts
97−
98−magicDo :: AST -> AST
99−magicDo = magicDo'' C.eff C.effDictionaries
100−
101−magicDo' :: AST -> AST
102−magicDo' = magicDo'' C.effect C.effectDictionaries
103−
104−magicDo'' :: Text -> C.EffectDictionaries -> AST -> AST
105−magicDo'' effectModule C.EffectDictionaries{..} = everywhereTopDown convert
106− where
107− -- Desugar monomorphic calls to >>= and return for the Eff monad
108− convert :: AST -> AST
109− -- Desugar pure
110− convert (App _ (App _ pure' [val]) []) | isPure pure' = val
111− -- Desugar discard
112− convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =
113− Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )
114− -- Desugar bind
115− convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =
116− Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)
117− -- Inline double applications
118− convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
119− App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
120− convert other = other
121−
122− -- Check if an expression represents a monomorphic call to >>= for the Eff monad
123− isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
124− isBind _ = False
125− -- Check if an expression represents a call to @discard@
126− isDiscard (App _ (App _ fn [dict1]) [dict2])
127− | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
128− isDict (effectModule, edBindDict) dict2 &&
129− isDiscardPoly fn = True
130− isDiscard _ = False
131− -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
132− isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
133− isPure _ = False
134− -- Check if an expression represents the polymorphic >>= function
135− isBindPoly = isDict (C.controlBind, C.bind)
136− -- Check if an expression represents the polymorphic pure function
137− isPurePoly = isDict (C.controlApplicative, C.pure')
138− -- Check if an expression represents the polymorphic discard function
139− isDiscardPoly = isDict (C.controlBind, C.discard)
140−
141−
142− applyReturns :: AST -> AST
143− applyReturns (Return ss ret) = Return ss (App ss ret [])
144− applyReturns (Block ss ils) = Block ss (map applyReturns ils)
145− applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
146− applyReturns other = other
147−
148− isDict :: (Text, PSString) -> AST -> Bool
149− isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
150− Just x == decodeString dictName && y == moduleNameToIL' moduleName
151− isDict _ _ = False
src/CodeGen/IL/Optimizer/Common.hsnew file+20
@@ -0,0 +1,20 @@
1+-- | Common functions used by the various optimizer phases
2+module CodeGen.IL.Optimizer.Common where
3+
4+import Prelude.Compat
5+
6+import Data.Text (Text)
7+
8+import Language.PureScript.CoreImp.AST
9+import Language.PureScript.PSString (PSString, decodeString)
10+
11+import CodeGen.IL.Common (moduleNameToIL')
12+
13+isDict :: (Text, PSString) -> AST -> Bool
14+isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
15+ Just x == decodeString dictName && y == moduleNameToIL' moduleName
16+isDict _ _ = False
17+
18+isDict' :: [(Text, PSString)] -> AST -> Bool
19+isDict' xs il = any (`isDict` il) xs
20+
src/CodeGen/IL/Optimizer/Inliner.hsnew file+419
@@ -0,0 +1,419 @@
1+-- | This module performs basic inlining of known functions
2+module CodeGen.IL.Optimizer.Inliner
3+ ( inlineCommonValues
4+ , inlineCommonOperators
5+ -- , inlineFnComposition
6+ , inlineUnsafeCoerce
7+ , inlineUnsafePartial
8+ ) where
9+
10+import Prelude.Compat
11+
12+import Control.Monad.Supply.Class (MonadSupply)
13+
14+import Data.Either (rights)
15+import Data.Maybe (fromMaybe)
16+import Data.String (IsString, fromString)
17+import Data.Text (Text)
18+import qualified Data.Text as T
19+
20+import Language.PureScript.PSString (PSString, decodeString, mkString)
21+import Language.PureScript.CoreImp.AST
22+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict, isDict')
23+import Language.PureScript.AST (SourceSpan(..))
24+import qualified Language.PureScript.Constants as C
25+
26+import CodeGen.IL.Common
27+import CodeGen.IL.Optimizer.Common
28+
29+-- TODO: Potential bug:
30+-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }
31+-- Needs to be: { 0..toFixed(10); }
32+-- Probably needs to be fixed in pretty-printer instead.
33+shouldInline :: AST -> Bool
34+shouldInline (Var _ _) = True
35+shouldInline (NumericLiteral _ _) = True
36+shouldInline (StringLiteral _ _) = True
37+shouldInline (BooleanLiteral _ _) = True
38+shouldInline (Indexer _ index val) = shouldInline index && shouldInline val
39+shouldInline _ = False
40+
41+inlineCommonValues :: AST -> AST
42+inlineCommonValues = everywhere convert
43+ where
44+ convert :: AST -> AST
45+ convert (App ss fn [dict])
46+ | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0)
47+ | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1)
48+ | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False
49+ | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True
50+ convert (App ss (App _ fn [dict]) [x])
51+ | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate x -- (unbox x $ snd ringInt)
52+ convert (App ss (App _ (App _ fn [dict]) [x]) [y])
53+ | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add semiringInt x y
54+ | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply semiringInt x y
55+ | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract ringInt x y
56+ convert other = other
57+ fnZero = (C.dataSemiring, C.zero)
58+ fnOne = (C.dataSemiring, C.one)
59+ fnBottom = (C.dataBounded, C.bottom)
60+ fnTop = (C.dataBounded, C.top)
61+ fnAdd = (C.dataSemiring, C.add)
62+ fnMultiply = (C.dataSemiring, C.mul)
63+ fnSubtract = (C.dataRing, C.sub)
64+ fnNegate = (C.dataRing, C.negate)
65+ intOp ss op (_, d) x y = Binary ss op (unbox x d) (unbox y d)
66+
67+inlineCommonOperators :: AST -> AST
68+inlineCommonOperators = everywhereTopDown $ applyAll $
69+ [ binary semiringNumber opAdd Add
70+ , binary semiringNumber opMul Multiply
71+
72+ , binary ringNumber opSub Subtract
73+ , unary ringNumber opNegate Negate
74+
75+ , binary euclideanRingNumber opDiv Divide
76+
77+ -- , binary eqNumber opEq EqualTo
78+ -- , binary eqNumber opNotEq NotEqualTo
79+ , binary eqInt opEq EqualTo
80+ , binary eqInt opNotEq NotEqualTo
81+ , binary eqString opEq EqualTo
82+ , binary eqString opNotEq NotEqualTo
83+ , binary eqChar opEq EqualTo
84+ , binary eqChar opNotEq NotEqualTo
85+ , binary eqBoolean opEq EqualTo
86+ , binary eqBoolean opNotEq NotEqualTo
87+
88+ , binary ordBoolean opLessThan LessThan
89+ , binary ordBoolean opLessThanOrEq LessThanOrEqualTo
90+ , binary ordBoolean opGreaterThan GreaterThan
91+ , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo
92+ , binary ordChar opLessThan LessThan
93+ , binary ordChar opLessThanOrEq LessThanOrEqualTo
94+ , binary ordChar opGreaterThan GreaterThan
95+ , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo
96+ , binary ordInt opLessThan LessThan
97+ , binary ordInt opLessThanOrEq LessThanOrEqualTo
98+ , binary ordInt opGreaterThan GreaterThan
99+ , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo
100+ , binary ordNumber opLessThan LessThan
101+ , binary ordNumber opLessThanOrEq LessThanOrEqualTo
102+ , binary ordNumber opGreaterThan GreaterThan
103+ , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo
104+ , binary ordString opLessThan LessThan
105+ , binary ordString opLessThanOrEq LessThanOrEqualTo
106+ , binary ordString opGreaterThan GreaterThan
107+ , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo
108+
109+ , binary semigroupString opAppend Add
110+
111+ , binary heytingAlgebraBoolean opConj And
112+ , binary heytingAlgebraBoolean opDisj Or
113+ , unary heytingAlgebraBoolean opNot Not
114+
115+ , binary' C.dataIntBits C.or BitwiseOr
116+ , binary' C.dataIntBits C.and BitwiseAnd
117+ , binary' C.dataIntBits C.xor BitwiseXor
118+ , binary' C.dataIntBits C.shl ShiftLeft
119+ , binary' C.dataIntBits C.shr ShiftRight
120+ , binary' C.dataIntBits C.zshr ZeroFillShiftRight
121+ , unary' C.dataIntBits C.complement BitwiseNot
122+
123+ , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]
124+ , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]
125+ , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)
126+ ] ++
127+ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++
128+ [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++
129+ [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ]
130+ where
131+ binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST
132+ binary dict@(_, d) fns op = convert where
133+ convert :: AST -> AST
134+ convert (App ss (App _ (App _ fn [dict']) [x]) [y])
135+ | isDict dict dict' && isDict fns fn = Binary ss op (unbox x d) (unbox y d)
136+ convert other = other
137+ binary' :: Text -> PSString -> BinaryOperator -> AST -> AST
138+ binary' moduleName opString op = convert where
139+ convert :: AST -> AST
140+ convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x opString) (unbox y opString)
141+ convert other = other
142+ unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST
143+ unary dicts@(_, d) fns op = convert where
144+ convert :: AST -> AST
145+ convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op (unbox x d)
146+ convert other = other
147+ unary' :: Text -> PSString -> UnaryOperator -> AST -> AST
148+ unary' moduleName fnName op = convert where
149+ convert :: AST -> AST
150+ convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op (unbox x fnName)
151+ convert other = other
152+
153+ mkFn :: Int -> AST -> AST
154+ mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args il ->
155+ Function ss1 Nothing args (Block ss2 [Return ss3 il])
156+
157+ mkEffFn :: Text -> Text -> Int -> AST -> AST
158+ mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args il ->
159+ Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 il [])])
160+
161+ mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST
162+ mkFn' modName fnName res 0 = convert where
163+ convert :: AST -> AST
164+ convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 il])]) | isNFn modName fnName 0 mkFnN =
165+ res s1 s2 s3 [] il
166+ convert other = other
167+ mkFn' modName fnName res n = convert where
168+ convert :: AST -> AST
169+ convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN =
170+ case collectArgs n [] fn of
171+ Just (args, [Return ss' ret]) -> res ss ss ss' args ret
172+ _ -> orig
173+ convert other = other
174+ collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])
175+ collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ il)) | length acc == n - 1 = Just (reverse (oneArg : acc), il)
176+ collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
177+ collectArgs _ _ _ = Nothing
178+
179+ isNFn :: Text -> Text -> Int -> AST -> Bool
180+ isNFn expectMod prefix n (Indexer _ (StringLiteral _ name) (Var _ modName)) | modName == expectMod =
181+ name == fromString (T.unpack prefix <> show n)
182+ isNFn _ _ _ _ = False
183+
184+ runFn :: Int -> AST -> AST
185+ runFn = runFn' C.dataFunctionUncurried C.runFn App
186+
187+ runEffFn :: Text -> Text -> Int -> AST -> AST
188+ runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->
189+ Function ss Nothing [] (Block ss [Return ss (App ss fn acc)])
190+
191+ runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST
192+ runFn' modName runFnName res n = convert where
193+ convert :: AST -> AST
194+ convert il = fromMaybe il $ go n [] il
195+
196+ go :: Int -> [AST] -> AST -> Maybe AST
197+ go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n =
198+ Just $ res ss fn acc
199+ go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs
200+ go _ _ _ = Nothing
201+
202+ inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
203+ inlineNonClassFunction p f = convert where
204+ convert :: AST -> AST
205+ convert (App _ (App _ op' [x]) [y]) | p op' = f x y
206+ convert other = other
207+
208+ isModFn :: (Text, PSString) -> AST -> Bool
209+ isModFn (m, op) (Indexer _ (StringLiteral _ op') (Var _ m')) =
210+ m == m' && op == op'
211+ isModFn _ _ = False
212+
213+ isModFnWithDict :: (Text, PSString) -> AST -> Bool
214+ isModFnWithDict (m, op) (App _ (Indexer _ (StringLiteral _ op') (Var _ m')) [Var _ _]) =
215+ m == m' && op == op'
216+ isModFnWithDict _ _ = False
217+
218+-- (f <<< g $ x) = f (g x)
219+-- (f <<< g) = \x -> f (g x)
220+inlineFnComposition :: forall m. MonadSupply m => AST -> m AST
221+inlineFnComposition = everywhereTopDownM convert where
222+ convert :: AST -> m AST
223+ convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])
224+ | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]
225+ | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]
226+ convert app@(App ss (App _ (App _ fn [dict']) _) _)
227+ | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName'
228+ convert other = return other
229+
230+ mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST
231+ mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []
232+ where
233+ vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns
234+ comp = Function ss Nothing [a] (Block ss [Return Nothing apps])
235+ apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns
236+
237+ mkApp :: Either AST (Text, AST) -> AST
238+ mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name
239+
240+ goApps :: AST -> m [Either AST (Text, AST)]
241+ goApps (App _ (App _ (App _ fn [dict']) [x]) [y])
242+ | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y
243+ | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x
244+ goApps app@(App {}) = pure . Right . (,app) <$> freshName'
245+ goApps other = pure [Left other]
246+
247+ isFnCompose :: AST -> AST -> Bool
248+ isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn
249+
250+ isFnComposeFlipped :: AST -> AST -> Bool
251+ isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn
252+
253+ fnCompose :: forall a b. (IsString a, IsString b) => (a, b)
254+ fnCompose = (C.controlSemigroupoid, C.compose)
255+
256+ fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
257+ fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
258+
259+inlineUnsafeCoerce :: AST -> AST
260+inlineUnsafeCoerce = everywhereTopDown convert where
261+ convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
262+ | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
263+ = comp
264+ convert other = other
265+
266+inlineUnsafePartial :: AST -> AST
267+inlineUnsafePartial = everywhereTopDown convert where
268+ convert (App ss (Indexer _ (Var _ unsafePartial) (Var _ partialUnsafe)) [ comp ])
269+ | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe
270+ -- Apply to undefined here, the application should be optimized away
271+ -- if it is safe to do so
272+ = App ss comp [ Var ss undefinedName ]
273+ convert other = other
274+
275+semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)
276+semiringNumber = (C.dataSemiring, C.semiringNumber)
277+
278+semiringInt :: forall a b. (IsString a, IsString b) => (a, b)
279+semiringInt = (C.dataSemiring, C.semiringInt)
280+
281+ringNumber :: forall a b. (IsString a, IsString b) => (a, b)
282+ringNumber = (C.dataRing, C.ringNumber)
283+
284+ringInt :: forall a b. (IsString a, IsString b) => (a, b)
285+ringInt = (C.dataRing, C.ringInt)
286+
287+euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)
288+euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)
289+
290+-- eqNumber :: forall a b. (IsString a, IsString b) => (a, b)
291+-- eqNumber = (C.dataEq, C.eqNumber)
292+
293+eqInt :: forall a b. (IsString a, IsString b) => (a, b)
294+eqInt = (C.dataEq, C.eqInt)
295+
296+eqString :: forall a b. (IsString a, IsString b) => (a, b)
297+eqString = (C.dataEq, C.eqString)
298+
299+eqChar :: forall a b. (IsString a, IsString b) => (a, b)
300+eqChar = (C.dataEq, C.eqChar)
301+
302+eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)
303+eqBoolean = (C.dataEq, C.eqBoolean)
304+
305+ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)
306+ordBoolean = (C.dataOrd, C.ordBoolean)
307+
308+ordNumber :: forall a b. (IsString a, IsString b) => (a, b)
309+ordNumber = (C.dataOrd, C.ordNumber)
310+
311+ordInt :: forall a b. (IsString a, IsString b) => (a, b)
312+ordInt = (C.dataOrd, C.ordInt)
313+
314+ordString :: forall a b. (IsString a, IsString b) => (a, b)
315+ordString = (C.dataOrd, C.ordString)
316+
317+ordChar :: forall a b. (IsString a, IsString b) => (a, b)
318+ordChar = (C.dataOrd, C.ordChar)
319+
320+semigroupString :: forall a b. (IsString a, IsString b) => (a, b)
321+semigroupString = (C.dataSemigroup, C.semigroupString)
322+
323+boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)
324+boundedBoolean = (C.dataBounded, C.boundedBoolean)
325+
326+heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)
327+heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)
328+
329+semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)
330+semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)
331+
332+opAdd :: forall a b. (IsString a, IsString b) => (a, b)
333+opAdd = (C.dataSemiring, C.add)
334+
335+opMul :: forall a b. (IsString a, IsString b) => (a, b)
336+opMul = (C.dataSemiring, C.mul)
337+
338+opEq :: forall a b. (IsString a, IsString b) => (a, b)
339+opEq = (C.dataEq, C.eq)
340+
341+opNotEq :: forall a b. (IsString a, IsString b) => (a, b)
342+opNotEq = (C.dataEq, C.notEq)
343+
344+opLessThan :: forall a b. (IsString a, IsString b) => (a, b)
345+opLessThan = (C.dataOrd, C.lessThan)
346+
347+opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
348+opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)
349+
350+opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)
351+opGreaterThan = (C.dataOrd, C.greaterThan)
352+
353+opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
354+opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)
355+
356+opAppend :: forall a b. (IsString a, IsString b) => (a, b)
357+opAppend = (C.dataSemigroup, C.append)
358+
359+opSub :: forall a b. (IsString a, IsString b) => (a, b)
360+opSub = (C.dataRing, C.sub)
361+
362+opNegate :: forall a b. (IsString a, IsString b) => (a, b)
363+opNegate = (C.dataRing, C.negate)
364+
365+opDiv :: forall a b. (IsString a, IsString b) => (a, b)
366+opDiv = (C.dataEuclideanRing, C.div)
367+
368+opConj :: forall a b. (IsString a, IsString b) => (a, b)
369+opConj = (C.dataHeytingAlgebra, C.conj)
370+
371+opDisj :: forall a b. (IsString a, IsString b) => (a, b)
372+opDisj = (C.dataHeytingAlgebra, C.disj)
373+
374+opNot :: forall a b. (IsString a, IsString b) => (a, b)
375+opNot = (C.dataHeytingAlgebra, C.not)
376+
377+unbox :: AST -> PSString -> AST
378+unbox e d = select . inlineCommonValues $ inlineCommonOperators e
379+ where
380+ select :: AST -> AST
381+ select e' =
382+ case e' of
383+ Var{} -> unbox' e'
384+ App{} -> unbox' e'
385+ Indexer{} -> unbox' e'
386+ _ -> e'
387+ unbox' :: AST -> AST
388+ unbox' e' = maybe e' (\t -> App Nothing (StringLiteral Nothing t) [e']) $ unboxType d
389+
390+unboxType :: PSString -> Maybe PSString
391+unboxType s = do
392+ t <- decodeString s
393+ t' <- unboxType' t
394+ return $ mkString t'
395+ where
396+ unboxType' :: Text -> Maybe Text
397+ unboxType' t
398+ | t == C.eqInt ||
399+ t == C.semiringInt ||
400+ t == C.ringInt ||
401+ t == C.ordInt ||
402+ t == C.dataIntBits
403+ = Just int
404+ | t == C.semiringNumber ||
405+ t == C.ringNumber ||
406+ t == C.ordNumber ||
407+ t == C.euclideanRingNumber
408+ = Just float
409+ | t == C.eqBoolean ||
410+ t == C.ordBoolean ||
411+ t == C.heytingAlgebraBoolean
412+ = Just bool
413+ | t == C.eqChar ||
414+ t == C.eqString ||
415+ t == C.ordChar ||
416+ t == C.ordString ||
417+ t == C.semigroupString
418+ = Just string
419+ | otherwise = Nothing
src/CodeGen/IL/Optimizer/MagicDo.hsnew file+146
@@ -0,0 +1,146 @@
1+-- | This module implements the "Magic Do" optimization, which inlines calls to return
2+-- and bind for the Eff monad, as well as some of its actions.
3+module CodeGen.IL.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where
4+
5+import Prelude.Compat
6+import Protolude (ordNub)
7+
8+import Data.Maybe (fromJust, isJust)
9+import Data.Text (Text)
10+
11+import Language.PureScript.CoreImp.AST
12+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
13+import Language.PureScript.PSString (PSString, decodeString, mkString)
14+import qualified Language.PureScript.Constants as C
15+
16+import CodeGen.IL.Common (moduleNameToIL', undefinedName, unusedName)
17+import CodeGen.IL.Optimizer.Common
18+
19+-- | Inline type class dictionaries for >>= and return for the Eff monad
20+--
21+-- E.g.
22+--
23+-- Prelude[">>="](dict)(m1)(function(x) {
24+-- return ...;
25+-- })
26+--
27+-- becomes
28+--
29+-- function __do {
30+-- var x = m1();
31+-- ...
32+-- }
33+magicDoEff :: AST -> AST
34+magicDoEff = magicDo C.eff C.effDictionaries
35+
36+magicDoEffect :: AST -> AST
37+magicDoEffect = magicDo C.effect C.effectDictionaries
38+
39+magicDoST :: AST -> AST
40+magicDoST = magicDo C.st C.stDictionaries
41+
42+magicDo :: Text -> C.EffectDictionaries -> AST -> AST
43+magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
44+ where
45+ -- Desugar monomorphic calls to >>= and return for the Eff monad
46+ convert :: AST -> AST
47+ -- Desugar pure
48+ convert (App _ (App _ pure' [val]) []) | isPure pure' = val
49+ -- Desugar discard
50+ convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =
51+ Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )
52+ -- Desugar bind
53+ convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =
54+ Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)
55+ -- Desugar untilE
56+ convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =
57+ App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
58+ -- Desugar whileE
59+ convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =
60+ App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
61+ -- -- Inline __do returns
62+ -- convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body
63+ -- Inline double applications
64+ convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
65+ App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
66+ convert other = other
67+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
68+ isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
69+ isBind _ = False
70+ -- Check if an expression represents a call to @discard@
71+ isDiscard (App _ (App _ fn [dict1]) [dict2])
72+ | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
73+ isDict (effectModule, edBindDict) dict2 &&
74+ isDiscardPoly fn = True
75+ isDiscard _ = False
76+
77+ -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
78+ isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
79+ isPure _ = False
80+ -- Check if an expression represents the polymorphic >>= function
81+ isBindPoly = isDict (C.controlBind, C.bind)
82+ -- Check if an expression represents the polymorphic pure function
83+ isPurePoly = isDict (C.controlApplicative, C.pure')
84+ -- Check if an expression represents the polymorphic discard function
85+ isDiscardPoly = isDict (C.controlBind, C.discard)
86+ -- Check if an expression represents a function in the Effect module
87+ isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name'
88+ isEffFunc _ _ = False
89+
90+ applyReturns :: AST -> AST
91+ applyReturns (Return ss ret) = Return ss (App ss ret [])
92+ applyReturns (Block ss ils) = Block ss (map applyReturns ils)
93+ applyReturns (While ss cond il) = While ss cond (applyReturns il)
94+ applyReturns (For ss v lo hi il) = For ss v lo hi (applyReturns il)
95+ applyReturns (ForIn ss v xs il) = ForIn ss v xs (applyReturns il)
96+ applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
97+ applyReturns other = other
98+
99+-- | Inline functions in the ST module
100+inlineST :: AST -> AST
101+inlineST = everywhere 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 (App s1 f [arg]) | isSTFunc C.runST f =
107+ let refs = ordNub . 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 App s1 (everywhere (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 (App s1 f [arg]) | isSTFunc C.newSTRef f =
117+ Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])
118+ convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =
119+ if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref
120+ convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f =
121+ if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg
122+ convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f =
123+ if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref])
124+ convert _ other = other
125+ -- Check if an expression represents a function in the ST module
126+ isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name'
127+ isSTFunc _ _ = False
128+ -- Find all ST Refs initialized in this block
129+ findSTRefsIn = everything (++) isSTRef
130+ where
131+ isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
132+ isSTRef _ = []
133+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
134+ findAllSTUsagesIn = everything (++) isSTUsage
135+ where
136+ isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
137+ isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
138+ isSTUsage _ = []
139+ -- Find all uses of a variable
140+ appearingIn ref = everything (++) isVar
141+ where
142+ isVar e@(Var _ v) | v == ref = [e]
143+ isVar _ = []
144+ -- Convert a AST value to a String if it is a Var
145+ toVar (Var _ v) = Just v
146+ toVar _ = Nothing
src/CodeGen/IL/Printer.hs+119−126
@@ -87,54 +87,77 @@ literals = mkPattern' match'
8787 , prettyPrintIL' val
8888 , return $ emit ")"
8989 ]
90+ match (App _ (StringLiteral _ u) [arg])
91+ | Just ty <- decodeString u = mconcat <$> sequence
92+ [ prettyPrintIL' arg
93+ , return $ emit ".("
94+ , return $ emit ty
95+ , return $ emit ")"
96+ ]
97+ -- match (App _ (StringLiteral _ u) [arg@Var{}])
98+ -- | Just ty <- decodeString u = mconcat <$> sequence
99+ -- [ prettyPrintIL' arg
100+ -- , return $ emit ".("
101+ -- , return $ emit ty
102+ -- , return $ emit ")"
103+ -- ]
104+ -- match (App _ (StringLiteral _ u) [arg])
105+ -- | Just ty <- decodeString u = mconcat <$> sequence
106+ -- [ return $ emit "("
107+ -- , prettyPrintIL' arg
108+ -- , return $ emit ")"
109+ -- , return $ emit ".("
110+ -- , return $ emit ty
111+ -- , return $ emit ")"
112+ -- ]
90113 match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence
91114 [ return $ emit arrayLengthFn
92115 , return $ emit "("
93116 , prettyPrintIL' arg
94117 , return $ emit ")"
95118 ]
96− match (App _ (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y])
97− | fnMod == dictMod
98− , dictMod == C.dataEq || dictMod == C.dataOrd
99− , Just op <- renderOp fn
100− , Just t <- unboxType dict
101− = mconcat <$> sequence
102− [ return $ emit $ unbox' t x
103− , return $ emit op
104− , return $ emit $ unbox' t y
105− ]
106− match (App _ (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y])
107− | not (isLiteral x) && not (isLiteral y)
108− , fnMod == dictMod
109− , dictMod == C.dataSemiring || dictMod == C.dataRing ||
110− dictMod == C.dataEuclideanRing || dictMod == C.dataHeytingAlgebra
111− , Just op <- renderOp fn
112− , Just t <- unboxType dict
113− = mconcat <$> sequence
114− [ return $ emit $ unbox' t x
115− , return $ emit op
116− , return $ emit $ unbox' t y
117− ]
118− match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
119− | fnMod == dictMod
120− , dictMod == C.dataRing
121− , fn == C.negate
122− , Just t <- unboxType dict
123− = mconcat <$> sequence
124− [ return $ emit "-("
125− , return $ emit $ unbox' t n
126− , return $ emit ")"
127− ]
128− match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
129− | fnMod == dictMod
130− , dictMod == C.dataHeytingAlgebra
131− , fn == properToIL C.not
132− , Just t <- unboxType dict
133− = mconcat <$> sequence
134− [ return $ emit "!("
135− , return $ emit $ unbox' t n
136− , return $ emit ")"
137− ]
119+ -- match (App _ (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y])
120+ -- | fnMod == dictMod
121+ -- , dictMod == C.dataEq || dictMod == C.dataOrd
122+ -- , Just op <- renderOp fn
123+ -- , Just t <- unboxType dict
124+ -- = mconcat <$> sequence
125+ -- [ return $ emit $ unbox' t x
126+ -- , return $ emit op
127+ -- , return $ emit $ unbox' t y
128+ -- ]
129+ -- match (App _ (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y])
130+ -- | not (isLiteral x) && not (isLiteral y)
131+ -- , fnMod == dictMod
132+ -- , dictMod == C.dataSemiring || dictMod == C.dataRing ||
133+ -- dictMod == C.dataEuclideanRing || dictMod == C.dataHeytingAlgebra
134+ -- , Just op <- renderOp fn
135+ -- , Just t <- unboxType dict
136+ -- = mconcat <$> sequence
137+ -- [ return $ emit $ unbox' t x
138+ -- , return $ emit op
139+ -- , return $ emit $ unbox' t y
140+ -- ]
141+ -- match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
142+ -- | fnMod == dictMod
143+ -- , dictMod == C.dataRing
144+ -- , fn == C.negate
145+ -- , Just t <- unboxType dict
146+ -- = mconcat <$> sequence
147+ -- [ return $ emit "-("
148+ -- , return $ emit $ unbox' t n
149+ -- , return $ emit ")"
150+ -- ]
151+ -- match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
152+ -- | fnMod == dictMod
153+ -- , dictMod == C.dataHeytingAlgebra
154+ -- , fn == properToIL C.not
155+ -- , Just t <- unboxType dict
156+ -- = mconcat <$> sequence
157+ -- [ return $ emit "!("
158+ -- , return $ emit $ unbox' t n
159+ -- , return $ emit ")"
160+ -- ]
138161 match app@(App{})
139162 | (val, args) <- unApp app []
140163 , length args > 1
@@ -238,53 +261,69 @@ literals = mkPattern' match'
238261 , return $ emit " "
239262 , prettyPrintIL' sts
240263 ]
241− match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses)
242− | (App _ (App _ (App _ (Indexer _ (Var _ _) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y]) <- cond
243− , fnMod == dictMod
244− , dictMod == C.dataEq || dictMod == C.dataOrd
245− , Just _ <- unboxTypeInt dict
246− = mconcat <$> sequence
264+ match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
247265 [ return $ emit "if "
248266 , prettyPrintIL' cond
249267 , return $ emit " "
250268 , prettyPrintIL' thens
251269 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
252270 ]
253− match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
254− [ return $ emit "if "
255− , return $ emit $ unbox' "bool" cond
256− , return $ emit " "
257− , prettyPrintIL' thens
258− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
259− ]
260− match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
271+ match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
261272 [ return $ emit "if !("
262− , return $ emit $ unbox' "bool" cond
273+ , prettyPrintIL' cond
263274 , return $ emit ") "
264275 , prettyPrintIL' thens
265276 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
266277 ]
267− match (IfElse _ (Binary _ EqualTo x y@(NumericLiteral _ n)) thens elses) = mconcat <$> sequence
268− [ return $ emit "if "
269− , return $ emit $ unbox' t x
270− , return $ emit $ " == "
271− , prettyPrintIL' y
272− , return $ emit " "
273− , prettyPrintIL' thens
274− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
275− ]
276− where
277− t | Left _ <- n = int
278− | Right _ <- n = float
279− match (IfElse _ (Binary _ EqualTo a b@StringLiteral{}) thens elses) = mconcat <$> sequence
280− [ return $ emit "if "
281− , return $ emit $ unbox' string a
282− , return $ emit $ " == "
283− , prettyPrintIL' b
284− , return $ emit " "
285− , prettyPrintIL' thens
286− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
287− ]
278+
279+
280+ -- match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses)
281+ -- | (App _ (App _ (App _ (Indexer _ (Var _ _) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y]) <- cond
282+ -- , fnMod == dictMod
283+ -- , dictMod == C.dataEq || dictMod == C.dataOrd
284+ -- , Just _ <- unboxTypeInt dict
285+ -- = mconcat <$> sequence
286+ -- [ return $ emit "if "
287+ -- , prettyPrintIL' cond
288+ -- , return $ emit " "
289+ -- , prettyPrintIL' thens
290+ -- , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
291+ -- ]
292+ -- match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
293+ -- [ return $ emit "if "
294+ -- , prettyPrintIL' (tyAssert cond C.heytingAlgebraBoolean)
295+ -- , return $ emit " "
296+ -- , prettyPrintIL' thens
297+ -- , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
298+ -- ]
299+ -- match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
300+ -- [ return $ emit "if !("
301+ -- , prettyPrintIL' (tyAssert cond C.heytingAlgebraBoolean)
302+ -- , return $ emit ") "
303+ -- , prettyPrintIL' thens
304+ -- , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
305+ -- ]
306+ -- match (IfElse _ (Binary _ EqualTo x y@(NumericLiteral _ n)) thens elses) = mconcat <$> sequence
307+ -- [ return $ emit "if "
308+ -- , return $ emit $ unbox' t x
309+ -- , return $ emit $ " == "
310+ -- , prettyPrintIL' y
311+ -- , return $ emit " "
312+ -- , prettyPrintIL' thens
313+ -- , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
314+ -- ]
315+ -- where
316+ -- t | Left _ <- n = int
317+ -- | Right _ <- n = float
318+ -- match (IfElse _ (Binary _ EqualTo a b@StringLiteral{}) thens elses) = mconcat <$> sequence
319+ -- [ return $ emit "if "
320+ -- , return $ emit $ unbox' string a
321+ -- , return $ emit $ " == "
322+ -- , prettyPrintIL' b
323+ -- , return $ emit " "
324+ -- , prettyPrintIL' thens
325+ -- , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
326+ -- ]
288327 match (IfElse _ cond thens elses) = mconcat <$> sequence
289328 [ return $ emit "if "
290329 , prettyPrintIL' cond
@@ -341,7 +380,7 @@ literals = mkPattern' match'
341380 Nothing -> ""
342381
343382unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
344−unary' op mkStr = Wrap match (const)
383+unary' op mkStr = Wrap match (<>)
345384 where
346385 match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
347386 match = mkPattern match'
@@ -350,7 +389,7 @@ unary' op mkStr = Wrap match (const)
350389 match' _ = Nothing
351390
352391unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
353−unary op str = unary' op (\v -> str <> "(" <> prettyPrintIL1 v <> ")")
392+unary op str = unary' op (const str)
354393
355394negateOperator :: (Emit gen) => Operator PrinterState AST gen
356395negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
@@ -456,52 +495,6 @@ stringLiteral pss | Just s <- decodeString pss = stringLiteral' s
456495 encodeChar c = T.singleton $ c
457496stringLiteral _ = "\"\\uFFFD\""
458497
459−unbox' :: Text -> AST -> Text
460−unbox' _ v@(NumericLiteral{}) = prettyPrintIL1 v
461−unbox' _ v@(BooleanLiteral{}) = prettyPrintIL1 v
462−unbox' _ v@(StringLiteral{}) = prettyPrintIL1 v
463−unbox' t v = "(" <> prettyPrintIL1 v <> ")" <> unbox t -- unbox t <> "(" <> prettyPrintIL1 v <> ")"
464−
465−unboxType :: Text -> Maybe Text
466−unboxType t
467− | t == C.eqInt ||
468− t == C.semiringInt ||
469− t == C.ringInt ||
470− t == C.ordInt
471− = Just int
472− | t == C.semiringNumber ||
473− t == C.ringNumber ||
474− t == C.euclideanRingNumber
475− = Just float
476− | t == C.heytingAlgebraBoolean
477− = Just bool
478− | otherwise = Nothing
479−
480−unboxTypeInt :: Text -> Maybe Text
481−unboxTypeInt t
482− | t == C.eqInt ||
483− t == C.semiringInt ||
484− t == C.ringInt ||
485− t == C.ordInt
486− = Just int
487− | otherwise = Nothing
488−
489−renderOp :: Text -> Maybe Text
490−renderOp op
491− | op == C.eq = Just " == "
492− | op == C.notEq = Just " != "
493− | op == C.lessThan = Just " < "
494− | op == C.lessThanOrEq = Just " <= "
495− | op == C.greaterThan = Just " > "
496− | op == C.greaterThanOrEq = Just " >= "
497− | op == C.add = Just " + "
498− | op == C.sub = Just " - "
499− | op == C.mul = Just " * "
500− | op == C.div = Just " / "
501− | op == C.conj = Just " && "
502− | op == C.disj = Just "|| "
503− | otherwise = Nothing
504−
505498interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
506499interfaceSource _ _ _ = ""
507500