flambda-backend: Basic uniqueness extension (#1552)

Author: riaqn

.depend

@@ -7,6 +7,7 @@ type token =
   | WHEN
   | VIRTUAL
   | VAL
+  | UNIQUE
   | UNDERSCORE
   | UIDENT of (string)
   | TYPE
@@ -38,6 +39,7 @@ type token =
   | OR
   | OPTLABEL of (string)
   | OPEN
+  | ONCE
   | OF
   | OBJECT
   | NONREC

boot/menhir/parser.ml

@@ -84,6 +84,7 @@ TYPING = \
   typing/layouts.cmo \
   typing/primitive.cmo \
   typing/shape.cmo \
+  typing/mode.cmo \
   typing/types.cmo \
   typing/btype.cmo \
   typing/oprint.cmo \
@@ -122,6 +123,7 @@ TYPING = \
   lambda/debuginfo.cmo lambda/lambda.cmo \
   typing/typedecl.cmo \
   typing/typeopt.cmo \
+  typing/uniqueness_analysis.cmo \
   typing/rec_check.cmo \
   typing/typecore.cmo \
   typing/typeclass.cmo \

boot/menhir/parser.mli

@@ -69,12 +69,12 @@
 
    ;; TYPING
    ident path layouts primitive shape types btype oprint subst predef datarepr
-   cmi_format persistent_env env errortrace
+   cmi_format persistent_env env errortrace mode
    typedtree printtyped ctype printtyp includeclass mtype envaux includecore
    tast_iterator tast_mapper signature_group cmt_format cms_format untypeast
    includemod includemod_errorprinter
    typetexp patterns printpat parmatch stypes typedecl typeopt rec_check
-   typecore
+   typecore mode uniqueness_analysis
    typeclass typemod typedecl_variance typedecl_properties
    typedecl_separability cmt2annot
    ; manual update: mli only files
@@ -299,6 +299,8 @@
     (typeopt.mli as compiler-libs/typeopt.mli)
     (rec_check.mli as compiler-libs/rec_check.mli)
     (typecore.mli as compiler-libs/typecore.mli)
+    (mode.mli as compiler-libs/mode.mli)
+    (uniqueness_analysis.mli as compiler-libs/uniqueness_analysis.mli)
     (typeclass.mli as compiler-libs/typeclass.mli)
     (typemod.mli as compiler-libs/typemod.mli)
     (typedecl_variance.mli as compiler-libs/typedecl_variance.mli)

boot/ocamlc

@@ -42,10 +42,12 @@ type field_read_semantics =
 
 include (struct
 
-  type alloc_mode =
+  type locality_mode =
     | Alloc_heap
     | Alloc_local
 
+  type alloc_mode = locality_mode
+
   type modify_mode =
     | Modify_heap
     | Modify_maybe_stack
@@ -64,31 +66,24 @@ include (struct
   let modify_heap = Modify_heap
 
   let modify_maybe_stack : modify_mode =
-    (* CR zqian: possible to move this check to a better place? *)
-    (* idealy I don't want to do the checking here.
-       if stack allocations are disabled, then the alloc_mode which this modify_mode
-        depends on should be heap, which makes this modify_mode to be heap *)
-
-    (* one suggestion: move the check to optimize_allocation;
-      if stack_allocation not enabled, force all allocations to be heap,
-        which then propagates to all the other modes.
-       *)
     if Config.stack_allocation then Modify_maybe_stack
     else Modify_heap
 
 end : sig
 
-  type alloc_mode = private
+  type locality_mode = private
     | Alloc_heap
     | Alloc_local
 
+  type alloc_mode = locality_mode
+
   type modify_mode = private
     | Modify_heap
     | Modify_maybe_stack
 
-  val alloc_heap : alloc_mode
+  val alloc_heap : locality_mode
 
-  val alloc_local : alloc_mode
+  val alloc_local : locality_mode
 
   val modify_heap : modify_mode
 

boot/ocamllex

@@ -34,18 +34,22 @@ type immediate_or_pointer =
   | Immediate
   | Pointer
 
-type alloc_mode = private
+type locality_mode = private
   | Alloc_heap
   | Alloc_local
 
+(** For now we don't have strong update, and thus uniqueness is irrelavent in 
+    middle and back-end; in the future this will be extended with uniqueness *)
+type alloc_mode = locality_mode
+
 type modify_mode = private
   | Modify_heap
   | Modify_maybe_stack
 
-val alloc_heap : alloc_mode
+val alloc_heap : locality_mode
 
 (* Actually [Alloc_heap] if [Config.stack_allocation] is [false] *)
-val alloc_local : alloc_mode
+val alloc_local : locality_mode
 
 val modify_heap : modify_mode
 

compilerlibs/Makefile.compilerlibs

@@ -242,7 +242,7 @@ let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases
     when use_lhs || trivial_pat pat && exp.exp_desc <> Texp_unreachable ->
       [{case with c_rhs = wrap_bindings bindings exp}]
   | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] ->
-      let mode = Value_mode.of_alloc arg_mode in
+      let mode = Mode.Value.of_alloc arg_mode in
       let param = Typecore.name_cases "param" cases in
       let desc =
         {val_type = pat.pat_type; val_kind = Val_reg;
@@ -261,7 +261,8 @@ let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases
             ({exp with exp_type = pat.pat_type; exp_env = env; exp_desc =
               Texp_ident
                 (Path.Pident param, mknoloc (Longident.Lident name),
-                 desc, Id_value)},
+                 desc, Id_value,
+                 (Mode.Value.uniqueness mode, Mode.Value.linearity mode))},
              arg_sort,
              cases, partial) }
       in
@@ -346,7 +347,7 @@ let can_apply_primitive p pmode pos args =
     else if pos <> Typedtree.Tail then true
     else begin
       let return_mode = Ctype.prim_mode pmode p.prim_native_repr_res in
-      is_heap_mode (transl_alloc_mode return_mode)
+      is_heap_mode (transl_locality_mode return_mode)
     end
   end
 
@@ -370,7 +371,7 @@ and transl_exp1 ~scopes ~in_new_scope sort e =
 
 and transl_exp0 ~in_new_scope ~scopes sort e =
   match e.exp_desc with
-  | Texp_ident(path, _, desc, kind) ->
+  | Texp_ident(path, _, desc, kind, _) ->
       transl_ident (of_location ~scopes e.exp_loc)
         e.exp_env e.exp_type path desc kind
   | Texp_constant cst ->
@@ -388,8 +389,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
       transl_function ~scopes e alloc_mode param arg_mode arg_sort ret_sort
         cases partial warnings region curry
   | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p},
-                                       Id_prim pmode);
-                exp_type = prim_type; } as funct, oargs, pos, alloc_mode)
+                                       Id_prim pmode, _);
+                exp_type = prim_type; } as funct, oargs, pos, ap_mode)
     when can_apply_primitive p pmode pos oargs ->
       let rec cut_args prim_repr oargs =
         match prim_repr, oargs with
@@ -419,19 +420,19 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
         let inlined = Translattribute.get_inlined_attribute funct in
         let specialised = Translattribute.get_specialised_attribute funct in
         let position = transl_apply_position pos in
-        let mode = transl_alloc_mode alloc_mode in
+        let mode = transl_locality_mode ap_mode in
         let result_layout = layout_exp sort e in
         event_after ~scopes e
           (transl_apply ~scopes ~tailcall ~inlined ~specialised ~position ~mode
              ~result_layout lam extra_args (of_location ~scopes e.exp_loc))
       end
-  | Texp_apply(funct, oargs, position, alloc_mode) ->
+  | Texp_apply(funct, oargs, position, ap_mode) ->
       let tailcall = Translattribute.get_tailcall_attribute funct in
       let inlined = Translattribute.get_inlined_attribute funct in
       let specialised = Translattribute.get_specialised_attribute funct in
       let result_layout = layout_exp sort e in
       let position = transl_apply_position position in
-      let mode = transl_alloc_mode alloc_mode in
+      let mode = transl_locality_mode ap_mode in
       event_after ~scopes e
         (transl_apply ~scopes ~tailcall ~inlined ~specialised ~result_layout
            ~position ~mode (transl_exp ~scopes Sort.for_function funct)
@@ -519,7 +520,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
       transl_record ~scopes e.exp_loc e.exp_env
         (Option.map transl_alloc_mode alloc_mode)
         fields representation extended_expression
-  | Texp_field(arg, _, lbl, alloc_mode) ->
+  | Texp_field(arg, _, lbl, _, alloc_mode) ->
       let targ = transl_exp ~scopes Sort.for_record arg in
       let sem =
         match lbl.lbl_mut with
@@ -1446,7 +1447,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
       Array.mapi
         (fun i (lbl, definition) ->
            match definition with
-           | Kept typ ->
+           | Kept (typ, _) ->
                let field_kind =
                  must_be_value (layout env lbl.lbl_loc Sort.for_record_field typ)
                in
@@ -1531,7 +1532,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
          the init record, we must have already checked for void. *)
       layout_must_be_value lbl.lbl_loc lbl.lbl_layout;
       match definition with
-      | Kept _type -> cont
+      | Kept (_type, _uu) -> cont
       | Overridden (_lid, expr) ->
           let upd =
             match repres with
@@ -1740,12 +1741,12 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort
           | Some (lhs, _) -> Typeopt.function_arg_layout env loc param_sort lhs
     in
     let return_layout = layout_exp case_sort case.c_rhs in
-    let curry = More_args { partial_mode = Alloc_mode.global } in
+    let curry = More_args { partial_mode = Mode.Alloc.legacy } in
     let (kind, params, return, _region), body =
       event_function ~scopes case.c_rhs
         (function repr ->
            transl_curried_function ~scopes ~arg_sort:param_sort ~arg_layout
-             ~arg_mode:(Amode Global) ~return_sort:case_sort
+             ~arg_mode:Mode.Alloc.legacy ~return_sort:case_sort
              ~return_layout case.c_rhs.exp_loc repr ~region:true ~curry partial
              warnings param [case])
     in

dune

@@ -1,11 +1,16 @@
-open Types
 open Lambda
-let transl_alloc_mode alloc_mode =
-  match Alloc_mode.constrain_lower alloc_mode with
+open Mode
+
+let transl_locality_mode locality =
+  match Locality.constrain_lower locality with
   | Global -> alloc_heap
   | Local -> alloc_local
 
-let transl_modify_mode alloc_mode =
-  match Alloc_mode.constrain_lower alloc_mode with
+let transl_alloc_mode mode =
+(* we only take the locality axis *)
+  transl_locality_mode (Alloc.locality mode)
+
+let transl_modify_mode locality =
+  match Locality.constrain_lower locality with
   | Global -> modify_heap
   | Local -> modify_maybe_stack

lambda/lambda.ml

@@ -1,3 +1,7 @@
-val transl_alloc_mode : Types.alloc_mode -> Lambda.alloc_mode
+open Mode
 
-val transl_modify_mode : Types.alloc_mode -> Lambda.modify_mode
+val transl_locality_mode : Locality.t -> Lambda.locality_mode
+
+val transl_alloc_mode : Alloc.t -> Lambda.alloc_mode
+
+val transl_modify_mode : Locality.t -> Lambda.modify_mode

lambda/lambda.mli

@@ -124,13 +124,13 @@ let gen_array_set_kind mode =
 let prim_sys_argv =
   Primitive.simple_on_values ~name:"caml_sys_argv" ~arity:1 ~alloc:true
 
-let to_alloc_mode ~poly = function
+let to_locality ~poly = function
   | Prim_global, _ -> alloc_heap
   | Prim_local, _ -> alloc_local
   | Prim_poly, _ ->
     match poly with
     | None -> assert false
-    | Some mode -> transl_alloc_mode mode
+    | Some locality -> transl_locality_mode locality
 
 let to_modify_mode ~poly = function
   | Prim_global, _ -> modify_heap
@@ -141,7 +141,7 @@ let to_modify_mode ~poly = function
     | Some mode -> transl_modify_mode mode
 
 let lookup_primitive loc poly pos p =
-  let mode = to_alloc_mode ~poly p.prim_native_repr_res in
+  let mode = to_locality ~poly p.prim_native_repr_res in
   let arg_modes = List.map (to_modify_mode ~poly) p.prim_native_repr_args in
   let get_first_arg_mode () =
     match arg_modes with
@@ -855,8 +855,8 @@ let lambda_of_prim prim_name prim loc args arg_exps =
 let check_primitive_arity loc p =
   let mode =
     match p.prim_native_repr_res with
-    | Prim_global, _ | Prim_poly, _ -> Some Alloc_mode.global
-    | Prim_local, _ -> Some Alloc_mode.local
+    | Prim_global, _ | Prim_poly, _ -> Some Mode.Locality.global
+    | Prim_local, _ -> Some Mode.Locality.local
   in
   let prim = lookup_primitive loc mode Rc_normal p in
   let ok =
@@ -890,7 +890,7 @@ let transl_primitive loc p env ty ~poly_mode path =
     | None -> prim
     | Some prim -> prim
   in
-  let to_alloc_mode = to_alloc_mode ~poly:poly_mode in
+  let to_locality = to_locality ~poly:poly_mode in
   let rec make_params ty repr_args repr_res =
     match repr_args, repr_res with
     | [], (_, res_repr) ->
@@ -906,7 +906,7 @@ let transl_primitive loc p env ty ~poly_mode path =
           let arg_layout =
             Typeopt.layout env (to_location loc) (Sort.of_const arg_sort) arg_ty
           in
-          let arg_mode = to_alloc_mode arg in
+          let arg_mode = to_locality arg in
           let params, return = make_params ret_ty repr_args repr_res in
           { name = Ident.create_local "prim";
             layout = arg_layout;
@@ -928,7 +928,7 @@ let transl_primitive loc p env ty ~poly_mode path =
      in
      let body = lambda_of_prim p.prim_name prim loc args None in
      let region =
-       match to_alloc_mode p.prim_native_repr_res with
+       match to_locality p.prim_native_repr_res with
        | Alloc_heap -> true
        | Alloc_local -> false
      in
@@ -938,7 +938,7 @@ let transl_primitive loc p env ty ~poly_mode path =
        | Alloc_heap :: args -> count_nlocal args
        | (Alloc_local :: _) as args -> List.length args
      in
-     let nlocal = count_nlocal (List.map to_alloc_mode p.prim_native_repr_args) in
+     let nlocal = count_nlocal (List.map to_locality p.prim_native_repr_args) in
      lfunction
        ~kind:(Curried {nlocal})
        ~params

lambda/translcore.ml

@@ -35,13 +35,13 @@ val check_primitive_arity :
 val transl_primitive :
   Lambda.scoped_location -> Primitive.description -> Env.t ->
   Types.type_expr ->
-  poly_mode:Types.alloc_mode option ->
+  poly_mode:Mode.Locality.t option ->
   Path.t option ->
   Lambda.lambda
 
 val transl_primitive_application :
   Lambda.scoped_location -> Primitive.description -> Env.t ->
-  Types.type_expr -> Types.alloc_mode option -> Path.t ->
+  Types.type_expr -> Mode.Locality.t option -> Path.t ->
   Typedtree.expression option ->
   Lambda.lambda list -> Typedtree.expression list ->
   Lambda.region_close -> Lambda.lambda

lambda/translmode.ml

@@ -108,6 +108,7 @@ COMPILERLIBS_SOURCES=\
   parsing/ast_mapper.ml \
   parsing/attr_helper.ml \
   parsing/pprintast.ml \
+  typing/mode.ml \
   typing/path.ml \
   typing/shape.ml \
   typing/layouts.ml \