0c81186 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #1070 from puffnfresh/optimisation/inline-semigroupoid-arr

0c81186Phil Freeman12 years ago

src/Language/PureScript/CodeGen/JS/AST.hs+30−24

compare with golang

unifiedsplit

@@ -17,7 +17,10 @@

18module Language.PureScript.CodeGen.JS.AST where

20+import Control.Applicative (Applicative, (<$>), (<*>))

21+import Control.Monad.Identity

20import Data.Data

22import Data.Data

23+import Data.Traversable (traverse)

22import Language.PureScript.Comments

25import Language.PureScript.Comments

@@ -281,31 +284,34 @@ everywhereOnJS f = go

281 go other = f other

284 go other = f other

282

285

283everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

286everywhereOnJSTopDown :: (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

285 where

291 where

286− go :: JS -> JS

292+ f' = f >=> go

287− go (JSUnary op j) = JSUnary op (go (f j))

293+ go (JSUnary op j) = JSUnary op <$> f' j

288− go (JSBinary op j1 j2) = JSBinary op (go (f j1)) (go (f j2))

294+ go (JSBinary op j1 j2) = JSBinary op <$> f' j1 <*> f' j2

289− go (JSArrayLiteral js) = JSArrayLiteral (map (go . f) js)

295+ go (JSArrayLiteral js) = JSArrayLiteral <$> traverse f' js

290− go (JSIndexer j1 j2) = JSIndexer (go (f j1)) (go (f j2))

296+ go (JSIndexer j1 j2) = JSIndexer <$> f' j1 <*> f' j2

291− go (JSObjectLiteral js) = JSObjectLiteral (map (fmap (go . f)) js)

297+ go (JSObjectLiteral js) = JSObjectLiteral <$> traverse (traverse f') js

292− go (JSAccessor prop j) = JSAccessor prop (go (f j))

298+ go (JSAccessor prop j) = JSAccessor prop <$> f' j

293− go (JSFunction name args j) = JSFunction name args (go (f j))

299+ go (JSFunction name args j) = JSFunction name args <$> f' j

294− go (JSApp j js) = JSApp (go (f j)) (map (go . f) js)

300+ go (JSApp j js) = JSApp <$> f' j <*> traverse f' js

295− go (JSConditional j1 j2 j3) = JSConditional (go (f j1)) (go (f j2)) (go (f j3))

301+ go (JSConditional j1 j2 j3) = JSConditional <$> f' j1 <*> f' j2 <*> f' j3

296− go (JSBlock js) = JSBlock (map (go . f) js)

302+ go (JSBlock js) = JSBlock <$> traverse f' js

297− go (JSVariableIntroduction name j) = JSVariableIntroduction name (fmap (go . f) j)

303+ go (JSVariableIntroduction name j) = JSVariableIntroduction name <$> traverse f' j

298− go (JSAssignment j1 j2) = JSAssignment (go (f j1)) (go (f j2))

304+ go (JSAssignment j1 j2) = JSAssignment <$> f' j1 <*> f' j2

299− go (JSWhile j1 j2) = JSWhile (go (f j1)) (go (f j2))

305+ go (JSWhile j1 j2) = JSWhile <$> f' j1 <*> f' j2

300− go (JSFor name j1 j2 j3) = JSFor name (go (f j1)) (go (f j2)) (go (f j3))

306+ go (JSFor name j1 j2 j3) = JSFor name <$> f' j1 <*> f' j2 <*> f' j3

301− go (JSForIn name j1 j2) = JSForIn name (go (f j1)) (go (f j2))

307+ go (JSForIn name j1 j2) = JSForIn name <$> f' j1 <*> f' j2

302− go (JSIfElse j1 j2 j3) = JSIfElse (go (f j1)) (go (f j2)) (fmap (go . f) j3)

308+ go (JSIfElse j1 j2 j3) = JSIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3

303− go (JSReturn j) = JSReturn (go (f j))

309+ go (JSReturn j) = JSReturn <$> f' j

304− go (JSThrow j) = JSThrow (go (f j))

310+ go (JSThrow j) = JSThrow <$> f' j

305− go (JSTypeOf j) = JSTypeOf (go (f j))

311+ go (JSTypeOf j) = JSTypeOf <$> f' j

306− go (JSLabel name j) = JSLabel name (go (f j))

312+ go (JSLabel name j) = JSLabel name <$> f' j

307− go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))

313+ go (JSInstanceOf j1 j2) = JSInstanceOf <$> f' j1 <*> f' j2

308− go (JSComment com j) = JSComment com (go (f j))

314+ go (JSComment com j) = JSComment com <$> f' j

309 go other = f other

315 go other = f other

310

316

311everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r

317everythingOnJS :: (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 (

37 optimize

38) where

40+import Control.Applicative (Applicative)

40import Control.Monad.Reader (MonadReader, ask, asks)

41import Control.Monad.Reader (MonadReader, ask, asks)

42+import Control.Monad.Supply.Class (MonadSupply)

42import Language.PureScript.CodeGen.JS.AST

44import Language.PureScript.CodeGen.JS.AST

43import Language.PureScript.Options

45import Language.PureScript.Options

@@ -53,15 +55,15 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks

53-- |

55-- |

54-- Apply a series of optimizer passes to simplified Javascript code

56-- Apply a series of optimizer passes to simplified Javascript code

55--

57--

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

57optimize js = do

59optimize js = do

58 noOpt <- asks optionsNoOptimizations

60 noOpt <- asks optionsNoOptimizations

59 if noOpt then return js else optimize' js

61 if noOpt then return js else optimize' js

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

62optimize' js = do

64optimize' js = do

63 opts <- ask

65 opts <- ask

64− return $ untilFixedPoint (applyAll

66+ untilFixedPoint (inlineArrComposition . applyAll

65 [ collapseNestedBlocks

67 [ collapseNestedBlocks

66 , collapseNestedIfs

68 , collapseNestedIfs

67 , tco opts

69 , tco opts

@@ -77,11 +79,11 @@ optimize' js = do

77 , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]

79 , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]

78 , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

80 , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

79 , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer

81 , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer

80− , inlineCommonOperators

82+ , inlineCommonOperators ]) js

81− , inlineAppliedArrComposition ]) js

83−untilFixedPoint :: (Eq a) => (a -> a) -> a -> a

84+untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a

84untilFixedPoint f = go

85untilFixedPoint f = go

85 where

86 where

87+ go a = do

86− go a = let a' = f a in

88+ a' <- f a

87− if a' == a then a' else go 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 (

18 inlineValues,

19 inlineOperator,

20 inlineCommonOperators,

21− inlineAppliedArrComposition,

21+ inlineArrComposition,

22 etaConvert,

23 unThunk,

24 evaluateIifes

25) where

27+import Control.Applicative (Applicative)

28+import Control.Monad.Supply.Class (MonadSupply, freshName)

27import Data.Maybe (fromMaybe)

29import Data.Maybe (fromMaybe)

29import Language.PureScript.CodeGen.JS.AST

31import Language.PureScript.CodeGen.JS.AST

@@ -238,13 +240,20 @@ inlineCommonOperators = applyAll $

238 go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs

240 go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs

239 go _ _ _ = Nothing

241 go _ _ _ = Nothing

240

242

241−-- (f << g $ x) = f (g x)

243+-- (f <<< g $ x) = f (g x)

242−inlineAppliedArrComposition :: JS -> JS

244+-- (f <<< g) = \x -> f (g x)

243−inlineAppliedArrComposition = everywhereOnJS convert

245+inlineArrComposition :: (Applicative m, MonadSupply m) => JS -> m JS

246+inlineArrComposition = everywhereOnJSTopDownM convert

244 where

247 where

245− convert :: JS -> JS

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

246− convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) | isDict semigroupoidArr dict' && isPreludeFn (C.<<<) fn = JSApp x [JSApp y [z]]

256+ isArrCompose dict' fn = isDict semigroupoidArr dict' && isPreludeFn (C.<<<) fn

247− convert other = other

248

257

249isDict :: (String, String) -> JS -> Bool

258isDict :: (String, String) -> JS -> Bool

250isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName

259isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName