summaryrefslogtreecommitdiff
path: root/middle_end
diff options
context:
space:
mode:
Diffstat (limited to 'middle_end')
-rw-r--r--middle_end/clambda_primitives.ml16
-rw-r--r--middle_end/clambda_primitives.mli17
-rw-r--r--middle_end/closure/closure.ml21
-rw-r--r--middle_end/convert_primitives.ml15
-rw-r--r--middle_end/flambda/build_export_info.ml2
-rw-r--r--middle_end/flambda/closure_conversion.ml6
-rw-r--r--middle_end/flambda/extract_projections.ml2
-rw-r--r--middle_end/flambda/flambda_to_clambda.ml13
-rw-r--r--middle_end/flambda/flambda_utils.ml4
-rw-r--r--middle_end/flambda/inline_and_simplify.ml2
-rw-r--r--middle_end/flambda/lift_constants.ml4
-rw-r--r--middle_end/flambda/lift_let_to_initialize_symbol.ml4
-rw-r--r--middle_end/flambda/ref_to_variables.ml2
-rw-r--r--middle_end/flambda/remove_unused_program_constructs.ml8
-rw-r--r--middle_end/internal_variable_names.ml42
-rw-r--r--middle_end/printclambda_primitives.ml22
-rw-r--r--middle_end/semantics_of_primitives.ml9
17 files changed, 154 insertions, 35 deletions
diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml
index 3dd0587972..eace031fab 100644
--- a/middle_end/clambda_primitives.ml
+++ b/middle_end/clambda_primitives.ml
@@ -34,13 +34,18 @@ type primitive =
| Pread_symbol of string
(* Operations on heap blocks *)
| Pmakeblock of int * mutable_flag * block_shape
- | Pfield of int
+ | Pfield of int * immediate_or_pointer * mutable_flag
| Pfield_computed
| Psetfield of int * immediate_or_pointer * initialization_or_assignment
| Psetfield_computed of immediate_or_pointer * initialization_or_assignment
| Pfloatfield of int
| Psetfloatfield of int * initialization_or_assignment
| Pduprecord of Types.record_representation * int
+ (* Context switches *)
+ | Prunstack
+ | Pperform
+ | Presume
+ | Preperform
(* External call *)
| Pccall of Primitive.description
(* Exceptions *)
@@ -114,8 +119,17 @@ type primitive =
| Pbbswap of boxed_integer
(* Integer to external pointer *)
| Pint_as_pointer
+ (* Atomic operations *)
+ | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
+ | Patomic_exchange
+ | Patomic_cas
+ | Patomic_fetch_add
(* Inhibition of optimisation *)
| Popaque
+ (* Polling for interrupts *)
+ | Ppoll
+ (* nop instruction for debugging *)
+ | Pnop
and integer_comparison = Lambda.integer_comparison =
Ceq | Cne | Clt | Cgt | Cle | Cge
diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli
index a75cd04814..74daefdd95 100644
--- a/middle_end/clambda_primitives.mli
+++ b/middle_end/clambda_primitives.mli
@@ -34,13 +34,18 @@ type primitive =
| Pread_symbol of string
(* Operations on heap blocks *)
| Pmakeblock of int * mutable_flag * block_shape
- | Pfield of int
+ | Pfield of int * immediate_or_pointer * mutable_flag
| Pfield_computed
| Psetfield of int * immediate_or_pointer * initialization_or_assignment
| Psetfield_computed of immediate_or_pointer * initialization_or_assignment
| Pfloatfield of int
| Psetfloatfield of int * initialization_or_assignment
| Pduprecord of Types.record_representation * int
+ (* Context switches *)
+ | Prunstack
+ | Pperform
+ | Presume
+ | Preperform
(* External call *)
| Pccall of Primitive.description
(* Exceptions *)
@@ -117,8 +122,18 @@ type primitive =
| Pbbswap of boxed_integer
(* Integer to external pointer *)
| Pint_as_pointer
+ (* Atomic operations *)
+ | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
+ | Patomic_exchange
+ | Patomic_cas
+ | Patomic_fetch_add
(* Inhibition of optimisation *)
| Popaque
+ (* Polling for interrupts *)
+ | Ppoll
+ (* nop instruction for debugging *)
+ | Pnop
+
and integer_comparison = Lambda.integer_comparison =
Ceq | Cne | Clt | Cgt | Cle | Cge
diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml
index a51768216c..bc942c27c8 100644
--- a/middle_end/closure/closure.ml
+++ b/middle_end/closure/closure.ml
@@ -54,7 +54,7 @@ let rec build_closure_env env_param pos = function
[] -> V.Map.empty
| id :: rem ->
V.Map.add id
- (Uprim(P.Pfield pos, [Uvar env_param], Debuginfo.none))
+ (Uprim(P.Pfield(pos, Pointer, Immutable), [Uvar env_param], Debuginfo.none))
(build_closure_env env_param (pos+1) rem)
(* Auxiliary for accessing globals. We change the name of the global
@@ -117,10 +117,15 @@ let prim_size prim args =
match prim with
| Pread_symbol _ -> 1
| Pmakeblock _ -> 5 + List.length args
- | Pfield _ -> 1
+ | Pfield(_, isptr, Mutable) ->
+ begin match isptr with
+ | Pointer -> 2
+ | Immediate -> 1
+ end
+ | Pfield(_, _, Immutable) -> 1
| Psetfield(_f, isptr, init) ->
begin match init with
- | Root_initialization -> 1 (* never causes a write barrier hit *)
+ | Root_initialization
| Assignment | Heap_initialization ->
match isptr with
| Pointer -> 4
@@ -478,10 +483,10 @@ let simplif_prim_pure ~backend fpc p (args, approxs) dbg =
(Uprim(p, args, dbg), Value_tuple (Array.of_list approxs))
end
(* Field access *)
- | Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ]
+ | Pfield (n, _, _), _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ]
when n < List.length l ->
make_const (List.nth l n)
- | Pfield n, [ Uprim(P.Pmakeblock _, ul, _) ], [approx]
+ | Pfield(n, _, _), [ Uprim(P.Pmakeblock _, ul, _) ], [approx]
when n < List.length ul ->
(List.nth ul n, field_approx n approx)
(* Strings *)
@@ -819,7 +824,7 @@ let check_constant_result ulam approx =
let glb =
Uprim(P.Pread_symbol id, [], Debuginfo.none)
in
- Uprim(P.Pfield i, [glb], Debuginfo.none), approx
+ Uprim(P.Pfield(i, Pointer, Immutable), [glb], Debuginfo.none), approx
end
| _ -> (ulam, approx)
@@ -1081,10 +1086,10 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
let dbg = Debuginfo.from_location loc in
check_constant_result (getglobal dbg id)
(Compilenv.global_approx id)
- | Lprim(Pfield n, [lam], loc) ->
+ | Lprim(Pfield (n, ptr, mut), [lam], loc) ->
let (ulam, approx) = close env lam in
let dbg = Debuginfo.from_location loc in
- check_constant_result (Uprim(P.Pfield n, [ulam], dbg))
+ check_constant_result (Uprim(P.Pfield (n, ptr, mut), [ulam], dbg))
(field_approx n approx)
| Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)->
let (ulam, approx) = close env lam in
diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml
index 4ea177393e..8ea75c2e3a 100644
--- a/middle_end/convert_primitives.ml
+++ b/middle_end/convert_primitives.ml
@@ -26,7 +26,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
match prim with
| Pmakeblock (tag, mutability, shape) ->
Pmakeblock (tag, mutability, shape)
- | Pfield field -> Pfield field
+ | Pfield (field, imm_or_pointer, mutability) ->
+ Pfield (field, imm_or_pointer, mutability)
| Pfield_computed -> Pfield_computed
| Psetfield (field, imm_or_pointer, init_or_assign) ->
Psetfield (field, imm_or_pointer, init_or_assign)
@@ -36,6 +37,10 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
| Psetfloatfield (field, init_or_assign) ->
Psetfloatfield (field, init_or_assign)
| Pduprecord (repr, size) -> Pduprecord (repr, size)
+ | Prunstack -> Prunstack
+ | Pperform -> Pperform
+ | Presume -> Presume
+ | Preperform -> Preperform
| Pccall prim -> Pccall prim
| Praise kind -> Praise kind
| Psequand -> Psequand
@@ -139,8 +144,14 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
| Pbigarraydim dim -> Pbigarraydim dim
| Pbswap16 -> Pbswap16
| Pint_as_pointer -> Pint_as_pointer
+ | Patomic_load { immediate_or_pointer } ->
+ Patomic_load { immediate_or_pointer }
+ | Patomic_exchange -> Patomic_exchange
+ | Patomic_cas -> Patomic_cas
+ | Patomic_fetch_add -> Patomic_fetch_add
| Popaque -> Popaque
-
+ | Ppoll -> Ppoll
+ | Pnop -> Pnop
| Pbytes_to_string
| Pbytes_of_string
| Pctconst _
diff --git a/middle_end/flambda/build_export_info.ml b/middle_end/flambda/build_export_info.ml
index 554b69a2e2..a3cb96d251 100644
--- a/middle_end/flambda/build_export_info.ml
+++ b/middle_end/flambda/build_export_info.ml
@@ -286,7 +286,7 @@ and descr_of_named (env : Env.t) (named : Flambda.named)
Value_block (Tag.create_exn tag, Array.of_list approxs)
in
Value_id (Env.new_descr env descr)
- | Prim (Pfield i, [arg], _) ->
+ | Prim (Pfield (i, _, _), [arg], _) ->
begin match Env.get_descr env (Env.find_approx env arg) with
| Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i)
| _ -> Value_unknown
diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml
index 8c731a9faa..0dd0f972bf 100644
--- a/middle_end/flambda/closure_conversion.ml
+++ b/middle_end/flambda/closure_conversion.ml
@@ -92,7 +92,7 @@ let tupled_function_call_stub original_params unboxed_version ~closure_bound_var
let _, body =
List.fold_left (fun (pos, body) param ->
let lam : Flambda.named =
- Prim (Pfield pos, [tuple_param_var], Debuginfo.none)
+ Prim (Pfield (pos, Pointer, Mutable), [tuple_param_var], Debuginfo.none)
in
pos + 1, Flambda.create_let param lam body)
(0, call) params
@@ -708,9 +708,9 @@ let lambda_to_flambda ~backend ~module_ident ~size ~filename lam
Flambda.create_let
sym_v (Symbol block_symbol)
(Flambda.create_let result_v
- (Prim (Pfield 0, [sym_v], Debuginfo.none))
+ (Prim (Pfield (0, Pointer, Mutable), [sym_v], Debuginfo.none))
(Flambda.create_let value_v
- (Prim (Pfield pos, [result_v], Debuginfo.none))
+ (Prim (Pfield (pos, Pointer, Mutable), [result_v], Debuginfo.none))
(Var value_v))))
in
let module_initializer : Flambda.program_body =
diff --git a/middle_end/flambda/extract_projections.ml b/middle_end/flambda/extract_projections.ml
index 33cd473ecd..a368b3bd7f 100644
--- a/middle_end/flambda/extract_projections.ml
+++ b/middle_end/flambda/extract_projections.ml
@@ -124,7 +124,7 @@ let rec analyse_expr ~which_variables expr =
when Variable.Map.mem move.closure which_variables ->
projections :=
Projection.Set.add (Move_within_set_of_closures move) !projections
- | Prim (Pfield field_index, [var], _dbg)
+ | Prim (Pfield (field_index, _, _), [var], _dbg)
when Variable.Map.mem var which_variables ->
projections :=
Projection.Set.add (Field (field_index, var)) !projections
diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml
index 6b4fae2462..c28167e042 100644
--- a/middle_end/flambda/flambda_to_clambda.ml
+++ b/middle_end/flambda/flambda_to_clambda.ml
@@ -371,7 +371,8 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
Flambda.print_named named
end
| Read_symbol_field (symbol, field) ->
- Uprim (Pfield field, [to_clambda_symbol env symbol], Debuginfo.none)
+ Uprim (Pfield (field, Pointer, Mutable),
+ [to_clambda_symbol env symbol], Debuginfo.none)
| Set_of_closures set_of_closures ->
to_clambda_set_of_closures t env set_of_closures
| Project_closure { set_of_closures; closure_id } ->
@@ -396,12 +397,13 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
let fun_offset = get_fun_offset t closure_id in
let var_offset = get_fv_offset t var in
let pos = var_offset - fun_offset in
- Uprim (Pfield pos,
+ Uprim (Pfield (pos, Pointer, Mutable),
[check_field t (check_closure t ulam (Expr (Var closure)))
pos (Some named)],
Debuginfo.none)
- | Prim (Pfield index, [block], dbg) ->
- Uprim (Pfield index, [check_field t (subst_var env block) index None], dbg)
+ | Prim (Pfield (index, ptr, mut), [block], dbg) ->
+ Uprim (Pfield (index, ptr, mut),
+ [check_field t (subst_var env block) index None], dbg)
| Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) ->
Uprim (Psetfield (index, maybe_ptr, init), [
check_field t (subst_var env block) index None;
@@ -514,7 +516,8 @@ and to_clambda_set_of_closures t env
in
let pos = var_offset - fun_offset in
Env.add_subst env id
- (Uprim (Pfield pos, [Clambda.Uvar env_var], Debuginfo.none))
+ (Uprim (Pfield (pos, Pointer, Mutable),
+ [Clambda.Uvar env_var], Debuginfo.none))
in
let env = Variable.Map.fold add_env_free_variable free_vars env in
(* Add the Clambda expressions for all functions defined in the current
diff --git a/middle_end/flambda/flambda_utils.ml b/middle_end/flambda/flambda_utils.ml
index c204f5e67c..1eb9705a34 100644
--- a/middle_end/flambda/flambda_utils.ml
+++ b/middle_end/flambda/flambda_utils.ml
@@ -543,7 +543,7 @@ let substitute_read_symbol_field_for_variables
Expr (
Flambda.create_let block (make_named t)
(Flambda.create_let field
- (Prim (Pfield h, [block], Debuginfo.none))
+ (Prim (Pfield (h, Pointer, Mutable), [block], Debuginfo.none))
(Var field)))
in
Flambda.create_let fresh_var (make_named path) expr
@@ -902,7 +902,7 @@ let projection_to_named (projection : Projection.t) : Flambda.named =
| Project_closure project_closure -> Project_closure project_closure
| Move_within_set_of_closures move -> Move_within_set_of_closures move
| Field (field_index, var) ->
- Prim (Pfield field_index, [var], Debuginfo.none)
+ Prim (Pfield (field_index, Pointer, Mutable), [var], Debuginfo.none)
type specialised_to_same_as =
| Not_specialised
diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml
index 775268a2c3..538bf9ff3e 100644
--- a/middle_end/flambda/inline_and_simplify.ml
+++ b/middle_end/flambda/inline_and_simplify.ml
@@ -991,7 +991,7 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t =
let tree = Flambda.Prim (prim, args, dbg) in
begin match prim, args, args_approxs with
(* CR-someday mshinwell: Optimise [Pfield_computed]. *)
- | Pfield field_index, [arg], [arg_approx] ->
+ | Pfield (field_index, _, _), [arg], [arg_approx] ->
let projection : Projection.t = Field (field_index, arg) in
begin match E.find_projection env ~projection with
| Some var ->
diff --git a/middle_end/flambda/lift_constants.ml b/middle_end/flambda/lift_constants.ml
index dd60de9ce2..4af9829d85 100644
--- a/middle_end/flambda/lift_constants.ml
+++ b/middle_end/flambda/lift_constants.ml
@@ -89,7 +89,7 @@ let assign_symbols_and_collect_constant_definitions
| Project_closure ({ closure_id } as project_closure) ->
assign_existing_symbol (closure_symbol ~backend closure_id);
record_definition (AA.Project_closure project_closure)
- | Prim (Pfield index, [block], _) ->
+ | Prim (Pfield (index, _, _), [block], _) ->
record_definition (AA.Field (block, index))
| Prim (Pfield _, _, _) ->
Misc.fatal_errorf "[Pfield] with the wrong number of arguments"
@@ -997,7 +997,7 @@ let lift_constants (program : Flambda.program) ~backend =
constant_definitions
in
let effect_tbl =
- Symbol.Tbl.map effect_tbl (fun (effect, dep) -> rewrite_expr effect, dep)
+ Symbol.Tbl.map effect_tbl (fun (eff, dep) -> rewrite_expr eff, dep)
in
let initialize_symbol_tbl =
Symbol.Tbl.map initialize_symbol_tbl (fun (tag, fields, dep) ->
diff --git a/middle_end/flambda/lift_let_to_initialize_symbol.ml b/middle_end/flambda/lift_let_to_initialize_symbol.ml
index ccef0d8a1f..32703833b7 100644
--- a/middle_end/flambda/lift_let_to_initialize_symbol.ml
+++ b/middle_end/flambda/lift_let_to_initialize_symbol.ml
@@ -264,8 +264,8 @@ let add_extracted introduced program =
match extracted with
| Initialisation (symbol, tag, def) ->
Flambda.Initialize_symbol (symbol, tag, def, program)
- | Effect effect ->
- Flambda.Effect (effect, program))
+ | Effect eff ->
+ Flambda.Effect (eff, program))
introduced program
let rec split_program (program : Flambda.program_body) : Flambda.program_body =
diff --git a/middle_end/flambda/ref_to_variables.ml b/middle_end/flambda/ref_to_variables.ml
index aa2a73c630..746374e885 100644
--- a/middle_end/flambda/ref_to_variables.ml
+++ b/middle_end/flambda/ref_to_variables.ml
@@ -155,7 +155,7 @@ let eliminate_ref_of_expr flam =
flam
and aux_named (named : Flambda.named) : Flambda.named =
match named with
- | Prim(Pfield field, [v], _)
+ | Prim(Pfield (field, _, _), [v], _)
when convertible_variable v ->
(match get_variable v field with
| None -> Expr Proved_unreachable
diff --git a/middle_end/flambda/remove_unused_program_constructs.ml b/middle_end/flambda/remove_unused_program_constructs.ml
index 059d68bcba..468223dcfa 100644
--- a/middle_end/flambda/remove_unused_program_constructs.ml
+++ b/middle_end/flambda/remove_unused_program_constructs.ml
@@ -94,14 +94,14 @@ let rec loop (program : Flambda.program_body)
Flambda.Effect (field, program), dep)
(program, dep) fields
end
- | Effect (effect, program) ->
+ | Effect (eff, program) ->
let program, dep = loop program in
- if Effect_analysis.no_effects effect then begin
+ if Effect_analysis.no_effects eff then begin
program, dep
end else begin
- let new_dep = dependency effect in
+ let new_dep = dependency eff in
let dep = Symbol.Set.union new_dep dep in
- Effect (effect, program), dep
+ Effect (eff, program), dep
end
| End symbol -> program, Symbol.Set.singleton symbol
diff --git a/middle_end/internal_variable_names.ml b/middle_end/internal_variable_names.ml
index d139dbb21e..98c6a8bfa8 100644
--- a/middle_end/internal_variable_names.ml
+++ b/middle_end/internal_variable_names.ml
@@ -172,6 +172,17 @@ let psubfloat = "Psubfloat"
let psubint = "Psubint"
let pxorbint = "Pxorbint"
let pxorint = "Pxorint"
+let patomic_cas = "Patomic_cas"
+let patomic_exchange = "Patomic_exchange"
+let patomic_fetch_add = "Patomic_fetch_add"
+let patomic_load = "Patomic_load"
+let prunstack = "Prunstack"
+let pperform = "Pperform"
+let presume = "Presume"
+let preperform = "Preperform"
+let ppoll = "Ppoll"
+let pnop = "Pnop"
+
let pabsfloat_arg = "Pabsfloat_arg"
let paddbint_arg = "Paddbint_arg"
let paddfloat_arg = "Paddfloat_arg"
@@ -277,6 +288,17 @@ let psubfloat_arg = "Psubfloat_arg"
let psubint_arg = "Psubint_arg"
let pxorbint_arg = "Pxorbint_arg"
let pxorint_arg = "Pxorint_arg"
+let patomic_cas_arg = "Patomic_cas_arg"
+let patomic_exchange_arg = "Patomic_exchange_arg"
+let patomic_fetch_add_arg = "Patomic_fetch_add_arg"
+let patomic_load_arg = "Patomic_load_arg"
+let prunstack_arg = "Prunstack_arg"
+let pperform_arg = "Pperform_arg"
+let presume_arg = "Presume_arg"
+let preperform_arg = "Preperform_arg"
+let ppoll_arg = "Ppoll_arg"
+let pnop_arg = "Pnop_arg"
+
let raise = "raise"
let raise_arg = "raise_arg"
let read_mutable = "read_mutable"
@@ -414,6 +436,16 @@ let of_primitive : Lambda.primitive -> string = function
| Pbbswap _ -> pbbswap
| Pint_as_pointer -> pint_as_pointer
| Popaque -> popaque
+ | Patomic_cas -> patomic_cas
+ | Patomic_exchange -> patomic_exchange
+ | Patomic_fetch_add -> patomic_fetch_add
+ | Patomic_load _ -> patomic_load
+ | Prunstack -> prunstack
+ | Pperform -> pperform
+ | Presume -> presume
+ | Preperform -> preperform
+ | Ppoll -> ppoll
+ | Pnop -> pnop
let of_primitive_arg : Lambda.primitive -> string = function
| Pidentity -> pidentity_arg
@@ -520,3 +552,13 @@ let of_primitive_arg : Lambda.primitive -> string = function
| Pbbswap _ -> pbbswap_arg
| Pint_as_pointer -> pint_as_pointer_arg
| Popaque -> popaque_arg
+ | Patomic_cas -> patomic_cas_arg
+ | Patomic_exchange -> patomic_exchange_arg
+ | Patomic_fetch_add -> patomic_fetch_add_arg
+ | Patomic_load _ -> patomic_load_arg
+ | Prunstack -> prunstack_arg
+ | Pperform -> pperform_arg
+ | Presume -> presume_arg
+ | Preperform -> preperform_arg
+ | Ppoll -> ppoll_arg
+ | Pnop -> pnop_arg
diff --git a/middle_end/printclambda_primitives.ml b/middle_end/printclambda_primitives.ml
index 2e94989155..5c591bfc21 100644
--- a/middle_end/printclambda_primitives.ml
+++ b/middle_end/printclambda_primitives.ml
@@ -61,7 +61,14 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
fprintf ppf "makeblock %i%a" tag Printlambda.block_shape shape
| Pmakeblock(tag, Mutable, shape) ->
fprintf ppf "makemutable %i%a" tag Printlambda.block_shape shape
- | Pfield n -> fprintf ppf "field %i" n
+ | Pfield(n, ptr, mut) ->
+ let instr =
+ match ptr, mut with
+ | Immediate, _ -> "field_int "
+ | Pointer, Mutable -> "field_mut "
+ | Pointer, Immutable -> "field_imm "
+ in
+ fprintf ppf "%s%i" instr n
| Pfield_computed -> fprintf ppf "field_computed"
| Psetfield(n, ptr, init) ->
let instr =
@@ -100,6 +107,10 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
fprintf ppf "setfloatfield%s %i" init n
| Pduprecord (rep, size) ->
fprintf ppf "duprecord %a %i" Printlambda.record_rep rep size
+ | Prunstack -> fprintf ppf "runstack"
+ | Pperform -> fprintf ppf "perform"
+ | Presume -> fprintf ppf "resume"
+ | Preperform -> fprintf ppf "reperform"
| Pccall p -> fprintf ppf "%s" p.Primitive.prim_name
| Praise k -> fprintf ppf "%s" (Lambda.raise_kind k)
| Psequand -> fprintf ppf "&&"
@@ -202,4 +213,13 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
| Pbswap16 -> fprintf ppf "bswap16"
| Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
| Pint_as_pointer -> fprintf ppf "int_as_pointer"
+ | Patomic_load {immediate_or_pointer} ->
+ (match immediate_or_pointer with
+ | Immediate -> fprintf ppf "atomic_load_imm"
+ | Pointer -> fprintf ppf "atomic_load_ptr")
+ | Patomic_exchange -> fprintf ppf "atomic_exchange"
+ | Patomic_cas -> fprintf ppf "atomic_cas"
+ | Patomic_fetch_add -> fprintf ppf "atomic_fetch_add"
| Popaque -> fprintf ppf "opaque"
+ | Ppoll -> fprintf ppf "poll"
+ | Pnop -> fprintf ppf "nop"
diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml
index 47ed8c3e59..71feafc94b 100644
--- a/middle_end/semantics_of_primitives.ml
+++ b/middle_end/semantics_of_primitives.ml
@@ -33,8 +33,13 @@ let for_primitive (prim : Clambda_primitives.primitive) =
( "caml_format_float" | "caml_format_int" | "caml_int32_format"
| "caml_nativeint_format" | "caml_int64_format" ) } ->
No_effects, No_coeffects
+ | Pnop -> Arbitrary_effects, Has_coeffects (* XXX KC: conservative so that
+ the optimiser will not move it
+ around. Is that right? *)
| Pccall _ -> Arbitrary_effects, Has_coeffects
| Praise _ -> Arbitrary_effects, No_coeffects
+ | Prunstack | Pperform | Presume | Preperform -> Arbitrary_effects, Has_coeffects
+ | Ppoll -> Arbitrary_effects, Has_coeffects
| Pnot
| Pnegint
| Paddint
@@ -115,6 +120,10 @@ let for_primitive (prim : Clambda_primitives.primitive) =
| Psetfield _
| Psetfield_computed _
| Psetfloatfield _
+ | Patomic_load _
+ | Patomic_exchange
+ | Patomic_cas
+ | Patomic_fetch_add
| Parraysetu _
| Parraysets _
| Pbytessetu
View Lorry Controller Status