[Git][ghc/ghc][wip/js-staging] 3 commits: JS.Linker: Cleanup: remove unused functions/types
doyougnu (@doyougnu)
gitlab at gitlab.haskell.org
Mon Sep 26 21:35:33 UTC 2022
doyougnu pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
23b4ec7e by doyougnu at 2022-09-26T17:34:55-04:00
JS.Linker: Cleanup: remove unused functions/types
- - - - -
3238b3eb by doyougnu at 2022-09-26T17:34:56-04:00
JS.Rts.Types: remove dead code, docs
- - - - -
816fea7f by doyougnu at 2022-09-26T17:34:56-04:00
StgToJS.RTS: cleanup and more docs
- - - - -
4 changed files:
- compiler/GHC/JS/Make.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- compiler/GHC/StgToJS/Rts/Types.hs
Changes:
=====================================
compiler/GHC/JS/Make.hs
=====================================
@@ -103,6 +103,7 @@ module GHC.JS.Make
, returnStack, assignAllEqual, assignAll, assignAllReverseOrder
, declAssignAll
, nullStat, (.^)
+ , trace
-- ** Hash combinators
, jhEmpty
, jhSingle
@@ -527,10 +528,12 @@ assignAll xs ys = mconcat (zipWith (|=) xs ys)
assignAllReverseOrder :: [JExpr] -> [JExpr] -> JStat
assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys))
-
declAssignAll :: [Ident] -> [JExpr] -> JStat
declAssignAll xs ys = mconcat (zipWith (||=) xs ys)
+trace :: ToJExpr a => a -> JStat
+trace ex = appS "h$log" [toJExpr ex]
+
--------------------------------------------------------------------------------
-- Literals
@@ -661,6 +664,7 @@ allocClsA i = toJExpr (TxtI (clsCache ! i))
--------------------------------------------------------------------------------
-- New Identifiers
--------------------------------------------------------------------------------
+
-- | The 'ToSat' class is heavily used in the Introduction function. It ensures
-- that all identifiers in the EDSL are tracked and named with an 'IdentSupply'.
class ToSat a where
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -65,7 +65,7 @@ import Data.Int
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import Data.IORef
-import Data.List ( partition, nub, foldl', intercalate, group, sort
+import Data.List ( partition, nub, intercalate, group, sort
, groupBy, intersperse
)
import Data.Map.Strict (Map)
@@ -77,7 +77,7 @@ import Data.Word
import GHC.Generics (Generic)
-import System.FilePath (splitPath, (<.>), (</>), dropExtension)
+import System.FilePath ((<.>), (</>), dropExtension)
import System.Directory ( createDirectoryIfMissing
, doesFileExist
, getCurrentDirectory
@@ -390,9 +390,6 @@ linkerStats meta s =
module_stats = "code size per module (in bytes):\n\n" <> unlines (map (concatMap showMod) pkgMods)
-splitPath' :: FilePath -> [FilePath]
-splitPath' = map (filter (`notElem` ("/\\"::String))) . splitPath
-
getPackageArchives :: StgToJSConfig -> [([FilePath],[String])] -> IO [FilePath]
getPackageArchives cfg pkgs =
filterM doesFileExist [ p </> "lib" ++ l ++ profSuff <.> "a"
@@ -402,15 +399,6 @@ getPackageArchives cfg pkgs =
profSuff | csProf cfg = "_p"
| otherwise = ""
--- fixme the wired-in package id's we get from GHC we have no version
-getShims :: [FilePath] -> [UnitId] -> IO ([FilePath], [FilePath])
-getShims = panic "Panic from getShims: Shims not implemented! no to shims!"
--- getShims dflags extraFiles pkgDeps = do
--- (w,a) <- collectShims (getLibDir dflags </> "shims")
--- (map (convertPkg dflags) pkgDeps)
--- extraFiles' <- mapM canonicalizePath extraFiles
--- return (w, a++extraFiles')
-
{- | convenience: combine rts.js, lib.js, out.js to all.js that can be run
directly with node.js or SpiderMonkey jsshell
-}
@@ -478,16 +466,6 @@ writeRunner _settings out = do
perms <- getPermissions runner
setPermissions runner (perms {executable = True})
--- | write the manifest.webapp file that for firefox os
-writeWebAppManifest :: FilePath -- ^ top directory
- -> FilePath -- ^ output directory
- -> IO ()
-writeWebAppManifest top out = do
- e <- doesFileExist manifestFile
- unless e $ B.readFile (top </> "manifest.webapp") >>= B.writeFile manifestFile
- where
- manifestFile = out </> "manifest.webapp"
-
rtsExterns :: FastString
rtsExterns =
"// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" <>
@@ -498,10 +476,6 @@ writeExterns :: FilePath -> IO ()
writeExterns out = writeFile (out </> "all.js.externs")
$ unpackFS rtsExterns
--- | get all functions in a module
-modFuns :: Deps -> [ExportedFun]
-modFuns (Deps _m _r e _b) = M.keys e
-
-- | get all dependencies for a given set of roots
getDeps :: Map Module Deps -- ^ loaded deps
-> Set LinkableUnit -- ^ don't link these blocks
@@ -638,18 +612,6 @@ readArObject ar_state mod ar_file = do
go_entries entries
-{- | Static dependencies are symbols that need to be linked regardless
- of whether the linked program refers to them. For example
- dependencies that the RTS uses or symbols that the user program
- refers to directly
- -}
-newtype StaticDeps =
- StaticDeps { unStaticDeps :: [(FastString, FastString)] -- module/symbol
- }
-
-noStaticDeps :: StaticDeps
-noStaticDeps = StaticDeps []
-
-- | A helper function to read system dependencies that are hardcoded via a file
-- path.
@@ -736,13 +698,16 @@ thDeps pkgs = diffDeps pkgs $
, S.fromList $ mkBaseFuns "GHC.JS.Prim.TH.Eval" ["runTHServer"]
)
-
+-- | Export the functions in base
mkBaseFuns :: FastString -> [FastString] -> [ExportedFun]
mkBaseFuns = mkExportedFuns baseUnitId
+-- | Export the Prim functions
mkPrimFuns :: FastString -> [FastString] -> [ExportedFun]
mkPrimFuns = mkExportedFuns primUnitId
+-- | Given a @UnitId@, a module name, and a set of symbols in the module,
+-- package these into an @ExportedFun at .
mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns uid mod_name symbols = map mk_fun symbols
where
@@ -765,67 +730,12 @@ mkJsSymbol mod s = mkFastString $ mconcat
will all come from the same version, but it's undefined which one.
-}
-type SDep = (FastString, FastString) -- ^ module/symbol
-
-staticDeps :: UnitEnv
- -> [(FastString, Module)] -- ^ wired-in package names / keys
- -> StaticDeps -- ^ deps from yaml file
- -> (StaticDeps, Set UnitId, Set ExportedFun)
- -- ^ the StaticDeps contains the symbols
- -- for which no package could be found
-staticDeps unit_env wiredin sdeps = mkDeps sdeps
- where
- u_st = ue_units unit_env
- mkDeps (StaticDeps ds) =
- let (u, p, r) = foldl' resolveDep ([], S.empty, S.empty) ds
- in (StaticDeps u, closePackageDeps u_st p, r)
- resolveDep :: ([SDep], Set UnitId, Set ExportedFun)
- -> SDep
- -> ([SDep], Set UnitId, Set ExportedFun)
- resolveDep (unresolved, pkgs, resolved) dep@(mod_name, s) =
- -- lookup our module in wiredin names
- case lookup mod_name wiredin of
- -- we didn't find the module in wiredin so add to unresolved
- Nothing -> ( dep : unresolved, pkgs, resolved)
- -- this is a wired in module
- Just mod ->
- let mod_uid = moduleUnitId mod
- in case lookupUnitId u_st mod_uid of
- -- couldn't find the uid for this wired in package so explode
- Nothing -> pprPanic ("Package key for wired-in dependency could not be found.`"
- ++ "I looked for: "
- ++ unpackFS mod_name
- ++ " received " ++ moduleNameString (moduleName mod)
- ++ " but could not find: " ++ unitString mod_uid
- ++ " in the UnitState."
- ++ " Here is too much info for you: ")
- $ pprWithUnitState u_st (ppr mod)
- -- we are all good, add the uid to the package set, construct
- -- its symbols on the fly and add the module to exported symbol
- -- set
- Just _ -> ( unresolved
- , S.insert mod_uid pkgs
- , S.insert (ExportedFun mod
- . LexicalFastString $ mkJsSymbol mod s) resolved
- )
-
-closePackageDeps :: UnitState -> Set UnitId -> Set UnitId
-closePackageDeps u_st pkgs
- | S.size pkgs == S.size pkgs' = pkgs
- | otherwise = closePackageDeps u_st pkgs'
- where
- pkgs' = pkgs `S.union` S.fromList (concatMap deps $ S.toList pkgs)
- notFound = error "closePackageDeps: package not found"
- deps :: UnitId -> [UnitId]
- deps = unitDepends
- . fromMaybe notFound
- . lookupUnitId u_st
-
--- read all dependency data from the to-be-linked files
+-- | read all dependency data from the to-be-linked files
loadObjDeps :: [LinkedObj] -- ^ object files to link
-> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
loadObjDeps objs = prepareLoadedDeps <$> mapM readDepsFile' objs
+-- | Load dependencies for the Linker from Ar
loadArchiveDeps :: GhcjsEnv
-> [FilePath]
-> IO ( Map Module (Deps, DepsLocation)
@@ -859,9 +769,11 @@ loadArchiveDeps' archives = do
let !deps = objDeps obj
pure $ Just (deps, ArchiveFile ar_file)
+-- | Predicate to check that an entry in Ar is a JS payload
isJsFile :: Ar.ArchiveEntry -> Bool
isJsFile = checkEntryHeader "//JavaScript"
+-- | Ensure that the entry header to the Archive object is sound.
checkEntryHeader :: B.ByteString -> Ar.ArchiveEntry -> Bool
checkEntryHeader header entry =
B.take (B.length header) (Ar.filedata entry) == header
@@ -879,7 +791,7 @@ prepareLoadedDeps deps =
requiredUnits :: Deps -> [LinkableUnit]
requiredUnits d = map (depsModule d,) (IS.toList $ depsRequired d)
--- read dependencies from an object that might have already been into memory
+-- | read dependencies from an object that might have already been into memory
-- pulls in all Deps from an archive
readDepsFile' :: LinkedObj -> IO (Deps, DepsLocation)
readDepsFile' = \case
@@ -889,8 +801,3 @@ readDepsFile' = \case
ObjFile file -> do
deps <- readObjectDeps file
pure (deps,ObjectFile file)
-
--- generateBase :: FilePath -> Base -> IO ()
--- generateBase outDir b =
--- BL.writeFile (outDir </> "out.base.symbs") (renderBase b)
-
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -17,7 +17,9 @@
-- Top level driver of the JavaScript Backend RTS. This file is an
-- implementation of the JS RTS for the JS backend written as an EDSL in
-- Haskell. It assumes the existence of pre-generated JS functions, included as
--- js-sources...
+-- js-sources in base. These functions are similarly assumed for non-inline
+-- Primops, See 'GHC.StgToJS.Prim'. Most of the elements in this module are
+-- constants in Haskell Land which define pieces of the JS RTS.
--
-----------------------------------------------------------------------------
@@ -46,23 +48,37 @@ import Data.Monoid
import Data.Char (toLower, toUpper)
import qualified Data.Bits as Bits
+-- | The garbageCollector resets registers and result variables.
garbageCollector :: JStat
garbageCollector =
mconcat [ TxtI "h$resetRegisters" ||= jLam (mconcat $ map resetRegister [minBound..maxBound])
, TxtI "h$resetResultVars" ||= jLam (mconcat $ map resetResultVar [minBound..maxBound])
]
-
+-- | Reset the register 'r' in JS Land. Note that this "resets" by setting the
+-- register to a dummy variable called "null", /not/ by setting to JS's nil
+-- value.
resetRegister :: StgReg -> JStat
resetRegister r = toJExpr r |= null_
+-- | Reset the return variable 'r' in JS Land. Note that this "resets" by
+-- setting the register to a dummy variable called "null", /not/ by setting to
+-- JS's nil value.
resetResultVar :: StgRet -> JStat
resetResultVar r = toJExpr r |= null_
-{-
- use h$c1, h$c2, h$c3, ... h$c24 instead of making objects manually so layouts
- and fields can be changed more easily
- -}
+-- | Define closures based on size, these functions are syntactic sugar, e.g., a
+-- Haskell function which generates some useful JS. Each Closure constructor
+-- follows the naming convention h$cN, where N is a natural number. For example,
+-- h$c (with the nat omitted) is a JS Land Constructor for a closure in JS land
+-- which has a single entry function 'f', and no fields; identical to h$c0. h$c1
+-- is a JS Land Constructor for a closure with an entry function 'f', and a
+-- /single/ field 'x1', 'Just foo' is an example of this kind of closure. h$c2
+-- is a JS Land Constructor for a closure with an entry function and two data
+-- fields: 'x1' and 'x2'. And so on. Note that this has JIT performance
+-- implications; you should use h$c1, h$c2, h$c3, ... h$c24 instead of making
+-- objects manually so layouts and fields can be changed more easily and so the
+-- JIT can optimize better.
closureConstructors :: StgToJSConfig -> JStat
closureConstructors s = BlockStat
[ declClsConstr "h$c" ["f"] $ Closure
@@ -192,6 +208,7 @@ closureConstructors s = BlockStat
extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds
fun = JFunc (map TxtI ds) (checkD <> returnS extra_args)
+-- | JS Payload to perform stack manipulation in the RTS
stackManip :: JStat
stackManip = mconcat (map mkPush [1..32]) <>
mconcat (map mkPpush [1..255])
@@ -242,6 +259,7 @@ bhLneStats _s p frameSize =
]
+-- | JS payload to declare the registers
declRegs :: JStat
declRegs =
mconcat [ TxtI "h$regs" ||= toJExpr (JList [])
@@ -253,6 +271,7 @@ declRegs =
declReg r = (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) r
<> BlockStat [AssignStat (toJExpr r) (ValExpr (JInt 0))] -- [j| `r` = 0; |]
+-- | JS payload to define getters and setters on the registers.
regGettersSetters :: JStat
regGettersSetters =
mconcat [ TxtI "h$getReg" ||= jLam (\n -> SwitchStat n getRegCases mempty)
@@ -264,6 +283,7 @@ regGettersSetters =
setRegCases v =
map (\r -> (toJExpr (jsRegToInt r), (toJExpr r |= toJExpr v) <> returnS undefined_)) regsFromR1
+-- | JS payload that defines the functions to load each register
loadRegs :: JStat
loadRegs = mconcat $ map mkLoad [1..32]
where
@@ -275,9 +295,9 @@ loadRegs = mconcat $ map mkLoad [1..32]
fun = JFunc args (mconcat assign)
in fname ||= toJExpr fun
--- assign registers R1 ... Rn
--- assigns Rn first
-assignRegs :: StgToJSConfig -> [JExpr] -> JStat
+-- | Assign registers R1 ... Rn in descending order, that is assign Rn first.
+-- This function uses the 'assignRegs'' array to construct functions which set
+-- the registers. assignRegs :: StgToJSConfig -> [JExpr] -> JStat
assignRegs _ [] = mempty
assignRegs s xs
| l <= 32 && not (csInlineLoadRegs s)
@@ -287,15 +307,24 @@ assignRegs s xs
where
l = length xs
+-- | JS payload which defines an array of function symbols that set N registers
+-- from M parameters. For example, h$l2 compiles to:
+-- @
+-- function h$l4(x1, x2, x3, x4) {
+-- h$r4 = x1;
+-- h$r3 = x2;
+-- h$r2 = x3;
+-- h$r1 = x4;
+-- };
+-- @
assignRegs' :: Array Int Ident
assignRegs' = listArray (1,32) (map (TxtI . mkFastString . ("h$l"++) . show) [(1::Int)..32])
+-- | JS payload to declare return variables.
declRets :: JStat
declRets = mconcat $ map (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) (enumFrom Ret1)
-trace :: ToJExpr a => a -> JStat
-trace ex = appS "h$log" [toJExpr ex]
-
+-- | JS payload defining the types closures.
closureTypes :: JStat
closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> closureTypeName
where
@@ -311,6 +340,7 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo
ifCT :: JExpr -> ClosureType -> JStat
ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct)))
+-- | JS payload declaring the RTS functions.
rtsDecls :: JStat
rtsDecls = jsSaturate (Just "h$RTSD") $
mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread
@@ -325,15 +355,19 @@ rtsDecls = jsSaturate (Just "h$RTSD") $
, declRegs
, declRets]
+-- | print the embedded RTS to a String
rtsText :: StgToJSConfig -> String
rtsText = show . pretty . rts
+-- | print the RTS declarations to a String.
rtsDeclsText :: String
rtsDeclsText = show . pretty $ rtsDecls
+-- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform'
rts :: StgToJSConfig -> JStat
rts = jsSaturate (Just "h$RTS") . rts'
+-- | JS Payload which defines the embedded RTS.
rts' :: StgToJSConfig -> JStat
rts' s =
mconcat [ closureConstructors s
=====================================
compiler/GHC/StgToJS/Rts/Types.hs
=====================================
@@ -26,35 +26,32 @@ import GHC.JS.Syntax
import GHC.StgToJS.Regs
import GHC.StgToJS.Types
-import GHC.Utils.Monad.State.Strict
-
-import GHC.Data.FastString
-
+--------------------------------------------------------------------------------
+-- Syntactic Sugar for some Utilities we want in JS land
+--------------------------------------------------------------------------------
+-- | Syntactic sugar, i.e., a Haskell function which generates useful JS code.
+-- Given a @JExpr@, 'ex', inject a trace statement on 'ex' in the compiled JS
+-- program
traceRts :: StgToJSConfig -> JExpr -> JStat
-traceRts s ex = jStatIf (csTraceRts s) (appS "h$log" [ex])
+traceRts s ex | (csTraceRts s) = appS "h$log" [ex]
+ | otherwise = mempty
+-- | Syntactic sugar. Given a @JExpr@, 'ex' which is assumed to be a predicate,
+-- and a message 'm', assert that 'not ex' is True, if not throw an exception in
+-- JS land with message 'm'.
assertRts :: ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat
-assertRts s ex m = jStatIf (csAssertRts s)
- (jwhenS (UOpExpr NotOp ex) (appS "throw" [toJExpr m]))
-
-jStatIf :: Bool -> JStat -> JStat
-jStatIf True s = s
-jStatIf _ _ = mempty
+assertRts s ex m | csAssertRts s = jwhenS (UOpExpr NotOp ex) (appS "throw" [toJExpr m])
+ | otherwise = mempty
+-- | name of the closure 'c'
clName :: JExpr -> JExpr
clName c = c .^ "n"
+-- | Type name of the closure 'c'
clTypeName :: JExpr -> JExpr
clTypeName c = app "h$closureTypeName" [c .^ "t"]
-type C = State GenState JStat
-
-assertRtsStat :: C -> C
-assertRtsStat stat = do
- s <- gets gsSettings
- if csAssertRts s then stat else return mempty
-
-- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers)
stackFrameSize :: JExpr -- ^ assign frame size to this
-> JExpr -- ^ stack frame header function
@@ -71,33 +68,11 @@ stackFrameSize tgt f =
]
))
--- some utilities do do something with a range of regs
--- start or end possibly supplied as javascript expr
-withRegs :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat
-withRegs start end f = mconcat $ map f [start..end]
-
-withRegs' :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat
-withRegs' start end = withRegs start end
-
--- start from js expr, start is guaranteed to be at least min
--- from low to high (fallthrough!)
-withRegsS :: JExpr -> StgReg -> StgReg -> Bool -> (StgReg -> JStat) -> JStat
-withRegsS start min end fallthrough f =
- SwitchStat start (map mkCase [min..end]) mempty
- where
- brk | fallthrough = mempty
- | otherwise = BreakStat Nothing
- mkCase r = let stat = f r
- in (toJExpr r, mconcat [stat , stat , brk])
+--------------------------------------------------------------------------------
+-- Register utilities
+--------------------------------------------------------------------------------
--- end from js expr, from high to low
-withRegsRE :: StgReg -> JExpr -> StgReg -> Bool -> (StgReg -> JStat) -> JStat
-withRegsRE start end max fallthrough f =
- SwitchStat end (reverse $ map mkCase [start..max]) mempty
- where
- brk | fallthrough = mempty
- | otherwise = BreakStat Nothing
- mkCase r = (toJExpr (fromEnum r), mconcat [f r , brk])
-
-jsVar :: String -> JExpr
-jsVar = ValExpr . JVar . TxtI . mkFastString
+-- | Perform the computation 'f', on the range of registers bounded by 'start'
+-- and 'end'.
+withRegs :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat
+withRegs start end f = mconcat $ fmap f [start..end]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/23c4c22834e5952a90294d7aefa074a422cc4ad7...816fea7ff6ef3af4d4a9e49c8874b746efbc01ec
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/23c4c22834e5952a90294d7aefa074a422cc4ad7...816fea7ff6ef3af4d4a9e49c8874b746efbc01ec
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/20220926/72cb3f4b/attachment-0001.html>
More information about the ghc-commits
mailing list