Move local allocations support behind '-extension local'

Author: stedolan

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

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 =

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
 *)
 

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
 *)
 

testsuite/tests/typing-local/alloc.ml

@@ -1,4 +1,5 @@
-(* TEST *)
+(* TEST
+   flags += "-extension local" *)
 
 type t = int
 

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

testsuite/tests/typing-local/comballoc.ml

@@ -1,4 +1,5 @@
-(* TEST *)
+(* TEST
+   flags += "-extension local" *)
 let glob = ref []
 
 let[@inline never] f g n =

testsuite/tests/typing-local/curry.ml

@@ -1,4 +1,5 @@
 (* TEST
+   flags += "-extension local"
    * bytecode
      reference = "${test_source_directory}/curry.byte.reference"
    * native

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"

testsuite/tests/typing-local/lifetime.ml

@@ -1,4 +1,5 @@
-(* TEST *)
+(* TEST
+   flags += "-extension local" *)
 
 let final = ref false
 let rtrue = ref true

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

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;

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

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;

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"

testsuite/tests/typing-local/tailcalls.ml

@@ -1,4 +1,5 @@
 (* TEST
+   flags += "-extension local"
    * native *)
 
 open Printexc

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 *)

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 =

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