implement let-no-escape

.gitignore

@@ -1,4 +1,5 @@
 /dist
+/utils/patch/dist
 /vendor/
 /GNUmakefile
 *.js_hi

Setup.hs

@@ -25,7 +25,7 @@ import           System.IO.Error       (IOError, isDoesNotExistError)
     add all executables that are not wrapped (or require an .options file on Windows) here
  -}
 notWrapped :: [String]
-notWrapped = ["ghcjs-boot", "ghcjs-run", "ghcjs-patch"]
+notWrapped = ["ghcjs-boot", "ghcjs-run"]
 
 main :: IO ()
 main = defaultMainWithHooks ghcjsHooks

ghcjs.cabal

@@ -80,7 +80,6 @@ Library
                      Gen2.Base,
                      Gen2.Cache,
                      Gen2.DynamicLinking,
-                     Gen2.GHC.CoreToStg,
                      Gen2.GHC.Linker,
                      Gen2.GHC.SysTools,
                      Gen2.GHC.Packages,
@@ -153,7 +152,7 @@ Library
     buildable: True
     hs-source-dirs: src
     include-dirs: include
-    GHC-Options: -O2 -fno-warn-orphans -auto-all -Wall
+    GHC-Options: -O2 -Wall -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind -auto-all
 
 -- the compiler executable, Setup.hs installs a wrapper script that
 -- supplies the installation directory
@@ -258,43 +257,6 @@ Executable ghcjs-boot
     else
       Build-Depends: network < 2.6
 
-Executable ghcjs-patch
-    if os(Windows)
-      cpp-options: -DWINDOWS
-    ghc-options:      -threaded -O
-    Main-Is:          Patch.hs
-    Default-Language: Haskell2010
-    Hs-Source-Dirs:   src-bin
-    Build-Depends:    base                 >= 4      && < 5,
-                      ghcjs,
-                      directory,
-                      Cabal,
-                      mtl,
-                      transformers,
-                      lens,
-                      unordered-containers,
-                      vector,
-                      filepath             >= 1.3    && < 1.4,
-                      text                 >= 0.11   && < 1.2,
-                      bytestring           >= 0.10   && < 0.11,
-                      system-filepath      >= 0.4    && < 0.5,
-                      shelly               >= 1.5    && < 1.6,
-                      system-fileio        >= 0.3    && < 0.4,
-                      optparse-applicative >= 0.9    && < 0.10,
-                      tar                  >= 0.4    && < 0.5,
-                      HTTP                 >= 4000.2 && < 5000,
-                      yaml                 >= 0.8    && < 0.9,
-                      process              >= 1.2    && < 1.3,
-                      time                 >= 1.4    && < 1.5,
-                      unix-compat          >= 0.4    && < 0.5,
-                      executable-path      >= 0      && < 0.1
-    if flag(network-uri)
-      Build-Depends: network-uri >= 2.6,
-                     network     >  2.6 
-    else
-      Build-Depends: network < 2.6
-
-
 Executable ghcjs-run
     if flag(compiler-only)
       Buildable:      False

src-bin/Boot.hs

@@ -63,6 +63,8 @@ import           Filesystem                      (getWorkingDirectory, getModifi
 import           Filesystem.Path                 hiding ((<.>), (</>), null, concat)
 import           Filesystem.Path.CurrentOS       (encodeString)
 
+import           GHC.IO.Encoding                 (setLocaleEncoding, setForeignEncoding, utf8)
+
 import qualified Network.Browser                 as Br
 import           Network.HTTP                    (mkRequest, RequestMethod(..), Response(..))
 import           Network.URI                     (parseURI, URI(..))
@@ -266,6 +268,8 @@ main = do
     whenM ((==["--init"]) <$> getArgs) (putStrLn "ghcjs-boot has been updated. see README.\nUse `ghcjs-boot --dev' for a development build (if you installed GHCJS from a Git repo) or `ghcjs-boot' for a release build" >> exitFailure)
     settings <- adjustDefaultSettings <$> execParser optParser'
     when (settings ^. bsShowVersion) (printVersion >> exitSuccess)
+    setLocaleEncoding utf8
+    setForeignEncoding utf8
     env <- initBootEnv settings
     printBootEnvSummary False env
     r <- Sh.shelly $ runReaderT ((actions >> pure Nothing) `catchAny` (pure . Just)) env
@@ -1342,7 +1346,7 @@ checkProgramVersions bs pgms = do
       return $ (if update then (l . pgmVersion .~ Just res) else id) ps
     verifyNodeVersion pgms = do
       let verTxt = fromMaybe "-" (pgms ^. bpNode . pgmVersion)
-          v      = mapM (readMaybe . T.unpack . T.dropWhile (== 'v')) . T.splitOn "." $ verTxt :: Maybe [Integer]
+          v      = mapM (readMaybe . T.unpack . T.dropWhile (== 'v')) . T.splitOn "." . T.takeWhile (/='-') $ verTxt :: Maybe [Integer]
       case v of
         Just (x:y:z:_)
           | x > 0 || y > 10 || (y == 10 && z >= 28) -> return pgms

src-bin/Hsc2Hs.hs

@@ -15,6 +15,7 @@ import qualified System.Info as Info
 
 import           Compiler.Info (getFullArguments)
 
+main :: IO ()
 main = do
   args <- getFullArguments
   exitWith =<< rawSystem "hsc2hs" (filter (\x -> isELF Info.os || not (isELFArg x)) args)

src/Compiler/GhcjsHooks.hs

@@ -2,6 +2,8 @@
 module Compiler.GhcjsHooks where
 
 import           CorePrep             (corePrepPgm)
+-- import           Gen2.GHC.CorePrep    (corePrepPgm) -- customized to not float new toplevel binds
+import           CoreToStg            (coreToStg)
 import           DriverPipeline
 import           DriverPhases
 import           DynFlags
@@ -29,12 +31,11 @@ import           Compiler.Variants
 
 import qualified Gen2.DynamicLinking  as Gen2
 import qualified Gen2.Foreign         as Gen2
-import           Gen2.GHC.CoreToStg   (coreToStg) -- version that does not generate StgLetNoEscape
+
 import qualified Gen2.PrimIface       as Gen2
 import qualified Gen2.TH              as Gen2TH
 
 import           System.IO.Error
-import           System.Environment
 
 installGhcjsHooks :: GhcjsEnv
                   -> GhcjsSettings
@@ -80,7 +81,7 @@ runGhcjsPhase :: GhcjsSettings
               -> PhasePlus -> FilePath -> DynFlags
               -> CompPipeline (PhasePlus, FilePath)
 
-runGhcjsPhase settings env (RealPhase (Cpp sf)) input_fn dflags0
+runGhcjsPhase _settings _env (RealPhase (Cpp sf)) input_fn dflags0
   = do
        src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
        (dflags1, unhandled_flags, warns)
@@ -149,7 +150,7 @@ runGhcjsPhase settings env (HscOut src_flavour mod_name result) _ dflags = do
 
                     return (RealPhase next_phase, outputFilename)
 -- skip these, but copy the result
-runGhcjsPhase _ _ (RealPhase ph) input dflags
+runGhcjsPhase _ _ (RealPhase ph) input _dflags
   | Just next <- lookup ph skipPhases = do
     output <- phaseOutputFilename next
     liftIO (copyFile input output `catchIOError` \_ -> return ())

src/Compiler/GhcjsProgram.hs

@@ -17,7 +17,6 @@ import           PrelInfo
 import           IfaceEnv
 import           HscTypes
 import           DsMeta
-import           LoadIface
 import           ErrUtils (fatalErrorMsg'')
 import           Panic (handleGhcException)
 import           Exception
@@ -29,7 +28,7 @@ import           Control.Monad.IO.Class
 
 import qualified Data.ByteString as B
 import           Data.IORef
-import           Data.List (isSuffixOf, isPrefixOf, partition)
+import           Data.List (isPrefixOf, partition)
 import qualified Data.List as L
 import qualified Data.Map as M
 import           Data.Maybe
@@ -67,7 +66,6 @@ import qualified Gen2.ClosureInfo as Gen2
 import qualified Gen2.PrimIface   as Gen2
 import qualified Gen2.Shim        as Gen2
 import qualified Gen2.Rts         as Gen2
-import qualified Gen2.RtsTypes    as Gen2
 import qualified Gen2.TH          as Gen2
 
 -- workaround for platform dependence bugs
@@ -217,7 +215,7 @@ bootstrapFallback = do
       ghcArgs args = filter (not . ignoreArg) args ++ ["-threaded"]
       getOutput []         = Nothing
       getOutput ("-o":x:_) = Just x
-      getOutput (x:xs)     = getOutput xs
+      getOutput (_:xs)     = getOutput xs
 
 installExecutable :: DynFlags -> GhcjsSettings -> [String] -> IO ()
 installExecutable dflags settings srcs = do
@@ -249,7 +247,7 @@ installExecutable dflags settings srcs = do
  -}
 
 generateLib :: GhcjsSettings -> Ghc ()
-generateLib settings = do
+generateLib _settings = do
   dflags1 <- getSessionDynFlags
   liftIO $ do
     (dflags2, _) <- initPackages dflags1
@@ -428,3 +426,9 @@ getArgsTopDir xs
   where
     minusB_args = filter ("-B" `isPrefixOf`) xs
 
+buildJsLibrary :: DynFlags -> [FilePath] -> [FilePath] -> [FilePath] -> IO ()
+buildJsLibrary _dflags srcs js_objs objs = do
+  print srcs
+  print js_objs
+  print objs
+  exitFailure

src/Compiler/Info.hs

@@ -3,7 +3,6 @@ module Compiler.Info where
 
 import           Control.Applicative
 import qualified Control.Exception as E
-import           Control.Monad
 
 import           Data.Function      (on)
 import           Data.List          (nubBy)
@@ -17,9 +16,6 @@ import           System.Info
 import           Config             (cProjectVersion)
 import           DynFlags
 
-import           GHC
-import qualified GHC.Paths
-
 #ifdef WINDOWS
 import           Control.Lens hiding ((<.>))
 

src/Compiler/JMacro/Base.hs

@@ -585,8 +585,8 @@ defRenderJsS r (WhileStat False p b)  = text "while" <> parens (jsToDocR r p) $$
 defRenderJsS r (WhileStat True  p b)  = (text "do" $$ braceNest' (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p)
 defRenderJsS r (UnsatBlock e) = jsToDocR r $ sat_ e
 
-defRenderJsS r (BreakStat l) = maybe (text "break") (((<+>) `on` text) "break" . TL.fromStrict) l
-defRenderJsS r (ContinueStat l) = maybe (text "continue") (((<+>) `on` text) "continue" . TL.fromStrict) l
+defRenderJsS _ (BreakStat l) = maybe (text "break") (((<+>) `on` text) "break" . TL.fromStrict) l
+defRenderJsS _ (ContinueStat l) = maybe (text "continue") (((<+>) `on` text) "continue" . TL.fromStrict) l
 defRenderJsS r (LabelStat l s) = text (TL.fromStrict l) <> char ':' $$ printBS s
         where
           printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss
@@ -613,7 +613,7 @@ defRenderJsS r (UOpStat op x)
         | isPre op && isAlphaOp op = text (uOpText op) <+> optParens r x
         | isPre op = text (uOpText op) <> optParens r x
         | otherwise = optParens r x <> text (uOpText op)
-defRenderJsS r (AntiStat s) = error "defRenderJsS: AntiStat"
+defRenderJsS _ (AntiStat{}) = error "defRenderJsS: AntiStat"
 defRenderJsS r (BlockStat xs) = jsToDocR r (flattenBlocks xs)
 
 flattenBlocks :: [JStat] -> [JStat]
@@ -637,20 +637,20 @@ defRenderJsE r (UOpExpr op x)
         | isPre op = text (uOpText op) <> optParens r x
         | otherwise = optParens r x <> text (uOpText op)
 defRenderJsE r (ApplExpr je xs) = jsToDocR r je <> (parens . fillSep . punctuate comma $ map (jsToDocR r) xs)
-defRenderJsE r (AntiExpr s) = error "defRenderJsE: AntiExpr" -- text . TL.fromChunks $ ["`(", s, ")`"]
+defRenderJsE _ (AntiExpr{}) = error "defRenderJsE: AntiExpr" -- text . TL.fromChunks $ ["`(", s, ")`"]
 
 defRenderJsE r (UnsatExpr e) = jsToDocR r $ sat_ e
 
 defRenderJsV :: RenderJs -> JVal -> Doc
 defRenderJsV r (JVar i) = jsToDocR r i
 defRenderJsV r (JList xs) = brackets . fillSep . punctuate comma $ map (jsToDocR r) xs
-defRenderJsV r (JDouble (SaneDouble d))
+defRenderJsV _ (JDouble (SaneDouble d))
                      | d < 0 || isNegativeZero d = parens (double d)
                      | otherwise                 = double d
-defRenderJsV r (JInt i) | i < 0     = parens (integer i)
+defRenderJsV _ (JInt i) | i < 0     = parens (integer i)
                      | otherwise = integer i
-defRenderJsV r (JStr s) = text . TL.fromChunks $ ["\"",encodeJson s,"\""]
-defRenderJsV r (JRegEx s) = text . TL.fromChunks $ ["/",s,"/"]
+defRenderJsV _ (JStr s) = text . TL.fromChunks $ ["\"",encodeJson s,"\""]
+defRenderJsV _ (JRegEx s) = text . TL.fromChunks $ ["/",s,"/"]
 defRenderJsV r (JHash m)
             | M.null m = text "{}"
             | otherwise = braceNest . fillSep . punctuate comma .
@@ -659,7 +659,7 @@ defRenderJsV r (JFunc is b) = parens $ text "function" <> parens (fillSep . punc
 defRenderJsV r (UnsatVal f) = jsToDocR r $ sat_ f
 
 defRenderJsI :: RenderJs -> Ident -> Doc
-defRenderJsI r (TxtI t) = text (TL.fromStrict t)
+defRenderJsI _ (TxtI t) = text (TL.fromStrict t)
 
 {--------------------------------------------------------------------
   ToJExpr Class

src/Compiler/JMacro/QQ.hs

@@ -53,11 +53,19 @@ import Numeric (readHex)
 
 -- | QuasiQuoter for a block of JMacro statements.
 jmacro :: QuasiQuoter
-jmacro = QuasiQuoter {quoteExp = quoteJMExp, quotePat = quoteJMPat}
+jmacro = QuasiQuoter { quoteExp  = quoteJMExp
+                     , quotePat  = quoteJMPat
+                     , quoteDec  = error "jmacro: quoteDec"
+                     , quoteType = error "jmacro: quoteType"
+                     }
 
 -- | QuasiQuoter for a JMacro expression.
 jmacroE :: QuasiQuoter
-jmacroE = QuasiQuoter {quoteExp = quoteJMExpE, quotePat = quoteJMPatE}
+jmacroE = QuasiQuoter { quoteExp = quoteJMExpE
+                      , quotePat = quoteJMPatE
+                      , quoteDec  = error "jmacroE: quoteDec"
+                      , quoteType = error "jmacroE: quoteType"
+                      }
 
 quoteJMPat :: String -> TH.PatQ
 quoteJMPat s = case parseJM s of

src/Compiler/Program.hs

@@ -64,7 +64,6 @@ import Binary              ( openBinMem, put_, fingerprintBinMem )
 
 -- Standard Haskell libraries
 import System.IO
-import System.Environment
 import System.Exit
 import System.FilePath
 import Control.Monad
@@ -295,6 +294,7 @@ main' postLoadMode dflags0 args flagWarnings ghcjsSettings native = do
        DoInstallExecutable    -> liftIO (Ghcjs.installExecutable dflags6 ghcjsSettings $ map fst srcs) >> return True
        DoPrintObj obj         -> liftIO (Ghcjs.printObj obj) >> return True
        DoPrintDeps obj        -> liftIO (Ghcjs.printDeps obj) >> return True
+       DoBuildJsLibrary       -> liftIO (Ghcjs.buildJsLibrary dflags6 (map fst srcs) js_objs objs) >> return True
 
   liftIO $ dumpFinalStats dflags6
   return (skipJs || buildingSetup)
@@ -522,10 +522,12 @@ data PostLoadMode
   | DoInstallExecutable                   -- ghcjs --install-executable ? -o ?
   | DoPrintObj FilePath                   -- ghcjs --print-obj file
   | DoPrintDeps FilePath                  -- ghcjs --print-deps file
+  | DoBuildJsLibrary                      -- ghcjs --build-js-library
 
-doGenerateLib, doPrintRts :: Mode
+doGenerateLib, doPrintRts, doBuildJsLibrary :: Mode
 doGenerateLib = mkPostLoadMode DoGenerateLib
 doPrintRts = mkPostLoadMode DoPrintRts
+doBuildJsLibrary = mkPostLoadMode DoBuildJsLibrary
 
 doInstallExecutable :: Mode
 doInstallExecutable = mkPostLoadMode DoInstallExecutable
@@ -689,6 +691,7 @@ mode_flags =
   , Flag "-print-rts"              (PassFlag (setMode doPrintRts))
   , Flag "-numeric-ghc-version"    (PassFlag (setMode (showNumGhcVersionMode)))
   , Flag "-numeric-ghcjs-version"  (PassFlag (setMode (showNumVersionMode)))
+  , Flag "-build-js-library"       (PassFlag (setMode doBuildJsLibrary))
   ]
 
 setMode :: Mode -> String -> EwM ModeM ()

src/Compiler/Settings.hs

@@ -2,37 +2,21 @@
 
 module Compiler.Settings where
 
-import           Compiler.JMacro
-
 import           Gen2.Base
 
 import           Control.Applicative
 import           Control.Concurrent.MVar
-import           Control.Lens
 import           Control.Monad
 
-import           Data.Array
-import qualified Data.Binary         as DB
-import qualified Data.Binary.Get     as DB
-import qualified Data.Binary.Put     as DB
 import           Data.ByteString        (ByteString)
-import           Data.Function          (on)
-import           Data.HashMap.Strict    (HashMap)
-import qualified Data.HashMap.Strict as HM
-import           Data.List              (nubBy)
 import           Data.Map               (Map)
 import qualified Data.Map            as M
 import           Data.Monoid
-import           Data.Set               (Set)
-import qualified Data.Set            as S
-import           Data.Text              (Text)
 
 import           System.IO
 import           System.Process
 
 import           Module
-import           DynFlags
-import qualified DynFlags
 
 {- | We can link incrementally against a base bundle, where we assume
      that the symbols from the bundle and their dependencies have already

src/Compiler/Utils.hs

@@ -232,5 +232,5 @@ substPatterns single double = unmatched
     substDouble (var, val) = T.replace ("{{"<>var<>"}}") val
     unmatched l | T.null b || T.null d = l
                 | otherwise            = a <> unmatched d
-          where (a,b) = T.breakOn "{{" l
-                (c,d) = T.breakOn "}}" b
+          where (a,b)  = T.breakOn "{{" l
+                (_c,d) = T.breakOn "}}" b

src/Compiler/Variants.hs

@@ -15,7 +15,6 @@ import qualified Gen2.Object           as Gen2
 
 import           CostCentre            (CollectedCCs)
 import           DynFlags              (DynFlags)
-import           HscTypes              (CgGuts)
 import           Module                (Module (..), PackageId)
 import           StgSyn                (StgBinding)
 

src/Gen2/Base.hs

@@ -21,7 +21,6 @@ import           Data.Array
 import qualified Data.Binary          as DB
 import qualified Data.Binary.Get      as DB
 import qualified Data.Binary.Put      as DB
-import qualified Data.ByteString.Lazy as BL
 import           Data.HashMap.Strict  (HashMap)
 import qualified Data.HashMap.Strict  as HM
 import qualified Data.HashSet         as HS