[Git][ghc/ghc][wip/js-staging] JS.Prim: add CAS and Fetch Ops
doyougnu (@doyougnu)
gitlab at gitlab.haskell.org
Wed Sep 14 09:32:05 UTC 2022
doyougnu pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
0fda1b72 by doyougnu at 2022-09-14T05:30:41-04:00
JS.Prim: add CAS and Fetch Ops
- - - - -
1 changed file:
- compiler/GHC/StgToJS/Prim.hs
Changes:
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1139,27 +1139,73 @@ genPrim prof ty op = case op of
]
WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ dv_s_u32 a i (i32 e)
- CasByteArrayOp_Int8 -> unhandledPrimop op
- CasByteArrayOp_Int16 -> unhandledPrimop op
- CasByteArrayOp_Int32 -> unhandledPrimop op
- CasByteArrayOp_Int64 -> unhandledPrimop op
+ CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline $ casOp u8_ r a i old new
+ CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline $ casOp u1_ r a i old new
+ CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline $ casOp i32_ r a i old new
+
+ CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline $
+ jVar \t_h t_l -> mconcat [ t_h |= i32_ a (Add (i .<<. one_) one_)
+ , t_l |= i32_ a (i .<<. one_)
+ , r_h |= t_h
+ , r_l |= t_l
+ , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast
+ (ifBlockS (t_h .===. old_h)
+ -- Pre-Condition is good, do the write
+ [ i32_ a (Add (i .<<. one_) one_) |= new_h
+ , i32_ a (i .<<. one_) |= i32 new_l
+ ]
+ -- no good, don't write
+ mempty)
+ mempty
+ ]
+
InterlockedExchange_Addr -> unhandledPrimop op
InterlockedExchange_Word -> unhandledPrimop op
- CasAddrOp_Addr -> unhandledPrimop op
- CasAddrOp_Word -> unhandledPrimop op
- CasAddrOp_Word8 -> unhandledPrimop op
- CasAddrOp_Word16 -> unhandledPrimop op
- CasAddrOp_Word32 -> unhandledPrimop op
- CasAddrOp_Word64 -> unhandledPrimop op
-
- FetchAddAddrOp_Word -> unhandledPrimop op
- FetchSubAddrOp_Word -> unhandledPrimop op
- FetchAndAddrOp_Word -> unhandledPrimop op
- FetchNandAddrOp_Word -> unhandledPrimop op
- FetchOrAddrOp_Word -> unhandledPrimop op
- FetchXorAddrOp_Word -> unhandledPrimop op
+ CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $
+ mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2])
+ (appS "h$memcpy" [a3,o3,a1,o1,8])
+ mempty
+ , r_a |= a1
+ , r_o |= o1
+ ]
+ CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $
+ mconcat [ r |= u32_ a o
+ , ifS (r .===. old)
+ -- use i32_ instead of u32_, u32_ cannot be used for writing due to
+ -- hard coded conversion to word using (.>>>. zero_). You see we still
+ -- do the same convnersion but on the value to write
+ (i32_ a o |= (new .>>>. zero_))
+ mempty
+ ]
+
+ CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp u8_ r a o old new
+ CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp u1_ r a o old new
+ CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $
+ mconcat [ r |= u32_ a o
+ , ifS (r .===. old)
+ (i32_ a o |= (new .>>>. zero_))
+ mempty
+ ]
+ CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $
+ mconcat [ r_h |= dv_u32 a (Add o (Int 4))
+ , r_l |= dv_u32 a o
+ , ifS (r_l .===. old_l)
+ (ifBlockS (r_h .===. old_h)
+ [ dv_s_u32 a (Add o (Int 4)) new_h
+ , dv_s_u32 a o new_l
+ ]
+ mempty)
+ mempty
+ ]
+
+ FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v
+ FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v
+ FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v
+ FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v
+ FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v
+ FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v
AtomicReadAddrOp_Word -> unhandledPrimop op
AtomicWriteAddrOp_Word -> unhandledPrimop op
@@ -1299,6 +1345,26 @@ fetchOpByteArray op tgt src i v = mconcat
, i32_ src i |= op tgt v
]
+fetchOpAddr :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat
+fetchOpAddr op tgt src i v = mconcat
+ [ tgt |= src .! i
+ , src .! i |= op tgt v
+ ]
+
+casOp
+ :: (JExpr -> JExpr -> JExpr) -- view, the view of the ArrayBuffer to use
+ -> JExpr -- target register to store result
+ -> JExpr -- source arrays
+ -> JExpr -- index
+ -> JExpr -- old value to compare
+ -> JExpr -- new value to write
+ -> JStat
+casOp view tgt src i old new = mconcat [ tgt |= view src i
+ , ifS (tgt .===. old)
+ (view src i |= new)
+ mempty
+ ]
+
--------------------------------------------------------------------------------
-- Lifted Arrays
--------------------------------------------------------------------------------
@@ -1333,6 +1399,10 @@ i32 e = BOr e zero_
-- required because of JS numbers. e>>>0 converts e to a Word32
-- so (-2147483648) >>> 0 = 2147483648
-- and ((-2147483648) >>>0) | 0 = -2147483648
+--
+-- Warning: This function will throw an exception if it ends up on the left side
+-- of an assignment. The reason it blows up is because of the bit shift (used
+-- for coercion) is illegal on the LHS of an assignment
u32 :: JExpr -> JExpr
u32 e = e .>>>. zero_
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0fda1b720e3278e1d5d47e8360dbbdd089d3a407
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0fda1b720e3278e1d5d47e8360dbbdd089d3a407
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/20220914/730abcfc/attachment-0001.html>
More information about the ghc-commits
mailing list