git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1070 from puffnfresh/optimisation/inline-semigroupoid-arr

Inline semigroupoidArr composition

commit0c811862f369cd87e8db5515db17e3ade1db5840 authorPhil Freeman <paf31@cantab.net> dateWed 22 Apr 2015, 18:41 (12 years ago) parente459633e929327
3 files changed+56−39
compare with golang
unifiedsplit
src/Language/PureScript/CodeGen/JS/AST.hs+30−24 src/Language/PureScript/CodeGen/JS/Optimizer.hs+10−8 src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+16−7
src/Language/PureScript/CodeGen/JS/AST.hs+30−24
@@ -17,7 +17,10 @@
1717
1818module Language.PureScript.CodeGen.JS.AST where
1919
20+import Control.Applicative (Applicative, (<$>), (<*>))
21+import Control.Monad.Identity
2022import Data.Data
23+import Data.Traversable (traverse)
2124
2225import Language.PureScript.Comments
2326
@@ -281,31 +284,34 @@ everywhereOnJS f = go
281284 go other = f other
282285
283286everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
284−everywhereOnJSTopDown f = go . f
287+everywhereOnJSTopDown f = runIdentity . everywhereOnJSTopDownM (Identity . f)
288+
289+everywhereOnJSTopDownM :: (Applicative m, Monad m) => (JS -> m JS) -> JS -> m JS
290+everywhereOnJSTopDownM f = f >=> go
285291 where
286− go :: JS -> JS
287− go (JSUnary op j) = JSUnary op (go (f j))
288− go (JSBinary op j1 j2) = JSBinary op (go (f j1)) (go (f j2))
289− go (JSArrayLiteral js) = JSArrayLiteral (map (go . f) js)
290− go (JSIndexer j1 j2) = JSIndexer (go (f j1)) (go (f j2))
291− go (JSObjectLiteral js) = JSObjectLiteral (map (fmap (go . f)) js)
292− go (JSAccessor prop j) = JSAccessor prop (go (f j))
293− go (JSFunction name args j) = JSFunction name args (go (f j))
294− go (JSApp j js) = JSApp (go (f j)) (map (go . f) js)
295− go (JSConditional j1 j2 j3) = JSConditional (go (f j1)) (go (f j2)) (go (f j3))
296− go (JSBlock js) = JSBlock (map (go . f) js)
297− go (JSVariableIntroduction name j) = JSVariableIntroduction name (fmap (go . f) j)
298− go (JSAssignment j1 j2) = JSAssignment (go (f j1)) (go (f j2))
299− go (JSWhile j1 j2) = JSWhile (go (f j1)) (go (f j2))
300− go (JSFor name j1 j2 j3) = JSFor name (go (f j1)) (go (f j2)) (go (f j3))
301− go (JSForIn name j1 j2) = JSForIn name (go (f j1)) (go (f j2))
302− go (JSIfElse j1 j2 j3) = JSIfElse (go (f j1)) (go (f j2)) (fmap (go . f) j3)
303− go (JSReturn j) = JSReturn (go (f j))
304− go (JSThrow j) = JSThrow (go (f j))
305− go (JSTypeOf j) = JSTypeOf (go (f j))
306− go (JSLabel name j) = JSLabel name (go (f j))
307− go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))
308− go (JSComment com j) = JSComment com (go (f j))
292+ f' = f >=> go
293+ go (JSUnary op j) = JSUnary op <$> f' j
294+ go (JSBinary op j1 j2) = JSBinary op <$> f' j1 <*> f' j2
295+ go (JSArrayLiteral js) = JSArrayLiteral <$> traverse f' js
296+ go (JSIndexer j1 j2) = JSIndexer <$> f' j1 <*> f' j2
297+ go (JSObjectLiteral js) = JSObjectLiteral <$> traverse (traverse f') js
298+ go (JSAccessor prop j) = JSAccessor prop <$> f' j
299+ go (JSFunction name args j) = JSFunction name args <$> f' j
300+ go (JSApp j js) = JSApp <$> f' j <*> traverse f' js
301+ go (JSConditional j1 j2 j3) = JSConditional <$> f' j1 <*> f' j2 <*> f' j3
302+ go (JSBlock js) = JSBlock <$> traverse f' js
303+ go (JSVariableIntroduction name j) = JSVariableIntroduction name <$> traverse f' j
304+ go (JSAssignment j1 j2) = JSAssignment <$> f' j1 <*> f' j2
305+ go (JSWhile j1 j2) = JSWhile <$> f' j1 <*> f' j2
306+ go (JSFor name j1 j2 j3) = JSFor name <$> f' j1 <*> f' j2 <*> f' j3
307+ go (JSForIn name j1 j2) = JSForIn name <$> f' j1 <*> f' j2
308+ go (JSIfElse j1 j2 j3) = JSIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3
309+ go (JSReturn j) = JSReturn <$> f' j
310+ go (JSThrow j) = JSThrow <$> f' j
311+ go (JSTypeOf j) = JSTypeOf <$> f' j
312+ go (JSLabel name j) = JSLabel name <$> f' j
313+ go (JSInstanceOf j1 j2) = JSInstanceOf <$> f' j1 <*> f' j2
314+ go (JSComment com j) = JSComment com <$> f' j
309315 go other = f other
310316
311317everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
src/Language/PureScript/CodeGen/JS/Optimizer.hs+10−8
@@ -37,7 +37,9 @@ module Language.PureScript.CodeGen.JS.Optimizer (
3737 optimize
3838) where
3939
40+import Control.Applicative (Applicative)
4041import Control.Monad.Reader (MonadReader, ask, asks)
42+import Control.Monad.Supply.Class (MonadSupply)
4143
4244import Language.PureScript.CodeGen.JS.AST
4345import Language.PureScript.Options
@@ -53,15 +55,15 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks
5355-- |
5456-- Apply a series of optimizer passes to simplified Javascript code
5557--
56−optimize :: (Monad m, MonadReader (Options mode) m) => JS -> m JS
58+optimize :: (Monad m, MonadReader (Options mode) m, Applicative m, MonadSupply m) => JS -> m JS
5759optimize js = do
5860 noOpt <- asks optionsNoOptimizations
5961 if noOpt then return js else optimize' js
6062
61−optimize' :: (Monad m, MonadReader (Options mode) m) => JS -> m JS
63+optimize' :: (Monad m, MonadReader (Options mode) m, Applicative m, MonadSupply m) => JS -> m JS
6264optimize' js = do
6365 opts <- ask
64− return $ untilFixedPoint (applyAll
66+ untilFixedPoint (inlineArrComposition . applyAll
6567 [ collapseNestedBlocks
6668 , collapseNestedIfs
6769 , tco opts
@@ -77,11 +79,11 @@ optimize' js = do
7779 , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
7880 , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
7981 , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer
80− , inlineCommonOperators
81− , inlineAppliedArrComposition ]) js
82+ , inlineCommonOperators ]) js
8283
83−untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
84+untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
8485untilFixedPoint f = go
8586 where
86− go a = let a' = f a in
87− if a' == a then a' else go a'
87+ go a = do
88+ a' <- f a
89+ if a' == a then return a' else go a'
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+16−7
@@ -18,12 +18,14 @@ module Language.PureScript.CodeGen.JS.Optimizer.Inliner (
1818 inlineValues,
1919 inlineOperator,
2020 inlineCommonOperators,
21− inlineAppliedArrComposition,
21+ inlineArrComposition,
2222 etaConvert,
2323 unThunk,
2424 evaluateIifes
2525) where
2626
27+import Control.Applicative (Applicative)
28+import Control.Monad.Supply.Class (MonadSupply, freshName)
2729import Data.Maybe (fromMaybe)
2830
2931import Language.PureScript.CodeGen.JS.AST
@@ -238,13 +240,20 @@ inlineCommonOperators = applyAll $
238240 go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs
239241 go _ _ _ = Nothing
240242
241−-- (f << g $ x) = f (g x)
242−inlineAppliedArrComposition :: JS -> JS
243−inlineAppliedArrComposition = everywhereOnJS convert
243+-- (f <<< g $ x) = f (g x)
244+-- (f <<< g) = \x -> f (g x)
245+inlineArrComposition :: (Applicative m, MonadSupply m) => JS -> m JS
246+inlineArrComposition = everywhereOnJSTopDownM convert
244247 where
245− convert :: JS -> JS
246− convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) | isDict semigroupoidArr dict' && isPreludeFn (C.<<<) fn = JSApp x [JSApp y [z]]
247− convert other = other
248+ convert :: (MonadSupply m) => JS -> m JS
249+ convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) | isArrCompose dict' fn =
250+ return $ JSApp x [JSApp y [z]]
251+ convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isArrCompose dict' fn = do
252+ arg <- freshName
253+ return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])
254+ convert other = return other
255+ isArrCompose :: JS -> JS -> Bool
256+ isArrCompose dict' fn = isDict semigroupoidArr dict' && isPreludeFn (C.<<<) fn
248257
249258isDict :: (String, String) -> JS -> Bool
250259isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName