Skip to content

Commit

Permalink
bow to check-typo
Browse files Browse the repository at this point in the history
  • Loading branch information
@gasche
gasche committed Nov 2, 2021
1 parent 49cde62 commit 8a790b0
Show file tree
Hide file tree
Showing 4 changed files with 69 additions and 54 deletions.
3 changes: 2 additions & 1 deletion lambda/lambda.mli
View file
Expand Up @@ -425,7 +425,8 @@ val default_function_attribute : function_attribute
val default_stub_attribute : function_attribute

val function_is_curried : lfunction -> bool
val find_exact_application : function_kind -> arity:int -> lambda list -> lambda list option
val find_exact_application :
function_kind -> arity:int -> lambda list -> lambda list option

val max_arity : unit -> int
(** Maximal number of parameters for a function, or in other words,
Expand Down
68 changes: 40 additions & 28 deletions lambda/tmc.ml
View file
Expand Up @@ -71,10 +71,10 @@ let assign_to_dst {var; offset; loc} lam =
[Lvar var; offset_code offset; lam], loc)

module Constr : sig
(** The type [Constr.t] represents a reified constructor with a single hole, which can
be either directly applied to a [lambda] term, or be used to create
a fresh [lambda destination] with a placeholder.
*)
(** The type [Constr.t] represents a reified constructor with
a single hole, which can be either directly applied to a [lambda]
term, or be used to create a fresh [lambda destination] with
a placeholder. *)
type t = {
tag : int;
flag: Asttypes.mutable_flag;
Expand All @@ -84,7 +84,8 @@ module Constr : sig
loc : Debuginfo.Scoped_location.t;
}

(** [apply constr e] plugs the expression [e] in the hole of the constructor [const]. *)
(** [apply constr e] plugs the expression [e] in the hole of the
constructor [const]. *)
val apply : t -> lambda -> lambda

(** [with_placeholder constr body] binds a placeholder
Expand Down Expand Up @@ -118,15 +119,17 @@ end = struct

let apply constr t =
let block_args = List.append constr.before @@ t :: constr.after in
Lprim (Pmakeblock (constr.tag, constr.flag, constr.shape), block_args, constr.loc)
Lprim (Pmakeblock (constr.tag, constr.flag, constr.shape),
block_args, constr.loc)

let tmc_placeholder =
(* we choose a placeholder whose tagged representation will be
reconizable. *)
Lconst (Const_base (Const_int (0xBBBB / 2)))

let with_placeholder constr (body : offset destination -> lambda) =
let k_with_placeholder = apply { constr with flag = Mutable } tmc_placeholder in
let k_with_placeholder =
apply { constr with flag = Mutable } tmc_placeholder in
let placeholder_pos = List.length constr.before in
let placeholder_pos_lam = Lconst (Const_base (Const_int placeholder_pos)) in
let block_var = Ident.create_local "block" in
Expand Down Expand Up @@ -480,10 +483,10 @@ module Choice = struct
and+ vs = list cs
in v :: vs

(** The [find_*] machinery is used to locate a single subterm
to optimize among a list of subterms. If there are several possible choices,
we require that exactly one of them be annotated with [@tailcall], or
we report an ambiguity. *)
(** The [find_*] machinery is used to locate a single subterm to
optimize among a list of subterms. If there are several possible
choices, we require that exactly one of them be annotated with
[@tailcall], or we report an ambiguity. *)
type 'a tmc_call_search =
| No_tmc_call of 'a list
| Nonambiguous of 'a zipper
Expand Down Expand Up @@ -575,8 +578,9 @@ let rec choice ctx t =
let t = traverse ctx t in
Choice.lambda t

(* [choice_prim] handles most primitives, but the important case of construction
[Lprim(Pmakeblock(...), ...)] is handled by [choice_makeblock] *)
(* [choice_prim] handles most primitives, but the important case
of construction [Lprim(Pmakeblock(...), ...)] is handled by
[choice_makeblock] *)
| Lprim (prim, primargs, loc) ->
choice_prim ctx ~tail prim primargs loc

Expand Down Expand Up @@ -690,8 +694,9 @@ let rec choice ctx t =
| Some args -> args
in
let tailcall tail =
(* If we are calling a tmc-specializable function in tail context,
then both the direct-style and dps-style calls must be tailcalls. *)
(* If we are calling a tmc-specializable function in tail
context, then both the direct-style and dps-style calls
must be tailcalls. *)
if tail
then Tailcall_expectation true
else Default_tailcall
Expand Down Expand Up @@ -870,7 +875,8 @@ let rec choice ctx t =
(* we don't handle { foo with x = ...; y = recursive-call } *)
| Pduprecord _

(* operations returning boxed values could be considered constructions someday *)
(* operations returning boxed values could be considered
constructions someday *)
| Pbintofint _ | Pintofbint _
| Pcvtbint _
| Pnegbint _
Expand All @@ -885,7 +891,8 @@ let rec choice ctx t =
| Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_64 _
| Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _
| Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _
| Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ | Pctconst _
| Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _
| Pctconst _
| Pbswap16
| Pbbswap _
| Pint_as_pointer
Expand Down Expand Up @@ -962,14 +969,17 @@ let rewrite t =
let () =
Location.register_error_of_exn
(function
| Error (loc, Ambiguous_constructor_arguments { explicit = false; arguments }) ->
| Error (loc,
Ambiguous_constructor_arguments
{ explicit = false; arguments }) ->
let print_msg ppf =
Format.pp_print_text ppf
"[@tail_mod_cons]: this constructor application may be \
TMC-transformed in several different ways. Please disambiguate \
by adding an explicit [@tailcall] attribute to the call that \
should be made tail-recursive, or a [@tailcall false] attribute \
on calls that should not be transformed."
TMC-transformed in several different ways. Please \
disambiguate by adding an explicit [@tailcall] \
attribute to the call that should be made \
tail-recursive, or a [@tailcall false] attribute on \
calls that should not be transformed."
in
let submgs =
let sub (info : tmc_call_information) =
Expand All @@ -981,15 +991,17 @@ let () =
|> List.map sub
in
Some (Location.errorf ~loc ~sub:submgs "%t" print_msg)
| Error (loc, Ambiguous_constructor_arguments { explicit = true; arguments }) ->
| Error (loc,
Ambiguous_constructor_arguments
{ explicit = true; arguments }) ->
let print_msg ppf =
Format.pp_print_text ppf
"[@tail_mod_cons]: this constructor application may be \
TMC-transformed in several different ways. Only one of the arguments \
may become a TMC call, but several arguments contain calls \
that are explicitly marked as tail-recursive. \
Please fix the conflict by reviewing and fixing the conflicting \
annotations."
TMC-transformed in several different ways. Only one of \
the arguments may become a TMC call, but several \
arguments contain calls that are explicitly marked as \
tail-recursive. Please fix the conflict by reviewing \
and fixing the conflicting annotations."
in
let submgs =
let sub (info : tmc_call_information) =
Expand Down
40 changes: 20 additions & 20 deletions testsuite/tests/tmc/usage_warnings.ml
View file
Expand Up @@ -20,10 +20,10 @@ Line 3, characters 17-40:
^^^^^^^^^^^^^^^^^^^^^^^
Warning 72 [tmc-breaks-tailcall]: This call is in tail-modulo-cons position in a TMC function,
but the function called is not itself specialized for TMC,
so the call will not be in tail position in the transformed version.
Please either mark the called function with the [@tail_mod_cons] attribute,
or mark this call with the [@tailcall false] attribute to make its
non-tailness explicit.
so the call will not be transformed into a tail call.
Please either mark the called function with
the [@tail_mod_cons] attribute, or mark this call with
the [@tailcall false] attribute to make its non-tailness explicit.
Lines 1-3, characters 34-40:
1 | ..................................function
2 | | [] -> []
Expand Down Expand Up @@ -62,10 +62,10 @@ Line 10, characters 9-30:
^^^^^^^^^^^^^^^^^^^^^
Warning 72 [tmc-breaks-tailcall]: This call is in tail-modulo-cons position in a TMC function,
but the function called is not itself specialized for TMC,
so the call will not be in tail position in the transformed version.
Please either mark the called function with the [@tail_mod_cons] attribute,
or mark this call with the [@tailcall false] attribute to make its
non-tailness explicit.
so the call will not be transformed into a tail call.
Please either mark the called function with
the [@tail_mod_cons] attribute, or mark this call with
the [@tailcall false] attribute to make its non-tailness explicit.
Lines 1-10, characters 34-30:
1 | ..................................function
2 | | [] -> []
Expand Down Expand Up @@ -104,10 +104,10 @@ Line 13, characters 12-23:
^^^^^^^^^^^
Warning 72 [tmc-breaks-tailcall]: This call is in tail-modulo-cons position in a TMC function,
but the function called is not itself specialized for TMC,
so the call will not be in tail position in the transformed version.
Please either mark the called function with the [@tail_mod_cons] attribute,
or mark this call with the [@tailcall false] attribute to make its
non-tailness explicit.
so the call will not be transformed into a tail call.
Please either mark the called function with
the [@tail_mod_cons] attribute, or mark this call with
the [@tailcall false] attribute to make its non-tailness explicit.
val flatten : 'a list list -> 'a list = <fun>
|}]

Expand Down Expand Up @@ -157,10 +157,10 @@ Lines 20-23, characters 10-27:
23 | (filter_1 f xs)
Warning 72 [tmc-breaks-tailcall]: This call is in tail-modulo-cons position in a TMC function,
but the function called is not itself specialized for TMC,
so the call will not be in tail position in the transformed version.
Please either mark the called function with the [@tail_mod_cons] attribute,
or mark this call with the [@tailcall false] attribute to make its
non-tailness explicit.
so the call will not be transformed into a tail call.
Please either mark the called function with
the [@tail_mod_cons] attribute, or mark this call with
the [@tailcall false] attribute to make its non-tailness explicit.
module Tail_calls_to_non_specialized_functions :
sig
val list_id : 'a list -> 'a list
Expand Down Expand Up @@ -239,10 +239,10 @@ Line 16, characters 13-56:
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 72 [tmc-breaks-tailcall]: This call is in tail-modulo-cons position in a TMC function,
but the function called is not itself specialized for TMC,
so the call will not be in tail position in the transformed version.
Please either mark the called function with the [@tail_mod_cons] attribute,
or mark this call with the [@tailcall false] attribute to make its
non-tailness explicit.
so the call will not be transformed into a tail call.
Please either mark the called function with
the [@tail_mod_cons] attribute, or mark this call with
the [@tailcall false] attribute to make its non-tailness explicit.
Line 17, characters 17-67:
17 | else Tau ((graft[@tailcall]) (* this should also warn *) n)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Expand Down
12 changes: 7 additions & 5 deletions utils/warnings.ml
View file
Expand Up @@ -1028,14 +1028,16 @@ let message = function
| Missing_mli ->
"Cannot find interface file."
| Unused_tmc_attribute ->
"This function is marked @tail_mod_cons but is never applied in TMC position."
"This function is marked @tail_mod_cons but is never applied in \
TMC position."
| Tmc_breaks_tailcall ->
"This call is in tail-modulo-cons position in a TMC function,\n\
but the function called is not itself specialized for TMC,\n\
so the call will not be in tail position in the transformed version.\n\
Please either mark the called function with the [@tail_mod_cons] attribute,\n\
or mark this call with the [@tailcall false] attribute to make its\n\
non-tailness explicit."
so the call will not be transformed into a tail call.\n\
Please either mark the called function with\n\
the [@tail_mod_cons] attribute, or mark this call with\n\
the [@tailcall false] attribute to make its non-tailness \
explicit."
;;

let nerrors = ref 0;;
Expand Down

0 comments on commit 8a790b0

Please sign in to comment.