diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index a2bcea0af5..49735266a9 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -31,6 +31,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. +- [@jutaro](https://github.com/jutaro) (Jürgen Nicklisch-Franken) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@kika](https://github.com/kika) (Kirill Pertsev) - My existing contributions and all future contributions until further notice are Copyright Kirill Pertsev, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 5e214847d6..3e0a9cd431 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -8,6 +8,7 @@ module Main (main) where import Data.Traversable (for) import Data.Version (showVersion) +import Data.Maybe (fromMaybe) import Control.Applicative import Control.Monad @@ -35,6 +36,7 @@ data Options = Options , optionsEntryPoints :: [String] , optionsMainModule :: Maybe String , optionsNamespace :: String + , optionsShouldUncurry :: Maybe Bool } deriving Show -- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier. @@ -60,8 +62,7 @@ app Options{..} = do length js `seq` return (mid, js) -- evaluate readFile till EOF before returning, not to exhaust file handles let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints - - bundle input entryIds optionsMainModule optionsNamespace + bundle input entryIds optionsMainModule optionsNamespace (fromMaybe False optionsShouldUncurry) -- | Command line options parser. options :: Parser Options @@ -70,6 +71,7 @@ options = Options <$> some inputFile <*> many entryPoint <*> optional mainModule <*> namespace + <*> (optional (not <$> noShouldUncurry) <|> optional shouldUncurry) where inputFile :: Parser FilePath inputFile = strArgument $ @@ -101,6 +103,18 @@ options = Options <$> some inputFile <> showDefault <> help "Specify the namespace that PureScript modules will be exported to when running in the browser." + + shouldUncurry :: Parser Bool + shouldUncurry = switch $ + short 'O' + <> long "optimize" + <> help "When given this option psc-bundle will apply an uncurry optimization" + + noShouldUncurry :: Parser Bool + noShouldUncurry = switch $ + long "no-optimize" + <> help "When given this option psc-bundle will prevent the uncurry optimization" + -- | Make it go. main :: IO () main = do diff --git a/psc-bundle/README.md b/psc-bundle/README.md index 98cd541c17..5e34f6a6d9 100644 --- a/psc-bundle/README.md +++ b/psc-bundle/README.md @@ -4,14 +4,15 @@ A dead code elimination tool for PureScript-style CommonJS modules. This can be ## Usage - psc-bundle FILE (-m|--module ARG) [--main ARG] [--namespace ARG] - + psc-bundle FILE (-m|--module ARG) [--main ARG] [--namespace ARG] [--optimize] + Options: - The input .js file(s) - Entry point module name(s) are specified with `-m` or `--module`. All code which is not a transitive dependency of an entry point module will be removed. - The main module is (optionally) specified using `--main`. If specified, this will generate code to run the main method in the specified module. - The browser namespace defaults to `PS`, and can be overridden with `--namespace`. +- The uncurry optimization option is off by default. It can be explicitly enabled with `-O` or `--optimize` and disabled with `--no-optimize`. For example, to bundle the modules in the `output` directory, with main module `Main`: diff --git a/purescript.cabal b/purescript.cabal index c9d20b237c..a0dcbb74f9 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -141,6 +141,8 @@ library Language.PureScript.AST.Traversals Language.PureScript.AST.Exported Language.PureScript.Bundle + Language.PureScript.BundleTypes + Language.PureScript.BundleOpt Language.PureScript.Crash Language.PureScript.Externs Language.PureScript.CodeGen diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index e3fbe0851f..e038483d11 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -1,33 +1,49 @@ --- | +----------------------------------------------------------------------------- +-- +-- Module : psc-bundle +-- Copyright : (c) Phil Freeman 2015 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- -- Bundles compiled PureScript modules for the browser. -- -- This module takes as input the individual generated modules from 'Language.PureScript.Make' and -- performs dead code elimination, filters empty modules, -- and generates the final Javascript bundle. -module Language.PureScript.Bundle - ( bundle - , ModuleIdentifier(..) - , moduleName - , ModuleType(..) - , ErrorMessage(..) - , printErrorMessage - , getExportedIdentifiers - ) where +----------------------------------------------------------------------------- -import Prelude.Compat -import Control.Monad -import Control.Monad.Error.Class +module Language.PureScript.Bundle ( + bundle + , ModuleIdentifier(..) + , moduleName + , ModuleType(..) + , ErrorMessage(..) + , printErrorMessage + , getExportedIdentifiers +) where + +import Prelude.Compat -import Data.Generics (everything, everywhere, mkQ, mkT) -import Data.Graph import Data.List (nub, stripPrefix) import Data.Maybe (mapMaybe, catMaybes) +import Data.Generics (everything, everywhere, mkQ, mkT) +import Data.Graph import Data.Version (showVersion) + import qualified Data.Set as S +import Control.Monad +import Control.Monad.Error.Class +import Language.JavaScript.Parser.AST hiding (showStripped) import Language.JavaScript.Parser -import Language.JavaScript.Parser.AST +import Language.PureScript.BundleOpt +import Language.PureScript.BundleTypes + +-- import Debug.Trace import qualified Paths_purescript as Paths @@ -41,54 +57,6 @@ data ErrorMessage | ErrorInModule ModuleIdentifier ErrorMessage deriving (Show, Read) --- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules. -data ModuleType - = Regular - | Foreign - deriving (Show, Read, Eq, Ord) - -showModuleType :: ModuleType -> String -showModuleType Regular = "Regular" -showModuleType Foreign = "Foreign" - --- | A module is identified by its module name and its type. -data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read, Eq, Ord) - -moduleName :: ModuleIdentifier -> String -moduleName (ModuleIdentifier name _) = name - --- | A piece of code is identified by its module and its name. These keys are used to label vertices --- in the dependency graph. -type Key = (ModuleIdentifier, String) - --- | An export is either a "regular export", which exports a name from the regular module we are in, --- or a reexport of a declaration in the corresponding foreign module. --- --- Regular exports are labelled, since they might re-export an operator with another name. -data ExportType - = RegularExport String - | ForeignReexport - deriving (Show, Eq, Ord) - --- | There are four types of module element we are interested in: --- --- 1) Require statements --- 2) Member declarations --- 3) Export lists --- 4) Everything else --- --- Each is labelled with the original AST node which generated it, so that we can dump it back --- into the output during codegen. -data ModuleElement - = Require JSStatement String (Either String ModuleIdentifier) - | Member JSStatement Bool String JSExpression [Key] - | ExportsList [(ExportType, String, JSExpression, [Key])] - | Other JSStatement - deriving (Show) - --- | A module is just a list of elements of the types listed above. -data Module = Module ModuleIdentifier [ModuleElement] deriving (Show) - -- | Prepare an error message for consumption by humans. printErrorMessage :: ErrorMessage -> [String] printErrorMessage (UnsupportedModulePath s) = @@ -567,13 +535,14 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p -- | The bundling function. -- This function performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. -bundle :: (MonadError ErrorMessage m) - => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. - -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination - -> Maybe String -- ^ An optional main module. - -> String -- ^ The namespace (e.g. PS). - -> m String -bundle inputStrs entryPoints mainModule namespace = do +bundle :: (Applicative m, MonadError ErrorMessage m) + => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. + -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination + -> Maybe String -- ^ An optional main + -> String -- ^ The namespace (e.g. PS). + -> Bool + -> m String +bundle inputStrs entryPoints mainModule namespace shouldUncurry = do input <- forM inputStrs $ \(ident, js) -> do ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident) return (ident, ast) @@ -583,6 +552,20 @@ bundle inputStrs entryPoints mainModule namespace = do modules <- traverse (fmap withDeps . uncurry (toModule mids)) input let compiled = compile modules entryPoints - sorted = sortModules (filter (not . isModuleEmpty) compiled) + + -- The uncurry optimization performs dead code elemination (DCE) once and then + -- generates uncurried variants of the surviving functions. We need to + -- perform DCE again to throw away variants (curried or uncurried) that + -- aren't called after choosing the appropriate variant for each call site. + -- This two-step process avoids generating variants for functions that + -- are dead weight anyway. + compiled' <- if shouldUncurry + then do + let modules' = uncurryFunc compiled entryPoints + modules'' <- traverse (fmap withDeps . pure) modules' -- traverse and compile again + return (compile modules'' entryPoints) + else return compiled + + let sorted = sortModules (filter (not . isModuleEmpty) compiled') return (codeGen mainModule namespace sorted) diff --git a/src/Language/PureScript/BundleOpt.hs b/src/Language/PureScript/BundleOpt.hs new file mode 100644 index 0000000000..d89124a2b4 --- /dev/null +++ b/src/Language/PureScript/BundleOpt.hs @@ -0,0 +1,475 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.BundleOpt +-- Copyright : (c) Jürgen Nicklisch-Franken 2016 +-- License : MIT +-- +-- Maintainer : Jürgen Nicklisch +-- Stability : experimental +-- Portability : +-- +-- | Optimize steps added to the bundle process for purescript. +-- +-- This module takes as input the Javascript AST and applies optimizations like +-- uncurrying and inlining +----------------------------------------------------------------------------- + +{-# LANGUAGE PatternGuards #-} + +module Language.PureScript.BundleOpt ( + uncurryFunc +) where + +import Prelude.Compat +import qualified Data.Map as M +import Data.Maybe (mapMaybe) + +import Language.PureScript.BundleTypes +import Language.JavaScript.Parser +import Language.JavaScript.Parser.AST + + +-- * Types + +data FuncAdmin = FuncAdmin + { moduleId :: ModuleIdentifier + , arity :: Int + , exported :: Bool} + deriving (Eq,Show) + +type FuncAdminMap = M.Map String [FuncAdmin] + +data FuncStats = FuncStats { + moduleCount :: Int, + moduleFunctions :: Int, + uncurriedFuncs :: Int, + exportedEntities :: Int, + uncurriedFuncsExported :: Int, + exportedForeignEntities :: Int, + uncurriedForeignFuncsExported :: Int +} deriving (Eq,Show) + +data FuncCollector = FuncCollector { + adminMap :: FuncAdminMap, + stats :: FuncStats +} deriving (Eq,Show) + +-- * Constants + +-- arbitrary suffix that gets mangled into an uncurried function's name +suffix :: String +suffix = "$_$_$" + + +-- * Functions + +-- | Main function for uncurry optimization +uncurryFunc :: [Module] -> [ModuleIdentifier] -> [Module] +uncurryFunc modules entryPoints = + -- add uncurried functions + let (modulesWithUncurried,funcCollector) = foldr generateUncurried ([],emptyCollector) modules + -- add exports for uncurried functions + (modulesWithExports,funcCollector2) = foldr (generateUncurriedExports entryPoints) ([],funcCollector) modulesWithUncurried + -- replace saturated calls to calls to uncurried functions + (modulesWithCalls, _funcCollector3) = -- trace ("Uncurry Stats: " ++ (show (stats funcCollector2))) $ + foldr generateSaturedCalls ([],funcCollector2) modulesWithExports + + in modulesWithCalls + + +-- | Generation of uncurried functions +generateUncurried :: Module -> ([Module],FuncCollector) -> ([Module],FuncCollector) +generateUncurried (Module moduleIdentifier moduleElements) (modules, funcCollector) = + let newCollector = funcCollector {adminMap = adminMap funcCollector, + stats = (stats funcCollector){moduleCount = moduleCount (stats funcCollector) + 1}} + (eles,funcCollector') = foldr (generateUncurriedEle moduleIdentifier) ([],newCollector) moduleElements + in (Module moduleIdentifier eles : modules, funcCollector') + + +-- | Generate uncurried functions from curried functions +generateUncurriedEle :: ModuleIdentifier -> ModuleElement -> ([ModuleElement],FuncCollector) -> ([ModuleElement],FuncCollector) +generateUncurriedEle mid m@(Member jsNode sort name decl keys) (eles, funcCollector) -- a var decl + | JSVariable _ (JSLOne varInitE) _ <- jsNode + , JSVarInitExpression (JSIdentifier _ia1 _funcName) varInit <- varInitE + , JSVarInit _va1 funcE <- varInit + , JSFunctionExpression _ _ _ idiL@(JSLOne _arg1) _ block <- funcE + = let newCollector = funcCollector + {adminMap = adminMap funcCollector, + stats = (stats funcCollector){moduleFunctions = moduleFunctions (stats funcCollector) + 1}} + {-trace ("candidate: " ++ name ++ " para: " ++ show idi) $-} + in case analyzeUncurriedPrim idiL block of + Nothing -> (m : eles, newCollector) + Just (argList,block') -> generateUncurried1 argList block' newCollector + where + generateUncurried1 :: JSCommaList JSIdent -> JSBlock -> FuncCollector -> ([ModuleElement],FuncCollector) + generateUncurried1 newArgList block funcCollector' + | JSVariable va1 (JSLOne varInitE) rb2 <- jsNode + , JSVarInitExpression (JSIdentifier ia1 _funcName) varInit <- varInitE + , JSVarInit va2 _funcE <- varInit + , JSFunctionExpression u1 u2 lb _ rb1 _ <- decl + = let newName = name ++ suffix + newDecl = JSFunctionExpression u1 u2 lb newArgList rb1 block + newVarIntro = JSVarInitExpression (JSIdentifier ia1 newName) (JSVarInit va2 newDecl) + newNode = JSVariable va1 (JSLOne newVarIntro) rb2 + newAdmin = FuncAdmin { moduleId = mid, arity = lengthJSCommaList newArgList, exported = False} + newCollector = funcCollector' {adminMap = addAdmin name newAdmin (adminMap funcCollector'), + stats = (stats funcCollector'){uncurriedFuncs = uncurriedFuncs (stats funcCollector') + 1}} + in (m : Member newNode sort newName newDecl keys : eles, newCollector) + generateUncurried1 _ _ funcCollector' = (m : eles, funcCollector') + +generateUncurriedEle mid m@(Member jsNode sort name decl keys) (eles, funcCollector) -- a var decl + | JSAssignStatement expr1 _u1 expr2 _u2 <- jsNode + , JSMemberDot (JSIdentifier _ia1 _exp) _mi (JSIdentifier _ia2 _funcName) <- expr1 + , JSFunctionExpression _ _ _ idiL@(JSLOne _arg1) _ block <- expr2 + = let newCollector = funcCollector + {adminMap = adminMap funcCollector, + stats = (stats funcCollector){moduleFunctions = moduleFunctions (stats funcCollector) + 1}} + {-trace ("candidate: " ++ name ++ " para: " ++ show idi) $-} + in case analyzeUncurriedPrim idiL block of + Nothing -> (m : eles, newCollector) + Just (argList,block') -> generateUncurried2 argList block' newCollector + where + generateUncurried2 :: JSCommaList JSIdent -> JSBlock -> FuncCollector -> ([ModuleElement],FuncCollector) + generateUncurried2 newArgList block funcCollector' + | JSAssignStatement expr1 u1 _expr2 u2 <- jsNode + , JSMemberDot (JSIdentifier ia1 expo) mi (JSIdentifier ia2 _funcName) <- expr1 + , JSFunctionExpression uf1 uf2 lb _ rb1 _ <- decl + = let newName = name ++ suffix + newDecl = JSFunctionExpression uf1 uf2 lb newArgList rb1 block + newMemberDot = JSMemberDot (JSIdentifier ia1 expo) mi (JSIdentifier ia2 newName) + newNode = JSAssignStatement newMemberDot u1 newDecl u2 + newAdmin = FuncAdmin { moduleId = mid, arity = lengthJSCommaList newArgList, exported = False} + newCollector = funcCollector' {adminMap = addAdmin name newAdmin (adminMap funcCollector'), + stats = (stats funcCollector'){uncurriedFuncs = uncurriedFuncs (stats funcCollector') + 1}} + in (m : Member newNode sort newName newDecl keys : eles, newCollector) + generateUncurried2 _ _ funcCollector' = (m : eles, funcCollector') +generateUncurriedEle _mid m (eles, funcCollector) = (m : eles, funcCollector) + + +analyzeUncurriedPrim :: JSCommaList JSIdent -> JSBlock -> Maybe (JSCommaList JSIdent, JSBlock) +analyzeUncurriedPrim idList decl + | JSBlock _ [ef] _ <- decl + , JSReturn _ (Just ef2) _ <- ef + , JSFunctionExpression _ _fn _ (JSLOne idi) _ block <- ef2 + = {-trace ("found deeper: " ++ show idList ++ " para: " ++ show idi) $-} + analyzeUncurriedPrim (consJSCommaList idi idList) block +analyzeUncurriedPrim l block | lengthJSCommaList l > 1 = Just (l,block) +analyzeUncurriedPrim _ _ = Nothing + +-- * Exports + +-- | Generation of uncurried exports +generateUncurriedExports :: [ModuleIdentifier] -> Module -> ([Module],FuncCollector) -> ([Module],FuncCollector) +generateUncurriedExports entryPoints (Module moduleIdentifier moduleElements) (modules, funcCollector) = + if elem moduleIdentifier entryPoints + then (Module moduleIdentifier moduleElements : modules, funcCollector) + else + let (eles,funcCollector') = foldr (generateUncurriedExpo moduleIdentifier) ([],funcCollector) moduleElements + in (Module moduleIdentifier eles : modules, funcCollector') + +generateUncurriedExpo :: ModuleIdentifier -> ModuleElement -> ([ModuleElement],FuncCollector) -> ([ModuleElement],FuncCollector) +generateUncurriedExpo mid (ExportsList l) (eles, funcCollector) = + let (newExports,funcCollector') = foldr (generateUncurriedEx mid) ([],funcCollector) l + in (ExportsList newExports : eles, funcCollector') +generateUncurriedExpo _mid other (eles, funcCollector) = (other : eles, funcCollector) + +generateUncurriedEx :: ModuleIdentifier -> (ExportType, String, JSExpression, [Key]) + -> ([(ExportType, String, JSExpression, [Key])],FuncCollector) -> ([(ExportType, String, JSExpression, [Key])],FuncCollector) +generateUncurriedEx mid t@(RegularExport name1, name2, jSNode, [key]) (eles, funcCollector) + | JSIdentifier ianno _name3 <- jSNode + = -- [(ExportType, String, JSStatement, [Key])] + let newCollector = funcCollector {stats = (stats funcCollector){exportedEntities = exportedEntities (stats funcCollector) + 1}} + in case findAdminFor name2 mid (adminMap newCollector) of + Nothing -> (t : eles, newCollector) + Just admin -> + let newName = name2 ++ suffix + newAdmin = admin {exported = True} + newNode = (JSIdentifier ianno newName) + newKeys = [(fst key,newName)] + newExport = (RegularExport (name1 ++ suffix ), newName, newNode, newKeys) + newCollector' = newCollector {adminMap = replaceAdmin name2 admin newAdmin (adminMap newCollector), + stats = (stats newCollector){uncurriedFuncsExported = uncurriedFuncsExported (stats newCollector) + 1}} + in (t : newExport : eles, newCollector') + +generateUncurriedEx mid t@(ForeignReexport, name, jSNode, [key]) (eles, funcCollector) + | JSMemberDot l m r <- jSNode + , JSIdentifier anno "$foreign" <- l + , JSIdentifier anno3 name2 <- r + = let newCollector = funcCollector {stats = (stats funcCollector){exportedForeignEntities = exportedForeignEntities (stats funcCollector) + 1}} + in case findAdminFor name2 mid (adminMap newCollector) of + Nothing -> (t : eles, newCollector) + Just admin -> + let newName = name ++ suffix + newAdmin = admin {exported = True} + newNode = (JSMemberDot (JSIdentifier anno "$foreign") m + (JSIdentifier anno3 newName)) + newKeys = [(fst key,newName)] + newExport = (ForeignReexport, newName, newNode, newKeys) + newCollector' = newCollector {adminMap = replaceAdmin name2 admin newAdmin (adminMap newCollector), + stats = (stats newCollector){uncurriedForeignFuncsExported = uncurriedForeignFuncsExported (stats newCollector) + 1}} + in (t : newExport : eles, newCollector') + +generateUncurriedEx _mid t (eles, funcCollector) = + {-trace ("export in unknown form: " ++ show t)-} (t : eles, funcCollector) + +-- * Call replacement + +-- | replace saturated calls to calls to uncurried functions +generateSaturedCalls :: Module -> ([Module],FuncCollector) -> ([Module],FuncCollector) +generateSaturedCalls (Module moduleIdentifier moduleElements) (modules, funcCollector) = + {- trace ("generateSaturedCalls: " ++ show moduleIdentifier) $ -} + let (eles,funcCollector') = foldr (generateSaturedC moduleIdentifier imports) ([],funcCollector) moduleElements + in (Module moduleIdentifier eles : modules, funcCollector') + where + imports :: [(String, ModuleIdentifier)] + imports = mapMaybe toImport moduleElements + where + toImport :: ModuleElement -> Maybe (String, ModuleIdentifier) + toImport (Require _ nm (Right mid)) = Just (nm, mid) + toImport _ = Nothing + +-- | Generate uncurried functions from curried functions +generateSaturedC :: ModuleIdentifier -> [(String, ModuleIdentifier)] -> ModuleElement -> + ([ModuleElement],FuncCollector) -> ([ModuleElement],FuncCollector) +generateSaturedC mid imports (Member node' sort name decl keys) (eles, funcCollector) = + let replaceSaturedNode = replaceSaturedStatement node' + replaceSaturedDecl = replaceSaturedExpression decl + in (Member replaceSaturedNode sort name replaceSaturedDecl keys : eles, funcCollector) + where + replaceSaturedStatement :: JSStatement -> JSStatement + replaceSaturedStatement (JSStatementBlock ann statements ann2 semi) = + JSStatementBlock ann (map replaceSaturedStatement statements) ann2 semi + replaceSaturedStatement inp@(JSBreak _ann _ident _semi) = inp + replaceSaturedStatement (JSConstant ann expressions semi) = + JSConstant ann (mapJSCommaList replaceSaturedExpression expressions) semi + replaceSaturedStatement inp@(JSContinue _ _ _) = inp + replaceSaturedStatement (JSDoWhile continue stmt while lb expr rb autosemi) = + JSDoWhile continue (replaceSaturedStatement stmt) while lb (replaceSaturedExpression expr) rb autosemi + replaceSaturedStatement (JSFor u1 u2 exprL1 u3 exprL2 u4 exprL3 u5 stmt) = + JSFor u1 u2 (mapJSCommaList replaceSaturedExpression exprL1) u3 (mapJSCommaList replaceSaturedExpression exprL2) u4 + (mapJSCommaList replaceSaturedExpression exprL3) u5 (replaceSaturedStatement stmt) + replaceSaturedStatement (JSForIn u1 u2 expr1 binOp expr2 u3 stmt) = + JSForIn u1 u2 (replaceSaturedExpression expr1) binOp (replaceSaturedExpression expr2) u3 (replaceSaturedStatement stmt) + replaceSaturedStatement (JSForVar u1 u2 u3 exprL1 u4 exprL2 u5 exprL3 u6 stmt) = + JSForVar u1 u2 u3 (mapJSCommaList replaceSaturedExpression exprL1) u4 (mapJSCommaList replaceSaturedExpression exprL2) u5 + (mapJSCommaList replaceSaturedExpression exprL3) u6 (replaceSaturedStatement stmt) + replaceSaturedStatement (JSForVarIn u1 u2 u3 expr1 u4 expr2 u5 stmt) = + JSForVarIn u1 u2 u3 (replaceSaturedExpression expr1) u4 (replaceSaturedExpression expr2) u5 + (replaceSaturedStatement stmt) + replaceSaturedStatement (JSFunction u1 u2 u3 u4 u5 block u6) = + JSFunction u1 u2 u3 u4 u5 (replaceSaturedBlock block) u6 + replaceSaturedStatement (JSIf u1 u2 expr u3 stmt) = + JSIf u1 u2 (replaceSaturedExpression expr) u3 (replaceSaturedStatement stmt) + replaceSaturedStatement (JSIfElse u1 u2 expr u3 stmt1 u4 stmt2) = + JSIfElse u1 u2 (replaceSaturedExpression expr) u3 (replaceSaturedStatement stmt1) u4 (replaceSaturedStatement stmt2) + replaceSaturedStatement (JSLabelled u1 u2 stmt) = + JSLabelled u1 u2 (replaceSaturedStatement stmt) + replaceSaturedStatement inp@(JSEmptyStatement _) = inp + replaceSaturedStatement (JSExpressionStatement expr u1) = JSExpressionStatement (replaceSaturedExpression expr) u1 + replaceSaturedStatement (JSAssignStatement expr1 u1 expr2 u2) = + JSAssignStatement (replaceSaturedExpression expr1) u1 (replaceSaturedExpression expr2) u2 + replaceSaturedStatement (JSMethodCall expr1 u1 exprL u2 u3) = -- TODO currently not used + JSMethodCall (replaceSaturedExpression expr1) u1 (mapJSCommaList replaceSaturedExpression exprL) u2 u3 + replaceSaturedStatement (JSReturn u1 (Just expr) u2) = JSReturn u1 (Just (replaceSaturedExpression expr)) u2 + replaceSaturedStatement inp@(JSReturn _u1 Nothing _u2) = inp + replaceSaturedStatement (JSSwitch u1 u2 expr u3 u4 switchParts u5 u6) = + JSSwitch u1 u2 (replaceSaturedExpression expr) u3 u4 (map replaceSaturedSwitchPart switchParts) u5 u6 + replaceSaturedStatement (JSThrow u1 expr u2) = + JSThrow u1 (replaceSaturedExpression expr) u2 + replaceSaturedStatement (JSTry u1 block tryCatch tryFinally) = + JSTry u1 (replaceSaturedBlock block) (map replaceSaturedTryCatch tryCatch) (replaceSaturedTryFinally tryFinally) + replaceSaturedStatement (JSVariable u1 exprL u2) = JSVariable u1 (mapJSCommaList replaceSaturedExpression exprL) u2 + replaceSaturedStatement (JSWhile u1 u2 expr u3 stmt) = + JSWhile u1 u2 (replaceSaturedExpression expr) u3 (replaceSaturedStatement stmt) + replaceSaturedStatement (JSWith u1 u2 expr u3 stmt u4) = + JSWith u1 u2 (replaceSaturedExpression expr) u3 (replaceSaturedStatement stmt) u4 + + replaceSaturedBlock (JSBlock u1 stmtL u2) = JSBlock u1 (map replaceSaturedStatement stmtL) u2 + + replaceSaturedSwitchPart (JSCase u1 expr u2 stmtL) = + JSCase u1 (replaceSaturedExpression expr) u2 (map replaceSaturedStatement stmtL) + replaceSaturedSwitchPart (JSDefault u1 u2 stmtL) = + JSDefault u1 u2 (map replaceSaturedStatement stmtL) + + replaceSaturedTryCatch (JSCatch u1 u2 expr u3 block) = + JSCatch u1 u2 (replaceSaturedExpression expr) u3 (replaceSaturedBlock block) + replaceSaturedTryCatch (JSCatchIf u1 u2 expr1 u3 expr2 u4 block) = + JSCatchIf u1 u2 (replaceSaturedExpression expr1) u3 (replaceSaturedExpression expr2) u4 (replaceSaturedBlock block) + + replaceSaturedTryFinally (JSFinally u1 block) = JSFinally u1 (replaceSaturedBlock block) + replaceSaturedTryFinally JSNoFinally = JSNoFinally + + replaceSaturedExpression inp@(JSIdentifier _u1 _u2) = inp + replaceSaturedExpression inp@(JSDecimal _u1 _u2) = inp + replaceSaturedExpression inp@(JSLiteral _u1 _u2) = inp + replaceSaturedExpression inp@(JSHexInteger _ _) = inp + replaceSaturedExpression inp@(JSOctal _ _) = inp + replaceSaturedExpression inp@(JSStringLiteral _ _)= inp + replaceSaturedExpression inp@(JSRegEx _ _) = inp + replaceSaturedExpression (JSArrayLiteral u1 arrayElementL u2) = + JSArrayLiteral u1 (map replaceSaturedArrayElement arrayElementL) u2 + replaceSaturedExpression (JSAssignExpression expr1 u1 expr2) = + JSAssignExpression (replaceSaturedExpression expr1) u1 (replaceSaturedExpression expr2) + replaceSaturedExpression inp@(JSCallExpression _expr _u1 _exprL _u2) = -- Here we uncurry Calls + mayUncurryCallExpression inp [] inp + -- JSCallExpression (replaceSaturedExpression expr) u1 (mapJSCommaList replaceSaturedExpression exprL) u2 + replaceSaturedExpression (JSCallExpressionDot expr1 u1 expr2) = + JSCallExpressionDot (replaceSaturedExpression expr1) u1 (replaceSaturedExpression expr2) + replaceSaturedExpression (JSCallExpressionSquare expr1 u1 expr2 u2) = + JSCallExpressionSquare (replaceSaturedExpression expr1) u1 (replaceSaturedExpression expr2) u2 + replaceSaturedExpression (JSCommaExpression expr1 u1 expr2) = + JSCommaExpression (replaceSaturedExpression expr1) u1 (replaceSaturedExpression expr2) + replaceSaturedExpression (JSExpressionBinary expr1 u1 expr2) = + JSExpressionBinary (replaceSaturedExpression expr1) u1 (replaceSaturedExpression expr2) + replaceSaturedExpression (JSExpressionParen u1 expr u2) = + JSExpressionParen u1 (replaceSaturedExpression expr) u2 + replaceSaturedExpression (JSExpressionPostfix expr u) = JSExpressionPostfix (replaceSaturedExpression expr) u + replaceSaturedExpression (JSExpressionTernary expr1 u1 expr2 u2 expr3) = + JSExpressionTernary (replaceSaturedExpression expr1) u1 (replaceSaturedExpression expr2) u2 + (replaceSaturedExpression expr3) + replaceSaturedExpression (JSFunctionExpression u1 u2 u3 u4 u5 block) = + JSFunctionExpression u1 u2 u3 u4 u5 (replaceSaturedBlock block) + replaceSaturedExpression (JSMemberDot expr1 u1 expr2) = + JSMemberDot (replaceSaturedExpression expr1) u1 (replaceSaturedExpression expr2) + + replaceSaturedExpression (JSMemberExpression expr u1 exprL u2) = + JSMemberExpression (replaceSaturedExpression expr) u1 (mapJSCommaList replaceSaturedExpression exprL) u2 + replaceSaturedExpression (JSMemberNew u1 expr u2 exprL u3) = + JSMemberNew u1 (replaceSaturedExpression expr) u2 (mapJSCommaList replaceSaturedExpression exprL) u3 + replaceSaturedExpression (JSMemberSquare expr1 u1 expr2 u2) = + JSMemberSquare (replaceSaturedExpression expr1) u1 (replaceSaturedExpression expr2) u2 + replaceSaturedExpression (JSNewExpression u1 expr) = + JSNewExpression u1 (replaceSaturedExpression expr) + replaceSaturedExpression (JSObjectLiteral u1 objectPropertyL u2) = + JSObjectLiteral u1 (mapJSCommaTrailingList replaceSaturedObjectProperty objectPropertyL) u2 + replaceSaturedExpression (JSUnaryExpression u1 expr) = + JSUnaryExpression u1 (replaceSaturedExpression expr) + replaceSaturedExpression (JSVarInitExpression expr varInitializer) = + JSVarInitExpression (replaceSaturedExpression expr) (replaceSaturedVarInitializer varInitializer) + + replaceSaturedArrayElement (JSArrayElement expr) = JSArrayElement (replaceSaturedExpression expr) + replaceSaturedArrayElement inp@(JSArrayComma _anno) = inp + + replaceSaturedObjectProperty (JSPropertyAccessor u1 u2 u3 exprL u4 block) = + JSPropertyAccessor u1 u2 u3 (map replaceSaturedExpression exprL) u4 (replaceSaturedBlock block) + replaceSaturedObjectProperty (JSPropertyNameandValue u1 u2 exprL) = + JSPropertyNameandValue u1 u2 (map replaceSaturedExpression exprL) + + replaceSaturedVarInitializer (JSVarInit u1 expr) = JSVarInit u1 (replaceSaturedExpression expr) + replaceSaturedVarInitializer JSVarInitNone = JSVarInitNone + + mayUncurryCallExpression :: JSExpression -> [JSExpression] -> JSExpression -> JSExpression + mayUncurryCallExpression expr args original -- One more argument + | JSCallExpression cexpr _cu1 cexprL _cu2 <- expr + , JSLOne arg <- cexprL + = mayUncurryCallExpression cexpr (replaceSaturedExpression arg : args) original + mayUncurryCallExpression expr [] _original -- Empty effect arg left untouched + | JSCallExpression cexpr cu1 cexprL cu2 <- expr + , JSLNil <- cexprL + = JSCallExpression (replaceSaturedExpression cexpr) cu1 cexprL cu2 + mayUncurryCallExpression expr args original + | JSMemberExpression mexpr mu1 mexprL mu2 <- expr + , JSIdentifier iu1 funcName <- mexpr + , JSLOne arg1 <- mexprL + = let newName = funcName ++ suffix + arityFound = 1 + length args + in case findAdminFor funcName mid (adminMap funcCollector) of + Nothing -> if arityFound > 1 + then {-trace ("replace candidate: not in map: " ++ funcName) $-} + continueUncurry original + else continueUncurry original + Just admin -> + if arity admin <= arityFound + then {-trace ("!*" ++ show arityFound) $-} + if arity admin == arityFound + then + let argList = toJSCommaList (reverse (replaceSaturedExpression arg1 : args)) + in JSMemberExpression (JSIdentifier iu1 newName) mu1 argList mu2 + else + let newArgs = replaceSaturedExpression arg1 : args + argList = toJSCommaList (reverse (take (arity admin) newArgs)) + mExpr = JSMemberExpression (JSIdentifier iu1 newName) mu1 argList mu2 + extraArgs = reverse $ drop (arity admin) newArgs + callFunc arg ex = JSCallExpression ex JSNoAnnot (JSLOne arg) JSNoAnnot + in -- trace ("special In: " ++ show (arity admin) ++ " " ++ show arityFound ++ " " ++ newName) $ + foldr callFunc mExpr extraArgs + else {-trace ("no replace!!! " ++ show (arity admin) ++ " " ++ show arityFound ++ " " ++ newName) $-} + continueUncurry original + mayUncurryCallExpression expr args original + | JSMemberExpression mexpr mu1 mexprL mu2 <- expr + , JSMemberDot l m r <- mexpr + , JSIdentifier _ scope <- l + , JSIdentifier a1 funcName <- r + , JSLOne arg1 <- mexprL + = let realMod = case lookup scope imports of + Nothing -> mid + Just moduleIdentifier -> moduleIdentifier + newName = funcName ++ suffix + arityFound = 1 + length args + in case findAdminFor funcName realMod (adminMap funcCollector) of + Nothing -> if arityFound > 1 + then {-trace ("replace candidate: not in map: " ++ funcName) $-} + continueUncurry original + else continueUncurry original + Just admin -> + if arity admin <= arityFound + then {-trace ("!!*" ++ show (arity admin)) $-} + if arity admin == arityFound + then + let argList = toJSCommaList (reverse (replaceSaturedExpression arg1 : args)) + in JSMemberExpression (JSMemberDot l m (JSIdentifier a1 newName)) mu1 argList mu2 + else + let newArgs = replaceSaturedExpression arg1 : args + argList = toJSCommaList (reverse (take (arity admin) newArgs)) + mExpr = JSMemberExpression (JSMemberDot l m (JSIdentifier a1 newName)) mu1 argList mu2 + extraArgs = reverse $ drop (arity admin) newArgs + callFunc arg ex = JSCallExpression ex JSNoAnnot (JSLOne arg) JSNoAnnot + in {- trace ("special In: " ++ show (arity admin) ++ " " ++ show arityFound ++ " " ++ newName) $ -} + foldr callFunc mExpr extraArgs + else {-trace ("no replace!!! " ++ show (arity admin) ++ " " ++ show arityFound ++ " " ++ newName)-} + continueUncurry original + mayUncurryCallExpression _expr _args original = continueUncurry original + + continueUncurry exprC + | JSCallExpression expr u1 exprL u2 <- exprC + = JSCallExpression (replaceSaturedExpression expr) u1 (mapJSCommaList replaceSaturedExpression exprL) u2 + continueUncurry _expr = error "BundleOpt>>continueUncurry: Impossible!" + +generateSaturedC _ _ e (eles, funcCollector) = (e : eles, funcCollector) + +-- * Admin +emptyStats :: FuncStats +emptyStats = FuncStats { + moduleCount = 0, + moduleFunctions = 0, + uncurriedFuncs = 0, + exportedEntities = 0, + uncurriedFuncsExported = 0, + exportedForeignEntities = 0, + uncurriedForeignFuncsExported = 0 +} + +emptyCollector :: FuncCollector +emptyCollector = FuncCollector { + adminMap = M.empty, + stats = emptyStats +} + +addAdmin :: String -> FuncAdmin -> FuncAdminMap -> FuncAdminMap +addAdmin funcName funcAdmin funcAdminMap = M.insertWith (++) funcName [funcAdmin] funcAdminMap + +replaceAdmin :: String -> FuncAdmin -> FuncAdmin -> FuncAdminMap -> FuncAdminMap +replaceAdmin funcName oldFuncAdmin newFuncAdmin funcAdminMap = M.adjust replaceFunc funcName funcAdminMap + where + replaceFunc [o] | o == oldFuncAdmin = [newFuncAdmin] + replaceFunc l@(_hd:_) = filter (\e -> e /= oldFuncAdmin) l ++ [newFuncAdmin] + replaceFunc [] = error "BundleOpt>>replaceAdmin: Impossible with FuncAdmin" + +findAdminFor :: String -> ModuleIdentifier -> FuncAdminMap -> Maybe FuncAdmin +findAdminFor name mid funcAdminMap = + case M.lookup name funcAdminMap of + Nothing -> Nothing + Just li -> case filter (\fa -> moduleName (moduleId fa) == moduleName mid) li of + [] -> Nothing + [e] -> Just e + _ -> error "BundleOpt>>findAdminFor: Impossible with Export" diff --git a/src/Language/PureScript/BundleTypes.hs b/src/Language/PureScript/BundleTypes.hs new file mode 100644 index 0000000000..4b3fb6b1f5 --- /dev/null +++ b/src/Language/PureScript/BundleTypes.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- +-- Module : psc-bundle +-- Copyright : (c) Phil Freeman 2015 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | Bundles compiled PureScript modules for the browser. +-- +-- This module takes as input the individual generated modules from 'Language.PureScript.Make' and +-- performs dead code elimination, filters empty modules, +-- and generates the final Javascript bundle. +----------------------------------------------------------------------------- + +{-# LANGUAGE PatternGuards #-} + +module Language.PureScript.BundleTypes where + +import Prelude +import Language.JavaScript.Parser +import Language.JavaScript.Parser.AST + +-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules. +data ModuleType + = Regular + | Foreign + deriving (Show, Read, Eq, Ord) + +showModuleType :: ModuleType -> String +showModuleType Regular = "Regular" +showModuleType Foreign = "Foreign" + +-- | A module is identified by its module name and its type. +data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read, Eq, Ord) + +moduleName :: ModuleIdentifier -> String +moduleName (ModuleIdentifier name _) = name + +-- | A piece of code is identified by its module and its name. These keys are used to label vertices +-- in the dependency graph. +type Key = (ModuleIdentifier, String) + +-- | An export is either a "regular export", which exports a name from the regular module we are in, +-- or a reexport of a declaration in the corresponding foreign module. +-- +-- Regular exports are labelled, since they might re-export an operator with another name. +data ExportType + = RegularExport String + | ForeignReexport + deriving (Show, Eq, Ord) + +-- | There are four types of module element we are interested in: +-- +-- 1) Require statements +-- 2) Member declarations +-- 3) Export lists +-- 4) Everything else +-- +-- Each is labelled with the original AST node which generated it, so that we can dump it back +-- into the output during codegen. +data ModuleElement + = Require JSStatement String (Either String ModuleIdentifier) + | Member JSStatement Bool String JSExpression [Key] + | ExportsList [(ExportType, String, JSExpression, [Key])] + | Other JSStatement + deriving (Show) + +-- | A module is just a list of elements of the types listed above. +data Module = Module ModuleIdentifier [ModuleElement] deriving (Show) + +-- *Helpers for JSCommaList + +toJSCommaList :: [a] -> JSCommaList a +toJSCommaList [] = JSLNil +toJSCommaList [a] = JSLOne a +toJSCommaList (hd:rest) = JSLCons (toJSCommaList rest) JSNoAnnot hd + +fromJSCommaList :: JSCommaList a -> [a] +fromJSCommaList JSLNil = [] +fromJSCommaList (JSLOne a) = [a] +fromJSCommaList (JSLCons list _ hd) = hd : fromJSCommaList list + +lengthJSCommaList :: JSCommaList a -> Int +lengthJSCommaList = length . fromJSCommaList + +mapJSCommaList :: (a -> b) -> JSCommaList a -> JSCommaList b +mapJSCommaList func inp = toJSCommaList (map func (fromJSCommaList inp)) + +mapJSCommaTrailingList :: (a -> b) -> JSCommaTrailingList a -> JSCommaTrailingList b +mapJSCommaTrailingList func (JSCTLComma inp a) = JSCTLComma (mapJSCommaList func inp) a +mapJSCommaTrailingList func (JSCTLNone inp) = JSCTLNone (mapJSCommaList func inp) + +consJSCommaList :: a -> JSCommaList a -> JSCommaList a +consJSCommaList a li = JSLCons li JSNoAnnot a + +reverseJSCommaList :: JSCommaList JSIdent -> JSCommaList JSIdent +reverseJSCommaList = toJSCommaList . reverse . fromJSCommaList