Move local allocations support behind '-extension local'

stedolan · stedolan · commit 1412792ed77b · 2022-02-01T17:59:54.000Z
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
@@ -101,6 +101,15 @@ let keyword_table =
     "asr", INFIXOP4("asr")
 ]
 
+let lookup_keyword name =
+  match Hashtbl.find keyword_table name with
+  | LOCAL | NONLOCAL | GLOBAL
+       when not (Clflags.Extension.is_enabled Local) ->
+     LIDENT name
+  | kw -> kw
+  | exception Not_found ->
+     LIDENT name
+
 (* To buffer string literals *)
 
 let string_buffer = Buffer.create 256
@@ -403,8 +412,7 @@ rule token = parse
       { warn_latin1 lexbuf;
         OPTLABEL name }
   | lowercase identchar * as name
-      { try Hashtbl.find keyword_table name
-        with Not_found -> LIDENT name }
+      { lookup_keyword name }
   | lowercase_latin1 identchar_latin1 * as name
       { warn_latin1 lexbuf; LIDENT name }
   | uppercase identchar * as name
diff --git a/testsuite/tests/translprim/array_spec.ml b/testsuite/tests/translprim/array_spec.ml
@@ -1,7 +1,7 @@
 (* TEST
    * setup-ocamlc.byte-build-env
    ** ocamlc.byte
-      flags = "-dlambda -dno-unique-ids"
+      flags = "-dlambda -dno-unique-ids -extension local"
    *** flat-float-array
    **** check-ocamlc.byte-output
         compiler_reference =
diff --git a/testsuite/tests/translprim/comparison_table.ml b/testsuite/tests/translprim/comparison_table.ml
@@ -1,7 +1,7 @@
 (* TEST
    * setup-ocamlc.byte-build-env
    ** ocamlc.byte
-      flags = "-dlambda -dno-unique-ids"
+      flags = "-dlambda -dno-unique-ids -extension local"
    *** check-ocamlc.byte-output
 *)
 
diff --git a/testsuite/tests/translprim/ref_spec.ml b/testsuite/tests/translprim/ref_spec.ml
@@ -1,7 +1,7 @@
 (* TEST
    * setup-ocamlc.byte-build-env
    ** ocamlc.byte
-      flags = "-dlambda -dno-unique-ids"
+      flags = "-dlambda -dno-unique-ids -extension local"
    *** check-ocamlc.byte-output
 *)
 
diff --git a/testsuite/tests/typing-local/alloc.ml b/testsuite/tests/typing-local/alloc.ml
@@ -1,4 +1,5 @@
-(* TEST *)
+(* TEST
+   flags += "-extension local" *)
 
 type t = int
 
diff --git a/testsuite/tests/typing-local/aritybug.ml b/testsuite/tests/typing-local/aritybug.ml
@@ -1,4 +1,5 @@
-(* TEST *)
+(* TEST
+   flags += "-extension local" *)
 
 let[@inline never] wat x =
   let f ~a:_ ~b:_ ~c:_ () () = x in
diff --git a/testsuite/tests/typing-local/comballoc.ml b/testsuite/tests/typing-local/comballoc.ml
@@ -1,4 +1,5 @@
-(* TEST *)
+(* TEST
+   flags += "-extension local" *)
 let glob = ref []
 
 let[@inline never] f g n =
diff --git a/testsuite/tests/typing-local/curry.ml b/testsuite/tests/typing-local/curry.ml
@@ -1,4 +1,5 @@
 (* TEST
+   flags += "-extension local"
    * bytecode
      reference = "${test_source_directory}/curry.byte.reference"
    * native
diff --git a/testsuite/tests/typing-local/exceptions.ml b/testsuite/tests/typing-local/exceptions.ml
@@ -1,4 +1,5 @@
 (* TEST
+   flags += "-extension local"
    * native *)
 
 external local_stack_offset : unit -> int = "caml_local_stack_offset"
diff --git a/testsuite/tests/typing-local/lifetime.ml b/testsuite/tests/typing-local/lifetime.ml
@@ -1,4 +1,5 @@
-(* TEST *)
+(* TEST
+   flags += "-extension local" *)
 
 let final = ref false
 let rtrue = ref true
diff --git a/testsuite/tests/typing-local/local.ml b/testsuite/tests/typing-local/local.ml
@@ -1,6 +1,6 @@
 (* TEST
-   * expect
-*)
+   flags += "-extension local"
+   * expect *)
 
 let leak n =
   let r = local_ ref n in
diff --git a/testsuite/tests/typing-local/mutate.ml b/testsuite/tests/typing-local/mutate.ml
@@ -1,4 +1,5 @@
-(* TEST *)
+(* TEST
+   flags += "-extension local" *)
 let[@inline never] f (g : local_ _ -> unit) n =
   let r = local_ { contents = ref 0 } in
   g r;
diff --git a/testsuite/tests/typing-local/partial.ml b/testsuite/tests/typing-local/partial.ml
@@ -1,5 +1,5 @@
 (* TEST
-   flags += " -g " *)
+   flags += " -g -extension local" *)
 
 let f1 ~a ~b ~c ~d ~e = a + b + c + d + e
 let f2 ~b ~c ~e = f1 ~b ~c ~e
diff --git a/testsuite/tests/typing-local/print_syntax.ml b/testsuite/tests/typing-local/print_syntax.ml
@@ -6,6 +6,7 @@
 
 let () =
   let fname = "example_syntax.ml" in
+  Clflags.Extension.enable "local";
   let ic = open_in fname in
   let lexbuf = Lexing.from_channel ic in
   Location.init lexbuf fname;
diff --git a/testsuite/tests/typing-local/regions.ml b/testsuite/tests/typing-local/regions.ml
@@ -1,4 +1,5 @@
 (* TEST
+   flags += "-extension local"
    * native *)
 
 external local_stack_offset : unit -> int = "caml_local_stack_offset"
diff --git a/testsuite/tests/typing-local/tailcalls.ml b/testsuite/tests/typing-local/tailcalls.ml
@@ -1,4 +1,5 @@
 (* TEST
+   flags += "-extension local"
    * native *)
 
 open Printexc
diff --git a/typing/typecore.ml b/typing/typecore.ml
@@ -367,9 +367,11 @@ let register_allocation (expected_mode : expected_mode) =
     (Value_mode.regional_to_global_alloc expected_mode.mode)
 
 let optimise_allocations () =
-  List.iter
-    (fun mode -> ignore (Alloc_mode.constrain_upper mode))
-    !allocations;
+  if Clflags.Extension.is_enabled Local then begin
+    List.iter
+      (fun mode -> ignore (Alloc_mode.constrain_upper mode))
+      !allocations
+  end;
   reset_allocations ()
 
 (* Typing of constants *)
diff --git a/utils/clflags.ml b/utils/clflags.ml
@@ -376,21 +376,23 @@ let set_dumped_pass s enabled =
   end
 
 module Extension = struct
-  type t = Comprehensions
+  type t = Comprehensions | Local
 
-  let all = [ Comprehensions ]
+  let all = [ Comprehensions; Local ]
 
   let extensions = ref ([] : t list)   (* -extension *)
-  let equal Comprehensions Comprehensions = true
+  let equal (a : t) (b : t) = (a = b)
 
   let disable_all_extensions = ref false             (* -disable-all-extensions *)
   let disable_all () = disable_all_extensions := true
 
   let to_string = function
     | Comprehensions -> "comprehensions"
+    | Local -> "local"
 
   let of_string = function
     | "comprehensions" -> Comprehensions
+    | "local" -> Local
     | extn -> raise (Arg.Bad(Printf.sprintf "Extension %s is not known" extn))
 
   let enable extn =
diff --git a/utils/clflags.mli b/utils/clflags.mli
@@ -202,7 +202,7 @@ val set_dumped_pass : string -> bool -> unit
 val dump_into_file : bool ref
 
 module Extension : sig
-  type t = Comprehensions
+  type t = Comprehensions | Local
   val enable : string -> unit
   val is_enabled : t -> bool
   val to_string : t -> string

Original file line number	Diff line number	Diff line change
`@@ -1,4 +1,5 @@`
`1`	`1`	`(* TEST`
	`2`	`+ flags += "-extension local"`
`2`	`3`	`* bytecode`
`3`	`4`	`reference = "${test_source_directory}/curry.byte.reference"`
`4`	`5`	`* native`