[Git][ghc/ghc][wip/js-staging] Backpack: fix empty stubs
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Tue Sep 20 14:56:38 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
6192e4f3 by Sylvain Henry at 2022-09-20T16:59:36+02:00
Backpack: fix empty stubs
- - - - -
4 changed files:
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/Utils/Binary.hs
Changes:
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -610,7 +610,7 @@ compileForeign hsc_env lang stub_c = do
LangObjc -> viaCPipeline Cobjc
LangObjcxx -> viaCPipeline Cobjcxx
LangAsm -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp
- LangJs -> panic "GHC.Driver.Pipeline:compileForeign unimplemented"
+ LangJs -> \pe hsc_env ml fp -> Just <$> jsPipeline pe hsc_env ml fp
#if __GLASGOW_HASKELL__ < 811
RawObject -> panic "compileForeign: should be unreachable"
#endif
@@ -634,14 +634,27 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
-- and https://github.com/haskell/cabal/issues/2257
let logger = hsc_logger hsc_env
let tmpfs = hsc_tmpfs hsc_env
- empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
let home_unit = hsc_home_unit hsc_env
- src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
- writeFile empty_stub (showSDoc dflags (pprCode src))
- let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
- pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
- _ <- runPipeline (hsc_hooks hsc_env) pipeline
- return ()
+
+ case backendCodeOutput (backend dflags) of
+ JSCodeOutput -> do
+ empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
+ let src = ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
+ writeFile empty_stub (showSDoc dflags (pprCode src))
+ let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
+ pipeline = Just <$> jsPipeline pipe_env hsc_env (Just location) empty_stub
+ _ <- runPipeline (hsc_hooks hsc_env) pipeline
+ pure ()
+
+ _ -> do
+ empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
+ let src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
+ writeFile empty_stub (showSDoc dflags (pprCode src))
+ let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
+ pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
+ _ <- runPipeline (hsc_hooks hsc_env) pipeline
+ pure ()
+
{- Environment Initialisation -}
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -82,6 +82,7 @@ import GHC.Unit.Module.Env
import GHC.Driver.Env.KnotVars
import GHC.Driver.Config.Finder
import GHC.Rename.Names
+import GHC.StgToJS.Object (isJsObjectFile)
import Language.Haskell.Syntax.Module.Name
@@ -352,15 +353,20 @@ runJsPhase pipe_env hsc_env input_fn = do
let logger = hsc_logger hsc_env
let tmpfs = hsc_tmpfs hsc_env
let unit_env = hsc_unit_env hsc_env
- -- the header lets the linker recognize processed JavaScript files
- let header = "//JavaScript\n"
output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env Nothing
need_cpp <- jsFileNeedsCpp input_fn
tmp_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
+
+ -- the header lets the linker recognize processed JavaScript files
+ -- But don't add JavaScript header to object files!
+ is_js_obj <- isJsObjectFile input_fn
+ let header
+ | is_js_obj = ""
+ | otherwise = "//JavaScript\n"
+
-- if the input filename is the same as the output, then we've probably
-- generated the object ourselves, we leave the file alone
- -- FIXME (Luite 2022-08) we should make sure that we never add the JavaScript header to object files
when (input_fn /= output_fn) $ do
if need_cpp
then do
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -51,6 +51,7 @@ module GHC.StgToJS.Object
, readObjectUnits
, readObjectDeps
, isGlobalUnit
+ , isJsObjectFile
, Object(..)
, IndexEntry(..)
, Deps (..), BlockDeps (..), DepsLocation (..)
@@ -220,16 +221,27 @@ putObject bh mod_name deps os = do
pure (oiSymbols o,p)
pure idx
--- | Parse object header
-getObjectHeader :: BinHandle -> IO (Either String ModuleName)
-getObjectHeader bh = do
+-- | Test if the object file is a JS object
+isJsObjectFile :: FilePath -> IO Bool
+isJsObjectFile fp =
+ readBinMemN (length magic) fp >>= \case
+ Nothing -> pure False
+ Just bh -> getCheckMagic bh
+
+-- | Parse object magic
+getCheckMagic :: BinHandle -> IO Bool
+getCheckMagic bh = do
let go_magic = \case
[] -> pure True
(e:es) -> getByte bh >>= \case
c | fromIntegral (ord e) == c -> go_magic es
| otherwise -> pure False
+ go_magic magic
- is_magic <- go_magic magic
+-- | Parse object header
+getObjectHeader :: BinHandle -> IO (Either String ModuleName)
+getObjectHeader bh = do
+ is_magic <- getCheckMagic bh
case is_magic of
False -> pure (Left "invalid magic header")
True -> do
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -48,6 +48,7 @@ module GHC.Utils.Binary
writeBinMem,
readBinMem,
+ readBinMemN,
putAt, getAt,
forwardPut, forwardPut_, forwardGet,
@@ -287,11 +288,23 @@ writeBinMem (BinMem _ ix_r _ arr_r) fn = do
hClose h
readBinMem :: FilePath -> IO BinHandle
--- Return a BinHandle with a totally undefined State
readBinMem filename = do
h <- openBinaryFile filename ReadMode
filesize' <- hFileSize h
let filesize = fromIntegral filesize'
+ readBinMem_ filesize h
+
+readBinMemN :: Int -> FilePath -> IO (Maybe BinHandle)
+readBinMemN size filename = do
+ h <- openBinaryFile filename ReadMode
+ filesize' <- hFileSize h
+ let filesize = fromIntegral filesize'
+ if filesize < size
+ then pure Nothing
+ else Just <$> readBinMem_ size h
+
+readBinMem_ :: Int -> Handle -> IO BinHandle
+readBinMem_ filesize h = do
arr <- mallocForeignPtrBytes filesize
count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize
when (count /= filesize) $
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6192e4f38f785c66ff3ab29c7bf7d85d853ce69a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6192e4f38f785c66ff3ab29c7bf7d85d853ce69a
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/20220920/5bdd764c/attachment-0001.html>
More information about the ghc-commits
mailing list