[Git][ghc/ghc][wip/js-staging] 7 commits: Hadrian: disable shared libs for JS target
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Thu Sep 1 03:18:51 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
c3a9c0e8 by Sylvain Henry at 2022-09-01T02:19:22+02:00
Hadrian: disable shared libs for JS target
- - - - -
6a9726e3 by Sylvain Henry at 2022-09-01T02:20:37+02:00
Support -ddump-stg-final with the JS backend
- - - - -
d6da694a by Sylvain Henry at 2022-09-01T02:21:33+02:00
Add ticky_ghc0 flavour transformer to ticky stage1
- - - - -
0f98be8c by Sylvain Henry at 2022-09-01T03:40:58+02:00
Don't read object file when -ddump-js isn't passed
- - - - -
5340cd7b by Sylvain Henry at 2022-09-01T04:06:19+02:00
Object: remove dead code + renaming
- - - - -
5a2f2223 by Sylvain Henry at 2022-09-01T04:24:25+02:00
Object: replace SymbolTableR with Dictionary
- - - - -
b24014b8 by Sylvain Henry at 2022-09-01T04:48:50+02:00
Object: refactoring
- - - - -
5 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Object.hs
- hadrian/src/Flavour.hs
- hadrian/src/Oracles/Flag.hs
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1753,6 +1753,9 @@ hscGenHardCode hsc_env cgguts location output_filename = do
stub_c_exists = Nothing
foreign_fps = []
+ putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG
+ (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds)
+
-- do the unfortunately effectual business
stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename
return (output_filename, stub_c_exists, foreign_fps, cg_infos)
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -92,13 +92,14 @@ stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_
return (ts ++ luOtherExports u, luStat u)
deps <- genDependencyData this_mod lus
- lift $ Object.object' (moduleName this_mod) sym_table deps (map (second BL.fromStrict) p)
+ lift $ Object.writeObject' (moduleName this_mod) sym_table deps (map (second BL.fromStrict) p)
-- Doc to dump when -ddump-js is enabled
let mod_name = renderWithContext defaultSDocContext (ppr this_mod)
- o <- Object.readObject mod_name obj
- putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS
- $ vcat (fmap (docToSDoc . jsToDoc . Object.oiStat) o)
+ when (logHasDumpFlag logger Opt_D_dump_js) $ do
+ o <- Object.readObject mod_name obj
+ putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS
+ $ vcat (fmap (docToSDoc . jsToDoc . Object.oiStat) o)
BL.writeFile output_fn obj
@@ -240,7 +241,8 @@ serializeLinkableUnit :: HasDebugCallStack
-> G (Object.SymbolTable, [FastString], BS.ByteString)
serializeLinkableUnit _m st i ci si stat rawStat fe fi = do
!i' <- mapM idStr i
- !(!st', !o) <- lift $ Object.serializeStat st ci si stat rawStat fe fi
+ !(!st', !lo) <- lift $ Object.runPutS st $ \bh -> Object.putLinkableUnit bh ci si stat rawStat fe fi
+ let !o = BL.toStrict lo
return (st', i', o) -- deepseq results?
where
idStr i = itxt <$> identForId i
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -30,7 +30,10 @@
-- serialized [Text] -> ([ClosureInfo], JStat) blocks
--
-- file layout:
--- - header ["GHCJSOBJ", length of symbol table, length of dependencies, length of index]
+-- - magic "GHCJSOBJ"
+-- - length of symbol table
+-- - length of dependencies
+-- - length of index
-- - compiler version tag
-- - symbol table
-- - dependency info
@@ -40,8 +43,7 @@
-----------------------------------------------------------------------------
module GHC.StgToJS.Object
- ( object
- , object'
+ ( writeObject'
, readDepsFile
, readDepsFileEither
, hReadDeps
@@ -51,7 +53,7 @@ module GHC.StgToJS.Object
, readObjectFileKeys
, readObject
, readObjectKeys
- , serializeStat
+ , putLinkableUnit
, emptySymbolTable
, isGlobalUnit
, isExportsUnit -- XXX verify that this is used
@@ -62,6 +64,7 @@ module GHC.StgToJS.Object
, Deps (..), BlockDeps (..), DepsLocation (..)
, ExpFun (..), ExportedFun (..)
, versionTag, versionTagLength
+ , runPutS
)
where
@@ -118,12 +121,20 @@ data Header = Header
, hdrIdxLen :: !Int64
} deriving (Eq, Ord, Show)
+type BlockId = Int
+type BlockIds = IntSet
+
-- | dependencies for a single module
data Deps = Deps
- { depsModule :: !Module -- ^ module
- , depsRequired :: !IntSet -- ^ blocks that always need to be linked when this object is loaded (e.g. everything that contains initializer code or foreign exports)
- , depsHaskellExported :: !(Map ExportedFun Int) -- ^ exported Haskell functions -> block
- , depsBlocks :: !(Array Int BlockDeps) -- ^ info about each block
+ { depsModule :: !Module
+ -- ^ module
+ , depsRequired :: !BlockIds
+ -- ^ blocks that always need to be linked when this object is loaded (e.g.
+ -- everything that contains initializer code or foreign exports)
+ , depsHaskellExported :: !(Map ExportedFun BlockId)
+ -- ^ exported Haskell functions -> block
+ , depsBlocks :: !(Array BlockId BlockDeps)
+ -- ^ info about each block
} deriving (Generic)
instance Outputable Deps where
@@ -208,22 +219,18 @@ insertSymbol s st@(SymbolTable n t) =
Nothing -> (SymbolTable (n+1) (addToUniqMap t s n), n)
data ObjEnv = ObjEnv
- { oeSymbols :: SymbolTableR
- , _oeName :: String
- }
-
-data SymbolTableR = SymbolTableR
- { strText :: Array Int FastString
- , _strString :: Array Int String
+ { oeSymbols :: Dictionary
+ , _oeName :: String
}
-runGetS :: HasDebugCallStack => String -> SymbolTableR -> (BinHandle -> IO a) -> ByteString -> IO a
+runGetS :: HasDebugCallStack => String -> Dictionary -> (BinHandle -> IO a) -> ByteString -> IO a
runGetS name st m bl = do
let bs = B.toStrict bl
bh0 <- unpackBinBuffer (BS.length bs) bs
let bh = setUserData bh0 (newReadState undefined (readTable (ObjEnv st name)))
m bh
+-- temporary kludge to bridge BinHandle and ByteString
runPutS :: SymbolTable -> (BinHandle -> IO ()) -> IO (SymbolTable, ByteString)
runPutS st ps = do
bh0 <- openBinMem (1024 * 1024)
@@ -235,7 +242,7 @@ runPutS st ps = do
insertTable :: IORef SymbolTable -> BinHandle -> FastString -> IO ()
insertTable t_r bh s = do
t <- readIORef t_r
- let (t', n) = insertSymbol s t
+ let !(t', n) = insertSymbol s t
writeIORef t_r t'
put_ bh n
return ()
@@ -243,11 +250,7 @@ insertTable t_r bh s = do
readTable :: ObjEnv -> BinHandle -> IO FastString
readTable e bh = do
n :: Int <- get bh
- return $ strText (oeSymbols e) ! fromIntegral n
-
--- unexpected :: String -> GetS a
--- unexpected err = ask >>= \e ->
--- error (oeName e ++ ": " ++ err)
+ return $ (oeSymbols e) ! fromIntegral n
-- one toplevel block in the object file
data ObjUnit = ObjUnit
@@ -260,39 +263,23 @@ data ObjUnit = ObjUnit
, oiFImports :: [ForeignJSRef]
}
--- | build an object file
-object :: ModuleName -- ^ the module name
- -> Deps -- ^ the dependencies
- -> [ObjUnit] -- ^ units, the first unit is the module-global one
- -> IO ByteString -- ^ serialized object
-object mname ds units = do
- (xs, symbs) <- go emptySymbolTable units
- object' mname symbs ds xs
- where
- go st0 (ObjUnit sy cl si st str fe fi : ys) = do
- (st1, bs ) <- serializeStat st0 cl si st str fe fi
- (bss, st2) <- go st1 ys
- return ((sy,B.fromChunks [bs]):bss, st2)
- go st0 [] = return ([], st0)
-
-serializeStat :: SymbolTable
- -> [ClosureInfo]
- -> [StaticInfo]
- -> JStat
- -> FastString
- -> [ExpFun]
- -> [ForeignJSRef]
- -> IO (SymbolTable, BS.ByteString)
-serializeStat st ci si s sraw fe fi = do
- -- TODO: Did any of the Objectable instances previously used here interact with the `State`?
- (st', bs) <- runPutS st $ \bh -> do
- put_ bh ci
- put_ bh si
- put_ bh s
- put_ bh sraw
- put_ bh fe
- put_ bh fi
- return (st', B.toStrict bs)
+-- | Write a linkable unit
+putLinkableUnit
+ :: BinHandle
+ -> [ClosureInfo]
+ -> [StaticInfo]
+ -> JStat
+ -> FastString
+ -> [ExpFun]
+ -> [ForeignJSRef]
+ -> IO ()
+putLinkableUnit bh ci si s sraw fe fi = do
+ put_ bh ci
+ put_ bh si
+ put_ bh s
+ put_ bh sraw
+ put_ bh fe
+ put_ bh fi
-- tag to store the module name in the object file
moduleNameTag :: ModuleName -> BS.ByteString
@@ -304,20 +291,19 @@ moduleNameTag (ModuleName fs) = case compare len moduleNameLength of
!tag = SBS.fromShort (fs_sbs fs)
!len = n_chars fs
-object'
+writeObject'
:: ModuleName -- ^ module
-> SymbolTable -- ^ final symbol table
-> Deps -- ^ dependencies
-> [([FastString],ByteString)] -- ^ serialized units and their exported symbols, the first unit is module-global
-> IO ByteString
-object' mod_name st0 deps0 os = do
+writeObject' mod_name st0 deps0 os = do
(sti, idx) <- putIndex st0 os
let symbs = putSymbolTable sti
deps1 <- putDepsSection deps0
+ let bl = fromIntegral . B.length
let hdr = putHeader (Header (moduleNameTag mod_name) (bl symbs) (bl deps1) (bl idx))
return $ hdr <> symbs <> deps1 <> idx <> mconcat (map snd os)
- where
- bl = fromIntegral . B.length
putIndex :: SymbolTable -> [([FastString], ByteString)] -> IO (SymbolTable, ByteString)
putIndex st xs = runPutS st (\bh -> put_ bh $ zip symbols offsets)
@@ -325,13 +311,13 @@ putIndex st xs = runPutS st (\bh -> put_ bh $ zip symbols offsets)
(symbols, values) = unzip xs
offsets = scanl (+) 0 (map B.length values)
-getIndex :: HasDebugCallStack => String -> SymbolTableR -> ByteString -> IO [([FastString], Int64)]
+getIndex :: HasDebugCallStack => String -> Dictionary -> ByteString -> IO [([FastString], Int64)]
getIndex name st bs = runGetS name st get bs
putDeps :: SymbolTable -> Deps -> IO (SymbolTable, ByteString)
putDeps st deps = runPutS st (\bh -> put_ bh deps)
-getDeps :: HasDebugCallStack => String -> SymbolTableR -> ByteString -> IO Deps
+getDeps :: HasDebugCallStack => String -> Dictionary -> ByteString -> IO Deps
getDeps name st bs = runGetS name st get bs
toI32 :: Int -> Int32
@@ -451,7 +437,7 @@ readObjectKeys name p bs =
readObjectKeys' :: HasDebugCallStack
=> String
-> (Int -> [FastString] -> Bool)
- -> SymbolTableR
+ -> Dictionary
-> ByteString
-> ByteString
-> IO [ObjUnit]
@@ -466,8 +452,8 @@ readObjectKeys' name p st bsidx bsobjs = do
| otherwise = return Nothing
getOU bh = (,,,,,) <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh
-getSymbolTable :: HasDebugCallStack => ByteString -> SymbolTableR
-getSymbolTable bs = SymbolTableR (listArray (0,n-1) xs) (listArray (0,n-1) (map unpackFS xs))
+getSymbolTable :: HasDebugCallStack => ByteString -> Dictionary
+getSymbolTable bs = listArray (0,n-1) xs
where
(n,xs) = DB.runGet getter bs
getter :: DB.Get (Int, [FastString])
@@ -530,19 +516,6 @@ tag = put_
getTag :: BinHandle -> IO Word8
getTag = get
--- instance Binary ShortText where
--- put_ bh t = put_ bh (mkFastString $ ST.unpack t)
--- get bh = ST.pack . unpackFS <$> get bh
- -- put_ bh t = do
- -- symbols <- St.get
- -- let (symbols', n) = insertSymbol t symbols
- -- St.put symbols'
- -- lift (DB.putWord32le $ fromIntegral n)
- -- get bh = do
- -- st <- oeSymbols <$> ask
- -- n <- lift DB.getWord32le
- -- return (strText st ! fromIntegral n)
-
instance Binary JStat where
put_ bh (DeclStat i) = tag bh 1 >> put_ bh i
put_ bh (ReturnStat e) = tag bh 2 >> put_ bh e
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -41,6 +41,7 @@ flavourTransformers = M.fromList
[ "werror" =: werror
, "debug_info" =: enableDebugInfo
, "ticky_ghc" =: enableTickyGhc
+ , "ticky_ghc0" =: enableTickyGhc0
, "split_sections" =: splitSections
, "thread_sanitizer" =: enableThreadSanitizer
, "llvm" =: viaLlvmBackend
@@ -90,13 +91,14 @@ parseFlavour baseFlavours transformers str =
baseFlavour =
P.choice [ f <$ P.try (P.string (name f))
| f <- reverse (sortOn name baseFlavours)
- ] -- needed to parse e.g. "quick-debug" before "quick"
+ ] -- reverse&sort needed to parse e.g. "quick-debug" before "quick"
flavourTrans :: Parser (Flavour -> Flavour)
flavourTrans = do
void $ P.char '+'
P.choice [ trans <$ P.try (P.string nm)
- | (nm, trans) <- M.toList transformers
+ | (nm, trans) <- reverse $ sortOn fst $ M.toList transformers
+ -- reverse&sort needed to parse e.g. "ticky_ghc0" before "ticky_ghc"
]
-- | Add arguments to the 'args' of a 'Flavour'.
@@ -121,19 +123,28 @@ enableDebugInfo = addArgs $ notStage0 ? mconcat
enableTickyGhc :: Flavour -> Flavour
enableTickyGhc =
addArgs $ stage1 ? mconcat
- [ builder (Ghc CompileHs) ? ticky
- , builder (Ghc LinkHs) ? ticky
+ [ builder (Ghc CompileHs) ? tickyArgs
+ , builder (Ghc LinkHs) ? tickyArgs
]
- where
- ticky = mconcat
- [ arg "-ticky"
- , arg "-ticky-allocd"
- , arg "-ticky-dyn-thunk"
- -- You generally need STG dumps to interpret ticky profiles
- , arg "-ddump-to-file"
- , arg "-ddump-stg-final"
+
+-- | Enable the ticky-ticky profiler in stage1 GHC
+enableTickyGhc0 :: Flavour -> Flavour
+enableTickyGhc0 =
+ addArgs $ stage0 ? mconcat
+ [ builder (Ghc CompileHs) ? tickyArgs
+ , builder (Ghc LinkHs) ? tickyArgs
]
+tickyArgs :: Args
+tickyArgs = mconcat
+ [ arg "-ticky"
+ , arg "-ticky-allocd"
+ , arg "-ticky-dyn-thunk"
+ -- You generally need STG dumps to interpret ticky profiles
+ , arg "-ddump-to-file"
+ , arg "-ddump-stg-final"
+ ]
+
-- | Enable Core, STG, and (not C--) linting in all compilations with the stage1 compiler.
enableLinting :: Flavour -> Flavour
enableLinting =
=====================================
hadrian/src/Oracles/Flag.hs
=====================================
@@ -74,8 +74,9 @@ platformSupportsSharedLibs = do
windows <- isWinTarget
ppc_linux <- anyTargetPlatform [ "powerpc-unknown-linux" ]
solaris <- anyTargetPlatform [ "i386-unknown-solaris2" ]
+ javascript <- anyTargetArch [ "js" ]
solarisBroken <- flag SolarisBrokenShld
- return $ not (windows || ppc_linux || solaris && solarisBroken)
+ return $ not (windows || ppc_linux || (solaris && solarisBroken) || javascript)
-- | Does the target support the threaded runtime system?
targetSupportsSMP :: Action Bool
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b782512356aeded56d8191f1fe51348fecb69be...b24014b836cf1f3cd781a72ba70e268783a99e26
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b782512356aeded56d8191f1fe51348fecb69be...b24014b836cf1f3cd781a72ba70e268783a99e26
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/20220831/f13d7dde/attachment-0001.html>
More information about the ghc-commits
mailing list