@@ -26,11 +26,16 @@ type native_repr =
26
26
| Unboxed_integer of boxed_integer
27
27
| Untagged_int
28
28
29
+ type effects = No_effects | Only_generative_effects | Arbitrary_effects
30
+ type coeffects = No_coeffects | Has_coeffects
31
+
29
32
type description =
30
33
{ prim_name : string ; (* Name of primitive or C function *)
31
34
prim_arity : int ; (* Number of arguments *)
32
35
prim_alloc : bool ; (* Does it allocates or raise? *)
33
36
prim_c_builtin : bool ; (* Is the compiler allowed to replace it? *)
37
+ prim_effects : effects ;
38
+ prim_coeffects : coeffects ;
34
39
prim_native_name : string ; (* Name of C function for the nat. code gen. *)
35
40
prim_native_repr_args : native_repr list ;
36
41
prim_native_repr_res : native_repr }
@@ -39,6 +44,8 @@ type error =
39
44
| Old_style_float_with_native_repr_attribute
40
45
| Old_style_noalloc_with_noalloc_attribute
41
46
| No_native_primitive_with_repr_attribute
47
+ | Inconsistent_attributes_for_effects
48
+ | Inconsistent_noalloc_attributes_for_effects
42
49
43
50
exception Error of Location. t * error
44
51
@@ -71,16 +78,20 @@ let simple ~name ~arity ~alloc =
71
78
prim_arity = arity;
72
79
prim_alloc = alloc;
73
80
prim_c_builtin = false ;
81
+ prim_effects = Arbitrary_effects ;
82
+ prim_coeffects = Has_coeffects ;
74
83
prim_native_name = " " ;
75
84
prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr ;
76
85
prim_native_repr_res = Same_as_ocaml_repr }
77
86
78
- let make ~name ~alloc ~c_builtin
87
+ let make ~name ~alloc ~c_builtin ~ effects ~ coeffects
79
88
~native_name ~native_repr_args ~native_repr_res =
80
89
{prim_name = name;
81
90
prim_arity = List. length native_repr_args;
82
91
prim_alloc = alloc;
83
92
prim_c_builtin = c_builtin;
93
+ prim_effects = effects;
94
+ prim_coeffects = coeffects;
84
95
prim_native_name = native_name;
85
96
prim_native_repr_args = native_repr_args;
86
97
prim_native_repr_res = native_repr_res}
@@ -106,6 +117,31 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res =
106
117
Attr_helper. has_no_payload_attribute [" builtin" ; " ocaml.builtin" ]
107
118
valdecl.pval_attributes
108
119
in
120
+ let no_effects_attribute =
121
+ Attr_helper. has_no_payload_attribute [" no_effects" ; " ocaml.no_effects" ]
122
+ valdecl.pval_attributes
123
+ in
124
+ let only_generative_effects_attribute =
125
+ Attr_helper. has_no_payload_attribute [" only_generative_effects" ;
126
+ " ocaml.only_generative_effects" ]
127
+ valdecl.pval_attributes
128
+ in
129
+ if no_effects_attribute && only_generative_effects_attribute then
130
+ raise (Error (valdecl.pval_loc,
131
+ Inconsistent_attributes_for_effects ));
132
+ let effects =
133
+ if no_effects_attribute then No_effects
134
+ else if only_generative_effects_attribute then Only_generative_effects
135
+ else Arbitrary_effects
136
+ in
137
+ let no_coeffects_attribute =
138
+ Attr_helper. has_no_payload_attribute [" no_coeffects" ; " ocaml.no_coeffects" ]
139
+ valdecl.pval_attributes
140
+ in
141
+ let coeffects =
142
+ if no_coeffects_attribute then No_coeffects
143
+ else Has_coeffects
144
+ in
109
145
if old_style_float &&
110
146
not (List. for_all is_ocaml_repr native_repr_args &&
111
147
is_ocaml_repr native_repr_res) then
@@ -130,6 +166,9 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res =
130
166
raise (Error (valdecl.pval_loc,
131
167
No_native_primitive_with_repr_attribute ));
132
168
let noalloc = old_style_noalloc || noalloc_attribute in
169
+ if noalloc && only_generative_effects_attribute then
170
+ raise (Error (valdecl.pval_loc,
171
+ Inconsistent_noalloc_attributes_for_effects ));
133
172
let native_repr_args, native_repr_res =
134
173
if old_style_float then
135
174
(make_native_repr_args arity Unboxed_float , Unboxed_float )
@@ -140,6 +179,8 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res =
140
179
prim_arity = arity;
141
180
prim_alloc = not noalloc;
142
181
prim_c_builtin = builtin_attribute;
182
+ prim_effects = effects;
183
+ prim_coeffects = coeffects;
143
184
prim_native_name = native_name;
144
185
prim_native_repr_args = native_repr_args;
145
186
prim_native_repr_res = native_repr_res}
@@ -165,6 +206,9 @@ let oattr_unboxed = { oattr_name = "unboxed" }
165
206
let oattr_untagged = { oattr_name = " untagged" }
166
207
let oattr_noalloc = { oattr_name = " noalloc" }
167
208
let oattr_builtin = { oattr_name = " builtin" }
209
+ let oattr_no_effects = { oattr_name = " no_effects" }
210
+ let oattr_only_generative_effects = { oattr_name = " only_generative_effects" }
211
+ let oattr_no_coeffects = { oattr_name = " no_coeffects" }
168
212
169
213
let print p osig_val_decl =
170
214
let prims =
@@ -180,6 +224,15 @@ let print p osig_val_decl =
180
224
let all_untagged = for_all is_untagged in
181
225
let attrs = if p.prim_alloc then [] else [oattr_noalloc] in
182
226
let attrs = if p.prim_c_builtin then oattr_builtin::attrs else attrs in
227
+ let attrs = match p.prim_effects with
228
+ | No_effects -> oattr_no_effects::attrs
229
+ | Only_generative_effects -> oattr_only_generative_effects::attrs
230
+ | Arbitrary_effects -> attrs
231
+ in
232
+ let attrs = match p.prim_coeffects with
233
+ | No_coeffects -> oattr_no_coeffects::attrs
234
+ | Has_coeffects -> attrs
235
+ in
183
236
let attrs =
184
237
if all_unboxed then
185
238
oattr_unboxed :: attrs
@@ -227,6 +280,12 @@ let report_error ppf err =
227
280
Format. fprintf ppf
228
281
" [@The native code version of the primitive is mandatory@ \
229
282
when attributes [%@untagged] or [%@unboxed] are present.@]"
283
+ | Inconsistent_attributes_for_effects ->
284
+ Format. fprintf ppf " At most one of [%@no_effects] and \
285
+ [%@only_generative_effects] can be specified."
286
+ | Inconsistent_noalloc_attributes_for_effects ->
287
+ Format. fprintf ppf " Cannot use [%@%@no_generative_effects] \
288
+ in conjunction with [%@%@noalloc]."
230
289
231
290
let () =
232
291
Location. register_error_of_exn
0 commit comments