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.

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

Add some native code tests for immediate/immediate64 #2016

Merged
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
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
100 changes: 100 additions & 0 deletions ocaml/testsuite/tests/typing-layouts/immediates.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,100 @@
(* TEST
reference = "${test_source_directory}/immediates.reference"
* flambda2
** native
flags = "-extension layouts_alpha"
** bytecode
flags = "-extension layouts_alpha"
** native
flags = "-extension layouts_beta"
** bytecode
flags = "-extension layouts_beta"
** native
flags = "-extension layouts"
** bytecode
flags = "-extension layouts"
** setup-ocamlc.byte-build-env
ocamlc_byte_exit_status = "2"
*** ocamlc.byte
compiler_reference = "${test_source_directory}/immediates_disabled.compilers.reference"
**** check-ocamlc.byte-output


*)

(* This tests some example uses of immediates in both native and bytecode. *)

(*****************************************)
(* Prelude: Some immediate types. *)

type a : immediate = A | B | C

(*********************************)
(* Test 1: higher-order function *)

let[@inline never] test1 (f : ('a : immediate). 'a -> 'a) =
match f 4 + f 5, f A with
| x, A -> Printf.printf "Test 1: %d\n" (x + 1)
| _, (B | C) -> assert false

let () = test1 (fun x -> x)

(****************************************)
(* Test 2: exercising the write barrier *)

type 'a mut =
{ mutable x : 'a }

type ('a : immediate) mut_imm =
{ mutable x_imm : 'a }

type ('a : immediate64) mut_imm64 =
{ mutable x_imm64 : 'a }

let[@inline never] update_with_write_barrier (type a) (m : a mut) (x : a) =
m.x <- x
;;

let[@inline never] update_1 (type (a : immediate)) (m : a mut) (x : a) =
m.x <- x
;;

let[@inline never] update_2 (type (a : immediate64)) (m : a mut) (x : a) =
m.x <- x
;;

let[@inline never] update_imm (type (a : immediate)) (m : a mut_imm) (x : a) =
m.x_imm <- x
;;

let[@inline never] update_imm64 (type (a : immediate64)) (m : a mut_imm64) (x : a) =
m.x_imm64 <- x
;;

let[@inline never] test2 x =
Printf.printf "Test 2: original value: %d\n" x;
let mut_non_imm = { x = [||] } in
let mut = { x } in
let mut_imm = { x_imm = x } in
let mut_imm64 = { x_imm64 = x } in
Gc.full_major ();
(* Exercise the write barrier by making something on the major heap point
back to the minor heap.
*)
update_with_write_barrier mut_non_imm [| x |];
Printf.printf " 1. mut_non_imm.x.(0): %d\n" mut_non_imm.x.(0);
update_with_write_barrier mut x;
Printf.printf " 2. mut.x: %d\n" mut.x;
update_1 mut x;
Printf.printf " 3. mut.x: %d\n" mut.x;
update_2 mut (x+1);
update_imm mut_imm (x+2);
update_imm64 mut_imm64 (x+3);
Gc.full_major ();
Printf.printf " 4. mut_non_imm.x.(0): %d\n" mut_non_imm.x.(0);
Printf.printf " 5. mut.x: %d\n" mut.x;
Printf.printf " 6. mut_imm.x_imm: %d\n" mut_imm.x_imm;
Printf.printf " 7. mut_imm64.x_imm64: %d\n" mut_imm64.x_imm64;
;;

let () = test2 123_456_789_000
9 changes: 9 additions & 0 deletions ocaml/testsuite/tests/typing-layouts/immediates.reference
Original file line number Diff line number Diff line change
@@ -0,0 +1,9 @@
Test 1: 10
Test 2: original value: 123456789000
1. mut_non_imm.x.(0): 123456789000
2. mut.x: 123456789000
3. mut.x: 123456789000
4. mut_non_imm.x.(0): 123456789000
5. mut.x: 123456789001
6. mut_imm.x_imm: 123456789002
7. mut_imm64.x_imm64: 123456789003
Original file line number Diff line number Diff line change
@@ -0,0 +1,4 @@
File "immediates.ml", line 35, characters 30-56:
35 | let[@inline never] test1 (f : ('a : immediate). 'a -> 'a) =
^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The extension "layouts" is disabled and cannot be used
Loading