[Git][ghc/ghc][wip/js-staging] Add support for JS files passed on the command line
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Thu Sep 29 14:20:10 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
5f549189 by Sylvain Henry at 2022-09-29T16:23:06+02:00
Add support for JS files passed on the command line
- - - - -
7 changed files:
- compiler/GHC/Driver/Pipeline.hs
- − compiler/GHC/StgToJS/Linker/Dynamic.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Utils/Monad.hs
- compiler/ghc.cabal.in
- testsuite/tests/ffi/should_run/all.T
- + testsuite/tests/ffi/should_run/fptr01_js.js
Changes:
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -79,7 +79,7 @@ import GHC.Linker.Static
import GHC.Linker.Static.Utils
import GHC.Linker.Types
-import GHC.StgToJS.Linker.Dynamic
+import GHC.StgToJS.Linker.Linker
import GHC.Utils.Outputable
import GHC.Utils.Error
@@ -105,8 +105,6 @@ import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.SourceError
-import GHC.StgToJS.Linker.Types ( newGhcjsEnv )
-
import GHC.Unit
import GHC.Unit.Env
--import GHC.Unit.Finder
@@ -445,11 +443,10 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt
case ghcLink dflags of
LinkBinary
| isJS -> do
- js_env <- liftIO newGhcjsEnv
let lc_cfg = mempty
let extra_js = mempty
let cfg = initStgToJSConfig dflags
- jsLinkBinary js_env lc_cfg cfg extra_js logger tmpfs dflags unit_env obj_files pkg_deps
+ jsLinkBinary lc_cfg cfg extra_js logger tmpfs dflags unit_env obj_files pkg_deps
| otherwise -> linkBinary logger tmpfs dflags unit_env obj_files pkg_deps
LinkStaticLib -> linkStaticLib logger dflags unit_env obj_files pkg_deps
LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env obj_files pkg_deps
@@ -572,11 +569,10 @@ doLink hsc_env o_files = do
NoLink -> return ()
LinkBinary
| isJS -> do
- js_env <- liftIO newGhcjsEnv
let lc_cfg = mempty
let extra_js = mempty
let cfg = initStgToJSConfig dflags
- jsLinkBinary js_env lc_cfg cfg extra_js logger tmpfs dflags unit_env o_files []
+ jsLinkBinary lc_cfg cfg extra_js logger tmpfs dflags unit_env o_files []
| otherwise -> linkBinary logger tmpfs dflags unit_env o_files []
LinkStaticLib -> linkStaticLib logger dflags unit_env o_files []
LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files []
=====================================
compiler/GHC/StgToJS/Linker/Dynamic.hs deleted
=====================================
@@ -1,115 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE LambdaCase #-}
-
------------------------------------------------------------------------------
--- |
--- Module : GHC.StgToJS.Linker.Dynamic
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file LICENSE)
---
--- Maintainer : Jeffrey Young <jeffrey.young at iohk.io>
--- Luite Stegeman <luite.stegeman at iohk.io>
--- Sylvain Henry <sylvain.henry at iohk.io>
--- Josh Meredith <josh.meredith at iohk.io>
--- Stability : experimental
---
--- Various utilities for building and loading dynamic libraries, to make
--- Template Haskell work in GHCJS
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Linker.Dynamic
- ( jsLinkBinary
- , jsLinkLib
- )
-where
-
-import GHC.Driver.Session
-
-import GHC.StgToJS.Types
-import GHC.StgToJS.Linker.Archive
-import GHC.StgToJS.Linker.Types
-import GHC.StgToJS.Linker.Utils
-import qualified GHC.StgToJS.Linker.Linker as JSLink
-
-import GHC.Linker.Types
-
-import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
-
-import GHC.Types.Unique.DFM
-import GHC.Types.Basic
-
-import GHC.Unit.Home.ModInfo
-import GHC.Unit.Env
-
-import Prelude
-
-import Control.Monad
-
-import qualified Data.ByteString as BS
-import Data.List ( nub )
-
-import System.FilePath
-import GHC.Platform.Ways
-import GHC.Utils.Logger
-import GHC.Utils.TmpFs (TmpFs)
-
----------------------------------------------------------------------------------
--- Link libraries
-
-jsLinkLib :: JSLinkConfig
- -> [FilePath] -- ^ extra JS files
- -> DynFlags
- -> Logger
- -> HomePackageTable
- -> IO SuccessFlag
-jsLinkLib settings jsFiles dflags _logger hpt
- | Just jsLib <- lcLinkJsLib settings = do
- let profSuff | WayProf `elem` ways dflags = "_p"
- | otherwise = ""
- libFileName = ("lib" ++ jsLib ++ profSuff) <.> "js_a"
- inOutputDir file =
- maybe file
- (</>file)
- (lcJsLibOutputDir settings `mplus` objectDir dflags)
- outputFile = inOutputDir libFileName
- jsFiles' = nub (lcJsLibSrcs settings ++ jsFiles)
- meta = Meta (opt_P dflags)
- jsEntries <- forM jsFiles' $ \file ->
- (JsSource file,) <$> BS.readFile file
- objEntries <- forM (eltsUDFM hpt) $ \hmi -> do
- let mod_name = moduleName . mi_module . hm_iface $ hmi
- files = maybe [] (\l -> [ o | DotO o <- linkableUnlinked l]) (hm_linkable hmi)
- -- fixme archive does not handle multiple files for a module yet
- forM files (fmap ((Object mod_name,)) . BS.readFile)
- writeArchive outputFile meta (concat objEntries ++ jsEntries)
- -- we don't use shared js_so libraries ourselves, but Cabal expects that we
- -- generate one when building with --dynamic-too. Just write an empty file
- when (gopt Opt_BuildDynamicToo dflags || WayDyn `elem` ways dflags) $ do
- let sharedLibFileName =
- "lib" ++ jsLib ++ "-ghcjs" ++ getCompilerVersion ++ profSuff <.> "js_so"
- sharedOutputFile = inOutputDir sharedLibFileName
- -- keep strip happy
- BS.writeFile sharedOutputFile =<< BS.readFile (topDir dflags </> "empty.o")
- return Succeeded
- | otherwise =
- return Succeeded
-
-jsLinkBinary :: GhcjsEnv
- -> JSLinkConfig
- -> StgToJSConfig
- -> [FilePath]
- -> Logger
- -> TmpFs
- -> DynFlags
- -> UnitEnv
- -> [FilePath]
- -> [UnitId]
- -> IO ()
-jsLinkBinary env lc_cfg cfg jsFiles logger tmpfs dflags u_env objs dep_pkgs =
- void $ JSLink.link env lc_cfg cfg logger tmpfs dflags u_env exe mempty dep_pkgs objs' jsFiles isRoot mempty
- where
- objs' = map ObjFile objs
- isRoot _ = True
- exe = jsExeFileName dflags
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -21,7 +21,7 @@
-----------------------------------------------------------------------------
module GHC.StgToJS.Linker.Linker
- ( link
+ ( jsLinkBinary
)
where
@@ -95,6 +95,8 @@ import GHC.Utils.Logger (Logger, logVerbAtLeast)
import GHC.Utils.TmpFs (TmpFs)
import GHC.Utils.Binary
import GHC.Utils.Ppr (Style(..), renderStyle, Mode(..))
+import GHC.Utils.CliOption
+import GHC.Utils.Monad
import GHC.Linker.Static.Utils (exeFileName)
@@ -119,6 +121,31 @@ newtype ArchiveState = ArchiveState { loadedArchives :: IORef (Map FilePath Ar.A
emptyArchiveState :: IO ArchiveState
emptyArchiveState = ArchiveState <$> newIORef M.empty
+jsLinkBinary
+ :: JSLinkConfig
+ -> StgToJSConfig
+ -> [FilePath]
+ -> Logger
+ -> TmpFs
+ -> DynFlags
+ -> UnitEnv
+ -> [FilePath]
+ -> [UnitId]
+ -> IO ()
+jsLinkBinary lc_cfg cfg js_srcs logger tmpfs dflags u_env objs dep_pkgs = do
+ -- additional objects to link are passed as FileOption ldInputs...
+ let cmdline_objs = [ f | FileOption _ f <- ldInputs dflags ]
+ -- discriminate JavaScript sources from real object files.
+ (cmdline_js_srcs, cmdline_js_objs) <- partitionM isJsFile cmdline_objs
+ let
+ objs' = map ObjFile (objs ++ cmdline_js_objs)
+ js_srcs' = js_srcs ++ cmdline_js_srcs
+ isRoot _ = True
+ exe = jsExeFileName dflags
+
+ env <- newGhcjsEnv
+ void $ link env lc_cfg cfg logger tmpfs dflags u_env exe mempty dep_pkgs objs' js_srcs' isRoot mempty
+
-- | link and write result to disk (jsexe directory)
link :: GhcjsEnv
-> JSLinkConfig
@@ -195,7 +222,7 @@ readShimsArchive ar_file = do
where
readEntry :: Ar.ArchiveEntry -> IO (Maybe B.ByteString)
readEntry ar_entry
- | isJsFile ar_entry = pure $ Just (Ar.filedata ar_entry)
+ | isJsArchiveEntry ar_entry = pure $ Just (Ar.filedata ar_entry)
| otherwise = pure Nothing
@@ -214,7 +241,7 @@ link' :: GhcjsEnv
-> (ExportedFun -> Bool) -- ^ functions from the objects to use as roots (include all their deps)
-> Set ExportedFun -- ^ extra symbols to link in
-> IO LinkResult
-link' env lc_cfg cfg logger unit_env target _include pkgs objFiles _jsFiles isRootFun extraStaticDeps
+link' env lc_cfg cfg logger unit_env target _include pkgs objFiles jsFiles isRootFun extraStaticDeps
= do
let ue_state = ue_units $ unit_env
(objDepsMap, objRequiredUnits) <- loadObjDeps objFiles
@@ -295,7 +322,7 @@ link' env lc_cfg cfg logger unit_env target _include pkgs objFiles _jsFiles isRo
-- retrieve code for dependencies
code <- collectDeps dep_map dep_units all_deps
- (outJs, metaSize, compactorState, stats) <- renderLinker lc_cfg cfg (baseCompactorState base) rts_wired_functions code
+ (outJs, metaSize, compactorState, stats) <- renderLinker lc_cfg cfg (baseCompactorState base) rts_wired_functions code jsFiles
let base' = Base compactorState (nub $ basePkgs base ++ bundle_diff)
(all_deps `S.union` baseUnits base)
@@ -334,8 +361,9 @@ renderLinker
-> CompactorState
-> Set ExportedFun
-> [ModuleCode] -- ^ linked code per module
+ -> [FilePath] -- ^ additional JS files
-> IO (FilePath -> IO (), Int64, CompactorState, LinkerStats)
-renderLinker settings cfg renamer_state rtsDeps code = do
+renderLinker settings cfg renamer_state rtsDeps code jsFiles = do
-- extract ModuleCode fields required to make a LinkedUnit
let code_to_linked_unit c = LinkedUnit
@@ -348,9 +376,12 @@ renderLinker settings cfg renamer_state rtsDeps code = do
let (renamer_state', compacted, meta) = compact settings cfg renamer_state
(map ((\(LexicalFastString f) -> f) . funSymbol) $ S.toList rtsDeps)
(map code_to_linked_unit code)
+
+ js_files_contents <- mconcat <$> mapM BL.readFile jsFiles
+
let
render_all fp = do
- BL.writeFile fp rendered_all
+ BL.writeFile fp (rendered_all <> js_files_contents)
-- render result into JS code
rendered_all = mconcat [mconcat rendered_mods, rendered_meta, rendered_exports]
@@ -776,14 +807,22 @@ 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"
+-- | Predicate to check that an entry in Ar is a JS source
+isJsArchiveEntry :: Ar.ArchiveEntry -> Bool
+isJsArchiveEntry entry = isJsBS (Ar.filedata entry)
+
+-- | Predicate to check that a file is a JS source
+isJsFile :: FilePath -> IO Bool
+isJsFile fp = isJsBS <$> B.readFile fp
+
+isJsBS :: B.ByteString -> Bool
+isJsBS bs = B.take (B.length jsHeader) bs == jsHeader
+ where
+ -- Header added to JS sources to discriminate them from other object files.
+ -- They all have .o extension but JS sources have this header.
+ jsHeader :: B.ByteString
+ jsHeader = "//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
prepareLoadedDeps :: [(Deps, DepsLocation)]
=====================================
compiler/GHC/Utils/Monad.hs
=====================================
@@ -21,6 +21,7 @@ module GHC.Utils.Monad
, maybeMapM
, whenM, unlessM
, filterOutM
+ , partitionM
) where
-------------------------------------------------------------------------------
@@ -237,6 +238,14 @@ filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a]
filterOutM p =
foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure [])
+-- | Monadic version of @partition@
+partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
+partitionM _ [] = pure ([], [])
+partitionM f (x:xs) = do
+ res <- f x
+ (as,bs) <- partitionM f xs
+ pure ([x | res]++as, [x | not res]++bs)
+
{- Note [The one-shot state monad trick]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Summary: many places in GHC use a state monad, and we really want those
=====================================
compiler/ghc.cabal.in
=====================================
@@ -662,7 +662,6 @@ Library
GHC.StgToJS.UnitUtils
GHC.StgToJS.Utils
GHC.StgToJS.Linker.Compactor
- GHC.StgToJS.Linker.Dynamic
GHC.StgToJS.Linker.Linker
GHC.StgToJS.Linker.Types
GHC.StgToJS.Linker.Utils
=====================================
testsuite/tests/ffi/should_run/all.T
=====================================
@@ -110,7 +110,8 @@ test('T2469', normal, compile_and_run, ['-optc-std=gnu99'])
test('T2594', [omit_ways(['ghci'])], compile_and_run, ['T2594_c.c'])
-test('fptr01', [omit_ways(['ghci'])], compile_and_run, ['fptr01_c.c'])
+test('fptr01', [omit_ways(['ghci'])], compile_and_run,
+ [ 'fptr01_js.js' if arch("js") else 'fptr01_c.c'])
test('fptr02', normal, compile_and_run, [''])
test('fptrfail01', [omit_ways(['ghci']), exit_code(1)], compile_and_run,
=====================================
testsuite/tests/ffi/should_run/fptr01_js.js
=====================================
@@ -0,0 +1,15 @@
+function h$f(i) {
+ console.log( "f" + i + "\n");
+}
+
+function h$g(i) {
+ console.log( "g" + i + "\n");
+}
+
+function h$h(i) {
+ console.log( "h" + i + "\n");
+}
+
+function h$f_env(env,i) {
+ console.log( "f_env " + env + " " + i + "\n");
+}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f549189115e33d07a3581b8ffd9dd7a51b58b69
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f549189115e33d07a3581b8ffd9dd7a51b58b69
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/20220929/db646502/attachment-0001.html>
More information about the ghc-commits
mailing list