Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

experiment: add flag to enable scalar tagging #4400

Merged
merged 8 commits into from
Feb 22, 2024
Merged

experiment: add flag to enable scalar tagging #4400

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
8 commits
Select commit Hold shift + click to select a range
7430f7b
add flag to enable rtti
crusso Feb 17, 2024
51df947
fix bugs in can_tag_i32/i64 tests and sanity checks
crusso Feb 18, 2024
bf55ff5
adjust test assert on heap size
crusso Feb 18, 2024
efc95a5
update perf numbers
crusso Feb 18, 2024
7b0b240
revert change
crusso Feb 18, 2024
53de330
revert test
crusso Feb 18, 2024
f550071
optimized clearing of all-zero tags
crusso Feb 18, 2024
16fa558
update perf numbers
crusso Feb 18, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
210 changes: 127 additions & 83 deletions src/codegen/compile.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,9 @@ let page_size = Int32.of_int (64*1024)
let page_size64 = Int64.of_int32 page_size
let page_size_bits = 16

(* Our code depends on OCaml int having at least 32 bits *)
let _ = assert (Sys.int_size >= 32)

(* Scalar Tagging Scheme *)

(* Rationale:
Expand Down Expand Up @@ -92,34 +95,64 @@ module TaggingScheme = struct
| _ -> TUnused

let tag_of_typ pty = Type.(
match pty with
| Nat
| Int -> 0b10l
| Nat64 -> 0b0100l
| Int64 -> 0b1100l
| Nat32 -> 0b01000l
| Int32 -> 0b11000l
| Char -> 0b010_00000000l
| Nat16 -> 0b01000000_00000000l
| Int16 -> 0b11000000_00000000l
| Nat8 -> 0b01000000_00000000_00000000l
| Int8 -> 0b11000000_00000000_00000000l
| _ -> assert false)

let unit_tag = (* all tag, no payload (none needed) *)
0b01000000_00000000_00000000_00000000l
if !Flags.rtti then
match pty with
| Nat
| Int -> 0b10l
| Nat64 -> 0b0100l
| Int64 -> 0b1100l
| Nat32 -> 0b01000l
| Int32 -> 0b11000l
| Char -> 0b010_00000000l
| Nat16 -> 0b01000000_00000000l
| Int16 -> 0b11000000_00000000l
| Nat8 -> 0b01000000_00000000_00000000l
| Int8 -> 0b11000000_00000000_00000000l
| _ -> assert false
else
(* no tag *)
match pty with
| Nat
| Int
| Nat64
| Int64
| Nat32
| Int32
| Char
| Nat16
| Int16
| Nat8
| Int8 -> 0l
| _ -> assert false)

let unit_tag () =
if !Flags.rtti then
(* all tag, no payload (none needed) *)
0b01000000_00000000_00000000_00000000l
else
(* no tag *)
0l

(* Number of payload bits in compact representation, including any sign *)
let ubits_of pty = Type.(
match pty with
| Nat | Int -> 30
| Nat64 | Int64 -> 28
| Nat32 | Int32 -> 27
| Char -> 21 (* suffices for 21-bit UTF8 codepoints *)
| Nat16 | Int16 -> 16
| Nat8 | Int8 -> 8
| _ -> assert false)

if !Flags.rtti then
match pty with
| Nat | Int -> 30
| Nat64 | Int64 -> 28
| Nat32 | Int32 -> 27
| Char -> 21 (* suffices for 21-bit UTF8 codepoints *)
| Nat16 | Int16 -> 16
| Nat8 | Int8 -> 8
| _ -> assert false
else
match pty with
| Nat | Int -> 31
| Nat64 | Int64 -> 31
| Nat32 | Int32 -> 31
| Char -> 21 (* suffices for 21-bit UTF8 codepoints *)
| Nat16 | Int16 -> 16
| Nat8 | Int8 -> 8
| _ -> assert false)
end

(*
Expand Down Expand Up @@ -1733,28 +1766,31 @@ module BitTagged = struct
if TaggingScheme.debug || !Flags.sanity then
get_x ^^
Func.share_code2 Func.Always env (prim_fun_name pty "check_can_tag_i64") (("res", I32Type), ("x", I64Type)) [I32Type]
(fun env get_res get_x ->
let lower_bound, upper_bound = Type.(
match pty with
| Nat | Int | Int64 | Int32 ->
let sbits = sbits_of pty in
Int64.(neg (shift_left 1L sbits), shift_left 1L sbits)
| Nat64 | Nat32 ->
let ubits = ubits_of pty in
(0L, Int64.shift_left 1L ubits)
| _ -> assert false)
in
(* lower_bound <= x < upper_bound *)
compile_const_64 lower_bound ^^
get_x ^^
G.i (Compare (Wasm.Values.I64 I64Op.LeS)) ^^
get_x ^^ compile_const_64 upper_bound ^^
G.i (Compare (Wasm.Values.I64 I64Op.LtS)) ^^
G.i (Binary (Wasm.Values.I32 I32Op.And)) ^^
get_res ^^
G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^
E.else_trap_with env (prim_fun_name pty "check_can_tag_i64") ^^
get_res)
(fun env get_res get_x -> Type.(
match pty with
| Nat | Int | Int64 | Int32 ->
let sbits = sbits_of pty in
let lower_bound = Int64.(neg (shift_left 1L sbits)) in
let upper_bound = Int64.shift_left 1L sbits in
(* lower_bound <= x < upper_bound *)
compile_const_64 lower_bound ^^
get_x ^^
G.i (Compare (Wasm.Values.I64 I32Op.LeS)) ^^
get_x ^^ compile_const_64 upper_bound ^^
G.i (Compare (Wasm.Values.I64 I32Op.LtS)) ^^
G.i (Binary (Wasm.Values.I32 I32Op.And))
| Nat64 | Nat32 ->
let ubits = ubits_of pty in
let upper_bound = Int64.shift_left 1L ubits in
(* 0 <= x < upper_bound *)
get_x ^^ compile_const_64 upper_bound ^^
G.i (Compare (Wasm.Values.I64 I32Op.LtU))
| _ ->
assert false) ^^
get_res ^^
G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^
E.else_trap_with env (prim_fun_name pty "check_can_tag_i64") ^^
get_res)
else
G.nop

Expand All @@ -1765,7 +1801,7 @@ module BitTagged = struct
(prim_fun_name pty "if_can_tag_i64") ("x", I64Type) [I32Type] (fun env get_x ->
(* checks that all but the low sbits are either all 0 or all 1 *)
get_x ^^
get_x ^^ compile_shrS64_const (Int64.of_int ((64 - ubits_of pty) - 1)) ^^
get_x ^^ compile_shrS64_const (Int64.of_int (64 - sbits_of pty)) ^^
G.i (Binary (Wasm.Values.I64 I32Op.Xor)) ^^
compile_shrU64_const (Int64.of_int (sbits_of pty)) ^^
G.i (Test (Wasm.Values.I64 I64Op.Eqz)) ^^
Expand Down Expand Up @@ -1835,28 +1871,31 @@ module BitTagged = struct
if TaggingScheme.debug || !Flags.sanity then
get_x ^^
Func.share_code2 Func.Always env (prim_fun_name pty "check_can_tag_i32") (("res", I32Type), ("x", I32Type)) [I32Type]
(fun env get_res get_x ->
let lower_bound, upper_bound = Type.(
match pty with
| Nat | Int | Int64 | Int32 ->
let sbits = sbits_of pty in
(Int32.(neg (shift_left 1l sbits)), Int32.shift_left 1l sbits)
| Nat64 | Nat32 ->
let ubits = ubits_of pty in
(0l, Int32.shift_left 1l ubits)
| _ -> assert false)
in
(* lower_bound <= x < upper_bound *)
compile_unboxed_const lower_bound ^^
get_x ^^
G.i (Compare (Wasm.Values.I32 I32Op.LeS)) ^^
get_x ^^ compile_unboxed_const upper_bound ^^
G.i (Compare (Wasm.Values.I32 I32Op.LtS)) ^^
G.i (Binary (Wasm.Values.I32 I32Op.And)) ^^
get_res ^^
G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^
E.else_trap_with env (prim_fun_name pty "check_can_tag_i32") ^^
get_res)
(fun env get_res get_x -> Type.(
match pty with
| Nat | Int | Int64 | Int32 ->
let sbits = sbits_of pty in
let lower_bound = Int32.(neg (shift_left 1l sbits)) in
let upper_bound = Int32.shift_left 1l sbits in
(* lower_bound <= x < upper_bound *)
compile_unboxed_const lower_bound ^^
get_x ^^
G.i (Compare (Wasm.Values.I32 I32Op.LeS)) ^^
get_x ^^ compile_unboxed_const upper_bound ^^
G.i (Compare (Wasm.Values.I32 I32Op.LtS)) ^^
G.i (Binary (Wasm.Values.I32 I32Op.And))
| Nat64 | Nat32 ->
let ubits = ubits_of pty in
let upper_bound = Int32.shift_left 1l ubits in
(* 0 <= x < upper_bound *)
get_x ^^ compile_unboxed_const upper_bound ^^
G.i (Compare (Wasm.Values.I32 I32Op.LtU))
| _ ->
assert false) ^^
get_res ^^
G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^
E.else_trap_with env (prim_fun_name pty "check_can_tag_i32") ^^
get_res)
else
G.nop

Expand All @@ -1866,7 +1905,7 @@ module BitTagged = struct
(prim_fun_name pty "if_can_tag_i32") ("x", I32Type) [I32Type] (fun env get_x ->
(* checks that all but the low sbits are both either 0 or 1 *)
get_x ^^
get_x ^^ compile_shrS_const (Int32.of_int ((32 - ubits_of pty) - 1)) ^^
get_x ^^ compile_shrS_const (Int32.of_int (32 - sbits_of pty)) ^^
G.i (Binary (Wasm.Values.I32 I32Op.Xor)) ^^
compile_shrU_const (Int32.of_int (sbits_of pty)) ^^
G.i (Test (Wasm.Values.I32 I32Op.Eqz)) ^^
Expand Down Expand Up @@ -1915,6 +1954,13 @@ module BitTagged = struct
compile_shrU_const (Int32.sub 32l (Int32.of_int ubits))
| _ -> assert false)

let clear_tag env pty =
if TaggingScheme.tag_of_typ pty <> 0l then
let shift_amount = 32 - ubits_of pty in
let mask = Int32.(lognot (sub (shift_left one shift_amount) one)) in
compile_bitand_const mask
else G.nop

end (* BitTagged *)

module Tagged = struct
Expand Down Expand Up @@ -2913,7 +2959,7 @@ module TaggedSmallWord = struct
(* check tag *)
BitTagged.sanity_check_tag __LINE__ env pty ^^
(* clear tag *)
compile_bitand_const (mask_of_type pty)
BitTagged.clear_tag env pty
| _ -> assert false

end (* TaggedSmallWord *)
Expand Down Expand Up @@ -3240,9 +3286,7 @@ module MakeCompact (Num : BigNumType) : BigNumType = struct
(* examine the skewed pointer and determine if number fits into ubits *)
let fits_in_vanilla env = Num.fits_signed_bits env (BitTagged.ubits_of Type.Int)

let clear_tag env =
let mask = Int32.(lognot (sub (shift_left 1l (32 - BitTagged.ubits_of Type.Int)) 1l)) in
compile_bitand_const mask
let clear_tag env = BitTagged.clear_tag env Type.Int

(* Tagged scalar to right-0-padded signed i64 *)
let extend64 env =
Expand Down Expand Up @@ -4782,8 +4826,8 @@ module Tuple = struct

(* We represent the boxed empty tuple as the unboxed scalar 0, i.e. simply as
number (but really anything is fine, we never look at this) *)
let unit_vanilla_lit = TaggingScheme.unit_tag (* all tag, trivial payload *)
let compile_unit = compile_unboxed_const unit_vanilla_lit
let unit_vanilla_lit env = TaggingScheme.unit_tag () (* all tag, trivial payload *)
let compile_unit env = compile_unboxed_const (unit_vanilla_lit ())

(* Expects on the stack the pointer to the array. *)
let load_n env n =
Expand All @@ -4792,7 +4836,7 @@ module Tuple = struct

(* Takes n elements of the stack and produces an argument tuple *)
let from_stack env n =
if n = 0 then compile_unit
if n = 0 then compile_unit env
else
let name = Printf.sprintf "to_%i_tuple" n in
let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i, I32Type) in
Expand Down Expand Up @@ -5283,7 +5327,7 @@ module IC = struct
get_code ^^ compile_unboxed_const const ^^
G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^
G.if1 I32Type
(Variant.inject env tag Tuple.compile_unit)
(Variant.inject env tag (Tuple.compile_unit env))
code)
["system_fatal", 1l;
"system_transient", 2l;
Expand Down Expand Up @@ -8700,7 +8744,7 @@ module StackRep = struct
| Const.Obj fs ->
let fs' = List.map (fun (n, c) -> (n, materialize_const_t env c)) fs in
Object.vanilla_lit env fs'
| Const.Unit -> Tuple.unit_vanilla_lit
| Const.Unit -> Tuple.unit_vanilla_lit env
| Const.Array cs ->
let ptrs = List.map (materialize_const_t env) cs in
Arr.vanilla_lit env ptrs
Expand Down Expand Up @@ -9149,7 +9193,7 @@ module FuncDec = struct
(* reply early for a oneway *)
(if control = Type.Returns
then
Tuple.compile_unit ^^
Tuple.compile_unit env ^^
Serialization.serialize env [] ^^
IC.reply_with_data env
else G.nop) ^^
Expand Down Expand Up @@ -9540,7 +9584,7 @@ module FuncDec = struct
(* To avoid more failing allocation, don't deserialize args nor serialize reply,
i.e. don't even try to do this:
Serialization.deserialize env [] ^^
Tuple.compile_unit ^^
Tuple.compile_unit env ^^
Serialization.serialize env [] ^^
*)
(* Instead, just ignore the argument and
Expand Down Expand Up @@ -10999,7 +11043,7 @@ and compile_prim_invocation (env : E.t) ae p es at =
begin match ts with
| [] ->
(* return some () *)
Opt.inject env Tuple.compile_unit
Opt.inject env (Tuple.compile_unit env)
| [t] ->
(* save to local, propagate error as null or return some value *)
let (set_val, get_val) = new_local env "val" in
Expand Down
1 change: 1 addition & 0 deletions src/mo_config/flags.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -46,6 +46,7 @@ let experimental_field_aliasing = ref false
let ocaml_js = ref false
let rts_stack_pages_default = 32 (* 2MB *)
let rts_stack_pages : int ref = ref rts_stack_pages_default
let rtti = ref false
let trap_on_call_error = ref false
let use_stable_regions = ref false
let share_code = ref false
6 changes: 3 additions & 3 deletions test/bench/ok/alloc.drun-run-opt.ok
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,8 +1,8 @@
ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
ingress Completed: Reply: 0x4449444c0000
debug.print: (+268_435_456, 3_373_867_377)
debug.print: (+268_435_456, 3_004_768_603)
ingress Completed: Reply: 0x4449444c0000
debug.print: (+268_435_456, 3_372_384_625)
debug.print: (+268_435_456, 3_003_285_851)
ingress Completed: Reply: 0x4449444c0000
debug.print: (+268_435_456, 3_372_384_625)
debug.print: (+268_435_456, 3_003_285_851)
ingress Completed: Reply: 0x4449444c0000
6 changes: 3 additions & 3 deletions test/bench/ok/alloc.drun-run.ok
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,8 +1,8 @@
ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
ingress Completed: Reply: 0x4449444c0000
debug.print: (+268_435_456, 3_441_090_958)
debug.print: (+268_435_456, 3_071_992_186)
ingress Completed: Reply: 0x4449444c0000
debug.print: (+268_435_456, 3_439_583_630)
debug.print: (+268_435_456, 3_070_484_858)
ingress Completed: Reply: 0x4449444c0000
debug.print: (+268_435_456, 3_439_583_630)
debug.print: (+268_435_456, 3_070_484_858)
ingress Completed: Reply: 0x4449444c0000
4 changes: 2 additions & 2 deletions test/bench/ok/bignum.drun-run-opt.ok
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
ingress Completed: Reply: 0x4449444c0000
debug.print: {cycles = 2_512_909; size = +59_652}
debug.print: {cycles = 2_512_723; size = +59_652}
ingress Completed: Reply: 0x4449444c0000
debug.print: {cycles = 107_695_087; size = +1_817_872}
debug.print: {cycles = 107_695_051; size = +1_817_872}
ingress Completed: Reply: 0x4449444c0000
4 changes: 2 additions & 2 deletions test/bench/ok/bignum.drun-run.ok
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
ingress Completed: Reply: 0x4449444c0000
debug.print: {cycles = 2_620_042; size = +59_652}
debug.print: {cycles = 2_619_856; size = +59_652}
ingress Completed: Reply: 0x4449444c0000
debug.print: {cycles = 107_890_056; size = +1_817_872}
debug.print: {cycles = 107_890_020; size = +1_817_872}
ingress Completed: Reply: 0x4449444c0000
4 changes: 2 additions & 2 deletions test/bench/ok/heap-32.drun-run-opt.ok
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
ingress Completed: Reply: 0x4449444c0000
debug.print: (50_227, +33_340_296, 763_038_144)
debug.print: (50_070, +34_703_580, 793_972_423)
debug.print: (50_227, +29_863_068, 708_174_952)
debug.print: (50_070, +32_992_212, 766_613_680)
ingress Completed: Reply: 0x4449444c0000
4 changes: 2 additions & 2 deletions test/bench/ok/heap-32.drun-run.ok
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
ingress Completed: Reply: 0x4449444c0000
debug.print: (50_227, +33_340_296, 826_535_101)
debug.print: (50_070, +34_703_580, 859_094_948)
debug.print: (50_227, +29_863_068, 769_000_085)
debug.print: (50_070, +32_992_212, 830_427_376)
ingress Completed: Reply: 0x4449444c0000
2 changes: 1 addition & 1 deletion test/bench/ok/nat16.drun-run-opt.ok
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
ingress Completed: Reply: 0x4449444c016c01b3c4b1f204680100010a00000000000000000101
ingress Completed: Reply: 0x4449444c0000
debug.print: (0, 22_021_275)
debug.print: (0, 22_021_107)
ingress Completed: Reply: 0x4449444c0000
Loading
Loading