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

More warnings when compiling the compiler.

master
alainfrisch 2016-03-09 11:40:16 +01:00
parent f4a29c6ca2
commit 502e4f9336
125 changed files with 1084 additions and 1125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile.shared
View File

@ -22,7 +22,7 @@ include stdlib/StdlibModules
CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot -use-prims byterun/primitives
CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink
COMPFLAGS=-strict-sequence -principal -w +33..39+48+50 -warn-error A \
COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-41-42-44-45-48 -warn-error A \
-bin-annot -safe-string -strict-formats $(INCLUDES)
LINKFLAGS=

4
asmcomp/CSEgen.ml
View File

@ -197,7 +197,7 @@ let remove_load_numbering n =
let kill_addr_regs n =
{ n with num_reg =
Reg.Map.filter (fun r n -> r.Reg.typ <> Cmm.Addr) n.num_reg }
Reg.Map.filter (fun r _n -> r.Reg.typ <> Cmm.Addr) n.num_reg }
(* Prepend a set of moves before [i] to assign [srcs] to [dsts]. *)
@ -207,7 +207,7 @@ let insert_move srcs dsts i =
match Array.length srcs with
| 0 -> i
| 1 -> instr_cons (Iop Imove) srcs dsts i
| l -> (* Parallel move: first copy srcs into tmps one by one,
| _ -> (* Parallel move: first copy srcs into tmps one by one,
then copy tmps into dsts one by one *)
let tmps = Reg.createv_like srcs in
let i1 = array_fold2 insert_single_move i tmps dsts in

2
asmcomp/amd64/CSE.ml
View File

@ -19,7 +19,7 @@ open Arch
open Mach
open CSEgen
class cse = object (self)
class cse = object
inherit cse_generic as super

10
asmcomp/amd64/arch.ml
View File

@ -73,11 +73,11 @@ let offset_addressing addr delta =
| Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta)
let num_args_addressing = function
Ibased(s, n) -> 0
| Iindexed n -> 1
| Iindexed2 n -> 2
| Iscaled(scale, n) -> 1
| Iindexed2scaled(scale, n) -> 2
Ibased _ -> 0
| Iindexed _ -> 1
| Iindexed2 _ -> 2
| Iscaled _ -> 1
| Iindexed2scaled _ -> 2
(* Printing operations and addressing modes *)

18
asmcomp/amd64/proc.ml
View File

@ -31,13 +31,6 @@ let win64 =
| "win64" | "mingw64" | "cygwin" -> true
| _ -> false
(* Which asm conventions to use *)
let masm =
match Config.ccomp_type with
| "msvc" -> true
| _ -> false
(* Registers available for register allocation *)
(* Register map:
@ -138,7 +131,6 @@ let phys_reg n =
if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
let rax = phys_reg 0
let rcx = phys_reg 5
let rdx = phys_reg 4
let rbp = phys_reg 12
let rxmm15 = phys_reg 115
@ -181,14 +173,14 @@ let calling_conventions first_int last_int first_float last_float make_stack
let incoming ofs = Incoming ofs
let outgoing ofs = Outgoing ofs
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
let loc_arguments arg =
calling_conventions 0 9 100 109 outgoing arg
let loc_parameters arg =
let (loc, ofs) = calling_conventions 0 9 100 109 incoming arg in loc
let (loc, _ofs) = calling_conventions 0 9 100 109 incoming arg in loc
let loc_results res =
let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc
(* C calling conventions under Unix:
first integer args in rdi, rsi, rdx, rcx, r8, r9
@ -204,7 +196,7 @@ let loc_results res =
Return value in rax or xmm0. *)
let loc_external_results res =
let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc
let unix_loc_external_arguments arg =
calling_conventions 2 7 100 107 outgoing arg
@ -253,7 +245,7 @@ let loc_exn_bucket = rax
(* Volatile registers: none *)
let regs_are_volatile rs = false
let regs_are_volatile _rs = false
(* Registers destroyed by operations *)

2
asmcomp/amd64/reload.ml
View File

@ -103,7 +103,7 @@ method! reload_operation op arg res =
method! reload_test tst arg =
match tst with
Iinttest cmp ->
Iinttest _ ->
(* One of the two arguments can reside on stack *)
if stackp arg.(0) && stackp arg.(1)
then [| self#makereg arg.(0); arg.(1) |]

4
asmcomp/amd64/selection.ml
View File

@ -138,7 +138,7 @@ method! is_simple_expr e =
| _ ->
super#is_simple_expr e
method select_addressing chunk exp =
method select_addressing _chunk exp =
let (a, d) = select_addr exp in
(* PR#4625: displacement must be a signed 32-bit immediate *)
if d < -0x8000_0000 || d > 0x7FFF_FFFF
@ -175,7 +175,7 @@ method! select_operation op args =
(* Recognize the LEA instruction *)
Caddi | Caddv | Cadda | Csubi ->
begin match self#select_addressing Word_int (Cop(op, args)) with
(Iindexed d, _) -> super#select_operation op args
(Iindexed _, _)
| (Iindexed2 0, _) -> super#select_operation op args
| (addr, arg) -> (Ispecific(Ilea addr), [arg])
end

2
asmcomp/arm/CSE.ml
View File

@ -19,7 +19,7 @@ open Arch
open Mach
open CSEgen
class cse = object (self)
class cse = object
inherit cse_generic as super

2
asmcomp/arm/arch.ml
View File

@ -157,7 +157,7 @@ let identity_addressing = Iindexed 0
let offset_addressing (Iindexed n) delta = Iindexed(n + delta)
let num_args_addressing (Iindexed n) = 1
let num_args_addressing (Iindexed _) = 1
(* Printing operations and addressing modes *)

4
asmcomp/arm/proc.ml
View File

@ -175,7 +175,7 @@ let calling_conventions first_int last_int first_float last_float make_stack
let incoming ofs = Incoming ofs
let outgoing ofs = Outgoing ofs
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
(* OCaml calling convention:
first integer args in r0...r7
@ -224,7 +224,7 @@ let loc_exn_bucket = phys_reg 0
(* Volatile registers: none *)
let regs_are_volatile rs = false
let regs_are_volatile _rs = false
(* Registers destroyed by operations *)

2
asmcomp/arm/scheduling.ml
View File

@ -19,7 +19,7 @@ open Mach
(* Instruction scheduling for the ARM *)
class scheduler = object(self)
class scheduler = object
inherit Schedgen.scheduler_generic as super

1
asmcomp/arm/selection.ml
View File

@ -53,7 +53,6 @@ exception Use_default
let r1 = phys_reg 1
let r6 = phys_reg 6
let r7 = phys_reg 7
let r12 = phys_reg 8
let pseudoregs_for_operation op arg res =
match op with

2
asmcomp/arm64/CSE.ml
View File

@ -19,7 +19,7 @@ open Arch
open Mach
open CSEgen
class cse = object (self)
class cse = object
inherit cse_generic as super

6
asmcomp/arm64/arch.ml
View File

@ -15,8 +15,6 @@
(* *)
(**************************************************************************)
let command_line_options = []
(* Specific operations for the ARM processor, 64-bit mode *)
open Format
@ -81,8 +79,8 @@ let offset_addressing addr delta =
| Ibased(s, n) -> Ibased(s, n + delta)
let num_args_addressing = function
| Iindexed n -> 1
| Ibased(s, n) -> 0
| Iindexed _ -> 1
| Ibased _ -> 0
(* Printing operations and addressing modes *)

9
asmcomp/arm64/emit.mlp
View File

@ -36,7 +36,6 @@ let reg_trap_ptr = phys_reg 23
let reg_alloc_ptr = phys_reg 24
let reg_alloc_limit = phys_reg 25
let reg_tmp1 = phys_reg 26
let reg_tmp2 = phys_reg 27
let reg_x15 = phys_reg 15
(* Output a label *)
@ -362,7 +361,7 @@ let num_call_gc_and_check_bound_points instr =
in
loop instr (0, 0)
let max_out_of_line_code_offset instr ~num_call_gc ~num_check_bound =
let max_out_of_line_code_offset ~num_call_gc ~num_check_bound =
if num_call_gc < 1 && num_check_bound < 1 then 0
else begin
let size_of_call_gc = 2 in
@ -606,7 +605,7 @@ let emit_instr i =
let dst = i.res.(0) in
let base =
match addr with
| Iindexed ofs -> i.arg.(0)
| Iindexed _ -> i.arg.(0)
| Ibased(s, ofs) ->
` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
reg_tmp1 in
@ -633,7 +632,7 @@ let emit_instr i =
let src = i.arg.(0) in
let base =
match addr with
| Iindexed ofs -> i.arg.(1)
| Iindexed _ -> i.arg.(1)
| Ibased(s, ofs) ->
` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
reg_tmp1 in
@ -905,7 +904,7 @@ let fundecl fundecl =
num_call_gc_and_check_bound_points fundecl.fun_body
in
let max_out_of_line_code_offset =
max_out_of_line_code_offset fundecl.fun_body ~num_call_gc
max_out_of_line_code_offset ~num_call_gc
~num_check_bound
in
BR.relax fundecl.fun_body ~max_out_of_line_code_offset;

4
asmcomp/arm64/proc.ml
View File

@ -135,7 +135,7 @@ let calling_conventions
let incoming ofs = Incoming ofs
let outgoing ofs = Outgoing ofs
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
(* OCaml calling convention:
first integer args in r0...r15
@ -171,7 +171,7 @@ let loc_exn_bucket = phys_reg 0
(* Volatile registers: none *)
let regs_are_volatile rs = false
let regs_are_volatile _rs = false
(* Registers destroyed by operations *)

4
asmcomp/arm64/selection.ml
View File

@ -76,10 +76,6 @@ let rec run_automata nbits state input =
let is_logical_immediate n =
n <> 0 && n <> -1 && run_automata 64 0 n
let is_intconst = function
Cconst_int _ -> true
| _ -> false
let inline_ops =
[ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap";
"caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ]

2
asmcomp/asmlink.ml
View File

@ -135,7 +135,7 @@ let is_required name =
try ignore (Hashtbl.find missing_globals name); true
with Not_found -> false
let add_required by (name, crc) =
let add_required by (name, _crc) =
try
let rq = Hashtbl.find missing_globals name in
rq := by :: !rq

7
asmcomp/asmpackager.ml
View File

@ -99,10 +99,7 @@ let make_package_object ppf members targetobj targetname coercion
let source_provenance = Timings.Pack targetname in
let prefixname = chop_extension_if_any objtemp in
if Config.flambda then begin
let size, lam =
Translmod.transl_package_flambda
components module_ident coercion
in
let size, lam = Translmod.transl_package_flambda components coercion in
let flam =
Middle_end.middle_end ppf
~source_provenance
@ -150,7 +147,7 @@ let build_package_cmx members cmxfile =
let unit_names =
List.map (fun m -> m.pm_name) members in
let filter lst =
List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in
List.filter (fun (name, _crc) -> not (List.mem name unit_names)) lst in
let union lst =
List.fold_left
(List.fold_left

2
asmcomp/clambda.ml
View File

@ -124,7 +124,7 @@ let rec compare_float_lists l1 l2 =
let compare_constants c1 c2 =
match c1, c2 with
| Uconst_ref(lbl1, c1), Uconst_ref(lbl2, c2) -> String.compare lbl1 lbl2
| Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2
(* Same labels -> same constants.
Different labels -> different constants, even if the contents
match, because of string constants that must not be

116
asmcomp/closure.ml
View File

@ -60,14 +60,14 @@ let occurs_var var u =
let rec occurs = function
Uvar v -> v = var
| Uconst _ -> false
| Udirect_apply(lbl, args, _) -> List.exists occurs args
| Udirect_apply(_lbl, args, _) -> List.exists occurs args
| Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args
| Uclosure(fundecls, clos) -> List.exists occurs clos
| Uoffset(u, ofs) -> occurs u
| Ulet(id, def, body) -> occurs def || occurs body
| Uclosure(_fundecls, clos) -> List.exists occurs clos
| Uoffset(u, _ofs) -> occurs u
| Ulet(_id, def, body) -> occurs def || occurs body
| Uletrec(decls, body) ->
List.exists (fun (id, u) -> occurs u) decls || occurs body
| Uprim(p, args, _) -> List.exists occurs args
List.exists (fun (_id, u) -> occurs u) decls || occurs body
| Uprim(_p, args, _) -> List.exists occurs args
| Uswitch(arg, s) ->
occurs arg ||
occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks
@ -77,12 +77,12 @@ let occurs_var var u =
(match d with None -> false | Some d -> occurs d)
| Ustaticfail (_, args) -> List.exists occurs args
| Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr
| Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr
| Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr
| Uifthenelse(cond, ifso, ifnot) ->
occurs cond || occurs ifso || occurs ifnot
| Usequence(u1, u2) -> occurs u1 || occurs u2
| Uwhile(cond, body) -> occurs cond || occurs body
| Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body
| Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body
| Uassign(id, u) -> id = var || occurs u
| Usend(_, met, obj, args, _) ->
occurs met || occurs obj || List.exists occurs args
@ -103,11 +103,11 @@ let occurs_var var u =
let prim_size prim args =
match prim with
Pidentity -> 0
| Pgetglobal id -> 1
| Psetglobal id -> 1
| Pmakeblock(tag, mut) -> 5 + List.length args
| Pfield f -> 1
| Psetfield(f, isptr, init) ->
| Pgetglobal _ -> 1
| Psetglobal _ -> 1
| Pmakeblock _ -> 5 + List.length args
| Pfield _ -> 1
| Psetfield(_f, isptr, init) ->
begin match init with
| Initialization -> 1 (* never causes a write barrier hit *)
| Assignment ->
@ -115,8 +115,8 @@ let prim_size prim args =
| Pointer -> 4
| Immediate -> 1
end
| Pfloatfield f -> 1
| Psetfloatfield (f, _) -> 1
| Pfloatfield _ -> 1
| Psetfloatfield _ -> 1
| Pduprecord _ -> 10 + List.length args
| Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args
| Praise _ -> 4
@ -140,19 +140,19 @@ let lambda_smaller lam threshold =
let rec lambda_size lam =
if !size > threshold then raise Exit;
match lam with
Uvar v -> ()
Uvar _ -> ()
| Uconst _ -> incr size
| Udirect_apply(fn, args, _) ->
| Udirect_apply(_, args, _) ->
size := !size + 4; lambda_list_size args
| Ugeneric_apply(fn, args, _) ->
size := !size + 6; lambda_size fn; lambda_list_size args
| Uclosure(defs, vars) ->
| Uclosure _ ->
raise Exit (* inlining would duplicate function definitions *)
| Uoffset(lam, ofs) ->
| Uoffset(lam, _ofs) ->
incr size; lambda_size lam
| Ulet(id, lam, body) ->
| Ulet(_id, lam, body) ->
lambda_size lam; lambda_size body
| Uletrec(bindings, body) ->
| Uletrec _ ->
raise Exit (* usually too large *)
| Uprim(prim, args, _) ->
size := !size + prim_size prim args;
@ -175,7 +175,7 @@ let lambda_smaller lam threshold =
| Ustaticfail (_,args) -> lambda_list_size args
| Ucatch(_, _, body, handler) ->
incr size; lambda_size body; lambda_size handler
| Utrywith(body, id, handler) ->
| Utrywith(body, _id, handler) ->
size := !size + 8; lambda_size body; lambda_size handler
| Uifthenelse(cond, ifso, ifnot) ->
size := !size + 2;
@ -184,9 +184,9 @@ let lambda_smaller lam threshold =
lambda_size lam1; lambda_size lam2
| Uwhile(cond, body) ->
size := !size + 2; lambda_size cond; lambda_size body
| Ufor(id, low, high, dir, body) ->
| Ufor(_id, low, high, _dir, body) ->
size := !size + 4; lambda_size low; lambda_size high; lambda_size body
| Uassign(id, lam) ->
| Uassign(_id, lam) ->
incr size; lambda_size lam
| Usend(_, met, obj, args, _) ->
size := !size + 8;
@ -203,12 +203,12 @@ let lambda_smaller lam threshold =
that is without side-effects *and* not containing function definitions *)
let rec is_pure_clambda = function
Uvar v -> true
Uvar _ -> true
| Uconst _ -> true
| Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets |
Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false
| Uprim(p, args, _) -> List.for_all is_pure_clambda args
| Uprim(_, args, _) -> List.for_all is_pure_clambda args
| _ -> false
(* Simplify primitive operations on known arguments *)
@ -542,7 +542,7 @@ let rec substitute fpc sb ulam =
bindings1 sb in
Uletrec(
List.map
(fun (id, id', rhs) -> (id', substitute fpc sb' rhs))
(fun (_id, id', rhs) -> (id', substitute fpc sb' rhs))
bindings1,
substitute fpc sb' body)
| Uprim(p, args, dbg) ->
@ -669,13 +669,13 @@ let bind_params fpc params args body =
that is without side-effects *and* not containing function definitions *)
let rec is_pure = function
Lvar v -> true
| Lconst cst -> true
Lvar _ -> true
| Lconst _ -> true
| Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets |
Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false
| Lprim(p, args) -> List.for_all is_pure args
| Levent(lam, ev) -> is_pure lam
| Lprim(_, args) -> List.for_all is_pure args
| Levent(lam, _ev) -> is_pure lam
| _ -> false
let warning_if_forced_inline ~loc ~attribute warning =
@ -752,19 +752,19 @@ let rec add_debug_info ev u =
match ev.lev_kind with
| Lev_after _ ->
begin match u with
| Udirect_apply(lbl, args, dinfo) ->
| Udirect_apply(lbl, args, _dinfo) ->
Udirect_apply(lbl, args, Debuginfo.from_call ev)
| Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1),
args2, dinfo2) ->
| Ugeneric_apply(Udirect_apply(lbl, args1, _dinfo1),
args2, _dinfo2) ->
Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev),
args2, Debuginfo.from_call ev)
| Ugeneric_apply(fn, args, dinfo) ->
| Ugeneric_apply(fn, args, _dinfo) ->
Ugeneric_apply(fn, args, Debuginfo.from_call ev)
| Uprim(Praise k, args, dinfo) ->
| Uprim(Praise k, args, _dinfo) ->
Uprim(Praise k, args, Debuginfo.from_call ev)
| Uprim(p, args, dinfo) ->
| Uprim(p, args, _dinfo) ->
Uprim(p, args, Debuginfo.from_call ev)
| Usend(kind, u1, u2, args, dinfo) ->
| Usend(kind, u1, u2, args, _dinfo) ->
Usend(kind, u1, u2, args, Debuginfo.from_call ev)
| Usequence(u1, u2) ->
Usequence(u1, add_debug_info ev u2)
@ -790,7 +790,7 @@ let close_approx_var fenv cenv id =
(subst, approx)
let close_var fenv cenv id =
let (ulam, app) = close_approx_var fenv cenv id in ulam
let (ulam, _app) = close_approx_var fenv cenv id in ulam
let rec close fenv cenv = function
Lvar id ->
@ -823,7 +823,7 @@ let rec close fenv cenv = function
| Const_base(Const_nativeint x) -> str (Uconst_nativeint x)
in
make_const (transl cst)
| Lfunction{kind; params; body} as funct ->
| Lfunction _ as funct ->
close_one_function fenv cenv (Ident.create "fun") funct
(* We convert [f a] to [let a' = a in fun b c -> f a' b c]
@ -842,7 +842,7 @@ let rec close fenv cenv = function
let app = direct_apply ~loc ~attribute fundesc funct ufunct uargs in
(app, strengthen_approx app approx_res)
| ((ufunct, Value_closure(fundesc, approx_res)), uargs)
| ((_ufunct, Value_closure(fundesc, _approx_res)), uargs)
when nargs < fundesc.fun_arity ->
let first_args = List.map (fun arg ->
(Ident.create "arg", arg) ) uargs in
@ -857,7 +857,7 @@ let rec close fenv cenv = function
(Ulet ( arg1, arg2, body))
in
let internal_args =
(List.map (fun (arg1, arg2) -> Lvar arg1) first_args)
(List.map (fun (arg1, _arg2) -> Lvar arg1) first_args)
@ (List.map (fun arg -> Lvar arg ) final_args)
in
let (new_fun, approx) = close fenv cenv
@ -876,7 +876,7 @@ let rec close fenv cenv = function
warning_if_forced_inline ~loc ~attribute "Partial application";
(new_fun, approx)
| ((ufunct, Value_closure(fundesc, approx_res)), uargs)
| ((ufunct, Value_closure(fundesc, _approx_res)), uargs)
when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
let (first_args, rem_args) = split_list fundesc.fun_arity uargs in
warning_if_forced_inline ~loc ~attribute "Over-application";
@ -907,7 +907,7 @@ let rec close fenv cenv = function
end
| Lletrec(defs, body) ->
if List.for_all
(function (id, Lfunction _) -> true | _ -> false)
(function (_id, Lfunction _) -> true | _ -> false)
defs
then begin
(* Simple case: only function definitions *)
@ -915,12 +915,12 @@ let rec close fenv cenv = function
let clos_ident = Ident.create "clos" in
let fenv_body =
List.fold_right
(fun (id, pos, approx) fenv -> Tbl.add id approx fenv)
(fun (id, _pos, approx) fenv -> Tbl.add id approx fenv)
infos fenv in
let (ubody, approx) = close fenv_body cenv body in
let sb =
List.fold_right
(fun (id, pos, approx) sb ->
(fun (id, pos, _approx) sb ->
Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb)
infos Tbl.empty in
(Ulet(clos_ident, clos, substitute !Clflags.float_const_prop sb ubody),
@ -960,7 +960,7 @@ let rec close fenv cenv = function
(Uprim(Psetfield(n, is_ptr, init), [getglobal id; ulam], Debuginfo.none),
Value_unknown)
| Lprim(Praise k, [Levent(arg, ev)]) ->
let (ulam, approx) = close fenv cenv arg in
let (ulam, _approx) = close fenv cenv arg in
(Uprim(Praise k, [ulam], Debuginfo.from_raise ev),
Value_unknown)
| Lprim(p, args) ->
@ -970,9 +970,9 @@ let rec close fenv cenv = function
let fn fail =
let (uarg, _) = close fenv cenv arg in
let const_index, const_actions, fconst =
close_switch arg fenv cenv sw.sw_consts sw.sw_numconsts fail
close_switch fenv cenv sw.sw_consts sw.sw_numconsts fail
and block_index, block_actions, fblock =
close_switch arg fenv cenv sw.sw_blocks sw.sw_numblocks fail in
close_switch fenv cenv sw.sw_blocks sw.sw_numblocks fail in
let ulam =
Uswitch
(uarg,
@ -1066,7 +1066,7 @@ and close_list_approx fenv cenv = function
(ulam :: ulams, approx :: approxs)
and close_named fenv cenv id = function
Lfunction{kind; params; body} as funct ->
Lfunction _ as funct ->
close_one_function fenv cenv id funct
| lam ->
close fenv cenv lam
@ -1085,7 +1085,7 @@ and close_functions fenv cenv fun_defs =
fun_defs)
in
let inline_attribute = match fun_defs with
| [_, Lfunction{kind; params; body; attr = { inline }}] -> inline
| [_, Lfunction{attr = { inline }}] -> inline
| _ -> Default_inline (* recursive functions can't be inlined *)
in
@ -1117,14 +1117,14 @@ and close_functions fenv cenv fun_defs =
(* Build an approximate fenv for compiling the functions *)
let fenv_rec =
List.fold_right
(fun (id, params, body, fundesc) fenv ->
(fun (id, _params, _body, fundesc) fenv ->
Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv)
uncurried_defs fenv in
(* Determine the offsets of each function's closure in the shared block *)
let env_pos = ref (-1) in
let clos_offsets =
List.map
(fun (id, params, body, fundesc) ->
(fun (_id, _params, _body, fundesc) ->
let pos = !env_pos + 1 in
env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);
pos)
@ -1143,7 +1143,7 @@ and close_functions fenv cenv fun_defs =
build_closure_env env_param (fv_pos - env_pos) fv in
let cenv_body =
List.fold_right2
(fun (id, params, body, fundesc) pos env ->
(fun (id, _params, _body, _fundesc) pos env ->
Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
uncurried_defs clos_offsets cenv_fv in
let (ubody, approx) = close fenv_rec cenv_body body in
@ -1193,7 +1193,7 @@ and close_functions fenv cenv fun_defs =
recompile *)
Compilenv.backtrack snap; (* PR#6337 *)
List.iter
(fun (id, params, body, fundesc) ->
(fun (_id, _params, _body, fundesc) ->
fundesc.fun_closed <- false;
fundesc.fun_inline <- None;
)
@ -1221,7 +1221,7 @@ and close_one_function fenv cenv id funct =
(* Close a switch *)
and close_switch arg fenv cenv cases num_keys default =
and close_switch fenv cenv cases num_keys default =
let ncases = List.length cases in
let index = Array.make num_keys 0
and store = Storer.mk_store () in
@ -1287,7 +1287,7 @@ let collect_exported_structured_constants a =
| Uconst_ref (s, (Some c)) ->
Compilenv.add_exported_constant s;
structured_constant c
| Uconst_ref (s, None) -> assert false (* Cannot be generated *)
| Uconst_ref (_s, None) -> assert false (* Cannot be generated *)
| Uconst_int _ | Uconst_ptr _ -> ()
and structured_constant = function
| Uconst_block (_, ul) -> List.iter const ul
@ -1339,7 +1339,7 @@ let intro size lam =
let id = Compilenv.make_symbol None in
global_approx := Array.init size (fun i -> Value_global_field (id, i));
Compilenv.set_global_approx(Value_tuple !global_approx);
let (ulam, approx) = close Tbl.empty Tbl.empty lam in
let (ulam, _approx) = close Tbl.empty Tbl.empty lam in
let opaque =
!Clflags.opaque
|| Env.is_imported_opaque (Compilenv.current_unit_name ())

56
asmcomp/cmmgen.ml
View File

@ -156,7 +156,7 @@ and mult_power2 c n = lsl_int c (Cconst_int (Misc.log2 n))
let rec mul_int c1 c2 =
match (c1, c2) with
| (c, Cconst_int 0) | (Cconst_int 0, c) ->
| (_, Cconst_int 0) | (Cconst_int 0, _) ->
Cconst_int 0
| (c, Cconst_int 1) | (Cconst_int 1, c) ->
c
@ -431,7 +431,7 @@ let safe_div_bi =
safe_divmod_bi div_int (fun c1 -> Cop(Csubi, [Cconst_int 0; c1]))
let safe_mod_bi =
safe_divmod_bi mod_int (fun c1 -> Cconst_int 0)
safe_divmod_bi mod_int (fun _ -> Cconst_int 0)
(* Bool *)
@ -444,7 +444,7 @@ let test_bool = function
let box_float c = Cop(Calloc, [alloc_float_header; c])
let rec unbox_float = function
Cop(Calloc, [header; c]) -> c
Cop(Calloc, [_header; c]) -> c
| Clet(id, exp, body) -> Clet(id, exp, unbox_float body)
| Cifthenelse(cond, e1, e2) ->
Cifthenelse(cond, unbox_float e1, unbox_float e2)
@ -482,9 +482,9 @@ let rec remove_unit = function
Ctrywith(remove_unit body, exn, remove_unit handler)
| Clet(id, c1, c2) ->
Clet(id, c1, remove_unit c2)
| Cop(Capply (mty, dbg), args) ->
| Cop(Capply (_mty, dbg), args) ->
Cop(Capply (typ_void, dbg), args)
| Cop(Cextcall(proc, mty, alloc, dbg), args) ->
| Cop(Cextcall(proc, _mty, alloc, dbg), args) ->
Cop(Cextcall(proc, typ_void, alloc, dbg), args)
| Cexit (_,_) as c -> c
| Ctuple [] as c -> c
@ -692,9 +692,9 @@ let rec expr_size env = function
RHS_block (fundecls_size fundecls + List.length clos_vars)
| Ulet(id, exp, body) ->
expr_size (Ident.add id (expr_size env exp) env) body
| Uletrec(bindings, body) ->
| Uletrec(_bindings, body) ->
expr_size env body
| Uprim(Pmakeblock(tag, mut), args, _) ->
| Uprim(Pmakeblock _, args, _) ->
RHS_block (List.length args)
| Uprim(Pmakearray((Paddrarray | Pintarray), _), args, _) ->
RHS_block (List.length args)
@ -710,7 +710,7 @@ let rec expr_size env = function
when prim_name = "caml_check_value_is_closure" ->
(* Used for "-clambda-checks". *)
expr_size env closure
| Usequence(exp, exp') ->
| Usequence(_exp, exp') ->
expr_size env exp'
| _ -> RHS_nonrec
@ -813,15 +813,15 @@ let split_int64_for_32bit_target arg =
let rec unbox_int bi arg =
match arg with
Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])])
Cop(Calloc, [_hdr; _ops; Cop(Clsl, [contents; Cconst_int 32])])
when bi = Pint32 && size_int = 8 && big_endian ->
(* Force sign-extension of low 32 bits *)
Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
| Cop(Calloc, [hdr; ops; contents])
| Cop(Calloc, [_hdr; _ops; contents])
when bi = Pint32 && size_int = 8 && not big_endian ->
(* Force sign-extension of low 32 bits *)
Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
| Cop(Calloc, [hdr; ops; contents]) ->
| Cop(Calloc, [_hdr; _ops; contents]) ->
contents
| Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body)
| Cifthenelse(cond, e1, e2) ->
@ -1182,9 +1182,9 @@ let simplif_primitive_32bits = function
| Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan")
| Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal")
| Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal")
| Pbigarrayref(unsafe, n, Pbigarray_int64, layout) ->
| Pbigarrayref(_unsafe, n, Pbigarray_int64, _layout) ->
Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
| Pbigarrayset(unsafe, n, Pbigarray_int64, layout) ->
| Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) ->
Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
| Pstring_load_64(_) -> Pccall (default_prim "caml_string_get64")
| Pstring_set_64(_) -> Pccall (default_prim "caml_string_set64")
@ -1197,13 +1197,13 @@ let simplif_primitive p =
match p with
| Pduprecord _ ->
Pccall (default_prim "caml_obj_dup")
| Pbigarrayref(unsafe, n, Pbigarray_unknown, layout) ->
| Pbigarrayref(_unsafe, n, Pbigarray_unknown, _layout) ->
Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
| Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) ->
| Pbigarrayset(_unsafe, n, Pbigarray_unknown, _layout) ->
Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
| Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) ->
| Pbigarrayref(_unsafe, n, _kind, Pbigarray_unknown_layout) ->
Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
| Pbigarrayset(unsafe, n, kind, Pbigarray_unknown_layout) ->
| Pbigarrayset(_unsafe, n, _kind, Pbigarray_unknown_layout) ->
Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
| p ->
if size_int = 8 then p else simplif_primitive_32bits p
@ -1371,7 +1371,7 @@ let rec is_unboxed_number env e =
| Parrayrefu Pfloatarray -> Boxed Boxed_float
| Parrayrefs Pfloatarray -> Boxed Boxed_float
| Pbintofint bi -> Boxed (Boxed_integer bi)
| Pcvtbint(src, dst) -> Boxed (Boxed_integer dst)
| Pcvtbint(_src, dst) -> Boxed (Boxed_integer dst)
| Pnegbint bi -> Boxed (Boxed_integer bi)
| Paddbint bi -> Boxed (Boxed_integer bi)
| Psubbint bi -> Boxed (Boxed_integer bi)
@ -1512,9 +1512,9 @@ let rec transl env e =
begin match (simplif_primitive prim, args) with
(Pgetglobal id, []) ->
Cconst_symbol (Ident.name id)
| (Pmakeblock(tag, mut), []) ->
| (Pmakeblock _, []) ->
assert false
| (Pmakeblock(tag, mut), args) ->
| (Pmakeblock(tag, _mut), args) ->
make_alloc tag (List.map (transl env) args)
| (Pccall prim, args) ->
transl_ccall env prim args dbg
@ -1536,10 +1536,10 @@ let rec transl env e =
Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
in
transl_ccall env prim_obj_dup [arg] dbg
| (Pmakearray (kind, _), []) ->
| (Pmakearray _, []) ->
transl_structured_constant (Uconst_block(0, []))
| (Pmakearray (kind, _), args) -> transl_make_array env kind args
| (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
| (Pbigarrayref(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) ->
let elt =
bigarray_get unsafe elt_kind layout
(transl env arg1) (List.map (transl env) argl) dbg in
@ -1552,7 +1552,7 @@ let rec transl env e =
| Pbigarray_caml_int -> force_tag_int elt
| _ -> tag_int elt
end
| (Pbigarrayset(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
| (Pbigarrayset(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) ->
let (argidx, argnewval) = split_last argl in
return_unit(bigarray_set unsafe elt_kind layout
(transl env arg1)
@ -2411,15 +2411,15 @@ and transl_letrec env bindings cont =
Cop(Cextcall(prim, typ_val, true, Debuginfo.none), [int_const sz]) in
let rec init_blocks = function
| [] -> fill_nonrec bsz
| (id, exp, RHS_block sz) :: rem ->
| (id, _exp, RHS_block sz) :: rem ->
Clet(id, op_alloc "caml_alloc_dummy" sz, init_blocks rem)
| (id, exp, RHS_floatblock sz) :: rem ->
| (id, _exp, RHS_floatblock sz) :: rem ->
Clet(id, op_alloc "caml_alloc_dummy_float" sz, init_blocks rem)
| (id, exp, RHS_nonrec) :: rem ->
| (id, _exp, RHS_nonrec) :: rem ->
Clet (id, Cconst_int 0, init_blocks rem)
and fill_nonrec = function
| [] -> fill_blocks bsz
| (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
| (_id, _exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
fill_nonrec rem
| (id, exp, RHS_nonrec) :: rem ->
Clet(id, transl env exp, fill_nonrec rem)
@ -2430,7 +2430,7 @@ and transl_letrec env bindings cont =
Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none),
[Cvar id; transl env exp]) in
Csequence(op, fill_blocks rem)
| (id, exp, RHS_nonrec) :: rem ->
| (_id, _exp, RHS_nonrec) :: rem ->
fill_blocks rem
in init_blocks bsz

4
asmcomp/comballoc.ml
View File

@ -26,7 +26,7 @@ type allocation_state =
let allocated_size = function
No_alloc -> 0
| Pending_alloc(reg, ofs) -> ofs
| Pending_alloc(_, ofs) -> ofs
let rec combine i allocstate =
match i.desc with
@ -55,7 +55,7 @@ let rec combine i allocstate =
let newnext = combine_restart i.next in
(instr_cons_debug i.desc i.arg i.res i.dbg newnext,
allocated_size allocstate)
| Iop op ->
| Iop _ ->
let (newnext, sz) = combine i.next allocstate in
(instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz)
| Iifthenelse(test, ifso, ifnot) ->

2
asmcomp/deadcode.ml
View File

@ -57,7 +57,7 @@ let rec deadcode i =
let (handler', _) = deadcode handler in
let (s, _) = deadcode i.next in
({i with desc = Icatch(nfail, body', handler'); next = s}, i.live)
| Iexit nfail ->
| Iexit _ ->
(i, i.live)
| Itrywith(body, handler) ->
let (body', _) = deadcode body in

2
asmcomp/i386/CSE.ml
View File

@ -20,7 +20,7 @@ open Arch
open Mach
open CSEgen
class cse = object (self)
class cse = object
inherit cse_generic as super

10
asmcomp/i386/arch.ml
View File

@ -79,11 +79,11 @@ let offset_addressing addr delta =
| Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta)
let num_args_addressing = function
Ibased(s, n) -> 0
| Iindexed n -> 1
| Iindexed2 n -> 2
| Iscaled(scale, n) -> 1
| Iindexed2scaled(scale, n) -> 2
Ibased _ -> 0
| Iindexed _ -> 1
| Iindexed2 _ -> 2
| Iscaled _ -> 1
| Iindexed2scaled _ -> 2
(* Printing operations and addressing modes *)

12
asmcomp/i386/proc.ml
View File

@ -140,7 +140,7 @@ let calling_conventions first_int last_int first_float last_float make_stack
let incoming ofs = Incoming ofs
let outgoing ofs = Outgoing ofs
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
(* Six arguments in integer registers plus eight in global memory. *)
let max_arguments_for_tailcalls = 14
@ -148,16 +148,16 @@ let max_arguments_for_tailcalls = 14
let loc_arguments arg =
calling_conventions 0 5 100 99 outgoing arg
let loc_parameters arg =
let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc
let (loc, _ofs) = calling_conventions 0 5 100 99 incoming arg in loc
let loc_results res =
let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc
let loc_external_arguments arg =
let (loc, _ofs) = calling_conventions 0 5 100 100 not_supported res in loc
let loc_external_arguments _arg =
fatal_error "Proc.loc_external_arguments"
let loc_external_results res =
match res with
| [|{typ=Int};{typ=Int}|] -> [|eax; edx|]
| _ ->
let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc
let loc_exn_bucket = eax
@ -195,7 +195,7 @@ let destroyed_at_raise = all_phys_regs
(* Maximal register pressure *)
let safe_register_pressure op = 4
let safe_register_pressure _op = 4
let max_register_pressure = function
Iextcall(_, _) -> [| 4; max_int |]

2
asmcomp/i386/reload.ml
View File

@ -71,7 +71,7 @@ method! reload_operation op arg res =
method! reload_test tst arg =
match tst with
Iinttest cmp ->
Iinttest _ ->
(* One of the two arguments can reside on stack *)
if stackp arg.(0) && stackp arg.(1)
then [| self#makereg arg.(0); arg.(1) |]

14
asmcomp/i386/selection.ml
View File

@ -88,7 +88,7 @@ let rec float_needs = function
let n1 = float_needs arg1 in
let n2 = float_needs arg2 in
if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2
| Cop(Cextcall(fn, ty_res, alloc, dbg), args)
| Cop(Cextcall(fn, _ty_res, _alloc, _dbg), args)
when !fast_math && List.mem fn inline_float_ops ->
begin match args with
[arg] -> float_needs arg
@ -138,7 +138,7 @@ let pseudoregs_for_operation op arg res =
(* For storing a byte, the argument must be in eax...edx.
(But for a short, any reg will do!)
Keep it simple, just force the argument to be in edx. *)
| Istore((Byte_unsigned | Byte_signed), addr, _) ->
| Istore((Byte_unsigned | Byte_signed), _, _) ->
let newarg = Array.copy arg in
newarg.(0) <- edx;
(newarg, res, false)
@ -157,18 +157,18 @@ class selector = object (self)
inherit Selectgen.selector_generic as super
method is_immediate (n : int) = true
method is_immediate (_n : int) = true
method! is_simple_expr e =
match e with
| Cop(Cextcall(fn, _, alloc, _), args)
| Cop(Cextcall(fn, _, _, _), args)
when !fast_math && List.mem fn inline_float_ops ->
(* inlined float ops are simple if their arguments are *)
List.for_all self#is_simple_expr args
| _ ->
super#is_simple_expr e
method select_addressing chunk exp =
method select_addressing _chunk exp =
match select_addr exp with
(Asymbol s, d) ->
(Ibased(s, d), Ctuple [])
@ -201,7 +201,7 @@ method! select_operation op args =
(* Recognize the LEA instruction *)
Caddi | Caddv | Cadda | Csubi ->
begin match self#select_addressing Word_int (Cop(op, args)) with
(Iindexed d, _) -> super#select_operation op args
(Iindexed _, _)
| (Iindexed2 0, _) -> super#select_operation op args
| (addr, arg) -> (Ispecific(Ilea addr), [arg])
end
@ -228,7 +228,7 @@ method! select_operation op args =
super#select_operation op args
end
(* Recognize inlined floating point operations *)
| Cextcall(fn, ty_res, false, dbg)
| Cextcall(fn, _ty_res, false, _dbg)
when !fast_math && List.mem fn inline_float_ops ->
(Ispecific(Ifloatspecial fn), args)
(* i386 does not support immediate operands for multiply high signed *)

16
asmcomp/interf.ml
View File

@ -91,16 +91,16 @@ let build_graph fundecl =
add_interf_move i.arg.(0) i.res.(0) i.live;
interf i.next
| Iop(Itailcall_ind) -> ()
| Iop(Itailcall_imm lbl) -> ()
| Iop op ->
| Iop(Itailcall_imm _) -> ()
| Iop _ ->
add_interf_set i.res i.live;
add_interf_self i.res;
interf i.next
| Iifthenelse(tst, ifso, ifnot) ->
| Iifthenelse(_tst, ifso, ifnot) ->
interf ifso;
interf ifnot;
interf i.next
| Iswitch(index, cases) ->
| Iswitch(_index, cases) ->
for i = 0 to Array.length cases - 1 do
interf cases.(i)
done;
@ -163,14 +163,14 @@ let build_graph fundecl =
add_pref (weight / 4) i.res.(0) i.arg.(0);
prefer weight i.next
| Iop(Itailcall_ind) -> ()
| Iop(Itailcall_imm lbl) -> ()
| Iop op ->
| Iop(Itailcall_imm _) -> ()
| Iop _ ->
prefer weight i.next
| Iifthenelse(tst, ifso, ifnot) ->
| Iifthenelse(_tst, ifso, ifnot) ->
prefer (weight / 2) ifso;
prefer (weight / 2) ifnot;
prefer weight i.next
| Iswitch(index, cases) ->
| Iswitch(_index, cases) ->
for i = 0 to Array.length cases - 1 do
prefer (weight / 2) cases.(i)
done;

4
asmcomp/liveness.ml
View File

@ -68,12 +68,12 @@ let rec live i finally =
i.live <- across;
Reg.add_set_array across i.arg
end
| Iifthenelse(test, ifso, ifnot) ->
| Iifthenelse(_test, ifso, ifnot) ->
let at_join = live i.next finally in
let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in
i.live <- at_fork;
Reg.add_set_array at_fork i.arg
| Iswitch(index, cases) ->
| Iswitch(_index, cases) ->
let at_join = live i.next finally in
let at_fork = ref Reg.Set.empty in
for i = 0 to Array.length cases - 1 do

4
asmcomp/mach.ml
View File

@ -115,9 +115,9 @@ let rec instr_iter f i =
match i.desc with
Iend -> ()
| Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> ()
| Iifthenelse(tst, ifso, ifnot) ->
| Iifthenelse(_tst, ifso, ifnot) ->
instr_iter f ifso; instr_iter f ifnot; instr_iter f i.next
| Iswitch(index, cases) ->
| Iswitch(_index, cases) ->
for i = 0 to Array.length cases - 1 do
instr_iter f cases.(i)
done;

2
asmcomp/power/CSE.ml
View File

@ -19,7 +19,7 @@ open Arch
open Mach
open CSEgen
class cse = object (self)
class cse = object
inherit cse_generic as super

4
asmcomp/power/arch.ml
View File

@ -85,8 +85,8 @@ let offset_addressing addr delta =
| Iindexed2 -> assert false
let num_args_addressing = function
Ibased(s, n) -> 0
| Iindexed n -> 1
Ibased _ -> 0
| Iindexed _ -> 1
| Iindexed2 -> 2
(* Printing operations and addressing modes *)

65
asmcomp/power/emit.mlp
View File

@ -116,7 +116,6 @@ let datag = if ppc64 then ".quad" else ".long"
let mullg = if ppc64 then "mulld" else "mullw"
let divg = if ppc64 then "divd" else "divw"
let tglle = if ppc64 then "tdlle" else "twlle"
let slgi = if ppc64 then "sldi" else "slwi"
(* Output a processor register *)
@ -422,17 +421,17 @@ module BR = Branch_relaxation.Make (struct
let size =
match abi with
| ELF32 -> (fun a b c -> a)
| ELF64v1 -> (fun a b c -> b)
| ELF64v2 -> (fun a b c -> c)
| ELF32 -> (fun a _ _ -> a)
| ELF64v1 -> (fun _ b _ -> b)
| ELF64v2 -> (fun _ _ c -> c)
let tocload_size() =
if !big_toc || !Clflags.for_package <> None then 2 else 1
let load_store_size = function
| Ibased(s, d) ->
| Ibased(_s, d) ->
if abi = ELF32 then 2 else begin
let (lo, hi) = low_high_s d in
let (_lo, hi) = low_high_s d in
tocload_size() + (if hi = 0 then 1 else 2)
end
| Iindexed ofs -> if is_immediate ofs then 1 else 3
@ -443,50 +442,50 @@ module BR = Branch_relaxation.Make (struct
| Lop(Imove | Ispill | Ireload) -> 1
| Lop(Iconst_int n | Iconst_blockheader n) ->
if is_native_immediate n then 1
else if (let (lo, hi) = native_low_high_s n in
else if (let (_lo, hi) = native_low_high_s n in
hi >= -0x8000 && hi <= 0x7FFF) then 2
else if (let (lo, hi) = native_low_high_u n in
else if (let (_lo, hi) = native_low_high_u n in
hi >= -0x8000 && hi <= 0x7FFF) then 2
else tocload_size()
| Lop(Iconst_float s) -> if abi = ELF32 then 2 else tocload_size()
| Lop(Iconst_symbol s) -> if abi = ELF32 then 2 else tocload_size()
| Lop(Iconst_float _) -> if abi = ELF32 then 2 else tocload_size()
| Lop(Iconst_symbol _) -> if abi = ELF32 then 2 else tocload_size()
| Lop(Icall_ind) -> size 2 5 4
| Lop(Icall_imm s) -> size 1 3 3
| Lop(Icall_imm _) -> size 1 3 3
| Lop(Itailcall_ind) -> size 5 7 6
| Lop(Itailcall_imm s) ->
if s = !function_name
then 1
else size 4 (7 + tocload_size()) (6 + tocload_size())
| Lop(Iextcall(s, true)) -> size 3 (2 + tocload_size()) (2 + tocload_size())
| Lop(Iextcall(s, false)) -> size 1 2 2
| Lop(Istackoffset n) -> 1
| Lop(Iextcall(_s, true)) -> size 3 (2 + tocload_size()) (2 + tocload_size())
| Lop(Iextcall(_s, false)) -> size 1 2 2
| Lop(Istackoffset _) -> 1
| Lop(Iload(chunk, addr)) ->
if chunk = Byte_signed
then load_store_size addr + 1
else load_store_size addr
| Lop(Istore(chunk, addr, _)) -> load_store_size addr
| Lop(Ialloc n) -> 4
| Lop(Ispecific(Ialloc_far n)) -> 5
| Lop(Istore(_chunk, addr, _)) -> load_store_size addr
| Lop(Ialloc _) -> 4
| Lop(Ispecific(Ialloc_far _)) -> 5
| Lop(Iintop Imod) -> 3
| Lop(Iintop(Icomp cmp)) -> 4
| Lop(Iintop op) -> 1
| Lop(Iintop_imm(Icomp cmp, n)) -> 4
| Lop(Iintop_imm(op, n)) -> 1
| Lop(Iintop(Icomp _)) -> 4
| Lop(Iintop _) -> 1
| Lop(Iintop_imm(Icomp _, _)) -> 4
| Lop(Iintop_imm _) -> 1
| Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1
| Lop(Ifloatofint) -> 9
| Lop(Iintoffloat) -> 4
| Lop(Ispecific sop) -> 1
| Lop(Ispecific _) -> 1
| Lreloadretaddr -> 2
| Lreturn -> 2
| Llabel lbl -> 0
| Lbranch lbl -> 1
| Lcondbranch(tst, lbl) -> 2
| Llabel _ -> 0
| Lbranch _ -> 1
| Lcondbranch _ -> 2
| Lcondbranch3(lbl0, lbl1, lbl2) ->
1 + (if lbl0 = None then 0 else 1)
+ (if lbl1 = None then 0 else 1)
+ (if lbl2 = None then 0 else 1)
| Lswitch jumptbl -> size 7 (5 + tocload_size()) (5 + tocload_size())
| Lsetuptrap lbl -> size 1 2 2
| Lswitch _ -> size 7 (5 + tocload_size()) (5 + tocload_size())
| Lsetuptrap _ -> size 1 2 2
| Lpushtrap -> size 4 5 5
| Lpoptrap -> 2
| Lraise _ -> 6
@ -510,17 +509,17 @@ let emit_instr i =
let src = i.arg.(0) and dst = i.res.(0) in
if src.loc <> dst.loc then begin
match (src, dst) with
| {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Reg rd} ->
| {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
` mr {emit_reg dst}, {emit_reg src}\n`
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
| {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
` fmr {emit_reg dst}, {emit_reg src}\n`
| {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Stack sd} ->
| {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} ->
` {emit_string stg} {emit_reg src}, {emit_stack dst}\n`
| {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
| {loc = Reg _; typ = Float}, {loc = Stack _} ->
` stfd {emit_reg src}, {emit_stack dst}\n`
| {loc = Stack ss; typ = (Val | Int | Addr)}, {loc = Reg rd} ->
| {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
` {emit_string lg} {emit_reg dst}, {emit_stack src}\n`
| {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
| {loc = Stack _; typ = Float}, {loc = Reg _} ->
` lfd {emit_reg dst}, {emit_stack src}\n`
| (_, _) ->
fatal_error "Emit: Imove"

12
asmcomp/power/proc.ml
View File

@ -168,7 +168,7 @@ let calling_conventions
let incoming ofs = Incoming ofs
let outgoing ofs = Outgoing ofs
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
let single_regs arg = Array.map (fun arg -> [| arg |]) arg
let ensure_single_regs res =
@ -185,12 +185,12 @@ let loc_arguments arg =
in
(ensure_single_regs loc, ofs)
let loc_parameters arg =
let (loc, ofs) =
let (loc, _ofs) =
calling_conventions 0 7 100 112 incoming 0 false (single_regs arg)
in
ensure_single_regs loc
let loc_results res =
let (loc, ofs) =
let (loc, _ofs) =
calling_conventions 0 7 100 112 not_supported 0 false (single_regs res)
in
ensure_single_regs loc
@ -244,12 +244,10 @@ let loc_external_arguments =
then (loc, ofs)
else (loc, 0)
let extcall_use_push = false
(* Results are in GPR 3 and FPR 1 *)
let loc_external_results res =
let (loc, ofs) =
let (loc, _ofs) =
calling_conventions 0 1 100 100 not_supported 0 false (single_regs res)
in
ensure_single_regs loc
@ -260,7 +258,7 @@ let loc_exn_bucket = phys_reg 0
(* Volatile registers: none *)
let regs_are_volatile rs = false
let regs_are_volatile _rs = false
(* Registers destroyed by operations *)

4
asmcomp/power/scheduling.ml
View File

@ -38,7 +38,7 @@ method oper_latency = function
| Ispecific(Imultaddf | Imultsubf) -> 5
| _ -> 1
method reload_retaddr_latency = 12
method! reload_retaddr_latency = 12
(* If we can have that many cycles between the reloadretaddr and the
return, we can expect that the blr branch will be completely folded. *)
@ -56,7 +56,7 @@ method oper_issue_cycles = function
| Iintoffloat -> 4
| _ -> 1
method reload_retaddr_issue_cycles = 3
method! reload_retaddr_issue_cycles = 3
(* load then stalling mtlr *)
end

2
asmcomp/power/selection.ml
View File

@ -51,7 +51,7 @@ inherit Selectgen.selector_generic as super
method is_immediate n = (n <= 32767) && (n >= -32768)
method select_addressing chunk exp =
method select_addressing _chunk exp =
match select_addr exp with
(Asymbol s, d) ->
(Ibased(s, d), Ctuple [])

4
asmcomp/printcmm.ml
View File

@ -54,8 +54,8 @@ let chunk = function
| Double_u -> "float64u"
let operation = function
| Capply(ty, d) -> "app" ^ Debuginfo.to_string d
| Cextcall(lbl, ty, alloc, d) ->
| Capply(_ty, d) -> "app" ^ Debuginfo.to_string d
| Cextcall(lbl, _ty, _alloc, d) ->
Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d)
| Cload c -> Printf.sprintf "load %s" (chunk c)
| Calloc -> "alloc"

2
asmcomp/reloadgen.ml
View File

@ -73,7 +73,7 @@ method reload_operation op arg res =
| _ ->
(self#makeregs arg, self#makeregs res)
method reload_test tst args =
method reload_test _tst args =
self#makeregs args
method private reload i =

2
asmcomp/s390x/CSE.ml
View File

@ -21,7 +21,7 @@ open Arch
open Mach
open CSEgen
class cse = object (self)
class cse = object
inherit cse_generic as super

4
asmcomp/s390x/arch.ml
View File

@ -65,8 +65,8 @@ let offset_addressing addr delta =
| Iindexed2 n -> Iindexed2(n + delta)
let num_args_addressing = function
| Iindexed n -> 1
| Iindexed2 n -> 2
| Iindexed _ -> 1
| Iindexed2 _ -> 2
(* Printing operations and addressing modes *)

16
asmcomp/s390x/emit.mlp
View File

@ -86,10 +86,6 @@ let emit_reg r =
| _ -> fatal_error "Emit.emit_reg"
let emit_gpr r = emit_string "%r"; emit_int r
let emit_fpr r = emit_string "%f"; emit_int r
(* Special registers *)
let reg_f15 = phys_reg 115
@ -292,17 +288,17 @@ let emit_instr i =
let src = i.arg.(0) and dst = i.res.(0) in
if src.loc <> dst.loc then begin
match (src, dst) with
{loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Reg rd} ->
{loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
` lgr {emit_reg dst}, {emit_reg src}\n`
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
| {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
` ldr {emit_reg dst}, {emit_reg src}\n`
| {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Stack sd} ->
| {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} ->
` stg {emit_reg src}, {emit_stack dst}\n`
| {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
| {loc = Reg _; typ = Float}, {loc = Stack _} ->
` std {emit_reg src}, {emit_stack dst}\n`
| {loc = Stack ss; typ = (Val | Int | Addr)}, {loc = Reg rd} ->
| {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
` lg {emit_reg dst}, {emit_stack src}\n`
| {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
| {loc = Stack _; typ = Float}, {loc = Reg _} ->
` ldy {emit_reg dst}, {emit_stack src}\n`
| (_, _) ->
fatal_error "Emit: Imove"

12
asmcomp/s390x/proc.ml
View File

@ -126,16 +126,16 @@ let calling_conventions
let incoming ofs = Incoming ofs
let outgoing ofs = Outgoing ofs
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
let max_arguments_for_tailcalls = 5
let loc_arguments arg =
calling_conventions 0 4 100 103 outgoing 0 arg
let loc_parameters arg =
let (loc, ofs) = calling_conventions 0 4 100 103 incoming 0 arg in loc
let (loc, _ofs) = calling_conventions 0 4 100 103 incoming 0 arg in loc
let loc_results res =
let (loc, ofs) = calling_conventions 0 4 100 103 not_supported 0 res in loc
let (loc, _ofs) = calling_conventions 0 4 100 103 not_supported 0 res in loc
(* C calling conventions under SVR4:
use GPR 2-6 and FPR 0,2,4,6 just like ML calling conventions.
@ -150,12 +150,10 @@ let loc_external_arguments arg =
calling_conventions 0 4 100 103 outgoing 160 arg in
(Array.map (fun reg -> [|reg|]) loc, ofs)
let extcall_use_push = false
(* Results are in GPR 2 and FPR 0 *)
let loc_external_results res =
let (loc, ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc
let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc
(* Exceptions are in GPR 2 *)
@ -163,7 +161,7 @@ let loc_exn_bucket = phys_reg 0
(* Volatile registers: none *)
let regs_are_volatile rs = false
let regs_are_volatile _rs = false
(* Registers destroyed by operations *)

4
asmcomp/s390x/scheduling.ml
View File

@ -44,7 +44,7 @@ method oper_latency = function
| Ispecific(Imultaddf | Imultsubf) -> 8
| _ -> 2
method reload_retaddr_latency = 4
method! reload_retaddr_latency = 4
(* Issue cycles. Rough approximations. *)
@ -56,7 +56,7 @@ method oper_issue_cycles = function
| Iintop_imm(Icomp _, _) -> 4
| _ -> 1
method reload_retaddr_issue_cycles = 1
method! reload_retaddr_issue_cycles = 1
end

4
asmcomp/s390x/selection.ml
View File

@ -51,7 +51,7 @@ let pseudoregs_for_operation op arg res =
(* Two-address binary operations: arg.(0) and res.(0) must be the same *)
| Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf ->
([|res.(0); arg.(1)|], res)
| Ispecific(sop) ->
| Ispecific _ ->
( [| arg.(0); arg.(1); res.(0) |], [| res.(0) |])
(* One-address unary operations: arg.(0) and res.(0) must be the same *)
| Iintop_imm((Imul|Iand|Ior|Ixor), _) -> (res, res)
@ -64,7 +64,7 @@ inherit Selectgen.selector_generic as super
method is_immediate n = (n <= 2147483647) && (n >= -2147483648)
method select_addressing chunk exp =
method select_addressing _chunk exp =
let (a, d) = select_addr exp in
(* 20-bit signed displacement *)
if d < 0x80000 && d >= -0x80000 then begin

32
asmcomp/selectgen.ml
View File

@ -27,7 +27,7 @@ type environment = (Ident.t, Reg.t array) Tbl.t
let oper_result_type = function
Capply(ty, _) -> ty
| Cextcall(s, ty, alloc, _) -> ty
| Cextcall(_s, ty, _alloc, _) -> ty
| Cload c ->
begin match c with
| Word_val -> typ_val
@ -35,7 +35,7 @@ let oper_result_type = function
| _ -> typ_int
end
| Calloc -> typ_val
| Cstore (c, _) -> typ_void
| Cstore _ -> typ_void
| Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi |
Cand | Cor | Cxor | Clsl | Clsr | Casr |
Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int
@ -69,11 +69,11 @@ let size_expr env exp =
end
| Ctuple el ->
List.fold_right (fun e sz -> size localenv e + sz) el 0
| Cop(op, args) ->
| Cop(op, _) ->
size_machtype(oper_result_type op)
| Clet(id, arg, body) ->
size (Tbl.add id (size localenv arg) localenv) body
| Csequence(e1, e2) ->
| Csequence(_e1, e2) ->
size localenv e2
| _ ->
fatal_error "Selection.size_expr"
@ -136,7 +136,7 @@ let join opt_r1 seq1 opt_r2 seq2 =
let join_array rs =
let some_res = ref None in
for i = 0 to Array.length rs - 1 do
let (r, s) = rs.(i) in
let (r, _) = rs.(i) in
if r <> None then some_res := r
done;
match !some_res with
@ -190,7 +190,7 @@ method is_simple_expr = function
| Cconst_natpointer _ -> true
| Cvar _ -> true
| Ctuple el -> List.for_all self#is_simple_expr el
| Clet(id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body
| Clet(_id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body
| Csequence(e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2
| Cop(op, args) ->
begin match op with
@ -251,9 +251,9 @@ method mark_instr = function
method select_operation op args =
match (op, args) with
(Capply(ty, dbg), Cconst_symbol s :: rem) -> (Icall_imm s, rem)
| (Capply(ty, dbg), _) -> (Icall_ind, args)
| (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args)
(Capply _, Cconst_symbol s :: rem) -> (Icall_imm s, rem)
| (Capply _, _) -> (Icall_ind, args)
| (Cextcall(s, _ty, alloc, _dbg), _) -> (Iextcall(s, alloc), args)
| (Cload chunk, [arg]) ->
let (addr, eloc) = self#select_addressing chunk arg in
(Iload(chunk, addr), [eloc])
@ -505,7 +505,7 @@ method emit_expr env exp =
self#insert_debug (Iraise k) dbg rd [||];
None
end
| Cop(Ccmpf comp, args) ->
| Cop(Ccmpf _, _) ->
self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0))
| Cop(op, args) ->
begin match self#emit_parts_list env args with
@ -556,7 +556,7 @@ method emit_expr env exp =
| Csequence(e1, e2) ->
begin match self#emit_expr env e1 with
None -> None
| Some r1 -> self#emit_expr env e2
| Some _ -> self#emit_expr env e2
end
| Cifthenelse(econd, eif, eelse) ->
let (cond, earg) = self#select_condition econd in
@ -577,12 +577,12 @@ method emit_expr env exp =
let rscases = Array.map (self#emit_sequence env) ecases in
let r = join_array rscases in
self#insert (Iswitch(index,
Array.map (fun (r, s) -> s#extract) rscases))
Array.map (fun (_, s) -> s#extract) rscases))
rsel [||];
r
end
| Cloop(ebody) ->
let (rarg, sbody) = self#emit_sequence env ebody in
let (_rarg, sbody) = self#emit_sequence env ebody in
self#insert (Iloop(sbody#extract)) [||] [||];
Some [||]
| Ccatch(nfail, ids, e1, e2) ->
@ -796,7 +796,7 @@ method emit_tail env exp =
| Csequence(e1, e2) ->
begin match self#emit_expr env e1 with
None -> ()
| Some r1 -> self#emit_tail env e2
| Some _ -> self#emit_tail env e2
end
| Cifthenelse(econd, eif, eelse) ->
let (cond, earg) = self#select_condition econd in
@ -868,7 +868,7 @@ method emit_fundecl f =
let loc_arg = Proc.loc_parameters rarg in
let env =
List.fold_right2
(fun (id, ty) r env -> Tbl.add id r env)
(fun (id, _ty) r env -> Tbl.add id r env)
f.Cmm.fun_args rargs Tbl.empty in
self#insert_moves loc_arg rarg;
self#emit_tail env f.Cmm.fun_body;
@ -890,7 +890,7 @@ end
let is_tail_call nargs =
assert (Reg.dummy.typ = Int);
let args = Array.make (nargs + 1) Reg.dummy in
let (loc_arg, stack_ofs) = Proc.loc_arguments args in
let (_loc_arg, stack_ofs) = Proc.loc_arguments args in
stack_ofs = 0
let _ =

2
asmcomp/sparc/CSE.ml
View File

@ -18,7 +18,7 @@
open Mach
open CSEgen
class cse = object (self)
class cse = object
inherit cse_generic (* as super *)

6
asmcomp/sparc/arch.ml
View File

@ -63,8 +63,8 @@ let offset_addressing addr delta =
| Iindexed n -> Iindexed(n + delta)
let num_args_addressing = function
Ibased(s, n) -> 0
| Iindexed n -> 1
Ibased _ -> 0
| Iindexed _ -> 1
(* Printing operations and addressing modes *)
@ -77,5 +77,5 @@ let print_addressing printreg addr ppf arg =
let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
fprintf ppf "%a%s" printreg arg.(0) idx
let print_specific_operation printreg op ppf arg =
let print_specific_operation _printreg _op _ppf _arg =
Misc.fatal_error "Arch_sparc.print_specific_operation"

16
asmcomp/sparc/emit.mlp
View File

@ -278,16 +278,16 @@ let rec emit_instr i dslot =
| Lop(Imove | Ispill | Ireload) ->
let src = i.arg.(0) and dst = i.res.(0) in
begin match (src, dst) with
{loc = Reg rs; typ = (Int | Addr | Val)}, {loc = Reg rd} ->
{loc = Reg _; typ = (Int | Addr | Val)}, {loc = Reg _} ->
` mov {emit_reg src}, {emit_reg dst}\n`
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
| {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
if !arch_version = SPARC_V9 then
` fmovd {emit_reg src}, {emit_reg dst}\n`
else begin
` fmovs {emit_reg src}, {emit_reg dst}\n`;
` fmovs {emit_reg(next_in_pair src)}, {emit_reg(next_in_pair dst)}\n`
end
| {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = (Int | Addr | Val)} ->
| {loc = Reg _; typ = Float}, {loc = Reg _; typ = (Int | Addr | Val)} ->
(* This happens when calling C functions and passing a float arg
in %o0...%o5 *)
` sub %sp, 8, %sp\n`;
@ -304,13 +304,13 @@ let rec emit_instr i dslot =
fatal_error "Emit: Imove Float [| _; _ |]"
end;
` add %sp, 8, %sp\n`
| {loc = Reg rs; typ = (Int | Addr | Val)}, {loc = Stack sd} ->
| {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Stack _} ->
` st {emit_reg src}, {emit_stack dst}\n`
| {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
| {loc = Reg _; typ = Float}, {loc = Stack _} ->
` std {emit_reg src}, {emit_stack dst}\n`
| {loc = Stack ss; typ = (Int | Addr | Val)}, {loc = Reg rd} ->
| {loc = Stack _; typ = (Int | Addr | Val)}, {loc = Reg _} ->
` ld {emit_stack src}, {emit_reg dst}\n`
| {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
| {loc = Stack _; typ = Float}, {loc = Reg _} ->
` ldd {emit_stack src}, {emit_reg dst}\n`
| (_, _) ->
fatal_error "Emit: Imove"
@ -514,7 +514,7 @@ let rec emit_instr i dslot =
` st %f30, [%sp + 96]\n`;
` ld [%sp + 96], {emit_reg i.res.(0)}\n`;
` add %sp, 8, %sp\n`
| Lop(Ispecific sop) ->
| Lop(Ispecific _) ->
assert false
| Lreloadretaddr ->
let n = frame_size() in

10
asmcomp/sparc/proc.ml
View File

@ -134,16 +134,16 @@ let calling_conventions first_int last_int first_float last_float make_stack
let incoming ofs = Incoming ofs
let outgoing ofs = Outgoing ofs
let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
let max_arguments_for_tailcalls = 10
let loc_arguments arg =
calling_conventions 6 15 100 105 outgoing arg
let loc_parameters arg =
let (loc, ofs) = calling_conventions 6 15 100 105 incoming arg in loc
let (loc, _ofs) = calling_conventions 6 15 100 105 incoming arg in loc
let loc_results res =
let (loc, ofs) = calling_conventions 0 5 100 105 not_supported res in loc
let (loc, _ofs) = calling_conventions 0 5 100 105 not_supported res in loc
(* On the Sparc, all arguments to C functions, even floating-point arguments,
are passed in %o0..%o5, then on the stack *)
@ -188,13 +188,13 @@ let loc_external_arguments arg =
(loc, Misc.align (!ofs + 4) 8)
let loc_external_results res =
let (loc, ofs) = calling_conventions 0 1 100 100 not_supported res in loc
let (loc, _ofs) = calling_conventions 0 1 100 100 not_supported res in loc
let loc_exn_bucket = phys_reg 0 (* $o0 *)
(* Volatile registers: none *)
let regs_are_volatile rs = false
let regs_are_volatile _rs = false
(* Registers destroyed by operations *)

2
asmcomp/sparc/selection.ml
View File

@ -26,7 +26,7 @@ inherit Selectgen.selector_generic as super
method is_immediate n = (n <= 4095) && (n >= -4096)
method select_addressing chunk = function
method select_addressing _chunk = function
Cconst_symbol s ->
(Ibased(s, 0), Ctuple [])
| Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n]) ->

2
asmcomp/spill.ml
View File

@ -72,7 +72,7 @@ let add_superpressure_regs op live_regs res_regs spilled =
(fun r ->
if Reg.Set.mem r spilled then () else begin
match r.loc with
Stack s -> ()
Stack _ -> ()
| _ -> let c = Proc.register_class r in
pressure.(c) <- pressure.(c) + 1
end)

10
asmcomp/split.ml
View File

@ -87,8 +87,8 @@ let identify_sub sub1 sub2 reg =
let merge_substs sub1 sub2 i =
match (sub1, sub2) with
(None, None) -> None
| (Some s1, None) -> sub1
| (None, Some s2) -> sub2
| (Some _, None) -> sub1
| (None, Some _) -> sub2
| (Some s1, Some s2) ->
Reg.Set.iter (identify_sub s1 s2) (Reg.add_set_array i.live i.arg);
sub1
@ -155,9 +155,9 @@ let rec rename i sub =
| Iswitch(index, cases) ->
let new_sub_cases = Array.map (fun c -> rename c sub) cases in
let sub_merge =
merge_subst_array (Array.map (fun (n, s) -> s) new_sub_cases) i.next in
merge_subst_array (Array.map (fun (_n, s) -> s) new_sub_cases) i.next in
let (new_next, sub_next) = rename i.next sub_merge in
(instr_cons (Iswitch(index, Array.map (fun (n, s) -> n) new_sub_cases))
(instr_cons (Iswitch(index, Array.map (fun (n, _s) -> n) new_sub_cases))
(subst_regs i.arg sub) [||] new_next,
sub_next)
| Iloop(body) ->
@ -206,7 +206,7 @@ let fundecl f =
reset ();
let new_args = Array.copy f.fun_args in
let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in
let (new_body, _sub_body) = rename f.fun_body (Some Reg.Map.empty) in
repres_regs new_args;
set_repres new_body;
equiv_classes := Reg.Map.empty;

2
asmcomp/strmatch.ml
View File

@ -368,7 +368,7 @@ module Make(I:I) = struct
(* Module entry point *)
let catch arg k = match arg with
| Cexit (e,[]) -> k arg
| Cexit (_e,[]) -> k arg
| _ ->
let e = next_raise_count () in
Ccatch (e,[],k (Cexit (e,[])),arg)

60
bytecomp/bytegen.ml
View File

@ -143,7 +143,7 @@ let rec check_recordwith_updates id e =
;;
let rec size_of_lambda = function
| Lfunction{kind; params; body} as funct ->
| Lfunction{params} as funct ->
RHS_function (1 + IdentSet.cardinal(free_variables funct),
List.length params)
| Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body)
@ -153,21 +153,21 @@ let rec size_of_lambda = function
| Record_float -> RHS_floatblock size
| Record_extension -> RHS_block (size + 1)
end
| Llet(str, id, arg, body) -> size_of_lambda body
| Lletrec(bindings, body) -> size_of_lambda body
| Lprim(Pmakeblock(tag, mut), args) -> RHS_block (List.length args)
| Llet(_str, _id, _arg, body) -> size_of_lambda body
| Lletrec(_bindings, body) -> size_of_lambda body
| Lprim(Pmakeblock _, args) -> RHS_block (List.length args)
| Lprim (Pmakearray ((Paddrarray|Pintarray), _), args) ->
RHS_block (List.length args)
| Lprim (Pmakearray (Pfloatarray, _), args) ->
RHS_floatblock (List.length args)
| Lprim (Pmakearray (Pgenarray, _), args) -> assert false
| Lprim (Pduprecord ((Record_regular | Record_inlined _), size), args) ->
| Lprim (Pmakearray (Pgenarray, _), _) -> assert false
| Lprim (Pduprecord ((Record_regular | Record_inlined _), size), _) ->
RHS_block size
| Lprim (Pduprecord (Record_extension, size), args) ->
| Lprim (Pduprecord (Record_extension, size), _) ->
RHS_block (size + 1)
| Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size
| Lprim (Pduprecord (Record_float, size), _) -> RHS_floatblock size
| Levent (lam, _) -> size_of_lambda lam
| Lsequence (lam, lam') -> size_of_lambda lam'
| Lsequence (_lam, lam') -> size_of_lambda lam'
| _ -> RHS_nonrec
(**** Merging consecutive events ****)
@ -310,9 +310,9 @@ let comp_primitive p args =
Pgetglobal id -> Kgetglobal id
| Psetglobal id -> Ksetglobal id
| Pintcomp cmp -> Kintcomp cmp
| Pmakeblock(tag, mut) -> Kmakeblock(List.length args, tag)
| Pmakeblock(tag, _mut) -> Kmakeblock(List.length args, tag)
| Pfield n -> Kgetfield n
| Psetfield(n, ptr, _init) -> Ksetfield n
| Psetfield(n, _ptr, _init) -> Ksetfield n
| Pfloatfield n -> Kgetfloatfield n
| Psetfloatfield (n, _init) -> Ksetfloatfield n
| Pduprecord _ -> Kccall("caml_obj_dup", 1)
@ -356,7 +356,7 @@ let comp_primitive p args =
| Pstring_set_16(_) -> Kccall("caml_string_set16", 3)
| Pstring_set_32(_) -> Kccall("caml_string_set32", 3)
| Pstring_set_64(_) -> Kccall("caml_string_set64", 3)
| Parraylength kind -> Kvectlength
| Parraylength _ -> Kvectlength
| Parrayrefs Pgenarray -> Kccall("caml_array_get", 2)
| Parrayrefs Pfloatarray -> Kccall("caml_array_get_float", 2)
| Parrayrefs _ -> Kccall("caml_array_get_addr", 2)
@ -402,12 +402,12 @@ let comp_primitive p args =
| Plslbint bi -> comp_bint_primitive bi "shift_left" args
| Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args
| Pasrbint bi -> comp_bint_primitive bi "shift_right" args
| Pbintcomp(bi, Ceq) -> Kccall("caml_equal", 2)
| Pbintcomp(bi, Cneq) -> Kccall("caml_notequal", 2)
| Pbintcomp(bi, Clt) -> Kccall("caml_lessthan", 2)
| Pbintcomp(bi, Cgt) -> Kccall("caml_greaterthan", 2)
| Pbintcomp(bi, Cle) -> Kccall("caml_lessequal", 2)
| Pbintcomp(bi, Cge) -> Kccall("caml_greaterequal", 2)
| Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2)
| Pbintcomp(_, Cneq) -> Kccall("caml_notequal", 2)
| Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2)
| Pbintcomp(_, Cgt) -> Kccall("caml_greaterthan", 2)
| Pbintcomp(_, Cle) -> Kccall("caml_lessequal", 2)
| Pbintcomp(_, Cge) -> Kccall("caml_greaterequal", 2)
| Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ string_of_int n, n + 1)
| Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ string_of_int n, n + 2)
| Pbigarraydim(n) -> Kccall("caml_ba_dim_" ^ string_of_int n, 1)
@ -497,7 +497,7 @@ let rec comp_expr env exp sz cont =
comp_args env args' (sz + 3)
(getmethod :: Kapply nargs :: cont1)
end
| Lfunction{kind; params; body} -> (* assume kind = Curried *)
| Lfunction{params; body} -> (* assume kind = Curried *)
let lbl = new_label() in
let fv = IdentSet.elements(free_variables exp) in
let to_compile =
@ -506,7 +506,7 @@ let rec comp_expr env exp sz cont =
Stack.push to_compile functions_to_compile;
comp_args env (List.map (fun n -> Lvar n) fv) sz
(Kclosure(lbl, List.length fv) :: cont)
| Llet(str, id, arg, body) ->
| Llet(_str, id, arg, body) ->
comp_expr env arg sz
(Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1)
(add_pop 1 cont))
@ -517,10 +517,10 @@ let rec comp_expr env exp sz cont =
(* let rec of functions *)
let fv =
IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in
let rec_idents = List.map (fun (id, lam) -> id) decl in
let rec_idents = List.map (fun (id, _lam) -> id) decl in
let rec comp_fun pos = function
[] -> []
| (id, Lfunction{kind; params; body}) :: rem ->
| (_id, Lfunction{params; body}) :: rem ->
let lbl = new_label() in
let to_compile =
{ params = params; body = body; label = lbl; free_vars = fv;
@ -538,39 +538,39 @@ let rec comp_expr env exp sz cont =
List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in
let rec comp_init new_env sz = function
| [] -> comp_nonrec new_env sz ndecl decl_size
| (id, exp, RHS_floatblock blocksize) :: rem ->
| (id, _exp, RHS_floatblock blocksize) :: rem ->
Kconst(Const_base(Const_int blocksize)) ::
Kccall("caml_alloc_dummy_float", 1) :: Kpush ::
comp_init (add_var id (sz+1) new_env) (sz+1) rem
| (id, exp, RHS_block blocksize) :: rem ->
| (id, _exp, RHS_block blocksize) :: rem ->
Kconst(Const_base(Const_int blocksize)) ::
Kccall("caml_alloc_dummy", 1) :: Kpush ::
comp_init (add_var id (sz+1) new_env) (sz+1) rem
| (id, exp, RHS_function (blocksize,arity)) :: rem ->
| (id, _exp, RHS_function (blocksize,arity)) :: rem ->
Kconst(Const_base(Const_int arity)) ::
Kpush ::
Kconst(Const_base(Const_int blocksize)) ::
Kccall("caml_alloc_dummy_function", 2) :: Kpush ::
comp_init (add_var id (sz+1) new_env) (sz+1) rem
| (id, exp, RHS_nonrec) :: rem ->
| (id, _exp, RHS_nonrec) :: rem ->
Kconst(Const_base(Const_int 0)) :: Kpush ::
comp_init (add_var id (sz+1) new_env) (sz+1) rem
and comp_nonrec new_env sz i = function
| [] -> comp_rec new_env sz ndecl decl_size
| (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _))
| (_id, _exp, (RHS_block _ | RHS_floatblock _ | RHS_function _))
:: rem ->
comp_nonrec new_env sz (i-1) rem
| (id, exp, RHS_nonrec) :: rem ->
| (_id, exp, RHS_nonrec) :: rem ->
comp_expr new_env exp sz
(Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem)
and comp_rec new_env sz i = function
| [] -> comp_expr new_env body sz (add_pop ndecl cont)
| (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _))
| (_id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _))
:: rem ->
comp_expr new_env exp sz
(Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) ::
comp_rec new_env sz (i-1) rem)
| (id, exp, RHS_nonrec) :: rem ->
| (_id, _exp, RHS_nonrec) :: rem ->
comp_rec new_env sz (i-1) rem
in
comp_init env sz decl_size

6
bytecomp/bytelink.ml
View File

@ -89,19 +89,19 @@ module IdentSet = Lambda.IdentSet
let missing_globals = ref IdentSet.empty
let is_required (rel, pos) =
let is_required (rel, _pos) =
match rel with
Reloc_setglobal id ->
IdentSet.mem id !missing_globals
| _ -> false
let add_required (rel, pos) =
let add_required (rel, _pos) =
match rel with
Reloc_getglobal id ->
missing_globals := IdentSet.add id !missing_globals
| _ -> ()
let remove_required (rel, pos) =
let remove_required (rel, _pos) =
match rel with
Reloc_setglobal id ->
missing_globals := IdentSet.remove id !missing_globals

4
bytecomp/bytepackager.ml
View File

@ -186,7 +186,7 @@ let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs
let build_global_target oc target_name members mapping pos coercion =
let components =
List.map2
(fun m (id1, id2) ->
(fun m (_id1, id2) ->
match m.pm_kind with
| PM_intf -> None
| PM_impl _ -> Some id2)
@ -232,7 +232,7 @@ let package_object_files ppf files targetfile targetname coercion =
let pos_final = pos_out oc in
let imports =
List.filter
(fun (name, crc) -> not (List.mem name unit_names))
(fun (name, _crc) -> not (List.mem name unit_names))
(Bytelink.extract_crc_interfaces()) in
let compunit =
{ cu_name = targetname;

2
bytecomp/bytesections.ml
View File

@ -94,7 +94,7 @@ let read_section_struct ic name =
let pos_first_section ic =
in_channel_length ic - 16 - 8 * List.length !section_table -
List.fold_left (fun total (name, len) -> total + len) 0 !section_table
List.fold_left (fun total (_name, len) -> total + len) 0 !section_table
let reset () =
section_table := [];

64
bytecomp/lambda.ml
View File

@ -329,7 +329,7 @@ let make_key e =
Lsequence (tr_rec env e1,tr_rec env e2)
| Lassign (x,e) ->
Lassign (x,tr_rec env e)
| Lsend (m,e1,e2,es,loc) ->
| Lsend (m,e1,e2,es,_loc) ->
Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none)
| Lifused (id,e) -> Lifused (id,tr_rec env e)
| Lletrec _|Lfunction _
@ -365,7 +365,7 @@ let name_lambda strict arg fn =
let name_lambda_list args fn =
let rec name_list names = function
[] -> fn (List.rev names)
| (Lvar id as arg) :: rem ->
| (Lvar _ as arg) :: rem ->
name_list (arg :: names) rem
| arg :: rem ->
let id = Ident.create "let" in
@ -382,19 +382,19 @@ let iter f = function
| Lconst _ -> ()
| Lapply{ap_func = fn; ap_args = args} ->
f fn; List.iter f args
| Lfunction{kind; params; body} ->
| Lfunction{body} ->
f body
| Llet(str, id, arg, body) ->
| Llet(_str, _id, arg, body) ->
f arg; f body
| Lletrec(decl, body) ->
f body;
List.iter (fun (id, exp) -> f exp) decl
| Lprim(p, args) ->
List.iter (fun (_id, exp) -> f exp) decl
| Lprim(_p, args) ->
List.iter f args
| Lswitch(arg, sw) ->
f arg;
List.iter (fun (key, case) -> f case) sw.sw_consts;
List.iter (fun (key, case) -> f case) sw.sw_blocks;
List.iter (fun (_key, case) -> f case) sw.sw_consts;
List.iter (fun (_key, case) -> f case) sw.sw_blocks;
iter_opt f sw.sw_failaction
| Lstringswitch (arg,cases,default) ->
f arg ;
@ -402,9 +402,9 @@ let iter f = function
iter_opt f default
| Lstaticraise (_,args) ->
List.iter f args
| Lstaticcatch(e1, (_,vars), e2) ->
| Lstaticcatch(e1, _, e2) ->
f e1; f e2
| Ltrywith(e1, exn, e2) ->
| Ltrywith(e1, _, e2) ->
f e1; f e2
| Lifthenelse(e1, e2, e3) ->
f e1; f e2; f e3
@ -412,15 +412,15 @@ let iter f = function
f e1; f e2
| Lwhile(e1, e2) ->
f e1; f e2
| Lfor(v, e1, e2, dir, e3) ->
| Lfor(_v, e1, e2, _dir, e3) ->
f e1; f e2; f e3
| Lassign(id, e) ->
| Lassign(_, e) ->
f e
| Lsend (k, met, obj, args, _) ->
| Lsend (_k, met, obj, args, _) ->
List.iter f (met::obj::args)
| Levent (lam, evt) ->
| Levent (lam, _evt) ->
f lam
| Lifused (v, e) ->
| Lifused (_v, e) ->
f e
@ -436,19 +436,19 @@ let free_ids get l =
iter free l;
fv := List.fold_right IdentSet.add (get l) !fv;
match l with
Lfunction{kind; params; body} ->
Lfunction{params} ->
List.iter (fun param -> fv := IdentSet.remove param !fv) params
| Llet(str, id, arg, body) ->
| Llet(_str, id, _arg, _body) ->
fv := IdentSet.remove id !fv
| Lletrec(decl, body) ->
List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl
| Lstaticcatch(e1, (_,vars), e2) ->
| Lletrec(decl, _body) ->
List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl
| Lstaticcatch(_e1, (_,vars), _e2) ->
List.iter (fun id -> fv := IdentSet.remove id !fv) vars
| Ltrywith(e1, exn, e2) ->
| Ltrywith(_e1, exn, _e2) ->
fv := IdentSet.remove exn !fv
| Lfor(v, e1, e2, dir, e3) ->
| Lfor(v, _e1, _e2, _dir, _e3) ->
fv := IdentSet.remove v !fv
| Lassign(id, e) ->
| Lassign(id, _e) ->
fv := IdentSet.add id !fv
| Lvar _ | Lconst _ | Lapply _
| Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _
@ -460,7 +460,7 @@ let free_variables l =
free_ids (function Lvar id -> [id] | _ -> []) l
let free_methods l =
free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l
free_ids (function Lsend(Self, Lvar meth, _, _, _) -> [meth] | _ -> []) l
(* Check if an action has a "when" guard *)
let raise_count = ref 0
@ -479,9 +479,9 @@ let next_negative_raise_count () =
let staticfail = Lstaticraise (0,[])
let rec is_guarded = function
| Lifthenelse( cond, body, Lstaticraise (0,[])) -> true
| Llet(str, id, lam, body) -> is_guarded body
| Levent(lam, ev) -> is_guarded lam
| Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true
| Llet(_str, _id, _lam, body) -> is_guarded body
| Levent(lam, _ev) -> is_guarded lam
| _ -> false
let rec patch_guarded patch = function
@ -498,9 +498,9 @@ let rec patch_guarded patch = function
let rec transl_normal_path = function
Pident id ->
if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
| Pdot(p, s, pos) ->
| Pdot(p, _s, pos) ->
Lprim(Pfield pos, [transl_normal_path p])
| Papply(p1, p2) ->
| Papply _ ->
fatal_error "Lambda.transl_path"
(* Translation of value identifiers *)
@ -526,7 +526,7 @@ let subst_lambda s lam =
let rec subst = function
Lvar id as l ->
begin try Ident.find_same id s with Not_found -> l end
| Lconst sc as l -> l
| Lconst _ as l -> l
| Lapply ap ->
Lapply{ap with ap_func = subst ap.ap_func;
ap_args = List.map subst ap.ap_args}
@ -566,8 +566,8 @@ let subst_lambda s lam =
let rec map f lam =
let lam =
match lam with
| Lvar v -> lam
| Lconst cst -> lam
| Lvar _ -> lam
| Lconst _ -> lam
| Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall;
ap_inlined; ap_specialised } ->
Lapply {

56
bytecomp/matching.ml
View File

@ -72,7 +72,7 @@ let lshift {left=left ; right=right} = match right with
| _ -> assert false
let lforget {left=left ; right=right} = match right with
| x::xs -> {left=omega::left ; right=xs}
| _::xs -> {left=omega::left ; right=xs}
| _ -> assert false
let rec small_enough n = function
@ -174,7 +174,7 @@ let ctx_matcher p =
| Cstr_extension _ ->
let nargs = List.length omegas in
(fun q rem -> match q.pat_desc with
| Tpat_construct (_, cstr',args)
| Tpat_construct (_, _cstr',args)
when List.length args = nargs ->
p,args @ rem
| Tpat_any -> p,omegas @ rem
@ -396,7 +396,7 @@ type pm_half_compiled_info =
let pretty_cases cases =
List.iter
(fun ((ps),l) ->
(fun (ps,_l) ->
List.iter
(fun p ->
Parmatch.top_pretty Format.str_formatter p ;
@ -1078,7 +1078,7 @@ and precompile_var args cls def k = match args with
| [] -> assert false
| _::((Lvar v as av,_) as arg)::rargs ->
begin match cls with
| [ps,_] -> (* as splitted as it can *)
| [_] -> (* as splitted as it can *)
dont_precompile_var args cls def k
| _ ->
(* Precompile *)
@ -1113,7 +1113,7 @@ and dont_precompile_var args cls def k =
and is_exc p = match p.pat_desc with
| Tpat_or (p1,p2,_) -> is_exc p1 || is_exc p2
| Tpat_alias (p,v,_) -> is_exc p
| Tpat_alias (p,_,_) -> is_exc p
| Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true
| _ -> false
@ -1325,7 +1325,7 @@ let matcher_constr cstr = match cstr.cstr_arity with
| None, None -> raise NoMatch
| Some r1, None -> r1
| None, Some r2 -> r2
| Some (a1::rem1), Some (a2::_) ->
| Some (a1::_), Some (a2::_) ->
{a1 with
pat_loc = Location.none ;
pat_desc = Tpat_or (a1, a2, None)}::
@ -1347,7 +1347,7 @@ let matcher_constr cstr = match cstr.cstr_arity with
let make_constr_matching p def ctx = function
[] -> fatal_error "Matching.make_constr_matching"
| ((arg, mut) :: argl) ->
| ((arg, _mut) :: argl) ->
let cstr = pat_as_constr p in
let newargs =
if cstr.cstr_inlined <> None then
@ -1387,7 +1387,7 @@ let rec matcher_variant_const lab p rem = match p.pat_desc with
let make_variant_matching_constant p lab def ctx = function
[] -> fatal_error "Matching.make_variant_matching_constant"
| ((arg, mut) :: argl) ->
| (_ :: argl) ->
let def = make_default (matcher_variant_const lab) def
and ctx = filter_ctx p ctx in
{pm={ cases = []; args = argl ; default=def} ;
@ -1403,7 +1403,7 @@ let matcher_variant_nonconst lab p rem = match p.pat_desc with
let make_variant_matching_nonconst p lab def ctx = function
[] -> fatal_error "Matching.make_variant_matching_nonconst"
| ((arg, mut) :: argl) ->
| ((arg, _mut) :: argl) ->
let def = make_default (matcher_variant_nonconst lab) def
and ctx = filter_ctx p ctx in
{pm=
@ -1431,7 +1431,7 @@ let divide_variant row ctx {cases = cl; args = al; default=def} =
add (make_variant_matching_nonconst p lab def ctx) variants
(=) (Cstr_block tag) (pat :: patl, action) al
end
| cl -> []
| _ -> []
in
divide cl
@ -1562,7 +1562,7 @@ let inline_lazy_force arg loc =
let make_lazy_matching def = function
[] -> fatal_error "Matching.make_lazy_matching"
| (arg,mut) :: argl ->
| (arg,_mut) :: argl ->
{ cases = [];
args =
(inline_lazy_force arg Location.none, Strict) :: argl;
@ -1591,7 +1591,7 @@ let matcher_tuple arity p rem = match p.pat_desc with
let make_tuple_matching arity def = function
[] -> fatal_error "Matching.make_tuple_matching"
| (arg, mut) :: argl ->
| (arg, _mut) :: argl ->
let rec make_args pos =
if pos >= arity
then argl
@ -1628,7 +1628,7 @@ let matcher_record num_fields p rem = match p.pat_desc with
let make_record_matching all_labels def = function
[] -> fatal_error "Matching.make_record_matching"
| ((arg, mut) :: argl) ->
| ((arg, _mut) :: argl) ->
let rec make_args pos =
if pos >= Array.length all_labels then argl else begin
let lbl = all_labels.(pos) in
@ -1675,7 +1675,7 @@ let matcher_array len p rem = match p.pat_desc with
let make_array_matching kind p def ctx = function
| [] -> fatal_error "Matching.make_array_matching"
| ((arg, mut) :: argl) ->
| ((arg, _mut) :: argl) ->
let len = get_key_array p in
let rec make_args pos =
if pos >= len
@ -2018,7 +2018,7 @@ let get_edges low high l = match l with
let as_interval_canfail fail low high l =
let store = StoreExp.mk_store () in
let do_store tag act =
let do_store _tag act =
let i = store.act_store act in
(*
@ -2188,7 +2188,7 @@ let mk_failaction_pos partial seen ctx defs =
| _,(pss,idef)::rem ->
let now, later =
List.partition
(fun (p,p_ctx) -> ctx_match p_ctx pss) to_test in
(fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in
match now with
| [] -> scan_def env to_test rem
| _ -> scan_def ((List.map fst now,idef)::env) later rem in
@ -2219,7 +2219,7 @@ let mk_failaction_pos partial seen ctx defs =
end
let combine_constant arg cst partial ctx def
(const_lambda_list, total, pats) =
(const_lambda_list, total, _pats) =
let fail, local_jumps =
mk_failaction_neg partial ctx def in
let lambda1 =
@ -2411,7 +2411,7 @@ let call_switcher_variant_constr fail arg int_lambda_list =
call_switcher
fail (Lvar v) min_int max_int int_lambda_list)
let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
let combine_variant row arg partial ctx def (tag_lambda_list, total1, _pats) =
let row = Btype.row_repr row in
let num_constr = ref 0 in
if row.row_closed then
@ -2439,7 +2439,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
| None, Some act -> act
| _,_ ->
match (consts, nonconsts) with
| ([n, act1], [m, act2]) when fail=None ->
| ([_, act1], [_, act2]) when fail=None ->
test_int_or_block arg act1 act2
| (_, []) -> (* One can compare integers and pointers *)
make_test_sequence_variant_constant fail arg consts
@ -2464,7 +2464,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
let combine_array arg kind partial ctx def
(len_lambda_list, total1, pats) =
(len_lambda_list, total1, _pats) =
let fail, local_jumps = mk_failaction_neg partial ctx def in
let lambda1 =
let newvar = Ident.create "len" in
@ -2491,7 +2491,7 @@ let rec event_branch repr lam =
| (Llet(str, id, lam, body), _) ->
Llet(str, id, lam, event_branch repr body)
| Lstaticraise _,_ -> lam
| (_, Some r) ->
| (_, Some _) ->
Printlambda.lambda Format.str_formatter lam ;
fatal_error
("Matching.event_branch: "^Format.flush_str_formatter ())
@ -2663,10 +2663,10 @@ let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs =
(* To find reasonable names for variables *)
let rec name_pattern default = function
(pat :: patl, action) :: rem ->
(pat :: _, _) :: rem ->
begin match pat.pat_desc with
Tpat_var (id, _) -> id
| Tpat_alias(p, id, _) -> id
| Tpat_alias(_, id, _) -> id
| _ -> name_pattern default rem
end
| _ -> Ident.create default
@ -2760,7 +2760,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
compile_no_test
(divide_lazy (normalize_pat pat))
ctx_combine repr partial ctx pm
| Tpat_variant(lab, _, row) ->
| Tpat_variant(_, _, row) ->
compile_test (compile_match repr partial) partial
(divide_variant !row)
(combine_variant !row arg partial)
@ -2879,7 +2879,7 @@ let check_total total lambda i handler_fun =
Lstaticcatch(lambda, (i,[]), handler_fun())
end
let compile_matching loc repr handler_fun arg pat_act_list partial =
let compile_matching repr handler_fun arg pat_act_list partial =
let partial = check_partial pat_act_list partial in
match partial with
| Partial ->
@ -2915,16 +2915,16 @@ let partial_function loc () =
Const_base(Const_int char)]))])])
let for_function loc repr param pat_act_list partial =
compile_matching loc repr (partial_function loc) param pat_act_list partial
compile_matching repr (partial_function loc) param pat_act_list partial
(* In the following two cases, exhaustiveness info is not available! *)
let for_trywith param pat_act_list =
compile_matching Location.none None
compile_matching None
(fun () -> Lprim(Praise Raise_reraise, [param]))
param pat_act_list Partial
let simple_for_let loc param pat body =
compile_matching loc None (partial_function loc) param [pat, body] Partial
compile_matching None (partial_function loc) param [pat, body] Partial
(* Optimize binding of immediate tuples

4
bytecomp/printlambda.ml
View File

@ -222,9 +222,9 @@ let primitive ppf = function
| Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi
| Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi
| Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi
| Pbigarrayref(unsafe, n, kind, layout) ->
| Pbigarrayref(unsafe, _n, kind, layout) ->
print_bigarray "get" unsafe kind ppf layout
| Pbigarrayset(unsafe, n, kind, layout) ->
| Pbigarrayset(unsafe, _n, kind, layout) ->
print_bigarray "set" unsafe kind ppf layout
| Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n
| Pstring_load_16(unsafe) ->

56
bytecomp/simplif.ml
View File

@ -26,11 +26,11 @@ exception Real_reference
let rec eliminate_ref id = function
Lvar v as lam ->
if Ident.same v id then raise Real_reference else lam
| Lconst cst as lam -> lam
| Lconst _ as lam -> lam
| Lapply ap ->
Lapply{ap with ap_func = eliminate_ref id ap.ap_func;
ap_args = List.map (eliminate_ref id) ap.ap_args}
| Lfunction{kind; params; body} as lam ->
| Lfunction _ as lam ->
if IdentSet.mem id (free_variables lam)
then raise Real_reference
else lam
@ -111,13 +111,13 @@ let simplify_exits lam =
let rec count = function
| (Lvar _| Lconst _) -> ()
| Lapply ap -> count ap.ap_func; List.iter count ap.ap_args
| Lfunction{kind; params; body = l} -> count l
| Llet(str, v, l1, l2) ->
| Lfunction {body} -> count body
| Llet(_str, _v, l1, l2) ->
count l2; count l1
| Lletrec(bindings, body) ->
List.iter (fun (v, l) -> count l) bindings;
List.iter (fun (_v, l) -> count l) bindings;
count body
| Lprim(p, ll) -> List.iter count ll
| Lprim(_p, ll) -> List.iter count ll
| Lswitch(l, sw) ->
count_default sw ;
count l;
@ -150,15 +150,15 @@ let simplify_exits lam =
l2 will be removed, so don't count its exits *)
if count_exit i > 0 then
count l2
| Ltrywith(l1, v, l2) -> count l1; count l2
| Ltrywith(l1, _v, l2) -> count l1; count l2
| Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3
| Lsequence(l1, l2) -> count l1; count l2
| Lwhile(l1, l2) -> count l1; count l2
| Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3
| Lassign(v, l) -> count l
| Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll)
| Lfor(_, l1, l2, _dir, l3) -> count l1; count l2; count l3
| Lassign(_v, l) -> count l
| Lsend(_k, m, o, ll, _) -> List.iter count (m::o::ll)
| Levent(l, _) -> count l
| Lifused(v, l) -> count l
| Lifused(_v, l) -> count l
and count_default sw = match sw.sw_failaction with
| None -> ()
@ -267,7 +267,7 @@ let simplify_exits lam =
with
| Not_found -> Lstaticraise (i,ls)
end
| Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) ->
| Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) ->
Hashtbl.add subst i ([],simplif l2) ;
simplif l1
| Lstaticcatch (l1,(i,xs),l2) ->
@ -352,7 +352,7 @@ let simplify_lets lam =
() in
let rec count bv = function
| Lconst cst -> ()
| Lconst _ -> ()
| Lvar v ->
use_var bv v 1
| Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args}
@ -364,9 +364,9 @@ let simplify_lets lam =
count bv (beta_reduce params body args)
| Lapply{ap_func = l1; ap_args = ll} ->
count bv l1; List.iter (count bv) ll
| Lfunction{kind; params; body = l} ->
count Tbl.empty l
| Llet(str, v, Lvar w, l2) when optimize ->
| Lfunction {body} ->
count Tbl.empty body
| Llet(_str, v, Lvar w, l2) when optimize ->
(* v will be replaced by w in l2, so each occurrence of v in l2
increases w's refcount *)
count (bind_var bv v) l2;
@ -376,9 +376,9 @@ let simplify_lets lam =
(* If v is unused, l1 will be removed, so don't count its variables *)
if str = Strict || count_var v > 0 then count bv l1
| Lletrec(bindings, body) ->
List.iter (fun (v, l) -> count bv l) bindings;
List.iter (fun (_v, l) -> count bv l) bindings;
count bv body
| Lprim(p, ll) -> List.iter (count bv) ll
| Lprim(_p, ll) -> List.iter (count bv) ll
| Lswitch(l, sw) ->
count_default bv sw ;
count bv l;
@ -395,14 +395,14 @@ let simplify_lets lam =
end
| None -> ()
end
| Lstaticraise (i,ls) -> List.iter (count bv) ls
| Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2
| Ltrywith(l1, v, l2) -> count bv l1; count bv l2
| Lstaticraise (_i,ls) -> List.iter (count bv) ls
| Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2
| Ltrywith(l1, _v, l2) -> count bv l1; count bv l2
| Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3
| Lsequence(l1, l2) -> count bv l1; count bv l2
| Lwhile(l1, l2) -> count Tbl.empty l1; count Tbl.empty l2
| Lfor(_, l1, l2, dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3
| Lassign(v, l) ->
| Lfor(_, l1, l2, _dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3
| Lassign(_v, l) ->
(* Lalias-bound variables are never assigned, so don't increase
v's refcount *)
count bv l
@ -447,7 +447,7 @@ let simplify_lets lam =
with Not_found ->
l
end
| Lconst cst as l -> l
| Lconst _ as l -> l
| Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args}
when optimize && List.length params = List.length args ->
simplif (beta_reduce params body args)
@ -465,7 +465,7 @@ let simplify_lets lam =
| body ->
Lfunction{kind; params; body; attr}
end
| Llet(str, v, Lvar w, l2) when optimize ->
| Llet(_str, v, Lvar w, l2) when optimize ->
Hashtbl.add subst v (simplif (Lvar w));
simplif l2
| Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [linit]), lbody)
@ -481,12 +481,12 @@ let simplify_lets lam =
begin match count_var v with
0 -> simplif l2
| 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2
| n -> Llet(Alias, v, simplif l1, simplif l2)
| _ -> Llet(Alias, v, simplif l1, simplif l2)
end
| Llet(StrictOpt, v, l1, l2) ->
begin match count_var v with
0 -> simplif l2
| n -> mklet(Alias, v, simplif l1, simplif l2)
| _ -> mklet(Alias, v, simplif l1, simplif l2)
end
| Llet(kind, v, l1, l2) -> mklet(kind, v, simplif l1, simplif l2)
| Lletrec(bindings, body) ->
@ -531,7 +531,7 @@ let simplify_lets lam =
(* Tail call info in annotation files *)
let is_tail_native_heuristic : (int -> bool) ref =
ref (fun n -> true)
ref (fun _ -> true)
let rec emit_tail_infos is_tail lambda =
let call_kind args =

26
bytecomp/switch.ml
View File

@ -390,13 +390,13 @@ let rec opt_count top cases =
if lcases < !cut then
enum top cases
else if lcases < !more_cut then
heuristic top cases
heuristic cases
else
divide top cases in
divide cases in
Hashtbl.add t key r ;
r
and divide top cases =
and divide cases =
let lcases = Array.length cases in
let m = lcases/2 in
let _,left,right = coupe cases m in
@ -412,10 +412,10 @@ and divide top cases =
add_test cm cml ;
Sep m,(cm, ci)
and heuristic top cases =
and heuristic cases =
let lcases = Array.length cases in
let sep,csep = divide false cases
let sep,csep = divide cases
and inter,cinter =
if !ok_inter then begin
@ -589,7 +589,7 @@ and enum top cases =
else begin
let w,c = opt_count false cases in
let w,_c = opt_count false cases in
(*
Printf.fprintf stderr
"off=%d tactic=%a for %a\n"
@ -664,13 +664,13 @@ let switch_min = ref 3
(* Particular case 0, 1, 2 *)
let particular_case cases i j =
j-i = 2 &&
(let l1,h1,act1 = cases.(i)
and l2,h2,act2 = cases.(i+1)
(let l1,_h1,act1 = cases.(i)
and l2,_h2,_act2 = cases.(i+1)
and l3,h3,act3 = cases.(i+2) in
l1+1=l2 && l2+1=l3 && l3=h3 &&
act1 <> act3)
let approx_count cases i j n_actions =
let approx_count cases i j =
let l = j-i+1 in
if l < !cut then
let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in
@ -680,12 +680,12 @@ let approx_count cases i j n_actions =
(* Sends back a boolean that says whether is switch is worth or not *)
let dense {cases=cases ; actions=actions} i j =
let dense {cases} i j =
if i=j then true
else
let l,_,_ = cases.(i)
and _,h,_ = cases.(j) in
let ntests = approx_count cases i j (Array.length actions) in
let ntests = approx_count cases i j in
(*
(ntests+1) >= theta * (h-l+1)
*)
@ -701,8 +701,8 @@ let dense {cases=cases ; actions=actions} i j =
Software Practice and Exprience Vol. 24(2) 233 (Feb 1994)
*)
let comp_clusters ({cases=cases ; actions=actions} as s) =
let len = Array.length cases in
let comp_clusters s =
let len = Array.length s.cases in
let min_clusters = Array.make len max_int
and k = Array.make len 0 in
let get_min i = if i < 0 then 0 else min_clusters.(i) in

4
bytecomp/symtable.ml
View File

@ -332,12 +332,12 @@ let check_global_initialized patchlist =
List.fold_left
(fun accu rel ->
match rel with
(Reloc_setglobal id, pos) -> id :: accu
(Reloc_setglobal id, _pos) -> id :: accu
| _ -> accu)
[] patchlist in
(* Then check that all referenced, not defined globals have a value *)
let check_reference = function
(Reloc_getglobal id, pos) ->
(Reloc_getglobal id, _pos) ->
if not (List.mem id defined_globals)
&& Obj.is_int (get_global_value id)
then raise (Error(Uninitialized_global(Ident.name id)))

28
bytecomp/translclass.ml
View File

@ -93,7 +93,7 @@ let meths_super tbl meths inh_meths =
let bind_super tbl (vals, meths) cl_init =
transl_vals tbl false StrictOpt vals
(List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem))
(List.fold_right (fun (_nm, id, def) rem -> Llet(StrictOpt, id, def, rem))
meths cl_init)
let create_object cl obj init =
@ -117,7 +117,7 @@ let create_object cl obj init =
let name_pattern default p =
match p.pat_desc with
| Tpat_var (id, _) -> id
| Tpat_alias(p, id, _) -> id
| Tpat_alias(_, id, _) -> id
| _ -> Ident.create default
let normalize_cl_path cl path =
@ -192,12 +192,12 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
build_object_init cl_table obj (vals @ params) inh_init obj_init cl
in
(inh_init, Translcore.transl_let rec_flag defs obj_init)
| Tcl_constraint (cl, _, vals, pub_meths, concr_meths) ->
| Tcl_constraint (cl, _, _vals, _pub_meths, _concr_meths) ->
build_object_init cl_table obj params inh_init obj_init cl
let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
match cl.cl_desc with
Tcl_let (rec_flag, defs, vals, cl) ->
Tcl_let (_rec_flag, _defs, vals, cl) ->
let vals = List.map (fun (id, _, e) -> id,e) vals in
build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids
| _ ->
@ -206,7 +206,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
let obj = if ids = [] then lambda_unit else Lvar self in
let envs = if top then None else Some env in
let ((_,inh_init), obj_init) =
build_object_init cl_table obj params (envs,[]) (copy_env env) cl in
build_object_init cl_table obj params (envs,[]) copy_env cl in
let obj_init =
if ids = [] then obj_init else lfunction [self] obj_init in
(inh_init, lfunction [env] (subst_env env inh_init obj_init))
@ -232,7 +232,7 @@ let bind_methods tbl meths vals cl_init =
mkappl (oo_prim getter,
[Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
List.fold_right
(fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
(fun (_lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
(methl @ vals) cl_init)
let output_methods tbl methods lam =
@ -262,7 +262,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
match cl.cl_desc with
Tcl_ident ( path, _, _) ->
begin match inh_init with
(obj_init, path')::inh_init ->
(obj_init, _path')::inh_init ->
let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in
(inh_init,
Llet (Strict, obj_init,
@ -319,15 +319,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
in
let cl_init = output_methods cla methods cl_init in
(inh_init, bind_methods cla str.cstr_meths values cl_init)
| Tcl_fun (_, pat, vals, cl, _) ->
| Tcl_fun (_, _pat, vals, cl, _) ->
let (inh_init, cl_init) =
build_class_init cla cstr super inh_init cl_init msubst top cl
in
let vals = List.map bind_id_as_val vals in
(inh_init, transl_vals cla true StrictOpt vals cl_init)
| Tcl_apply (cl, exprs) ->
| Tcl_apply (cl, _exprs) ->
build_class_init cla cstr super inh_init cl_init msubst top cl
| Tcl_let (rec_flag, defs, vals, cl) ->
| Tcl_let (_rec_flag, _defs, vals, cl) ->
let (inh_init, cl_init) =
build_class_init cla cstr super inh_init cl_init msubst top cl
in
@ -381,7 +381,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
let rec build_class_lets cl ids =
match cl.cl_desc with
Tcl_let (rec_flag, defs, vals, cl') ->
Tcl_let (rec_flag, defs, _vals, cl') ->
let env, wrap = build_class_lets cl' [] in
(env, fun x ->
let lam = Translcore.transl_let rec_flag defs (wrap x) in
@ -430,7 +430,7 @@ let rec transl_class_rebind obj_init cl vf =
| Tcl_apply (cl, oexprs) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
(path, transl_apply obj_init oexprs Location.none)
| Tcl_let (rec_flag, defs, vals, cl) ->
| Tcl_let (rec_flag, defs, _vals, cl) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
(path, Translcore.transl_let rec_flag defs obj_init)
| Tcl_structure _ -> raise Exit
@ -446,7 +446,7 @@ let rec transl_class_rebind obj_init cl vf =
let rec transl_class_rebind_0 self obj_init cl vf =
match cl.cl_desc with
Tcl_let (rec_flag, defs, vals, cl) ->
Tcl_let (rec_flag, defs, _vals, cl) ->
let path, obj_init = transl_class_rebind_0 self obj_init cl vf in
(path, Translcore.transl_let rec_flag defs obj_init)
| _ ->
@ -677,7 +677,7 @@ let transl_class ids cl_id pub_meths cl vflag =
in
let new_ids_init = ref [] in
let env1 = Ident.create "env" and env1' = Ident.create "env'" in
let copy_env envs self =
let copy_env self =
if top then lambda_unit else
Lifused(env2, Lprim(Parraysetu Paddrarray,
[Lvar self; Lvar env2; Lvar env1']))

45
bytecomp/translcore.ml
View File

@ -37,11 +37,11 @@ let use_dup_for_constant_arrays_bigger_than = 4
(* Forward declaration -- to be filled in by Translmod.transl_module *)
let transl_module =
ref((fun cc rootpath modl -> assert false) :
ref((fun _cc _rootpath _modl -> assert false) :
module_coercion -> Path.t option -> module_expr -> lambda)
let transl_object =
ref (fun id s cl -> assert false :
ref (fun _id _s _cl -> assert false :
Ident.t -> string list -> class_expr -> lambda)
(* Compile an exception/extension definition *)
@ -57,11 +57,11 @@ let transl_extension_constructor env path ext =
| Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p)
in
match ext.ext_kind with
Text_decl(args, ret) ->
Text_decl _ ->
Lprim (Pmakeblock (Obj.object_tag, Immutable),
[Lconst (Const_base (Const_string (name, None)));
Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))])])
| Text_rebind(path, lid) ->
| Text_rebind(path, _lid) ->
transl_path ~loc:ext.ext_loc env path
(* Translation of primitives *)
@ -325,9 +325,6 @@ let primitives_table = create_hashtable 57 [
"%opaque", Popaque;
]
let prim_obj_dup =
Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
let find_primitive loc prim_name =
match prim_name with
"%revapply" -> Prevapply loc
@ -365,7 +362,7 @@ let specialize_primitive loc p env ty ~has_constant_constructor =
intcomp
else
match is_function_type env ty with
| Some (lhs,rhs) -> specialize_comparison table env lhs
| Some (lhs,_rhs) -> specialize_comparison table env lhs
| None -> gencomp
with Not_found ->
let p = find_primitive loc p.prim_name in
@ -377,7 +374,7 @@ let specialize_primitive loc p env ty ~has_constant_constructor =
| Some (p2, _) -> [p1;p2]
in
match (p, params) with
(Psetfield(n, _, init), [p1; p2]) ->
(Psetfield(n, _, init), [_p1; p2]) ->
Psetfield(n, maybe_pointer_type env p2, init)
| (Parraylength Pgenarray, [p]) -> Parraylength(array_type_kind env p)
| (Parrayrefu Pgenarray, p1 :: _) -> Parrayrefu(array_type_kind env p1)
@ -397,7 +394,7 @@ let specialize_primitive loc p env ty ~has_constant_constructor =
(* Eta-expand a primitive *)
let used_primitives = Hashtbl.create 7
let add_used_primitive loc p env path =
let add_used_primitive loc env path =
match path with
Some (Path.Pdot _ as path) ->
let path = Env.normalize_path (Some loc) env path in
@ -410,7 +407,7 @@ let transl_primitive loc p env ty path =
let prim =
try specialize_primitive loc p env ty ~has_constant_constructor:false
with Not_found ->
add_used_primitive loc p env path;
add_used_primitive loc env path;
Pccall p
in
match prim with
@ -452,7 +449,7 @@ let transl_primitive_application loc prim env ty path args =
with Not_found ->
if String.length prim_name > 0 && prim_name.[0] = '%' then
raise(Error(loc, Unknown_builtin_primitive prim_name));
add_used_primitive loc prim env path;
add_used_primitive loc env path;
Pccall prim
@ -463,13 +460,13 @@ let check_recursive_lambda idlist lam =
| Lvar v -> not (List.mem v idlist)
| Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam ->
true
| Llet(str, id, arg, body) ->
| Llet(_str, id, arg, body) ->
check idlist arg && check_top (add_let id arg idlist) body
| Lletrec(bindings, body) ->
let idlist' = add_letrec bindings idlist in
List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
List.for_all (fun (_id, arg) -> check idlist' arg) bindings &&
check_top idlist' body
| Lprim (Pmakearray (Pgenarray, _), args) -> false
| Lprim (Pmakearray (Pgenarray, _), _) -> false
| Lprim (Pmakearray (Pfloatarray, _), args) ->
List.for_all (check idlist) args
| Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2
@ -478,16 +475,16 @@ let check_recursive_lambda idlist lam =
and check idlist = function
| Lvar _ -> true
| Lfunction{kind; params; body} -> true
| Lfunction _ -> true
| Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam ->
true
| Llet(str, id, arg, body) ->
| Llet(_str, id, arg, body) ->
check idlist arg && check (add_let id arg idlist) body
| Lletrec(bindings, body) ->
let idlist' = add_letrec bindings idlist in
List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
List.for_all (fun (_id, arg) -> check idlist' arg) bindings &&
check idlist' body
| Lprim(Pmakeblock(tag, mut), args) ->
| Lprim(Pmakeblock _, args) ->
List.for_all (check idlist) args
| Lprim (Pmakearray (Pfloatarray, _), _) -> false
| Lprim (Pmakearray _, args) ->
@ -544,7 +541,7 @@ let rec name_pattern default = function
| {c_lhs=p; _} :: rem ->
match p.pat_desc with
Tpat_var (id, _) -> id
| Tpat_alias(p, id, _) -> id
| Tpat_alias(_, id, _) -> id
| _ -> name_pattern default rem
(* Push the default values under the functional abstractions *)
@ -701,7 +698,7 @@ and transl_exp0 e =
[Lvar cache; Lvar pos], e.exp_loc)}
else
transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path)
| Texp_ident(path, _, {val_kind = Val_anc _}) ->
| Texp_ident(_, _, {val_kind = Val_anc _}) ->
raise(Error(e.exp_loc, Free_super_var))
| Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->
transl_path ~loc:e.exp_loc e.exp_env path
@ -1172,7 +1169,7 @@ and transl_function loc untuplify_fn repr partial cases =
(fun {c_lhs; c_guard; c_rhs} ->
(Matching.flatten_pattern size c_lhs, c_guard, c_rhs))
cases in
let params = List.map (fun p -> Ident.create "param") pl in
let params = List.map (fun _ -> Ident.create "param") pl in
((Tupled, params),
Matching.for_tupled_function loc params
(transl_tupled_cases pats_expr_list) partial)
@ -1212,7 +1209,7 @@ and transl_let rec_flag pat_expr_list body =
| Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id
| _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)))
pat_expr_list in
let transl_case {vb_pat=pat; vb_expr=expr; vb_attributes; vb_loc} id =
let transl_case {vb_expr=expr; vb_attributes; vb_loc} id =
let lam = transl_exp expr in
let lam =
Translattribute.add_inline_attribute lam vb_loc
@ -1246,7 +1243,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr =
let init_id = Ident.create "init" in
begin match opt_init_expr with
None -> ()
| Some init_expr ->
| Some _ ->
for i = 0 to Array.length all_labels - 1 do
let access =
match all_labels.(i).lbl_repres with

78
bytecomp/translmod.ml
View File

@ -91,7 +91,7 @@ let rec apply_coercion strict restr arg =
transl_primitive pc_loc pc_desc pc_env pc_type None
| Tcoerce_alias (path, cc) ->
name_lambda strict arg
(fun id -> apply_coercion Alias cc (transl_normal_path path))
(fun _ -> apply_coercion Alias cc (transl_normal_path path))
and apply_coercion_field get_field (pos, cc) =
apply_coercion Alias cc (get_field pos)
@ -192,12 +192,12 @@ let init_shape modl =
Const_block (1, [Const_pointer 0])
| Mty_signature sg ->
Const_block(0, [Const_block(0, init_shape_struct env sg)])
| Mty_functor(id, arg, res) ->
| Mty_functor _ ->
raise Not_found (* can we do better? *)
and init_shape_struct env sg =
match sg with
[] -> []
| Sig_value(id, vdesc) :: rem ->
| Sig_value(_id, vdesc) :: rem ->
let init_v =
match Ctype.expand_head env vdesc.val_type with
{desc = Tarrow(_,_,_,_)} ->
@ -208,17 +208,17 @@ let init_shape modl =
init_v :: init_shape_struct env rem
| Sig_type(id, tdecl, _) :: rem ->
init_shape_struct (Env.add_type ~check:false id tdecl env) rem
| Sig_typext(id, ext, _) :: rem ->
| Sig_typext _ :: _ ->
raise Not_found
| Sig_module(id, md, _) :: rem ->
init_shape_mod env md.md_type ::
init_shape_struct (Env.add_module_declaration id md env) rem
| Sig_modtype(id, minfo) :: rem ->
init_shape_struct (Env.add_modtype id minfo env) rem
| Sig_class(id, cdecl, _) :: rem ->
| Sig_class _ :: rem ->
Const_pointer 2 (* camlinternalMod.Class *)
:: init_shape_struct env rem
| Sig_class_type(id, ctyp, _) :: rem ->
| Sig_class_type _ :: rem ->
init_shape_struct env rem
in
try
@ -267,9 +267,9 @@ let eval_rec_bindings bindings cont =
let rec bind_inits = function
[] ->
bind_strict bindings
| (id, None, rhs) :: rem ->
| (_id, None, _rhs) :: rem ->
bind_inits rem
| (id, Some(loc, shape), rhs) :: rem ->
| (id, Some(loc, shape), _rhs) :: rem ->
Llet(Strict, id,
Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
@ -283,14 +283,14 @@ let eval_rec_bindings bindings cont =
patch_forwards bindings
| (id, None, rhs) :: rem ->
Llet(Strict, id, rhs, bind_strict rem)
| (id, Some(loc, shape), rhs) :: rem ->
| (_id, Some _, _rhs) :: rem ->
bind_strict rem
and patch_forwards = function
[] ->
cont
| (id, None, rhs) :: rem ->
| (_id, None, _rhs) :: rem ->
patch_forwards rem
| (id, Some(loc, shape), rhs) :: rem ->
| (id, Some(_loc, shape), rhs) :: rem ->
Lsequence(Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=mod_prim "update_mod";
@ -319,9 +319,9 @@ let rec bound_value_identifiers = function
[] -> []
| Sig_value(id, {val_kind = Val_reg}) :: rem ->
id :: bound_value_identifiers rem
| Sig_typext(id, ext, _) :: rem -> id :: bound_value_identifiers rem
| Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem
| Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem
| Sig_typext(id, _, _) :: rem -> id :: bound_value_identifiers rem
| Sig_module(id, _, _) :: rem -> id :: bound_value_identifiers rem
| Sig_class(id, _, _) :: rem -> id :: bound_value_identifiers rem
| _ :: rem -> bound_value_identifiers rem
@ -349,7 +349,7 @@ let rec transl_module cc rootpath mexp =
(transl_path ~loc:mexp.mod_loc mexp.mod_env path)
| Tmod_structure str ->
fst (transl_struct [] cc rootpath str)
| Tmod_functor( param, _, mty, body) ->
| Tmod_functor(param, _, _, body) ->
let bodypath = functor_path rootpath param in
let inline_attribute =
Translattribute.get_inline_attribute mexp.mod_attributes
@ -387,7 +387,7 @@ let rec transl_module cc rootpath mexp =
ap_args=[transl_module ccarg None arg];
ap_inlined=inlined_attribute;
ap_specialised=Default_specialise})
| Tmod_constraint(arg, mty, _, ccarg) ->
| Tmod_constraint(arg, _, _, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
| Tmod_unpack(arg, _) ->
apply_coercion Strict cc (Translcore.transl_exp arg)
@ -456,7 +456,7 @@ and transl_structure fields cc rootpath final_env = function
| Tstr_primitive descr ->
record_primitive descr.val_val;
transl_structure fields cc rootpath final_env rem
| Tstr_type(_, decls) ->
| Tstr_type _ ->
transl_structure fields cc rootpath final_env rem
| Tstr_typext(tyext) ->
let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in
@ -558,7 +558,7 @@ let wrap_globals body =
let add_global id req =
if IdentSet.mem id globals then req else IdentSet.add id req in
let required =
Hashtbl.fold (fun path loc -> add_global (Path.head path))
Hashtbl.fold (fun path _ -> add_global (Path.head path))
used_primitives IdentSet.empty
in
let required =
@ -600,11 +600,11 @@ let rec defined_idents = function
[] -> []
| item :: rem ->
match item.str_desc with
| Tstr_eval (expr, _) -> defined_idents rem
| Tstr_value(rec_flag, pat_expr_list) ->
| Tstr_eval _ -> defined_idents rem
| Tstr_value(_rec_flag, pat_expr_list) ->
let_bound_idents pat_expr_list @ defined_idents rem
| Tstr_primitive desc -> defined_idents rem
| Tstr_type (_, decls) -> defined_idents rem
| Tstr_primitive _ -> defined_idents rem
| Tstr_type _ -> defined_idents rem
| Tstr_typext tyext ->
List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
@ defined_idents rem
@ -616,7 +616,7 @@ let rec defined_idents = function
| Tstr_open _ -> defined_idents rem
| Tstr_class cl_list ->
List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem
| Tstr_class_type cl_list -> defined_idents rem
| Tstr_class_type _ -> defined_idents rem
| Tstr_include incl ->
bound_value_identifiers incl.incl_type @ defined_idents rem
| Tstr_attribute _ -> defined_idents rem
@ -627,17 +627,17 @@ let rec more_idents = function
[] -> []
| item :: rem ->
match item.str_desc with
| Tstr_eval (expr, _attrs) -> more_idents rem
| Tstr_value(rec_flag, pat_expr_list) -> more_idents rem
| Tstr_eval _ -> more_idents rem
| Tstr_value _ -> more_idents rem
| Tstr_primitive _ -> more_idents rem
| Tstr_type (_, decls) -> more_idents rem
| Tstr_typext tyext -> more_idents rem
| Tstr_type _ -> more_idents rem
| Tstr_typext _ -> more_idents rem
| Tstr_exception _ -> more_idents rem
| Tstr_recmodule decls -> more_idents rem
| Tstr_recmodule _ -> more_idents rem
| Tstr_modtype _ -> more_idents rem
| Tstr_open _ -> more_idents rem
| Tstr_class cl_list -> more_idents rem
| Tstr_class_type cl_list -> more_idents rem
| Tstr_class _ -> more_idents rem
| Tstr_class_type _ -> more_idents rem
| Tstr_include _ -> more_idents rem
| Tstr_module {mb_expr={mod_desc = Tmod_structure str}}
| Tstr_module{mb_expr={mod_desc =
@ -651,11 +651,11 @@ and all_idents = function
[] -> []
| item :: rem ->
match item.str_desc with
| Tstr_eval (expr, _attrs) -> all_idents rem
| Tstr_value(rec_flag, pat_expr_list) ->
| Tstr_eval _ -> all_idents rem
| Tstr_value(_rec_flag, pat_expr_list) ->
let_bound_idents pat_expr_list @ all_idents rem
| Tstr_primitive _ -> all_idents rem
| Tstr_type (_, decls) -> all_idents rem
| Tstr_type _ -> all_idents rem
| Tstr_typext tyext ->
List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
@ all_idents rem
@ -666,7 +666,7 @@ and all_idents = function
| Tstr_open _ -> all_idents rem
| Tstr_class cl_list ->
List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem
| Tstr_class_type cl_list -> all_idents rem
| Tstr_class_type _ -> all_idents rem
| Tstr_include incl ->
bound_value_identifiers incl.incl_type @ all_idents rem
| Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}}
@ -717,7 +717,7 @@ let transl_store_structure glob map prims str =
| Tstr_primitive descr ->
record_primitive descr.val_val;
transl_store rootpath subst rem
| Tstr_type(_, decls) ->
| Tstr_type _ ->
transl_store rootpath subst rem
| Tstr_typext(tyext) ->
let ids =
@ -900,7 +900,7 @@ let build_ident_map restr idlist more_ids =
let rec export_map pos map prims undef = function
[] ->
natural_map pos map prims undef
| (source_pos, Tcoerce_primitive p) :: rem ->
| (_source_pos, Tcoerce_primitive p) :: rem ->
export_map (pos + 1) map ((pos, p) :: prims) undef rem
| (source_pos, cc) :: rem ->
let id = idarray.(source_pos) in
@ -1061,7 +1061,7 @@ let get_component = function
None -> Lconst const_unit
| Some id -> Lprim(Pgetglobal id, [])
let transl_package_flambda component_names target_name coercion =
let transl_package_flambda component_names coercion =
let size =
match coercion with
| Tcoerce_none -> List.length component_names
@ -1108,7 +1108,7 @@ let transl_store_package component_names target_name coercion =
[Lprim(Pgetglobal target_name, []);
get_component id]))
0 component_names)
| Tcoerce_structure (pos_cc_list, id_pos_list) ->
| Tcoerce_structure (pos_cc_list, _id_pos_list) ->
let components =
Lprim(Pmakeblock(0, Immutable), List.map get_component component_names)
in
@ -1116,7 +1116,7 @@ let transl_store_package component_names target_name coercion =
(List.length pos_cc_list,
Llet (Strict, blk, apply_coercion Strict coercion components,
make_sequence
(fun pos id ->
(fun pos _id ->
Lprim(Psetfield(pos, Pointer, Initialization),
[Lprim(Pgetglobal target_name, []);
Lprim(Pfield pos, [Lvar blk])]))

2
bytecomp/translmod.mli
View File

@ -34,7 +34,7 @@ val transl_store_package:
Ident.t option list -> Ident.t -> module_coercion -> int * lambda
val transl_package_flambda:
Ident.t option list -> Ident.t -> module_coercion -> int * lambda
Ident.t option list -> module_coercion -> int * lambda
val toplevel_name: Ident.t -> string
val nat_toplevel_name: Ident.t -> Ident.t * int

2
bytecomp/translobj.ml
View File

@ -33,7 +33,7 @@ let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17
let share c =
match c with
Const_block (n, l) when l <> [] ->
Const_block (_n, l) when l <> [] ->
begin try
Lvar (Hashtbl.find consts c)
with Not_found ->

4
bytecomp/typeopt.ml
View File

@ -48,7 +48,7 @@ let array_element_kind env ty =
match scrape env ty with
| Tvar _ | Tunivar _ ->
Pgenarray
| Tconstr(p, args, abbrev) ->
| Tconstr(p, _args, _abbrev) ->
if Path.same p Predef.path_int || Path.same p Predef.path_char then
Pintarray
else if Path.same p Predef.path_float then
@ -120,7 +120,7 @@ let layout_table =
let bigarray_type_kind_and_layout env typ =
match scrape env typ with
| Tconstr(p, [caml_type; elt_type; layout_type], abbrev) ->
| Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) ->
(bigarray_decode_type env elt_type kind_table Pbigarray_unknown,
bigarray_decode_type env layout_type layout_table
Pbigarray_unknown_layout)

2
driver/compenv.ml
View File

@ -158,6 +158,7 @@ let int_option_setter ppf name option s =
(Warnings.Bad_env_variable
("OCAMLPARAM", Printf.sprintf "non-integer parameter for \"%s\"" name))
(*
let float_setter ppf name option s =
try
option := float_of_string s
@ -165,6 +166,7 @@ let float_setter ppf name option s =
Location.print_warning Location.none ppf
(Warnings.Bad_env_variable
("OCAMLPARAM", Printf.sprintf "non-float parameter for \"%s\"" name))
*)
let check_bool ppf name s =
match s with

54
driver/optmain.ml
View File

@ -114,39 +114,48 @@ module Options = Main_args.Make_optcomp_options (struct
let _I dir = include_dirs := dir :: !include_dirs
let _impl = impl
let _inline spec =
Float_arg_helper.parse spec ~update:inline_threshold
~help_text:"Syntax: -inline <n> | <round>=<n>[,...]"
Float_arg_helper.parse spec
"Syntax: -inline <n> | <round>=<n>[,...]" inline_threshold
let _inline_toplevel spec =
Int_arg_helper.parse spec ~update:inline_toplevel_threshold
~help_text:"Syntax: -inline-toplevel <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-toplevel <n> | <round>=<n>[,...]"
inline_toplevel_threshold
let _inlining_report () = inlining_report := true
let _dump_pass pass = set_dumped_pass pass true
let _rounds n = simplify_rounds := Some n
let _inline_max_unroll spec =
Int_arg_helper.parse spec ~update:inline_max_unroll
~help_text:"Syntax: -inline-max-unroll <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-max-unroll <n> | <round>=<n>[,...]"
inline_max_unroll
let _classic_inlining () = classic_inlining := true
let _inline_call_cost spec =
Int_arg_helper.parse spec ~update:inline_call_cost
~help_text:"Syntax: -inline-call-cost <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-call-cost <n> | <round>=<n>[,...]"
inline_call_cost
let _inline_alloc_cost spec =
Int_arg_helper.parse spec ~update:inline_alloc_cost
~help_text:"Syntax: -inline-alloc-cost <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-alloc-cost <n> | <round>=<n>[,...]"
inline_alloc_cost
let _inline_prim_cost spec =
Int_arg_helper.parse spec ~update:inline_prim_cost
~help_text:"Syntax: -inline-prim-cost <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-prim-cost <n> | <round>=<n>[,...]"
inline_prim_cost
let _inline_branch_cost spec =
Int_arg_helper.parse spec ~update:inline_branch_cost
~help_text:"Syntax: -inline-branch-cost <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-branch-cost <n> | <round>=<n>[,...]"
inline_branch_cost
let _inline_indirect_cost spec =
Int_arg_helper.parse spec ~update:inline_indirect_cost
~help_text:"Syntax: -inline-indirect-cost <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-indirect-cost <n> | <round>=<n>[,...]"
inline_indirect_cost
let _inline_lifting_benefit spec =
Int_arg_helper.parse spec ~update:inline_lifting_benefit
~help_text:"Syntax: -inline-lifting-benefit <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-lifting-benefit <n> | <round>=<n>[,...]"
inline_lifting_benefit
let _inline_branch_factor spec =
Float_arg_helper.parse spec ~update:inline_branch_factor
~help_text:"Syntax: -inline-branch-factor <n> | <round>=<n>[,...]"
Float_arg_helper.parse spec
"Syntax: -inline-branch-factor <n> | <round>=<n>[,...]"
inline_branch_factor
let _intf = intf
let _intf_suffix s = Config.interface_suffix := s
let _keep_docs = set keep_docs
@ -154,8 +163,9 @@ module Options = Main_args.Make_optcomp_options (struct
let _labels = clear classic
let _linkall = set link_everything
let _inline_max_depth spec =
Int_arg_helper.parse spec ~update:inline_max_depth
~help_text:"Syntax: -inline-max-depth <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-max-depth <n> | <round>=<n>[,...]"
inline_max_depth
let _no_alias_deps = set transparent_modules
let _no_app_funct = clear applicative_functors
let _no_float_const_prop = clear float_const_prop

64
parsing/ast_iterator.ml
View File

@ -98,13 +98,13 @@ module T = struct
| Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl
| Ptyp_constr (lid, tl) ->
iter_loc sub lid; List.iter (sub.typ sub) tl
| Ptyp_object (l, o) ->
| Ptyp_object (l, _o) ->
let f (_, a, t) = sub.attributes sub a; sub.typ sub t in
List.iter f l
| Ptyp_class (lid, tl) ->
iter_loc sub lid; List.iter (sub.typ sub) tl
| Ptyp_alias (t, _) -> sub.typ sub t
| Ptyp_variant (rl, b, ll) ->
| Ptyp_variant (rl, _b, _ll) ->
List.iter (row_field sub) rl
| Ptyp_poly (_, t) -> sub.typ sub t
| Ptyp_package (lid, l) ->
@ -115,7 +115,7 @@ module T = struct
let iter_type_declaration sub
{ptype_name; ptype_params; ptype_cstrs;
ptype_kind;
ptype_private;
ptype_private = _;
ptype_manifest;
ptype_attributes;
ptype_loc} =
@ -144,7 +144,7 @@ module T = struct
let iter_type_extension sub
{ptyext_path; ptyext_params;
ptyext_constructors;
ptyext_private;
ptyext_private = _;
ptyext_attributes} =
iter_loc sub ptyext_path;
List.iter (sub.extension_constructor sub) ptyext_constructors;
@ -189,8 +189,8 @@ module CT = struct
sub.attributes sub attrs;
match desc with
| Pctf_inherit ct -> sub.class_type sub ct
| Pctf_val (s, m, v, t) -> sub.typ sub t
| Pctf_method (s, p, v, t) -> sub.typ sub t
| Pctf_val (_s, _m, _v, t) -> sub.typ sub t
| Pctf_method (_s, _p, _v, t) -> sub.typ sub t
| Pctf_constraint (t1, t2) ->
sub.typ sub t1; sub.typ sub t2
| Pctf_attribute x -> sub.attribute sub x
@ -234,7 +234,7 @@ module MT = struct
sub.location sub loc;
match desc with
| Psig_value vd -> sub.value_description sub vd
| Psig_type (rf, l) -> List.iter (sub.type_declaration sub) l
| Psig_type (_rf, l) -> List.iter (sub.type_declaration sub) l
| Psig_typext te -> sub.type_extension sub te
| Psig_exception ed -> sub.extension_constructor sub ed
| Psig_module x -> sub.module_declaration sub x
@ -277,9 +277,9 @@ module M = struct
match desc with
| Pstr_eval (x, attrs) ->
sub.expr sub x; sub.attributes sub attrs
| Pstr_value (r, vbs) -> List.iter (sub.value_binding sub) vbs
| Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs
| Pstr_primitive vd -> sub.value_description sub vd
| Pstr_type (rf, l) -> List.iter (sub.type_declaration sub) l
| Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l
| Pstr_typext te -> sub.type_extension sub te
| Pstr_exception ed -> sub.extension_constructor sub ed
| Pstr_module x -> sub.module_binding sub x
@ -303,11 +303,11 @@ module E = struct
sub.attributes sub attrs;
match desc with
| Pexp_ident x -> iter_loc sub x
| Pexp_constant x -> ()
| Pexp_let (r, vbs, e) ->
| Pexp_constant _ -> ()
| Pexp_let (_r, vbs, e) ->
List.iter (sub.value_binding sub) vbs;
sub.expr sub e
| Pexp_fun (lab, def, p, e) ->
| Pexp_fun (_lab, def, p, e) ->
iter_opt (sub.expr sub) def;
sub.pat sub p;
sub.expr sub e
@ -320,7 +320,7 @@ module E = struct
| Pexp_tuple el -> List.iter (sub.expr sub) el
| Pexp_construct (lid, arg) ->
iter_loc sub lid; iter_opt (sub.expr sub) arg
| Pexp_variant (lab, eo) ->
| Pexp_variant (_lab, eo) ->
iter_opt (sub.expr sub) eo
| Pexp_record (l, eo) ->
List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l;
@ -338,7 +338,7 @@ module E = struct
sub.expr sub e1; sub.expr sub e2
| Pexp_while (e1, e2) ->
sub.expr sub e1; sub.expr sub e2
| Pexp_for (p, e1, e2, d, e3) ->
| Pexp_for (p, e1, e2, _d, e3) ->
sub.pat sub p; sub.expr sub e1; sub.expr sub e2;
sub.expr sub e3
| Pexp_coerce (e, t1, t2) ->
@ -346,7 +346,7 @@ module E = struct
sub.typ sub t2
| Pexp_constraint (e, t) ->
sub.expr sub e; sub.typ sub t
| Pexp_send (e, s) -> sub.expr sub e
| Pexp_send (e, _s) -> sub.expr sub e
| Pexp_new lid -> iter_loc sub lid
| Pexp_setinstvar (s, e) ->
iter_loc sub s; sub.expr sub e
@ -363,9 +363,9 @@ module E = struct
| Pexp_poly (e, t) ->
sub.expr sub e; iter_opt (sub.typ sub) t
| Pexp_object cls -> sub.class_structure sub cls
| Pexp_newtype (s, e) -> sub.expr sub e
| Pexp_newtype (_s, e) -> sub.expr sub e
| Pexp_pack me -> sub.module_expr sub me
| Pexp_open (ovf, lid, e) ->
| Pexp_open (_ovf, lid, e) ->
iter_loc sub lid; sub.expr sub e
| Pexp_extension x -> sub.extension sub x
| Pexp_unreachable -> ()
@ -381,13 +381,13 @@ module P = struct
| Ppat_any -> ()
| Ppat_var s -> iter_loc sub s
| Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s
| Ppat_constant c -> ()
| Ppat_interval (c1, c2) -> ()
| Ppat_constant _ -> ()
| Ppat_interval _ -> ()
| Ppat_tuple pl -> List.iter (sub.pat sub) pl
| Ppat_construct (l, p) ->
iter_loc sub l; iter_opt (sub.pat sub) p
| Ppat_variant (l, p) -> iter_opt (sub.pat sub) p
| Ppat_record (lpl, cf) ->
| Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p
| Ppat_record (lpl, _cf) ->
List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl
| Ppat_array pl -> List.iter (sub.pat sub) pl
| Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2
@ -411,14 +411,14 @@ module CE = struct
iter_loc sub lid; List.iter (sub.typ sub) tys
| Pcl_structure s ->
sub.class_structure sub s
| Pcl_fun (lab, e, p, ce) ->
| Pcl_fun (_lab, e, p, ce) ->
iter_opt (sub.expr sub) e;
sub.pat sub p;
sub.class_expr sub ce
| Pcl_apply (ce, l) ->
sub.class_expr sub ce;
List.iter (iter_snd (sub.expr sub)) l
| Pcl_let (r, vbs, ce) ->
| Pcl_let (_r, vbs, ce) ->
List.iter (sub.value_binding sub) vbs;
sub.class_expr sub ce
| Pcl_constraint (ce, ct) ->
@ -426,16 +426,16 @@ module CE = struct
| Pcl_extension x -> sub.extension sub x
let iter_kind sub = function
| Cfk_concrete (o, e) -> sub.expr sub e
| Cfk_concrete (_o, e) -> sub.expr sub e
| Cfk_virtual t -> sub.typ sub t
let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
sub.location sub loc;
sub.attributes sub attrs;
match desc with
| Pcf_inherit (o, ce, s) -> sub.class_expr sub ce
| Pcf_val (s, m, k) -> iter_loc sub s; iter_kind sub k
| Pcf_method (s, p, k) ->
| Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce
| Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k
| Pcf_method (s, _p, k) ->
iter_loc sub s; iter_kind sub k
| Pcf_constraint (t1, t2) ->
sub.typ sub t1; sub.typ sub t2
@ -447,7 +447,7 @@ module CE = struct
sub.pat sub pcstr_self;
List.iter (sub.class_field sub) pcstr_fields
let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr;
pci_loc; pci_attributes} =
List.iter (iter_fst (sub.typ sub)) pl;
iter_loc sub pci_name;
@ -487,7 +487,7 @@ let default_iterator =
type_extension = T.iter_type_extension;
extension_constructor = T.iter_extension_constructor;
value_description =
(fun this {pval_name; pval_type; pval_prim; pval_loc;
(fun this {pval_name; pval_type; pval_prim = _; pval_loc;
pval_attributes} ->
iter_loc this pval_name;
this.typ this pval_type;
@ -523,7 +523,7 @@ let default_iterator =
open_description =
(fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
(fun this {popen_lid; popen_override = _; popen_attributes; popen_loc} ->
iter_loc this popen_lid;
this.location this popen_loc;
this.attributes this popen_attributes
@ -564,7 +564,7 @@ let default_iterator =
);
label_declaration =
(fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
(fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes} ->
iter_loc this pld_name;
this.typ this pld_type;
this.location this pld_loc;
@ -579,7 +579,7 @@ let default_iterator =
this.expr this pc_rhs
);
location = (fun this l -> ());
location = (fun _this _l -> ());
extension = (fun this (s, e) -> iter_loc this s; this.payload this e);
attribute = (fun this (s, e) -> iter_loc this s; this.payload this e);

2
parsing/ast_mapper.ml
View File

@ -617,7 +617,7 @@ let default_mapper =
location = (fun this l -> l);
location = (fun _this l -> l);
extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));

2
parsing/builtin_attributes.ml
View File

@ -32,7 +32,7 @@ let rec error_of_extension ext =
match inner with
| {pstr_desc=Pstr_extension (ext, _)} :: rest ->
error_of_extension ext :: sub_from rest
| {pstr_loc} :: rest ->
| _ :: rest ->
(Location.errorf ~loc
"Invalid syntax for sub-error of extension '%s'." txt) ::
sub_from rest

2
parsing/docstrings.ml
View File

@ -151,7 +151,7 @@ let get_docstring ~info dsl =
let rec loop = function
| [] -> None
| {ds_attached = Info; _} :: rest -> loop rest
| ds :: rest ->
| ds :: _ ->
ds.ds_attached <- if info then Info else Docs;
Some ds
in

2
parsing/location.ml
View File

@ -390,7 +390,7 @@ let error_of_exn exn =
let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
let highlighted =
if if_highlight <> "" then
let rec collect_locs locs {loc; sub; if_highlight; _} =
let rec collect_locs locs {loc; sub; _} =
List.fold_left collect_locs (loc :: locs) sub
in
let locs = collect_locs [] err in

4
parsing/parser.mly
View File

@ -1266,7 +1266,7 @@ class_description:
CLASS ext_attributes virtual_flag class_type_parameters LIDENT COLON
class_type post_item_attributes
{ let (ext, attrs) = $2 in
Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:(attrs@$8)
Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:(attrs @ $8)
~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
, ext }
;
@ -1426,7 +1426,7 @@ expr:
| expr EQUAL expr
{ mkinfix $1 "=" $3 }
| expr LESS expr
{ mkinfix $1 "<" $3 }
{ mkinfix $1 "<" $3 }
| expr GREATER expr
{ mkinfix $1 ">" $3 }
| expr OR expr

4
parsing/pprintast.ml
View File

@ -218,7 +218,7 @@ class printer ()= object(self:'self)
pp f "[%a] " (* space *)
(self#list self#type_param ~sep:",") l
method type_with_label f (label,({ptyp_desc;_}as c) ) =
method type_with_label f (label, c) =
match label with
| Nolabel -> self#core_type1 f c (* otherwise parenthesize *)
| Labelled s -> pp f "%s:%a" s self#core_type1 c
@ -330,7 +330,7 @@ class printer ()= object(self:'self)
else match x.ppat_desc with
| Ppat_alias (p, s) -> pp f "@[<2>%a@;as@;%a@]"
self#pattern p protect_ident s.txt (* RA*)
| Ppat_or (p1, p2) -> (* *)
| Ppat_or _ -> (* *)
pp f "@[<hov0>%a@]" (self#list ~sep:"@,|" self#pattern)
(list_of_pattern [] x)
| _ -> self#pattern1 f x

2
toplevel/expunge.ml
View File

@ -41,7 +41,7 @@ let expunge_map tbl =
Symtable.filter_global_map (fun id -> keep (Ident.name id)) tbl
let expunge_crcs tbl =
List.filter (fun (unit, crc) -> keep unit) tbl
List.filter (fun (unit, _crc) -> keep unit) tbl
let main () =
let input_name = Sys.argv.(1) in

20
toplevel/genprintval.ml
View File

@ -77,7 +77,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
let hash x =
try
Hashtbl.hash x
with exn -> 0
with _exn -> 0
end)
@ -159,7 +159,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
let install_printer path ty fn =
let print_val ppf obj =
try fn ppf obj with exn -> exn_printer ppf path in
try fn ppf obj with _exn -> exn_printer ppf path in
let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
printers := (path, Simple (ty, printer)) :: !printers
@ -196,9 +196,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
let tree_of_qualified lookup_fun env ty_path name =
match ty_path with
| Pident id ->
| Pident _ ->
Oide_ident name
| Pdot(p, s, pos) ->
| Pdot(p, _s, _pos) ->
if try
match (lookup_fun (Lident name) env).desc with
| Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
@ -206,7 +206,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
with Not_found -> false
then Oide_ident name
else Oide_dot (Printtyp.tree_of_path p, name)
| Papply(p1, p2) ->
| Papply _ ->
Printtyp.tree_of_path ty_path
let tree_of_constr =
@ -255,7 +255,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
match (Ctype.repr ty).desc with
| Tvar _ | Tunivar _ ->
Oval_stuff "<poly>"
| Tarrow(_, ty1, ty2, _) ->
| Tarrow _ ->
Oval_stuff "<fun>"
| Ttuple(ty_list) ->
Oval_tuple (tree_of_val_list 0 depth obj ty_list)
@ -545,15 +545,15 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
and find_printer depth env ty =
let rec find = function
| [] -> raise Not_found
| (name, Simple (sch, printer)) :: remainder ->
| (_name, Simple (sch, printer)) :: remainder ->
if Ctype.moregeneral env false sch ty
then printer
else find remainder
| (name, Generic (path, fn)) :: remainder ->
| (_name, Generic (path, fn)) :: remainder ->
begin match (Ctype.expand_head env ty).desc with
| Tconstr (p, args, _) when Path.same p path ->
begin try apply_generic_printer path (fn depth) args
with _ -> (fun obj -> out_exn path) end
with _ -> (fun _obj -> out_exn path) end
| _ -> find remainder end in
find !printers
@ -564,7 +564,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
let printer = fn (fun depth obj -> tree_of_val depth obj arg) in
apply_generic_printer path printer args
| _ ->
(fun obj ->
(fun _obj ->
let printer ppf =
fprintf ppf "<internal error: incorrect arity for '%a'>"
Printtyp.path path in

4
toplevel/opttopdirs.ml
View File

@ -151,7 +151,7 @@ let dir_install_printer ppf lid =
let v = eval_path !toplevel_env path in
let print_function =
if is_old_style then
(fun formatter repr -> Obj.obj v (Obj.obj repr))
(fun _formatter repr -> Obj.obj v (Obj.obj repr))
else
(fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
install_printer path ty_arg print_function
@ -159,7 +159,7 @@ let dir_install_printer ppf lid =
let dir_remove_printer ppf lid =
try
let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in
begin try
remove_printer path
with Not_found ->

8
toplevel/opttoploop.ml
View File

@ -99,9 +99,9 @@ let rec eval_path = function
if Ident.persistent id || Ident.global id
then global_symbol id
else toplevel_value id
| Pdot(p, s, pos) ->
| Pdot(p, _s, pos) ->
Obj.field (eval_path p) pos
| Papply(p1, p2) ->
| Papply _ ->
fatal_error "Toploop.eval_path"
let eval_path env path =
@ -318,7 +318,7 @@ let execute_phrase print_outcome ppf phr =
let res = load_lambda ppf ~module_ident res size in
let out_phr =
match res with
| Result v ->
| Result _ ->
if Config.flambda then
(* CR-someday trefis: *)
()
@ -380,7 +380,7 @@ let execute_phrase print_outcome ppf phr =
dir_name;
false
end
| Directive_int f, Pdir_int (n, Some _) ->
| Directive_int _, Pdir_int (_, Some _) ->
fprintf ppf "Wrong integer literal for directive `%s'.@."
dir_name;
false

55
toplevel/opttopmain.ml
View File

@ -73,42 +73,53 @@ module Options = Main_args.Make_opttop_options (struct
let _noinit = set noinit
let _clambda_checks () = clambda_checks := true
let _inline spec =
Float_arg_helper.parse spec ~update:inline_threshold
~help_text:"Syntax: -inline <n> | <round>=<n>[,...]"
Float_arg_helper.parse spec
"Syntax: -inline <n> | <round>=<n>[,...]"
inline_threshold
let _inline_indirect_cost spec =
Int_arg_helper.parse spec ~update:inline_indirect_cost
~help_text:"Syntax: -inline-indirect-cost <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-indirect-cost <n> | <round>=<n>[,...]"
inline_indirect_cost
let _inline_toplevel spec =
Int_arg_helper.parse spec ~update:inline_toplevel_threshold
~help_text:"Syntax: -inline-toplevel <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-toplevel <n> | <round>=<n>[,...]"
inline_toplevel_threshold
let _inlining_report () = inlining_report := true
let _dump_pass pass = set_dumped_pass pass true
let _rounds n = simplify_rounds := Some n
let _inline_max_unroll spec =
Int_arg_helper.parse spec ~update:inline_max_unroll
~help_text:"Syntax: -inline-max-unroll <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-max-unroll <n> | <round>=<n>[,...]"
inline_max_unroll
let _classic_inlining () = classic_inlining := true
let _inline_call_cost spec =
Int_arg_helper.parse spec ~update:inline_call_cost
~help_text:"Syntax: -inline-call-cost <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-call-cost <n> | <round>=<n>[,...]"
inline_call_cost
let _inline_alloc_cost spec =
Int_arg_helper.parse spec ~update:inline_alloc_cost
~help_text:"Syntax: -inline-alloc-cost <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-alloc-cost <n> | <round>=<n>[,...]"
inline_alloc_cost
let _inline_prim_cost spec =
Int_arg_helper.parse spec ~update:inline_prim_cost
~help_text:"Syntax: -inline-prim-cost <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-prim-cost <n> | <round>=<n>[,...]"
inline_prim_cost
let _inline_branch_cost spec =
Int_arg_helper.parse spec ~update:inline_branch_cost
~help_text:"Syntax: -inline-branch-cost <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-branch-cost <n> | <round>=<n>[,...]"
inline_branch_cost
let _inline_lifting_benefit spec =
Int_arg_helper.parse spec ~update:inline_lifting_benefit
~help_text:"Syntax: -inline-lifting-benefit <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-lifting-benefit <n> | <round>=<n>[,...]"
inline_lifting_benefit
let _inline_branch_factor spec =
Float_arg_helper.parse spec ~update:inline_branch_factor
~help_text:"Syntax: -inline-branch-factor <n> | <round>=<n>[,...]"
Float_arg_helper.parse spec
"Syntax: -inline-branch-factor <n> | <round>=<n>[,...]"
inline_branch_factor
let _inline_max_depth spec =
Int_arg_helper.parse spec ~update:inline_max_depth
~help_text:"Syntax: -inline-max-depth <n> | <round>=<n>[,...]"
Int_arg_helper.parse spec
"Syntax: -inline-max-depth <n> | <round>=<n>[,...]"
inline_max_depth
let _no_unbox_free_vars_of_closures = clear unbox_free_vars_of_closures
let _no_unbox_specialised_args = clear unbox_specialised_args
let _o s = output_name := Some s

36
toplevel/topdirs.ml
View File

@ -289,7 +289,7 @@ let printer_type ppf typename =
raise Exit in
printer_type
let match_simple_printer_type ppf desc printer_type =
let match_simple_printer_type desc printer_type =
Ctype.begin_def();
let ty_arg = Ctype.newvar() in
Ctype.unify !toplevel_env
@ -299,7 +299,7 @@ let match_simple_printer_type ppf desc printer_type =
Ctype.generalize ty_arg;
(ty_arg, None)
let match_generic_printer_type ppf desc path args printer_type =
let match_generic_printer_type desc path args printer_type =
Ctype.begin_def();
let args = List.map (fun _ -> Ctype.newvar ()) args in
let ty_target = Ctype.newty (Tconstr (path, args, ref Mnil)) in
@ -324,15 +324,15 @@ let match_printer_type ppf desc =
let printer_type_old = printer_type ppf "printer_type_old" in
Ctype.init_def(Ident.current_time());
try
(match_simple_printer_type ppf desc printer_type_new, false)
(match_simple_printer_type desc printer_type_new, false)
with Ctype.Unify _ ->
try
(match_simple_printer_type ppf desc printer_type_old, true)
(match_simple_printer_type desc printer_type_old, true)
with Ctype.Unify _ as exn ->
match extract_target_parameters desc.val_type with
| None -> raise exn
| Some (path, args) ->
(match_generic_printer_type ppf desc path args printer_type_new,
(match_generic_printer_type desc path args printer_type_new,
false)
let find_printer_type ppf lid =
@ -358,7 +358,7 @@ let dir_install_printer ppf lid =
| None ->
let print_function =
if is_old_style then
(fun formatter repr -> Obj.obj v (Obj.obj repr))
(fun _formatter repr -> Obj.obj v (Obj.obj repr))
else
(fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
install_printer path ty_arg print_function
@ -367,7 +367,7 @@ let dir_install_printer ppf lid =
| [] ->
let print_function =
if is_old_style then
(fun formatter repr -> Obj.obj v (Obj.obj repr))
(fun _formatter repr -> Obj.obj v (Obj.obj repr))
else
(fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
Zero print_function
@ -379,7 +379,7 @@ let dir_install_printer ppf lid =
let dir_remove_printer ppf lid =
try
let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in
begin try
remove_printer path
with Not_found ->
@ -414,7 +414,7 @@ let dir_trace ppf lid =
let (path, desc) = Env.lookup_value lid !toplevel_env in
(* Check if this is a primitive *)
match desc.val_kind with
| Val_prim p ->
| Val_prim _ ->
fprintf ppf "%a is an external function and cannot be traced.@."
Printtyp.longident lid
| _ ->
@ -449,7 +449,7 @@ let dir_trace ppf lid =
let dir_untrace ppf lid =
try
let (path, desc) = Env.lookup_value lid !toplevel_env in
let (path, _desc) = Env.lookup_value lid !toplevel_env in
let rec remove = function
| [] ->
fprintf ppf "%a was not traced.@." Printtyp.longident lid;
@ -530,7 +530,7 @@ let reg_show_prim name to_sig doc =
let () =
reg_show_prim "show_val"
(fun env loc id lid ->
let path, desc = Typetexp.find_value env loc lid in
let _path, desc = Typetexp.find_value env loc lid in
[ Sig_value (id, desc) ]
)
"Print the signature of the corresponding value."
@ -538,7 +538,7 @@ let () =
let () =
reg_show_prim "show_type"
(fun env loc id lid ->
let path, desc = Typetexp.find_type env loc lid in
let _path, desc = Typetexp.find_type env loc lid in
[ Sig_type (id, desc, Trec_not) ]
)
"Print the signature of the corresponding type constructor."
@ -569,7 +569,7 @@ let () =
let () =
reg_show_prim "show_module"
(fun env loc id lid ->
let path, md = Typetexp.find_module env loc lid in
let _path, md = Typetexp.find_module env loc lid in
[ Sig_module (id, {md with md_type = trim_signature md.md_type},
Trec_not) ]
)
@ -578,7 +578,7 @@ let () =
let () =
reg_show_prim "show_module_type"
(fun env loc id lid ->
let path, desc = Typetexp.find_modtype env loc lid in
let _path, desc = Typetexp.find_modtype env loc lid in
[ Sig_modtype (id, desc) ]
)
"Print the signature of the corresponding module type."
@ -586,7 +586,7 @@ let () =
let () =
reg_show_prim "show_class"
(fun env loc id lid ->
let path, desc = Typetexp.find_class env loc lid in
let _path, desc = Typetexp.find_class env loc lid in
[ Sig_class (id, desc, Trec_not) ]
)
"Print the signature of the corresponding class."
@ -594,7 +594,7 @@ let () =
let () =
reg_show_prim "show_class_type"
(fun env loc id lid ->
let path, desc = Typetexp.find_class_type env loc lid in
let _path, desc = Typetexp.find_class_type env loc lid in
[ Sig_class_type (id, desc, Trec_not) ]
)
"Print the signature of the corresponding class type."
@ -740,9 +740,9 @@ let print_directive ppf (name, directive, doc) =
| Directive_bool _ -> " <bool>"
| Directive_ident _ -> " <ident>" in
match doc with
| None -> printf "#%s%s@." name param
| None -> fprintf ppf "#%s%s@." name param
| Some doc ->
printf "@[<hov 2>#%s%s@\n%a@]@."
fprintf ppf "@[<hov 2>#%s%s@\n%a@]@."
name param
Format.pp_print_text doc

6
toplevel/toploop.ml
View File

@ -65,9 +65,9 @@ let rec eval_path = function
with Not_found ->
raise (Symtable.Error(Symtable.Undefined_global name))
end
| Pdot(p, s, pos) ->
| Pdot(p, _s, pos) ->
Obj.field (eval_path p) pos
| Papply(p1, p2) ->
| Papply _ ->
fatal_error "Toploop.eval_path"
let eval_path env path =
@ -334,7 +334,7 @@ let execute_phrase print_outcome ppf phr =
dir_name;
false
end
| Directive_int f, Pdir_int (n, Some _) ->
| Directive_int _, Pdir_int (_, Some _) ->
fprintf ppf "Wrong integer literal for directive `%s'.@."
dir_name;
false

2
toplevel/trace.ml
View File

@ -67,7 +67,7 @@ let rec instrument_result env name ppf clos_typ =
match name with
| Lident s -> Lident(s ^ "*")
| Ldot(lid, s) -> Ldot(lid, s ^ "*")
| Lapply(l1, l2) -> fatal_error "Trace.instrument_result" in
| Lapply _ -> fatal_error "Trace.instrument_result" in
let trace_res = instrument_result env starred_name ppf t2 in
(fun clos_val ->
Obj.repr (fun arg ->

14
typing/btype.ml
View File

@ -383,7 +383,7 @@ let type_iterators =
| Tvariant row ->
may (fun (p,_) -> it.it_path p) (row_repr row).row_name
| _ -> ()
and it_path p = ()
and it_path _p = ()
in
{ it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
it_type_kind; it_class_type; it_module_type;
@ -436,12 +436,12 @@ let rec copy_type_desc ?(keep_names=false) f = function
| Tobject(ty, {contents = Some (p, tl)})
-> Tobject (f ty, ref (Some(p, List.map f tl)))
| Tobject (ty, _) -> Tobject (f ty, ref None)
| Tvariant row -> assert false (* too ambiguous *)
| Tvariant _ -> assert false (* too ambiguous *)
| Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
Tfield (p, field_kind_repr k, f ty1, f ty2)
| Tnil -> Tnil
| Tlink ty -> copy_type_desc f ty.desc
| Tsubst ty -> assert false
| Tsubst _ -> assert false
| Tunivar _ as ty -> ty (* always keep the name *)
| Tpoly (ty, tyl) ->
let tyl = List.map (fun x -> norm_univar (f x)) tyl in
@ -510,7 +510,7 @@ let rec unmark_type ty =
end
let unmark_iterators =
let it_type_expr it ty = unmark_type ty in
let it_type_expr _it ty = unmark_type ty in
{type_iterators with it_type_expr}
let unmark_type_decl decl =
@ -523,7 +523,7 @@ let unmark_extension_constructor ext =
let unmark_class_signature sign =
unmark_type sign.csig_self;
Vars.iter (fun l (m, v, t) -> unmark_type t) sign.csig_vars
Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars
let unmark_class_type cty =
unmark_iterators.it_class_type unmark_iterators cty
@ -542,7 +542,7 @@ let lte_public p1 p2 = (* Private <= Public *)
let rec find_expans priv p1 = function
Mnil -> None
| Mcons (priv', p2, ty0, ty, _)
| Mcons (priv', p2, _ty0, ty, _)
when lte_public priv priv' && Path.same p1 p2 -> Some ty
| Mcons (_, _, _, _, rem) -> find_expans priv p1 rem
| Mlink {contents = rem} -> find_expans priv p1 rem
@ -718,7 +718,7 @@ let rec rev_compress_log log r =
| Change (_, next) ->
rev_compress_log log next
let undo_compress (changes, old) =
let undo_compress (changes, _old) =
match !changes with
Unchanged
| Invalid -> ()

114
typing/ctype.ml
View File

@ -284,9 +284,9 @@ let associate_fields fields1 fields2 =
(List.rev p, List.rev s, (List.rev s') @ l')
| ((n, k, t)::r, (n', k', t')::r') when n = n' ->
associate ((n, k, t, k', t')::p) s s' (r, r')
| ((n, k, t)::r, ((n', k', t')::_ as l')) when n < n' ->
| ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' ->
associate p ((n, k, t)::s) s' (r, l')
| (((n, k, t)::r as l), (n', k', t')::r') (* when n > n' *) ->
| (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) ->
associate p s ((n', k', t')::s') (l, r')
in
associate [] [] [] (fields1, fields2)
@ -345,7 +345,7 @@ let row_variable ty =
let set_object_name id rv params ty =
match (repr ty).desc with
Tobject (fi, nm) ->
Tobject (_fi, nm) ->
set_name nm (Some (Path.Pident id, rv::params))
| _ ->
assert false
@ -382,7 +382,7 @@ let rec signature_of_class_type =
function
Cty_constr (_, _, cty) -> signature_of_class_type cty
| Cty_signature sign -> sign
| Cty_arrow (_, ty, cty) -> signature_of_class_type cty
| Cty_arrow (_, _, cty) -> signature_of_class_type cty
let self_type cty =
repr (signature_of_class_type cty).csig_self
@ -418,7 +418,7 @@ let merge_row_fields fi1 fi2 =
let rec filter_row_fields erase = function
[] -> []
| (l,f as p)::fi ->
| (_l,f as p)::fi ->
let fi = filter_row_fields erase fi in
match row_field_repr f with
Rabsent -> fi
@ -511,7 +511,7 @@ let closed_type_decl decl =
| Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l
)
v
| Type_record(r, rep) ->
| Type_record(r, _rep) ->
List.iter (fun l -> closed_type l.ld_type) r
| Type_open -> ()
end;
@ -659,7 +659,7 @@ let rec generalize_spine ty =
| _ -> ()
let forward_try_expand_once = (* Forward declaration *)
ref (fun env ty -> raise Cannot_expand)
ref (fun _env _ty -> raise Cannot_expand)
(*
Lower the levels of a type (assume [level] is not
@ -707,7 +707,7 @@ let rec update_level env level ty =
| None -> ()
end;
match ty.desc with
Tconstr(p, tl, abbrev) when level < get_level env p ->
Tconstr(p, _tl, _abbrev) when level < get_level env p ->
(* Try first to replace an abbreviation by its expansion. *)
begin try
(* if is_newtype env p then raise Cannot_expand; *)
@ -724,14 +724,14 @@ let rec update_level env level ty =
if Path.same p p' then raise (Unify [(ty, newvar2 level)]);
log_type ty; ty.desc <- Tpackage (p', nl, tl);
update_level env level ty
| Tobject(_, ({contents=Some(p, tl)} as nm))
| Tobject(_, ({contents=Some(p, _tl)} as nm))
when level < get_level env p ->
set_name nm None;
update_level env level ty
| Tvariant row ->
let row = row_repr row in
begin match row.row_name with
| Some (p, tl) when level < get_level env p ->
| Some (p, _tl) when level < get_level env p ->
log_type ty;
ty.desc <- Tvariant {row with row_name = None}
| _ -> ()
@ -864,7 +864,7 @@ let compute_univars ty =
let node_univars = TypeHash.create 17 in
let rec add_univar univ inv =
match inv.inv_type.desc with
Tpoly (ty, tl) when List.memq univ (List.map repr tl) -> ()
Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> ()
| _ ->
try
let univs = TypeHash.find node_univars inv.inv_type in
@ -1025,7 +1025,7 @@ let rec copy ?env ?partial ?keep_names ty =
(* Return a new copy *)
Tvariant (copy_row copy true row keep more')
end
| Tfield (p, k, ty1, ty2) ->
| Tfield (_p, k, _ty1, ty2) ->
begin match field_kind_repr k with
Fabsent -> Tlink (copy ty2)
| Fpresent -> copy_type_desc copy desc
@ -1064,7 +1064,7 @@ let instance_def sch =
cleanup_types ();
ty
let generic_instance ?partial env sch =
let generic_instance env sch =
let old = !current_level in
current_level := generic_level;
let ty = instance env sch in
@ -1281,7 +1281,7 @@ let instance_label fixed lbl =
match repr lbl.lbl_arg with
{desc = Tpoly (ty, tl)} ->
instance_poly fixed tl ty
| ty ->
| _ ->
[], copy lbl.lbl_arg
in
cleanup_types ();
@ -1290,7 +1290,7 @@ let instance_label fixed lbl =
(**** Instantiation with parameter substitution ****)
let unify' = (* Forward declaration *)
ref (fun env ty1 ty2 -> raise (Unify []))
ref (fun _env _ty1 _ty2 -> raise (Unify []))
let subst env level priv abbrev ty params args body =
if List.length params <> List.length args then raise (Unify []);
@ -1439,7 +1439,7 @@ let safe_abbrev env ty =
let try_expand_once env ty =
let ty = repr ty in
match ty.desc with
Tconstr (p, _, _) -> repr (expand_abbrev env ty)
Tconstr _ -> repr (expand_abbrev env ty)
| _ -> raise Cannot_expand
(* This one only raises Cannot_expand *)
@ -1524,7 +1524,7 @@ let expand_head_opt env ty =
respect the type constraints *)
let enforce_constraints env ty =
match ty with
{desc = Tconstr (path, args, abbrev); level = level} ->
{desc = Tconstr (path, args, _abbrev); level = level} ->
begin try
let decl = Env.find_type path env in
ignore
@ -1588,7 +1588,7 @@ let rec occur_rec env allow_recursive visited ty0 = function
| ty ->
if ty == ty0 then raise Occur;
match ty.desc with
Tconstr(p, tl, abbrev) ->
Tconstr(p, _tl, _abbrev) ->
if allow_recursive && is_contractive env p then () else
begin try
if TypeSet.mem ty visited then raise Occur;
@ -1639,7 +1639,7 @@ let rec local_non_recursive_abbrev visited env p ty =
let ty = repr ty in
if not (List.memq ty visited) then begin
match ty.desc with
Tconstr(p', args, abbrev) ->
Tconstr(p', args, _abbrev) ->
if Path.same p p' then raise Occur;
if is_contractive env p' then () else
let visited = ty :: visited in
@ -2034,7 +2034,7 @@ and mcomp_fields type_pairs env ty1 ty2 =
if miss1 <> [] && (object_row ty1).desc = Tnil
|| miss2 <> [] && (object_row ty2).desc = Tnil then raise (Unify []);
List.iter
(function (n, k1, t1, k2, t2) ->
(function (_n, k1, t1, k2, t2) ->
mcomp_kind k1 k2;
mcomp type_pairs env t1 t2)
pairs
@ -2244,7 +2244,7 @@ let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 =
&& !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found
let unify_eq env t1 t2 =
let unify_eq t1 t2 =
t1 == t2 ||
match !umode with
| Expression -> false
@ -2269,7 +2269,7 @@ let rec unify (env:Env.t ref) t1 t2 =
if t1 == t2 then () else
let t1 = repr t1 in
let t2 = repr t2 in
if unify_eq !env t1 t2 then () else
if unify_eq t1 t2 then () else
let reset_tracing = check_trace_gadt_instances !env in
try
@ -2326,7 +2326,7 @@ and unify2 env t1 t2 =
let lv = min t1'.level t2'.level in
update_level !env lv t2;
update_level !env lv t1;
if unify_eq !env t1' t2' then () else
if unify_eq t1' t2' then () else
let t1 = repr t1 and t2 = repr t2 in
if !trace_gadt_instances then begin
@ -2346,7 +2346,7 @@ and unify2 env t1 t2 =
(match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2)
else (t1, t2)
in
if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then
if unify_eq t1 t1' || not (unify_eq t2 t2') then
unify3 env t1 t1' t2 t2'
else
try unify3 env t2 t2' t1 t1' with Unify trace ->
@ -2568,7 +2568,7 @@ and unify_kind k1 k2 =
and unify_row env row1 row2 =
let row1 = row_repr row1 and row2 = row_repr row2 in
let rm1 = row_more row1 and rm2 = row_more row2 in
if unify_eq !env rm1 rm2 then () else
if unify_eq rm1 rm2 then () else
let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
if r1 <> [] && r2 <> [] then begin
let ht = Hashtbl.create (List.length r1) in
@ -2683,7 +2683,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
and (tl2',tlu2) = split_univars tl2' in
begin match tlu1, tlu2 with
[], [] -> ()
| (tu1::tlu1), (tu2::_) ->
| (tu1::tlu1), _ :: _ ->
(* Attempt to merge all the types containing univars *)
List.iter (unify env tu1) (tlu1@tlu2)
| (tu::_, []) | ([], tu::_) -> occur_univar !env tu
@ -2934,7 +2934,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
end
| (Tvariant row1, Tvariant row2) ->
moregen_row inst_nongen type_pairs env row1 row2
| (Tobject (fi1, nm1), Tobject (fi2, nm2)) ->
| (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
moregen_fields inst_nongen type_pairs env fi1 fi2
| (Tfield _, Tfield _) -> (* Actually unused *)
moregen_fields inst_nongen type_pairs env t1' t2'
@ -3011,7 +3011,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 =
| _ -> raise (Unify [])
end;
List.iter
(fun (l,f1,f2) ->
(fun (_l,f1,f2) ->
let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
if f1 == f2 then () else
match f1, f2 with
@ -3200,7 +3200,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
end
| (Tvariant row1, Tvariant row2) ->
eqtype_row rename type_pairs subst env row1 row2
| (Tobject (fi1, nm1), Tobject (fi2, nm2)) ->
| (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
eqtype_fields rename type_pairs subst env fi1 fi2
| (Tfield _, Tfield _) -> (* Actually unused *)
eqtype_fields rename type_pairs subst env t1' t2'
@ -3349,19 +3349,19 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
| Cty_signature sign1, Cty_signature sign2 ->
let ty1 = object_fields (repr sign1.csig_self) in
let ty2 = object_fields (repr sign2.csig_self) in
let (fields1, rest1) = flatten_fields ty1
and (fields2, rest2) = flatten_fields ty2 in
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
let (fields1, _rest1) = flatten_fields ty1
and (fields2, _rest2) = flatten_fields ty2 in
let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
List.iter
(fun (lab, k1, t1, k2, t2) ->
(fun (lab, _k1, t1, _k2, t2) ->
begin try moregen true type_pairs env t1 t2 with Unify trace ->
raise (Failure [CM_Meth_type_mismatch
(lab, env, expand_trace env trace)])
end)
pairs;
Vars.iter
(fun lab (mut, v, ty) ->
let (mut', v', ty') = Vars.find lab sign1.csig_vars in
(fun lab (_mut, _v, ty) ->
let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in
try moregen true type_pairs env ty' ty with Unify trace ->
raise (Failure [CM_Val_type_mismatch
(lab, env, expand_trace env trace)]))
@ -3418,16 +3418,16 @@ let match_class_types ?(trace=true) env pat_sch subj_sch =
moregen true type_pairs env rest1 rest2;
let error =
List.fold_right
(fun (lab, k1, t1, k2, t2) err ->
(fun (lab, k1, _t1, k2, _t2) err ->
try moregen_kind k1 k2; err with
Unify _ -> CM_Public_method lab::err)
pairs error
in
let error =
Vars.fold
(fun lab (mut, vr, ty) err ->
(fun lab (mut, vr, _ty) err ->
try
let (mut', vr', ty') = Vars.find lab sign1.csig_vars in
let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
if mut = Mutable && mut' <> Mutable then
CM_Non_mutable_value lab::err
else if vr = Concrete && vr' <> Concrete then
@ -3484,11 +3484,11 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
| Cty_signature sign1, Cty_signature sign2 ->
let ty1 = object_fields (repr sign1.csig_self) in
let ty2 = object_fields (repr sign2.csig_self) in
let (fields1, rest1) = flatten_fields ty1
and (fields2, rest2) = flatten_fields ty2 in
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
let (fields1, _rest1) = flatten_fields ty1
and (fields2, _rest2) = flatten_fields ty2 in
let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
List.iter
(fun (lab, k1, t1, k2, t2) ->
(fun (lab, _k1, t1, _k2, t2) ->
begin try eqtype true type_pairs subst env t1 t2 with
Unify trace ->
raise (Failure [CM_Meth_type_mismatch
@ -3527,7 +3527,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
let err =
let k = field_kind_repr k in
begin match k with
Fvar r -> err
Fvar _ -> err
| _ -> CM_Hide_public lab::err
end
in
@ -3543,7 +3543,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
eqtype true type_pairs subst env rest1 rest2;
let error =
List.fold_right
(fun (lab, k1, t1, k2, t2) err ->
(fun (lab, k1, _t1, k2, _t2) err ->
let k1 = field_kind_repr k1 in
let k2 = field_kind_repr k2 in
match k1, k2 with
@ -3556,9 +3556,9 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
in
let error =
Vars.fold
(fun lab (mut, vr, ty) err ->
(fun lab (mut, vr, _ty) err ->
try
let (mut', vr', ty') = Vars.find lab sign1.csig_vars in
let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
if mut = Mutable && mut' <> Mutable then
CM_Non_mutable_value lab::err
else if vr = Concrete && vr' <> Concrete then
@ -3651,7 +3651,7 @@ let rec lid_of_path ?(sharp="") = function
Longident.Lapply (lid_of_path ~sharp p1, lid_of_path p2)
let find_cltype_for_path env p =
let path, cl_abbr = Env.lookup_type (lid_of_path ~sharp:"#" p) env in
let _path, cl_abbr = Env.lookup_type (lid_of_path ~sharp:"#" p) env in
match cl_abbr.type_manifest with
Some ty ->
begin match (repr ty).desc with
@ -3733,7 +3733,7 @@ let rec build_subtype env visited loops posi level t =
if c > Unchanged then (t'',c)
else (t, Unchanged)
end
| Tconstr(p, tl, abbrev) ->
| Tconstr(p, tl, _abbrev) ->
(* Must check recursion on constructors, since we do not always
expand them *)
if memq_warn t visited then (t, Unchanged) else
@ -3872,10 +3872,10 @@ let rec subtype_rec env trace t1 t2 cstrs =
subtype_list env trace tl1 tl2 cstrs
| (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
cstrs
| (Tconstr(p1, tl1, abbrev1), _)
| (Tconstr(p1, _tl1, _abbrev1), _)
when generic_abbrev env p1 && safe_abbrev env t1 ->
subtype_rec env trace (expand_abbrev env t1) t2 cstrs
| (_, Tconstr(p2, tl2, abbrev2))
| (_, Tconstr(p2, _tl2, _abbrev2))
when generic_abbrev env p2 && safe_abbrev env t2 ->
subtype_rec env trace t1 (expand_abbrev env t2) cstrs
| (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
@ -3979,7 +3979,7 @@ and subtype_fields env trace ty1 ty2 cstrs =
!univar_pairs) :: cstrs
in
List.fold_left
(fun cstrs (_, k1, t1, k2, t2) ->
(fun cstrs (_, _k1, t1, _k2, t2) ->
(* Theses fields are always present *)
subtype_rec env ((t1, t2)::trace) t1 t2 cstrs)
cstrs pairs
@ -4078,7 +4078,7 @@ let unalias ty =
(* Return the arity (as for curried functions) of the given type. *)
let rec arity ty =
match (repr ty).desc with
Tarrow(_, t1, t2, _) -> 1 + arity t2
Tarrow(_, _t1, t2, _) -> 1 + arity t2
| _ -> 0
(* Check whether an abbreviation expands to itself. *)
@ -4086,7 +4086,7 @@ let cyclic_abbrev env id ty =
let rec check_cycle seen ty =
let ty = repr ty in
match ty.desc with
Tconstr (p, tl, abbrev) ->
Tconstr (p, _tl, _abbrev) ->
p = Path.Pident id || List.memq ty seen ||
begin try
check_cycle (ty :: seen) (expand_abbrev_opt env ty)
@ -4221,7 +4221,7 @@ let rec nondep_type_rec env id ty =
TypeHash.add nondep_hash ty ty';
ty'.desc <-
begin match ty.desc with
| Tconstr(p, tl, abbrev) ->
| Tconstr(p, tl, _abbrev) ->
if Path.isfree id p then
begin try
Tlink (nondep_type_rec env id
@ -4266,7 +4266,7 @@ let rec nondep_type_rec env id ty =
let row =
copy_row (nondep_type_rec env id) true row true more' in
match row.row_name with
Some (p, tl) when Path.isfree id p ->
Some (p, _tl) when Path.isfree id p ->
Tvariant {row with row_name = None}
| _ -> Tvariant row
end
@ -4432,7 +4432,7 @@ let rec collapse_conj env visited ty =
Tvariant row ->
let row = row_repr row in
List.iter
(fun (l,fi) ->
(fun (_l,fi) ->
match row_field_repr fi with
Reither (c, t1::(_::_ as tl), m, e) ->
List.iter (unify env t1) tl;
@ -4459,7 +4459,7 @@ let () =
let maybe_pointer_type env typ =
match (repr typ).desc with
| Tconstr(p, args, abbrev) ->
| Tconstr(p, _args, _abbrev) ->
begin try
let type_decl = Env.find_type p env in
not type_decl.type_immediate

2
typing/ctype.mli
View File

@ -116,7 +116,7 @@ val instance: ?partial:bool -> Env.t -> type_expr -> type_expr
partial=true -> newty2 ty.level Tvar for non generic subterms *)
val instance_def: type_expr -> type_expr
(* use defaults *)
val generic_instance: ?partial:bool -> Env.t -> type_expr -> type_expr
val generic_instance: Env.t -> type_expr -> type_expr
(* Same as instance, but new nodes at generic_level *)
val instance_list: Env.t -> type_expr list -> type_expr list
(* Take an instance of a list of type schemes *)

96
typing/env.ml
View File

@ -297,22 +297,22 @@ let diff env1 env2 =
(* Forward declarations *)
let components_of_module' =
ref ((fun ~deprecated env sub path mty -> assert false) :
ref ((fun ~deprecated:_ _env _sub _path _mty -> assert false) :
deprecated:string option -> t -> Subst.t -> Path.t -> module_type ->
module_components)
let components_of_module_maker' =
ref ((fun (env, sub, path, mty) -> assert false) :
ref ((fun (_env, _sub, _path, _mty) -> assert false) :
t * Subst.t * Path.t * module_type -> module_components_repr)
let components_of_functor_appl' =
ref ((fun f env p1 p2 -> assert false) :
ref ((fun _f _env _p1 _p2 -> assert false) :
functor_components -> t -> Path.t -> Path.t -> module_components)
let check_modtype_inclusion =
(* to be filled with Includemod.check_modtype_inclusion *)
ref ((fun env mty1 path1 mty2 -> assert false) :
ref ((fun _env _mty1 _path1 _mty2 -> assert false) :
t -> module_type -> Path.t -> module_type -> unit)
let strengthen =
(* to be filled with Mtype.strengthen *)
ref ((fun env mty path -> assert false) :
ref ((fun _env _mty _path -> assert false) :
t -> module_type -> Path.t -> module_type)
let md md_type =
@ -524,42 +524,42 @@ let rec find_module_descr path env =
match path with
Pident id ->
begin try
let (p, desc) = EnvTbl.find_same id env.components
let (_p, desc) = EnvTbl.find_same id env.components
in desc
with Not_found ->
if Ident.persistent id && not (Ident.name id = !current_unit)
then (find_pers_struct (Ident.name id)).ps_comps
else raise Not_found
end
| Pdot(p, s, pos) ->
| Pdot(p, s, _pos) ->
begin match get_components (find_module_descr p env) with
Structure_comps c ->
let (descr, pos) = Tbl.find s c.comp_components in
let (descr, _pos) = Tbl.find s c.comp_components in
descr
| Functor_comps f ->
| Functor_comps _ ->
raise Not_found
end
| Papply(p1, p2) ->
begin match get_components (find_module_descr p1 env) with
Functor_comps f ->
!components_of_functor_appl' f env p1 p2
| Structure_comps c ->
| Structure_comps _ ->
raise Not_found
end
let find proj1 proj2 path env =
match path with
Pident id ->
let (p, data) = EnvTbl.find_same id (proj1 env)
let (_p, data) = EnvTbl.find_same id (proj1 env)
in data
| Pdot(p, s, pos) ->
| Pdot(p, s, _pos) ->
begin match get_components (find_module_descr p env) with
Structure_comps c ->
let (data, pos) = Tbl.find s (proj2 c) in data
| Functor_comps f ->
let (data, _pos) = Tbl.find s (proj2 c) in data
| Functor_comps _ ->
raise Not_found
end
| Papply(p1, p2) ->
| Papply _ ->
raise Not_found
let find_value =
@ -627,7 +627,7 @@ let find_module ~alias path env =
match path with
Pident id ->
begin try
let (p, data) = EnvTbl.find_same id env.modules
let (_p, data) = EnvTbl.find_same id env.modules
in data
with Not_found ->
if Ident.persistent id && not (Ident.name id = !current_unit) then
@ -635,12 +635,12 @@ let find_module ~alias path env =
md (Mty_signature(Lazy.force ps.ps_sig))
else raise Not_found
end
| Pdot(p, s, pos) ->
| Pdot(p, s, _pos) ->
begin match get_components (find_module_descr p env) with
Structure_comps c ->
let (data, pos) = Tbl.find s c.comp_modules in
let (data, _pos) = Tbl.find s c.comp_modules in
md (EnvLazy.force subst_modtype_maker data)
| Functor_comps f ->
| Functor_comps _ ->
raise Not_found
end
| Papply(p1, p2) ->
@ -648,7 +648,7 @@ let find_module ~alias path env =
begin match get_components desc1 with
Functor_comps f ->
md begin match f.fcomp_res with
| Mty_alias p as mty-> mty
| Mty_alias _ as mty -> mty
| mty ->
if alias then mty else
try
@ -661,7 +661,7 @@ let find_module ~alias path env =
Hashtbl.add f.fcomp_subst_cache p2 mty;
mty
end
| Structure_comps c ->
| Structure_comps _ ->
raise Not_found
end
@ -754,7 +754,7 @@ let rec is_functor_arg path env =
begin try Ident.find_same id env.functor_args; true
with Not_found -> false
end
| Pdot (p, s, _) -> is_functor_arg p env
| Pdot (p, _s, _) -> is_functor_arg p env
| Papply _ -> true
(* Lookup by name *)
@ -786,7 +786,7 @@ let rec lookup_module_descr_aux ?loc lid env =
Structure_comps c ->
let (descr, pos) = Tbl.find s c.comp_components in
(Pdot(p, s, pos), descr)
| Functor_comps f ->
| Functor_comps _ ->
raise Not_found
end
| Lapply(l1, l2) ->
@ -797,7 +797,7 @@ let rec lookup_module_descr_aux ?loc lid env =
Functor_comps f ->
Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
(Papply(p1, p2), !components_of_functor_appl' f env p1 p2)
| Structure_comps c ->
| Structure_comps _ ->
raise Not_found
end
@ -834,12 +834,12 @@ and lookup_module ~load ?loc lid env : Path.t =
let (p, descr) = lookup_module_descr ?loc l env in
begin match get_components descr with
Structure_comps c ->
let (data, pos) = Tbl.find s c.comp_modules in
let (_data, pos) = Tbl.find s c.comp_modules in
let (comps, _) = Tbl.find s c.comp_components in
let p = Pdot(p, s, pos) in
report_deprecated ?loc p comps.deprecated;
p
| Functor_comps f ->
| Functor_comps _ ->
raise Not_found
end
| Lapply(l1, l2) ->
@ -851,7 +851,7 @@ and lookup_module ~load ?loc lid env : Path.t =
Functor_comps f ->
Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
p
| Structure_comps c ->
| Structure_comps _ ->
raise Not_found
end
@ -865,10 +865,10 @@ let lookup proj1 proj2 ?loc lid env =
Structure_comps c ->
let (data, pos) = Tbl.find s (proj2 c) in
(Pdot(p, s, pos), data)
| Functor_comps f ->
| Functor_comps _ ->
raise Not_found
end
| Lapply(l1, l2) ->
| Lapply _ ->
raise Not_found
let lookup_all_simple proj1 proj2 shadow ?loc lid env =
@ -880,23 +880,23 @@ let lookup_all_simple proj1 proj2 shadow ?loc lid env =
| [] -> []
| ((x, f) :: xs) ->
(x, f) ::
(do_shadow (List.filter (fun (y, g) -> not (shadow x y)) xs))
(do_shadow (List.filter (fun (y, _) -> not (shadow x y)) xs))
in
do_shadow xl
| Ldot(l, s) ->
let (p, desc) = lookup_module_descr ?loc l env in
let (_p, desc) = lookup_module_descr ?loc l env in
begin match get_components desc with
Structure_comps c ->
let comps =
try Tbl.find s (proj2 c) with Not_found -> []
in
List.map
(fun (data, pos) -> (data, (fun () -> ())))
(fun (data, _pos) -> (data, (fun () -> ())))
comps
| Functor_comps f ->
| Functor_comps _ ->
raise Not_found
end
| Lapply(l1, l2) ->
| Lapply _ ->
raise Not_found
let has_local_constraints env = env.local_constraints
@ -906,7 +906,7 @@ let cstr_shadow cstr1 cstr2 =
| Cstr_extension _, Cstr_extension _ -> true
| _ -> false
let lbl_shadow lbl1 lbl2 = false
let lbl_shadow _lbl1 _lbl2 = false
let lookup_value =
lookup (fun env -> env.values) (fun sc -> sc.comp_values)
@ -1098,7 +1098,7 @@ let iter_env proj1 proj2 f env () =
let visit =
match EnvLazy.get_arg mcomps.comps with
| None -> true
| Some (env, sub, path, mty) -> scrape_alias_for_visit env mty
| Some (env, _sub, _path, mty) -> scrape_alias_for_visit env mty
in
if not visit then () else
match get_components mcomps with
@ -1257,35 +1257,35 @@ let rec prefix_idents root pos sub = function
let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in
let (pl, final_sub) = prefix_idents root nextpos sub rem in
(p::pl, final_sub)
| Sig_type(id, decl, _) :: rem ->
| Sig_type(id, _, _) :: rem ->
let p = Pdot(root, Ident.name id, nopos) in
let (pl, final_sub) =
prefix_idents root pos (Subst.add_type id p sub) rem in
(p::pl, final_sub)
| Sig_typext(id, ext, _) :: rem ->
| Sig_typext(id, _, _) :: rem ->
let p = Pdot(root, Ident.name id, pos) in
(* we extend the substitution in case of an inlined record *)
let (pl, final_sub) =
prefix_idents root (pos+1) (Subst.add_type id p sub) rem in
(p::pl, final_sub)
| Sig_module(id, mty, _) :: rem ->
| Sig_module(id, _, _) :: rem ->
let p = Pdot(root, Ident.name id, pos) in
let (pl, final_sub) =
prefix_idents root (pos+1) (Subst.add_module id p sub) rem in
(p::pl, final_sub)
| Sig_modtype(id, decl) :: rem ->
| Sig_modtype(id, _) :: rem ->
let p = Pdot(root, Ident.name id, nopos) in
let (pl, final_sub) =
prefix_idents root pos
(Subst.add_modtype id (Mty_ident p) sub) rem in
(p::pl, final_sub)
| Sig_class(id, decl, _) :: rem ->
| Sig_class(id, _, _) :: rem ->
(* pretend this is a type, cf. PR#6650 *)
let p = Pdot(root, Ident.name id, pos) in
let (pl, final_sub) =
prefix_idents root (pos + 1) (Subst.add_type id p sub) rem in
(p::pl, final_sub)
| Sig_class_type(id, decl, _) :: rem ->
| Sig_class_type(id, _, _) :: rem ->
let p = Pdot(root, Ident.name id, nopos) in
let (pl, final_sub) =
prefix_idents root pos (Subst.add_type id p sub) rem in
@ -1662,7 +1662,7 @@ let add_module ?arg id mty env =
let add_local_constraint id info elv env =
match info with
{type_manifest = Some ty; type_newtype_level = Some (lv, _)} ->
{type_manifest = Some _; type_newtype_level = Some (lv, _)} ->
(* elv is the expansion level, lv is the definition level *)
let env =
add_type ~check:false
@ -1711,7 +1711,7 @@ let rec add_signature sg env =
let open_signature slot root sg env0 =
(* First build the paths and substitution *)
let (pl, sub, sg) = prefix_idents_and_subst root Subst.identity sg in
let (pl, _sub, sg) = prefix_idents_and_subst root Subst.identity sg in
let sg = Lazy.force sg in
(* Then enter the components in the environment after substitution *)
@ -1877,17 +1877,17 @@ let find_all_simple_list proj1 proj2 f lid env acc =
match lid with
| None ->
EnvTbl.fold_name
(fun id data acc -> f data acc)
(fun _id data acc -> f data acc)
(proj1 env) acc
| Some l ->
let p, desc = lookup_module_descr l env in
let (_p, desc) = lookup_module_descr l env in
begin match get_components desc with
Structure_comps c ->
Tbl.fold
(fun s comps acc ->
(fun _s comps acc ->
match comps with
[] -> acc
| (data, pos) :: _ ->
| (data, _pos) :: _ ->
f data acc)
(proj2 c) acc
| Functor_comps _ ->

20
typing/ident.mli
View File

@ -17,6 +17,14 @@
type t = { stamp: int; name: string; mutable flags: int }
include Identifiable.S with type t := t
(* Notes:
- [equal] compares identifiers by name
- [compare x y] is 0 if [same x y] is true.
- [compare] compares identifiers by binding location
*)
val create: string -> t
val create_persistent: string -> t
val create_predef_exn: string -> t
@ -25,8 +33,6 @@ val name: t -> string
val unique_name: t -> string
val unique_toplevel_name: t -> string
val persistent: t -> bool
val equal: t -> t -> bool
(* Compare identifiers by name. *)
val same: t -> t -> bool
(* Compare identifiers by binding location.
Two identifiers are the same either if they are both
@ -34,17 +40,12 @@ val same: t -> t -> bool
[new], or if they are both persistent and have the same
name. *)
val compare: t -> t -> int
(* [compare x y] is 0 if [same x y] is true. *)
val hash: t -> int
val hide: t -> t
(* Return an identifier with same name as the given identifier,
but stamp different from any stamp returned by new.
When put in a 'a tbl, this identifier can only be looked
up by name. *)
val compare : t -> t -> int
(* Compare identifiers by binding location *)
val make_global: t -> unit
val global: t -> bool
val is_predef_exn: t -> bool
@ -54,9 +55,6 @@ val current_time: unit -> int
val set_current_time: int -> unit
val reinit: unit -> unit
val print: Format.formatter -> t -> unit
val output : out_channel -> t -> unit
type 'a tbl
(* Association tables from identifiers to type 'a. *)
@ -73,5 +71,3 @@ val iter: (t -> 'a -> unit) -> 'a tbl -> unit
(* Idents for sharing keys *)
val make_key_generator : unit -> (t -> t)
include Identifiable.S with type t := t

2
typing/includeclass.ml
View File

@ -47,7 +47,7 @@ let include_err ppf =
function
| CM_Virtual_class ->
fprintf ppf "A class cannot be changed from virtual to concrete"
| CM_Parameter_arity_mismatch (ls, lp) ->
| CM_Parameter_arity_mismatch _ ->
fprintf ppf
"The classes do not have the same number of type parameters"
| CM_Type_parameter_mismatch (env, trace) ->

6
typing/includecore.ml
View File

@ -33,7 +33,7 @@ let value_descriptions env vd1 vd2 =
let pc = {pc_desc = p; pc_type = vd2.Types.val_type;
pc_env = env; pc_loc = vd1.Types.val_loc; } in
Tcoerce_primitive pc
| (_, Val_prim p) -> raise Dont_match
| (_, Val_prim _) -> raise Dont_match
| (_, _) -> Tcoerce_none
end else
raise Dont_match
@ -51,7 +51,7 @@ let private_flags decl1 decl2 =
let is_absrow env ty =
match ty.desc with
Tconstr(Pident id, _, _) ->
Tconstr(Pident _, _, _) ->
begin match Ctype.expand_head env ty with
{desc=Tobject _|Tvariant _} -> true
| _ -> false
@ -98,7 +98,7 @@ let type_manifest env ty1 params1 ty2 params2 priv2 =
Ctype.equal env true (ty1::params1) (rest2::params2) &&
let (fields1,rest1) = Ctype.flatten_fields fi1 in
(match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in
let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in
miss2 = [] &&
let tl1, tl2 =
List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in

28
typing/includemod.ml
View File

@ -245,11 +245,11 @@ and try_modtypes env cxt subst mty1 mty2 =
Tcoerce_alias (p1, modtypes env cxt subst mty1 mty2)
| (Mty_ident p1, _) when may_expand_module_path env p1 ->
try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
| (_, Mty_ident p2) ->
| (_, Mty_ident _) ->
try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
| (Mty_signature sig1, Mty_signature sig2) ->
signatures env cxt subst sig1 sig2
| (Mty_functor(param1, None, res1), Mty_functor(param2, None, res2)) ->
| (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) ->
begin match modtypes env (Body param1::cxt) subst res1 res2 with
Tcoerce_none -> Tcoerce_none
| cc -> Tcoerce_functor (Tcoerce_none, cc)
@ -372,34 +372,34 @@ and signature_components old_env env cxt subst paired =
let comps_rec rem = signature_components old_env env cxt subst rem in
match paired with
[] -> []
| (Sig_value(id1, valdecl1), Sig_value(id2, valdecl2), pos) :: rem ->
| (Sig_value(id1, valdecl1), Sig_value(_id2, valdecl2), pos) :: rem ->
let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
begin match valdecl2.val_kind with
Val_prim p -> comps_rec rem
Val_prim _ -> comps_rec rem
| _ -> (pos, cc) :: comps_rec rem
end
| (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem ->
| (Sig_type(id1, tydecl1, _), Sig_type(_id2, tydecl2, _), _pos) :: rem ->
type_declarations ~old_env env cxt subst id1 tydecl1 tydecl2;
comps_rec rem
| (Sig_typext(id1, ext1, _), Sig_typext(id2, ext2, _), pos)
| (Sig_typext(id1, ext1, _), Sig_typext(_id2, ext2, _), pos)
:: rem ->
extension_constructors env cxt subst id1 ext1 ext2;
(pos, Tcoerce_none) :: comps_rec rem
| (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem ->
| (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem ->
let p1 = Pident id1 in
let cc =
modtypes env (Module id1::cxt) subst
(Mtype.strengthen (Env.add_functor_arg id1 env) mty1.md_type p1)
mty2.md_type in
(pos, cc) :: comps_rec rem
| (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem ->
| (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem ->
modtype_infos env cxt subst id1 info1 info2;
comps_rec rem
| (Sig_class(id1, decl1, _), Sig_class(id2, decl2, _), pos) :: rem ->
| (Sig_class(id1, decl1, _), Sig_class(_id2, decl2, _), pos) :: rem ->
class_declarations ~old_env env cxt subst id1 decl1 decl2;
(pos, Tcoerce_none) :: comps_rec rem
| (Sig_class_type(id1, info1, _),
Sig_class_type(id2, info2, _), pos) :: rem ->
Sig_class_type(_id2, info2, _), _pos) :: rem ->
class_type_declarations ~old_env env cxt subst id1 info1 info2;
comps_rec rem
| _ ->
@ -413,7 +413,7 @@ and modtype_infos env cxt subst id info1 info2 =
try
match (info1.mtd_type, info2.mtd_type) with
(None, None) -> ()
| (Some mty1, None) -> ()
| (Some _, None) -> ()
| (Some mty1, Some mty2) ->
check_modtype_equiv env cxt' mty1 mty2
| (None, Some mty2) ->
@ -427,9 +427,9 @@ and check_modtype_equiv env cxt mty1 mty2 =
modtypes env cxt Subst.identity mty2 mty1)
with
(Tcoerce_none, Tcoerce_none) -> ()
| (c1, c2) ->
| (_c1, _c2) ->
(* Format.eprintf "@[c1 = %a@ c2 = %a@]@."
print_coercion c1 print_coercion c2; *)
print_coercion _c1 print_coercion _c2; *)
raise(Error [cxt, env, Modtype_permutation])
(* Simplified inclusion check between module types (for Env) *)
@ -438,7 +438,7 @@ let check_modtype_inclusion env mty1 path1 mty2 =
try
ignore(modtypes env [] Subst.identity
(Mtype.strengthen env mty1 path1) mty2)
with Error reasons ->
with Error _ ->
raise Not_found
let _ = Env.check_modtype_inclusion := check_modtype_inclusion

30
typing/mtype.ml
View File

@ -46,10 +46,10 @@ let rec strengthen env mty p =
and strengthen_sig env sg p pos =
match sg with
[] -> []
| (Sig_value(id, desc) as sigelt) :: rem ->
| (Sig_value(_, desc) as sigelt) :: rem ->
let nextpos = match desc.val_kind with Val_prim _ -> pos | _ -> pos+1 in
sigelt :: strengthen_sig env rem p nextpos
| Sig_type(id, {type_kind=Type_abstract}, rs) ::
| Sig_type(id, {type_kind=Type_abstract}, _) ::
(Sig_type(id', {type_private=Private}, _) :: _ as rem)
when Ident.name id = Ident.name id' ^ "#row" ->
strengthen_sig env rem p pos
@ -68,7 +68,7 @@ and strengthen_sig env sg p pos =
{ decl with type_manifest = manif }
in
Sig_type(id, newdecl, rs) :: strengthen_sig env rem p pos
| (Sig_typext(id, ext, es) as sigelt) :: rem ->
| (Sig_typext _ as sigelt) :: rem ->
sigelt :: strengthen_sig env rem p (pos+1)
| Sig_module(id, md, rs) :: rem ->
let str =
@ -91,9 +91,9 @@ and strengthen_sig env sg p pos =
Sig_modtype(id, newdecl) ::
strengthen_sig (Env.add_modtype id decl env) rem p pos
(* Need to add the module type in case it is manifest *)
| (Sig_class(id, decl, rs) as sigelt) :: rem ->
| (Sig_class _ as sigelt) :: rem ->
sigelt :: strengthen_sig env rem p (pos+1)
| (Sig_class_type(id, decl, rs) as sigelt) :: rem ->
| (Sig_class_type _ as sigelt) :: rem ->
sigelt :: strengthen_sig env rem p pos
and strengthen_decl env md p =
@ -171,7 +171,7 @@ let nondep_supertype env mid mty =
let enrich_typedecl env p decl =
match decl.type_manifest with
Some ty -> decl
Some _ -> decl
| None ->
try
let orig_decl = Env.find_type p env in
@ -203,18 +203,18 @@ and enrich_item env p = function
let rec type_paths env p mty =
match scrape env mty with
Mty_ident p -> []
| Mty_alias p -> []
Mty_ident _ -> []
| Mty_alias _ -> []
| Mty_signature sg -> type_paths_sig env p 0 sg
| Mty_functor(param, arg, res) -> []
| Mty_functor _ -> []
and type_paths_sig env p pos sg =
match sg with
[] -> []
| Sig_value(id, decl) :: rem ->
| Sig_value(_id, decl) :: rem ->
let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in
type_paths_sig env p pos' rem
| Sig_type(id, decl, _) :: rem ->
| Sig_type(id, _decl, _) :: rem ->
Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem
| Sig_module(id, md, _) :: rem ->
type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @
@ -228,15 +228,15 @@ and type_paths_sig env p pos sg =
let rec no_code_needed env mty =
match scrape env mty with
Mty_ident p -> false
Mty_ident _ -> false
| Mty_signature sg -> no_code_needed_sig env sg
| Mty_functor(_, _, _) -> false
| Mty_alias p -> true
| Mty_alias _ -> true
and no_code_needed_sig env sg =
match sg with
[] -> true
| Sig_value(id, decl) :: rem ->
| Sig_value(_id, decl) :: rem ->
begin match decl.val_kind with
| Val_prim _ -> no_code_needed_sig env rem
| _ -> false
@ -246,7 +246,7 @@ and no_code_needed_sig env sg =
no_code_needed_sig (Env.add_module_declaration id md env) rem
| (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
no_code_needed_sig env rem
| (Sig_typext _ | Sig_class _) :: rem ->
| (Sig_typext _ | Sig_class _) :: _ ->
false

2
typing/oprint.ml
View File

@ -431,7 +431,7 @@ and print_out_sig_item ppf =
| Osig_typext (ext, Oext_exception) ->
fprintf ppf "@[<2>exception %a@]"
print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
| Osig_typext (ext, es) ->
| Osig_typext (ext, _es) ->
print_out_extension_constructor ppf ext
| Osig_modtype (name, Omty_abstract) ->
fprintf ppf "@[<2>module type %s@]" name

57
typing/parmatch.ml
View File

@ -93,9 +93,9 @@ let rec compat p q =
| Tpat_lazy p, Tpat_lazy q -> compat p q
| Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) ->
c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
| Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) ->
| Tpat_variant(l1,Some p1, _r1), Tpat_variant(l2,Some p2,_) ->
l1=l2 && compat p1 p2
| Tpat_variant (l1,None,r1), Tpat_variant(l2,None,_) ->
| Tpat_variant (l1,None, _r1), Tpat_variant(l2,None,_) ->
l1 = l2
| Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false
| Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false
@ -156,7 +156,7 @@ let rec pretty_val ppf v =
begin match cstr with
| Tpat_unpack ->
fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
| Tpat_constraint ctyp ->
| Tpat_constraint _ ->
fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem }
| Tpat_type _ ->
fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
@ -323,8 +323,8 @@ let all_record_args lbls = match lbls with
(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
let rec simple_match_args p1 p2 = match p2.pat_desc with
| Tpat_alias (p2,_,_) -> simple_match_args p1 p2
| Tpat_construct(_, cstr, args) -> args
| Tpat_variant(lab, Some arg, _) -> [arg]
| Tpat_construct(_, _, args) -> args
| Tpat_variant(_, Some arg, _) -> [arg]
| Tpat_tuple(args) -> args
| Tpat_record(args,_) -> extract_fields (record_arg p1) args
| Tpat_array(args) -> args
@ -455,7 +455,7 @@ let do_set_args erase_mutable q r = match q with
make_pat
(Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_lazy omega} ->
| {pat_desc = Tpat_lazy _omega} ->
begin match r with
arg::rest ->
make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
@ -583,7 +583,7 @@ let close_variant env row =
let row = Btype.row_repr row in
let nm =
List.fold_left
(fun nm (tag,f) ->
(fun nm (_tag,f) ->
match Btype.row_field_repr f with
| Reither(_, _, false, e) ->
(* m=false means that this tag is not explicitly matched *)
@ -609,23 +609,8 @@ let row_of_pat pat =
not.
*)
let generalized_constructor x =
match x with
({pat_desc = Tpat_construct(_,c,_);pat_env=env},_) ->
c.cstr_generalized
| _ -> assert false
let clean_env env =
let rec loop =
function
| [] -> []
| x :: xs ->
if generalized_constructor x then loop xs else x :: loop xs
in
loop env
let full_match closing env = match env with
| ({pat_desc = Tpat_construct(_,c,_);pat_type=typ},_) :: _ ->
| ({pat_desc = Tpat_construct(_,c,_)},_) :: _ ->
if c.cstr_consts < 0 then false (* extensions *)
else List.length env = c.cstr_consts + c.cstr_nonconsts
| ({pat_desc = Tpat_variant _} as p,_) :: _ ->
@ -718,7 +703,7 @@ let pats_of_type ?(always=false) env ty =
List.for_all (fun cd -> cd.Types.cd_res <> None) cl ->
let cstrs = fst (Env.find_type_descrs path env) in
List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs
| Type_record (ldl, _) ->
| Type_record _ ->
let labels = snd (Env.find_type_descrs path env) in
let fields =
List.map (fun ld ->
@ -748,14 +733,6 @@ let rec get_variant_constructors env ty =
end
| _ -> fatal_error "Parmatch.get_variant_constructors"
let rec map_filter f =
function
[] -> []
| x :: xs ->
match f x with
| None -> map_filter f xs
| Some y -> y :: map_filter f xs
(* Sends back a pattern that complements constructor tags all_tag *)
let complete_constrs p all_tags =
let c =
@ -798,7 +775,7 @@ let build_other ext env = match env with
({cstr_tag=Cstr_extension _} as c),_)},_) :: _ ->
let c = {c with cstr_name = "*extension*"} in
make_pat (Tpat_construct(lid, c, [])) Ctype.none Env.empty
| ({pat_desc = Tpat_construct (_, cd,_)} as p,_) :: _ ->
| ({pat_desc = Tpat_construct _} as p,_) :: _ ->
begin match ext with
| Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
extra_pat
@ -896,7 +873,7 @@ let build_other ext env = match env with
(function f -> Tpat_constant(Const_float (string_of_float f)))
0.0 (fun f -> f +. 1.0) p env
| ({pat_desc = Tpat_array args} as p,_)::_ ->
| ({pat_desc = Tpat_array _} as p,_)::_ ->
let all_lengths =
List.map
(fun (p,_) -> match p.pat_desc with
@ -1020,12 +997,14 @@ type 'a result =
| Rnone (* No matching value *)
| Rsome of 'a (* This matching value *)
(*
let rec try_many f = function
| [] -> Rnone
| (p,pss)::rest ->
match f (p,pss) with
| Rnone -> try_many f rest
| r -> r
*)
let rappend r1 r2 =
match r1, r2 with
@ -1214,7 +1193,7 @@ let rec pressure_variants tdefs = function
[] -> pressure_variants tdefs (filter_extra pss)
| constrs ->
let rec try_non_omega = function
(p,pss) :: rem ->
(_p,pss) :: rem ->
let ok = pressure_variants tdefs pss in
try_non_omega rem && ok
| [] -> true
@ -1500,7 +1479,7 @@ let rec le_pat p q =
c1.cstr_tag = c2.cstr_tag && le_pats ps qs
| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
(l1 = l2 && le_pat p1 p2)
| Tpat_variant(l1,None,r1), Tpat_variant(l2,None,_) ->
| Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) ->
l1 = l2
| Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
| Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
@ -1555,7 +1534,7 @@ let rec lub p q = match p.pat_desc,q.pat_desc with
when l1=l2 ->
let r=lub p1 p2 in
make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
| Tpat_variant (l1,None,row), Tpat_variant(l2,None,_)
| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_)
when l1 = l2 -> p
| Tpat_record (l1,closed),Tpat_record (l2,_) ->
let rs = record_lubs l1 l2 in
@ -1727,7 +1706,7 @@ module Conv = struct
| lst -> Some (mkpat (Ppat_tuple lst))
in
mkpat (Ppat_construct(lid, arg))
| Tpat_variant(label,p_opt,row_desc) ->
| Tpat_variant(label,p_opt,_row_desc) ->
let arg = Misc.may_map loop p_opt in
mkpat (Ppat_variant(label, arg))
| Tpat_record (subpatterns, _closed_flag) ->
@ -1915,7 +1894,7 @@ let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt
(* Exported unused clause check *)
(********************************)
let check_unused pred tdefs casel =
let check_unused pred casel =
if Warnings.is_active Warnings.Unused_match
|| List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then
let rec do_rec pref = function

2
typing/parmatch.mli
View File

@ -71,7 +71,7 @@ val check_unused:
(string, constructor_description) Hashtbl.t ->
(string, label_description) Hashtbl.t ->
Parsetree.pattern -> pattern option) ->
Env.t -> case list -> unit
case list -> unit
(* Irrefutability tests *)
val irrefutable : pattern -> bool

Some files were not shown because too many files have changed in this diff Show More