diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.2.9.1 +version: 0.2.9.2 cabal-version: >=1.8 build-type: Simple license: MIT @@ -17,29 +17,45 @@ build-depends: base >=4 && <5, cmdtheline -any, containers -any, directory -any, filepath -any, mtl -any, parsec -any, syb -any, transformers -any, utf8-string -any - exposed-modules: Language.PureScript.Options Data.Generics.Extras - Language.PureScript Language.PureScript.CodeGen - Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS + exposed-modules: Data.Generics.Extras + Language.PureScript.Options + Language.PureScript + Language.PureScript.CodeGen + Language.PureScript.CodeGen.Externs + Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST - Language.PureScript.CodeGen.Monad Language.PureScript.Declarations - Language.PureScript.Kinds Language.PureScript.Names - Language.PureScript.Operators Language.PureScript.Optimize - Language.PureScript.Parser Language.PureScript.Parser.Common + Language.PureScript.CodeGen.Monad + Language.PureScript.CodeGen.Optimize + Language.PureScript.Declarations + Language.PureScript.Kinds + Language.PureScript.Names + Language.PureScript.Operators + Language.PureScript.Parser + Language.PureScript.Parser.Common Language.PureScript.Parser.Declarations - Language.PureScript.Parser.Kinds Language.PureScript.Parser.State - Language.PureScript.Parser.Types Language.PureScript.Parser.Values - Language.PureScript.Pretty Language.PureScript.Pretty.Common - Language.PureScript.Pretty.JS Language.PureScript.Pretty.Kinds - Language.PureScript.Pretty.Types Language.PureScript.Pretty.Values + Language.PureScript.Parser.Kinds + Language.PureScript.Parser.State + Language.PureScript.Parser.Types + Language.PureScript.Parser.Values + Language.PureScript.Pretty + Language.PureScript.Pretty.Common + Language.PureScript.Pretty.JS + Language.PureScript.Pretty.Kinds + Language.PureScript.Pretty.Types + Language.PureScript.Pretty.Values Language.PureScript.TypeChecker Language.PureScript.TypeChecker.Kinds Language.PureScript.TypeChecker.Monad Language.PureScript.TypeChecker.Synonyms - Language.PureScript.TypeChecker.Types Language.PureScript.Types - Language.PureScript.Unknown Language.PureScript.Values Main - Language.PureScript.CaseDeclarations Language.PureScript.DoNotation + Language.PureScript.TypeChecker.Types + Language.PureScript.Types + Language.PureScript.Unknown + Language.PureScript.Values + Language.PureScript.CaseDeclarations + Language.PureScript.DoNotation Language.PureScript.TypeDeclarations - Language.PureScript.BindingGroups Language.PureScript.Scope + Language.PureScript.BindingGroups + Language.PureScript.Scope exposed: True buildable: True hs-source-dirs: src diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -23,7 +23,6 @@ import Language.PureScript.CodeGen as P import Language.PureScript.TypeChecker as P import Language.PureScript.Pretty as P -import Language.PureScript.Optimize as P import Language.PureScript.Operators as P import Language.PureScript.CaseDeclarations as P import Language.PureScript.TypeDeclarations as P diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs --- a/src/Language/PureScript/CodeGen.hs +++ b/src/Language/PureScript/CodeGen.hs @@ -16,3 +16,4 @@ import Language.PureScript.CodeGen.JS as C import Language.PureScript.CodeGen.Externs as C +import Language.PureScript.CodeGen.Optimize as C diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -53,9 +53,24 @@ [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)), setProperty (identToJs ident) (JSVar ident) mp ] ) vals -declToJs _ mp (ExternMemberDeclaration member ident _) _ = - Just [ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]), - setProperty (show ident) (JSVar ident) mp ] +declToJs _ mp (ExternMemberDeclaration member ident ty) _ + | returnsFunction ty = + Just [ JSFunction (Just ident) [Ident "value"] (JSBlock + [ JSReturn $ JSApp (JSAccessor "bind" (JSAccessor member (JSVar (Ident "value")))) [JSVar (Ident "value")] + ]), + setProperty (show ident) (JSVar ident) mp ] + | otherwise = + Just [ JSFunction (Just ident) [Ident "value"] (JSBlock + [ JSReturn $ JSAccessor member (JSVar (Ident "value")) + ]), + setProperty (show ident) (JSVar ident) mp ] + where + returnsFunction (Function _ ret) = isFunction ret + returnsFunction (ForAll _ ty') = returnsFunction ty' + returnsFunction _ = error "Expected function type in declToJs" + isFunction (Function _ _) = True + isFunction (ForAll _ ty') = isFunction ty' + isFunction _ = False declToJs _ mp (DataDeclaration _ _ ctors) _ = Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) -> let diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/CodeGen/Optimize.hs @@ -0,0 +1,198 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Optimize +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.PureScript.CodeGen.Optimize ( + optimize +) where + +import Data.Data +import Data.Maybe (fromMaybe) +import Data.Generics + +import Language.PureScript.Names +import Language.PureScript.CodeGen.JS.AST +import Language.PureScript.Options + +optimize :: Options -> JS -> JS +optimize opts = + collapseNestedBlocks + . tco opts + . removeUnusedVariables + . unThunk + . etaConvert + . inlineVariables + +replaceIdent :: (Data d) => Ident -> JS -> d -> d +replaceIdent var1 js = everywhere (mkT replace) + where + replace (JSVar var2) | var1 == var2 = js + replace other = other + +replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d +replaceIdents vars = everywhere (mkT replace) + where + replace v@(JSVar var) = fromMaybe v $ lookup var vars + replace other = other + +isReassigned :: (Data d) => Ident -> d -> Bool +isReassigned var1 = everything (||) (mkQ False check) + where + check :: JS -> Bool + check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True + check _ = False + +isUsed :: (Data d) => Ident -> d -> Bool +isUsed var1 = everything (||) (mkQ False check) + where + check :: JS -> Bool + check (JSVar var2) | var1 == var2 = True + check (JSAssignment target _) | var1 == targetVariable target = True + check _ = False + targetVariable :: JSAssignment -> Ident + targetVariable (JSAssignVariable var) = var + targetVariable (JSAssignProperty _ tgt) = targetVariable tgt + +shouldInline :: JS -> Bool +shouldInline (JSVar _) = True +shouldInline (JSNumericLiteral _) = True +shouldInline (JSStringLiteral _) = True +shouldInline (JSBooleanLiteral _) = True +shouldInline (JSAccessor _ val) = shouldInline val +shouldInline (JSIndexer index val) = shouldInline index && shouldInline val +shouldInline _ = False + +inlineVariables :: JS -> JS +inlineVariables = everywhere (mkT removeFromBlock) + where + removeFromBlock :: JS -> JS + removeFromBlock (JSBlock sts) = JSBlock (go sts) + removeFromBlock js = js + go :: [JS] -> [JS] + go [] = [] + go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts) + go (s:sts) = s : go sts + +removeUnusedVariables :: JS -> JS +removeUnusedVariables = everywhere (mkT removeFromBlock) + where + removeFromBlock :: JS -> JS + removeFromBlock (JSBlock sts) = JSBlock (go sts) + removeFromBlock js = js + go :: [JS] -> [JS] + go [] = [] + go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts + go (s:sts) = s : go sts + +etaConvert :: JS -> JS +etaConvert = everywhere (mkT convert) + where + convert :: JS -> JS + convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)]) + | all shouldInline args = JSBlock (replaceIdents (zip idents args) body) + convert js = js + +unThunk :: JS -> JS +unThunk = everywhere (mkT convert) + where + convert :: JS -> JS + convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body + convert js = js + +tco :: Options -> JS -> JS +tco opts | optionsTco opts = tco' + | otherwise = id + +tco' :: JS -> JS +tco' = everywhere (mkT convert) + where + tcoLabel :: String + tcoLabel = "tco" + tcoVar :: Ident -> Ident + tcoVar (Ident arg) = Ident $ "__tco_" ++ arg + tcoVar _ = error "Invalid name in tcoVar" + copyVar :: Ident -> Ident + copyVar (Ident arg) = Ident $ "__copy_" ++ arg + copyVar _ = error "Invalid name in copyVar" + convert :: JS -> JS + convert js@(JSVariableIntroduction name (Just fn@(JSFunction Nothing _ _))) = + let + (argss, body', replace) = collectAllFunctionArgs [] id fn + in case () of + _ | isTailCall name body' -> + let + allArgs = reverse $ concat argss + in + JSVariableIntroduction name (Just (replace (toLoop name allArgs body'))) + | otherwise -> js + convert js = js + collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS) + collectAllFunctionArgs allArgs f (JSFunction Nothing args (JSBlock (body@(JSReturn _):_))) = + collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction Nothing (map copyVar args) (JSBlock [b]))) body + collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args (JSBlock [body]))) = + collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction Nothing (map copyVar args) (JSBlock [b])))) body + collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args body@(JSBlock _))) = + (args : allArgs, body, \b -> f (JSReturn (JSFunction Nothing (map copyVar args) b))) + collectAllFunctionArgs allArgs f body = (allArgs, body, f) + isTailCall :: Ident -> JS -> Bool + isTailCall ident js = + let + numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js + numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js + numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js + in + numSelfCalls > 0 + && numSelfCalls == numSelfCallsInTailPosition + && numSelfCallsUnderFunctions == 0 + where + countSelfCalls :: JS -> Int + countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1 + countSelfCalls _ = 0 + countSelfCallsInTailPosition :: JS -> Int + countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1 + countSelfCallsInTailPosition _ = 0 + countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js' + countSelfCallsUnderFunctions _ = 0 + toLoop :: Ident -> [Ident] -> JS -> JS + toLoop ident allArgs js = JSBlock $ + map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++ + [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ] + where + loopify :: JS -> JS + loopify (JSReturn ret) | isSelfCall ident ret = + let + allArgumentValues = concat $ collectSelfCallArgs [] ret + in + JSBlock $ zipWith (\val arg -> + JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs + ++ map (\arg -> + JSAssignment (JSAssignVariable arg) (JSVar (tcoVar arg))) allArgs + ++ [ JSContinue tcoLabel ] + loopify other = other + collectSelfCallArgs :: [[JS]] -> JS -> [[JS]] + collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn + collectSelfCallArgs allArgumentValues _ = allArgumentValues + isSelfCall :: Ident -> JS -> Bool + isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True + isSelfCall ident (JSApp fn _) = isSelfCall ident fn + isSelfCall _ _ = False + +collapseNestedBlocks :: JS -> JS +collapseNestedBlocks = everywhere (mkT collapse) + where + collapse :: JS -> JS + collapse (JSBlock sts) = JSBlock (concatMap go sts) + collapse js = js + go :: JS -> [JS] + go (JSBlock sts) = sts + go s = [s] diff --git a/src/Language/PureScript/Optimize.hs b/src/Language/PureScript/Optimize.hs deleted file mode 100644 --- a/src/Language/PureScript/Optimize.hs +++ /dev/null @@ -1,198 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Optimize --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module Language.PureScript.Optimize ( - optimize -) where - -import Data.Data -import Data.Maybe (fromMaybe) -import Data.Generics - -import Language.PureScript.Names -import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.Options - -optimize :: Options -> JS -> JS -optimize opts = - collapseNestedBlocks - . tco opts - . removeUnusedVariables - . unThunk - . etaConvert - . inlineVariables - -replaceIdent :: (Data d) => Ident -> JS -> d -> d -replaceIdent var1 js = everywhere (mkT replace) - where - replace (JSVar var2) | var1 == var2 = js - replace other = other - -replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d -replaceIdents vars = everywhere (mkT replace) - where - replace v@(JSVar var) = fromMaybe v $ lookup var vars - replace other = other - -isReassigned :: (Data d) => Ident -> d -> Bool -isReassigned var1 = everything (||) (mkQ False check) - where - check :: JS -> Bool - check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True - check _ = False - -isUsed :: (Data d) => Ident -> d -> Bool -isUsed var1 = everything (||) (mkQ False check) - where - check :: JS -> Bool - check (JSVar var2) | var1 == var2 = True - check (JSAssignment target _) | var1 == targetVariable target = True - check _ = False - targetVariable :: JSAssignment -> Ident - targetVariable (JSAssignVariable var) = var - targetVariable (JSAssignProperty _ tgt) = targetVariable tgt - -shouldInline :: JS -> Bool -shouldInline (JSVar _) = True -shouldInline (JSNumericLiteral _) = True -shouldInline (JSStringLiteral _) = True -shouldInline (JSBooleanLiteral _) = True -shouldInline (JSAccessor _ val) = shouldInline val -shouldInline (JSIndexer index val) = shouldInline index && shouldInline val -shouldInline _ = False - -inlineVariables :: JS -> JS -inlineVariables = everywhere (mkT removeFromBlock) - where - removeFromBlock :: JS -> JS - removeFromBlock (JSBlock sts) = JSBlock (go sts) - removeFromBlock js = js - go :: [JS] -> [JS] - go [] = [] - go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts) - go (s:sts) = s : go sts - -removeUnusedVariables :: JS -> JS -removeUnusedVariables = everywhere (mkT removeFromBlock) - where - removeFromBlock :: JS -> JS - removeFromBlock (JSBlock sts) = JSBlock (go sts) - removeFromBlock js = js - go :: [JS] -> [JS] - go [] = [] - go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts - go (s:sts) = s : go sts - -etaConvert :: JS -> JS -etaConvert = everywhere (mkT convert) - where - convert :: JS -> JS - convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)]) - | all shouldInline args = JSBlock (replaceIdents (zip idents args) body) - convert js = js - -unThunk :: JS -> JS -unThunk = everywhere (mkT convert) - where - convert :: JS -> JS - convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body - convert js = js - -tco :: Options -> JS -> JS -tco opts | optionsTco opts = tco' - | otherwise = id - -tco' :: JS -> JS -tco' = everywhere (mkT convert) - where - tcoLabel :: String - tcoLabel = "tco" - tcoVar :: Ident -> Ident - tcoVar (Ident arg) = Ident $ "__tco_" ++ arg - tcoVar _ = error "Invalid name in tcoVar" - copyVar :: Ident -> Ident - copyVar (Ident arg) = Ident $ "__copy_" ++ arg - copyVar _ = error "Invalid name in copyVar" - convert :: JS -> JS - convert js@(JSVariableIntroduction name (Just fn@(JSFunction Nothing _ _))) = - let - (argss, body', replace) = collectAllFunctionArgs [] id fn - in case () of - _ | isTailCall name body' -> - let - allArgs = reverse $ concat argss - in - JSVariableIntroduction name (Just (replace (toLoop name allArgs body'))) - | otherwise -> js - convert js = js - collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS) - collectAllFunctionArgs allArgs f (JSFunction Nothing args (JSBlock (body@(JSReturn _):_))) = - collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction Nothing (map copyVar args) (JSBlock [b]))) body - collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args (JSBlock [body]))) = - collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction Nothing (map copyVar args) (JSBlock [b])))) body - collectAllFunctionArgs allArgs f (JSReturn (JSFunction Nothing args body@(JSBlock _))) = - (args : allArgs, body, \b -> f (JSReturn (JSFunction Nothing (map copyVar args) b))) - collectAllFunctionArgs allArgs f body = (allArgs, body, f) - isTailCall :: Ident -> JS -> Bool - isTailCall ident js = - let - numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js - numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js - numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js - in - numSelfCalls > 0 - && numSelfCalls == numSelfCallsInTailPosition - && numSelfCallsUnderFunctions == 0 - where - countSelfCalls :: JS -> Int - countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1 - countSelfCalls _ = 0 - countSelfCallsInTailPosition :: JS -> Int - countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1 - countSelfCallsInTailPosition _ = 0 - countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js' - countSelfCallsUnderFunctions _ = 0 - toLoop :: Ident -> [Ident] -> JS -> JS - toLoop ident allArgs js = JSBlock $ - map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++ - [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ] - where - loopify :: JS -> JS - loopify (JSReturn ret) | isSelfCall ident ret = - let - allArgumentValues = concat $ collectSelfCallArgs [] ret - in - JSBlock $ zipWith (\val arg -> - JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs - ++ map (\arg -> - JSAssignment (JSAssignVariable arg) (JSVar (tcoVar arg))) allArgs - ++ [ JSContinue tcoLabel ] - loopify other = other - collectSelfCallArgs :: [[JS]] -> JS -> [[JS]] - collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn - collectSelfCallArgs allArgumentValues _ = allArgumentValues - isSelfCall :: Ident -> JS -> Bool - isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True - isSelfCall ident (JSApp fn _) = isSelfCall ident fn - isSelfCall _ _ = False - -collapseNestedBlocks :: JS -> JS -collapseNestedBlocks = everywhere (mkT collapse) - where - collapse :: JS -> JS - collapse (JSBlock sts) = JSBlock (concatMap go sts) - collapse js = js - go :: JS -> [JS] - go (JSBlock sts) = sts - go s = [s]