flambda-backend: Unboxed literal jane syntax (#1487)

* Add rudimentary support for literal expressions

* Add support for patterns

* minimize diff

* Remove lack of comment

* fix ocamlprof

Author: ncik-roberts

boot/menhir/parser.ml

@@ -78,7 +78,10 @@ let iterator =
         | Cexp_array_comprehension (_, {clauses = []; body = _}) )
       ->
         empty_comprehension loc
-    | Jexp_comprehension _ | Jexp_immutable_array _ -> ()
+    | Jexp_comprehension _
+    | Jexp_immutable_array _
+    | Jexp_unboxed_constant _
+      -> ()
   in
   let expr self exp =
     begin match exp.pexp_desc with

parsing/ast_invariants.ml

@@ -399,6 +399,10 @@ module M = struct
     | Pstr_attribute x -> sub.attribute sub x
 end
 
+(* A no-op, but makes it clearer which jane syntax cases should have the same
+   handling as core-language cases. *)
+let iter_constant = ()
+
 module E = struct
   (* Value expressions for the core language *)
 
@@ -438,6 +442,7 @@ module E = struct
   let iter_jst sub : Jane_syntax.Expression.t -> _ = function
     | Jexp_comprehension comp_exp -> iter_comp_exp sub comp_exp
     | Jexp_immutable_array iarr_exp -> iter_iarr_exp sub iarr_exp
+    | Jexp_unboxed_constant _ -> iter_constant
 
   let iter sub
         ({pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} as expr)=
@@ -450,7 +455,7 @@ module E = struct
     sub.attributes sub attrs;
     match desc with
     | Pexp_ident x -> iter_loc sub x
-    | Pexp_constant _ -> ()
+    | Pexp_constant _ -> iter_constant
     | Pexp_let (_r, vbs, e) ->
         List.iter (sub.value_binding sub) vbs;
         sub.expr sub e
@@ -540,6 +545,7 @@ module P = struct
 
   let iter_jst sub : Jane_syntax.Pattern.t -> _ = function
     | Jpat_immutable_array iapat -> iter_iapat sub iapat
+    | Jpat_unboxed_constant _ -> iter_constant
 
   let iter sub
         ({ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} as pat) =
@@ -554,7 +560,7 @@ module P = struct
     | Ppat_any -> ()
     | Ppat_var s -> iter_loc sub s
     | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s
-    | Ppat_constant _ -> ()
+    | Ppat_constant _ -> iter_constant
     | Ppat_interval _ -> ()
     | Ppat_tuple pl -> List.iter (sub.pat sub) pl
     | Ppat_construct (l, p) ->

parsing/ast_iterator.ml

@@ -487,6 +487,7 @@ module E = struct
 
   module C = Jane_syntax.Comprehensions
   module IA = Jane_syntax.Immutable_arrays
+  module UC = Jane_syntax.Unboxed_constants
 
   let map_iterator sub : C.iterator -> C.iterator = function
     | Range { start; stop; direction } ->
@@ -519,10 +520,18 @@ module E = struct
     | Iaexp_immutable_array elts ->
       Iaexp_immutable_array (List.map (sub.expr sub) elts)
 
+  let map_unboxed_constant_exp _sub : UC.expression -> UC.expression = function
+    (* We can't reasonably call [sub.constant] because it might return a kind
+       of constant we don't know how to unbox.
+    *)
+    | Float _ | Integer _ as x -> x
+
   let map_jst sub : Jane_syntax.Expression.t -> Jane_syntax.Expression.t =
     function
-    | Jexp_comprehension cexp -> Jexp_comprehension (map_cexp sub cexp)
-    | Jexp_immutable_array iaexp -> Jexp_immutable_array (map_iaexp sub iaexp)
+    | Jexp_comprehension x -> Jexp_comprehension (map_cexp sub x)
+    | Jexp_immutable_array x -> Jexp_immutable_array (map_iaexp sub x)
+    | Jexp_unboxed_constant x ->
+        Jexp_unboxed_constant (map_unboxed_constant_exp sub x)
 
   let map sub
         ({pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} as exp) =
@@ -531,10 +540,8 @@ module E = struct
     match Jane_syntax.Expression.of_ast exp with
     | Some (jexp, attrs) -> begin
         let attrs = sub.attributes sub attrs in
-        Jane_syntax_parsing.Expression.wrap_desc ~loc ~info:attrs @@
-        match sub.expr_jane_syntax sub jexp with
-        | Jexp_comprehension   c -> Jane_syntax.Comprehensions.expr_of   ~loc c
-        | Jexp_immutable_array i -> Jane_syntax.Immutable_arrays.expr_of ~loc i
+        Jane_syntax_parsing.Expression.wrap_desc ~loc ~info:attrs
+          (Jane_syntax.Expression.expr_of ~loc (sub.expr_jane_syntax sub jexp))
     end
     | None ->
     let attrs = sub.attributes sub attrs in
@@ -627,13 +634,22 @@ module P = struct
   (* Patterns *)
 
   module IA = Jane_syntax.Immutable_arrays
+  module UC = Jane_syntax.Unboxed_constants
 
   let map_iapat sub : IA.pattern -> IA.pattern = function
     | Iapat_immutable_array elts ->
       Iapat_immutable_array (List.map (sub.pat sub) elts)
 
+  let map_unboxed_constant_pat _sub : UC.pattern -> UC.pattern = function
+    (* We can't reasonably call [sub.constant] because it might return a kind
+       of constant we don't know how to unbox.
+    *)
+    | Float _ | Integer _ as x -> x
+
   let map_jst sub : Jane_syntax.Pattern.t -> Jane_syntax.Pattern.t = function
-    | Jpat_immutable_array iapat -> Jpat_immutable_array (map_iapat sub iapat)
+    | Jpat_immutable_array x -> Jpat_immutable_array (map_iapat sub x)
+    | Jpat_unboxed_constant x ->
+        Jpat_unboxed_constant (map_unboxed_constant_pat sub x)
 
   let map sub
         ({ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} as pat) =
@@ -643,8 +659,7 @@ module P = struct
     | Some (jpat, attrs) -> begin
         let attrs = sub.attributes sub attrs in
         Jane_syntax_parsing.Pattern.wrap_desc ~loc ~info:attrs @@
-        match sub.pat_jane_syntax sub jpat with
-        | Jpat_immutable_array i -> Jane_syntax.Immutable_arrays.pat_of ~loc i
+        Jane_syntax.Pattern.pat_of ~loc (sub.pat_jane_syntax sub jpat)
     end
     | None ->
     let attrs = sub.attributes sub attrs in

parsing/ast_mapper.ml

@@ -178,6 +178,10 @@ let add_type_exception bv te =
 
 let pattern_bv = ref String.Map.empty
 
+(* A no-op, but makes it clearer which jane syntax cases should have the same
+   handling as core-language cases. *)
+let add_constant = ()
+
 let rec add_pattern bv pat =
   match Jane_syntax.Pattern.of_ast pat with
   | Some (jpat, _attrs) -> add_pattern_jane_syntax bv jpat
@@ -211,6 +215,7 @@ let rec add_pattern bv pat =
 and add_pattern_jane_syntax bv : Jane_syntax.Pattern.t -> _ = function
   | Jpat_immutable_array (Iapat_immutable_array pl) ->
       List.iter (add_pattern bv) pl
+  | Jpat_unboxed_constant _ -> add_constant
 
 let add_pattern bv pat =
   pattern_bv := bv;
@@ -223,7 +228,7 @@ let rec add_expr bv exp =
   | None ->
   match exp.pexp_desc with
     Pexp_ident l -> add bv l
-  | Pexp_constant _ -> ()
+  | Pexp_constant _ -> add_constant
   | Pexp_let(rf, pel, e) ->
       let bv = add_bindings rf bv pel in add_expr bv e
   | Pexp_fun (_, opte, p, e) ->
@@ -294,8 +299,9 @@ let rec add_expr bv exp =
   | Pexp_unreachable -> ()
 
 and add_expr_jane_syntax bv : Jane_syntax.Expression.t -> _ = function
-  | Jexp_comprehension cexp -> add_comprehension_expr bv cexp
-  | Jexp_immutable_array iaexp -> add_immutable_array_expr bv iaexp
+  | Jexp_comprehension x -> add_comprehension_expr bv x
+  | Jexp_immutable_array x -> add_immutable_array_expr bv x
+  | Jexp_unboxed_constant _ -> add_constant
 
 and add_comprehension_expr bv : Jane_syntax.Comprehensions.expression -> _ =
   function

parsing/depend.ml

@@ -364,6 +364,57 @@ module Strengthen = struct
     | _ -> failwith "Malformed strengthened module type"
 end
 
+module Unboxed_constants = struct
+  type t =
+    | Float of string * char option
+    | Integer of string * char
+
+  type expression = t
+  type pattern = t
+
+  let feature : Feature.t = Language_extension Layouts
+
+  let fail_malformed ~loc =
+    Location.raise_errorf ~loc "Malformed unboxed numeric literal"
+
+  let of_constant ~loc = function
+    | Pconst_float (x, suffix) -> Float (x, suffix)
+    | Pconst_integer (x, Some suffix) -> Integer (x, suffix)
+    | Pconst_integer (_, None) ->
+        Location.raise_errorf ~loc
+          "Malformed unboxed int literal: suffix required"
+    | _ -> fail_malformed ~loc
+
+
+  (* Returns remaining unconsumed attributes *)
+  let of_expr expr =
+    let loc = expr.pexp_loc in
+    match expr.pexp_desc with
+    | Pexp_constant const -> of_constant ~loc const, expr.pexp_attributes
+    | _ -> fail_malformed ~loc
+
+  (* Returns remaining unconsumed attributes *)
+  let of_pat pat =
+    let loc = pat.ppat_loc in
+    match pat.ppat_desc with
+    | Ppat_constant const -> of_constant ~loc const, pat.ppat_attributes
+    | _ -> fail_malformed ~loc
+
+  let constant_of = function
+    | Float (x, suffix) -> Pconst_float (x, suffix)
+    | Integer (x, suffix) -> Pconst_integer (x, Some suffix)
+
+  let expr_of ~loc t =
+    let constant = constant_of t in
+    Expression.make_entire_jane_syntax ~loc feature (fun () ->
+      Ast_helper.Exp.constant constant)
+
+  let pat_of ~loc t =
+    let constant = constant_of t in
+    Pattern.make_entire_jane_syntax ~loc feature (fun () ->
+      Ast_helper.Pat.constant constant)
+end
+
 (******************************************************************************)
 (** The interface to our novel syntax, which we export *)
 
@@ -396,6 +447,7 @@ module Expression = struct
   type t =
     | Jexp_comprehension   of Comprehensions.expression
     | Jexp_immutable_array of Immutable_arrays.expression
+    | Jexp_unboxed_constant of Unboxed_constants.expression
 
   let of_ast_internal (feat : Feature.t) expr = match feat with
     | Language_extension Comprehensions ->
@@ -404,22 +456,38 @@ module Expression = struct
     | Language_extension Immutable_arrays ->
       let expr, attrs = Immutable_arrays.of_expr expr in
       Some (Jexp_immutable_array expr, attrs)
+    | Language_extension Layouts ->
+      let expr, attrs = Unboxed_constants.of_expr expr in
+      Some (Jexp_unboxed_constant expr, attrs)
     | _ -> None
 
   let of_ast = Expression.make_of_ast ~of_ast_internal
+
+  let expr_of ~loc = function
+    | Jexp_comprehension    x -> Comprehensions.expr_of    ~loc x
+    | Jexp_immutable_array  x -> Immutable_arrays.expr_of  ~loc x
+    | Jexp_unboxed_constant x -> Unboxed_constants.expr_of ~loc x
 end
 
 module Pattern = struct
   type t =
     | Jpat_immutable_array of Immutable_arrays.pattern
+    | Jpat_unboxed_constant of Unboxed_constants.pattern
 
   let of_ast_internal (feat : Feature.t) pat = match feat with
     | Language_extension Immutable_arrays ->
       let expr, attrs = Immutable_arrays.of_pat pat in
       Some (Jpat_immutable_array expr, attrs)
+    | Language_extension Layouts ->
+      let pat, attrs = Unboxed_constants.of_pat pat in
+      Some (Jpat_unboxed_constant pat, attrs)
     | _ -> None
 
   let of_ast = Pattern.make_of_ast ~of_ast_internal
+
+  let pat_of ~loc = function
+    | Jpat_immutable_array x -> Immutable_arrays.pat_of ~loc x
+    | Jpat_unboxed_constant x -> Unboxed_constants.pat_of ~loc x
 end
 
 module Module_type = struct

parsing/jane_syntax.ml

@@ -121,6 +121,22 @@ module Strengthen : sig
     -> Parsetree.module_type_desc With_attributes.t
 end
 
+(** The ASTs for unboxed literals, like #4.0 *)
+module Unboxed_constants : sig
+  type t =
+    | Float of string * char option
+    | Integer of string * char
+
+  type expression = t
+  type pattern = t
+
+  val expr_of :
+    loc:Location.t -> expression -> Parsetree.expression_desc With_attributes.t
+
+  val pat_of :
+    loc:Location.t -> pattern -> Parsetree.pattern_desc With_attributes.t
+end
+
 (******************************************)
 (* General facility, which we export *)
 
@@ -219,22 +235,30 @@ end
 (** Novel syntax in expressions *)
 module Expression : sig
   type t =
-    | Jexp_comprehension   of Comprehensions.expression
-    | Jexp_immutable_array of Immutable_arrays.expression
+    | Jexp_comprehension    of Comprehensions.expression
+    | Jexp_immutable_array  of Immutable_arrays.expression
+    | Jexp_unboxed_constant of Unboxed_constants.expression
 
   include AST
     with type t := t * Parsetree.attributes
      and type ast := Parsetree.expression
+
+  val expr_of :
+    loc:Location.t -> t -> Parsetree.expression_desc With_attributes.t
 end
 
 (** Novel syntax in patterns *)
 module Pattern : sig
   type t =
     | Jpat_immutable_array of Immutable_arrays.pattern
+    | Jpat_unboxed_constant of Unboxed_constants.pattern
 
   include AST
     with type t := t * Parsetree.attributes
      and type ast := Parsetree.pattern
+
+  val pat_of :
+    loc:Location.t -> t -> Parsetree.pattern_desc With_attributes.t
 end
 
 (** Novel syntax in module types *)