1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
6(*                                                                        *)
7(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
8(*     en Automatique.                                                    *)
9(*                                                                        *)
10(*   All rights reserved.  This file is distributed under the terms of    *)
11(*   the GNU Lesser General Public License version 2.1, with the          *)
12(*   special exception on linking described in the file LICENSE.          *)
13(*                                                                        *)
14(**************************************************************************)
15
16(* Description of primitive functions *)
17
18open Misc
19open Parsetree
20
21type boxed_integer = Pnativeint | Pint32 | Pint64
22
23type native_repr =
24  | Same_as_ocaml_repr
25  | Unboxed_float
26  | Unboxed_integer of boxed_integer
27  | Untagged_int
28
29type description =
30  { prim_name: string;         (* Name of primitive  or C function *)
31    prim_arity: int;           (* Number of arguments *)
32    prim_alloc: bool;          (* Does it allocates or raise? *)
33    prim_native_name: string;  (* Name of C function for the nat. code gen. *)
34    prim_native_repr_args: native_repr list;
35    prim_native_repr_res: native_repr }
36
37type error =
38  | Old_style_float_with_native_repr_attribute
39  | Old_style_noalloc_with_noalloc_attribute
40  | No_native_primitive_with_repr_attribute
41
42exception Error of Location.t * error
43
44let is_ocaml_repr = function
45  | Same_as_ocaml_repr -> true
46  | Unboxed_float
47  | Unboxed_integer _
48  | Untagged_int -> false
49
50let is_unboxed = function
51  | Same_as_ocaml_repr
52  | Untagged_int -> false
53  | Unboxed_float
54  | Unboxed_integer _ -> true
55
56let is_untagged = function
57  | Untagged_int -> true
58  | Same_as_ocaml_repr
59  | Unboxed_float
60  | Unboxed_integer _ -> false
61
62let rec make_native_repr_args arity x =
63  if arity = 0 then
64    []
65  else
66    x :: make_native_repr_args (arity - 1) x
67
68let simple ~name ~arity ~alloc =
69  {prim_name = name;
70   prim_arity = arity;
71   prim_alloc = alloc;
72   prim_native_name = "";
73   prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr;
74   prim_native_repr_res = Same_as_ocaml_repr}
75
76let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res =
77  {prim_name = name;
78   prim_arity = List.length native_repr_args;
79   prim_alloc = alloc;
80   prim_native_name = native_name;
81   prim_native_repr_args = native_repr_args;
82   prim_native_repr_res = native_repr_res}
83
84let parse_declaration valdecl ~native_repr_args ~native_repr_res =
85  let arity = List.length native_repr_args in
86  let name, native_name, old_style_noalloc, old_style_float =
87    match valdecl.pval_prim with
88    | name :: "noalloc" :: name2 :: "float" :: _ -> (name, name2, true, true)
89    | name :: "noalloc" :: name2 :: _ -> (name, name2, true, false)
90    | name :: name2 :: "float" :: _ -> (name, name2, false, true)
91    | name :: "noalloc" :: _ -> (name, "", true, false)
92    | name :: name2 :: _ -> (name, name2, false, false)
93    | name :: _ -> (name, "", false, false)
94    | [] ->
95        fatal_error "Primitive.parse_declaration"
96  in
97  let noalloc_attribute =
98    Attr_helper.has_no_payload_attribute ["noalloc"; "ocaml.noalloc"]
99      valdecl.pval_attributes
100  in
101  if old_style_float &&
102     not (List.for_all is_ocaml_repr native_repr_args &&
103          is_ocaml_repr native_repr_res) then
104    raise (Error (valdecl.pval_loc,
105                  Old_style_float_with_native_repr_attribute));
106  if old_style_noalloc && noalloc_attribute then
107    raise (Error (valdecl.pval_loc,
108                  Old_style_noalloc_with_noalloc_attribute));
109  (* The compiler used to assume "noalloc" with "float", we just make this
110     explicit now (GPR#167): *)
111  let old_style_noalloc = old_style_noalloc || old_style_float in
112  if old_style_float then
113    Location.prerr_warning valdecl.pval_loc
114      (Warnings.Deprecated "[@@unboxed] + [@@noalloc] should be used instead \
115                            of \"float\"")
116  else if old_style_noalloc then
117    Location.prerr_warning valdecl.pval_loc
118      (Warnings.Deprecated "[@@noalloc] should be used instead of \
119                            \"noalloc\"");
120  if native_name = "" &&
121     not (List.for_all is_ocaml_repr native_repr_args &&
122          is_ocaml_repr native_repr_res) then
123    raise (Error (valdecl.pval_loc,
124                  No_native_primitive_with_repr_attribute));
125  let noalloc = old_style_noalloc || noalloc_attribute in
126  let native_repr_args, native_repr_res =
127    if old_style_float then
128      (make_native_repr_args arity Unboxed_float, Unboxed_float)
129    else
130      (native_repr_args, native_repr_res)
131  in
132  {prim_name = name;
133   prim_arity = arity;
134   prim_alloc = not noalloc;
135   prim_native_name = native_name;
136   prim_native_repr_args = native_repr_args;
137   prim_native_repr_res = native_repr_res}
138
139open Outcometree
140
141let rec add_native_repr_attributes ty attrs =
142  match ty, attrs with
143  | Otyp_arrow (label, a, b), attr_opt :: rest ->
144    let b = add_native_repr_attributes b rest in
145    let a =
146      match attr_opt with
147      | None -> a
148      | Some attr -> Otyp_attribute (a, attr)
149    in
150    Otyp_arrow (label, a, b)
151  | _, [Some attr] -> Otyp_attribute (ty, attr)
152  | _ ->
153    assert (List.for_all (fun x -> x = None) attrs);
154    ty
155
156let oattr_unboxed = { oattr_name = "unboxed" }
157let oattr_untagged = { oattr_name = "untagged" }
158let oattr_noalloc = { oattr_name = "noalloc" }
159
160let print p osig_val_decl =
161  let prims =
162    if p.prim_native_name <> "" then
163      [p.prim_name; p.prim_native_name]
164    else
165      [p.prim_name]
166  in
167  let for_all f =
168    List.for_all f p.prim_native_repr_args && f p.prim_native_repr_res
169  in
170  let all_unboxed = for_all is_unboxed in
171  let all_untagged = for_all is_untagged in
172  let attrs = if p.prim_alloc then [] else [oattr_noalloc] in
173  let attrs =
174    if all_unboxed then
175      oattr_unboxed :: attrs
176    else if all_untagged then
177      oattr_untagged :: attrs
178    else
179      attrs
180  in
181  let attr_of_native_repr = function
182    | Same_as_ocaml_repr -> None
183    | Unboxed_float
184    | Unboxed_integer _ -> if all_unboxed then None else Some oattr_unboxed
185    | Untagged_int -> if all_untagged then None else Some oattr_untagged
186  in
187  let type_attrs =
188    List.map attr_of_native_repr p.prim_native_repr_args @
189    [attr_of_native_repr p.prim_native_repr_res]
190  in
191  { osig_val_decl with
192    oval_prims = prims;
193    oval_type = add_native_repr_attributes osig_val_decl.oval_type type_attrs;
194    oval_attributes = attrs }
195
196let native_name p =
197  if p.prim_native_name <> ""
198  then p.prim_native_name
199  else p.prim_name
200
201let byte_name p =
202  p.prim_name
203
204let report_error ppf err =
205  match err with
206  | Old_style_float_with_native_repr_attribute ->
207    Format.fprintf ppf "Cannot use \"float\" in conjunction with \
208                        [%@unboxed]/[%@untagged]"
209  | Old_style_noalloc_with_noalloc_attribute ->
210    Format.fprintf ppf "Cannot use \"noalloc\" in conjunction with \
211                        [%@%@noalloc]"
212  | No_native_primitive_with_repr_attribute ->
213    Format.fprintf ppf
214      "The native code version of the primitive is mandatory when \
215       attributes [%@untagged] or [%@unboxed] are present"
216
217let () =
218  Location.register_error_of_exn
219    (function
220      | Error (loc, err) ->
221        Some (Location.error_of_printer loc report_error err)
222      | _ ->
223        None
224    )
225