[Git][ghc/ghc][wip/js-staging] implement KeepAlive primop

[Luite Stegeman (@luite)]

Luite Stegeman pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC


Commits:
3c523b3a by Luite Stegeman at 2022-08-15T20:42:39+02:00
implement KeepAlive primop

- - - - -


3 changed files:

- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- js/rts.js.pp


Changes:

=====================================
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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c523b3af8f2a5a158455042fe00a279437495f9

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c523b3af8f2a5a158455042fe00a279437495f9
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/1b1ac58d/attachment-0001.html>