2b217fe · rowtype-yoga/purescript-native

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

Fix some bugs, including an issue with overenthusiastic inlining of variables.

commit2b217fe06659823713a1c6466a6cc099d791c037 authorPhil Freeman <paf31@cantab.net> dateFri 10 Jan 2014, 17:20 (13 years ago) parent5564d57

8 files changed+45−61

compare with golang

unifiedsplit

examples/shelltest/runAll.test+1−1 libraries/jquery/tests/jquery.purs+1 libraries/prelude/Makefile+1−1 libraries/prelude/tests/Eff.purs+1−1 src/Language/PureScript/CodeGen/JS.hs+20−21 src/Language/PureScript/CodeGen/Monad.hs+8−13 src/Language/PureScript/CodeGen/Optimize.hs+12−4 src/Language/PureScript/Scope.hs+1−20

examples/shelltest/runAll.test+1−1

@@ -1,5 +1,5 @@

11# Maybe

2−mkdir -p tests && ../../dist/build/psc/psc ../passing/Maybe.purs -o tests/Maybe.js && cat tests/Maybe.js Maybe.js | nodejs

2+mkdir -p tests && ../../dist/build/psc/psc --no-prelude ../passing/Maybe.purs -o tests/Maybe.js && cat tests/Maybe.js Maybe.js | nodejs

33<<<

44>>>

55{ ctor: 'Maybe.Just', value: 'ab' }

libraries/jquery/tests/jquery.purs+1

@@ -1,5 +1,6 @@

11module Tests where

3+import Eff

34import JQuery

56test = eff do

libraries/prelude/Makefile+1−1

@@ -1,3 +1,3 @@

11all:

2− ../../dist/build/psc/psc prelude.purs -o all.js

2+ ../../dist/build/psc/psc --no-prelude prelude.purs -o all.js

33 cat prelude.js >> all.js

libraries/prelude/tests/Eff.purs+1−1

@@ -5,7 +5,7 @@ import Eff

55import Errors

66import Trace

8−test = \n -> catchError (\s -> eff do return 0) $ eff do

8+test n = catchError (\s -> eff do return 0) $ eff do

99 case {} of

1010 _ | n > 10 -> eff do

1111 trace "n > 10"

src/Language/PureScript/CodeGen/JS.hs+20−21

@@ -86,7 +86,7 @@ valueToJs _ m e (Constructor (Qualified Nothing name)) =

8686 _ -> JSVar . Ident . runProperName $ name

8787valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name

8888valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) []

89−valueToJs opts m e (Case values binders) = runGen (bindersToJs opts m e binders (map (valueToJs opts m e) values))

89+valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)

9090valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)

9191valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)

9292valueToJs opts m e (Indexer index val) = JSIndexer (valueToJs opts m e index) (valueToJs opts m e val)

@@ -144,15 +144,14 @@ qualifiedToJS :: (a -> String) -> Qualified a -> JS

144144qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))

145145qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))

146146

147−bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS

148−bindersToJs opts m e binders vals = do

149− setNextName $ firstUnusedName (binders, vals)

147+bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> JS

148+bindersToJs opts m e binders vals = runGen (unusedNames (binders, vals)) $ do

150149 valNames <- replicateM (length vals) fresh

151150 jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m e result)] bs grd

152− return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

151+ return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

153152 vals

154153 where

155− go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]

154+ go :: [Ident] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]

156155 go _ done [] Nothing = return done

157156 go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]

158157 go (v:vs) done' (b:bs) grd = do

@@ -160,24 +159,24 @@ bindersToJs opts m e binders vals = do

160159 binderToJs m e v done'' b

161160 go _ _ _ _ = error "Invalid arguments to bindersToJs"

162161

163−binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]

162+binderToJs :: ModuleName -> Environment -> Ident -> [JS] -> Binder -> Gen [JS]

164163binderToJs _ _ _ done NullBinder = return done

165164binderToJs _ _ varName done (StringBinder str) =

166− return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]

165+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]

167166binderToJs _ _ varName done (NumberBinder num) =

168− return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]

167+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]

169168binderToJs _ _ varName done (BooleanBinder True) =

170− return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]

169+ return [JSIfElse (JSVar varName) (JSBlock done) Nothing]

171170binderToJs _ _ varName done (BooleanBinder False) =

172− return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]

171+ return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

173172binderToJs _ _ varName done (VarBinder ident) =

174− return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)

173+ return (JSVariableIntroduction ident (Just (JSVar varName)) : done)

175174binderToJs m _ varName done (NullaryBinder ctor) =

176− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]

175+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]

177176binderToJs m e varName done (UnaryBinder ctor b) = do

178177 value <- fresh

179178 js <- binderToJs m e value done b

180− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock (JSVariableIntroduction (Ident value) (Just (JSAccessor "value" (JSVar (Ident varName)))) : js)) Nothing]

179+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)) Nothing]

181180binderToJs m e varName done (ObjectBinder bs) = go done bs

182181 where

183182 go :: [JS] -> [(String, Binder)] -> Gen [JS]

@@ -186,10 +185,10 @@ binderToJs m e varName done (ObjectBinder bs) = go done bs

186185 propVar <- fresh

187186 done'' <- go done' bs'

188187 js <- binderToJs m e propVar done'' binder

189− return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js)

188+ return (JSVariableIntroduction propVar (Just (JSAccessor prop (JSVar varName))) : js)

190189binderToJs m e varName done (ArrayBinder bs) = do

191190 js <- go done 0 bs

192− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

191+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

193192 where

194193 go :: [JS] -> Integer -> [Binder] -> Gen [JS]

195194 go done' _ [] = return done'

@@ -197,20 +196,20 @@ binderToJs m e varName done (ArrayBinder bs) = do

197196 elVar <- fresh

198197 done'' <- go done' (index + 1) bs'

199198 js <- binderToJs m e elVar done'' binder

200− return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js)

199+ return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)

201200binderToJs m e varName done (ConsBinder headBinder tailBinder) = do

202201 headVar <- fresh

203202 tailVar <- fresh

204203 js1 <- binderToJs m e headVar done headBinder

205204 js2 <- binderToJs m e tailVar js1 tailBinder

206− return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left 0))) (JSBlock

207− ( JSVariableIntroduction (Ident headVar) (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar (Ident varName)))) :

208− JSVariableIntroduction (Ident tailVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left 1)])) :

205+ return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock

206+ ( JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar varName))) :

207+ JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left 1)])) :

209208 js2

210209 )) Nothing]

211210binderToJs m e varName done (NamedBinder ident binder) = do

212211 js <- binderToJs m e varName done binder

213− return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)

212+ return (JSVariableIntroduction ident (Just (JSVar varName)) : js)

214213

215214statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS

216215statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))

src/Language/PureScript/CodeGen/Monad.hs+8−13

@@ -18,20 +18,15 @@ module Language.PureScript.CodeGen.Monad where

1818

1919import Control.Monad.State

2020import Control.Applicative

21+import Language.PureScript.Names

2122

22−newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int, MonadFix)

23+newtype Gen a = Gen { unGen :: State [Ident] a } deriving (Functor, Applicative, Monad, MonadState [Ident])

2324

24−runGen :: Gen a -> a

25−runGen = flip evalState 0 . unGen

25+runGen :: [Ident] -> Gen a -> a

26+runGen names = flip evalState names . unGen

2627

27−fresh :: Gen String

28+fresh :: Gen Ident

2829fresh = do

29− n <- get

30− modify (+ 1)

31− return $ '_' : show n

32−

33−getNextName :: Gen Int

34−getNextName = get

35−

36−setNextName :: Int -> Gen ()

37−setNextName = put

30+ (s:ss) <- get

31+ put ss

32+ return s

src/Language/PureScript/CodeGen/Optimize.hs+12−4

@@ -49,9 +49,17 @@ isReassigned :: (Data d) => Ident -> d -> Bool

4949isReassigned var1 = everything (||) (mkQ False check)

5050 where

5151 check :: JS -> Bool

52− check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True

52+ check (JSFunction _ args _) | var1 `elem` args = True

5353 check _ = False

5454

55+isRebound :: (Data d) => JS -> d -> Bool

56+isRebound (JSVar var1) = everything (||) (mkQ False check)

57+ where

58+ check :: JS -> Bool

59+ check (JSFunction _ args _) | var1 `elem` args = True

60+ check _ = False

61+isRebound _ = const False

62+

5563isUsed :: (Data d) => Ident -> d -> Bool

5664isUsed var1 = everything (||) (mkQ False check)

5765 where

@@ -80,7 +88,7 @@ inlineVariables = everywhere (mkT removeFromBlock)

8088 removeFromBlock js = js

8189 go :: [JS] -> [JS]

8290 go [] = []

83− go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)

91+ go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) = go (replaceIdent var js sts)

8492 go (s:sts) = s : go sts

8593

8694removeUnusedVariables :: JS -> JS

@@ -98,8 +106,8 @@ etaConvert :: JS -> JS

98106etaConvert = everywhere (mkT convert)

99107 where

100108 convert :: JS -> JS

101− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])

102− | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)

109+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])

110+ | all shouldInline args && not (or (map (flip isRebound block) args)) = JSBlock (replaceIdents (zip idents args) body)

103111 convert js = js

104112

105113unThunk :: JS -> JS

src/Language/PureScript/Scope.hs+1−20

@@ -14,8 +14,7 @@

1414

1515module Language.PureScript.Scope (

1616 usedNames,

17− unusedNames,

18− firstUnusedName

17+ unusedNames

1918) where

2019

2120import Data.Data

@@ -25,7 +24,6 @@ import Data.Generics (extQ, mkQ, everything)

2524import Language.PureScript.Values

2625import Language.PureScript.Names

2726import Language.PureScript.CodeGen.JS.AST

28−import Data.Maybe (mapMaybe)

2927

3028usedNames :: (Data d) => d -> [Ident]

3129usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val

@@ -56,20 +54,3 @@ unusedNames val =

5654 varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])

5755 in

5856 varNames \\ allNames

59−

60−firstUnusedName :: (Data d) => d -> Int

61−firstUnusedName val =

62− let

63− allNames = usedNames val

64− varNames = mapMaybe toUnknown allNames

65− in

66− 1 + maximum (0 : varNames)

67− where

68− toUnknown :: Ident -> Maybe Int

69− toUnknown (Ident ('_' : s)) = readMaybe s

70− toUnknown _ = Nothing

71−

72−readMaybe :: String -> Maybe Int

73−readMaybe s = case reads s of

74− [(n, "")] -> Just n

75− _ -> Nothing