[Git][ghc/ghc][wip/js-staging] 2 commits: Linker: refactor wired-in deps
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Fri Aug 26 16:38:37 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
b343306c by Sylvain Henry at 2022-08-26T18:20:41+02:00
Linker: refactor wired-in deps
- - - - -
cea5c8c5 by Sylvain Henry at 2022-08-26T18:37:07+02:00
Ppr: remove useless left padding for functions in JS dumps
- - - - -
2 changed files:
- compiler/GHC/JS/Ppr.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
Changes:
=====================================
compiler/GHC/JS/Ppr.hs
=====================================
@@ -137,7 +137,17 @@ defRenderJsS r = \case
| otherwise = text "catch" <> parens (jsToDocR r i) $$ braceNest' (jsToDocR r s1)
mbFinally | s2 == BlockStat [] = PP.empty
| otherwise = text "finally" $$ braceNest' (jsToDocR r s2)
- AssignStat i x -> jsToDocR r i <+> char '=' <+> jsToDocR r x
+ AssignStat i x -> case x of
+ -- special treatment for functions, otherwise there is too much left padding
+ -- (more than the length of the expression assigned to). E.g.
+ --
+ -- var long_variable_name = (function()
+ -- {
+ -- ...
+ -- });
+ --
+ ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"]
+ _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x
UOpStat op x
| isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x
| isPre op -> ftext (uOpText op) <> optParens r x
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -237,7 +237,7 @@ link' env lc_cfg cfg dflags logger unit_env target _include pkgs objFiles _jsFil
BaseFile file -> loadBase file
BaseState b -> return b
- (rdPkgs, rds) <- rtsDeps pkgs
+ let (rdPkgs, rds) = rtsDeps pkgs
-- c <- newMVar M.empty
let preload_units = preloadUnits (ue_units unit_env)
@@ -629,73 +629,103 @@ noStaticDeps :: StaticDeps
noStaticDeps = StaticDeps []
+-- | A helper function to read system dependencies that are hardcoded via a file
+-- path.
+diffDeps
+ :: [UnitId] -- ^ Packages that are already Linked
+ -> ([UnitId], Set ExportedFun) -- ^ New units and functions to link
+ -> ([UnitId], Set ExportedFun) -- ^ Diff
+diffDeps pkgs (deps_pkgs,deps_funs) =
+ ( filter linked_pkg deps_pkgs
+ , S.filter linked_fun deps_funs
+ )
+ where
+ linked_fun f = moduleUnitId (funModule f) `S.member` linked_pkgs
+ linked_pkg p = S.member p linked_pkgs
+ linked_pkgs = S.fromList pkgs
+
-- | dependencies for the RTS, these need to be always linked
-rtsDeps :: [UnitId] -> IO ([UnitId], Set ExportedFun)
-rtsDeps pkgs = readSystemDeps pkgs "rtsdeps.yaml"
+rtsDeps :: [UnitId] -> ([UnitId], Set ExportedFun)
+rtsDeps pkgs = diffDeps pkgs $
+ ( [baseUnitId, primUnitId]
+ , S.fromList $ concat
+ [ mkBaseFuns "GHC.Conc.Sync"
+ ["reportError"]
+ , mkBaseFuns "Control.Exception.Base"
+ ["nonTermination"]
+ , mkBaseFuns "GHC.Exception.Type"
+ [ "SomeException"
+ , "underflowException"
+ , "overflowException"
+ , "divZeroException"
+ ]
+ , mkBaseFuns "GHC.TopHandler"
+ [ "runMainIO"
+ , "topHandler"
+ ]
+ , mkBaseFuns "GHC.Base"
+ ["$fMonadIO"]
+ , mkBaseFuns "GHC.Maybe"
+ [ "Nothing"
+ , "Just"
+ ]
+ , mkBaseFuns "GHC.Ptr"
+ ["Ptr"]
+ , mkBaseFuns "GHC.JS.Prim"
+ [ "JSVal"
+ , "JSException"
+ , "$fShowJSException"
+ , "$fExceptionJSException"
+ , "resolve"
+ , "resolveIO"
+ , "toIO"
+ ]
+ , mkBaseFuns "GHC.JS.Prim.Internal"
+ [ "wouldBlock"
+ , "blockedIndefinitelyOnMVar"
+ , "blockedIndefinitelyOnSTM"
+ , "ignoreException"
+ , "setCurrentThreadResultException"
+ , "setCurrentThreadResultValue"
+ ]
+ , mkPrimFuns "GHC.Types"
+ [ ":"
+ , "[]"
+ ]
+ , mkPrimFuns "GHC.Tuple"
+ [ "(,)"
+ , "(,,)"
+ , "(,,,)"
+ , "(,,,,)"
+ , "(,,,,,)"
+ , "(,,,,,,)"
+ , "(,,,,,,,)"
+ , "(,,,,,,,,)"
+ , "(,,,,,,,,,)"
+ ]
+ ]
+ )
-- | dependencies for the Template Haskell, these need to be linked when running
-- Template Haskell (in addition to the RTS deps)
-thDeps :: [UnitId] -> IO ([UnitId], Set ExportedFun)
-thDeps pkgs = readSystemDeps pkgs "thdeps.yaml"
+thDeps :: [UnitId] -> ([UnitId], Set ExportedFun)
+thDeps pkgs = diffDeps pkgs $
+ ( [ baseUnitId ]
+ , S.fromList $ mkBaseFuns "GHC.JS.Prim.TH.Eval" ["runTHServer"]
+ )
--- | A helper function to read system dependencies that are hardcoded via a file
--- path.
-readSystemDeps :: [UnitId] -- ^ Packages that are already Linked
- -> FilePath -- ^ File to read
- -> IO ([UnitId], Set ExportedFun)
-readSystemDeps pkgs file = do
- (deps_pkgs, deps_funs) <- readSystemDeps' file
- pure ( filter (`S.member` linked_pkgs) deps_pkgs
- , S.filter (\fun ->
- moduleUnitId (funModule fun) `S.member` linked_pkgs) deps_funs
- )
- where
- linked_pkgs = S.fromList pkgs
-
-
-readSystemDeps' :: FilePath -> IO ([UnitId], Set ExportedFun)
-readSystemDeps' file
- -- hardcode contents to get rid of yaml dep
- -- XXX move runTHServer to some suitable wired-in package
- | file == "thdeps.yaml" = pure ( [ baseUnitId ]
- , S.fromList $ d baseUnitId "GHC.JS.Prim.TH.Eval" ["runTHServer"])
- | file == "rtsdeps.yaml" = pure ( [ baseUnitId
- , primUnitId
- ]
- , S.fromList $ concat
- [ d baseUnitId "GHC.Conc.Sync" ["reportError"]
- , d baseUnitId "Control.Exception.Base" ["nonTermination"]
- , d baseUnitId "GHC.Exception.Type"
- [ "SomeException"
- , "underflowException"
- , "overflowException"
- , "divZeroException"
- ]
- , d baseUnitId "GHC.TopHandler" ["runMainIO", "topHandler"]
- , d baseUnitId "GHC.Base" ["$fMonadIO"]
- , d baseUnitId "GHC.Maybe" ["Nothing", "Just"]
- , d baseUnitId "GHC.Ptr" ["Ptr"]
- , d primUnitId "GHC.Types" [":", "[]"]
- , d primUnitId "GHC.Tuple" ["(,)", "(,,)", "(,,,)", "(,,,,)", "(,,,,,)","(,,,,,,)", "(,,,,,,,)", "(,,,,,,,,)", "(,,,,,,,,,)"]
- , d baseUnitId "GHC.JS.Prim" ["JSVal", "JSException", "$fShowJSException", "$fExceptionJSException", "resolve", "resolveIO", "toIO"]
- , d baseUnitId "GHC.JS.Prim.Internal" ["wouldBlock", "blockedIndefinitelyOnMVar", "blockedIndefinitelyOnSTM", "ignoreException", "setCurrentThreadResultException", "setCurrentThreadResultValue"]
- ]
- )
- | otherwise = pure (mempty, mempty)
- where
+mkBaseFuns :: FastString -> [FastString] -> [ExportedFun]
+mkBaseFuns = mkExportedFuns baseUnitId
+
+mkPrimFuns :: FastString -> [FastString] -> [ExportedFun]
+mkPrimFuns = mkExportedFuns primUnitId
- d :: UnitId -> FastString -> [FastString] -> [ExportedFun]
- d uid mod symbols =
- let pkg_module = mkJsModule uid mod
- in map (ExportedFun pkg_module
- . LexicalFastString
- . mkJsSymbol pkg_module
- )
- symbols
-
- mkJsModule :: UnitId -> FastString -> Module
- mkJsModule uid mod = mkModule (RealUnit (Definite uid)) (mkModuleNameFS mod)
+mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun]
+mkExportedFuns uid mod_name symbols = map mk_fun symbols
+ where
+ mod = mkModule (RealUnit (Definite uid)) (mkModuleNameFS mod_name)
+ mk_fun sym = ExportedFun mod (LexicalFastString (mkJsSymbol mod sym))
-- | Make JS symbol corresponding to the given Haskell symbol in the given
-- module
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9f0d5c4e9e4b01508e32ea7660744b36e4f90e56...cea5c8c5b76ab76631fe0d1521334858051faea8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9f0d5c4e9e4b01508e32ea7660744b36e4f90e56...cea5c8c5b76ab76631fe0d1521334858051faea8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220826/727aa5dd/attachment-0001.html>
More information about the ghc-commits
mailing list