Skip to content

Commit

Permalink
fixes
Browse files Browse the repository at this point in the history
  • Loading branch information
d-kalinichenko committed Nov 14, 2024
1 parent 271bcd6 commit 951d7dd
Show file tree
Hide file tree
Showing 14 changed files with 228 additions and 77 deletions.
1 change: 0 additions & 1 deletion bytecomp/bytegen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -561,7 +561,6 @@ let comp_primitive stack_info p sz args =
| Runtime5 -> "runtime5" in
Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1)
| Pisint _ -> Kisint
| Pisnull -> Misc.fatal_error "null not implemented in bytecode" (* CR layouts v3: support null in bytecode *)
| Pisout -> Kisout
| Pbintofint (bi,_) -> comp_bint_primitive bi "of_int" args
| Pintofbint bi -> comp_bint_primitive bi "to_int" args
Expand Down
9 changes: 0 additions & 9 deletions bytecomp/emitcode.ml
Original file line number Diff line number Diff line change
Expand Up @@ -261,10 +261,6 @@ let emit_instr = function
out opCONSTINT; out_int (Char.code c)
| Const_block(t, []) ->
if t = 0 then out opATOM0 else (out opATOM; out_int t)
| Const_null ->
out opCONST0;
out opC_CALL1;
slot_for_c_prim "caml_int_as_pointer"
| _ ->
out opGETGLOBAL; slot_for_literal sc
end
Expand Down Expand Up @@ -400,11 +396,6 @@ let rec emit = function
out opPUSHCONSTINT; out_int(Char.code c)
| Const_block(t, []) ->
if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t)
| Const_null ->
out opPUSH;
out opCONST0;
out opC_CALL1;
slot_for_c_prim "caml_int_as_pointer"
| _ ->
out opPUSHGETGLOBAL; slot_for_literal sc
end;
Expand Down
5 changes: 3 additions & 2 deletions bytecomp/symtable.ml
Original file line number Diff line number Diff line change
Expand Up @@ -192,6 +192,8 @@ let output_primitive_table outchan =
opaque [Obj.t]. This is sufficient for interfacing with the runtime. *)
external float32_of_string : string -> Obj.t = "caml_float32_of_string"

external int_as_pointer : int -> Obj.t = "%int_as_pointer"

let rec transl_const = function
Const_base(Const_int i) -> Obj.repr i
| Const_base(Const_char c) -> Obj.repr c
Expand Down Expand Up @@ -225,8 +227,7 @@ let rec transl_const = function
List.iteri (fun i f -> Array.Floatarray.set res i (float_of_string f))
fields;
Obj.repr res
| Const_null -> Misc.fatal_error "[Const_null] not supported in bytecode."
(* CR layouts v3: add bytecode support. *)
| Const_null -> int_as_pointer 0

(* Initialization for batch linking *)

Expand Down
5 changes: 5 additions & 0 deletions runtime4/obj.c
Original file line number Diff line number Diff line change
Expand Up @@ -381,3 +381,8 @@ CAMLprim value caml_succ_scannable_prefix_len (value v) {
}
#endif /* NATIVE_CODE */
}

CAMLprim value caml_is_null(value v)
{
return v == Val_null ? Val_true : Val_false;
}
12 changes: 6 additions & 6 deletions testsuite/tests/basic/patmatch_for_multiple.ml
Original file line number Diff line number Diff line change
Expand Up @@ -104,11 +104,11 @@ let _ = fun a b -> match a, b with
[%%expect {|
(function {nlocal = 0} a/291[int] b/292
[(consts ()) (non_consts ([0: [int], *]))](let
(p/293 =a[(consts ())
(p/294 =a[(consts ())
(non_consts (
[0: [int], *]))]
(makeblock 0 a/291 b/292))
p/293))
p/294))
(function {nlocal = 0} a/291[int] b/292
[(consts ()) (non_consts ([0: [int], *]))](makeblock 0 a/291 b/292))
- : bool -> 'a -> bool * 'a = <fun>
Expand Down Expand Up @@ -140,11 +140,11 @@ let _ = fun a b -> match a, b with
[(consts ())
(non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], *]))]]))]
(let
(x/303 =a[int] a/301
p/304 =a[(consts ()) (non_consts ([0: [int], *]))]
(x/305 =a[int] a/301
p/306 =a[(consts ()) (non_consts ([0: [int], *]))]
(makeblock 0 a/301 b/302))
(makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) x/303
p/304)))
(makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) x/305
p/306)))
(function {nlocal = 0} a/301[int] b/302
[(consts ())
(non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], *]))]]))]
Expand Down
3 changes: 2 additions & 1 deletion testsuite/tests/parsetree/source_jane_street.ml
Original file line number Diff line number Diff line change
Expand Up @@ -170,7 +170,8 @@ end
let x () = #( M.Null, M.This "hi" )

[%%expect{|
module M : sig type 'a t = 'a or_null = Null | This of 'a end
module M :
sig type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] end
val x : unit -> #('a M.t * string M.t) @@ global many = <fun>
|}]

Expand Down
42 changes: 21 additions & 21 deletions testsuite/tests/typing-layouts-or-null/reexport.ml
Original file line number Diff line number Diff line change
Expand Up @@ -11,18 +11,15 @@ module Or_null = struct
| This of 'a
end

(* CR layouts v3: this error message is not great, but it will be a
different error message in the final PR. *)

[%%expect{|
Lines 2-4, characters 2-16:
2 | ..type ('a : value) t : value_or_null = 'a or_null =
3 | | Null
4 | | This of 'a
Error: The kind of type "'a or_null" is value_or_null
because it is the primitive value_or_null type or_null.
But the kind of type "'a or_null" must be a subkind of value
because of the definition of t at lines 2-4, characters 2-16.
Error: This variant or record definition does not match that of type
"'a or_null"
Their internal representations differ:
the original definition has a null constructor.
|}]

module Or_null = struct
Expand Down Expand Up @@ -62,7 +59,8 @@ let n = Or_null.Null
let t v = Or_null.This v

[%%expect{|
module Or_null : sig type 'a t = 'a or_null = Null | This of 'a end
module Or_null :
sig type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] end
val n : 'a Or_null.t = Or_null.Null
val t : 'a -> 'a Or_null.t = <fun>
|}]
Expand Down Expand Up @@ -90,7 +88,8 @@ end
let fail = Or_null.This (Or_null.This 5)

[%%expect{|
module Or_null : sig type 'a t = 'a or_null = Null | This of 'a end
module Or_null :
sig type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] end
Line 4, characters 24-40:
4 | let fail = Or_null.This (Or_null.This 5)
^^^^^^^^^^^^^^^^
Expand All @@ -110,10 +109,10 @@ type 'a t : value = 'a or_null [@@or_null_reexport]
Line 1, characters 0-51:
1 | type 'a t : value = 'a or_null [@@or_null_reexport]
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The kind of type "'a or_null" is value_or_null
Error: The kind of type "t" is value_or_null
because it is the primitive value_or_null type or_null.
But the kind of type "'a or_null" must be a subkind of value
because of the definition of t at line 1, characters 0-51.
But the kind of type "t" must be a subkind of value
because of the annotation on the declaration of the type t.
|}]

type 'a t : float64 = 'a or_null [@@or_null_reexport]
Expand All @@ -122,10 +121,10 @@ type 'a t : float64 = 'a or_null [@@or_null_reexport]
Line 1, characters 0-53:
1 | type 'a t : float64 = 'a or_null [@@or_null_reexport]
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The layout of type "'a or_null" is value
Error: The layout of type "t" is value
because it is the primitive value_or_null type or_null.
But the layout of type "'a or_null" must be a sublayout of float64
because of the definition of t at line 1, characters 0-53.
But the layout of type "t" must be a sublayout of float64
because of the annotation on the declaration of the type t.
|}]

type ('a : float64) t = 'a or_null [@@or_null_reexport]
Expand All @@ -150,7 +149,8 @@ end
let fail = Or_null.This (Or_null.This 5)

[%%expect{|
module Or_null : sig type 'a t = 'a or_null = Null | This of 'a end
module Or_null :
sig type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] end
Line 4, characters 24-40:
4 | let fail = Or_null.This (Or_null.This 5)
^^^^^^^^^^^^^^^^
Expand Down Expand Up @@ -233,7 +233,7 @@ type 'a t = 'a or_null [@@or_null_reexport]
and t' = int or_null

[%%expect{|
type 'a t = 'a or_null = Null | This of 'a
type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport]
and t' = int or_null
|}]

Expand All @@ -256,8 +256,8 @@ type 'a t1 = 'a or_null [@@or_null_reexport]
type 'a t2 = 'a t1 [@@or_null_reexport]

[%%expect{|
type 'a t1 = 'a or_null = Null | This of 'a
type 'a t2 = 'a t1 = Null | This of 'a
type 'a t1 = 'a or_null = Null | This of 'a [@@or_null_reexport]
type 'a t2 = 'a t1 = Null | This of 'a [@@or_null_reexport]
|}]

(* Correct injectivity and variance annotations are accepted. *)
Expand All @@ -267,8 +267,8 @@ type !'a t = 'a or_null [@@or_null_reexport]
type +'a t = 'a or_null [@@or_null_reexport]

[%%expect{|
type 'a t = 'a or_null = Null | This of 'a
type 'a t = 'a or_null = Null | This of 'a
type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport]
type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport]
|}]

(* Incorrect variance annotation fails. *)
Expand Down
150 changes: 150 additions & 0 deletions testsuite/tests/typing-layouts-or-null/runtime.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,150 @@
(* TEST
flags = "-extension layouts_alpha";
runtime5;
*)

let x = Null

let () =
match x with
| Null -> ()
| This _ -> assert false
;;

let y = This 3

let () =
match y with
| This 3 -> ()
| _ -> assert false
;;


external int_as_pointer : int -> int or_null = "%int_as_pointer"

let n = int_as_pointer 0

let () =
match n with
| Null -> ()
| _ -> assert false
;;

external int_as_int : int -> int or_null = "%identity"

let m = int_as_int 5

let () =
match m with
| This 5 -> ()
| This _ -> assert false
| Null -> assert false
;;

let x = (Null, This "bar")

let () =
match x with
| Null, This "foo" -> assert false
| Null, This "bar" -> ()
| _, This "bar" -> assert false
| Null, _ -> assert false
| _, _ -> assert false
;;

let y a = fun () -> This a

let d = y 5

let () =
match d () with
| This 5 -> ()
| _ -> assert false
;;

external to_bytes : ('a : value_or_null) . 'a -> int list -> bytes = "caml_output_value_to_bytes"

external from_bytes_unsafe : ('a : value_or_null) . bytes -> int -> 'a = "caml_input_value_from_bytes"

let z = to_bytes (This "foo") []

let () =
match from_bytes_unsafe z 0 with
| This "foo" -> ()
| This _ -> assert false
| Null -> assert false
;;

let w = to_bytes Null []

let () =
match from_bytes_unsafe w 0 with
| Null -> ()
| This _ -> assert false
;;

external evil : 'a or_null -> 'a = "%identity"

let e = This (evil Null)

let () =
match e with
| Null -> ()
| This _ -> assert false
;;

let e' = evil (This 4)

let () =
match e' with
| 4 -> ()
| _ -> assert false
;;

let f a = fun () ->
match a with
| This x -> x ^ "bar"
| Null -> "foo"
;;

let g = f (This "xxx")

let () =
match g () with
| "xxxbar" -> ()
| _ -> assert false
;;

let h = f Null

let () =
match h () with
| "foo" -> ()
| _ -> assert false
;;

type 'a nref = { mutable v : 'a or_null }

let x : string nref = { v = Null }

let () =
match x.v with
| Null -> ()
| _ -> assert false
;;

let () = x.v <- This "foo"

let () =
match x.v with
| This "foo" -> ()
| _ -> assert false
;;

let () = x.v <- Null

let () =
match x.v with
| Null -> ()
| _ -> assert false
;;
2 changes: 1 addition & 1 deletion testsuite/tests/typing-layouts-or-null/test_or_null.ml
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@
type ('a : value) t : value_or_null = 'a or_null [@@or_null_reexport]

[%%expect{|
type 'a t = 'a or_null = Null | This of 'a
type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport]
|}]

let to_option (x : 'a or_null) =
Expand Down
6 changes: 5 additions & 1 deletion tools/dumpobj.ml
Original file line number Diff line number Diff line change
Expand Up @@ -78,8 +78,12 @@ let record_events orig evl =
let same_custom x y =
Nativeint.equal (Obj.raw_field x 0) (Obj.raw_field (Obj.repr y) 0)

external is_null : Obj.t -> bool = "%is_null"

let rec print_obj x =
if Obj.is_block x then begin
if is_null x then
printf "null"
else if Obj.is_block x then begin
let tag = Obj.tag x in
if tag = Obj.string_tag then
printf "%S" (Obj.magic x : string)
Expand Down
Loading

0 comments on commit 951d7dd

Please sign in to comment.