Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

More debugging information in Cmm terms (#2308) 

Following on from GPR#851 and GPR#873, this pull request further enhances debugging information in Cmm terms. This was driven both by manually examining the debugger's behaviour and also by a report received from a user regarding substandard DWARF location information.
master
Mark Shinwell 2019-03-13 15:40:04 +00:00 committed by Stephen Dolan
parent 0bd539ae24
commit 618e5dbfbd
18 changed files with 1031 additions and 695 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Changes
View File

@ -50,6 +50,9 @@ Working version
- GPR#2286: Functorise [Consistbl]
(Mark Shinwell, review by Gabriel Radanne)
- GPR#2308: More debugging information on [Cmm] terms
(Mark Shinwell, review by Stephen Dolan)
### Runtime system:
- GPR#1725: Deprecate Obj.set_tag

52
asmcomp/afl_instrument.ml
View File

@ -20,11 +20,11 @@ open Cmm
module V = Backend_var
module VP = Backend_var.With_provenance
let afl_area_ptr = Cconst_symbol "caml_afl_area_ptr"
let afl_prev_loc = Cconst_symbol "caml_afl_prev_loc"
let afl_area_ptr dbg = Cconst_symbol ("caml_afl_area_ptr", dbg)
let afl_prev_loc dbg = Cconst_symbol ("caml_afl_prev_loc", dbg)
let afl_map_size = 1 lsl 16
let rec with_afl_logging b =
let rec with_afl_logging b dbg =
if !Clflags.afl_inst_ratio < 100 &&
Random.int 100 >= !Clflags.afl_inst_ratio then instrument b else
let instrumentation =
@ -40,29 +40,36 @@ let rec with_afl_logging b =
let cur_location = Random.int afl_map_size in
let cur_pos = V.create_local "pos" in
let afl_area = V.create_local "shared_mem" in
let op oper args = Cop (oper, args, Debuginfo.none) in
let op oper args = Cop (oper, args, dbg) in
Clet(VP.create afl_area,
op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr],
op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr dbg],
Clet(VP.create cur_pos, op Cxor [op (Cload (Word_int, Asttypes.Mutable))
[afl_prev_loc]; Cconst_int cur_location],
[afl_prev_loc dbg]; Cconst_int (cur_location, dbg)],
Csequence(
op (Cstore(Byte_unsigned, Assignment))
[op Cadda [Cvar afl_area; Cvar cur_pos];
op Cadda [op (Cload (Byte_unsigned, Asttypes.Mutable))
[op Cadda [Cvar afl_area; Cvar cur_pos]];
Cconst_int 1]],
Cconst_int (1, dbg)]],
op (Cstore(Word_int, Assignment))
[afl_prev_loc; Cconst_int (cur_location lsr 1)]))) in
[afl_prev_loc dbg; Cconst_int (cur_location lsr 1, dbg)]))) in
Csequence(instrumentation, instrument b)
and instrument = function
(* these cases add logging, as they may be targets of conditional branches *)
| Cifthenelse (cond, t, f) ->
Cifthenelse (instrument cond, with_afl_logging t, with_afl_logging f)
| Ctrywith (e, ex, handler) ->
Ctrywith (instrument e, ex, with_afl_logging handler)
| Cifthenelse (cond, t_dbg, t, f_dbg, f, dbg) ->
Cifthenelse (instrument cond, t_dbg, with_afl_logging t t_dbg,
f_dbg, with_afl_logging f f_dbg, dbg)
| Ctrywith (e, ex, handler, dbg) ->
Ctrywith (instrument e, ex, with_afl_logging handler dbg, dbg)
| Cswitch (e, cases, handlers, dbg) ->
Cswitch (instrument e, cases, Array.map with_afl_logging handlers, dbg)
let handlers =
Array.map (fun (handler, handler_dbg) ->
let handler = with_afl_logging handler handler_dbg in
handler, handler_dbg)
handlers
in
Cswitch (instrument e, cases, handlers, dbg)
(* these cases add no logging, but instrument subexpressions *)
| Clet (v, e, body) -> Clet (v, instrument e, instrument body)
@ -73,9 +80,11 @@ and instrument = function
| Cop (op, es, dbg) -> Cop (op, List.map instrument es, dbg)
| Csequence (e1, e2) -> Csequence (instrument e1, instrument e2)
| Ccatch (isrec, cases, body) ->
Ccatch (isrec,
List.map (fun (nfail, ids, e) -> nfail, ids, instrument e) cases,
instrument body)
let cases =
List.map (fun (nfail, ids, e, dbg) -> nfail, ids, instrument e, dbg)
cases
in
Ccatch (isrec, cases, instrument body)
| Cexit (ex, args) -> Cexit (ex, List.map instrument args)
(* these are base cases and have no logging *)
@ -83,16 +92,17 @@ and instrument = function
| Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _
| Cblockheader _ | Cvar _ as c -> c
let instrument_function c =
with_afl_logging c
let instrument_function c dbg =
with_afl_logging c dbg
let instrument_initialiser c =
let instrument_initialiser c dbg =
(* Each instrumented module calls caml_setup_afl at
initialisation, which is a no-op on the second and subsequent
calls *)
with_afl_logging
(Csequence
(Cop (Cextcall ("caml_setup_afl", typ_int, false, None),
[Cconst_int 0],
Debuginfo.none),
[Cconst_int (0, dbg ())],
dbg ()),
c))
(dbg ())

23
asmcomp/afl_instrument.mli
View File

@ -1,4 +1,21 @@
(* Instrumentation for afl-fuzz *)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Stephen Dolan, University of Cambridge *)
(* *)
(* Copyright 2016 Stephen Dolan. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
val instrument_function : Cmm.expression -> Cmm.expression
val instrument_initialiser : Cmm.expression -> Cmm.expression
(** Instrumentation for afl-fuzz. *)
val instrument_function : Cmm.expression -> Debuginfo.t -> Cmm.expression
val instrument_initialiser
: Cmm.expression
-> (unit -> Debuginfo.t)
-> Cmm.expression

26
asmcomp/amd64/selection.ml
View File

@ -31,25 +31,25 @@ type addressing_expr =
let rec select_addr exp =
match exp with
Cconst_symbol s when not !Clflags.dlcode ->
Cconst_symbol (s, _) when not !Clflags.dlcode ->
(Asymbol s, 0)
| Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], _) ->
| Cop((Caddi | Caddv | Cadda), [arg; Cconst_int (m, _)], _) ->
let (a, n) = select_addr arg in (a, n + m)
| Cop(Csubi, [arg; Cconst_int m], _) ->
| Cop(Csubi, [arg; Cconst_int (m, _)], _) ->
let (a, n) = select_addr arg in (a, n - m)
| Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], _) ->
| Cop((Caddi | Caddv | Cadda), [Cconst_int (m, _); arg], _) ->
let (a, n) = select_addr arg in (a, n + m)
| Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)], _) ->
| Cop(Clsl, [arg; Cconst_int((1|2|3 as shift), _)], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
| _ -> (Alinear exp, 0)
end
| Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)], _) ->
| Cop(Cmuli, [arg; Cconst_int((2|4|8 as mult), _)], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, mult), n * mult)
| _ -> (Alinear exp, 0)
end
| Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg], _) ->
| Cop(Cmuli, [Cconst_int((2|4|8 as mult), _); arg], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, mult), n * mult)
| _ -> (Alinear exp, 0)
@ -169,16 +169,16 @@ method select_addressing _chunk exp =
method! select_store is_assign addr exp =
match exp with
Cconst_int n when self#is_immediate n ->
Cconst_int (n, _dbg) when self#is_immediate n ->
(Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
| (Cconst_natint n) when self#is_immediate_natint n ->
| (Cconst_natint (n, _dbg)) when self#is_immediate_natint n ->
(Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
| (Cblockheader(n, _dbg))
when self#is_immediate_natint n && not Config.spacetime ->
(Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
| Cconst_pointer n when self#is_immediate n ->
| Cconst_pointer (n, _dbg) when self#is_immediate n ->
(Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
| Cconst_natpointer n when self#is_immediate_natint n ->
| Cconst_natpointer (n, _dbg) when self#is_immediate_natint n ->
(Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
| _ ->
super#select_store is_assign addr exp
@ -214,7 +214,7 @@ method! select_operation op args dbg =
(* Recognize store instructions *)
| Cstore ((Word_int|Word_val as chunk), _init) ->
begin match args with
[loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int n], _)]
[loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int (n, _dbg)], _)]
when loc = loc' && self#is_immediate n ->
let (addr, arg) = self#select_addressing chunk loc in
(Ispecific(Ioffset_loc(n, addr)), [arg])
@ -234,7 +234,7 @@ method! select_operation op args dbg =
| Casr ->
begin match args with
(* Recognize sign extension *)
[Cop(Clsl, [k; Cconst_int 32], _); Cconst_int 32] ->
[Cop(Clsl, [k; Cconst_int (32, _)], _); Cconst_int (32, _)] ->
(Ispecific Isextend32, [k])
| _ -> super#select_operation op args dbg
end

17
asmcomp/arm/selection.ml
View File

@ -131,10 +131,11 @@ method! effects_of e =
| e -> super#effects_of e
method select_addressing chunk = function
| Cop((Cadda | Caddv), [arg; Cconst_int n], _)
| Cop((Cadda | Caddv), [arg; Cconst_int (n, _)], _)
when is_offset chunk n ->
(Iindexed n, arg)
| Cop((Cadda | Caddv as op), [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg)
| Cop((Cadda | Caddv as op),
[arg1; Cop(Caddi, [arg2; Cconst_int (n, _)], _)], dbg)
when is_offset chunk n ->
(Iindexed n, Cop(op, [arg1; arg2], dbg))
| arg ->
@ -142,10 +143,10 @@ method select_addressing chunk = function
method select_shift_arith op dbg arithop arithrevop args =
match args with
[arg1; Cop(Clsl | Clsr | Casr as op, [arg2; Cconst_int n], _)]
[arg1; Cop(Clsl | Clsr | Casr as op, [arg2; Cconst_int (n, _)], _)]
when n > 0 && n < 32 ->
(Ispecific(Ishiftarith(arithop, select_shiftop op, n)), [arg1; arg2])
| [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n], _); arg2]
| [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int (n, _)], _); arg2]
when n > 0 && n < 32 ->
(Ispecific(Ishiftarith(arithrevop, select_shiftop op, n)), [arg2; arg1])
| args ->
@ -184,15 +185,15 @@ method private iextcall (func, alloc) =
method! select_operation op args dbg =
match (op, args) with
(* Recognize special shift arithmetic *)
((Caddv | Cadda | Caddi), [arg; Cconst_int n])
((Caddv | Cadda | Caddi), [arg; Cconst_int (n, _)])
when n < 0 && self#is_immediate (-n) ->
(Iintop_imm(Isub, -n), [arg])
| ((Caddv | Cadda | Caddi as op), args) ->
self#select_shift_arith op dbg Ishiftadd Ishiftadd args
| (Csubi, [arg; Cconst_int n])
| (Csubi, [arg; Cconst_int (n, _)])
when n < 0 && self#is_immediate (-n) ->
(Iintop_imm(Iadd, -n), [arg])
| (Csubi, [Cconst_int n; arg])
| (Csubi, [Cconst_int (n, _); arg])
when self#is_immediate n ->
(Ispecific(Irevsubimm n), [arg])
| (Csubi as op, args) ->
@ -204,7 +205,7 @@ method! select_operation op args dbg =
| (Cxor as op, args) ->
self#select_shift_arith op dbg Ishiftxor Ishiftxor args
| (Ccheckbound,
[Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n], _); arg2])
[Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int (n, _)], _); arg2])
when n > 0 && n < 32 ->
(Ispecific(Ishiftcheckbound(select_shiftop op, n)), [arg1; arg2])
(* ARM does not support immediate operands for multiplication *)

33
asmcomp/arm64/selection.ml
View File

@ -109,16 +109,17 @@ method! effects_of e =
| e -> super#effects_of e
method select_addressing chunk = function
| Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n], _)
| Cop((Caddv | Cadda), [Cconst_symbol (s, _); Cconst_int (n, _)], _)
when use_direct_addressing s ->
(Ibased(s, n), Ctuple [])
| Cop((Caddv | Cadda), [arg; Cconst_int n], _)
| Cop((Caddv | Cadda), [arg; Cconst_int (n, _)], _)
when is_offset chunk n ->
(Iindexed n, arg)
| Cop((Caddv | Cadda as op), [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg)
| Cop((Caddv | Cadda as op),
[arg1; Cop(Caddi, [arg2; Cconst_int (n, _)], _)], dbg)
when is_offset chunk n ->
(Iindexed n, Cop(op, [arg1; arg2], dbg))
| Cconst_symbol s
| Cconst_symbol (s, _)
when use_direct_addressing s ->
(Ibased(s, 0), Ctuple [])
| arg ->
@ -130,20 +131,20 @@ method! select_operation op args dbg =
| Caddi | Caddv | Cadda ->
begin match args with
(* Add immediate *)
| [arg; Cconst_int n] when self#is_immediate n ->
| [arg; Cconst_int (n, _)] when self#is_immediate n ->
((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)),
[arg])
| [Cconst_int n; arg] when self#is_immediate n ->
| [Cconst_int (n, _); arg] when self#is_immediate n ->
((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)),
[arg])
(* Shift-add *)
| [arg1; Cop(Clsl, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
| [arg1; Cop(Clsl, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftadd, n)), [arg1; arg2])
| [arg1; Cop(Casr, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
| [arg1; Cop(Casr, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftadd, -n)), [arg1; arg2])
| [Cop(Clsl, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 ->
| [Cop(Clsl, [arg1; Cconst_int (n, _)], _); arg2] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftadd, n)), [arg2; arg1])
| [Cop(Casr, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 ->
| [Cop(Casr, [arg1; Cconst_int (n, _)], _); arg2] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftadd, -n)), [arg2; arg1])
(* Multiply-add *)
| [arg1; Cop(Cmuli, args2, dbg)] | [Cop(Cmuli, args2, dbg); arg1] ->
@ -162,13 +163,13 @@ method! select_operation op args dbg =
| Csubi ->
begin match args with
(* Sub immediate *)
| [arg; Cconst_int n] when self#is_immediate n ->
| [arg; Cconst_int (n, _)] when self#is_immediate n ->
((if n >= 0 then Iintop_imm(Isub, n) else Iintop_imm(Iadd, -n)),
[arg])
(* Shift-sub *)
| [arg1; Cop(Clsl, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
| [arg1; Cop(Clsl, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftsub, n)), [arg1; arg2])
| [arg1; Cop(Casr, [arg2; Cconst_int n], _)] when n > 0 && n < 64 ->
| [arg1; Cop(Casr, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 ->
(Ispecific(Ishiftarith(Ishiftsub, -n)), [arg1; arg2])
(* Multiply-sub *)
| [arg1; Cop(Cmuli, args2, dbg)] ->
@ -186,7 +187,7 @@ method! select_operation op args dbg =
(* Checkbounds *)
| Ccheckbound ->
begin match args with
| [Cop(Clsr, [arg1; Cconst_int n], _); arg2] when n > 0 && n < 64 ->
| [Cop(Clsr, [arg1; Cconst_int (n, _)], _); arg2] when n > 0 && n < 64 ->
(Ispecific(Ishiftcheckbound { shift = n; label_after_error = None; }),
[arg1; arg2])
| _ ->
@ -242,9 +243,9 @@ method! select_operation op args dbg =
super#select_operation op args dbg
method select_logical op = function
| [arg; Cconst_int n] when is_logical_immediate n ->
| [arg; Cconst_int (n, _)] when is_logical_immediate n ->
(Iintop_imm(op, n), [arg])
| [Cconst_int n; arg] when is_logical_immediate n ->
| [Cconst_int (n, _); arg] when is_logical_immediate n ->
(Iintop_imm(op, n), [arg])
| args ->
(Iintop op, args)

25
asmcomp/cmm.ml
View File

@ -159,12 +159,12 @@ and operation =
| Ccheckbound
type expression =
Cconst_int of int
| Cconst_natint of nativeint
| Cconst_float of float
| Cconst_symbol of string
| Cconst_pointer of int
| Cconst_natpointer of nativeint
Cconst_int of int * Debuginfo.t
| Cconst_natint of nativeint * Debuginfo.t
| Cconst_float of float * Debuginfo.t
| Cconst_symbol of string * Debuginfo.t
| Cconst_pointer of int * Debuginfo.t
| Cconst_natpointer of nativeint * Debuginfo.t
| Cblockheader of nativeint * Debuginfo.t
| Cvar of Backend_var.t
| Clet of Backend_var.With_provenance.t * expression * expression
@ -174,15 +174,18 @@ type expression =
| Ctuple of expression list
| Cop of operation * expression list * Debuginfo.t
| Csequence of expression * expression
| Cifthenelse of expression * expression * expression
| Cswitch of expression * int array * expression array * Debuginfo.t
| Cifthenelse of expression * Debuginfo.t * expression
* Debuginfo.t * expression * Debuginfo.t
| Cswitch of expression * int array * (expression * Debuginfo.t) array
* Debuginfo.t
| Ccatch of
rec_flag
* (int * (Backend_var.With_provenance.t * machtype) list
* expression) list
* expression * Debuginfo.t) list
* expression
| Cexit of int * expression list
| Ctrywith of expression * Backend_var.With_provenance.t * expression
* Debuginfo.t
type codegen_option =
| Reduce_code_size
@ -214,8 +217,8 @@ type phrase =
Cfunction of fundecl
| Cdata of data_item list
let ccatch (i, ids, e1, e2)=
Ccatch(Nonrecursive, [i, ids, e2], e1)
let ccatch (i, ids, e1, e2, dbg) =
Ccatch(Nonrecursive, [i, ids, e2, dbg], e1)
let reset () =
label_counter := 99

29
asmcomp/cmm.mli
View File

@ -152,17 +152,15 @@ and operation =
| Craise of raise_kind
| Ccheckbound
(** Not all cmm expressions currently have [Debuginfo.t] values attached to
them. The ones that do are those that are likely to generate code that
can fairly robustly be mapped back to a source location. In the future
it might be the case that more [Debuginfo.t] annotations are desirable. *)
(** Every basic block should have a corresponding [Debuginfo.t] for its
beginning. *)
and expression =
Cconst_int of int
| Cconst_natint of nativeint
| Cconst_float of float
| Cconst_symbol of string
| Cconst_pointer of int
| Cconst_natpointer of nativeint
Cconst_int of int * Debuginfo.t
| Cconst_natint of nativeint * Debuginfo.t
| Cconst_float of float * Debuginfo.t
| Cconst_symbol of string * Debuginfo.t
| Cconst_pointer of int * Debuginfo.t
| Cconst_natpointer of nativeint * Debuginfo.t
| Cblockheader of nativeint * Debuginfo.t
| Cvar of Backend_var.t
| Clet of Backend_var.With_provenance.t * expression * expression
@ -172,15 +170,18 @@ and expression =
| Ctuple of expression list
| Cop of operation * expression list * Debuginfo.t
| Csequence of expression * expression
| Cifthenelse of expression * expression * expression
| Cswitch of expression * int array * expression array * Debuginfo.t
| Cifthenelse of expression * Debuginfo.t * expression
* Debuginfo.t * expression * Debuginfo.t
| Cswitch of expression * int array * (expression * Debuginfo.t) array
* Debuginfo.t
| Ccatch of
rec_flag
* (int * (Backend_var.With_provenance.t * machtype) list
* expression) list
* expression * Debuginfo.t) list
* expression
| Cexit of int * expression list
| Ctrywith of expression * Backend_var.With_provenance.t * expression
* Debuginfo.t
type codegen_option =
| Reduce_code_size
@ -214,7 +215,7 @@ type phrase =
val ccatch :
int * (Backend_var.With_provenance.t * machtype) list
* expression * expression
* expression * expression * Debuginfo.t
-> expression
val reset : unit -> unit

1166
asmcomp/cmmgen.ml
View File

File diff suppressed because it is too large Load Diff

37
asmcomp/i386/selection.ml
View File

@ -32,25 +32,25 @@ type addressing_expr =
let rec select_addr exp =
match exp with
Cconst_symbol s ->
Cconst_symbol (s, _) ->
(Asymbol s, 0)
| Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], _) ->
| Cop((Caddi | Caddv | Cadda), [arg; Cconst_int (m, _)], _) ->
let (a, n) = select_addr arg in (a, n + m)
| Cop(Csubi, [arg; Cconst_int m], _) ->
| Cop(Csubi, [arg; Cconst_int (m, _)], _) ->
let (a, n) = select_addr arg in (a, n - m)
| Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], _) ->
| Cop((Caddi | Caddv | Cadda), [Cconst_int (m, _); arg], _) ->
let (a, n) = select_addr arg in (a, n + m)
| Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)], _) ->
| Cop(Clsl, [arg; Cconst_int ((1|2|3 as shift), _)], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
| _ -> (Alinear exp, 0)
end
| Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)], _) ->
| Cop(Cmuli, [arg; Cconst_int ((2|4|8 as mult), _)], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, mult), n * mult)
| _ -> (Alinear exp, 0)
end
| Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg], _) ->
| Cop(Cmuli, [Cconst_int ((2|4|8 as mult), _); arg], _) ->
begin match select_addr arg with
(Alinear e, n) -> (Ascale(e, mult), n * mult)
| _ -> (Alinear exp, 0)
@ -192,15 +192,15 @@ method select_addressing _chunk exp =
method! select_store is_assign addr exp =
match exp with
Cconst_int n ->
Cconst_int (n, _) ->
(Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
| (Cconst_natint n | Cblockheader (n, _)) ->
| (Cconst_natint (n, _) | Cblockheader (n, _)) ->
(Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
| Cconst_pointer n ->
| Cconst_pointer (n, _) ->
(Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
| Cconst_natpointer n ->
| Cconst_natpointer (n, _) ->
(Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
| Cconst_symbol s ->
| Cconst_symbol (s, _) ->
(Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple [])
| _ ->
super#select_store is_assign addr exp
@ -229,7 +229,7 @@ method! select_operation op args dbg =
(* Recognize store instructions *)
| Cstore ((Word_int | Word_val) as chunk, _) ->
begin match args with
[loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int n], _)]
[loc; Cop(Caddi, [Cop(Cload _, [loc'], _); Cconst_int (n, _)], _)]
when loc = loc' ->
let (addr, arg) = self#select_addressing chunk loc in
(Ispecific(Ioffset_loc(n, addr)), [arg])
@ -287,11 +287,12 @@ method! insert_op_debug env op dbg rs rd =
method select_push exp =
match exp with
Cconst_int n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple [])
| Cconst_natint n -> (Ispecific(Ipush_int n), Ctuple [])
| Cconst_pointer n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple [])
| Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple [])
| Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
Cconst_int (n, _) -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple [])
| Cconst_natint (n, _) -> (Ispecific(Ipush_int n), Ctuple [])
| Cconst_pointer (n, _) ->
(Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple [])
| Cconst_natpointer (n, _) -> (Ispecific(Ipush_int n), Ctuple [])
| Cconst_symbol (s, _) -> (Ispecific(Ipush_symbol s), Ctuple [])
| Cop(Cload ((Word_int | Word_val as chunk), _), [loc], _) ->
let (addr, arg) = self#select_addressing chunk loc in
(Ispecific(Ipush_load addr), arg)

10
asmcomp/power/selection.ml
View File

@ -27,11 +27,11 @@ type addressing_expr =
| Aadd of expression * expression
let rec select_addr = function
Cconst_symbol s ->
Cconst_symbol (s, _) ->
(Asymbol s, 0, Debuginfo.none)
| Cop((Caddi | Caddv | Cadda), [arg; Cconst_int m], dbg) ->
| Cop((Caddi | Caddv | Cadda), [arg; Cconst_int (m, _)], dbg) ->
let (a, n, _) = select_addr arg in (a, n + m, dbg)
| Cop((Caddi | Caddv | Cadda), [Cconst_int m; arg], dbg) ->
| Cop((Caddi | Caddv | Cadda), [Cconst_int (m, _); arg], dbg) ->
let (a, n, _) = select_addr arg in (a, n + m, dbg)
| Cop((Caddi | Caddv | Cadda), [arg1; arg2], dbg) ->
begin match (select_addr arg1, select_addr arg2) with
@ -82,9 +82,9 @@ method! select_operation op args dbg =
super#select_operation op args dbg
method select_logical op = function
[arg; Cconst_int n] when n >= 0 && n <= 0xFFFF ->
[arg; Cconst_int (n, _)] when n >= 0 && n <= 0xFFFF ->
(Iintop_imm(op, n), [arg])
| [Cconst_int n; arg] when n >= 0 && n <= 0xFFFF ->
| [Cconst_int (n, _); arg] when n >= 0 && n <= 0xFFFF ->
(Iintop_imm(op, n), [arg])
| args ->
(Iintop op, args)

20
asmcomp/printcmm.ml
View File

@ -143,16 +143,16 @@ let operation d = function
| Ccheckbound -> "checkbound" ^ Debuginfo.to_string d
let rec expr ppf = function
| Cconst_int n -> fprintf ppf "%i" n
| Cconst_natint n ->
| Cconst_int (n, _dbg) -> fprintf ppf "%i" n
| Cconst_natint (n, _dbg) ->
fprintf ppf "%s" (Nativeint.to_string n)
| Cblockheader(n, d) ->
fprintf ppf "block-hdr(%s)%s"
(Nativeint.to_string n) (Debuginfo.to_string d)
| Cconst_float n -> fprintf ppf "%F" n
| Cconst_symbol s -> fprintf ppf "\"%s\"" s
| Cconst_pointer n -> fprintf ppf "%ia" n
| Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n)
| Cconst_float (n, _dbg) -> fprintf ppf "%F" n
| Cconst_symbol (s, _dbg) -> fprintf ppf "\"%s\"" s
| Cconst_pointer (n, _dbg) -> fprintf ppf "%ia" n
| Cconst_natpointer (n, _dbg) -> fprintf ppf "%sa" (Nativeint.to_string n)
| Cvar id -> V.print ppf id
| Clet(id, def, (Clet(_, _, _) as body)) ->
let print_binding id ppf def =
@ -211,7 +211,7 @@ let rec expr ppf = function
fprintf ppf ")@]"
| Csequence(e1, e2) ->
fprintf ppf "@[<2>(seq@ %a@ %a)@]" sequence e1 sequence e2
| Cifthenelse(e1, e2, e3) ->
| Cifthenelse(e1, _e2_dbg, e2, _e3_dbg, e3, _dbg) ->
fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" expr e1 expr e2 expr e3
| Cswitch(e1, index, cases, _dbg) ->
let print_case i ppf =
@ -220,11 +220,11 @@ let rec expr ppf = function
done in
let print_cases ppf =
for i = 0 to Array.length cases - 1 do
fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i)
fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence (fst cases.(i))
done in
fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases
| Ccatch(flag, handlers, e1) ->
let print_handler ppf (i, ids, e2) =
let print_handler ppf (i, ids, e2, _dbg) =
fprintf ppf "(%d%a)@ %a"
i
(fun ppf ids ->
@ -247,7 +247,7 @@ let rec expr ppf = function
fprintf ppf "@[<2>(exit %d" i;
List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
fprintf ppf ")@]"
| Ctrywith(e1, id, e2) ->
| Ctrywith(e1, id, e2, _dbg) ->
fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]"
sequence e1 VP.print id sequence e2

8
asmcomp/s390x/selection.ml
View File

@ -30,9 +30,9 @@ type addressing_expr =
| Aadd of expression * expression
let rec select_addr = function
| Cop((Caddi | Cadda | Caddv), [arg; Cconst_int m], _) ->
| Cop((Caddi | Cadda | Caddv), [arg; Cconst_int (m, _)], _) ->
let (a, n) = select_addr arg in (a, n + m)
| Cop((Caddi | Cadda | Caddv), [Cconst_int m; arg], _) ->
| Cop((Caddi | Cadda | Caddv), [Cconst_int (m, _); arg], _) ->
let (a, n) = select_addr arg in (a, n + m)
| Cop((Caddi | Cadda | Caddv), [arg1; arg2], _) ->
begin match (select_addr arg1, select_addr arg2) with
@ -97,9 +97,9 @@ method! select_operation op args dbg =
super#select_operation op args dbg
method select_logical op lo hi = function
[arg; Cconst_int n] when n >= lo && n <= hi ->
[arg; Cconst_int (n, _)] when n >= lo && n <= hi ->
(Iintop_imm(op, n), [arg])
| [Cconst_int n; arg] when n >= lo && n <= hi ->
| [Cconst_int (n, _); arg] when n >= lo && n <= hi ->
(Iintop_imm(op, n), [arg])
| args ->
(Iintop op, args)

118
asmcomp/selectgen.ml
View File

@ -336,7 +336,7 @@ method effects_of exp =
| Cphantom_let (_var, _defining_expr, body) -> self#effects_of body
| Csequence (e1, e2) ->
EC.join (self#effects_of e1) (self#effects_of e2)
| Cifthenelse (cond, ifso, ifnot) ->
| Cifthenelse (cond, _ifso_dbg, ifso, _ifnot_dbg, ifnot, _dbg) ->
EC.join (self#effects_of cond)
(EC.join (self#effects_of ifso) (self#effects_of ifnot))
| Cop (op, args, _) ->
@ -414,7 +414,7 @@ method select_checkbound_extra_args () = []
method select_operation op args _dbg =
match (op, args) with
| (Capply _, Cconst_symbol func :: rem) ->
| (Capply _, Cconst_symbol (func, _dbg) :: rem) ->
let label_after = Cmm.new_label () in
(Icall_imm { func; label_after; }, rem)
| (Capply _, _) ->
@ -477,39 +477,39 @@ method select_operation op args _dbg =
| _ -> Misc.fatal_error "Selection.select_oper"
method private select_arith_comm op = function
[arg; Cconst_int n] when self#is_immediate n ->
[arg; Cconst_int (n, _)] when self#is_immediate n ->
(Iintop_imm(op, n), [arg])
| [arg; Cconst_pointer n] when self#is_immediate n ->
| [arg; Cconst_pointer (n, _)] when self#is_immediate n ->
(Iintop_imm(op, n), [arg])
| [Cconst_int n; arg] when self#is_immediate n ->
| [Cconst_int (n, _); arg] when self#is_immediate n ->
(Iintop_imm(op, n), [arg])
| [Cconst_pointer n; arg] when self#is_immediate n ->
| [Cconst_pointer (n, _); arg] when self#is_immediate n ->
(Iintop_imm(op, n), [arg])
| args ->
(Iintop op, args)
method private select_arith op = function
[arg; Cconst_int n] when self#is_immediate n ->
[arg; Cconst_int (n, _)] when self#is_immediate n ->
(Iintop_imm(op, n), [arg])
| [arg; Cconst_pointer n] when self#is_immediate n ->
| [arg; Cconst_pointer (n, _)] when self#is_immediate n ->
(Iintop_imm(op, n), [arg])
| args ->
(Iintop op, args)
method private select_shift op = function
[arg; Cconst_int n] when n >= 0 && n < Arch.size_int * 8 ->
[arg; Cconst_int (n, _)] when n >= 0 && n < Arch.size_int * 8 ->
(Iintop_imm(op, n), [arg])
| args ->
(Iintop op, args)
method private select_arith_comp cmp = function
[arg; Cconst_int n] when self#is_immediate n ->
[arg; Cconst_int (n, _)] when self#is_immediate n ->
(Iintop_imm(Icomp cmp, n), [arg])
| [arg; Cconst_pointer n] when self#is_immediate n ->
| [arg; Cconst_pointer (n, _)] when self#is_immediate n ->
(Iintop_imm(Icomp cmp, n), [arg])
| [Cconst_int n; arg] when self#is_immediate n ->
| [Cconst_int (n, _); arg] when self#is_immediate n ->
(Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
| [Cconst_pointer n; arg] when self#is_immediate n ->
| [Cconst_pointer (n, _); arg] when self#is_immediate n ->
(Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
| args ->
(Iintop(Icomp cmp), args)
@ -517,29 +517,29 @@ method private select_arith_comp cmp = function
(* Instruction selection for conditionals *)
method select_condition = function
Cop(Ccmpi cmp, [arg1; Cconst_int n], _) when self#is_immediate n ->
Cop(Ccmpi cmp, [arg1; Cconst_int (n, _)], _) when self#is_immediate n ->
(Iinttest_imm(Isigned cmp, n), arg1)
| Cop(Ccmpi cmp, [Cconst_int n; arg2], _) when self#is_immediate n ->
| Cop(Ccmpi cmp, [Cconst_int (n, _); arg2], _) when self#is_immediate n ->
(Iinttest_imm(Isigned(swap_integer_comparison cmp), n), arg2)
| Cop(Ccmpi cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n ->
| Cop(Ccmpi cmp, [arg1; Cconst_pointer (n, _)], _) when self#is_immediate n ->
(Iinttest_imm(Isigned cmp, n), arg1)
| Cop(Ccmpi cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n ->
| Cop(Ccmpi cmp, [Cconst_pointer (n, _); arg2], _) when self#is_immediate n ->
(Iinttest_imm(Isigned(swap_integer_comparison cmp), n), arg2)
| Cop(Ccmpi cmp, args, _) ->
(Iinttest(Isigned cmp), Ctuple args)
| Cop(Ccmpa cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n ->
| Cop(Ccmpa cmp, [arg1; Cconst_pointer (n, _)], _) when self#is_immediate n ->
(Iinttest_imm(Iunsigned cmp, n), arg1)
| Cop(Ccmpa cmp, [arg1; Cconst_int n], _) when self#is_immediate n ->
| Cop(Ccmpa cmp, [arg1; Cconst_int (n, _)], _) when self#is_immediate n ->
(Iinttest_imm(Iunsigned cmp, n), arg1)
| Cop(Ccmpa cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n ->
| Cop(Ccmpa cmp, [Cconst_pointer (n, _); arg2], _) when self#is_immediate n ->
(Iinttest_imm(Iunsigned(swap_integer_comparison cmp), n), arg2)
| Cop(Ccmpa cmp, [Cconst_int n; arg2], _) when self#is_immediate n ->
| Cop(Ccmpa cmp, [Cconst_int (n, _); arg2], _) when self#is_immediate n ->
(Iinttest_imm(Iunsigned(swap_integer_comparison cmp), n), arg2)
| Cop(Ccmpa cmp, args, _) ->
(Iinttest(Iunsigned cmp), Ctuple args)
| Cop(Ccmpf cmp, args, _) ->
(Ifloattest cmp, Ctuple args)
| Cop(Cand, [arg; Cconst_int 1], _) ->
| Cop(Cand, [arg; Cconst_int (1, _)], _) ->
(Ioddtest, arg)
| arg ->
(Itruetest, arg)
@ -629,7 +629,7 @@ method emit_blockheader env n _dbg =
let r = self#regs_for typ_int in
Some(self#insert_op env (Iconst_int n) [||] r)
method about_to_emit_call _env _insn _arg = None
method about_to_emit_call _env _insn _arg _dbg = None
(* Prior to a function call, update the Spacetime node hole pointer hard
register. *)
@ -644,22 +644,22 @@ method private maybe_emit_spacetime_move env ~spacetime_reg =
method emit_expr (env:environment) exp =
match exp with
Cconst_int n ->
Cconst_int (n, _dbg) ->
let r = self#regs_for typ_int in
Some(self#insert_op env (Iconst_int(Nativeint.of_int n)) [||] r)
| Cconst_natint n ->
| Cconst_natint (n, _dbg) ->
let r = self#regs_for typ_int in
Some(self#insert_op env (Iconst_int n) [||] r)
| Cconst_float n ->
| Cconst_float (n, _dbg) ->
let r = self#regs_for typ_float in
Some(self#insert_op env (Iconst_float (Int64.bits_of_float n)) [||] r)
| Cconst_symbol n ->
| Cconst_symbol (n, _dbg) ->
let r = self#regs_for typ_val in
Some(self#insert_op env (Iconst_symbol n) [||] r)
| Cconst_pointer n ->
| Cconst_pointer (n, _dbg) ->
let r = self#regs_for typ_val in (* integer as Caml value *)
Some(self#insert_op env (Iconst_int(Nativeint.of_int n)) [||] r)
| Cconst_natpointer n ->
| Cconst_natpointer (n, _dbg) ->
let r = self#regs_for typ_val in (* integer as Caml value *)
Some(self#insert_op env (Iconst_int n) [||] r)
| Cblockheader(n, dbg) ->
@ -705,8 +705,12 @@ method emit_expr (env:environment) exp =
self#insert_debug env (Iraise k) dbg rd [||];
None
end
| Cop(Ccmpf _, _, _) ->
self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0))
| Cop(Ccmpf _, _, dbg) ->
self#emit_expr env
(Cifthenelse (exp,
dbg, Cconst_int (1, dbg),
dbg, Cconst_int (0, dbg),
dbg))
| Cop(op, args, dbg) ->
begin match self#emit_parts_list env args with
None -> None
@ -721,7 +725,7 @@ method emit_expr (env:environment) exp =
let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
let loc_res = Proc.loc_results rd in
let spacetime_reg =
self#about_to_emit_call env (Iop new_op) [| r1.(0) |]
self#about_to_emit_call env (Iop new_op) [| r1.(0) |] dbg
in
self#insert_move_args env rarg loc_arg stack_ofs;
self#maybe_emit_spacetime_move env ~spacetime_reg;
@ -735,7 +739,7 @@ method emit_expr (env:environment) exp =
let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
let loc_res = Proc.loc_results rd in
let spacetime_reg =
self#about_to_emit_call env (Iop new_op) [| |]
self#about_to_emit_call env (Iop new_op) [| |] dbg
in
self#insert_move_args env r1 loc_arg stack_ofs;
self#maybe_emit_spacetime_move env ~spacetime_reg;
@ -744,7 +748,7 @@ method emit_expr (env:environment) exp =
Some rd
| Iextcall _ ->
let spacetime_reg =
self#about_to_emit_call env (Iop new_op) [| |]
self#about_to_emit_call env (Iop new_op) [| |] dbg
in
let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in
self#maybe_emit_spacetime_move env ~spacetime_reg;
@ -774,7 +778,7 @@ method emit_expr (env:environment) exp =
None -> None
| Some _ -> self#emit_expr env e2
end
| Cifthenelse(econd, eif, eelse) ->
| Cifthenelse(econd, _ifso_dbg, eif, _ifnot_dbg, eelse, _dbg) ->
let (cond, earg) = self#select_condition econd in
begin match self#emit_expr env earg with
None -> None
@ -790,7 +794,9 @@ method emit_expr (env:environment) exp =
begin match self#emit_expr env esel with
None -> None
| Some rsel ->
let rscases = Array.map (self#emit_sequence env) ecases in
let rscases =
Array.map (fun (case, _dbg) -> self#emit_sequence env case) ecases
in
let r = join_array env rscases in
self#insert env (Iswitch(index,
Array.map (fun (_, s) -> s#extract) rscases))
@ -801,25 +807,25 @@ method emit_expr (env:environment) exp =
self#emit_expr env e1
| Ccatch(rec_flag, handlers, body) ->
let handlers =
List.map (fun (nfail, ids, e2) ->
List.map (fun (nfail, ids, e2, dbg) ->
let rs =
List.map
(fun (id, typ) ->
let r = self#regs_for typ in name_regs id r; r)
ids in
(nfail, ids, rs, e2))
(nfail, ids, rs, e2, dbg))
handlers
in
let env =
(* Since the handlers may be recursive, and called from the body,
the same environment is used for translating both the handlers and
the body. *)
List.fold_left (fun env (nfail, _ids, rs, _e2) ->
List.fold_left (fun env (nfail, _ids, rs, _e2, _dbg) ->
env_add_static_exception nfail rs env)
env handlers
in
let (r_body, s_body) = self#emit_sequence env body in
let translate_one_handler (nfail, ids, rs, e2) =
let translate_one_handler (nfail, ids, rs, e2, _dbg) =
assert(List.length ids = List.length rs);
let new_env =
List.fold_left (fun env ((id, _typ), r) -> env_add id r env)
@ -856,7 +862,7 @@ method emit_expr (env:environment) exp =
self#insert env (Iexit nfail) [||] [||];
None
end
| Ctrywith(e1, v, e2) ->
| Ctrywith(e1, v, e2, _dbg) ->
let (r1, s1) = self#emit_sequence env e1 in
let rv = self#regs_for typ_val in
let (r2, s2) = self#emit_sequence (env_add v rv env) e2 in
@ -1058,7 +1064,7 @@ method emit_tail (env:environment) exp =
if stack_ofs = 0 then begin
let call = Iop (Itailcall_ind { label_after; }) in
let spacetime_reg =
self#about_to_emit_call env call [| r1.(0) |]
self#about_to_emit_call env call [| r1.(0) |] dbg
in
self#insert_moves env rarg loc_arg;
self#maybe_emit_spacetime_move env ~spacetime_reg;
@ -1068,7 +1074,7 @@ method emit_tail (env:environment) exp =
let rd = self#regs_for ty in
let loc_res = Proc.loc_results rd in
let spacetime_reg =
self#about_to_emit_call env (Iop new_op) [| r1.(0) |]
self#about_to_emit_call env (Iop new_op) [| r1.(0) |] dbg
in
self#insert_move_args env rarg loc_arg stack_ofs;
self#maybe_emit_spacetime_move env ~spacetime_reg;
@ -1083,7 +1089,7 @@ method emit_tail (env:environment) exp =
if stack_ofs = 0 then begin
let call = Iop (Itailcall_imm { func; label_after; }) in
let spacetime_reg =
self#about_to_emit_call env call [| |]
self#about_to_emit_call env call [| |] dbg
in
self#insert_moves env r1 loc_arg;
self#maybe_emit_spacetime_move env ~spacetime_reg;
@ -1092,7 +1098,7 @@ method emit_tail (env:environment) exp =
let call = Iop (Itailcall_imm { func; label_after; }) in
let loc_arg' = Proc.loc_parameters r1 in
let spacetime_reg =
self#about_to_emit_call env call [| |]
self#about_to_emit_call env call [| |] dbg
in
self#insert_moves env r1 loc_arg';
self#maybe_emit_spacetime_move env ~spacetime_reg;
@ -1101,7 +1107,7 @@ method emit_tail (env:environment) exp =
let rd = self#regs_for ty in
let loc_res = Proc.loc_results rd in
let spacetime_reg =
self#about_to_emit_call env (Iop new_op) [| |]
self#about_to_emit_call env (Iop new_op) [| |] dbg
in
self#insert_move_args env r1 loc_arg stack_ofs;
self#maybe_emit_spacetime_move env ~spacetime_reg;
@ -1116,7 +1122,7 @@ method emit_tail (env:environment) exp =
None -> ()
| Some _ -> self#emit_tail env e2
end
| Cifthenelse(econd, eif, eelse) ->
| Cifthenelse(econd, _ifso_dbg, eif, _ifnot_dbg, eelse, _dbg) ->
let (cond, earg) = self#select_condition econd in
begin match self#emit_expr env earg with
None -> ()
@ -1130,28 +1136,30 @@ method emit_tail (env:environment) exp =
begin match self#emit_expr env esel with
None -> ()
| Some rsel ->
self#insert env
(Iswitch(index, Array.map (self#emit_tail_sequence env) ecases))
rsel [||]
let cases =
Array.map (fun (case, _dbg) -> self#emit_tail_sequence env case)
ecases
in
self#insert env (Iswitch (index, cases)) rsel [||]
end
| Ccatch(_, [], e1) ->
self#emit_tail env e1
| Ccatch(rec_flag, handlers, e1) ->
let handlers =
List.map (fun (nfail, ids, e2) ->
List.map (fun (nfail, ids, e2, dbg) ->
let rs =
List.map
(fun (id, typ) ->
let r = self#regs_for typ in name_regs id r; r)
ids in
(nfail, ids, rs, e2))
(nfail, ids, rs, e2, dbg))
handlers in
let env =
List.fold_left (fun env (nfail, _ids, rs, _e2) ->
List.fold_left (fun env (nfail, _ids, rs, _e2, _dbg) ->
env_add_static_exception nfail rs env)
env handlers in
let s_body = self#emit_tail_sequence env e1 in
let aux (nfail, ids, rs, e2) =
let aux (nfail, ids, rs, e2, _dbg) =
assert(List.length ids = List.length rs);
let new_env =
List.fold_left
@ -1161,7 +1169,7 @@ method emit_tail (env:environment) exp =
in
self#insert env (Icatch(rec_flag, List.map aux handlers, s_body))
[||] [||]
| Ctrywith(e1, v, e2) ->
| Ctrywith(e1, v, e2, _dbg) ->
let (opt_r1, s1) = self#emit_sequence env e1 in
let rv = self#regs_for typ_val in
let s2 = self#emit_tail_sequence (env_add v rv env) e2 in

1
asmcomp/selectgen.mli
View File

@ -168,6 +168,7 @@ class virtual selector_generic : object
: environment
-> Mach.instruction_desc
-> Reg.t array
-> Debuginfo.t
-> Reg.t array option
method initial_env : unit -> environment
method insert_prologue

94
asmcomp/spacetime_profiling.ml
View File

@ -4,7 +4,7 @@
(* *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2015--2017 Jane Street Group LLC *)
(* Copyright 2015--2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
@ -12,6 +12,8 @@
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-30-40-41-42"]
module V = Backend_var
module VP = Backend_var.With_provenance
@ -23,11 +25,17 @@ let index_within_node = ref node_num_header_words
arch.ml.) *)
let spacetime_node = ref (lazy (Cmm.Cvar (V.create_local "dummy")))
let spacetime_node_ident = ref (lazy (V.create_local "dummy"))
let current_function_label = ref ""
let current_function_label = ref None
let direct_tail_call_point_indexes = ref []
let reverse_shape = ref ([] : Mach.spacetime_shape)
(* CR-someday mshinwell: This code could be updated to use [placeholder_dbg] as
in [Cmmgen]. *)
let cconst_int i = Cmm.Cconst_int (i, Debuginfo.none)
let cconst_natint i = Cmm.Cconst_natint (i, Debuginfo.none)
let cconst_symbol s = Cmm.Cconst_symbol (s, Debuginfo.none)
let something_was_instrumented () =
!index_within_node > node_num_header_words
@ -54,16 +62,15 @@ let reset ~spacetime_node_ident:ident ~function_label =
spacetime_node := lazy (Cmm.Cvar ident);
spacetime_node_ident := lazy ident;
direct_tail_call_point_indexes := [];
current_function_label := function_label;
current_function_label := Some function_label;
reverse_shape := []
let code_for_function_prologue ~function_name ~node_hole =
let code_for_function_prologue ~function_name ~fun_dbg:dbg ~node_hole =
let node = V.create_local "node" in
let new_node = V.create_local "new_node" in
let must_allocate_node = V.create_local "must_allocate_node" in
let is_new_node = V.create_local "is_new_node" in
let no_tail_calls = List.length !direct_tail_call_point_indexes < 1 in
let dbg = Debuginfo.none in
let open Cmm in
let initialize_direct_tail_call_points_and_return_node =
let new_node_encoded = V.create_local "new_node_encoded" in
@ -77,7 +84,7 @@ let code_for_function_prologue ~function_name ~node_hole =
let offset_in_bytes = index * Arch.size_addr in
Csequence (
Cop (Cstore (Word_int, Lambda.Assignment),
[Cop (Caddi, [Cvar new_node; Cconst_int offset_in_bytes], dbg);
[Cop (Caddi, [Cvar new_node; cconst_int offset_in_bytes], dbg);
Cvar new_node_encoded], dbg),
init_code))
(Cvar new_node)
@ -88,22 +95,24 @@ let code_for_function_prologue ~function_name ~node_hole =
| _ ->
Clet (VP.create new_node_encoded,
(* Cf. [Encode_tail_caller_node] in the runtime. *)
Cop (Cor, [Cvar new_node; Cconst_int 1], dbg),
Cop (Cor, [Cvar new_node; cconst_int 1], dbg),
body)
in
let pc = V.create_local "pc" in
Clet (VP.create node,
Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg),
Clet (VP.create must_allocate_node,
Cop (Cand, [Cvar node; Cconst_int 1], dbg),
Cop (Cand, [Cvar node; cconst_int 1], dbg),
Cifthenelse (
Cop (Ccmpi Cne, [Cvar must_allocate_node; Cconst_int 1], dbg),
Cop (Ccmpi Cne, [Cvar must_allocate_node; cconst_int 1], dbg),
dbg,
Cvar node,
dbg,
Clet (VP.create is_new_node,
Clet (VP.create pc, Cconst_symbol function_name,
Clet (VP.create pc, cconst_symbol function_name,
Cop (Cextcall ("caml_spacetime_allocate_node",
[| Int |], false, None),
[Cconst_int (1 (* header *) + !index_within_node);
[cconst_int (1 (* header *) + !index_within_node);
Cvar pc;
Cvar node_hole;
],
@ -113,9 +122,13 @@ let code_for_function_prologue ~function_name ~node_hole =
if no_tail_calls then Cvar new_node
else
Cifthenelse (
Cop (Ccmpi Ceq, [Cvar is_new_node; Cconst_int 0], dbg),
Cop (Ccmpi Ceq, [Cvar is_new_node; cconst_int 0], dbg),
dbg,
Cvar new_node,
initialize_direct_tail_call_points_and_return_node))))))
dbg,
initialize_direct_tail_call_points_and_return_node,
dbg))),
dbg)))
let code_for_blockheader ~value's_header ~node ~dbg =
let num_words = Nativeint.shift_right_logical value's_header 10 in
@ -141,7 +154,7 @@ let code_for_blockheader ~value's_header ~node ~dbg =
Cop (Cextcall ("caml_spacetime_generate_profinfo", [| Int |],
false, Some label),
[Cvar address_of_profinfo;
Cconst_int (index_within_node + 1)],
cconst_int (index_within_node + 1)],
dbg)
in
(* Check if we have already allocated a profinfo value for this allocation
@ -150,30 +163,33 @@ let code_for_blockheader ~value's_header ~node ~dbg =
Clet (VP.create address_of_profinfo,
Cop (Caddi, [
Cvar node;
Cconst_int offset_into_node;
cconst_int offset_into_node;
], dbg),
Clet (VP.create existing_profinfo,
Cop (Cload (Word_int, Asttypes.Mutable), [Cvar address_of_profinfo],
dbg),
Clet (VP.create profinfo,
Cifthenelse (
Cop (Ccmpi Cne, [Cvar existing_profinfo; Cconst_int 1 (* () *)], dbg),
Cop (Ccmpi Cne, [Cvar existing_profinfo; cconst_int 1 (* () *)], dbg),
dbg,
Cvar existing_profinfo,
generate_new_profinfo),
dbg,
generate_new_profinfo,
dbg),
Clet (VP.create existing_count,
Cop (Cload (Word_int, Asttypes.Mutable), [
Cop (Caddi,
[Cvar address_of_profinfo; Cconst_int Arch.size_addr], dbg)
[Cvar address_of_profinfo; cconst_int Arch.size_addr], dbg)
], dbg),
Csequence (
Cop (Cstore (Word_int, Lambda.Assignment),
[Cop (Caddi,
[Cvar address_of_profinfo; Cconst_int Arch.size_addr], dbg);
[Cvar address_of_profinfo; cconst_int Arch.size_addr], dbg);
Cop (Caddi, [
Cvar existing_count;
(* N.B. "*2" since the count is an OCaml integer.
The "1 +" is to count the value's header. *)
Cconst_int (2 * (1 + Nativeint.to_int num_words));
cconst_int (2 * (1 + Nativeint.to_int num_words));
], dbg);
], dbg),
(* [profinfo] looks like a black [Infix_tag] header. Instead of
@ -188,18 +204,22 @@ let code_for_blockheader ~value's_header ~node ~dbg =
(* The following is the [Infix_offset_val], in words. *)
(Nativeint.of_int (index_within_node + 1)) 10))
in
Cop (Cxor, [Cvar profinfo; Cconst_natint value's_header], dbg))))))
Cop (Cxor, [Cvar profinfo; cconst_natint value's_header], dbg))))))
type callee =
| Direct of string
| Indirect of Cmm.expression
let code_for_call ~node ~callee ~is_tail ~label =
let code_for_call ~node ~callee ~is_tail ~label dbg =
(* We treat self recursive calls as tail calls to avoid blow-ups in the
graph. *)
let is_self_recursive_call =
match callee with
| Direct callee -> callee = !current_function_label
| Direct callee ->
begin match !current_function_label with
| None -> Misc.fatal_error "[current_function_label] not set"
| Some label -> String.equal callee label
end
| Indirect _ -> false
in
let is_tail = is_tail || is_self_recursive_call in
@ -221,10 +241,9 @@ let code_for_call ~node ~callee ~is_tail ~label =
| Direct _ | Indirect _ -> ()
end;
let place_within_node = V.create_local "place_within_node" in
let dbg = Debuginfo.none in
let open Cmm in
Clet (VP.create place_within_node,
Cop (Caddi, [node; Cconst_int (index_within_node * Arch.size_addr)], dbg),
Cop (Caddi, [node; cconst_int (index_within_node * Arch.size_addr)], dbg),
(* The following code returns the address that is to be moved into the
(hard) node hole pointer register immediately before the call.
(That move is inserted in [Selectgen].) *)
@ -234,14 +253,14 @@ let code_for_call ~node ~callee ~is_tail ~label =
let count_addr = V.create_local "call_count_addr" in
let count = V.create_local "call_count" in
Clet (VP.create count_addr,
Cop (Caddi, [Cvar place_within_node; Cconst_int Arch.size_addr], dbg),
Cop (Caddi, [Cvar place_within_node; cconst_int Arch.size_addr], dbg),
Clet (VP.create count,
Cop (Cload (Word_int, Asttypes.Mutable), [Cvar count_addr], dbg),
Csequence (
Cop (Cstore (Word_int, Lambda.Assignment),
(* Adding 2 really means adding 1; the count is encoded
as an OCaml integer. *)
[Cvar count_addr; Cop (Caddi, [Cvar count; Cconst_int 2], dbg)],
[Cvar count_addr; Cop (Caddi, [Cvar count; cconst_int 2], dbg)],
dbg),
Cvar place_within_node)))
end else begin
@ -250,7 +269,7 @@ let code_for_call ~node ~callee ~is_tail ~label =
| Indirect callee ->
let caller_node =
if is_tail then node
else Cconst_int 1 (* [Val_unit] *)
else cconst_int 1 (* [Val_unit] *)
in
Cop (Cextcall ("caml_spacetime_indirect_node_hole_ptr",
[| Int |], false, None),
@ -264,20 +283,21 @@ class virtual instruction_selection = object (self)
instrumentation... *)
val mutable disable_instrumentation = false
method private instrument_direct_call ~env ~func ~is_tail ~label_after =
method private instrument_direct_call ~env ~func ~is_tail ~label_after dbg =
let instrumentation =
code_for_call
~node:(Lazy.force !spacetime_node)
~callee:(Direct func)
~is_tail
~label:label_after
dbg
in
match self#emit_expr env instrumentation with
| None -> assert false
| Some reg -> Some reg
method private instrument_indirect_call ~env ~callee ~is_tail
~label_after =
~label_after dbg =
(* [callee] is a pseudoregister, so we have to bind it in the environment
and reference the variable to which it is bound. *)
let callee_ident = V.create_local "callee" in
@ -288,6 +308,7 @@ class virtual instruction_selection = object (self)
~callee:(Indirect (Cmm.Cvar callee_ident))
~is_tail
~label:label_after
dbg
in
match self#emit_expr env instrumentation with
| None -> assert false
@ -296,29 +317,29 @@ class virtual instruction_selection = object (self)
method private can_instrument () =
Config.spacetime && not disable_instrumentation
method! about_to_emit_call env desc arg =
method! about_to_emit_call env desc arg dbg =
if not (self#can_instrument ()) then None
else
let module M = Mach in
match desc with
| M.Iop (M.Icall_imm { func; label_after; }) ->
assert (Array.length arg = 0);
self#instrument_direct_call ~env ~func ~is_tail:false ~label_after
self#instrument_direct_call ~env ~func ~is_tail:false ~label_after dbg
| M.Iop (M.Icall_ind { label_after; }) ->
assert (Array.length arg = 1);
self#instrument_indirect_call ~env ~callee:arg.(0)
~is_tail:false ~label_after
~is_tail:false ~label_after dbg
| M.Iop (M.Itailcall_imm { func; label_after; }) ->
assert (Array.length arg = 0);
self#instrument_direct_call ~env ~func ~is_tail:true ~label_after
self#instrument_direct_call ~env ~func ~is_tail:true ~label_after dbg
| M.Iop (M.Itailcall_ind { label_after; }) ->
assert (Array.length arg = 1);
self#instrument_indirect_call ~env ~callee:arg.(0)
~is_tail:true ~label_after
~is_tail:true ~label_after dbg
| M.Iop (M.Iextcall { func; alloc = true; label_after; }) ->
(* N.B. No need to instrument "noalloc" external calls. *)
assert (Array.length arg = 0);
self#instrument_direct_call ~env ~func ~is_tail:false ~label_after
self#instrument_direct_call ~env ~func ~is_tail:false ~label_after dbg
| _ -> None
method private instrument_blockheader ~env ~value's_header ~dbg =
@ -336,6 +357,7 @@ class virtual instruction_selection = object (self)
if something_was_instrumented () then begin
let prologue_cmm =
code_for_function_prologue ~function_name:f.Cmm.fun_name ~node_hole
~fun_dbg:f.Cmm.fun_dbg
in
disable_instrumentation <- true;
let node_temp_reg =

12
asmcomp/strmatch.ml
View File

@ -77,7 +77,7 @@ module Make(I:I) = struct
let dbg = Debuginfo.none in
let cell =
Cop(Cload (Word_int, Asttypes.Mutable),
[Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)], dbg)],
[Cop(Cadda,[str;Cconst_int(Arch.size_int*ind, dbg)], dbg)],
dbg) in
Clet(id, cell, body)
@ -88,9 +88,9 @@ module Make(I:I) = struct
let mk_cmp_gen cmp_op id nat ifso ifnot =
let dbg = Debuginfo.none in
let test =
Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ], dbg)
Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer (nat, dbg) ], dbg)
in
Cifthenelse (test, ifso, ifnot)
Cifthenelse (test, dbg, ifso, dbg, ifnot, dbg)
let mk_lt = mk_cmp_gen Clt
let mk_eq = mk_cmp_gen Ceq
@ -377,11 +377,11 @@ module Make(I:I) = struct
(* Module entry point *)
let catch arg k = match arg with
let catch dbg arg k = match arg with
| Cexit (_e,[]) -> k arg
| _ ->
let e = next_raise_count () in
ccatch (e,[],k (Cexit (e,[])),arg)
ccatch (e,[],k (Cexit (e,[])),arg,dbg)
let compile dbg str default cases =
(* We do not attempt to really optimise default=None *)
@ -393,6 +393,6 @@ module Make(I:I) = struct
List.rev_map
(fun (s,act) -> pat_of_string s,act)
cases in
catch default (fun default -> top_compile dbg str default cases)
catch dbg default (fun default -> top_compile dbg str default cases)
end

52
testsuite/tools/parsecmm.mly
View File

@ -29,22 +29,27 @@ let rec make_letdef def body =
let make_switch n selector caselist =
let index = Array.make n 0 in
let casev = Array.of_list caselist in
let actv = Array.make (Array.length casev) (Cexit(0,[])) in
let dbg = Debuginfo.none in
let actv = Array.make (Array.length casev) (Cexit(0,[]), dbg) in
for i = 0 to Array.length casev - 1 do
let (posl, e) = casev.(i) in
List.iter (fun pos -> index.(pos) <- i) posl;
actv.(i) <- e
actv.(i) <- (e, dbg)
done;
Cswitch(selector, index, actv, Debuginfo.none)
Cswitch(selector, index, actv, dbg)
let access_array base numelt size =
match numelt with
Cconst_int 0 -> base
| Cconst_int n -> Cop(Cadda, [base; Cconst_int(n * size)], Debuginfo.none)
| _ -> Cop(Cadda, [base;
Cop(Clsl, [numelt; Cconst_int(Misc.log2 size)],
Debuginfo.none)],
Debuginfo.none)
Cconst_int (0, _) -> base
| Cconst_int (n, _) ->
let dbg = Debuginfo.none in
Cop(Cadda, [base; Cconst_int(n * size, dbg)], dbg)
| _ ->
let dbg = Debuginfo.none in
Cop(Cadda, [base;
Cop(Clsl, [numelt; Cconst_int(Misc.log2 size, dbg)],
dbg)],
dbg)
%}
@ -195,10 +200,10 @@ componentlist:
| componentlist STAR component { $3 :: $1 }
;
expr:
INTCONST { Cconst_int $1 }
| FLOATCONST { Cconst_float (float_of_string $1) }
| STRING { Cconst_symbol $1 }
| POINTER { Cconst_pointer $1 }
INTCONST { Cconst_int ($1, debuginfo ()) }
| FLOATCONST { Cconst_float (float_of_string $1, debuginfo ()) }
| STRING { Cconst_symbol ($1, debuginfo ()) }
| POINTER { Cconst_pointer ($1, debuginfo ()) }
| IDENT { Cvar(find_ident $1) }
| LBRACKET RBRACKET { Ctuple [] }
| LPAREN LET letdef sequence RPAREN { make_letdef $3 $4 }
@ -213,26 +218,29 @@ expr:
| LPAREN unaryop expr RPAREN { Cop($2, [$3], debuginfo ()) }
| LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4], debuginfo ()) }
| LPAREN SEQ sequence RPAREN { $3 }
| LPAREN IF expr expr expr RPAREN { Cifthenelse($3, $4, $5) }
| LPAREN IF expr expr expr RPAREN
{ Cifthenelse($3, debuginfo (), $4, debuginfo (), $5, debuginfo ()) }
| LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 }
| LPAREN WHILE expr sequence RPAREN
{ let body =
match $3 with
Cconst_int x when x <> 0 -> $4
| _ -> Cifthenelse($3, $4, (Cexit(0,[]))) in
Cconst_int (x, _) when x <> 0 -> $4
| _ -> Cifthenelse($3, debuginfo (), $4, debuginfo (), (Cexit(0,[])),
debuginfo ()) in
Ccatch(Nonrecursive, [0, [],
Ccatch(Recursive, [1, [], Csequence(body, Cexit(1, []))],
Cexit(1, []))], Ctuple []) }
Ccatch(Recursive,
[1, [], Csequence(body, Cexit(1, [])), debuginfo ()],
Cexit(1, [])), debuginfo ()], Ctuple []) }
| LPAREN EXIT IDENT exprlist RPAREN
{ Cexit(find_label $3, List.rev $4) }
| LPAREN CATCH sequence WITH catch_handlers RPAREN
{ let handlers = $5 in
List.iter (fun (_, l, _) ->
List.iter (fun (_, l, _, _) ->
List.iter (fun (x, _) -> unbind_ident x) l) handlers;
Ccatch(Recursive, handlers, $3) }
| EXIT { Cexit(0,[]) }
| LPAREN TRY sequence WITH bind_ident sequence RPAREN
{ unbind_ident $5; Ctrywith($3, $5, $6) }
{ unbind_ident $5; Ctrywith($3, $5, $6, debuginfo ()) }
| LPAREN VAL expr expr RPAREN
{ Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr],
debuginfo ()) }
@ -378,9 +386,9 @@ catch_handlers:
catch_handler:
| sequence
{ 0, [], $1 }
{ 0, [], $1, debuginfo () }
| LPAREN IDENT params RPAREN sequence
{ find_label $2, $3, $5 }
{ find_label $2, $3, $5, debuginfo () }
location:
/**/ { None }