Skip to content

Add a returns field to Cmm.Cextcall #74

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 4 commits into from
Jul 16, 2021
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 3 additions & 2 deletions backend/afl_instrument.ml
Original file line number Diff line number Diff line change
Expand Up @@ -103,11 +103,12 @@ let instrument_initialiser c dbg =
calls *)
with_afl_logging
(Csequence
(Cop (Cextcall { name = "caml_setup_afl";
(Cop (Cextcall { func = "caml_setup_afl";
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ret = typ_int; alloc = false; ty_args = []; },
ty = typ_int; alloc = false; ty_args = []; },
[Cconst_int (0, dbg ())],
dbg ()),
c))
Expand Down
18 changes: 9 additions & 9 deletions backend/amd64/selection.ml
Original file line number Diff line number Diff line change
Expand Up @@ -167,7 +167,7 @@ method is_immediate_test _cmp n = is_immediate n

method! is_simple_expr e =
match e with
| Cop(Cextcall { name = fn; }, args, _)
| Cop(Cextcall { func = fn; }, args, _)
when List.mem fn inline_ops ->
(* inlined ops are simple if their arguments are *)
List.for_all self#is_simple_expr args
Expand All @@ -176,7 +176,7 @@ method! is_simple_expr e =

method! effects_of e =
match e with
| Cop(Cextcall { name = fn; }, args, _)
| Cop(Cextcall { func = fn; }, args, _)
when List.mem fn inline_ops ->
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
| _ ->
Expand Down Expand Up @@ -233,7 +233,7 @@ method! select_operation op args dbg =
self#select_floatarith true Imulf Ifloatmul args
| Cdivf ->
self#select_floatarith false Idivf Ifloatdiv args
| Cextcall { name = "sqrt"; alloc = false; } ->
| Cextcall { func = "sqrt"; alloc = false; } ->
begin match args with
[Cop(Cload ((Double as chunk), _), [loc], _dbg)] ->
let (addr, arg) = self#select_addressing chunk loc in
Expand All @@ -243,8 +243,8 @@ method! select_operation op args dbg =
| _ ->
assert false
end
| Cextcall { name; builtin = true; ret; ty_args = _; } ->
begin match name, ret with
| Cextcall { func; builtin = true; ty = ret; ty_args = _; } ->
begin match func, ret with
| "caml_rdtsc_unboxed", [|Int|] -> Ispecific Irdtsc, args
| "caml_rdpmc_unboxed", [|Int|] -> Ispecific Irdpmc, args
| ("caml_int64_crc_unboxed", [|Int|]
Expand All @@ -263,12 +263,12 @@ method! select_operation op args dbg =
| _ ->
super#select_operation op args dbg
end
| Cextcall { name = "caml_bswap16_direct"; } ->
| Cextcall { func = "caml_bswap16_direct"; } ->
(Ispecific (Ibswap 16), args)
| Cextcall { name = "caml_int32_direct_bswap"; } ->
| Cextcall { func = "caml_int32_direct_bswap"; } ->
(Ispecific (Ibswap 32), args)
| Cextcall { name = "caml_int64_direct_bswap"; }
| Cextcall { name = "caml_nativeint_direct_bswap"; } ->
| Cextcall { func = "caml_int64_direct_bswap"; }
| Cextcall { func = "caml_nativeint_direct_bswap"; } ->
(Ispecific (Ibswap 64), args)
(* Recognize sign extension *)
| Casr ->
Expand Down
1 change: 1 addition & 0 deletions backend/cfg/cfg_intf.ml
Original file line number Diff line number Diff line change
Expand Up @@ -43,6 +43,7 @@ module S = struct
| External of
{ func_symbol : string;
alloc : bool;
returns : bool;
ty_res : Cmm.machtype;
ty_args : Cmm.exttype list
}
Expand Down
4 changes: 2 additions & 2 deletions backend/cfg/cfg_to_linear.ml
Original file line number Diff line number Diff line change
Expand Up @@ -46,8 +46,8 @@ let from_basic (basic : Cfg.basic) : L.instruction_desc =
| Call (F (Indirect)) -> Lop (Icall_ind)
| Call (F (Direct { func_symbol; })) ->
Lop (Icall_imm { func = func_symbol; })
| Call (P (External { func_symbol; alloc; ty_args; ty_res; })) ->
Lop (Iextcall { func = func_symbol; alloc; ty_args; ty_res; })
| Call (P (External { func_symbol; alloc; ty_args; ty_res; returns; })) ->
Lop (Iextcall { func = func_symbol; alloc; ty_args; ty_res; returns; })
| Call
(P
(Checkbound { immediate = None; }))
Expand Down
4 changes: 2 additions & 2 deletions backend/cfg/linear_to_cfg.ml
Original file line number Diff line number Diff line change
Expand Up @@ -400,8 +400,8 @@ let to_basic (mop : Mach.operation) : C.basic =
| Icall_ind -> Call (F Indirect)
| Icall_imm { func; } ->
Call (F (Direct { func_symbol = func; }))
| Iextcall { func; alloc; ty_args; ty_res; } ->
Call (P (External { func_symbol = func; alloc; ty_args; ty_res }))
| Iextcall { func; alloc; ty_args; ty_res; returns; } ->
Call (P (External { func_symbol = func; alloc; ty_args; ty_res; returns }))
| Iintop Icheckbound ->
Call
(P
Expand Down
7 changes: 4 additions & 3 deletions backend/cmm.ml
Original file line number Diff line number Diff line change
Expand Up @@ -167,13 +167,14 @@ type memory_chunk =
and operation =
Capply of machtype
| Cextcall of
{ name: string;
ret: machtype;
{ func: string;
ty: machtype;
ty_args : exttype list;
alloc: bool;
builtin: bool;
returns: bool;
effects: effects;
coeffects: coeffects;
ty_args : exttype list;
}
| Cload of memory_chunk * Asttypes.mutable_flag
| Calloc
Expand Down
7 changes: 4 additions & 3 deletions backend/cmm.mli
Original file line number Diff line number Diff line change
Expand Up @@ -166,13 +166,14 @@ type memory_chunk =
and operation =
Capply of machtype
| Cextcall of
{ name: string;
ret: machtype;
{ func: string;
ty: machtype;
ty_args : exttype list;
alloc: bool;
builtin: bool;
returns: bool;
effects: effects;
coeffects: coeffects;
ty_args : exttype list;
}
(** The [machtype] is the machine type of the result.
The [exttype list] describes the unboxing types of the arguments.
Expand Down
44 changes: 27 additions & 17 deletions backend/cmm_helpers.ml
Original file line number Diff line number Diff line change
Expand Up @@ -612,7 +612,7 @@ let rec remove_unit = function
| Cop(Capply _mty, args, dbg) ->
Cop(Capply typ_void, args, dbg)
| Cop(Cextcall c, args, dbg) ->
Cop(Cextcall {c with ret = typ_void; }, args, dbg)
Cop(Cextcall {c with ty = typ_void; }, args, dbg)
| Cexit (_,_,_) as c -> c
| Ctuple [] as c -> c
| c -> Csequence(c, Ctuple [])
Expand Down Expand Up @@ -734,18 +734,20 @@ let float_array_ref arr ofs dbg =
box_float dbg (unboxed_float_array_ref arr ofs dbg)

let addr_array_set arr ofs newval dbg =
Cop(Cextcall { name = "caml_modify"; ret = typ_void; alloc = false;
Cop(Cextcall { func = "caml_modify"; ty = typ_void; alloc = false;
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ty_args = []},
[array_indexing log2_size_addr arr ofs dbg; newval], dbg)
let addr_array_initialize arr ofs newval dbg =
Cop(Cextcall { name = "caml_initialize";
Cop(Cextcall { func = "caml_initialize";
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ret = typ_void; alloc = false; ty_args = []},
ty = typ_void; alloc = false; ty_args = []},
[array_indexing log2_size_addr arr ofs dbg; newval], dbg)
let int_array_set arr ofs newval dbg =
Cop(Cstore (Word_int, Lambda.Assignment),
Expand Down Expand Up @@ -781,8 +783,9 @@ let bigstring_length ba dbg =

let lookup_tag obj tag dbg =
bind "tag" tag (fun tag ->
Cop(Cextcall { name = "caml_get_public_method"; ret = typ_val;
Cop(Cextcall { func = "caml_get_public_method"; ty = typ_val;
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
alloc = false; ty_args = [] },
Expand Down Expand Up @@ -815,8 +818,9 @@ let make_alloc_generic set_fn dbg tag wordsize args =
| e1::el -> Csequence(set_fn (Cvar id) (Cconst_int (idx, dbg)) e1 dbg,
fill_fields (idx + 2) el) in
Clet(VP.create id,
Cop(Cextcall { name = "caml_alloc"; ret = typ_val; alloc = true;
Cop(Cextcall { func = "caml_alloc"; ty = typ_val; alloc = true;
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ty_args = [] },
Expand All @@ -826,8 +830,9 @@ let make_alloc_generic set_fn dbg tag wordsize args =

let make_alloc dbg tag args =
let addr_array_init arr ofs newval dbg =
Cop(Cextcall { name = "caml_initialize"; ret = typ_void; alloc = false;
Cop(Cextcall { func = "caml_initialize"; ty = typ_void; alloc = false;
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ty_args = [] },
Expand Down Expand Up @@ -2177,20 +2182,22 @@ let bbswap bi arg dbg =
| Pint32 -> "int32", XInt32
| Pint64 -> "int64", XInt64
in
Cop(Cextcall { name = Printf.sprintf "caml_%s_direct_bswap" prim;
Cop(Cextcall { func = Printf.sprintf "caml_%s_direct_bswap" prim;
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ret = typ_int; alloc = false; ty_args = [tyarg]; },
ty = typ_int; alloc = false; ty_args = [tyarg]; },
[arg],
dbg)

let bswap16 arg dbg =
(Cop(Cextcall { name = "caml_bswap16_direct";
(Cop(Cextcall { func = "caml_bswap16_direct";
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ret = typ_int; alloc = false; ty_args = []; },
ty = typ_int; alloc = false; ty_args = []; },
[arg],
dbg))

Expand Down Expand Up @@ -2251,19 +2258,21 @@ let assignment_kind
let setfield n ptr init arg1 arg2 dbg =
match assignment_kind ptr init with
| Caml_modify ->
return_unit dbg (Cop(Cextcall { name = "caml_modify";
ret = typ_void; alloc = false;
return_unit dbg (Cop(Cextcall { func = "caml_modify";
ty = typ_void; alloc = false;
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ty_args = [] },
[field_address arg1 n dbg;
arg2],
dbg))
| Caml_initialize ->
return_unit dbg (Cop(Cextcall { name = "caml_initialize";
ret = typ_void; alloc = false;
return_unit dbg (Cop(Cextcall { func = "caml_initialize";
ty = typ_void; alloc = false;
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ty_args = [] },
Expand Down Expand Up @@ -2723,13 +2732,14 @@ let transl_builtin name args dbg =
| _ -> None

(* [cextcall] is called from [Cmmgen.transl_ccall] *)
let cextcall (prim : Primitive.description) args dbg ret ty_args =
let cextcall (prim : Primitive.description) args dbg ret ty_args returns =
let name = Primitive.native_name prim in
let default = Cop(Cextcall { name; ret;
let default = Cop(Cextcall { func = name; ty = ret;
builtin = prim.prim_c_builtin;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
alloc = prim.prim_alloc;
returns;
ty_args },
args, dbg)
in
Expand Down
2 changes: 1 addition & 1 deletion backend/cmm_helpers.mli
Original file line number Diff line number Diff line change
Expand Up @@ -579,7 +579,7 @@ val send :
that corresponds to [prim]. If [prim] is a C builtin supported on the
target, returns [Cmm.operation] variant for [prim]'s intrinsics. *)
val cextcall : Primitive.description -> expression list -> Debuginfo.t ->
machtype -> exttype list -> expression
machtype -> exttype list -> bool -> expression

(** Generic Cmm fragments *)

Expand Down
13 changes: 8 additions & 5 deletions backend/cmmgen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -764,11 +764,12 @@ and transl_catch env nfail ids body handler dbg =
and transl_make_array dbg env kind args =
match kind with
| Pgenarray ->
Cop(Cextcall { name = "caml_make_array";
Cop(Cextcall { func = "caml_make_array";
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ret = typ_val; alloc = true; ty_args = []},
ty = typ_val; alloc = true; ty_args = []},
[make_alloc dbg 0 (List.map (transl env) args)], dbg)
| Paddrarray | Pintarray ->
make_alloc dbg 0 (List.map (transl env) args)
Expand Down Expand Up @@ -816,7 +817,7 @@ and transl_ccall env prim args dbg =
| Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
in
let typ_args, args = transl_args prim.prim_native_repr_args args in
let op = cextcall prim args dbg typ_res typ_args in
let op = cextcall prim args dbg typ_res typ_args true in
wrap_result op

and transl_prim_1 env p arg dbg =
Expand Down Expand Up @@ -1359,8 +1360,9 @@ and transl_letrec env bindings cont =
bindings
in
let op_alloc prim args =
Cop(Cextcall { name = prim; ret = typ_val; alloc = true;
Cop(Cextcall { func = prim; ty = typ_val; alloc = true;
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ty_args = [] },
Expand Down Expand Up @@ -1390,8 +1392,9 @@ and transl_letrec env bindings cont =
| [] -> cont
| (id, exp, (RHS_block _ | RHS_infix _ | RHS_floatblock _)) :: rem ->
let op =
Cop(Cextcall { name = "caml_update_dummy"; ret = typ_void;
Cop(Cextcall { func = "caml_update_dummy"; ty = typ_void;
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
alloc = false; ty_args = [] },
Expand Down
3 changes: 2 additions & 1 deletion backend/linearize.ml
Original file line number Diff line number Diff line change
Expand Up @@ -168,7 +168,8 @@ let linear i n contains_calls =
let rec linear env i n =
match i.Mach.desc with
Iend -> n
| Iop(Itailcall_ind | Itailcall_imm _ as op) ->
| Iop(Itailcall_ind | Itailcall_imm _ as op)
| Iop((Iextcall { returns = false; _ }) as op) ->
(* note: there cannot be deadcode in n *)
copy_instr (Lop op) i (linear env i.Mach.next n)
| Iop(Imove | Ireload | Ispill)
Expand Down
3 changes: 3 additions & 0 deletions backend/liveness.ml
Original file line number Diff line number Diff line change
Expand Up @@ -73,6 +73,9 @@ let rec live env i finally =
let across_after = Reg.diff_set_array after i.res in
let across =
match op with
| Iextcall { returns = false; _ } ->
(* extcalls that never return can raise an exception *)
env.at_raise
| Icall_ind | Icall_imm _ | Iextcall _ | Ialloc _
| Iprobe _
| Iintop (Icheckbound) | Iintop_imm(Icheckbound, _) ->
Expand Down
2 changes: 1 addition & 1 deletion backend/mach.ml
Original file line number Diff line number Diff line change
Expand Up @@ -57,7 +57,7 @@ type operation =
| Itailcall_imm of { func : string; }
| Iextcall of { func : string;
ty_res : Cmm.machtype; ty_args : Cmm.exttype list;
alloc : bool; }
alloc : bool; returns : bool; }
| Istackoffset of int
| Iload of Cmm.memory_chunk * Arch.addressing_mode
| Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
Expand Down
2 changes: 1 addition & 1 deletion backend/mach.mli
Original file line number Diff line number Diff line change
Expand Up @@ -60,7 +60,7 @@ type operation =
| Itailcall_imm of { func : string; }
| Iextcall of { func : string;
ty_res : Cmm.machtype; ty_args : Cmm.exttype list;
alloc : bool; }
alloc : bool; returns : bool; }
| Istackoffset of int
| Iload of Cmm.memory_chunk * Arch.addressing_mode
| Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
Expand Down
14 changes: 10 additions & 4 deletions backend/printcmm.ml
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,12 @@ let extcall_signature ppf (ty_res, ty_args) =
exttype ppf ty_arg1;
List.iter (fun ty -> fprintf ppf ",%a" exttype ty) ty_args
end;
fprintf ppf "->%a" machtype ty_res
begin match ty_res with
| None ->
fprintf ppf "->."
| Some ty_res ->
fprintf ppf "->%a" machtype ty_res
end

let integer_comparison = function
| Ceq -> "=="
Expand Down Expand Up @@ -137,7 +142,7 @@ let trywith_kind ppf kind =

let operation d = function
| Capply _ty -> "app" ^ location d
| Cextcall { name = lbl; _ } ->
| Cextcall { func = lbl; _ } ->
Printf.sprintf "extcall \"%s\"%s" lbl (location d)
| Cload (c, Asttypes.Immutable) -> Printf.sprintf "load %s" (chunk c)
| Cload (c, Asttypes.Mutable) -> Printf.sprintf "load_mut %s" (chunk c)
Expand Down Expand Up @@ -246,8 +251,9 @@ let rec expr ppf = function
List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
begin match op with
| Capply mty -> fprintf ppf "@ %a" machtype mty
| Cextcall { ret; ty_args; alloc = _; name = _; } ->
fprintf ppf "@ %a" extcall_signature (ret, ty_args)
| Cextcall { ty; ty_args; alloc = _; func = _; returns; } ->
let ty = if returns then Some ty else None in
fprintf ppf "@ %a" extcall_signature (ty, ty_args)
| _ -> ()
end;
fprintf ppf ")@]"
Expand Down
Loading