[Git][ghc/ghc][wip/9.6.4-backports] 4 commits: darwin: Fix single_module is obsolete warning
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Mon Dec 18 15:03:42 UTC 2023
Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC
Commits:
273f5a3f by Rodrigo Mesquita at 2023-12-18T20:33:03+05:30
darwin: Fix single_module is obsolete warning
In XCode 15's linker, -single_module is the default and otherwise
passing it as a flag results in a warning being raised:
ld: warning: -single_module is obsolete
This patch fixes this warning by, at configure time, determining whether
the linker supports -single_module (which is likely false for all
non-darwin linkers, and true for darwin linkers in previous versions of
macOS), and using that information at runtime to decide to pass or not
the flag in the invocation.
Fixes #24168
(cherry picked from commit e6c803f702e8b09dfd0073b973b8afcd7071db50)
- - - - -
000a6a8f by Josh Meredith at 2023-12-18T20:33:03+05:30
JS: fix bounds checking (Issue 23123)
* For ByteArray-based bounds-checking, the JavaScript backend must use the
`len` field, instead of the inbuild JavaScript `length` field.
* Range-based operations must also check both the start and end of the range
for bounds
* All indicies are valid for ranges of size zero, since they are essentially no-ops
* For cases of ByteArray accesses (e.g. read as Int), the end index is
(i * sizeof(type) + sizeof(type) - 1), while the previous implementation
uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3)
* IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike
the previous point), but now check both start and end indicies
* Byte array copies now check if the arrays are the same by identity and
then if the ranges overlap.
(cherry picked from commit 116d7312ec4c76f75a26bd0ad2b2815710049e0e)
- - - - -
689375f4 by Sylvain Henry at 2023-12-18T20:33:03+05:30
Fix remaining issues with bound checking (#23123)
While fixing these I've also changed the way we store addresses into
ByteArray#. Addr# are composed of two parts: a JavaScript array and an
offset (32-bit number).
Suppose we want to store an Addr# in a ByteArray# foo at offset i.
Before this patch, we were storing both fields as a tuple in the "arr"
array field:
foo.arr[i] = [addr_arr, addr_offset];
Now we only store the array part in the "arr" field and the offset
directly in the array:
foo.dv.setInt32(i, addr_offset):
foo.arr[i] = addr_arr;
It avoids wasting space for the tuple.
(cherry picked from commit 2d5c1ddecf195da9a8ee4f7b38fbb79d3b680aeb)
- - - - -
3ce937a7 by Zubin Duggal at 2023-12-18T20:33:03+05:30
Prepare release 9.6.4
- - - - -
22 changed files:
- compiler/GHC/Linker/Dynamic.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Settings/IO.hs
- compiler/GHC/StgToJS/Linker/Utils.hs
- compiler/GHC/StgToJS/Prim.hs
- configure.ac
- distrib/configure.ac.in
- + docs/users_guide/9.6.4-notes.rst
- docs/users_guide/release-notes.rst
- hadrian/bindist/Makefile
- hadrian/bindist/config.mk.in
- hadrian/cfg/system.config.in
- hadrian/src/Rules/Generate.hs
- libraries/base/jsbits/base.js
- + m4/fp_prog_ld_single_module.m4
- rts/js/environment.js
- rts/js/mem.js
- rts/js/profiling.js
- rts/js/staticpointer.js
- rts/js/string.js
- testsuite/tests/codeGen/should_fail/all.T
- testsuite/tests/codeGen/should_run/all.T
Changes:
=====================================
compiler/GHC/Linker/Dynamic.hs
=====================================
@@ -11,6 +11,7 @@ where
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Ways
+import GHC.Settings (ToolSettings(toolSettings_ldSupportsSingleModule))
import GHC.Driver.Config.Linker
import GHC.Driver.Session
@@ -150,6 +151,9 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
-- dynamic binding nonsense when referring to symbols from
-- within the library. The NCG assumes that this option is
-- specified (on i386, at least).
+ -- In XCode 15, -single_module is the default and passing the
+ -- flag is now obsolete and raises a warning (#24168). We encode
+ -- this information into the toolchain field ...SupportsSingleModule.
-- -install_name
-- Mac OS/X stores the path where a dynamic library is (to
-- be) installed in the library itself. It's called the
@@ -175,8 +179,11 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
]
++ map Option o_files
++ [ Option "-undefined",
- Option "dynamic_lookup",
- Option "-single_module" ]
+ Option "dynamic_lookup"
+ ]
+ ++ (if toolSettings_ldSupportsSingleModule (toolSettings dflags)
+ then [ Option "-single_module" ]
+ else [ ])
++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ]
then [ ]
else [ Option "-Wl,-read_only_relocs,suppress" ])
=====================================
compiler/GHC/Settings.hs
=====================================
@@ -87,6 +87,7 @@ data Settings = Settings
data ToolSettings = ToolSettings
{ toolSettings_ldSupportsCompactUnwind :: Bool
, toolSettings_ldSupportsFilelist :: Bool
+ , toolSettings_ldSupportsSingleModule :: Bool
, toolSettings_ldIsGnuLd :: Bool
, toolSettings_ccSupportsNoPie :: Bool
, toolSettings_useInplaceMinGW :: Bool
=====================================
compiler/GHC/Settings/IO.hs
=====================================
@@ -95,6 +95,7 @@ initSettings top_dir = do
cxx_args = words cxx_args_str
ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
ldSupportsFilelist <- getBooleanSetting "ld supports filelist"
+ ldSupportsSingleModule <- getBooleanSetting "ld supports single module"
ldIsGnuLd <- getBooleanSetting "ld is GNU ld"
arSupportsDashL <- getBooleanSetting "ar supports -L"
@@ -163,6 +164,7 @@ initSettings top_dir = do
, sToolSettings = ToolSettings
{ toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind
, toolSettings_ldSupportsFilelist = ldSupportsFilelist
+ , toolSettings_ldSupportsSingleModule = ldSupportsSingleModule
, toolSettings_ldIsGnuLd = ldIsGnuLd
, toolSettings_ccSupportsNoPie = gccSupportsNoPie
, toolSettings_useInplaceMinGW = useInplaceMinGW
=====================================
compiler/GHC/StgToJS/Linker/Utils.hs
=====================================
@@ -137,6 +137,10 @@ genCommonCppDefs profiling = mconcat
then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n"
else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n"
+ -- Put Addr# in ByteArray# or at Addr# (same thing)
+ , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n"
+ , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n"
+
-- Data.Maybe.Maybe
, "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n"
, "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n"
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString)
import GHC.Data.FastString
import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr)
-import Data.Maybe
genPrim :: Bool -- ^ Profiling (cost-centres) enabled
@@ -527,214 +526,201 @@ genPrim prof bound ty op = case op of
------------------------------ Arrays -------------------------------------------
- NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e)
- ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i)
- WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v)
+ NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e]
+ ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i)
+ WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v)
SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length"
SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length"
- IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i)
+ IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i)
UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a
UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a
CopyArrayOp -> \[] [a,o1,ma,o2,n] ->
- PrimInline $ loopBlockS (Int 0) (.<. n) \i ->
- [ ma .! (Add i o2) |= a .! (Add i o1)
- , preIncrS i
- ]
- CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n]
- CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n]
- CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n]
- FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n]
- ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n]
- CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $
- jVar \x -> mconcat
- [ x |= a .! i
- , ifBlockS (x .===. old)
- [ o |= new
- , a .! i |= new
- , s |= zero_
- ]
- [ s |= one_
- , o |= x
- ]
- ]
+ PrimInline
+ $ bnd_arr_range bound a o1 n
+ $ bnd_arr_range bound ma o2 n
+ $ loopBlockS (Int 0) (.<. n) \i ->
+ [ ma .! (Add i o2) |= a .! (Add i o1)
+ , preIncrS i
+ ]
+ CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] ->
+ PrimInline
+ $ bnd_arr_range bound a1 o1 n
+ $ bnd_arr_range bound a2 o2 n
+ $ appS "h$copyMutableArray" [a1,o1,a2,o2,n]
+
+ CloneArrayOp -> \[r] [a,start,n] ->
+ PrimInline
+ $ bnd_arr_range bound a start n
+ $ r |= app "h$sliceArray" [a,start,n]
+
+ CloneMutableArrayOp -> \[r] [a,start,n] ->
+ PrimInline
+ $ bnd_arr_range bound a start n
+ $ r |= app "h$sliceArray" [a,start,n]
+
+ FreezeArrayOp -> \[r] [a,start,n] ->
+ PrimInline
+ $ bnd_arr_range bound a start n
+ $ r |= app "h$sliceArray" [a,start,n]
+
+ ThawArrayOp -> \[r] [a,start,n] ->
+ PrimInline
+ $ bnd_arr_range bound a start n
+ $ r |= app "h$sliceArray" [a,start,n]
+
+ CasArrayOp -> \[s,o] [a,i,old,new] ->
+ PrimInline
+ $ bnd_arr bound a i
+ $ jVar \x -> mconcat
+ [ x |= a .! i
+ , ifBlockS (x .===. old)
+ [ o |= new
+ , a .! i |= new
+ , s |= zero_
+ ]
+ [ s |= one_
+ , o |= x
+ ]
+ ]
------------------------------ Small Arrays -------------------------------------
NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e]
- ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i)
- WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e)
+ ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i)
+ WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e)
SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length"
SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length"
- IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i)
+ IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i)
UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a
UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a
- CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $
- loopBlockS (Sub n one_) (.>=. zero_) \i ->
- [ d .! (Add di i) |= s .! (Add si i)
- , postDecrS i
+ CopySmallArrayOp -> \[] [s,si,d,di,n] ->
+ PrimInline
+ $ bnd_arr_range bound s si n
+ $ bnd_arr_range bound d di n
+ $ loopBlockS (Sub n one_) (.>=. zero_) \i ->
+ [ d .! (Add di i) |= s .! (Add si i)
+ , postDecrS i
+ ]
+ CopySmallMutableArrayOp -> \[] [s,si,d,di,n] ->
+ PrimInline
+ $ bnd_arr_range bound s si n
+ $ bnd_arr_range bound d di n
+ $ appS "h$copyMutableArray" [s,si,d,di,n]
+
+ CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n
+ CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n
+ FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n
+ ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n
+
+ CasSmallArrayOp -> \[s,o] [a,i,old,new] ->
+ PrimInline
+ $ bnd_arr bound a i
+ $ jVar \x -> mconcat
+ [ x |= a .! i
+ , ifBlockS (x .===. old)
+ [ o |= new
+ , a .! i |= new
+ , s |= zero_
+ ]
+ [ s |= one_
+ , o |= x
+ ]
]
- CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n]
- CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n
- CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n
- FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n
- ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n
- CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat
- [ x |= a .! i
- , ifBlockS (x .===. old)
- [ o |= new
- , a .! i |= new
- , s |= zero_
- ]
- [ s |= one_
- , o |= x
- ]
- ]
------------------------------- Byte Arrays -------------------------------------
- NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l)
- NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l)
- NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l)
- MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_
- ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_
- ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_]
- MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_]
- ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n]
- ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n]
- UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b
- SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len"
- SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len"
- GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len"
- IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i
- IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
- IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
- IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i
- IndexByteArrayOp_Addr -> \[r1,r2] [a,i] ->
- PrimInline . boundsChecked bound a i $ jVar \t -> mconcat
- [ t |= a .^ "arr"
- , ifBlockS (t .&&. t .! (i .<<. two_))
- [ r1 |= t .! (i .<<. two_) .! zero_
- , r2 |= t .! (i .<<. two_) .! one_
- ]
- [ r1 |= null_
- , r2 |= zero_
- ]
- ]
+ NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l)
+ NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l)
+ NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l)
+ MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_
+ ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_
+ ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_]
+ MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_]
+ ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n]
+ ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n]
+ UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b
+ SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len"
+ SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len"
+ GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len"
+
+ IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i
+ IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i
+ IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i
+ IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i
+ IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o
+ IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i
+ IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i
+ IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o
+ IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i
+ IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i
+ IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i
+ IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l
+ IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i
+ IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i
+ IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i
+ IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l
+
+ ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i
+ ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i
+ ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i
+ ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i
+ ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o
+ ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i
+ ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i
+ ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o
+ ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i
+ ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i
+ ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i
+ ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l
+ ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i
+ ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i
+ ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i
+ ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l
+
+ WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e
+ WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e
+ WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e
+ WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e
+ WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o
+ WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e
+ WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e
+ WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o
+ WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e
+ WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e
+ WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e
+ WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l
+ WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e
+ WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e
+ WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e
+ WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l
- IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i
- IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i
- IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] ->
- PrimInline . boundsChecked bound a (Add i 3) $ mconcat
- [ r1 |= var "h$stablePtrBuf"
- , r2 |= read_i32 a i
- ]
- IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i
- IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i
- IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
- IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat
- [ h |= read_i32 a (Add (i .<<. one_) one_)
- , l |= read_u32 a (i .<<. one_)
- ]
- IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i
- IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i
- IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i
- IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat
- [ h |= read_u32 a (Add (i .<<. one_) one_)
- , l |= read_u32 a (i .<<. one_)
- ]
- ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i
- ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
- ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
- ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i
- ReadByteArrayOp_Addr -> \[r1,r2] [a,i] ->
- PrimInline $ jVar \x -> mconcat
- [ x |= i .<<. two_
- , ifS (a .^ "arr" .&&. a .^ "arr" .! x)
- (mconcat [ r1 |= a .^ "arr" .! x .! zero_
- , r2 |= a .^ "arr" .! x .! one_
- ])
- (mconcat [r1 |= null_, r2 |= one_])
- ]
- ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i
- ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i
- ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] ->
- PrimInline . boundsChecked bound a (Add i 3) $ mconcat
- [ r1 |= var "h$stablePtrBuf"
- , r2 |= read_i32 a i
- ]
- ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i
- ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i
- ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
- ReadByteArrayOp_Int64 -> \[h,l] [a,i] ->
- PrimInline . boundsChecked bound a (Add i 7) $ mconcat
- [ h |= read_i32 a (Add (i .<<. one_) one_)
- , l |= read_u32 a (i .<<. one_)
- ]
- ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i
- ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i
- ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i
- ReadByteArrayOp_Word64 -> \[h,l] [a,i] ->
- PrimInline . boundsChecked bound a (Add i 7) $ mconcat
- [ h |= read_u32 a (Add (i .<<. one_) one_)
- , l |= read_u32 a (i .<<. one_)
- ]
- WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e
- WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e
- WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e
- WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e
- WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] ->
- PrimInline $ mconcat
- [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty
- , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2])
- ]
- WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e
- WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e
- WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2
-
- WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e
- WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e
- WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e
- WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] ->
- PrimInline . boundsChecked bound a (Add i 7) $ mconcat
- [ write_i32 a (Add (i .<<. one_) one_) e1
- , write_u32 a (i .<<. one_) e2
- ]
- WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e
- WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e
- WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e
- WriteByteArrayOp_Word64 -> \[] [a,i,h,l] ->
- PrimInline . boundsChecked bound a (Add i 7) $ mconcat
- [ write_u32 a (Add (i .<<. one_) one_) h
- , write_u32 a (i .<<. one_) l
- ]
CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] ->
- PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1))
- . boundsChecked bound a2 (Add o2 (Sub n 1))
+ PrimInline . bnd_ba_range bound a1 o1 n
+ . bnd_ba_range bound a2 o2 n
$ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n]
- CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] ->
- PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1))
- . boundsChecked bound a2 (Add o2 (Sub n 1))
- $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n]
- CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs
- CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs
- CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs
- CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs
+ -- We assume the arrays aren't overlapping since they're of different types
+ -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#)
+ CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n
+ CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n
+ CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n
+
+ CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n
SetByteArrayOp -> \[] [a,o,n,v] ->
- PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i ->
+ PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i ->
[ write_u8 a (Add o i) v
, postIncrS i
]
- AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
- AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v
- FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v
- FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v
- FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v
- FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v
- FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v
- FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v
+ AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i
+ AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v
+ FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v
+ FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v
+ FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v
+ FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v
+ FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v
+ FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v
------------------------------- Addr# ------------------------------------------
@@ -752,107 +738,58 @@ genPrim prof bound ty op = case op of
------------------------------- Addr Indexing: Unboxed Arrays -------------------
- IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i)
- IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i)
- IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i)
- IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i)
- IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] ->
- PrimInline . boundsChecked bound (a .^ "arr") (off32 o i)
- $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_))
- [ ca |= a .^ "arr" .! (off32 o i) .! zero_
- , co |= a .^ "arr" .! (off32 o i) .! one_
- ]
- [ ca |= null_
- , co |= zero_
- ]
- IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i)
- IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i)
- IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat
- [ c1 |= var "h$stablePtrBuf"
- , c2 |= read_boff_i32 a (off32 o i)
- ]
- IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i)
- IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i)
- IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i)
- IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] ->
- PrimInline $ mconcat
- [ h |= read_boff_i32 a (Add (off64 o i) (Int 4))
- , l |= read_boff_u32 a (off64 o i)
- ]
- IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i)
- IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i)
- IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i)
- IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] ->
- PrimInline $ mconcat
- [ h |= read_boff_u32 a (Add (off64 o i) (Int 4))
- , l |= read_boff_u32 a (off64 o i)
- ]
- ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i)
- ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i)
- ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i)
- ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i)
- ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] ->
- PrimInline $ jVar \x -> mconcat
- [ x |= i .<<. two_
- , boundsChecked bound (a .^ "arr") (Add o x) $
- ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x))
- [ c1 |= a .^ "arr" .! (Add o x) .! zero_
- , c2 |= a .^ "arr" .! (Add o x) .! one_
- ]
- [ c1 |= null_
- , c2 |= zero_
- ]
- ]
- ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i)
- ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i)
- ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat
- [ c1 |= var "h$stablePtrBuf"
- , c2 |= read_boff_u32 a (off32 o i)
- ]
- ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i)
- ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i)
- ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i)
- ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] ->
- PrimInline $ mconcat
- [ h |= read_i32 a (Add (off64 o i) (Int 4))
- , l |= read_u32 a (off64 o i)
- ]
- ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i)
- ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i)
- ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i)
- ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] ->
- PrimInline $ mconcat
- [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4))
- , c2 |= read_boff_u32 a (off64 o i)
- ]
- WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v
- WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v
- WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v
- WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v
- WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] ->
- PrimInline $ mconcat
- [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty
- , boundsChecked bound (a .^ "arr") (off32 o i) $
- AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo])
- ]
- WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v
- WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v
- WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2
- WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v
- WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v
- WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v
- WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat
- [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1
- , write_boff_u32 a (off64 o i) v2
- ]
- WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v
- WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v
- WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v
- WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat
- [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1
- , write_boff_u32 a (off64 o i) v2
- ]
--- Mutable variables
+ IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i)
+ IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i)
+ IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i)
+ IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i)
+ IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro
+ IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i)
+ IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i)
+ IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro
+ IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i)
+ IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i)
+ IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i)
+ IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l
+ IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i)
+ IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i)
+ IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i)
+ IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l
+
+ ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i)
+ ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i)
+ ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i)
+ ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i)
+ ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro
+ ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i)
+ ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i)
+ ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro
+ ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i)
+ ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i)
+ ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i)
+ ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l
+ ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i)
+ ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i)
+ ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i)
+ ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l
+
+ WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v
+ WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v
+ WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v
+ WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v
+ WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo
+ WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v
+ WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v
+ WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo
+ WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v
+ WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v
+ WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v
+ WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l
+ WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v
+ WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v
+ WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v
+ WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l
+
+------------------------------- Mutable varialbes --------------------------------------
NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x])
ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val"
WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x
@@ -913,17 +850,17 @@ genPrim prof bound ty op = case op of
------------------------------- Concurrency Primitives -------------------------
- ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_])
- ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument
- KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex])
- YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" [])
- MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread"
- IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_
- NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing
- ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid]
- ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" []
- GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t]
- LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l
+ ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_])
+ ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument
+ KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex])
+ YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" [])
+ MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread"
+ IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_
+ NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing
+ ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid]
+ ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" []
+ GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t]
+ LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l
------------------------------- Weak Pointers -----------------------------------
@@ -1027,184 +964,82 @@ genPrim prof bound ty op = case op of
TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len]
TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo]
- IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i
- IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i
- IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] ->
- PrimInline $ jVar \x -> mconcat
- [ x |= i .<<. two_
- , boundsChecked bound (a .^ "arr") x $
- ifS (a .^ "arr" .&&. a .^ "arr" .! x)
- (mconcat [ r1 |= a .^ "arr" .! x .! zero_
- , r2 |= a .^ "arr" .! x .! one_
- ])
- (mconcat [r1 |= null_, r2 |= one_])
- ]
- IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i
- IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i
- IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] ->
- PrimInline $ mconcat
- [ r1 |= var "h$stablePtrBuf"
- , r2 |= read_boff_i32 a i
- ]
- IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i
- IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i
- IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] ->
- PrimInline $ mconcat
- [ h |= read_boff_i32 a (Add i (Int 4))
- , l |= read_boff_u32 a i
- ]
- IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i
- IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i
- IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i
- IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] ->
- PrimInline . boundsChecked bound a (Add i 7) $ mconcat
- [ h |= read_boff_u32 a (Add i (Int 4))
- , l |= read_boff_u32 a i
- ]
- IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i
-
- ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i
- ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i
- ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] ->
- PrimInline $ jVar \x -> mconcat
- [ x |= i .<<. two_
- , boundsChecked bound (a .^ "arr") x $
- ifS (a .^ "arr" .&&. a .^ "arr" .! x)
- (mconcat [ r1 |= a .^ "arr" .! x .! zero_
- , r2 |= a .^ "arr" .! x .! one_
- ])
- (mconcat [r1 |= null_, r2 |= one_])
- ]
- ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i
- ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i
- ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] ->
- PrimInline $ mconcat
- [ r1 |= var "h$stablePtrBuf"
- , r2 |= read_boff_i32 a i
- ]
- ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i
- ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i
- ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] ->
- PrimInline $ mconcat
- [ h |= read_boff_i32 a (Add i (Int 4))
- , l |= read_boff_u32 a i
- ]
- ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i
- ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i
- ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i
- ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] ->
- PrimInline . boundsChecked bound a (Add i 7) $ mconcat
- [ h |= read_boff_u32 a (Add i (Int 4))
- , l |= read_boff_u32 a i
- ]
- ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i
-
- WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e
- WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e
- WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] ->
- PrimInline $ mconcat
- [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty
- , boundsChecked bound (a .^ "arr") (i .<<. two_) $
- a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2])
- ]
-
- WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e
- WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e
- WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2
- WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e
- WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e
- WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] ->
- -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i
- -- then write the higher 4 bytes to i+4
- PrimInline . boundsChecked bound a i
- $ mconcat [ write_boff_i32 a (Add i (Int 4)) h
- , write_boff_u32 a i l
- ]
- WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e
- WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e
- WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e
- WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] ->
- PrimInline . boundsChecked bound a (Add i 7)
- $ mconcat [ write_boff_u32 a (Add i (Int 4)) h
- , write_boff_u32 a i l
- ]
- WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e
-
- CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new
- CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new
- CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new
- CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new
-
- CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $
- jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_)
- , t_l |= read_u32 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
- [ write_i32 a (Add (i .<<. one_) one_) new_h
- , write_u32 a (i .<<. one_) new_l
- ]
- -- no good, don't write
- mempty)
- mempty
- ]
-
- 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
- ]
+------------------------------ ByteArray -------------------
+
+ IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i
+ IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i
+ IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o
+ IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i
+ IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i
+ IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o
+ IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i
+ IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i
+ IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l
+ IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i
+ IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i
+ IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i
+ IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l
+ IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i
+
+ ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i
+ ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i
+ ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o
+ ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i
+ ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i
+ ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o
+ ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i
+ ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i
+ ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l
+ ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i
+ ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i
+ ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i
+ ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l
+ ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i
+
+ WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e
+ WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e
+ WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o
+ WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e
+ WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e
+ WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o
+ WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e
+ WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e
+ WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l
+ WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e
+ WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e
+ WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e
+ WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l
+ WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e
+
+ CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n
+ CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n
+ CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n
+ CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n
+
+ CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl)
+
+ CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no)
CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new
CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new
CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new
CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new
- CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $
- mconcat [ r_h |= read_u32 a (Add o (Int 4))
- , r_l |= read_u32 a o
- , ifS (r_l .===. old_l)
- (ifBlockS (r_h .===. old_h)
- [ write_u32 a (Add o (Int 4)) new_h
- , write_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
+ CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl)
+
+ 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
- InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $
- -- this primop can't be implemented
- -- correctly because we don't store
- -- the array reference part of an Addr#,
- -- only the offset part.
- --
- -- So let's assume that all the array
- -- references are the same...
- --
- -- Note: we could generate an assert
- -- that checks that a1 === a2. However
- -- we can't check that the Addr# read
- -- at Addr# a2[o2] also comes from this
- -- a1/a2 array.
- mconcat [ r_a |= a1 -- might be wrong (see above)
- , r_o |= read_boff_u32 a1 o1
- -- TODO (see above)
- -- assert that a1 === a2
- , write_boff_u32 a1 o1 o2
- ]
- InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $
- mconcat [ r |= read_boff_u32 a o
- , write_boff_u32 a o w
- ]
+ InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat
+ [ read_boff_addr a1 o1 ra ro
+ , write_boff_addr a1 o1 a2 o2
+ ]
+ InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat
+ [ r |= read_boff_u32 a o
+ , write_boff_u32 a o w
+ ]
ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n]
GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length"
@@ -1363,6 +1198,79 @@ read_f32 a i = idx_f32 a i
read_f64 :: JExpr -> JExpr -> JExpr
read_f64 a i = idx_f64 a i
+read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+read_u64 a i rh rl = mconcat
+ [ rl |= read_u32 a (i .<<. 1)
+ , rh |= read_u32 a (Add 1 (i .<<. 1))
+ ]
+
+read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+read_i64 a i rh rl = mconcat
+ [ rl |= read_u32 a (i .<<. 1)
+ , rh |= read_i32 a (Add 1 (i .<<. 1))
+ ]
+
+--------------------------------------
+-- Addr#
+--------------------------------------
+
+write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+write_addr a i r o = mconcat
+ [ write_i32 a i o
+ -- create the hidden array for arrays if it doesn't exist
+ , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty
+ , a .^ "arr" .! (i .<<. 2) |= r
+ ]
+
+read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+read_addr a i r o = mconcat
+ [ o |= read_i32 a i
+ , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2)))
+ (a .^ "arr" .! (i .<<. 2))
+ null_
+ ]
+
+read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+read_boff_addr a i r o = mconcat
+ [ o |= read_boff_i32 a i
+ , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i))
+ (a .^ "arr" .! i)
+ null_
+ ]
+
+write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+write_boff_addr a i r o = mconcat
+ [ write_boff_i32 a i o
+ -- create the hidden array for arrays if it doesn't exist
+ , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty
+ , a .^ "arr" .! i |= r
+ ]
+
+
+--------------------------------------
+-- StablePtr
+--------------------------------------
+
+read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+read_stableptr a i r o = mconcat
+ [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array
+ , o |= read_i32 a i
+ ]
+
+read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+read_boff_stableptr a i r o = mconcat
+ [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array
+ , o |= read_boff_i32 a i
+ ]
+
+write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+write_stableptr a i _r o = write_i32 a i o
+ -- don't store "r" as it must be h$stablePtrBuf
+
+write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+write_boff_stableptr a i _r o = write_boff_i32 a i o
+ -- don't store "r" as it must be h$stablePtrBuf
+
write_u8 :: JExpr -> JExpr -> JExpr -> JStat
write_u8 a i v = idx_u8 a i |= v
@@ -1387,6 +1295,18 @@ write_f32 a i v = idx_f32 a i |= v
write_f64 :: JExpr -> JExpr -> JExpr -> JStat
write_f64 a i v = idx_f64 a i |= v
+write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+write_u64 a i h l = mconcat
+ [ write_u32 a (i .<<. 1) l
+ , write_u32 a (Add 1 (i .<<. 1)) h
+ ]
+
+write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+write_i64 a i h l = mconcat
+ [ write_u32 a (i .<<. 1) l
+ , write_i32 a (Add 1 (i .<<. 1)) h
+ ]
+
-- Data View helper functions: byte indexed!
--
-- The argument list consists of the array @a@, the index @i@, and the new value
@@ -1402,6 +1322,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_]
write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_]
write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_]
+write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+write_boff_i64 a i h l = mconcat
+ [ write_boff_i32 a (Add i (Int 4)) h
+ , write_boff_u32 a i l
+ ]
+write_boff_u64 a i h l = mconcat
+ [ write_boff_u32 a (Add i (Int 4)) h
+ , write_boff_u32 a i l
+ ]
+
read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr
read_boff_i8 a i = read_i8 a i
read_boff_u8 a i = read_u8 a i
@@ -1412,6 +1342,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_]
read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_]
read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_]
+read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+read_boff_i64 a i rh rl = mconcat
+ [ rh |= read_boff_i32 a (Add i (Int 4))
+ , rl |= read_boff_u32 a i
+ ]
+
+read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat
+read_boff_u64 a i rh rl = mconcat
+ [ rh |= read_boff_u32 a (Add i (Int 4))
+ , rl |= read_boff_u32 a i
+ ]
+
fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat
fetchOpByteArray op tgt src i v = mconcat
[ tgt |= read_i32 src i
@@ -1427,8 +1369,8 @@ fetchOpAddr op tgt src i v = mconcat
casOp
:: (JExpr -> JExpr -> JExpr) -- read
-> (JExpr -> JExpr -> JExpr -> JStat) -- write
- -> JExpr -- target register to store result
- -> JExpr -- source arrays
+ -> JExpr -- target register to store result
+ -> JExpr -- source array
-> JExpr -- index
-> JExpr -- old value to compare
-> JExpr -- new value to write
@@ -1440,39 +1382,174 @@ casOp read write tgt src i old new = mconcat
mempty
]
+casOp2
+ :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read
+ -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write
+ -> (JExpr,JExpr) -- target registers to store result
+ -> JExpr -- source array
+ -> JExpr -- index
+ -> (JExpr,JExpr) -- old value to compare
+ -> (JExpr,JExpr) -- new value to write
+ -> JStat
+casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat
+ [ read src i tgt1 tgt2
+ , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1))
+ (write src i new1 new2)
+ mempty
+ ]
+
--------------------------------------------------------------------------------
-- Lifted Arrays
--------------------------------------------------------------------------------
-- | lifted arrays
-cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat
-cloneArray tgt src mb_offset len = mconcat
- [ tgt |= ApplExpr (src .^ "slice") [start, end]
- , tgt .^ closureMeta_ |= zero_
- , tgt .^ "__ghcjsArray" |= true_
- ]
- where
- start = fromMaybe zero_ mb_offset
- end = maybe len (Add len) mb_offset
-
-newArray :: JExpr -> JExpr -> JExpr -> JStat
-newArray tgt len elem =
- tgt |= app "h$newArray" [len, elem]
+cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat
+cloneArray bound_check tgt src start len =
+ bnd_arr_range bound_check src start len
+ $ mconcat
+ [ tgt |= ApplExpr (src .^ "slice") [start, Add len start]
+ , tgt .^ closureMeta_ |= zero_
+ , tgt .^ "__ghcjsArray" |= true_
+ ]
newByteArray :: JExpr -> JExpr -> JStat
newByteArray tgt len =
tgt |= app "h$newByteArray" [len]
-boundsChecked :: Bool -- ^ Should we do bounds checking?
- -> JExpr -- ^ Array
- -> JExpr -- ^ Index
- -> JStat -- ^ Result
- -> JStat
-boundsChecked False _ _ r = r
-boundsChecked True xs i r =
- ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_))
+-- | Check that index is positive and below a max value. Halt the process with
+-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds
+check_bound
+ :: JExpr -- ^ Max index expression
+ -> Bool -- ^ Should we do bounds checking?
+ -> JExpr -- ^ Index
+ -> JStat -- ^ Result
+ -> JStat
+check_bound _ False _ r = r
+check_bound max_index True i r = mconcat
+ [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $
+ returnS (app "h$exitProcess" [Int 134])
+ , r
+ ]
+
+-- | Bounds checking using ".length" property (Arrays)
+bnd_arr
+ :: Bool -- ^ Should we do bounds checking?
+ -> JExpr -- ^ Array
+ -> JExpr -- ^ Index
+ -> JStat -- ^ Result
+ -> JStat
+bnd_arr do_check arr = check_bound (arr .^ "length") do_check
+
+-- | Range bounds checking using ".length" property (Arrays)
+--
+-- Empty ranges trivially pass the check
+bnd_arr_range
+ :: Bool -- ^ Should we do bounds checking?
+ -> JExpr -- ^ Array
+ -> JExpr -- ^ Index
+ -> JExpr -- ^ Range size
+ -> JStat -- ^ Result
+ -> JStat
+bnd_arr_range False _arr _i _n r = r
+bnd_arr_range True arr i n r =
+ ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $
+ -- Empty ranges trivially pass the check
+ ifS (n .===. zero_)
+ r
+ (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r)
+
+-- | Bounds checking using ".len" property (ByteArrays)
+bnd_ba
+ :: Bool -- ^ Should we do bounds checking?
+ -> JExpr -- ^ Array
+ -> JExpr -- ^ Index
+ -> JStat -- ^ Result
+ -> JStat
+bnd_ba do_check arr = check_bound (arr .^ "len") do_check
+
+-- | ByteArray bounds checking (byte offset, 8-bit value)
+bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat
+bnd_ba8 = bnd_ba
+
+-- | ByteArray bounds checking (byte offset, 16-bit value)
+bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat
+bnd_ba16 do_check arr idx r =
+ -- check that idx non incremented is in range:
+ -- (idx + 1) may be in range while idx isn't
+ bnd_ba do_check arr idx
+ $ bnd_ba do_check arr (Add idx 1) r
+
+-- | ByteArray bounds checking (byte offset, 32-bit value)
+bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat
+bnd_ba32 do_check arr idx r =
+ -- check that idx non incremented is in range:
+ -- (idx + 3) may be in range while idx isn't
+ bnd_ba do_check arr idx
+ $ bnd_ba do_check arr (Add idx 3) r
+
+-- | ByteArray bounds checking (byte offset, 64-bit value)
+bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat
+bnd_ba64 do_check arr idx r =
+ -- check that idx non incremented is in range:
+ -- (idx + 7) may be in range while idx isn't
+ bnd_ba do_check arr idx
+ $ bnd_ba do_check arr (Add idx 7) r
+
+-- | ByteArray bounds checking (8-bit offset, 8-bit value)
+bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat
+bnd_ix8 = bnd_ba8
+
+-- | ByteArray bounds checking (16-bit offset, 16-bit value)
+bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat
+bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r
+
+-- | ByteArray bounds checking (32-bit offset, 32-bit value)
+bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat
+bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r
+
+-- | ByteArray bounds checking (64-bit offset, 64-bit value)
+bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat
+bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r
+
+-- | Bounds checking on a range and using ".len" property (ByteArrays)
+--
+-- Empty ranges trivially pass the check
+bnd_ba_range
+ :: Bool -- ^ Should we do bounds checking?
+ -> JExpr -- ^ Array
+ -> JExpr -- ^ Index
+ -> JExpr -- ^ Range size
+ -> JStat -- ^ Result
+ -> JStat
+bnd_ba_range False _ _ _ r = r
+bnd_ba_range True xs i n r =
+ ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $
+ -- Empty ranges trivially pass the check
+ ifS (n .===. zero_)
+ r
+ (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r))
+
+checkOverlapByteArray
+ :: Bool -- ^ Should we do bounds checking?
+ -> JExpr -- ^ First array
+ -> JExpr -- ^ First offset
+ -> JExpr -- ^ Second array
+ -> JExpr -- ^ Second offset
+ -> JExpr -- ^ Range size
+ -> JStat -- ^ Result
+ -> JStat
+checkOverlapByteArray False _ _ _ _ _ r = r
+checkOverlapByteArray True a1 o1 a2 o2 n r =
+ ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n])
r
(returnS $ app "h$exitProcess" [Int 134])
+copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes
+copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n]
+ where
+ check = bnd_ba_range bound a1 o1 n
+ . bnd_ba_range bound a2 o2 n
+ . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id)
+
-- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0
-- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript.
-- So (x|0) * (y|0) can still return values outside of the Int32 range. You have
=====================================
configure.ac
=====================================
@@ -13,7 +13,7 @@ dnl
# see what flags are available. (Better yet, read the documentation!)
#
-AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION])
+AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.4], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION])
# Version on master must be X.Y (not X.Y.Z) for ProjectVersionMunged variable
# to be useful (cf #19058). However, the version must have three components
# (X.Y.Z) on stable branches (e.g. ghc-9.2) to ensure that pre-releases are
@@ -22,7 +22,7 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-has
AC_CONFIG_MACRO_DIRS([m4])
# Set this to YES for a released version, otherwise NO
-: ${RELEASE=NO}
+: ${RELEASE=YES}
# The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line
# above. If this is not a released version, then we will append the
@@ -502,6 +502,7 @@ FP_PROG_LD_IS_GNU
FP_PROG_LD_BUILD_ID
FP_PROG_LD_NO_COMPACT_UNWIND
FP_PROG_LD_FILELIST
+FP_PROG_LD_SINGLE_MODULE
dnl ** Which nm to use?
dnl --------------------------------------------------------------
=====================================
distrib/configure.ac.in
=====================================
@@ -134,6 +134,7 @@ FP_PROG_LD_IS_GNU
FP_PROG_LD_BUILD_ID
FP_PROG_LD_NO_COMPACT_UNWIND
FP_PROG_LD_FILELIST
+FP_PROG_LD_SINGLE_MODULE
dnl ** which strip to use?
dnl --------------------------------------------------------------
=====================================
docs/users_guide/9.6.4-notes.rst
=====================================
@@ -0,0 +1,123 @@
+.. _release-9-6-4:
+
+Version 9.6.4
+==============
+
+The significant changes to the various parts of the compiler are listed below.
+See the `migration guide
+<https://gitlab.haskell.org/ghc/ghc/-/wikis/migration/9.6>`_ on the GHC Wiki
+for specific guidance on migrating programs to this release.
+
+The :ghc-flag:`LLVM backend <-fllvm>` of this release is to be used with LLVM
+11, 12, 13, 14 or 15.
+
+Significant Changes
+~~~~~~~~~~~~~~~~~~~~
+
+Issues fixed in this release include:
+
+Compiler
+--------
+
+- Fix a code generator bug on AArch64 platforms resulting in invalid conditional
+ jumps (:ghc-ticket:`23746`).
+- Fix a simplifier bug that may cause segfaults and core lint failures due to
+ incorrect handling of join points (:ghc-ticket:`23952`).
+- Ensure unconstrained instance dictionaries get IPE info (:ghc-ticket:`24005`).
+- Fix a bug where we could silently truncate 64 bit values to 32 bit on
+ 32 bit architectures.
+- Fix a GHCi bug where a failure in the ``:add`` command would cause the
+ process to exit (:ghc-ticket:`24115`).
+- Fix a bug causing suboptimal error messages for certain invalid cyclic
+ module graphs with hs-boot files (:ghc-ticket:`24196`).
+- Fix a bug causing compiler panics with certain package databases involving
+ unusable units and module reexports (:ghc-ticket:`21097`, :ghc-ticket:`16996`,
+ :ghc-ticket:`11050`).
+- Fix some memory leaks in GHCi that manifest on reloads (:ghc-ticket:`24107`,
+ :ghc-ticket:`24118`).
+- Fix a bug leading to some template haskell splices failing on being reloaded
+ into GHCi due to not clearing the interactive context properly
+ (:ghc-ticket:`23405`).
+- Fix a type checker crash on certain programs involving implicitly scoped type
+ variables (:ghc-ticket:`24083`).
+- Fix a bug where certain warning flags were not recognised (:ghc-ticket:`24071`).
+- Fix an incorrect assertion in the simplifier (:ghc-ticket:`23862`).
+
+Runtime system
+--------------
+
+- Ensure concurrent thunk update is sound (:ghc-ticket:`23185`).
+- Ensure the ``listAllBlocks`` function takes the non-moving heap into account
+ (:ghc-ticket:`22627`).
+- Ensure the non-moving GC is not running when pausing
+- Fix some non-moving loops and bugs on Windows and LLP64 platforms
+ (:ghc-ticket:`23003`, :ghc-ticket:`24042`).
+- Fix a bug where certain programs could have incorrect async exception masking
+ (:ghc-ticket:`23513`).
+- Ensure we respect maximum event length and don't overflow into program
+ memory (:ghc-ticket:`24197`).
+
+Build system and packaging
+--------------------------
+
+- Ensure we use the right linker flags on AArch64 darwin (:ghc-ticket:`21712`,
+ :ghc-ticket:`24033`).
+- Fix a bug where ``-DNOSMP`` wasn't being passed to the C compiler even if the
+ target doesn't support SMP (:ghc-ticket:`24082`).
+
+Core libraries
+--------------
+
+- Fix a bug in ghc-bignum where usage of `bigNatIsPowerOf2` might result in
+ out of bounds access (:ghc-ticket:`24066`).
+- Bump ``base`` to 4.18.2.0
+- base: Update to Unicode 15.1.0
+- Bump ``filepath`` to 1.4.200.1
+- Bump ``unix`` to 2.8.4.0
+- Bump ``haddock`` to 2.29.2
+
+Included libraries
+------------------
+
+The package database provided with this distribution also contains a number of
+packages other than GHC itself. See the changelogs provided with these packages
+for further change information.
+
+.. ghc-package-list::
+
+ libraries/array/array.cabal: Dependency of ``ghc`` library
+ libraries/base/base.cabal: Core library
+ libraries/binary/binary.cabal: Dependency of ``ghc`` library
+ libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library
+ libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility
+ libraries/Cabal/Cabal-syntax/Cabal-syntax.cabal: Dependency of ``ghc-pkg`` utility
+ libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library
+ libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library
+ libraries/directory/directory.cabal: Dependency of ``ghc`` library
+ libraries/exceptions/exceptions.cabal: Dependency of ``ghc`` and ``haskeline`` library
+ libraries/filepath/filepath.cabal: Dependency of ``ghc`` library
+ compiler/ghc.cabal: The compiler itself
+ libraries/ghci/ghci.cabal: The REPL interface
+ libraries/ghc-boot/ghc-boot.cabal: Internal compiler library
+ libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library
+ libraries/ghc-compact/ghc-compact.cabal: Core library
+ libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library
+ libraries/ghc-prim/ghc-prim.cabal: Core library
+ libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable
+ libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable
+ libraries/integer-gmp/integer-gmp.cabal: Core library
+ libraries/libiserv/libiserv.cabal: Internal compiler library
+ libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library
+ libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library
+ libraries/pretty/pretty.cabal: Dependency of ``ghc`` library
+ libraries/process/process.cabal: Dependency of ``ghc`` library
+ libraries/stm/stm.cabal: Dependency of ``haskeline`` library
+ libraries/template-haskell/template-haskell.cabal: Core library
+ libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library
+ libraries/text/text.cabal: Dependency of ``Cabal`` library
+ libraries/time/time.cabal: Dependency of ``ghc`` library
+ libraries/transformers/transformers.cabal: Dependency of ``ghc`` library
+ libraries/unix/unix.cabal: Dependency of ``ghc`` library
+ libraries/Win32/Win32.cabal: Dependency of ``ghc`` library
+ libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable
+
=====================================
docs/users_guide/release-notes.rst
=====================================
@@ -7,3 +7,4 @@ Release notes
9.6.1-notes
9.6.2-notes
9.6.3-notes
+ 9.6.4-notes
=====================================
hadrian/bindist/Makefile
=====================================
@@ -92,6 +92,7 @@ lib/settings : config.mk
@echo ',("ld flags", "$(SettingsLdFlags)")' >> $@
@echo ',("ld supports compact unwind", "$(LdHasNoCompactUnwind)")' >> $@
@echo ',("ld supports filelist", "$(LdHasFilelist)")' >> $@
+ @echo ',("ld supports single module", "$(LdHasSingleModule)")' >> $@
@echo ',("ld is GNU ld", "$(LdIsGNULd)")' >> $@
@echo ',("Merge objects command", "$(SettingsMergeObjectsCommand)")' >> $@
@echo ',("Merge objects flags", "$(SettingsMergeObjectsFlags)")' >> $@
=====================================
hadrian/bindist/config.mk.in
=====================================
@@ -240,6 +240,7 @@ LdHasBuildId = @LdHasBuildId@
LdHasFilelist = @LdHasFilelist@
LdIsGNULd = @LdIsGNULd@
LdHasNoCompactUnwind = @LdHasNoCompactUnwind@
+LdHasSingleModule = @LdHasSingleModule@
ArArgs = @ArArgs@
ArSupportsAtFile = @ArSupportsAtFile@
ArSupportsDashL = @ArSupportsDashL@
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -141,6 +141,7 @@ gcc-extra-via-c-opts = @GccExtraViaCOpts@
ld-has-no-compact-unwind = @LdHasNoCompactUnwind@
ld-has-filelist = @LdHasFilelist@
ld-is-gnu-ld = @LdIsGNULd@
+ld-supports-single-module = @LdHasSingleModule@
ar-args = @ArArgs@
settings-c-compiler-command = @SettingsCCompilerCommand@
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -430,6 +430,7 @@ generateSettings = do
, ("ld supports compact unwind", expr $ lookupSystemConfig "ld-has-no-compact-unwind")
, ("ld supports filelist", expr $ lookupSystemConfig "ld-has-filelist")
, ("ld is GNU ld", expr $ lookupSystemConfig "ld-is-gnu-ld")
+ , ("ld supports single module", expr $ lookupSystemConfig "ld-supports-single-module")
, ("Merge objects command", expr $ settingsFileSetting SettingsFileSetting_MergeObjectsCommand)
, ("Merge objects flags", expr $ settingsFileSetting SettingsFileSetting_MergeObjectsFlags)
, ("ar command", expr $ settingsFileSetting SettingsFileSetting_ArCommand)
=====================================
libraries/base/jsbits/base.js
=====================================
@@ -826,8 +826,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) {
}
const e = d.readSync();
- if (!dst_a.arr) dst_a.arr = [];
- dst_a.arr[dst_o*2] = [e,0];
+ PUT_ADDR(dst_a,dst_o*2,e,0);
return 0;
}
=====================================
m4/fp_prog_ld_single_module.m4
=====================================
@@ -0,0 +1,30 @@
+# FP_PROG_LD_SINGLE_MODULE
+# ----------------------------
+# Sets the output variable LdHasSingleModule to YES if the darwin ld supports
+# -single_module, or NO otherwise.
+#
+# In XCode 15, -single_module is a default and passing it as a flag raises a
+# warning.
+AC_DEFUN([FP_PROG_LD_SINGLE_MODULE],
+[
+AC_CACHE_CHECK([whether ld supports -single_module], [fp_cv_ld_single_module],
+[
+case $target in
+ *-darwin)
+ echo 'int foo(int x) { return x*x; }' > conftest.c
+ echo 'extern int foo(int); int main() { return foo(5); }' > conftestmain.c
+ "$CC" -c -o conftestmain.o conftestmain.c
+ "$CC" -shared -o conftest.dylib conftest.c
+ if "$CC" -Wl,-single_module -o conftest conftestmain.o conftest.dylib 2>&1 | grep obsolete > /dev/null; then
+ fp_cv_ld_single_module=no
+ else
+ fp_cv_ld_single_module=yes
+ fi
+ rm -rf conftest* ;;
+ *)
+ fp_cv_ld_single_module=no ;;
+esac
+])
+FP_CAPITALIZE_YES_NO(["$fp_cv_ld_single_module"], [LdHasSingleModule])
+AC_SUBST([LdHasSingleModule])
+])# FP_PROG_LD_SINGLE_MODULE
=====================================
rts/js/environment.js
=====================================
@@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) {
} else {
argc_v.dv.setInt32(argc_off, c, true);
var argv = h$newByteArray(4*c);
- argv.arr = [];
for(var i=0;i<h$programArgs().length;i++) {
- argv.arr[4*i] = [ h$encodeUtf8(h$programArgs()[i]), 0 ];
+ PUT_ADDR(argv,4*i,h$encodeUtf8(h$programArgs()[i]),0);
}
- if(!argv_v.arr) { argv_v.arr = []; }
- argv_v.arr[argv_off] = [argv, 0];
+ PUT_ADDR(argv_v,argv_off,argv,0);
}
}
function h$setProgArgv(n, ptr_d, ptr_o) {
args = [];
for(var i=0;i<n;i++) {
- var p = ptr_d.arr[ptr_o+4*i];
- var arg = h$decodeUtf8z(p[0], p[1]);
+ var off = ptr_o+4*i;
+ GET_ADDR(ptr_d,off,p,o);
+ var arg = h$decodeUtf8z(p, o);
args.push(arg);
}
h$programArgs_ = args;
@@ -218,9 +217,10 @@ function h$__hscore_environ() {
}
if(env.length === 0) return null;
var p = h$newByteArray(4*env.length+1);
- p.arr = [];
- for(i=0;i<env.length;i++) p.arr[4*i] = [h$encodeUtf8(env[i]), 0];
- p.arr[4*env.length] = [null, 0];
+ for(i=0;i<env.length;i++) {
+ PUT_ADDR(p,4*i,h$encodeUtf8(env[i]),0);
+ }
+ PUT_ADDR(p,4*env.length,null,0);
RETURN_UBX_TUP2(p, 0);
}
#endif
@@ -435,9 +435,8 @@ function h$localtime_r(timep_v, timep_o, result_v, result_o) {
result_v.dv.setInt32(result_o + 28, 0, true); // fixme yday 1-365 (366?)
result_v.dv.setInt32(result_o + 32, -1, true); // dst information unknown
result_v.dv.setInt32(result_o + 40, 0, true); // gmtoff?
- if(!result_v.arr) result_v.arr = [];
- result_v.arr[result_o + 40] = [h$myTimeZone, 0];
- result_v.arr[result_o + 48] = [h$myTimeZone, 0];
+ PUT_ADDR(result_v,result_o+40, h$myTimeZone, 0);
+ PUT_ADDR(result_v,result_o+48, h$myTimeZone, 0);
RETURN_UBX_TUP2(result_v, result_o);
}
var h$__hscore_localtime_r = h$localtime_r;
=====================================
rts/js/mem.js
=====================================
@@ -563,6 +563,20 @@ function h$copyMutableByteArray(a1,o1,a2,o2,n) {
a2.u8[o2+i] = a1.u8[o1+i];
}
}
+
+ // also update sub-array for Addr# support
+ if (!a1.arr) return;
+ if (!a2.arr) { a2.arr = [] };
+
+ if (o1 < o2) {
+ for (var i=n-1;i>=0;i--) {
+ a2.arr[o2+i] = a1.arr[o1+i] || null;
+ }
+ } else {
+ for (var i=0;i<n;i++) {
+ a2.arr[o2+i] = a1.arr[o1+i] || null;
+ }
+ }
}
//////////////////////////////////////////////////////////
@@ -961,7 +975,7 @@ function h$strlen(a_v, a_o) {
}
function h$newArray(len, e) {
- var r = [];
+ var r = new Array(len);
r.__ghcjsArray = true;
r.m = 0;
if(e === null) e = r;
@@ -986,6 +1000,7 @@ function h$newByteArray(len) {
, f3: new Float32Array(buf)
, f6: new Float64Array(buf)
, dv: new DataView(buf)
+ , arr: [] // for Addr# array part
, m: 0
}
}
@@ -1455,3 +1470,13 @@ function h$pext64(src_b, src_a, mask_b, mask_a) {
}
RETURN_UBX_TUP2(dst_b, dst_a);
}
+
+function h$checkOverlapByteArray(a1, o1, a2, o2, n) {
+ if (n == 0) return true;
+ if (a1 !== a2) return true;
+ if (o1 === o2) return true;
+
+ if (o1 < o2) return o2 - o1 >= n;
+ if (o1 > o2) return o1 - o2 >= n;
+ return true;
+}
=====================================
rts/js/profiling.js
=====================================
@@ -302,10 +302,9 @@ function h$buildCCPtr(o) {
#ifdef GHCJS_TRACE_PROF
cc.myTag = "cc pointer";
#endif
- cc.arr = [];
- cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0];
- cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0];
- cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0];
+ PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0);
+ PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0);
+ PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0);
return cc;
}
=====================================
rts/js/staticpointer.js
=====================================
@@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) {
ba.i3[1] = key1;
ba.i3[2] = key4;
ba.i3[3] = key3;
- h$static_pointer_table_keys.push([ba,0]);
+ h$static_pointer_table_keys.push(ba);
h$retain({ root: ref, _key: -1 });
}
var s = h$static_pointer_table;
@@ -33,8 +33,9 @@ function h$hs_spt_key_count() {
function h$hs_spt_keys(tgt_d, tgt_o, n) {
var ks = h$static_pointer_table_keys;
- if(!tgt_d.arr) tgt_d.arr = [];
- for(var i=0;(i<n&&i<ks.length);i++) tgt_d.arr[tgt_o+4*i] = ks[i];
+ for(var i=0;(i<n&&i<ks.length);i++) {
+ PUT_ADDR(tgt_d, tgt_o+4*i, ks[i], 0);
+ }
return Math.min(n,ks.length);
}
=====================================
rts/js/string.js
=====================================
@@ -602,47 +602,6 @@ function h$hs_iconv_close(iconv) {
return 0;
}
-// ptr* -> ptr (array)
-function h$derefPtrA(ptr, ptr_off) {
- return ptr.arr[ptr_off][0];
-}
-// ptr* -> ptr (offset)
-function h$derefPtrO(ptr, ptr_off) {
- return ptr.arr[ptr_off][1];
-}
-
-// word** -> word ptr[x][y]
-function h$readPtrPtrU32(ptr, ptr_off, x, y) {
- x = x || 0;
- y = y || 0;
- var arr = ptr.arr[ptr_off + 4 * x];
- return arr[0].dv.getInt32(arr[1] + 4 * y, true);
-}
-
-// char** -> char ptr[x][y]
-function h$readPtrPtrU8(ptr, ptr_off, x, y) {
- x = x || 0;
- y = y || 0;
- var arr = ptr.arr[ptr_off + 4 * x];
- return arr[0].dv.getUint8(arr[1] + y);
-}
-
-// word** ptr[x][y] = v
-function h$writePtrPtrU32(ptr, ptr_off, v, x, y) {
- x = x || 0;
- y = y || 0;
- var arr = ptr.arr[ptr_off + 4 * x];
- arr[0].dv.putInt32(arr[1] + y, v);
-}
-
-// unsigned char** ptr[x][y] = v
-function h$writePtrPtrU8(ptr, ptr_off, v, x, y) {
- x = x || 0;
- y = y || 0;
- var arr = ptr.arr[ptr_off+ 4 * x];
- arr[0].dv.putUint8(arr[1] + y, v);
-}
-
// convert JavaScript String to a Haskell String
#ifdef GHCJS_PROF
function h$toHsString(str, cc) {
=====================================
testsuite/tests/codeGen/should_fail/all.T
=====================================
@@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array
check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length
check_bounds_test('CheckOverlapCopyByteArray')
check_bounds_test('CheckOverlapCopyAddrToByteArray')
-
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -229,7 +229,7 @@ test('T20640b', normal, compile_and_run, [''])
test('T22296',[only_ways(llvm_ways)
,unless(arch('x86_64'), skip)],compile_and_run,[''])
test('T22798', normal, compile_and_run, ['-fregs-graph'])
-test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds'])
+test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds'])
# TODO: Enable more architectures here. N.B. some code generation backends are
# not implemeted correctly (according to
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/862a225013247e09621164bcead3befcadb6ba17...3ce937a721e77accc8578d603d477e66a1c28931
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/862a225013247e09621164bcead3befcadb6ba17...3ce937a721e77accc8578d603d477e66a1c28931
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/20231218/92cabc84/attachment-0001.html>
More information about the ghc-commits
mailing list