2b217fe · rowtype-yoga/purescript-native

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

on golang help sign in

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

2b217fePhil Freeman13 years ago

examples/shelltest/runAll.test+1−1

compare with golang

unifiedsplit

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

1# 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

3<<<

4>>>

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

libraries/jquery/tests/jquery.purs+1

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

1module Tests where

3+import Eff

3import JQuery

4import JQuery

5test = eff do

6test = eff do

libraries/prelude/Makefile+1−1

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

1all:

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

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

3 cat prelude.js >> all.js

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

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

5import Errors

6import Trace

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

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

9 case {} of

10 _ | n > 10 -> eff do

11 trace "n > 10"

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

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

86 _ -> JSVar . Ident . runProperName $ name

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

88valueToJs 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)

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

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

92valueToJs 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

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

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

146

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

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

148−bindersToJs opts m e binders vals = do

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

149− setNextName $ firstUnusedName (binders, vals)

150 valNames <- replicateM (length vals) fresh

149 valNames <- replicateM (length vals) fresh

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

150 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")])))

153 vals

152 vals

154 where

153 where

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

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

156 go _ done [] Nothing = return done

155 go _ done [] Nothing = return done

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

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

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

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

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

160 binderToJs m e v done'' b

159 binderToJs m e v done'' b

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

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

162

161

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

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

164binderToJs _ _ _ done NullBinder = return done

163binderToJs _ _ _ done NullBinder = return done

165binderToJs _ _ varName done (StringBinder str) =

164binderToJs _ _ 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]

167binderToJs _ _ varName done (NumberBinder num) =

166binderToJs _ _ 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]

169binderToJs _ _ varName done (BooleanBinder True) =

168binderToJs _ _ varName done (BooleanBinder True) =

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

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

171binderToJs _ _ varName done (BooleanBinder False) =

170binderToJs _ _ 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]

173binderToJs _ _ varName done (VarBinder ident) =

172binderToJs _ _ varName done (VarBinder ident) =

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

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

175binderToJs m _ varName done (NullaryBinder ctor) =

174binderToJs 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]

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

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

178 value <- fresh

177 value <- fresh

179 js <- binderToJs m e value done b

178 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]

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

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

182 where

181 where

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

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

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

186 propVar <- fresh

185 propVar <- fresh

187 done'' <- go done' bs'

186 done'' <- go done' bs'

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

187 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)

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

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

191 js <- go done 0 bs

190 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]

193 where

192 where

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

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

195 go done' _ [] = return done'

194 go done' _ [] = return done'

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

197 elVar <- fresh

196 elVar <- fresh

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

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

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

198 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)

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

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

202 headVar <- fresh

201 headVar <- fresh

203 tailVar <- fresh

202 tailVar <- fresh

204 js1 <- binderToJs m e headVar done headBinder

203 js1 <- binderToJs m e headVar done headBinder

205 js2 <- binderToJs m e tailVar js1 tailBinder

204 js2 <- binderToJs m e tailVar js1 tailBinder

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

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

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

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

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

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

209 js2

208 js2

210 )) Nothing]

209 )) Nothing]

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

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

212 js <- binderToJs m e varName done binder

211 js <- binderToJs m e varName done binder

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

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

214

213

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

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

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

215statementToJs 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

19import Control.Monad.State

20import Control.Applicative

21+import Language.PureScript.Names

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])

24−runGen :: Gen a -> a

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

25−runGen = flip evalState 0 . unGen

26+runGen names = flip evalState names . unGen

27−fresh :: Gen String

28+fresh :: Gen Ident

28fresh = do

29fresh = do

29− n <- get

30+ (s:ss) <- get

30− modify (+ 1)

31+ put ss

31− return $ '_' : show n

32+ return s

32−

33−getNextName :: Gen Int

34−getNextName = get

35−

36−setNextName :: Int -> Gen ()

37−setNextName = put

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

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

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

50 where

51 check :: JS -> Bool

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

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

53 check _ = False

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+

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

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

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

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

57 where

65 where

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

80 removeFromBlock js = js

88 removeFromBlock js = js

81 go :: [JS] -> [JS]

89 go :: [JS] -> [JS]

82 go [] = []

90 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)

84 go (s:sts) = s : go sts

92 go (s:sts) = s : go sts

86removeUnusedVariables :: JS -> JS

94removeUnusedVariables :: JS -> JS

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

98etaConvert = everywhere (mkT convert)

106etaConvert = everywhere (mkT convert)

99 where

107 where

100 convert :: JS -> JS

108 convert :: JS -> JS

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

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

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

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

103 convert js = js

111 convert js = js

104

112

105unThunk :: JS -> JS

113unThunk :: JS -> JS

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

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

15module Language.PureScript.Scope (

16 usedNames,

17− unusedNames,

17+ unusedNames

18− firstUnusedName

19) where

18) where

21import Data.Data

20import Data.Data

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

25import Language.PureScript.Values

24import Language.PureScript.Values

26import Language.PureScript.Names

25import Language.PureScript.Names

27import Language.PureScript.CodeGen.JS.AST

26import Language.PureScript.CodeGen.JS.AST

28−import Data.Maybe (mapMaybe)

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

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

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

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

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

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

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

57 in

55 in

58 varNames \\ allNames

56 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