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

Implement unboxed float literals #2025

Merged
merged 12 commits into from
Nov 27, 2023
Merged

Implement unboxed float literals #2025

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
12 commits
Select commit Hold shift + click to select a range
524be49
implement unboxed float literals
alanechang Nov 10, 2023
6a5efa8
fix test
alanechang Nov 10, 2023
998bf1e
allocation test
alanechang Nov 10, 2023
9c1a2cf
remove unused error
alanechang Nov 20, 2023
977570e
make unboxed literals alpha
alanechang Nov 20, 2023
3463194
add native test
alanechang Nov 20, 2023
0964ed3
clean up test output
alanechang Nov 21, 2023
f2d9a1e
pass args for alloc test
alanechang Nov 21, 2023
dd628a5
remove print_flush
alanechang Nov 22, 2023
a781108
refactor Untypeast.constant
alanechang Nov 22, 2023
cfc52c8
add comment
alanechang Nov 22, 2023
0fe6825
add missing build_other case
alanechang Nov 22, 2023
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
Next Next commit
implement unboxed float literals
  • Loading branch information
@alanechang
alanechang committed Nov 10, 2023
commit 524be490ea829a49757c0cd745cdd408f0d34c17
36 changes: 27 additions & 9 deletions ocaml/lambda/matching.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1171,6 +1171,7 @@ let can_group discr pat =
| Constant (Const_char _), Constant (Const_char _)
| Constant (Const_string _), Constant (Const_string _)
| Constant (Const_float _), Constant (Const_float _)
| Constant (Const_unboxed_float _), Constant (Const_unboxed_float _)
| Constant (Const_int32 _), Constant (Const_int32 _)
| Constant (Const_int64 _), Constant (Const_int64 _)
| Constant (Const_nativeint _), Constant (Const_nativeint _) ->
Expand All @@ -1194,7 +1195,7 @@ let can_group discr pat =
( Any
| Constant
( Const_int _ | Const_char _ | Const_string _ | Const_float _
| Const_int32 _ | Const_int64 _ | Const_nativeint _ )
| Const_unboxed_float _ | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
| Construct _ | Tuple _ | Record _ | Array _ | Variant _ | Lazy ) ) ->
false

Expand Down Expand Up @@ -2536,7 +2537,7 @@ let rec do_tests_fail value_kind loc fail tst arg = function
| [] -> fail
| (c, act) :: rem ->
Lifthenelse
( Lprim (tst, [ arg; Lconst (Const_base c) ], loc),
( Lprim (tst, [ arg; c ], loc),
do_tests_fail value_kind loc fail tst arg rem,
act, value_kind )

Expand All @@ -2545,15 +2546,16 @@ let rec do_tests_nofail value_kind loc tst arg = function
| [ (_, act) ] -> act
| (c, act) :: rem ->
Lifthenelse
( Lprim (tst, [ arg; Lconst (Const_base c) ], loc),
( Lprim (tst, [ arg; c ], loc),
do_tests_nofail value_kind loc tst arg rem,
act, value_kind )

let make_test_sequence value_kind loc fail tst lt_tst arg const_lambda_list =
let make_test_sequence value_kind loc fail tst lt_tst arg const_lambda_list transl_const =
let const_lambda_list = sort_lambda_list const_lambda_list in
let hs, const_lambda_list, fail =
share_actions_tree value_kind const_lambda_list fail
in
let const_lambda_list = List.map (fun (c, l) -> transl_const c, l) const_lambda_list in
let rec make_test_sequence const_lambda_list =
if List.length const_lambda_list >= 4 && lt_tst <> Pignore then
split_sequence const_lambda_list
Expand All @@ -2566,7 +2568,7 @@ let make_test_sequence value_kind loc fail tst lt_tst arg const_lambda_list =
rev_split_at (List.length const_lambda_list / 2) const_lambda_list
in
Lifthenelse
( Lprim (lt_tst, [ arg; Lconst (Const_base (fst (List.hd list2))) ], loc),
( Lprim (lt_tst, [ arg; fst (List.hd list2) ], loc),
make_test_sequence list1,
make_test_sequence list2, value_kind )
in
Expand Down Expand Up @@ -2963,6 +2965,16 @@ let mk_failaction_pos partial seen ctx defs =
let combine_constant value_kind loc arg cst partial ctx def
(const_lambda_list, total, _pats) =
let fail, local_jumps = mk_failaction_neg partial ctx def in
let transl_const = function
| Const_int c -> Lconst(Const_base (Const_int c))
| Const_char c -> Lconst(Const_base (Const_char c))
| Const_string (s,loc,d) -> Lconst(Const_base (Const_string (s,loc,d)))
| Const_float c -> Lconst(Const_base (Const_float c))
| Const_int32 c -> Lconst(Const_base (Const_int32 c))
| Const_int64 c -> Lconst(Const_base (Const_int64 c))
| Const_nativeint c -> Lconst(Const_base (Const_nativeint c))
| Const_unboxed_float f -> Lconst (Const_base (Const_float f))
in
let lambda1 =
match cst with
| Const_int _ ->
Expand Down Expand Up @@ -3002,22 +3014,28 @@ let combine_constant value_kind loc arg cst partial ctx def
| Const_float _ ->
make_test_sequence value_kind loc fail (Pfloatcomp CFneq)
(Pfloatcomp CFlt) arg
const_lambda_list
const_lambda_list transl_const
| Const_unboxed_float _ ->
make_test_sequence value_kind loc fail
(Pfloatcomp CFneq)
(Pfloatcomp CFlt)
(Lprim (Pbox_float Lambda.alloc_local, [arg], loc))
const_lambda_list transl_const
| Const_int32 _ ->
make_test_sequence value_kind loc fail
(Pbintcomp (Pint32, Cne))
(Pbintcomp (Pint32, Clt))
arg const_lambda_list
arg const_lambda_list transl_const
| Const_int64 _ ->
make_test_sequence value_kind loc fail
(Pbintcomp (Pint64, Cne))
(Pbintcomp (Pint64, Clt))
arg const_lambda_list
arg const_lambda_list transl_const
| Const_nativeint _ ->
make_test_sequence value_kind loc fail
(Pbintcomp (Pnativeint, Cne))
(Pbintcomp (Pnativeint, Clt))
arg const_lambda_list
arg const_lambda_list transl_const
in
(lambda1, Jumps.union local_jumps total)

Expand Down
13 changes: 12 additions & 1 deletion ocaml/lambda/translcore.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -390,7 +390,18 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
transl_ident (of_location ~scopes e.exp_loc)
e.exp_env e.exp_type path desc kind
| Texp_constant cst ->
Lconst(Const_base cst)
begin match cst with
| Const_int c -> Lconst(Const_base (Const_int c))
| Const_char c -> Lconst(Const_base (Const_char c))
| Const_string (s,loc,d) -> Lconst(Const_base (Const_string (s,loc,d)))
| Const_float c -> Lconst(Const_base (Const_float c))
| Const_int32 c -> Lconst(Const_base (Const_int32 c))
| Const_int64 c -> Lconst(Const_base (Const_int64 c))
| Const_nativeint c -> Lconst(Const_base (Const_nativeint c))
| Const_unboxed_float f ->
Lprim (Punbox_float, [Lconst (Const_base (Const_float f))],
of_location ~scopes e.exp_loc)
end
| Texp_let(rec_flag, pat_expr_list, body) ->
let return_layout = layout_exp sort body in
transl_let ~scopes ~return_layout rec_flag pat_expr_list
Expand Down
6 changes: 5 additions & 1 deletion ocaml/typing/parmatch.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -131,13 +131,15 @@ let all_coherent column =
| Const_int64 _, Const_int64 _
| Const_nativeint _, Const_nativeint _
| Const_float _, Const_float _
| Const_unboxed_float _, Const_unboxed_float _
| Const_string _, Const_string _ -> true
| ( Const_char _
| Const_int _
| Const_int32 _
| Const_int64 _
| Const_nativeint _
| Const_float _
| Const_unboxed_float _
| Const_string _), _ -> false
end
| Tuple l1, Tuple l2 -> l1 = l2
Expand Down Expand Up @@ -240,6 +242,7 @@ let is_absent_pat d =

let const_compare x y =
match x,y with
| Const_unboxed_float f1, Const_unboxed_float f2
| Const_float f1, Const_float f2 ->
Stdlib.compare (float_of_string f1) (float_of_string f2)
| Const_string (s1, _, _), Const_string (s2, _, _) ->
Expand All @@ -248,6 +251,7 @@ let const_compare x y =
|Const_char _
|Const_string (_, _, _)
|Const_float _
|Const_unboxed_float _
|Const_int32 _
|Const_int64 _
|Const_nativeint _
Expand Down Expand Up @@ -2074,7 +2078,7 @@ let inactive ~partial pat =
| Tpat_constant c -> begin
match c with
| Const_string _
| Const_int _ | Const_char _ | Const_float _
| Const_int _ | Const_char _ | Const_float _ | Const_unboxed_float _
| Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true
end
| Tpat_tuple ps | Tpat_construct (_, _, ps, _)
Expand Down
8 changes: 8 additions & 0 deletions ocaml/typing/printpat.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,14 @@ let pretty_const c = match c with
| Const_char c -> Printf.sprintf "%C" c
| Const_string (s, _, _) -> Printf.sprintf "%S" s
| Const_float f -> Printf.sprintf "%s" f
| Const_unboxed_float f ->
let s =
match String.split_on_char '-' f with
| [""; f] -> "-#" ^ f
| [f] -> "#" ^ f
| _ -> assert false
in
Printf.sprintf "%s" s
| Const_int32 i -> Printf.sprintf "%ldl" i
| Const_int64 i -> Printf.sprintf "%LdL" i
| Const_nativeint i -> Printf.sprintf "%ndn" i
Expand Down
2 changes: 1 addition & 1 deletion ocaml/typing/printpat.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -16,7 +16,7 @@


val pretty_const
: Asttypes.constant -> string
: Typedtree.constant -> string
val top_pretty
: Format.formatter -> 'k Typedtree.general_pattern -> unit
val pretty_pat
Expand Down
1 change: 1 addition & 0 deletions ocaml/typing/printtyped.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -67,6 +67,7 @@ let fmt_constant f x =
| Const_string (s, strloc, Some delim) ->
fprintf f "Const_string (%S,%a,Some %S)" s fmt_location strloc delim
| Const_float (s) -> fprintf f "Const_float %s" s
| Const_unboxed_float (s) -> fprintf f "Const_unboxed_float %s" s
| Const_int32 (i) -> fprintf f "Const_int32 %ld" i
| Const_int64 (i) -> fprintf f "Const_int64 %Ld" i
| Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i
Expand Down
38 changes: 13 additions & 25 deletions ocaml/typing/typecore.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -589,22 +589,17 @@ let optimise_allocations () =

(* Typing of constants *)

let type_constant = function
let type_constant: Typedtree.constant -> type_expr = function
Const_int _ -> instance Predef.type_int
| Const_char _ -> instance Predef.type_char
| Const_string _ -> instance Predef.type_string
| Const_float _ -> instance Predef.type_float
| Const_unboxed_float _ -> instance Predef.type_unboxed_float
| Const_int32 _ -> instance Predef.type_int32
| Const_int64 _ -> instance Predef.type_int64
| Const_nativeint _ -> instance Predef.type_nativeint

let type_constant_unboxed env loc
: Jane_syntax.Layouts.constant -> _ = function
| Float _ -> raise (Error (loc, env, Unboxed_float_literals_not_supported))
(* CR layouts v2.5: This should be [instance Predef.type_unboxed_float] *)
| Integer _ -> raise (Error (loc, env, Unboxed_int_literals_not_supported))

let constant_integer i ~suffix : (Asttypes.constant, error) result =
let constant_integer i ~suffix : (Typedtree.constant, error) result =
match suffix with
| 'l' ->
begin
Expand All @@ -623,7 +618,7 @@ let constant_integer i ~suffix : (Asttypes.constant, error) result =
end
| c -> Error (Unknown_literal (i, c))

let constant : Parsetree.constant -> (Asttypes.constant, error) result =
let constant : Parsetree.constant -> (Typedtree.constant, error) result =
function
| Pconst_integer (i, Some suffix) -> constant_integer i ~suffix
| Pconst_integer (i,None) ->
Expand All @@ -641,22 +636,15 @@ let constant_or_raise env loc cst =
| Ok c -> c
| Error err -> raise (Error (loc, env, err))

let unboxed_constant :
type a. Jane_syntax.Layouts.constant -> (a, error) result
let unboxed_constant : Jane_syntax.Layouts.constant -> (Typedtree.constant, error) result
= function
| Float (_, None) -> Error Unboxed_float_literals_not_supported
| Float (f, None) -> Ok (Const_unboxed_float f)
| Float (x, Some c) -> Error (Unknown_literal ("#" ^ x, c))
| Integer (_, _) -> Error Unboxed_int_literals_not_supported

(* CR layouts v2.5: this is missing the part where we actually typecheck
unboxed literals.
*)
let unboxed_constant_or_raise env loc cst =
let open struct
type nothing = |
end in
match unboxed_constant cst with
| Ok (_ : nothing) -> .
| Ok c -> c
| Error err -> raise (Error (loc, env, err))

(* Specific version of type_option, using newty rather than newgenty *)
Expand Down Expand Up @@ -2307,11 +2295,11 @@ and type_pat_aux
| Jpat_immutable_array (Iapat_immutable_array spl) ->
type_pat_array Immutable spl attrs
| Jpat_layout (Lpat_constant cst) ->
let desc = unboxed_constant_or_raise !env loc cst in
let cst = unboxed_constant_or_raise !env loc cst in
rvp @@ solve_expected {
pat_desc = desc;
pat_desc = Tpat_constant cst;
pat_loc = loc; pat_extra=[];
pat_type = type_constant_unboxed !env loc cst;
pat_type = type_constant cst;
pat_attributes = attrs;
pat_env = !env }
end
Expand Down Expand Up @@ -3021,7 +3009,6 @@ let rec check_counter_example_pat
end
| Tpat_alias (p, _, _, _, _) -> check_rec ~info p expected_ty k
| Tpat_constant cst ->
let cst = constant_or_raise !env loc (Untypeast.constant cst) in
ncik-roberts marked this conversation as resolved.
Show resolved Hide resolved
k @@ solve_expected (mp (Tpat_constant cst) ~pat_type:(type_constant cst))
| Tpat_tuple tpl ->
let tpl_ann =
Expand Down Expand Up @@ -8343,11 +8330,12 @@ and type_jkind_expr
name (Some jkind_annot) sbody

and type_unboxed_constant ~loc ~env ~rue ~attributes cst =
let cst = unboxed_constant_or_raise env loc cst in
rue {
exp_desc = unboxed_constant_or_raise env loc cst;
exp_desc = Texp_constant cst;
exp_loc = loc;
exp_extra = [];
exp_type = type_constant_unboxed env loc cst;
exp_type = type_constant cst;
exp_attributes = attributes;
exp_env = env }

Expand Down
2 changes: 1 addition & 1 deletion ocaml/typing/typecore.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -312,7 +312,7 @@ val type_package:
(Env.t -> Parsetree.module_expr -> Path.t -> (Longident.t * type_expr) list ->
Typedtree.module_expr * (Longident.t * type_expr) list) ref

val constant: Parsetree.constant -> (Asttypes.constant, error) result
val constant: Parsetree.constant -> (Typedtree.constant, error) result

val check_recursive_bindings : Env.t -> Typedtree.value_binding list -> unit
val check_recursive_class_bindings :
Expand Down
10 changes: 10 additions & 0 deletions ocaml/typing/typedtree.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,16 @@
open Asttypes
open Types

type constant =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_unboxed_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
ncik-roberts marked this conversation as resolved.
Show resolved Hide resolved

module Uid = Shape.Uid

(* Value expressions for the core language *)
Expand Down
10 changes: 10 additions & 0 deletions ocaml/typing/typedtree.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,6 +23,16 @@

open Asttypes

type constant =
Const_int of int
| Const_char of char
| Const_string of string * Location.t * string option
| Const_float of string
| Const_unboxed_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_nativeint of nativeint
alanechang marked this conversation as resolved.
Show resolved Hide resolved

module Uid = Shape.Uid

(* Value expressions for the core language *)
Expand Down
35 changes: 25 additions & 10 deletions ocaml/typing/untypeast.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -130,14 +130,29 @@ let rec extract_letop_patterns n pat =

(** Mapping functions. *)

let constant = function
| Const_char c -> Pconst_char c
| Const_string (s,loc,d) -> Pconst_string (s,loc,d)
| Const_int i -> Pconst_integer (Int.to_string i, None)
| Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l')
| Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L')
| Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n')
| Const_float f -> Pconst_float (f,None)
let constant_to_pat ~loc add_jane_syntax_attributes = function
| Const_char c -> Ppat_constant (Pconst_char c)
| Const_string (s,loc,d) -> Ppat_constant (Pconst_string (s,loc,d))
| Const_int i -> Ppat_constant (Pconst_integer (Int.to_string i, None))
| Const_int32 i -> Ppat_constant (Pconst_integer (Int32.to_string i, Some 'l'))
| Const_int64 i -> Ppat_constant (Pconst_integer (Int64.to_string i, Some 'L'))
| Const_nativeint i -> Ppat_constant (Pconst_integer (Nativeint.to_string i, Some 'n'))
| Const_float f -> Ppat_constant (Pconst_float (f,None))
| Const_unboxed_float f ->
Jane_syntax.Layouts.pat_of ~loc (Lpat_constant (Float (f, None)))
|> add_jane_syntax_attributes

let constant_to_exp ~loc add_jane_syntax_attributes = function
| Const_char c -> Pexp_constant (Pconst_char c)
| Const_string (s,loc,d) -> Pexp_constant (Pconst_string (s,loc,d))
| Const_int i -> Pexp_constant (Pconst_integer (Int.to_string i, None))
| Const_int32 i -> Pexp_constant (Pconst_integer (Int32.to_string i, Some 'l'))
| Const_int64 i -> Pexp_constant (Pconst_integer (Int64.to_string i, Some 'L'))
| Const_nativeint i -> Pexp_constant (Pconst_integer (Nativeint.to_string i, Some 'n'))
| Const_float f -> Pexp_constant (Pconst_float (f,None))
| Const_unboxed_float f ->
Jane_syntax.Layouts.expr_of ~loc (Lexp_constant (Float (f, None)))
|> add_jane_syntax_attributes
ncik-roberts marked this conversation as resolved.
Show resolved Hide resolved

let attribute sub a = {
attr_name = map_loc sub a.attr_name;
Expand Down Expand Up @@ -358,7 +373,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->

| Tpat_alias (pat, _id, name, _uid, _mode) ->
Ppat_alias (sub.pat sub pat, name)
| Tpat_constant cst -> Ppat_constant (constant cst)
| Tpat_constant cst -> constant_to_pat ~loc add_jane_syntax_attributes cst
| Tpat_tuple list ->
Ppat_tuple (List.map (sub.pat sub) list)
| Tpat_construct (lid, _, args, vto) ->
Expand Down Expand Up @@ -494,7 +509,7 @@ let expression sub exp =
let desc =
match exp.exp_desc with
Texp_ident (_path, lid, _, _, _) -> Pexp_ident (map_loc sub lid)
| Texp_constant cst -> Pexp_constant (constant cst)
| Texp_constant cst -> constant_to_exp ~loc add_jane_syntax_attributes cst
| Texp_let (rec_flag, list, exp) ->
Pexp_let (rec_flag,
List.map (sub.value_binding sub) list,
Expand Down
Loading
Loading