[Git][ghc/ghc][wip/js-staging] 4 commits: Remove dubious JSLinkConfig instances
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Wed Nov 9 12:30:54 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
257c8175 by Sylvain Henry at 2022-11-09T13:27:29+01:00
Remove dubious JSLinkConfig instances
- - - - -
7bf1e700 by Sylvain Henry at 2022-11-09T13:27:59+01:00
Hadrian: tweak validate flavour to avoid building threaded
- - - - -
feef116b by Sylvain Henry at 2022-11-09T13:29:35+01:00
Fix warnings in base
- - - - -
4556033e by Sylvain Henry at 2022-11-09T13:34:25+01:00
Add some HasDebugCallStack
- - - - -
10 changed files:
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/StgToJS/Linker/Types.hs
- compiler/GHC/StgToJS/Utils.hs
- hadrian/src/Settings/Flavours/Validate.hs
- libraries/base/GHC/Conc/IO.hs
- libraries/base/GHC/IO/FD.hs
- libraries/base/GHC/TopHandler.hs
- libraries/base/System/CPUTime.hsc
- + libraries/base/System/CPUTime/Javascript.hs
- libraries/base/base.cabal
Changes:
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -83,6 +83,7 @@ import GHC.Linker.Static.Utils
import GHC.Linker.Types
import GHC.StgToJS.Linker.Linker
+import GHC.StgToJS.Linker.Types (defaultJSLinkConfig)
import GHC.Utils.Outputable
import GHC.Utils.Error
@@ -364,8 +365,8 @@ link :: GhcLink -- ^ interactive or batch
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.
-link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt
- = case linkHook hooks of
+link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt =
+ case linkHook hooks of
Nothing -> case ghcLink of
NoLink -> return Succeeded
LinkBinary -> normal_link
@@ -448,7 +449,7 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt
case ghcLink dflags of
LinkBinary
| isJS -> do
- let lc_cfg = mempty
+ let lc_cfg = defaultJSLinkConfig
let extra_js = mempty
let cfg = initStgToJSConfig dflags
jsLinkBinary lc_cfg cfg extra_js logger dflags unit_env obj_files pkg_deps
@@ -574,7 +575,7 @@ doLink hsc_env o_files = do
NoLink -> return ()
LinkBinary
| isJS -> do
- let lc_cfg = mempty
+ let lc_cfg = defaultJSLinkConfig
let extra_js = mempty
let cfg = initStgToJSConfig dflags
jsLinkBinary lc_cfg cfg extra_js logger dflags unit_env o_files []
=====================================
compiler/GHC/StgToJS/Linker/Types.hs
=====================================
@@ -22,6 +22,7 @@ module GHC.StgToJS.Linker.Types
( GhcjsEnv (..)
, newGhcjsEnv
, JSLinkConfig (..)
+ , defaultJSLinkConfig
, generateAllJs
, LinkedObj (..)
, LinkableUnit
@@ -60,26 +61,14 @@ data JSLinkConfig = JSLinkConfig
generateAllJs :: JSLinkConfig -> Bool
generateAllJs s = not (lcOnlyOut s) && not (lcNoRts s)
-instance Monoid JSLinkConfig where
- mempty = JSLinkConfig
- { lcNoJSExecutables = False
- , lcNoHsMain = False
- , lcOnlyOut = False
- , lcNoRts = False
- , lcNoStats = False
- }
-
-instance Semigroup JSLinkConfig where
- (<>) c1 c2 =
- let comb :: (a -> a -> a) -> (JSLinkConfig -> a) -> a
- comb f a = f (a c1) (a c2)
- in JSLinkConfig
- { lcNoJSExecutables = comb (||) lcNoJSExecutables
- , lcNoHsMain = comb (||) lcNoHsMain
- , lcOnlyOut = comb (||) lcOnlyOut
- , lcNoRts = comb (||) lcNoRts
- , lcNoStats = comb (||) lcNoStats
- }
+defaultJSLinkConfig :: JSLinkConfig
+defaultJSLinkConfig = JSLinkConfig
+ { lcNoJSExecutables = False
+ , lcNoHsMain = False
+ , lcOnlyOut = False
+ , lcNoRts = False
+ , lcNoStats = False
+ }
--------------------------------------------------------------------------------
-- Linker Environment
=====================================
compiler/GHC/StgToJS/Utils.hs
=====================================
@@ -21,7 +21,7 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable
-assignToTypedExprs :: [TypedExpr] -> [JExpr] -> JStat
+assignToTypedExprs :: HasDebugCallStack => [TypedExpr] -> [JExpr] -> JStat
assignToTypedExprs tes es =
assignAllEqual (concatMap typex_expr tes) es
@@ -30,7 +30,7 @@ assignTypedExprs tes es =
-- TODO: check primRep (typex_typ) here?
assignToTypedExprs tes (concatMap typex_expr es)
-assignToExprCtx :: ExprCtx -> [JExpr] -> JStat
+assignToExprCtx :: HasDebugCallStack => ExprCtx -> [JExpr] -> JStat
assignToExprCtx ctx es = assignToTypedExprs (ctxTarget ctx) es
-- | Assign first expr only (if it exists), performing coercions between some
=====================================
hadrian/src/Settings/Flavours/Validate.hs
=====================================
@@ -18,9 +18,11 @@ validateFlavour = enableLinting $ werror $ defaultFlavour
, notStage0 ? platformSupportsSharedLibs ? pure [dynamic]
]
, rtsWays = Set.fromList <$>
- mconcat [ pure [vanilla, threaded, debug, threadedDebug]
- , notStage0 ? platformSupportsSharedLibs ? pure
- [ dynamic, threadedDynamic, debugDynamic, threadedDebugDynamic
+ mconcat [ pure [vanilla, debug]
+ , targetSupportsSMP ? pure [threaded, threadedDebug]
+ , notStage0 ? platformSupportsSharedLibs ? mconcat
+ [ pure [ dynamic, debugDynamic ]
+ , targetSupportsSMP ? pure [ threadedDynamic, threadedDebugDynamic ]
]
]
, ghcDebugAssertions = (<= Stage1)
=====================================
libraries/base/GHC/Conc/IO.hs
=====================================
@@ -215,13 +215,15 @@ threadDelay time
-- 2147483647 μs, less than 36 minutes.
--
registerDelay :: Int -> IO (TVar Bool)
-registerDelay usecs
+registerDelay _usecs
#if defined(mingw32_HOST_OS)
- | isWindowsNativeIO = Windows.registerDelay usecs
- | threaded = Windows.registerDelay usecs
+ | isWindowsNativeIO = Windows.registerDelay _usecs
+ | threaded = Windows.registerDelay _usecs
#elif !defined(js_HOST_ARCH)
- | threaded = Event.registerDelay usecs
+ | threaded = Event.registerDelay _usecs
#endif
| otherwise = errorWithoutStackTrace "registerDelay: requires -threaded"
+#if !defined(js_HOST_ARCH)
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
+#endif
=====================================
libraries/base/GHC/IO/FD.hs
=====================================
@@ -658,15 +658,13 @@ writeRawBufferPtrNoBlock loc !fd !buf !off !len
safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
#endif
+#ifndef js_HOST_ARCH
isNonBlocking :: FD -> Bool
-#ifdef js_HOST_ARCH
-isNonBlocking _ = True
-#else
isNonBlocking fd = fdIsNonBlocking fd /= 0
-#endif
foreign import ccall unsafe "fdReady"
unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt
+#endif
#else /* mingw32_HOST_OS.... */
@@ -756,7 +754,9 @@ foreign import WINDOWS_CCONV safe "send"
#endif
+#ifndef js_HOST_ARCH
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
+#endif
-- -----------------------------------------------------------------------------
-- utils
=====================================
libraries/base/GHC/TopHandler.hs
=====================================
@@ -46,6 +46,7 @@ import GHC.Weak
#if defined(mingw32_HOST_OS)
import GHC.ConsoleHandler
+#elif defined(js_HOST_ARCH)
#else
import Data.Dynamic (toDyn)
#endif
=====================================
libraries/base/System/CPUTime.hsc
=====================================
@@ -1,8 +1,5 @@
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, CApiFFI #-}
-##if defined(js_HOST_ARCH)
-{-# LANGUAGE JavaScriptFFI #-}
-##endif
-----------------------------------------------------------------------------
-- |
@@ -33,31 +30,13 @@ module System.CPUTime
import System.IO.Unsafe (unsafePerformIO)
-##if defined(js_HOST_ARCH)
-import qualified System.CPUTime.Unsupported as I
-
-cpuTimePrecision :: Integer
-cpuTimePrecision = toInteger js_cpuTimePrecision
-
-getCPUTime :: IO Integer
-getCPUTime = do
- t <- js_getCPUTime
- if t == -1 then I.getCPUTime
- else pure (1000 * round t)
-
-foreign import javascript unsafe
- "(() => { return h$cpuTimePrecision; })"
- js_cpuTimePrecision :: Int
-
-foreign import javascript unsafe
- "(() => { return h$getCPUTime; })"
- js_getCPUTime :: IO Double
-
-##else
-- Here is where we decide which backend to use
#if defined(mingw32_HOST_OS)
import qualified System.CPUTime.Windows as I
+#elif defined(js_HOST_ARCH)
+import qualified System.CPUTime.Javascript as I
+
#elif _POSIX_TIMERS > 0 && defined(_POSIX_CPUTIME) && _POSIX_CPUTIME >= 0
import qualified System.CPUTime.Posix.ClockGetTime as I
@@ -89,5 +68,3 @@ cpuTimePrecision = unsafePerformIO I.getCpuTimePrecision
-- implementation-dependent.
getCPUTime :: IO Integer
getCPUTime = I.getCPUTime
-
-##endif
=====================================
libraries/base/System/CPUTime/Javascript.hs
=====================================
@@ -0,0 +1,26 @@
+{-# LANGUAGE JavaScriptFFI #-}
+
+module System.CPUTime.Javascript
+ ( getCPUTime
+ , getCpuTimePrecision
+ )
+where
+
+import qualified System.CPUTime.Unsupported as I
+
+getCpuTimePrecision :: IO Integer
+getCpuTimePrecision = toInteger <$> js_cpuTimePrecision
+
+getCPUTime :: IO Integer
+getCPUTime = do
+ t <- js_getCPUTime
+ if t == -1 then I.getCPUTime
+ else pure (1000 * round t)
+
+foreign import javascript unsafe
+ "(() => { return h$cpuTimePrecision(); })"
+ js_cpuTimePrecision :: IO Int
+
+foreign import javascript unsafe
+ "(() => { return h$getCPUTime(); })"
+ js_getCPUTime :: IO Double
=====================================
libraries/base/base.cabal
=====================================
@@ -460,6 +460,10 @@ Library
System.CPUTime.Posix.RUsage
System.CPUTime.Unsupported
+ if arch(js)
+ other-modules:
+ System.CPUTime.Javascript
+
-- The Ports framework always passes this flag when building software that
-- uses iconv to make iconv from Ports compatible with iconv from the base system
-- See /usr/ports/Mk/Uses/iconv.mk
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/291ae43721c76895f93fc052194dae80eea54585...4556033e37a93bb02c4c2c04433cf86d4be9ebe0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/291ae43721c76895f93fc052194dae80eea54585...4556033e37a93bb02c4c2c04433cf86d4be9ebe0
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/20221109/ed301e6e/attachment-0001.html>
More information about the ghc-commits
mailing list