git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Aggressively inline ST computations when STRefs are only used locally. Inline whileE and untilE.
94fc8d1Phil Freeman
prelude/prelude.purs+17−17
compare with golang
unifiedsplit
@@ -54,11 +54,11 @@ module Prelude where
54 instance Read Boolean where
54 instance Read Boolean where
55 read "true" = true
55 read "true" = true
56 read _ = false
56 read _ = false
57−
57+
58 foreign import readNumber "function readNumber(n) {\
58 foreign import readNumber "function readNumber(n) {\
59 \ return parseInt(n, 10);\
59 \ return parseInt(n, 10);\
60 \}" :: String -> Number
60 \}" :: String -> Number
61−
61+
62 instance Read Number where
62 instance Read Number where
63 read = readNumber
63 read = readNumber
64
64
@@ -369,7 +369,7 @@ module Monoid where
369 instance Monoid String where
369 instance Monoid String where
370 mempty = ""
370 mempty = ""
371 (<>) = (++)
371 (<>) = (++)
372−
372+
373 instance Monoid [a] where
373 instance Monoid [a] where
374 mempty = []
374 mempty = []
375 (<>) = Arrays.concat
375 (<>) = Arrays.concat
@@ -440,11 +440,11 @@ module Maybe where
440
440
441 fromMaybe :: forall a. a -> Maybe a -> a
441 fromMaybe :: forall a. a -> Maybe a -> a
442 fromMaybe a = maybe a (Prelude.id :: forall a. a -> a)
442 fromMaybe a = maybe a (Prelude.id :: forall a. a -> a)
443−
443+
444 instance Prelude.Monad Maybe where
444 instance Prelude.Monad Maybe where
445 return = Just
445 return = Just
446 (>>=) m f = maybe Nothing f m
446 (>>=) m f = maybe Nothing f m
447−
447+
448 instance Prelude.Applicative Maybe where
448 instance Prelude.Applicative Maybe where
449 pure = Just
449 pure = Just
450 (<*>) (Just fn) x = fn <$> x
450 (<*>) (Just fn) x = fn <$> x
@@ -453,7 +453,7 @@ module Maybe where
453 instance Prelude.Functor Maybe where
453 instance Prelude.Functor Maybe where
454 (<$>) fn (Just x) = Just (fn x)
454 (<$>) fn (Just x) = Just (fn x)
455 (<$>) _ _ = Nothing
455 (<$>) _ _ = Nothing
456−
456+
457 instance (Show a) => Prelude.Show (Maybe a) where
457 instance (Show a) => Prelude.Show (Maybe a) where
458 show (Just x) = "Just " ++ (show x)
458 show (Just x) = "Just " ++ (show x)
459 show Nothing = "Nothing"
459 show Nothing = "Nothing"
@@ -467,11 +467,11 @@ module Either where
467 either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
467 either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
468 either f _ (Left a) = f a
468 either f _ (Left a) = f a
469 either _ g (Right b) = g b
469 either _ g (Right b) = g b
470−
470+
471 instance Prelude.Monad (Either e) where
471 instance Prelude.Monad (Either e) where
472 return = Right
472 return = Right
473 (>>=) = either (\e _ -> Left e) (\a f -> f a)
473 (>>=) = either (\e _ -> Left e) (\a f -> f a)
474−
474+
475 instance Prelude.Applicative (Either e) where
475 instance Prelude.Applicative (Either e) where
476 pure = Right
476 pure = Right
477 (<*>) (Left e) _ = Left e
477 (<*>) (Left e) _ = Left e
@@ -480,7 +480,7 @@ module Either where
480 instance Prelude.Functor (Either a) where
480 instance Prelude.Functor (Either a) where
481 (<$>) _ (Left x) = Left x
481 (<$>) _ (Left x) = Left x
482 (<$>) f (Right y) = Right (f y)
482 (<$>) f (Right y) = Right (f y)
483−
483+
484 instance (Show a, Show b) => Prelude.Show (Either a b) where
484 instance (Show a, Show b) => Prelude.Show (Either a b) where
485 show (Left x) = "Left " ++ (show x)
485 show (Left x) = "Left " ++ (show x)
486 show (Right y) = "Right " ++ (show y)
486 show (Right y) = "Right " ++ (show y)
@@ -632,10 +632,10 @@ module Arrays where
632 instance (Prelude.Show a) => Prelude.Show [a] where
632 instance (Prelude.Show a) => Prelude.Show [a] where
633 show [] = "[]"
633 show [] = "[]"
634 show (x:xs) = show x ++ " : " ++ show xs
634 show (x:xs) = show x ++ " : " ++ show xs
635−
635+
636 instance Prelude.Functor [] where
636 instance Prelude.Functor [] where
637 (<$>) = map
637 (<$>) = map
638−
638+
639 instance Prelude.Monad [] where
639 instance Prelude.Monad [] where
640 return = singleton
640 return = singleton
641 (>>=) = concatMap
641 (>>=) = concatMap
@@ -893,7 +893,7 @@ module Math where
893 foreign import tan "function tan(n){\
893 foreign import tan "function tan(n){\
894 \ return Math.tan(n);\
894 \ return Math.tan(n);\
895 \}" :: Number -> Number
895 \}" :: Number -> Number
896−
896+
897 foreign import e "var e = Math.E;" :: Number
897 foreign import e "var e = Math.E;" :: Number
898 foreign import ln2 "var ln2 = Math.LN2;" :: Number
898 foreign import ln2 "var ln2 = Math.LN2;" :: Number
899 foreign import ln10 "var ln10 = Math.LN10;" :: Number
899 foreign import ln10 "var ln10 = Math.LN10;" :: Number
@@ -947,7 +947,7 @@ module Eff where
947 \ return {};\
947 \ return {};\
948 \ };\
948 \ };\
949 \ };\
949 \ };\
950− \}" :: forall e. Eff e Boolean -> Eff e {} -> Eff e {}
950+ \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}
951
951
952 foreign import forE "function forE(lo) {\
952 foreign import forE "function forE(lo) {\
953 \ return function(hi) {\
953 \ return function(hi) {\
@@ -1088,18 +1088,18 @@ module ST where
1088 foreign import modifySTRef "function modifySTRef(ref) {\
1088 foreign import modifySTRef "function modifySTRef(ref) {\
1089 \ return function(f) {\
1089 \ return function(f) {\
1090 \ return function() {\
1090 \ return function() {\
1091− \ ref.value = f(ref.value);\
1091+ \ return ref.value = f(ref.value);\
1092 \ };\
1092 \ };\
1093 \ };\
1093 \ };\
1094− \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) {}
1094+ \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
1095
1095
1096 foreign import writeSTRef "function writeSTRef(ref) {\
1096 foreign import writeSTRef "function writeSTRef(ref) {\
1097 \ return function(a) {\
1097 \ return function(a) {\
1098 \ return function() {\
1098 \ return function() {\
1099− \ ref.value = a;\
1099+ \ return ref.value = a;\
1100 \ };\
1100 \ };\
1101 \ };\
1101 \ };\
1102− \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) {}
1102+ \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
1103
1103
1104 foreign import runST "function runST(f) {\
1104 foreign import runST "function runST(f) {\
1105 \ return f;\
1105 \ return f;\
prelude/tests/Eff.purs+3−4
@@ -46,13 +46,12 @@ test7 _ = do
46
46
47test8 _ = (\_1 _2 -> {}) <$> print "Test" <*> print 8
47test8 _ = (\_1 _2 -> {}) <$> print "Test" <*> print 8
48
48
49−test9 _ = do
49+test9 _ = runST (do
50 r <- newSTRef 1
50 r <- newSTRef 1
51− untilE $ do
51+ whileE (return true) $ do
52 n <- readSTRef r
52 n <- readSTRef r
53 trace $ "Count " ++ show n
53 trace $ "Count " ++ show n
54− modifySTRef r $ (+) 1
54+ modifySTRef r $ (+) 1)
55− return false
56
55
57module Main where
56module Main where
58
57
src/Language/PureScript/CodeGen/Optimize.hs+53−7
@@ -38,7 +38,8 @@ module Language.PureScript.CodeGen.Optimize (
38) where
38) where
39
39
40import Data.Data
40import Data.Data
41−import Data.Maybe (fromMaybe)
41+import Data.List (nub)
42+import Data.Maybe (fromJust, isJust, fromMaybe)
42import Data.Generics
43import Data.Generics
43
44
44import Language.PureScript.Names
45import Language.PureScript.Names
@@ -288,6 +289,12 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
288 -- Desugar >>=
289 -- Desugar >>=
289 convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
290 convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
290 JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
291 JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
292+ -- Desugar untilE
293+ convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =
294+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []
295+ -- Desugar whileE
296+ convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc "whileE" f =
297+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []
291 convert other = other
298 convert other = other
292 -- Check if an expression represents a monomorphic call to >>= for the Eff monad
299 -- Check if an expression represents a monomorphic call to >>= for the Eff monad
293 isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
300 isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
@@ -303,6 +310,9 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
303 isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True
310 isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True
304 isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True
311 isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True
305 isRetPoly _ = False
312 isRetPoly _ = False
313+ -- Check if an expression represents a function in the Ef module
314+ isEffFunc name (JSAccessor name' (JSAccessor "Eff" (JSVar "_ps"))) | name == name' = True
315+ isEffFunc _ _ = False
306 -- Module names
316 -- Module names
307 prelude = ModuleName (ProperName "Prelude")
317 prelude = ModuleName (ProperName "Prelude")
308 effModule = ModuleName (ProperName "Eff")
318 effModule = ModuleName (ProperName "Eff")
@@ -324,20 +334,56 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
324-- Inline functions in the ST module
334-- Inline functions in the ST module
325--
335--
326inlineST :: JS -> JS
336inlineST :: JS -> JS
327−inlineST = everywhere (mkT convert)
337+inlineST = everywhere (mkT convertBlock)
328 where
338 where
339+ -- Look for runST blocks and inline the STRefs there.
340+ -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
341+ -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
342+ convertBlock (JSApp f [arg]) | isSTFunc "runST" f =
343+ let refs = nub . findSTRefsIn $ arg
344+ usages = findAllSTUsagesIn arg
345+ allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
346+ localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
347+ in everywhere (mkT $ if allUsagesAreLocalVars then convertAggressive else convertSafe) arg
348+ convertBlock other = other
349+ -- Convert a block in a safe way, preserving object wrappers of references
329− convert (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =
350+ convertSafe (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =
330 JSObjectLiteral [("value", arg)]
351 JSObjectLiteral [("value", arg)]
331− convert (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =
352+ convertSafe (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =
332 JSAccessor "value" ref
353 JSAccessor "value" ref
333− convert (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =
354+ convertSafe (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =
334 JSAssignment (JSAccessor "value" ref) arg
355 JSAssignment (JSAccessor "value" ref) arg
335− convert (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =
356+ convertSafe (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =
336 JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])
357 JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])
358+ convertSafe other = other
359+ -- Convert a block in a more agressive way, unwrapping object wrappers into local variables
360+ convertAggressive (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f = arg
361+ convertAggressive (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = ref
362+ convertAggressive (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f = JSAssignment ref arg
363+ convertAggressive (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f = JSAssignment ref (JSApp func [ref])
337− convert other = other
364+ convertAggressive other = other
338 -- Check if an expression represents a function in the ST module
365 -- Check if an expression represents a function in the ST module
339 isSTFunc name (JSAccessor name' (JSAccessor "ST" (JSVar "_ps"))) | name == name' = True
366 isSTFunc name (JSAccessor name' (JSAccessor "ST" (JSVar "_ps"))) | name == name' = True
340 isSTFunc _ _ = False
367 isSTFunc _ _ = False
368+ -- Find all ST Refs initialized in this block
369+ findSTRefsIn = everything (++) (mkQ [] isSTRef)
370+ where
371+ isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [arg]) []))) | isSTFunc "newSTRef" f = [ident]
372+ isSTRef _ = []
373+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
374+ findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)
375+ where
376+ isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]
377+ isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]
378+ isSTUsage _ = []
379+ -- Find all uses of a variable
380+ appearingIn ref = everything (++) (mkQ [] isVar)
381+ where
382+ isVar e@(JSVar v) | v == ref = [e]
383+ isVar _ = []
384+ -- Convert a JS value to a String if it is a JSVar
385+ toVar (JSVar v) = Just v
386+ toVar _ = Nothing
341
387
342collapseNestedBlocks :: JS -> JS
388collapseNestedBlocks :: JS -> JS
343collapseNestedBlocks = everywhere (mkT collapse)
389collapseNestedBlocks = everywhere (mkT collapse)