[Git][ghc/ghc][wip/js-staging] 2 commits: base: GHCJS.Prim directory --> GHC.JS.Prim
doyougnu (@doyougnu)
gitlab at gitlab.haskell.org
Mon Aug 15 19:00:09 UTC 2022
doyougnu pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
37d31fe2 by doyougnu at 2022-08-15T14:58:10-04:00
base: GHCJS.Prim directory --> GHC.JS.Prim
- - - - -
9f2e853f by Luite Stegeman at 2022-08-15T14:58:10-04:00
implement KeepAlive primop
- - - - -
8 changed files:
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- js/rts.js.pp
- libraries/base/GHCJS/Prim.hs → libraries/base/GHC/JS/Prim.hs
- libraries/base/GHCJS/Prim/Internal.hs → libraries/base/GHC/JS/Prim/Internal.hs
- libraries/base/GHCJS/Prim/Internal/Build.hs → libraries/base/GHC/JS/Prim/Internal/Build.hs
- libraries/base/base.cabal
Changes:
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -707,7 +707,6 @@ readArObject ar_state mod ar_file = do
++ " in "
++ ar_file)
(BL.fromStrict . Ar.filedata) (find matchTag entries)
- -- mapM_ (\e -> putStrLn ("found file: " ++ Ar.filename e)) entries
{- | Static dependencies are symbols that need to be linked regardless
of whether the linked program refers to them. For example
@@ -721,29 +720,6 @@ newtype StaticDeps =
noStaticDeps :: StaticDeps
noStaticDeps = StaticDeps []
-{- | The input file format for static deps is a yaml document with a
- package/module/symbol tree where symbols can be either a list or
- just a single string, for example:
-
- base:
- GHC.Conc.Sync: reportError
- Control.Exception.Base: nonTermination
- ghcjs-prim:
- GHCJS.Prim:
- - JSVal
- - JSException
- -}
--- instance FromJSON StaticDeps where
--- parseJSON (Object v) = StaticDeps . concat <$> mapM (uncurry parseMod) (HM.toList v)
--- where
--- parseMod p (Object v) = concat <$> mapM (uncurry (parseSymb p)) (HM.toList v)
--- parseMod _ _ = mempty
--- parseSymb p m (String s) = pure [(p,m,s)]
--- parseSymb p m (Array v) = mapM (parseSingleSymb p m) (V.toList v)
--- parseSymb _ _ _ = mempty
--- parseSingleSymb p m (String s) = pure (p,m,s)
--- parseSingleSymb _ _ _ = mempty
--- parseJSON _ = mempty
-- | dependencies for the RTS, these need to be always linked
rtsDeps :: [UnitId] -> IO ([UnitId], Set ExportedFun)
@@ -782,7 +758,7 @@ readSystemDeps' file
-- wired-in just like in GHC and thus we should make them top level
-- definitions
| file == "thdeps.yaml" = pure ( [ baseUnitId ]
- , S.fromList $ d baseUnitId "GHCJS.Prim.TH.Eval" ["runTHServer"])
+ , S.fromList $ d baseUnitId "GHC.JS.Prim.TH.Eval" ["runTHServer"])
| file == "rtsdeps.yaml" = pure ( [ baseUnitId
, primUnitId
, bignumUnitId
@@ -800,8 +776,8 @@ readSystemDeps' file
-- FIXME Sylvain (2022,05): no longer valid
-- integer constructors
-- , d bignumUnitId "GHC.Integer.Type" ["S#", "Jp#", "Jn#"]
- , d baseUnitId "GHCJS.Prim" ["JSVal", "JSException", "$fShowJSException", "$fExceptionJSException", "resolve", "resolveIO", "toIO"]
- , d baseUnitId "GHCJS.Prim.Internal" ["wouldBlock", "blockedIndefinitelyOnMVar", "blockedIndefinitelyOnSTM", "ignoreException", "setCurrentThreadResultException", "setCurrentThreadResultValue"]
+ , d baseUnitId "GHC.JS.Prim" ["JSVal", "JSException", "$fShowJSException", "$fExceptionJSException", "resolve", "resolveIO", "toIO"]
+ , d baseUnitId "GHC.JS.Prim.Internal" ["wouldBlock", "blockedIndefinitelyOnMVar", "blockedIndefinitelyOnSTM", "ignoreException", "setCurrentThreadResultException", "setCurrentThreadResultValue"]
]
)
| otherwise = pure (mempty, mempty)
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -930,6 +930,8 @@ genPrim prof ty op = case op of
]
FinalizeWeakOp -> \[fl,fin] [w] -> PrimInline $ appT [fin, fl] "h$finalizeWeak" [w]
TouchOp -> \[] [_e] -> PrimInline mempty -- fixme what to do?
+ KeepAliveOp -> \[_r] [x, f] -> PRPrimCall $ ReturnStat (app "h$keepAlive" [x, f])
+
------------------------------ Stable pointers and names ------------------------
@@ -1109,8 +1111,6 @@ genPrim prof ty op = case op of
ReadIOPortOp -> unhandledPrimop op
WriteIOPortOp -> unhandledPrimop op
- KeepAliveOp -> unhandledPrimop op
-
GetSparkOp -> unhandledPrimop op
AnyToAddrOp -> unhandledPrimop op
MkApUpd0_Op -> unhandledPrimop op
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -523,6 +523,11 @@ rts' s =
, adjSpN' 1
, returnS (app "h$ap_0_0_fast" [])
]
+ , closure (ClosureInfo "h$keepAlive_e" (CIRegs 0 [PtrV]) "keepAlive" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+ (mconcat [ adjSpN' 2
+ , returnS (stack .! sp)
+ ]
+ )
-- a thunk that just raises a synchronous exception
, closure (ClosureInfo "h$raise_e" (CIRegs 0 [PtrV]) "h$raise_e" (CILayoutFixed 0 []) CIThunk mempty)
(returnS (app "h$throw" [closureField1 r1, false_]))
=====================================
js/rts.js.pp
=====================================
@@ -703,3 +703,11 @@ function h$catch(a, handler) {
h$r1 = a;
return h$ap_1_0_fast();
}
+
+function h$keepAlive(x, f) {
+ h$sp += 2;
+ h$stack[h$sp-1] = x;
+ h$stack[h$sp] = h$keepAlive_e;
+ h$r1 = f;
+ return h$ap_1_0_fast();
+}
\ No newline at end of file
=====================================
libraries/base/GHCJS/Prim.hs → libraries/base/GHC/JS/Prim.hs
=====================================
@@ -5,9 +5,9 @@
UnboxedTuples
#-}
-module GHCJS.Prim ( JSVal(..), JSVal#
- , JSException(..)
- , WouldBlockException(..)
+module GHC.JS.Prim ( JSVal(..), JSVal#
+ , JSException(..)
+ , WouldBlockException(..)
#ifdef js_HOST_ARCH
, toIO
, resolve
@@ -112,9 +112,9 @@ toJSString :: String -> JSVal
toJSString = js_toJSString . unsafeCoerce . seqList
{-# INLINE [0] toJSString #-}
{-# RULES
-"GHCJSPRIM toJSString/literal" forall a.
+"GHC.JS.PRIM toJSString/literal" forall a.
toJSString (GHC.unpackCString# a) = JSVal (unsafeUnpackJSStringUtf8## a)
-"GHCJSPRIM toJSString/literalUtf8" forall a.
+"GHC.JS.PRIM toJSString/literalUtf8" forall a.
toJSString (GHC.unpackCStringUtf8# a) = JSVal (unsafeUnpackJSStringUtf8## a)
#-}
@@ -152,9 +152,9 @@ getProp :: JSVal -> String -> IO JSVal
getProp o p = js_getProp o (unsafeCoerce $ seqList p)
{-# INLINE [0] getProp #-}
{-# RULES
-"GHCJSPRIM getProp/literal" forall o a.
+"GHC.JS.PRIM getProp/literal" forall o a.
getProp o (GHC.unpackCString# a) = getProp# o a
-"GHCJSPRIM getProp/literalUtf8" forall o a.
+"GHC.JS.PRIM getProp/literalUtf8" forall o a.
getProp o (GHC.unpackCStringUtf8# a) = getPropUtf8# o a
#-}
@@ -163,9 +163,9 @@ unsafeGetProp :: JSVal -> String -> JSVal
unsafeGetProp o p = js_unsafeGetProp o (unsafeCoerce $ seqList p)
{-# INLINE [0] unsafeGetProp #-}
{-# RULES
-"GHCJSPRIM unsafeGetProp/literal" forall o a.
+"GHC.JS.PRIM unsafeGetProp/literal" forall o a.
unsafeGetProp o (GHC.unpackCString# a) = unsafeGetProp# o a
-"GHCJSPRIM unsafeGetProp/literalUtf8" forall o a.
+"GHC.JS.PRIM unsafeGetProp/literalUtf8" forall o a.
unsafeGetProp o (GHC.unpackCStringUtf8# a) = unsafeGetPropUtf8# o a
#-}
@@ -173,9 +173,9 @@ getProp' :: JSVal -> JSVal -> IO JSVal
getProp' o p = js_getProp' o p
{-# INLINE [0] getProp' #-}
{-# RULES
-"GHCJSPRIM getProp'/literal" forall o a.
+"GHC.JS.PRIM getProp'/literal" forall o a.
getProp' o (unsafeUnpackJSString# a) = getProp# o a
-"GHCJSPRIM getProp'/literalUtf8" forall o a.
+"GHC.JS.PRIM getProp'/literalUtf8" forall o a.
getProp' o (unsafeUnpackJSStringUtf8# a) = getPropUtf8# o a
#-}
@@ -184,9 +184,9 @@ unsafeGetProp' :: JSVal -> JSVal -> JSVal
unsafeGetProp' o p = js_unsafeGetProp' o p
{-# INLINE [0] unsafeGetProp' #-}
{-# RULES
-"GHCJSPRIM unsafeGetProp'/literal" forall o a.
+"GHC.JS.PRIM unsafeGetProp'/literal" forall o a.
unsafeGetProp' o (unsafeUnpackJSString# a) = unsafeGetPropUtf8# o a
-"GHCJSPRIM unsafeGetProp'/literalUtf8" forall o a.
+"GHC.JS.PRIM unsafeGetProp'/literalUtf8" forall o a.
unsafeGetProp' o (unsafeUnpackJSStringUtf8# a) = unsafeGetPropUtf8# o a
#-}
=====================================
libraries/base/GHCJS/Prim/Internal.hs → libraries/base/GHC/JS/Prim/Internal.hs
=====================================
@@ -2,17 +2,17 @@
-}
-module GHCJS.Prim.Internal ( blockedIndefinitelyOnMVar
- , blockedIndefinitelyOnSTM
- , wouldBlock
- , ignoreException
- , setCurrentThreadResultException
- , setCurrentThreadResultValue
- ) where
+module GHC.JS.Prim.Internal ( blockedIndefinitelyOnMVar
+ , blockedIndefinitelyOnSTM
+ , wouldBlock
+ , ignoreException
+ , setCurrentThreadResultException
+ , setCurrentThreadResultValue
+ ) where
import Control.Exception
-import GHCJS.Prim
+import GHC.JS.Prim
wouldBlock :: SomeException
wouldBlock = toException WouldBlockException
=====================================
libraries/base/GHCJS/Prim/Internal/Build.hs → libraries/base/GHC/JS/Prim/Internal/Build.hs
=====================================
@@ -2,10 +2,10 @@
-- no Template Haskell available yet, generated by utils/genBuildObject.hs
{-# LANGUAGE CPP #-}
#ifndef js_HOST_ARCH
-module GHCJS.Prim.Internal.Build () where
+module GHC.JS.Prim.Internal.Build () where
#else
{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, GHCForeignImportPrim #-}
-module GHCJS.Prim.Internal.Build
+module GHC.JS.Prim.Internal.Build
( buildArrayI
, buildArrayM
, buildObjectI
@@ -140,7 +140,7 @@ module GHCJS.Prim.Internal.Build
, buildObjectM32
) where
-import GHCJS.Prim
+import GHC.JS.Prim
import GHC.Exts
import Unsafe.Coerce
import System.IO.Unsafe
=====================================
libraries/base/base.cabal
=====================================
@@ -461,10 +461,9 @@ Library
if arch(js)
exposed-modules:
- -- FIXME: Luite (2022,05): remove GHCJS name
- GHCJS.Prim
- GHCJS.Prim.Internal
- GHCJS.Prim.Internal.Build
+ GHC.JS.Prim
+ GHC.JS.Prim.Internal
+ GHC.JS.Prim.Internal.Build
-- We need to set the unit id to base (without a version number)
-- as it's magic.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c523b3af8f2a5a158455042fe00a279437495f9...9f2e853f01b16119339f4f9086bfdf802e576eda
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c523b3af8f2a5a158455042fe00a279437495f9...9f2e853f01b16119339f4f9086bfdf802e576eda
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/20220815/89ccca70/attachment-0001.html>
More information about the ghc-commits
mailing list