[Git][ghc/ghc][master] JS: implement getMonotonicTime (fix #23687)

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
33598ecb by Sylvain Henry at 2023-08-01T14:45:54-04:00
JS: implement getMonotonicTime (fix #23687)

- - - - -


4 changed files:

- libraries/base/GHC/Clock.hsc
- libraries/base/GHC/Conc/POSIX.hs
- + libraries/base/tests/T23687.hs
- libraries/base/tests/all.T


Changes:

=====================================
libraries/base/GHC/Clock.hsc
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -9,17 +10,36 @@ module GHC.Clock
 import GHC.Base
 import GHC.Real
 import Data.Word
+#if defined(javascript_HOST_ARCH)
+import GHC.Num
+#endif
 
 -- | Return monotonic time in seconds, since some unspecified starting point
 --
 -- @since 4.11.0.0
 getMonotonicTime :: IO Double
-getMonotonicTime = do w <- getMonotonicTimeNSec
-                      return (fromIntegral w / 1000000000)
+getMonotonicTime = do
+#if defined(javascript_HOST_ARCH)
+  w <- getMonotonicTimeMSec
+  return (w / 1000)
+#else
+  w <- getMonotonicTimeNSec
+  return (fromIntegral w / 1000000000)
+#endif
 
 -- | Return monotonic time in nanoseconds, since some unspecified starting point
 --
 -- @since 4.11.0.0
+#if defined(javascript_HOST_ARCH)
+getMonotonicTimeNSec :: IO Word64
+getMonotonicTimeNSec = do
+  w <- getMonotonicTimeMSec
+  return (floor w * 1000000)
+
+foreign import javascript unsafe "performance.now" getMonotonicTimeMSec:: IO Double
+
+
+#else
 foreign import ccall unsafe "getMonotonicNSec"
     getMonotonicTimeNSec :: IO Word64
-
+#endif


=====================================
libraries/base/GHC/Conc/POSIX.hs
=====================================
@@ -49,6 +49,7 @@ module GHC.Conc.POSIX
 
 import Data.Bits (shiftR)
 import GHC.Base
+import GHC.Clock
 import GHC.Conc.Sync
 import GHC.Conc.POSIX.Const
 import GHC.Event.Windows.ConsoleEvent
@@ -209,13 +210,9 @@ delayTime (Delay t _) = t
 delayTime (DelaySTM t _) = t
 
 type USecs = Word64
-type NSecs = Word64
-
-foreign import ccall unsafe "getMonotonicNSec"
-  getMonotonicNSec :: IO NSecs
 
 getMonotonicUSec :: IO USecs
-getMonotonicUSec = fmap (`div` 1000) getMonotonicNSec
+getMonotonicUSec = fmap (`div` 1000) getMonotonicTimeNSec
 
 {-# NOINLINE prodding #-}
 prodding :: IORef Bool


=====================================
libraries/base/tests/T23687.hs
=====================================
@@ -0,0 +1,14 @@
+module Main where
+
+import GHC.Clock
+import Control.Monad
+
+main :: IO ()
+main = do
+  a <- getMonotonicTimeNSec
+  b <- getMonotonicTimeNSec
+  when (a > b) $ putStrLn "Non-monotonic time"
+
+  c <- getMonotonicTime
+  d <- getMonotonicTime
+  when (c > d) $ putStrLn "Non-monotonic time"


=====================================
libraries/base/tests/all.T
=====================================
@@ -310,3 +310,4 @@ test('inits1tails1', normal, compile_and_run, [''])
 test('CLC149', normal, compile, [''])
 test('AtomicSwapIORef', normal, compile_and_run, [''])
 test('T23454', normal, compile_fail, [''])
+test('T23687', normal, compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/33598ecb624867dce36a71b265c054b689ed9701

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/33598ecb624867dce36a71b265c054b689ed9701
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/20230801/482008bc/attachment-0001.html>