summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-02-08 02:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-02-08 02:29:00 (GMT)
commitde52288120e0cde661aca4c1cbdf794fffded8cb (patch)
tree10a0147f128ff5bff77aa3f1afc6272d4bcbb21a
parent8f515100470cc96ad45ed3473d6d9a257929326a (diff)
version 0.3.10.10.3.10.1
-rw-r--r--libraries/prelude/prelude.purs2
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/CodeGen/Optimize.hs14
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs13
4 files changed, 17 insertions, 14 deletions
diff --git a/libraries/prelude/prelude.purs b/libraries/prelude/prelude.purs
index fec2078..7959f73 100644
--- a/libraries/prelude/prelude.purs
+++ b/libraries/prelude/prelude.purs
@@ -987,6 +987,7 @@ module IORef where
\ return function(f) {\
\ return function() {\
\ ref.value = f(ref.value);\
+ \ return {};\
\ };\
\ };\
\}" :: forall s r. IORef s -> (s -> s) -> Eff (ref :: Ref | r) {}
@@ -995,6 +996,7 @@ module IORef where
\ return function(val) {\
\ return function() {\
\ ref.value = val;\
+ \ return {};\
\ };\
\ };\
\}" :: forall s r. IORef s -> s -> Eff (ref :: Ref | r) {}
diff --git a/purescript.cabal b/purescript.cabal
index a3c3065..7043137 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.3.10
+version: 0.3.10.1
cabal-version: >=1.8
build-type: Simple
license: MIT
diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs
index 4427a4f..368d0c9 100644
--- a/src/Language/PureScript/CodeGen/Optimize.hs
+++ b/src/Language/PureScript/CodeGen/Optimize.hs
@@ -94,14 +94,13 @@ isReassigned var1 = everything (||) (mkQ False check)
where
check :: JS -> Bool
check (JSFunction _ args _) | var1 `elem` args = True
+ check (JSVariableIntroduction arg _) | var1 == arg = True
check _ = False
isRebound :: (Data d) => JS -> d -> Bool
-isRebound js d = any (\var -> isReassigned var d) (variablesOf js)
+isRebound js d = any (\var -> isReassigned var d) (everything (++) (mkQ [] variablesOf) js)
where
variablesOf (JSVar var) = [var]
- variablesOf (JSAccessor _ val) = variablesOf val
- variablesOf (JSIndexer index val) = variablesOf index ++ variablesOf val
variablesOf _ = []
isUsed :: (Data d) => String -> d -> Bool
@@ -163,7 +162,10 @@ etaConvert = everywhere (mkT convert)
where
convert :: JS -> JS
convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
- | all shouldInline args && not (or (map (flip isRebound block) args)) = JSBlock (replaceIdents (zip idents args) body)
+ | all shouldInline args &&
+ not (any (flip isRebound block) (map JSVar idents)) &&
+ not (or (map (flip isRebound block) args))
+ = JSBlock (replaceIdents (zip idents args) body)
convert js = js
unThunk :: JS -> JS
@@ -270,12 +272,10 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
isBind _ = False
isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
isReturn _ = False
- isBindPoly (JSVar op) | op == identToJs (Op ">>=") = True
isBindPoly (JSAccessor prop (JSVar "Prelude")) | prop == identToJs (Op ">>=") = True
isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSVar "Prelude")) = True
isBindPoly _ = False
- isRetPoly (JSVar "ret") = True
- isRetPoly (JSAccessor "ret" (JSVar "Prelude")) = True
+ isRetPoly (JSAccessor "$return" (JSVar "Prelude")) = True
isRetPoly _ = False
prelude = ModuleName (ProperName "Prelude")
effModule = ModuleName (ProperName "Eff")
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index de04561..ff92518 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -36,7 +36,7 @@ import Language.PureScript.Types
-- Replace all sets of mutually-recursive declarations in a module with binding groups
--
createBindingGroupsModule :: [Module] -> Either String [Module]
-createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups ds
+createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups (ModuleName name) ds
-- |
-- Collapse all binding groups in a module to individual declarations
@@ -47,15 +47,15 @@ collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBi
-- |
-- Replace all sets of mutually-recursive declarations with binding groups
--
-createBindingGroups :: [Declaration] -> Either String [Declaration]
-createBindingGroups ds = do
+createBindingGroups :: ModuleName -> [Declaration] -> Either String [Declaration]
+createBindingGroups moduleName ds = do
let values = filter isValueDecl ds
dataDecls = filter isDataDecl ds
allProperNames = map getProperName dataDecls
dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls
dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts
let allIdents = map getIdent values
- valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values
+ valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
return $ filter isImportDecl ds ++
filter isExternDataDecl ds ++
@@ -75,11 +75,12 @@ collapseBindingGroups ds = concatMap go ds
go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds
go other = [other]
-usedIdents :: (Data d) => d -> [Ident]
-usedIdents = nub . everything (++) (mkQ [] names)
+usedIdents :: (Data d) => ModuleName -> d -> [Ident]
+usedIdents moduleName = nub . everything (++) (mkQ [] names)
where
names :: Value -> [Ident]
names (Var (Qualified Nothing name)) = [name]
+ names (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
names _ = []
usedProperNames :: (Data d) => d -> [ProperName]