diff options
83 files changed, 1679 insertions, 527 deletions
@@ -1,4 +1,4 @@ -putils/ccomp.cmi : +utils/ccomp.cmi : utils/clflags.cmi : utils/config.cmi : utils/consistbl.cmi : @@ -570,6 +570,7 @@ bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \ bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \ typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi +asmcomp/CSEgen.cmi : asmcomp/mach.cmi asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi asmcomp/asmlibrarian.cmi : asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi @@ -586,6 +587,7 @@ asmcomp/coloring.cmi : asmcomp/comballoc.cmi : asmcomp/mach.cmi asmcomp/compilenv.cmi : typing/ident.cmi asmcomp/cmx_format.cmi \ asmcomp/clambda.cmi +asmcomp/deadcode.cmi : asmcomp/mach.cmi asmcomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/emitaux.cmi : asmcomp/debuginfo.cmi @@ -611,6 +613,10 @@ asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/spill.cmi : asmcomp/mach.cmi asmcomp/split.cmi : asmcomp/mach.cmi asmcomp/strmatch.cmi : asmcomp/cmm.cmi +asmcomp/CSE.cmo : asmcomp/mach.cmi asmcomp/CSEgen.cmi asmcomp/arch.cmo +asmcomp/CSE.cmx : asmcomp/mach.cmx asmcomp/CSEgen.cmx asmcomp/arch.cmx +asmcomp/CSEgen.cmo : asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/mach.cmx asmcomp/CSEgen.cmi asmcomp/arch.cmo : asmcomp/arch.cmx : asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \ @@ -619,20 +625,20 @@ asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \ asmcomp/printlinear.cmi asmcomp/printcmm.cmi asmcomp/printclambda.cmi \ typing/primitive.cmi utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi \ asmcomp/liveness.cmi asmcomp/linearize.cmi asmcomp/interf.cmi \ - asmcomp/emitaux.cmi asmcomp/emit.cmi utils/config.cmi \ - asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \ - asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \ - asmcomp/asmgen.cmi + asmcomp/emitaux.cmi asmcomp/emit.cmi asmcomp/deadcode.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/comballoc.cmi \ + asmcomp/coloring.cmi asmcomp/cmmgen.cmi asmcomp/cmm.cmi \ + asmcomp/closure.cmi utils/clflags.cmi asmcomp/CSE.cmo asmcomp/asmgen.cmi asmcomp/asmgen.cmx : bytecomp/translmod.cmx asmcomp/split.cmx \ asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ asmcomp/printlinear.cmx asmcomp/printcmm.cmx asmcomp/printclambda.cmx \ typing/primitive.cmx utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx \ asmcomp/liveness.cmx asmcomp/linearize.cmx asmcomp/interf.cmx \ - asmcomp/emitaux.cmx asmcomp/emit.cmx utils/config.cmx \ - asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \ - asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \ - asmcomp/asmgen.cmi + asmcomp/emitaux.cmx asmcomp/emit.cmx asmcomp/deadcode.cmx \ + utils/config.cmx asmcomp/compilenv.cmx asmcomp/comballoc.cmx \ + asmcomp/coloring.cmx asmcomp/cmmgen.cmx asmcomp/cmm.cmx \ + asmcomp/closure.cmx utils/clflags.cmx asmcomp/CSE.cmx asmcomp/asmgen.cmi asmcomp/asmlibrarian.cmo : utils/misc.cmi parsing/location.cmi \ utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \ utils/clflags.cmi asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \ @@ -713,6 +719,10 @@ asmcomp/compilenv.cmo : utils/misc.cmi parsing/location.cmi typing/ident.cmi \ asmcomp/compilenv.cmx : utils/misc.cmx parsing/location.cmx typing/ident.cmx \ typing/env.cmx utils/config.cmx asmcomp/cmx_format.cmi \ asmcomp/clambda.cmx asmcomp/compilenv.cmi +asmcomp/deadcode.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/deadcode.cmi +asmcomp/deadcode.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/deadcode.cmi asmcomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \ asmcomp/debuginfo.cmi asmcomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \ @@ -977,18 +987,22 @@ toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ driver/compenv.cmx utils/clflags.cmx toplevel/opttopmain.cmi toplevel/opttopstart.cmo : toplevel/opttopmain.cmi toplevel/opttopstart.cmx : toplevel/opttopmain.cmx -toplevel/topdirs.cmo : utils/warnings.cmi typing/types.cmi \ - toplevel/trace.cmi toplevel/toploop.cmi bytecomp/symtable.cmi \ - typing/printtyp.cmi typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi \ - bytecomp/meta.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \ - bytecomp/dll.cmi typing/ctype.cmi utils/consistbl.cmi utils/config.cmi \ - bytecomp/cmo_format.cmi utils/clflags.cmi toplevel/topdirs.cmi -toplevel/topdirs.cmx : utils/warnings.cmx typing/types.cmx \ - toplevel/trace.cmx toplevel/toploop.cmx bytecomp/symtable.cmx \ - typing/printtyp.cmx typing/path.cmx bytecomp/opcodes.cmx utils/misc.cmx \ - bytecomp/meta.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \ - bytecomp/dll.cmx typing/ctype.cmx utils/consistbl.cmx utils/config.cmx \ - bytecomp/cmo_format.cmi utils/clflags.cmx toplevel/topdirs.cmi +toplevel/topdirs.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi toplevel/trace.cmi toplevel/toploop.cmi \ + bytecomp/symtable.cmi typing/printtyp.cmi typing/path.cmi \ + parsing/parsetree.cmi bytecomp/opcodes.cmo utils/misc.cmi \ + bytecomp/meta.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi bytecomp/dll.cmi typing/ctype.cmi \ + utils/consistbl.cmi utils/config.cmi bytecomp/cmo_format.cmi \ + utils/clflags.cmi toplevel/topdirs.cmi +toplevel/topdirs.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx toplevel/trace.cmx toplevel/toploop.cmx \ + bytecomp/symtable.cmx typing/printtyp.cmx typing/path.cmx \ + parsing/parsetree.cmi bytecomp/opcodes.cmx utils/misc.cmx \ + bytecomp/meta.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx typing/env.cmx bytecomp/dll.cmx typing/ctype.cmx \ + utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \ + utils/clflags.cmx toplevel/topdirs.cmi toplevel/toploop.cmo : utils/warnings.cmi typing/types.cmi \ typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \ bytecomp/translmod.cmi bytecomp/symtable.cmi bytecomp/simplif.cmi \ @@ -7,11 +7,9 @@ Language features: - Attributes and extension nodes - Generative functors - Module aliases -- Read-only strings: split the "string" type into two types, "string" and - "bytes". Same for the stdlib modules "String" and "Bytes". "string" is - now read-only and "bytes" is read-write. A compatibility mode (enabled - by default) identifies the two types so old programs still work as - before. The new mode is enabled with command-line option "-safe-string". +* Alternative syntax for string literals {id|...|id} (can break comments) +- Separation between read-only strings (type string) and read-write byte + sequences (type bytes). Activated by command-line option -safe-string. Build system for the OCaml distribution: - Use -bin-annot when building. @@ -40,6 +38,14 @@ Type system: representation is unchanged. Compilers: +- More aggressive constant propagation, including float and + int32/int64/nativeint arithmetic. Constant propagation for floats + can be turned off with option -no-float-const-prop, for codes that + change FP rounding modes at run-time. +- New back-end optimization pass: common subexpression elimination (CSE). + (Reuses results of previous computations instead of recomputing them.) +- New back-end optimization pass: dead code elimination. + (Removes arithmetic and load instructions whose results are unused.) - PR#6269 Optimization of string matching (patch by Benoit Vaugon and Luc Maranget) - Experimental native code generator for AArch64 (ARM 64 bits) @@ -56,8 +62,7 @@ Compilers: - PR#6260: Unnecessary boxing in let (patch by vbrankov) Toplevel interactive system: -- Support for directive with multiple arguments -- PR#5377: New "#show" directive +- PR#5377: New "#show_*" directives Runtime system: - Fixed a major performance problem on large heaps (~1GB) by making heap @@ -119,6 +124,7 @@ Bug fixes: - PR#6346: Build failure with latest version of xcode on OSX - PR#6348: Unification failure for GADT when original definition is hidden - PR#6352: Automatic removal of optional arguments and sequencing +- PR#6361: Hashtbl.hash not terminating on some lazy values w/ recursive types - fix -dsource printing of "external _pipe = ..." (Gabriel Scherer) - bound-checking bug in caml_string_{get,set}{16,32,64} @@ -85,10 +85,13 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \ asmcomp/closure.cmo asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ - asmcomp/comballoc.cmo asmcomp/liveness.cmo \ + asmcomp/comballoc.cmo \ + asmcomp/CSEgen.cmo asmcomp/CSE.cmo \ + asmcomp/liveness.cmo \ asmcomp/spill.cmo asmcomp/split.cmo \ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ + asmcomp/deadcode.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ @@ -589,6 +592,14 @@ partialclean:: beforedepend:: asmcomp/selection.ml +asmcomp/CSE.ml: asmcomp/$(ARCH)/CSE.ml + ln -s $(ARCH)/CSE.ml asmcomp/CSE.ml + +partialclean:: + rm -f asmcomp/CSE.ml + +beforedepend:: asmcomp/CSE.ml + asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml ln -s $(ARCH)/reload.ml asmcomp/reload.ml diff --git a/Makefile.nt b/Makefile.nt index cfeaac4b52..02e0b1c2df 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -519,6 +519,14 @@ partialclean:: beforedepend:: asmcomp/selection.ml +asmcomp/CSE.ml: asmcomp/$(ARCH)/CSE.ml + cp asmcomp/$(ARCH)/CSE.ml asmcomp/CSE.ml + +partialclean:: + rm -f asmcomp/CSE.ml + +beforedepend:: asmcomp/CSE.ml + asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml cp asmcomp/$(ARCH)/reload.ml asmcomp/reload.ml @@ -1,4 +1,4 @@ -4.02.0+safe-string6-2014-04-25 +4.02.0+safe-string7-2014-04-28 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/asmcomp/.ignore b/asmcomp/.ignore index 31d00178a0..8c24e74ad1 100644 --- a/asmcomp/.ignore +++ b/asmcomp/.ignore @@ -4,3 +4,4 @@ proc.ml selection.ml reload.ml scheduling.ml +CSE.ml diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml new file mode 100644 index 0000000000..1cbef266b8 --- /dev/null +++ b/asmcomp/CSEgen.ml @@ -0,0 +1,258 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Common subexpression elimination by value numbering over extended + basic blocks. *) + +open Mach + +type valnum = int + +(* We maintain sets of equations of the form + valnums = operation(valnums) + plus a mapping from registers to value numbers. *) + +type rhs = operation * valnum array + +module Equations = + Map.Make(struct type t = rhs let compare = Pervasives.compare end) + +type numbering = + { num_next: int; (* next fresh value number *) + num_eqs: valnum array Equations.t; (* mapping rhs -> valnums *) + num_reg: valnum Reg.Map.t } (* mapping register -> valnum *) + +let empty_numbering = + { num_next = 0; num_eqs = Equations.empty; num_reg = Reg.Map.empty } + +(** [valnum_reg n r] returns the value number for the contents of + register [r]. If none exists, a fresh value number is returned + and associated with register [r]. The possibly updated numbering + is also returned. [valnum_regs] is similar, but for an array of + registers. *) + +let valnum_reg n r = + try + (n, Reg.Map.find r n.num_reg) + with Not_found -> + let v = n.num_next in + ({n with num_next = v + 1; num_reg = Reg.Map.add r v n.num_reg}, v) + +let valnum_regs n rs = + let l = Array.length rs in + let vs = Array.make l 0 in + let n = ref n in + for i = 0 to l-1 do + let (ni, vi) = valnum_reg !n rs.(i) in + vs.(i) <- vi; + n := ni + done; + (!n, vs) + +(* Look up the set of equations for an equation with the given rhs. + Return [Some res] if there is one, where [res] is the lhs. *) + +let find_equation n rhs = + try + Some(Equations.find rhs n.num_eqs) + with Not_found -> + None + +(* Find a set of registers containing the given value numbers. *) + +let find_regs_containing n vs = + match Array.length vs with + | 0 -> Some [||] + | 1 -> let v = vs.(0) in + Reg.Map.fold (fun r v' res -> if v' = v then Some [|r|] else res) + n.num_reg None + | _ -> assert false + +(* Associate the given value numbers to the given result registers, + without adding new equations. *) + +let set_known_regs n rs vs = + match Array.length rs with + | 0 -> n + | 1 -> { n with num_reg = Reg.Map.add rs.(0) vs.(0) n.num_reg } + | _ -> assert false + +(* Record the effect of a move: no new equations, but the result reg + maps to the same value number as the argument reg. *) + +let set_move n src dst = + let (n1, v) = valnum_reg n src in + { n1 with num_reg = Reg.Map.add dst v n1.num_reg } + +(* Record the equation [fresh valnums = rhs] and associate the given + result registers [rs] to [fresh valnums]. *) + +let set_fresh_regs n rs rhs = + match Array.length rs with + | 0 -> { n with num_eqs = Equations.add rhs [||] n.num_eqs } + | 1 -> let v = n.num_next in + { num_next = v + 1; + num_eqs = Equations.add rhs [|v|] n.num_eqs; + num_reg = Reg.Map.add rs.(0) v n.num_reg } + | _ -> assert false + +(* Forget everything we know about the given result registers, + which are receiving unpredictable values at run-time. *) + +let set_unknown_regs n rs = + { n with num_reg = Array.fold_right Reg.Map.remove rs n.num_reg } + +(* Keep only the equations satisfying the given predicate. *) + +let filter_equations pred n = + { n with num_eqs = Equations.filter (fun (op,_) res -> pred op) n.num_eqs } + +(* Prepend a reg-reg move *) + +let insert_move srcs dsts i = + match Array.length srcs with + | 0 -> i + | 1 -> instr_cons (Iop Imove) srcs dsts i + | _ -> assert false + +(* Classification of operations *) + +type op_class = + | Op_pure (* pure, produce one result *) + | Op_checkbound (* checkbound-style: no result, can raise an exn *) + | Op_load (* memory load *) + | Op_store of bool (* memory store, false = init, true = assign *) + | Op_other (* anything else that does not store in memory *) + +class cse_generic = object (self) + +(* Default classification of operations. Can be overriden in + processor-specific files to classify specific operations better. *) + +method class_of_operation op = + match op with + | Imove | Ispill | Ireload -> assert false (* treated specially *) + | Iconst_int _ | Iconst_float _ | Iconst_symbol _ + | Iconst_blockheader _ -> Op_pure + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ -> assert false (* treated specially *) + | Istackoffset _ -> Op_other + | Iload(_,_) -> Op_load + | Istore(_,_,asg) -> Op_store asg + | Ialloc _ -> Op_other + | Iintop(Icheckbound) -> Op_checkbound + | Iintop _ -> Op_pure + | Iintop_imm(Icheckbound, _) -> Op_checkbound + | Iintop_imm(_, _) -> Op_pure + | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Ifloatofint | Iintoffloat -> Op_pure + | Ispecific _ -> Op_other + +(* Operations that are so cheap that it isn't worth factoring them. *) + +method is_cheap_operation op = + match op with + | Iconst_int _ | Iconst_blockheader _ -> true + | _ -> false + +(* Forget all equations involving memory loads. Performed after a + non-initializing store *) + +method private kill_loads n = + filter_equations (fun o -> self#class_of_operation o <> Op_load) n + +(* Keep only equations involving checkbounds, and forget register values. + Performed across a call. *) + +method private keep_checkbounds n = + filter_equations (fun o -> self#class_of_operation o = Op_checkbound) + {n with num_reg = Reg.Map.empty } + +(* Perform CSE on the given instruction [i] and its successors. + [n] is the value numbering current at the beginning of [i]. *) + +method private cse n i = + match i.desc with + | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) + | Iexit _ | Iraise _ -> + i + | Iop (Imove | Ispill | Ireload) -> + (* For moves, we associate the same value number to the result reg + as to the argument reg. *) + let n1 = set_move n i.arg.(0) i.res.(0) in + {i with next = self#cse n1 i.next} + | Iop (Icall_ind | Icall_imm _ | Iextcall _) -> + (* We don't perform CSE across function calls, as it increases + register pressure too much. We do remember the checkbound + instructions already performed, though, since their reuse + cannot increase register pressure. *) + let n1 = self#keep_checkbounds n in + {i with next = self#cse n1 i.next} + | Iop op -> + begin match self#class_of_operation op with + | Op_pure | Op_checkbound | Op_load -> + assert (Array.length i.res <= 1); + let (n1, varg) = valnum_regs n i.arg in + begin match find_equation n1 (op, varg) with + | Some vres -> + (* This operation was computed earlier. *) + let n2 = set_known_regs n1 i.res vres in + begin match find_regs_containing n1 vres with + | Some res when not (self#is_cheap_operation op) -> + (* We can replace res <- op args with r <- move res. + If the operation is very cheap to compute, e.g. + an integer constant, don't bother. *) + insert_move res i.res (self#cse n2 i.next) + | _ -> + {i with next = self#cse n2 i.next} + end + | None -> + (* This operation produces a result we haven't seen earlier. *) + let n2 = set_fresh_regs n1 i.res (op, varg) in + {i with next = self#cse n2 i.next} + end + | Op_store false | Op_other -> + (* An initializing store or an "other" operation do not invalidate + any equations, but we do not know anything about the results. *) + let n1 = set_unknown_regs n i.res in + {i with next = self#cse n1 i.next} + | Op_store true -> + (* A non-initializing store: it can invalidate + anything we know about prior loads. *) + let n1 = set_unknown_regs (self#kill_loads n) i.res in + {i with next = self#cse n1 i.next} + end + (* For control structures, we set the numbering to empty at every + join point, but propagate the current numbering across fork points. *) + | Iifthenelse(test, ifso, ifnot) -> + {i with desc = Iifthenelse(test, self#cse n ifso, self#cse n ifnot); + next = self#cse empty_numbering i.next} + | Iswitch(index, cases) -> + {i with desc = Iswitch(index, Array.map (self#cse n) cases); + next = self#cse empty_numbering i.next} + | Iloop(body) -> + {i with desc = Iloop(self#cse empty_numbering body); + next = self#cse empty_numbering i.next} + | Icatch(nfail, body, handler) -> + {i with desc = Icatch(nfail, self#cse n body, self#cse empty_numbering handler); + next = self#cse empty_numbering i.next} + | Itrywith(body, handler) -> + {i with desc = Itrywith(self#cse n body, self#cse empty_numbering handler); + next = self#cse empty_numbering i.next} + +method fundecl f = + {f with fun_body = self#cse empty_numbering f.fun_body} + +end + + + diff --git a/asmcomp/CSEgen.mli b/asmcomp/CSEgen.mli new file mode 100644 index 0000000000..c19855eca5 --- /dev/null +++ b/asmcomp/CSEgen.mli @@ -0,0 +1,38 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Common subexpression elimination by value numbering over extended + basic blocks. *) + +type op_class = + | Op_pure (* pure, produce one result *) + | Op_checkbound (* checkbound-style: no result, can raise an exn *) + | Op_load (* memory load *) + | Op_store of bool (* memory store, false = init, true = assign *) + | Op_other (* anything else that does not store in memory *) + +class cse_generic : object + (* The following methods can be overriden to handle processor-specific + operations. *) + + method class_of_operation: Mach.operation -> op_class + + method is_cheap_operation: Mach.operation -> bool + (* Operations that are so cheap that it isn't worth factoring them. *) + + (* The following method is the entry point and should not be overridden *) + method fundecl: Mach.fundecl -> Mach.fundecl + +end + + + diff --git a/asmcomp/amd64/CSE.ml b/asmcomp/amd64/CSE.ml new file mode 100644 index 0000000000..63ef088531 --- /dev/null +++ b/asmcomp/amd64/CSE.ml @@ -0,0 +1,36 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the AMD64 *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Ilea _) -> Op_pure + | Ispecific(Istore_int(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Istore_symbol(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Ioffset_loc(_, _)) -> Op_store true + | Ispecific(Ifloatarithmem _) -> Op_load + | _ -> super#class_of_operation op + +end + +let fundecl f = + (new cse)#fundecl f + diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml index b0a5ffb8b7..3741dd74bc 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -33,8 +33,8 @@ type addressing_mode = type specific_operation = Ilea of addressing_mode (* "lea" gives scaled adds *) - | Istore_int of nativeint * addressing_mode (* Store an integer constant *) - | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Istore_int of nativeint * addressing_mode * bool (* Store an integer constant *) + | Istore_symbol of string * addressing_mode * bool (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ifloatarithmem of float_operation * addressing_mode (* Float arith operation with memory *) @@ -101,10 +101,14 @@ let print_addressing printreg addr ppf arg = let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg - | Istore_int(n, addr) -> - fprintf ppf "[%a] := %nd" (print_addressing printreg addr) arg n - | Istore_symbol(lbl, addr) -> - fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Istore_int(n, addr, is_assign) -> + fprintf ppf "[%a] := %nd %s" + (print_addressing printreg addr) arg n + (if is_assign then "(assign)" else "(init)") + | Istore_symbol(lbl, addr, is_assign) -> + fprintf ppf "[%a] := \"%s\" %s" + (print_addressing printreg addr) arg lbl + (if is_assign then "(assign)" else "(init)") | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Isqrtf -> diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index bdcc3a18d3..b576ece983 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -335,15 +335,16 @@ let output_epilogue f = (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl let emit_float_constant (cst, lbl) = @@ -382,12 +383,12 @@ let emit_instr fallthrough i = ` movq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` else ` movabsq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` movsd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` end | Lop(Iconst_symbol s) -> @@ -448,7 +449,7 @@ let emit_instr fallthrough i = | Double | Double_u -> ` movsd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word -> ` movq {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` @@ -541,9 +542,9 @@ let emit_instr fallthrough i = ` cvttsd2siq {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` | Lop(Ispecific(Ilea addr)) -> ` leaq {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` movq ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> assert (not !pic_code && not !Clflags.dlcode); ` movq ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> @@ -764,9 +765,9 @@ let emit_item = function | Cint n -> ` .quad {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_directive ".quad" f + emit_float64_directive ".quad" (Int64.bits_of_float f) | Csymbol_address s -> ` .quad {emit_symbol s}\n` | Clabel_address lbl -> diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index 77156b8f01..a66f0c93b8 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -53,9 +53,10 @@ let slot_offset loc cl = else !stack_offset + (num_stack_slots.(0) + n) * 8 | Outgoing n -> n -(* Output a 32 bit integer in hex *) +(* Output a 32 or 64 bit integer in hex *) let emit_int32 n = emit_printf "0%lxh" n +let emit_int64 n = emit_printf "0%Lxh" n (* Symbols *) @@ -321,36 +322,20 @@ let output_epilogue () = (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - let emit_float_constant (cst, lbl) = - `{emit_label lbl} REAL8 {emit_float cst}\n` + `{emit_label lbl}: QWORD {emit_int64 cst}\n` let emit_movabs reg n = (* force ml64 to use mov reg, imm64 instruction *) @@ -389,12 +374,12 @@ let emit_instr fallthrough i = ` mov {emit_reg32 i.res.(0)}, {emit_nativeint n}\n` else emit_movabs i.res.(0) n - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` movsd {emit_reg i.res.(0)}, {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -458,7 +443,7 @@ let emit_instr fallthrough i = | Double | Double_u -> ` movsd {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word -> ` mov QWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` @@ -547,9 +532,9 @@ let emit_instr fallthrough i = ` cvttsd2si {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` | Lop(Ispecific(Ilea addr)) -> ` lea {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` mov QWORD PTR {emit_addressing addr i.arg 0}, {emit_nativeint n}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> assert (not !pic_code); add_used_symbol s; ` mov QWORD PTR {emit_addressing addr i.arg 0}, OFFSET {emit_symbol s}\n` @@ -721,9 +706,9 @@ let emit_item = function | Cint n -> ` QWORD {emit_nativeint n}\n` | Csingle f -> - ` REAL4 {emit_float f}\n` + ` DWORD {emit_int32 (Int32.bits_of_float f)}\n` | Cdouble f -> - ` REAL8 {emit_float f}\n` + ` QWORD {emit_int64 (Int64.bits_of_float f)}\n` | Csymbol_address s -> add_used_symbol s; ` QWORD {emit_symbol s}\n` diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index b6e0fa94ab..cd06559e1e 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -259,7 +259,7 @@ let destroyed_at_oper = function | Iop(Iextcall(_, false)) -> destroyed_at_c_call | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _)) -> [| rax; rdx |] - | Iop(Istore(Single, _)) -> [| rxmm15 |] + | Iop(Istore(Single, _, _)) -> [| rxmm15 |] | Iop(Ialloc _ | Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _)) -> [| rax |] | Iswitch(_, _) -> [| rax; rdx |] @@ -290,10 +290,21 @@ let max_register_pressure = function if fp then [| 10; 16 |] else [| 11; 16 |] | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Icomp _), _) -> if fp then [| 11; 16 |] else [| 12; 16 |] - | Istore(Single, _) -> + | Istore(Single, _, _) -> if fp then [| 12; 15 |] else [| 13; 15 |] | _ -> if fp then [| 12; 16 |] else [| 13; 16 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Ilea _) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 5e6afbcabf..fa7fe66c05 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -152,20 +152,20 @@ method select_addressing chunk exp = | Ascaledadd(e1, e2, scale) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method! select_store addr exp = +method! select_store is_assign addr exp = match exp with Cconst_int n when self#is_immediate n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | (Cconst_natint n | Cconst_blockheader n) when self#is_immediate_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n when self#is_immediate n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | Cconst_natpointer n when self#is_immediate_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_symbol s when not (!pic_code || !Clflags.dlcode) -> - (Ispecific(Istore_symbol(s, addr)), Ctuple []) + (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple []) | _ -> - super#select_store addr exp + super#select_store is_assign addr exp method! select_operation op args = match op with diff --git a/asmcomp/arm/CSE.ml b/asmcomp/arm/CSE.ml new file mode 100644 index 0000000000..00282f1f55 --- /dev/null +++ b/asmcomp/arm/CSE.ml @@ -0,0 +1,38 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for ARM *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Ishiftcheckbound _) -> Op_checkbound + | Ispecific _ -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 255n && n >= 0n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f + diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 2f20ecf61a..61035b85fd 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -273,7 +273,7 @@ let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 (* Pending floating-point literals *) -let float_literals = ref ([] : (string * label) list) +let float_literals = ref ([] : (int64 * label) list) (* Pending relative references to the global offset table *) let gotrel_literals = ref ([] : (label * label) list) (* Pending symbol literals *) @@ -283,12 +283,13 @@ let num_literals = ref 0 (* Label a floating-point literal *) let float_literal f = + let repr = Int64.bits_of_float f in try - List.assoc f !float_literals + List.assoc repr !float_literals with Not_found -> let lbl = new_label() in num_literals := !num_literals + 2; - float_literals := (f, lbl) :: !float_literals; + float_literals := (repr, lbl) :: !float_literals; lbl (* Label a GOTREL literal *) @@ -314,7 +315,7 @@ let emit_literals() = ` .align 3\n`; List.iter (fun (f, lbl) -> - `{emit_label lbl}: .double {emit_string f}\n`) + `{emit_label lbl}:`; emit_float64_split_directive ".long" f) !float_literals; float_literals := [] end; @@ -390,8 +391,7 @@ let emit_instr i = | Lop(Iconst_int n | Iconst_blockheader n) -> emit_intconst i.res.(0) (Nativeint.to_int32 n) | Lop(Iconst_float f) when !fpu = Soft -> - ` @ {emit_string f}\n`; - let bits = Int64.bits_of_float (float_of_string f) in + let bits = Int64.bits_of_float f in let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32) and low_bits = Int64.to_int32 bits in if is_immediate low_bits || is_immediate high_bits then begin @@ -406,7 +406,7 @@ let emit_instr i = end | Lop(Iconst_float f) when !fpu = VFPv2 -> let lbl = float_literal f in - ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n`; + ` fldd {emit_reg i.res.(0)}, {emit_label lbl}\n`; 1 | Lop(Iconst_float f) -> let encode imm = @@ -425,12 +425,12 @@ let emit_instr i = let ex = ((ex + 3) land 0x07) lxor 0x04 in Some((sg lsl 7) lor (ex lsl 4) lor mn) end in - begin match encode (Int64.bits_of_float (float_of_string f)) with + begin match encode (Int64.bits_of_float f) with None -> let lbl = float_literal f in - ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n` + ` fldd {emit_reg i.res.(0)}, {emit_label lbl}\n` | Some imm8 -> - ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8} @ {emit_string f}\n` + ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8}\n` end; 1 | Lop(Iconst_symbol s) -> emit_load_symbol_addr i.res.(0) s @@ -508,10 +508,10 @@ let emit_instr i = | Double_u -> "fldd" | _ (* 32-bit quantities *) -> "ldr" in ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1 - | Lop(Istore(Single, addr)) when !fpu >= VFPv2 -> + | Lop(Istore(Single, addr, _)) when !fpu >= VFPv2 -> ` fcvtsd s14, {emit_reg i.arg.(0)}\n`; ` fsts s14, {emit_addressing addr i.arg 1}\n`; 2 - | Lop(Istore((Double | Double_u), addr)) when !fpu = Soft -> + | Lop(Istore((Double | Double_u), addr, _)) when !fpu = Soft -> (* Use STM or STRD if possible *) begin match i.arg.(0), i.arg.(1), addr with {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0 @@ -525,7 +525,7 @@ let emit_instr i = ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`; ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; 2 end - | Lop(Istore(size, addr)) -> + | Lop(Istore(size, addr, _)) -> let r = i.arg.(0) in let instr = match size with @@ -874,8 +874,8 @@ let emit_item = function | Cint16 n -> ` .short {emit_int n}\n` | Cint32 n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` | Cint n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` - | Csingle f -> ` .single {emit_string f}\n` - | Cdouble f -> ` .double {emit_string f}\n` + | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` | Clabel_address lbl -> ` .word {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index a16c35a226..a5bf3d5c8c 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -203,7 +203,7 @@ let destroyed_at_oper = function [| phys_reg 3; phys_reg 8 |] (* r3 and r12 destroyed *) | Iop(Iintop Imulh) when !arch < ARMv6 -> [| phys_reg 8 |] (* r12 destroyed *) - | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) -> [| phys_reg 107 |] (* d7 (s14-s15) destroyed *) | _ -> [||] @@ -222,9 +222,19 @@ let max_register_pressure = function | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |] | Iconst_symbol _ when !pic_code -> [| 7; 16; 32 |] | Iintoffloat | Ifloatofint - | Iload(Single, _) | Istore(Single, _) -> [| 9; 15; 31 |] + | Iload(Single, _) | Istore(Single, _, _) -> [| 9; 15; 31 |] | _ -> [| 9; 16; 32 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) + | Ispecific(Ishiftcheckbound _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0; 0 |] diff --git a/asmcomp/arm64/CSE.ml b/asmcomp/arm64/CSE.ml new file mode 100644 index 0000000000..359e57eb55 --- /dev/null +++ b/asmcomp/arm64/CSE.ml @@ -0,0 +1,38 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for ARM64 *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Ishiftcheckbound _) -> Op_checkbound + | Ispecific _ -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 65535n && n >= 0n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f + diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index 4a3e3cd7b4..2c2454fde6 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -286,7 +286,7 @@ let emit_literals() = ` .align 3\n`; List.iter (fun (f, lbl) -> - `{emit_label lbl}: .quad `; emit_printf "0x%Lx\n" f) + `{emit_label lbl}:`; emit_float64_directive ".quad" f) !float_literals; float_literals := [] end @@ -326,15 +326,15 @@ let emit_instr i = | Lop(Iconst_int n | Iconst_blockheader n) -> emit_intconst i.res.(0) n | Lop(Iconst_float f) -> - let b = Int64.bits_of_float(float_of_string f) in + let b = Int64.bits_of_float f in if b = 0L then - ` fmov {emit_reg i.res.(0)}, xzr /* {emit_string f} */\n` + ` fmov {emit_reg i.res.(0)}, xzr\n` else if is_immediate_float b then - ` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" b} /* {emit_string f} */\n` + ` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" b}\n` else begin let lbl = float_literal b in ` adrp {emit_reg reg_tmp1}, {emit_label lbl}\n`; - ` ldr {emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}] /* {emit_string f} */\n` + ` ldr {emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n` end | Lop(Iconst_symbol s) -> emit_load_symbol_addr i.res.(0) s @@ -388,7 +388,7 @@ let emit_instr i = | Word | Double | Double_u -> ` ldr {emit_reg dst}, {emit_addressing addr base}\n` end - | Lop(Istore(size, addr)) -> + | Lop(Istore(size, addr, _)) -> let src = i.arg.(0) in let base = match addr with @@ -675,8 +675,8 @@ let emit_item = function | Cint16 n -> ` .short {emit_int n}\n` | Cint32 n -> ` .long {emit_nativeint n}\n` | Cint n -> ` .quad {emit_nativeint n}\n` - | Csingle f -> emit_float32_directive ".long" f - | Cdouble f -> emit_float64_directive ".quad" f + | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> emit_float64_directive ".quad" (Int64.bits_of_float f) | Csymbol_address s -> ` .quad {emit_symbol s}\n` | Clabel_address lbl -> ` .quad {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml index b52c2fd8ae..d2cda5c235 100644 --- a/asmcomp/arm64/proc.ml +++ b/asmcomp/arm64/proc.ml @@ -177,7 +177,7 @@ let destroyed_at_oper = function destroyed_at_c_call | Iop(Ialloc _) -> [| reg_x15 |] - | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) -> [| reg_d7 |] (* d7 / s7 destroyed *) | _ -> [||] @@ -194,9 +194,19 @@ let max_register_pressure = function | Iextcall(_, _) -> [| 10; 8 |] | Ialloc _ -> [| 25; 32 |] | Iintoffloat | Ifloatofint - | Iload(Single, _) | Istore(Single, _) -> [| 26; 31 |] + | Iload(Single, _) | Istore(Single, _, _) -> [| 26; 31 |] | _ -> [| 26; 32 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) + | Ispecific(Ishiftcheckbound _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 34283875cb..311bb029b2 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -64,7 +64,10 @@ let compile_fundecl (ppf : formatter) fd_cmm = ++ pass_dump_if ppf dump_selection "After instruction selection" ++ Comballoc.fundecl ++ pass_dump_if ppf dump_combine "After allocation combining" + ++ CSE.fundecl + ++ pass_dump_if ppf dump_cse "After CSE" ++ liveness ppf + ++ Deadcode.fundecl ++ pass_dump_if ppf dump_live "Liveness analysis" ++ Spill.fundecl ++ liveness ppf diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index 3586296e4f..4088265337 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -19,12 +19,12 @@ open Lambda type function_label = string type ustructured_constant = - | Uconst_float of string + | Uconst_float of float | Uconst_int32 of int32 | Uconst_int64 of int64 | Uconst_nativeint of nativeint | Uconst_block of int * uconstant list - | Uconst_float_array of string list + | Uconst_float_array of float list | Uconst_string of string and uconstant = @@ -74,7 +74,9 @@ type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } (* Approximation of values *) diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index e751326fe4..abb0e9c626 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -19,12 +19,12 @@ open Lambda type function_label = string type ustructured_constant = - | Uconst_float of string + | Uconst_float of float | Uconst_int32 of int32 | Uconst_int64 of int64 | Uconst_nativeint of nativeint | Uconst_block of int * uconstant list - | Uconst_float_array of string list + | Uconst_float_array of float list | Uconst_string of string and uconstant = @@ -74,7 +74,9 @@ type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } (* Approximation of values *) diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index eff35ce4f2..2f37e0fcc7 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -245,14 +245,15 @@ let rec is_pure_clambda = function | Uprim(p, args, _) -> List.for_all is_pure_clambda args | _ -> false -(* Simplify primitive operations on integers *) +(* Simplify primitive operations on known arguments *) let make_const c = (Uconst c, Value_const c) - +let make_const_ref c = + make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, c)) let make_const_int n = make_const (Uconst_int n) let make_const_ptr n = make_const (Uconst_ptr n) let make_const_bool b = make_const_ptr(if b then 1 else 0) -let make_comparison cmp (x: int) (y: int) = +let make_comparison cmp x y = make_const_bool (match cmp with Ceq -> x = y @@ -261,71 +262,187 @@ let make_comparison cmp (x: int) (y: int) = | Cgt -> x > y | Cle -> x <= y | Cge -> x >= y) +let make_const_float n = make_const_ref (Uconst_float n) +let make_const_natint n = make_const_ref (Uconst_nativeint n) +let make_const_int32 n = make_const_ref (Uconst_int32 n) +let make_const_int64 n = make_const_ref (Uconst_int64 n) + +(* The [fpc] parameter is true if constant propagation of + floating-point computations is allowed *) -let simplif_int_prim_pure p (args, approxs) dbg = +let simplif_arith_prim_pure fpc p (args, approxs) dbg = + let default = (Uprim(p, args, dbg), Value_unknown) in match approxs with - [Value_const (Uconst_int x)] -> + (* int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] -> begin match p with - Pidentity -> make_const_int x - | Pnegint -> make_const_int (-x) - | Pbswap16 -> - make_const_int (((x land 0xff) lsl 8) lor - ((x land 0xff00) lsr 8)) - | Poffsetint y -> make_const_int (x + y) - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pnot -> make_const_bool (n1 = 0) + | Pnegint -> make_const_int (- n1) + | Poffsetint n -> make_const_int (n + n1) + | Pfloatofint when fpc -> make_const_float (float_of_int n1) + | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1) + | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1) + | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1) + | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8) + lor ((n1 land 0xff00) lsr 8)) + | _ -> default end - | [Value_const (Uconst_int x); Value_const (Uconst_int y)] -> + (* int (or enumerated type), int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1); + Value_const(Uconst_int n2 | Uconst_ptr n2) ] -> begin match p with - Paddint -> make_const_int(x + y) - | Psubint -> make_const_int(x - y) - | Pmulint -> make_const_int(x * y) - | Pdivint when y <> 0 -> make_const_int(x / y) - | Pmodint when y <> 0 -> make_const_int(x mod y) - | Pandint -> make_const_int(x land y) - | Porint -> make_const_int(x lor y) - | Pxorint -> make_const_int(x lxor y) - | Plslint -> make_const_int(x lsl y) - | Plsrint -> make_const_int(x lsr y) - | Pasrint -> make_const_int(x asr y) - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0) + | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0) + | Paddint -> make_const_int (n1 + n2) + | Psubint -> make_const_int (n1 - n2) + | Pmulint -> make_const_int (n1 * n2) + | Pdivint when n2 <> 0 -> make_const_int (n1 / n2) + | Pmodint when n2 <> 0 -> make_const_int (n1 mod n2) + | Pandint -> make_const_int (n1 land n2) + | Porint -> make_const_int (n1 lor n2) + | Pxorint -> make_const_int (n1 lxor n2) + | Plslint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 lsl n2) + | Plsrint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 lsr n2) + | Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 asr n2) + | Pintcomp c -> make_comparison c n1 n2 + | _ -> default end - | [Value_const (Uconst_ptr x)] -> + (* float *) + | [Value_const(Uconst_ref(_, Uconst_float n1))] when fpc -> begin match p with - Pidentity -> make_const_ptr x - | Pnot -> make_const_bool(x = 0) - | Pisint -> make_const_bool true - | Pctconst c -> - begin - match c with - | Big_endian -> make_const_bool Arch.big_endian - | Word_size -> make_const_int (8*Arch.size_int) - | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") - | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") - | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") - end - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pintoffloat -> make_const_int (int_of_float n1) + | Pnegfloat -> make_const_float (-. n1) + | Pabsfloat -> make_const_float (abs_float n1) + | _ -> default end - | [Value_const (Uconst_ptr x); Value_const (Uconst_ptr y)] -> + (* float, float *) + | [Value_const(Uconst_ref(_, Uconst_float n1)); + Value_const(Uconst_ref(_, Uconst_float n2))] when fpc -> begin match p with - Psequand -> make_const_bool(x <> 0 && y <> 0) - | Psequor -> make_const_bool(x <> 0 || y <> 0) - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Paddfloat -> make_const_float (n1 +. n2) + | Psubfloat -> make_const_float (n1 -. n2) + | Pmulfloat -> make_const_float (n1 *. n2) + | Pdivfloat -> make_const_float (n1 /. n2) + | Pfloatcomp c -> make_comparison c n1 n2 + | _ -> default end - | [Value_const (Uconst_ptr x); Value_const (Uconst_int y)] -> + (* nativeint *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n))] -> begin match p with - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n) + | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n) + | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n) + | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n) + | _ -> default end - | [Value_const (Uconst_int x); Value_const (Uconst_ptr y)] -> + (* nativeint, nativeint *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n1)); + Value_const(Uconst_ref(_, Uconst_nativeint n2))] -> begin match p with - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2) + | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2) + | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2) + | Pdivbint Pnativeint when n2 <> 0n -> + make_const_natint (Nativeint.div n1 n2) + | Pmodbint Pnativeint when n2 <> 0n -> + make_const_natint (Nativeint.rem n1 n2) + | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2) + | Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2) + | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2) + | Pbintcomp(Pnativeint, c) -> make_comparison c n1 n2 + | _ -> default + end + (* nativeint, int *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n1)); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_left n1 n2) + | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_right_logical n1 n2) + | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_right n1 n2) + | _ -> default + end + (* int32 *) + | [Value_const(Uconst_ref(_, Uconst_int32 n))] -> + begin match p with + | Pintofbint Pint32 -> make_const_int (Int32.to_int n) + | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n) + | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n) + | Pnegbint Pint32 -> make_const_int32 (Int32.neg n) + | _ -> default + end + (* int32, int32 *) + | [Value_const(Uconst_ref(_, Uconst_int32 n1)); + Value_const(Uconst_ref(_, Uconst_int32 n2))] -> + begin match p with + | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2) + | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2) + | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2) + | Pdivbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.div n1 n2) + | Pmodbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.rem n1 n2) + | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2) + | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2) + | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2) + | Pbintcomp(Pint32, c) -> make_comparison c n1 n2 + | _ -> default + end + (* int32, int *) + | [Value_const(Uconst_ref(_, Uconst_int32 n1)); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_left n1 n2) + | Plsrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right_logical n1 n2) + | Pasrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right n1 n2) + | _ -> default + end + (* int64 *) + | [Value_const(Uconst_ref(_, Uconst_int64 n))] -> + begin match p with + | Pintofbint Pint64 -> make_const_int (Int64.to_int n) + | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n) + | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n) + | Pnegbint Pint64 -> make_const_int64 (Int64.neg n) + | _ -> default + end + (* int64, int64 *) + | [Value_const(Uconst_ref(_, Uconst_int64 n1)); + Value_const(Uconst_ref(_, Uconst_int64 n2))] -> + begin match p with + | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2) + | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2) + | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2) + | Pdivbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.div n1 n2) + | Pmodbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.rem n1 n2) + | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2) + | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2) + | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2) + | Pbintcomp(Pint64, c) -> make_comparison c n1 n2 + | _ -> default + end + (* int64, int *) + | [Value_const(Uconst_ref(_, Uconst_int64 n1)); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_left n1 n2) + | Plsrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right_logical n1 n2) + | Pasrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right n1 n2) + | _ -> default end + (* TODO: Pbbswap *) + (* Catch-all *) | _ -> - (Uprim(p, args, dbg), Value_unknown) - + default let field_approx n = function | Value_tuple a when n < Array.length a -> a.(n) @@ -333,8 +450,9 @@ let field_approx n = function Value_const (List.nth l n) | _ -> Value_unknown -let simplif_prim_pure p (args, approxs) dbg = +let simplif_prim_pure fpc p (args, approxs) dbg = match p, args, approxs with + (* Block construction *) | Pmakeblock(tag, Immutable), _, _ -> let field = function | Value_const c -> c @@ -349,24 +467,43 @@ let simplif_prim_pure p (args, approxs) dbg = with Exit -> (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs)) end + (* Field access *) | Pfield n, _, [ Value_const(Uconst_ref(_, Uconst_block(_, l))) ] when n < List.length l -> make_const (List.nth l n) - - | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx] -> - assert(n < List.length ul); - List.nth ul n, field_approx n approx - - | Pstringlength, _, [ Value_const(Uconst_ref(_, Uconst_string s)) ] - -> + | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx] + when n < List.length ul -> + (List.nth ul n, field_approx n approx) + (* Strings *) + | Pstringlength, _, [ Value_const(Uconst_ref(_, Uconst_string s)) ] -> make_const_int (String.length s) - + (* Identity *) + | Pidentity, [arg1], [app1] -> + (arg1, app1) + (* Kind test *) + | Pisint, _, [a1] -> + begin match a1 with + | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true + | Value_const(Uconst_ref _) -> make_const_bool false + | Value_closure _ | Value_tuple _ -> make_const_bool false + | _ -> (Uprim(p, args, dbg), Value_unknown) + end + (* Compile-time constants *) + | Pctconst c, _, _ -> + begin match c with + | Big_endian -> make_const_bool Arch.big_endian + | Word_size -> make_const_int (8*Arch.size_int) + | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") + | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") + | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") + end + (* Catch-all *) | _ -> - simplif_int_prim_pure p (args, approxs) dbg + simplif_arith_prim_pure fpc p (args, approxs) dbg -let simplif_prim p (args, approxs as args_approxs) dbg = +let simplif_prim fpc p (args, approxs as args_approxs) dbg = if List.for_all is_pure_clambda args - then simplif_prim_pure p args_approxs dbg + then simplif_prim_pure fpc p args_approxs dbg else (* XXX : always return the same approxs as simplif_prim_pure? *) let approx = @@ -391,15 +528,16 @@ let approx_ulam = function Uconst c -> Value_const c | _ -> Value_unknown -let rec substitute sb ulam = +let rec substitute fpc sb ulam = match ulam with Uvar v -> begin try Tbl.find v sb with Not_found -> ulam end | Uconst _ -> ulam | Udirect_apply(lbl, args, dbg) -> - Udirect_apply(lbl, List.map (substitute sb) args, dbg) + Udirect_apply(lbl, List.map (substitute fpc sb) args, dbg) | Ugeneric_apply(fn, args, dbg) -> - Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg) + Ugeneric_apply(substitute fpc sb fn, + List.map (substitute fpc sb) args, dbg) | Uclosure(defs, env) -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. @@ -409,11 +547,12 @@ let rec substitute sb ulam = - When we substitute offsets for idents bound by let rec in [close], case [Lletrec], we discard the original let rec body and use only the substituted term. *) - Uclosure(defs, List.map (substitute sb) env) - | Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs) + Uclosure(defs, List.map (substitute fpc sb) env) + | Uoffset(u, ofs) -> Uoffset(substitute fpc sb u, ofs) | Ulet(id, u1, u2) -> let id' = Ident.rename id in - Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2) + Ulet(id', substitute fpc sb u1, + substitute fpc (Tbl.add id (Uvar id') sb) u2) | Uletrec(bindings, body) -> let bindings1 = List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in @@ -422,57 +561,64 @@ let rec substitute sb ulam = (fun (id, id', _) s -> Tbl.add id (Uvar id') s) bindings1 sb in Uletrec( - List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1, - substitute sb' body) + List.map + (fun (id, id', rhs) -> (id', substitute fpc sb' rhs)) + bindings1, + substitute fpc sb' body) | Uprim(p, args, dbg) -> - let sargs = List.map (substitute sb) args in - let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in + let sargs = + List.map (substitute fpc sb) args in + let (res, _) = + simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in res | Uswitch(arg, sw) -> - Uswitch(substitute sb arg, + Uswitch(substitute fpc sb arg, { sw with us_actions_consts = - Array.map (substitute sb) sw.us_actions_consts; + Array.map (substitute fpc sb) sw.us_actions_consts; us_actions_blocks = - Array.map (substitute sb) sw.us_actions_blocks; + Array.map (substitute fpc sb) sw.us_actions_blocks; }) | Ustringswitch(arg,sw,d) -> Ustringswitch - (substitute sb arg, - List.map (fun (s,act) -> s,substitute sb act) sw, - Misc.may_map (substitute sb) d) + (substitute fpc sb arg, + List.map (fun (s,act) -> s,substitute fpc sb act) sw, + Misc.may_map (substitute fpc sb) d) | Ustaticfail (nfail, args) -> - Ustaticfail (nfail, List.map (substitute sb) args) + Ustaticfail (nfail, List.map (substitute fpc sb) args) | Ucatch(nfail, ids, u1, u2) -> - Ucatch(nfail, ids, substitute sb u1, substitute sb u2) + Ucatch(nfail, ids, substitute fpc sb u1, substitute fpc sb u2) | Utrywith(u1, id, u2) -> let id' = Ident.rename id in - Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2) + Utrywith(substitute fpc sb u1, id', + substitute fpc (Tbl.add id (Uvar id') sb) u2) | Uifthenelse(u1, u2, u3) -> - begin match substitute sb u1 with + begin match substitute fpc sb u1 with Uconst (Uconst_ptr n) -> - if n <> 0 then substitute sb u2 else substitute sb u3 + if n <> 0 then substitute fpc sb u2 else substitute fpc sb u3 | Uprim(Pmakeblock _, _, _) -> - substitute sb u2 + substitute fpc sb u2 | su1 -> - Uifthenelse(su1, substitute sb u2, substitute sb u3) + Uifthenelse(su1, substitute fpc sb u2, substitute fpc sb u3) end - | Usequence(u1, u2) -> Usequence(substitute sb u1, substitute sb u2) - | Uwhile(u1, u2) -> Uwhile(substitute sb u1, substitute sb u2) + | Usequence(u1, u2) -> + Usequence(substitute fpc sb u1, substitute fpc sb u2) + | Uwhile(u1, u2) -> + Uwhile(substitute fpc sb u1, substitute fpc sb u2) | Ufor(id, u1, u2, dir, u3) -> let id' = Ident.rename id in - Ufor(id', substitute sb u1, substitute sb u2, dir, - substitute (Tbl.add id (Uvar id') sb) u3) + Ufor(id', substitute fpc sb u1, substitute fpc sb u2, dir, + substitute fpc (Tbl.add id (Uvar id') sb) u3) | Uassign(id, u) -> let id' = try match Tbl.find id sb with Uvar i -> i | _ -> assert false with Not_found -> id in - Uassign(id', substitute sb u) + Uassign(id', substitute fpc sb u) | Usend(k, u1, u2, ul, dbg) -> - Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, - dbg) + Usend(k, substitute fpc sb u1, substitute fpc sb u2, + List.map (substitute fpc sb) ul, dbg) (* Perform an inline expansion *) @@ -484,12 +630,12 @@ let no_effects = function | Uclosure _ -> true | u -> is_simple_argument u -let rec bind_params_rec subst params args body = +let rec bind_params_rec fpc subst params args body = match (params, args) with - ([], []) -> substitute subst body + ([], []) -> substitute fpc subst body | (p1 :: pl, a1 :: al) -> if is_simple_argument a1 then - bind_params_rec (Tbl.add p1 a1 subst) pl al body + bind_params_rec fpc (Tbl.add p1 a1 subst) pl al body else begin let p1' = Ident.rename p1 in let u1, u2 = @@ -500,17 +646,17 @@ let rec bind_params_rec subst params args body = a1, Uvar p1' in let body' = - bind_params_rec (Tbl.add p1 u2 subst) pl al body in + bind_params_rec fpc (Tbl.add p1 u2 subst) pl al body in if occurs_var p1 body then Ulet(p1', u1, body') else if no_effects a1 then body' else Usequence(a1, body') end | (_, _) -> assert false -let bind_params params args body = +let bind_params fpc params args body = (* Reverse parameters and arguments to preserve right-to-left evaluation order (PR#2910). *) - bind_params_rec Tbl.empty (List.rev params) (List.rev args) body + bind_params_rec fpc Tbl.empty (List.rev params) (List.rev args) body (* Check if a lambda term is ``pure'', that is without side-effects *and* not containing function definitions *) @@ -532,8 +678,10 @@ let direct_apply fundesc funct ufunct uargs = if fundesc.fun_closed then uargs else uargs @ [ufunct] in let app = match fundesc.fun_inline with - None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) - | Some(params, body) -> bind_params params app_args body in + | None -> + Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) + | Some(params, body) -> + bind_params fundesc.fun_float_const_prop params app_args body in (* If ufunct can contain side-effects or function definitions, we must make sure that it is evaluated exactly once. If the function is not closed, we evaluate ufunct as part of the @@ -648,14 +796,14 @@ let rec close fenv cenv = function str (Uconst_block (tag, List.map transl fields)) | Const_float_array sl -> (* constant float arrays are really immutable *) - str (Uconst_float_array sl) + str (Uconst_float_array (List.map float_of_string sl)) | Const_immstring s -> str (Uconst_string s) | Const_base (Const_string (s, _)) -> (* strings (even literal ones) are mutable! *) (* of course, the empty string is really immutable *) str ~shared:false(*(String.length s = 0)*) (Uconst_string s) - | Const_base(Const_float x) -> str (Uconst_float x) + | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) | Const_base(Const_int32 x) -> str (Uconst_int32 x) | Const_base(Const_int64 x) -> str (Uconst_int64 x) | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) @@ -749,7 +897,7 @@ let rec close fenv cenv = function (fun (id, pos, approx) sb -> Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb) infos Tbl.empty in - (Ulet(clos_ident, clos, substitute sb ubody), + (Ulet(clos_ident, clos, substitute !Clflags.float_const_prop sb ubody), approx) end else begin (* General case: recursive definition of values *) @@ -785,7 +933,8 @@ let rec close fenv cenv = function (Uprim(Praise k, [ulam], Debuginfo.from_raise ev), Value_unknown) | Lprim(p, args) -> - simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none + simplif_prim !Clflags.float_const_prop + p (close_list_approx fenv cenv args) Debuginfo.none | Lswitch(arg, sw) -> let fn fail = let (uarg, _) = close fenv cenv arg in @@ -925,7 +1074,8 @@ and close_functions fenv cenv fun_defs = {fun_label = label; fun_arity = (if kind = Tupled then -arity else arity); fun_closed = initially_closed; - fun_inline = None } in + fun_inline = None; + fun_float_const_prop = !Clflags.float_const_prop } in (id, params, body, fundesc) | (_, _) -> fatal_error "Closure.close_functions") fun_defs in diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 9a5f3ec6b8..67ee3445fd 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -85,7 +85,7 @@ type operation = type expression = Cconst_int of int | Cconst_natint of nativeint - | Cconst_float of string + | Cconst_float of float | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint @@ -118,8 +118,8 @@ type data_item = | Cint16 of int | Cint32 of nativeint | Cint of nativeint - | Csingle of string - | Cdouble of string + | Csingle of float + | Cdouble of float | Csymbol_address of string | Clabel_address of int | Cstring of string diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index be2bd41457..97b8d40971 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -71,7 +71,7 @@ type operation = type expression = Cconst_int of int | Cconst_natint of nativeint - | Cconst_float of string + | Cconst_float of float | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint @@ -104,8 +104,8 @@ type data_item = | Cint16 of int | Cint32 of nativeint | Cint of nativeint - | Csingle of string - | Cdouble of string + | Csingle of float + | Cdouble of float | Csymbol_address of string | Clabel_address of int | Cstring of string diff --git a/asmcomp/deadcode.ml b/asmcomp/deadcode.ml new file mode 100644 index 0000000000..d3d0fcb906 --- /dev/null +++ b/asmcomp/deadcode.ml @@ -0,0 +1,64 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Dead code elimination: remove pure instructions whose results are + not used. *) + +open Mach + +(* [deadcode i] returns a pair of an optimized instruction [i'] + and a set of registers live "before" instruction [i]. *) + +let rec deadcode i = + match i.desc with + | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) | Iraise _ -> + (i, Reg.add_set_array i.live i.arg) + | Iop op -> + let (s, before) = deadcode i.next in + if Proc.op_is_pure op + && Reg.disjoint_set_array before i.res then begin + assert (Array.length i.res > 0); (* sanity check *) + (s, before) + end else begin + ({i with next = s}, Reg.add_set_array i.live i.arg) + end + | Iifthenelse(test, ifso, ifnot) -> + let (ifso', _) = deadcode ifso in + let (ifnot', _) = deadcode ifnot in + let (s, _) = deadcode i.next in + ({i with desc = Iifthenelse(test, ifso', ifnot'); next = s}, + Reg.add_set_array i.live i.arg) + | Iswitch(index, cases) -> + let cases' = Array.map (fun c -> fst (deadcode c)) cases in + let (s, _) = deadcode i.next in + ({i with desc = Iswitch(index, cases'); next = s}, + Reg.add_set_array i.live i.arg) + | Iloop(body) -> + let (body', _) = deadcode body in + let (s, _) = deadcode i.next in + ({i with desc = Iloop body'; next = s}, i.live) + | Icatch(nfail, body, handler) -> + let (body', _) = deadcode body in + let (handler', _) = deadcode handler in + let (s, _) = deadcode i.next in + ({i with desc = Icatch(nfail, body', handler'); next = s}, i.live) + | Iexit nfail -> + (i, i.live) + | Itrywith(body, handler) -> + let (body', _) = deadcode body in + let (handler', _) = deadcode handler in + let (s, _) = deadcode i.next in + ({i with desc = Itrywith(body', handler'); next = s}, i.live) + +let fundecl f = + let (new_body, _) = deadcode f.fun_body in + {f with fun_body = new_body} diff --git a/asmcomp/deadcode.mli b/asmcomp/deadcode.mli new file mode 100644 index 0000000000..6aafae0540 --- /dev/null +++ b/asmcomp/deadcode.mli @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Dead code elimination: remove pure instructions whose results are + not used. *) + +val fundecl: Mach.fundecl -> Mach.fundecl diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index ccfa977ffa..11212140a2 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -88,16 +88,10 @@ let emit_bytes_directive directive s = done; if !pos > 0 then emit_char '\n' -(* PR#4813: assemblers do strange things with float literals indeed, - so we convert to IEEE representation ourselves and emit float - literals as 32- or 64-bit integers. *) - -let emit_float64_directive directive f = - let x = Int64.bits_of_float (float_of_string f) in +let emit_float64_directive directive x = emit_printf "\t%s\t0x%Lx\n" directive x -let emit_float64_split_directive directive f = - let x = Int64.bits_of_float (float_of_string f) in +let emit_float64_split_directive directive x = let lo = Int64.logand x 0xFFFF_FFFFL and hi = Int64.shift_right_logical x 32 in emit_printf "\t%s\t0x%Lx, 0x%Lx\n" @@ -105,8 +99,7 @@ let emit_float64_split_directive directive f = (if Arch.big_endian then hi else lo) (if Arch.big_endian then lo else hi) -let emit_float32_directive directive f = - let x = Int32.bits_of_float (float_of_string f) in +let emit_float32_directive directive x = emit_printf "\t%s\t0x%lx\n" directive x (* Record live pointers at call points *) diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index cc479d8ccf..9b19e294c7 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -23,9 +23,9 @@ val emit_char: char -> unit val emit_string_literal: string -> unit val emit_string_directive: string -> string -> unit val emit_bytes_directive: string -> string -> unit -val emit_float64_directive: string -> string -> unit -val emit_float64_split_directive: string -> string -> unit -val emit_float32_directive: string -> string -> unit +val emit_float64_directive: string -> int64 -> unit +val emit_float64_split_directive: string -> int64 -> unit +val emit_float32_directive: string -> int32 -> unit val reset_debug_info: unit -> unit val emit_debug_info: Debuginfo.t -> unit diff --git a/asmcomp/i386/CSE.ml b/asmcomp/i386/CSE.ml new file mode 100644 index 0000000000..3ce4567024 --- /dev/null +++ b/asmcomp/i386/CSE.ml @@ -0,0 +1,48 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the i386 *) + +open Cmm +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + (* Operations that affect the floating-point stack cannot be factored *) + | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Iintoffloat | Ifloatofint + | Iload((Single | Double | Double_u), _) -> Op_other + (* Specific ops *) + | Ispecific(Ilea _) -> Op_pure + | Ispecific(Istore_int(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Istore_symbol(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Ioffset_loc(_, _)) -> Op_store true + | Ispecific _ -> Op_other + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int _ | Iconst_blockheader _ -> true + | Iconst_symbol _ -> true + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f + diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index d2f9fd61a8..0d2130445e 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -31,8 +31,8 @@ type addressing_mode = type specific_operation = Ilea of addressing_mode (* Lea gives scaled adds *) - | Istore_int of nativeint * addressing_mode (* Store an integer constant *) - | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Istore_int of nativeint * addressing_mode * bool (* Store an integer constant *) + | Istore_symbol of string * addressing_mode * bool (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ipush (* Push regs on stack *) | Ipush_int of nativeint (* Push an integer constant *) @@ -105,11 +105,14 @@ let print_addressing printreg addr ppf arg = let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg - | Istore_int(n, addr) -> - fprintf ppf "[%a] := %s" (print_addressing printreg addr) arg - (Nativeint.to_string n) - | Istore_symbol(lbl, addr) -> - fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Istore_int(n, addr, is_assign) -> + fprintf ppf "[%a] := %nd %s" + (print_addressing printreg addr) arg n + (if is_assign then "(assign)" else "(init)") + | Istore_symbol(lbl, addr, is_assign) -> + fprintf ppf "[%a] := \"%s\" %s" + (print_addressing printreg addr) arg lbl + (if is_assign then "(assign)" else "(init)") | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Ipush -> diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 2b90d37f64..98df5f958b 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -412,15 +412,16 @@ let emit_floatspecial = function (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl let emit_float_constant (cst, lbl) = @@ -465,8 +466,8 @@ let emit_instr fallthrough i = | _ -> ` movl $0, {emit_reg i.res.(0)}\n` end else ` movl ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` | 0x8000_0000_0000_0000L -> (* -0.0 *) @@ -476,7 +477,7 @@ let emit_instr fallthrough i = | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` fldl {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -543,7 +544,7 @@ let emit_instr fallthrough i = | Double | Double_u -> ` fldl {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` movl {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` @@ -683,9 +684,9 @@ let emit_instr fallthrough i = stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` movl ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> ` movl ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> ` addl ${emit_int n}, {emit_addressing addr i.arg 0}\n` @@ -960,9 +961,9 @@ let emit_item = function | Cint n -> ` .long {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_split_directive ".long" f + emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` .long {emit_symbol s}\n` | Clabel_address lbl -> diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index 495a29aecc..a9c9db3e4f 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -62,7 +62,10 @@ let add_used_symbol s = let emit_symbol s = emit_string "_"; Emitaux.emit_symbol '$' s +(* Output a 32 or 64 bit integer in hex *) + let emit_int32 n = emit_printf "0%lxh" n +let emit_int64 n = emit_printf "0%Lxh" n (* Output a label *) @@ -361,36 +364,20 @@ let emit_floatspecial = function (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - let emit_float_constant (cst, lbl) = - `{emit_label lbl} REAL8 {emit_float cst}\n` + `{emit_label lbl}: QWORD {emit_int64 cst}\n` (* Output the assembly code for an instruction *) @@ -426,8 +413,8 @@ let emit_instr i = | _ -> ` mov {emit_reg i.res.(0)}, 0\n` end else ` mov {emit_reg i.res.(0)}, {emit_nativeint n}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` | 0x8000_0000_0000_0000L -> (* -0.0 *) @@ -437,7 +424,7 @@ let emit_instr i = | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` fld {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -493,7 +480,7 @@ let emit_instr i = | Double | Double_u -> ` fld REAL8 PTR {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` mov DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` @@ -631,9 +618,9 @@ let emit_instr i = stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_reg i.res.(0)}, DWORD PTR {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` mov DWORD PTR {emit_addressing addr i.arg 0},{emit_nativeint n}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> add_used_symbol s ; ` mov DWORD PTR {emit_addressing addr i.arg 0},OFFSET {emit_symbol s}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> @@ -816,9 +803,9 @@ let emit_item = function | Cint32 n -> ` DWORD {emit_nativeint n}\n` | Csingle f -> - ` REAL4 {emit_float f}\n` + ` DWORD {emit_int32 (Int32.bits_of_float f)}\n` | Cdouble f -> - ` REAL8 {emit_float f}\n` + ` QWORD {emit_int64 (Int64.bits_of_float f)}\n` | Csymbol_address s -> add_used_symbol s ; ` DWORD {emit_symbol s}\n` diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index d80d182088..38bfdb29f9 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -182,6 +182,20 @@ let max_register_pressure = function Iintoffloat -> [| 6; max_int |] | _ -> [|7; max_int |] +(* Pure operations (without any side effect besides updating their result + registers). Note that floating-point operations are not pure + because they update the float stack. *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Iintoffloat | Ifloatofint | Iload((Single | Double | Double_u), _) -> false + | Ispecific(Ilea _) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index d86f1b2823..10d2d40e37 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -135,7 +135,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), addr, _) -> let newarg = Array.copy arg in newarg.(0) <- edx; (newarg, res, false) @@ -178,20 +178,20 @@ method select_addressing chunk exp = | (Ascaledadd(e1, e2, scale), d) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method! select_store addr exp = +method! select_store is_assign addr exp = match exp with Cconst_int n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | (Cconst_natint n | Cconst_blockheader n) -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | Cconst_natpointer n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_symbol s -> - (Ispecific(Istore_symbol(s, addr)), Ctuple []) + (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple []) | _ -> - super#select_store addr exp + super#select_store is_assign addr exp method! select_operation op args = match op with diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index 434d506558..7e3f1fe080 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -16,13 +16,13 @@ open Mach let live_at_exit = ref [] + let find_live_at_exit k = try List.assoc k !live_at_exit with - | Not_found -> Misc.fatal_error "Spill.find_live_at_exit" + | Not_found -> Misc.fatal_error "Liveness.find_live_at_exit" -let live_at_break = ref Reg.Set.empty let live_at_raise = ref Reg.Set.empty let rec live i finally = @@ -37,8 +37,30 @@ let rec live i finally = i.live <- finally; finally | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> - (* i.live remains empty since no regs are live across *) + i.live <- Reg.Set.empty; (* no regs are live across *) Reg.set_of_array i.arg + | Iop op -> + let after = live i.next finally in + if Proc.op_is_pure op && Reg.disjoint_set_array after i.res then begin + (* This operation is dead code. Ignore its arguments. *) + i.live <- after; + after + end else begin + let across_after = Reg.diff_set_array after i.res in + let across = + match op with + | Icall_ind | Icall_imm _ | Iextcall _ + | Iintop Icheckbound | Iintop_imm(Icheckbound, _) -> + (* The function call may raise an exception, branching to the + nearest enclosing try ... with. Similarly for bounds checks. + Hence, everything that must be live at the beginning of + the exception handler must also be live across this instr. *) + Reg.Set.union across_after !live_at_raise + | _ -> + across_after in + i.live <- across; + Reg.add_set_array across i.arg + end | 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 @@ -90,23 +112,8 @@ let rec live i finally = i.live <- before_body; before_body | Iraise _ -> - (* i.live remains empty since no regs are live across *) + i.live <- !live_at_raise; Reg.add_set_array !live_at_raise i.arg - | _ -> - let across_after = Reg.diff_set_array (live i.next finally) i.res in - let across = - match i.desc with - Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) - | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> - (* The function call may raise an exception, branching to the - nearest enclosing try ... with. Similarly for bounds checks. - Hence, everything that must be live at the beginning of - the exception handler must also be live across this instr. *) - Reg.Set.union across_after !live_at_raise - | _ -> - across_after in - i.live <- across; - Reg.add_set_array across i.arg let fundecl ppf f = let initially_live = live f.fun_body Reg.Set.empty in diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index a11910ec73..3a7174763a 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -36,7 +36,7 @@ type operation = | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of string + | Iconst_float of float | Iconst_symbol of string | Iconst_blockheader of nativeint | Icall_ind @@ -46,7 +46,7 @@ type operation = | Iextcall of string * bool | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode - | Istore of Cmm.memory_chunk * Arch.addressing_mode + | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool | Ialloc of int | Iintop of integer_operation | Iintop_imm of integer_operation * int diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index 000c3cf9f1..618e5e4ce7 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -36,17 +36,18 @@ type operation = | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of string + | Iconst_float of float | Iconst_symbol of string | Iconst_blockheader of nativeint | Icall_ind | Icall_imm of string | Itailcall_ind | Itailcall_imm of string - | Iextcall of string * bool + | Iextcall of string * bool (* false = noalloc, true = alloc *) | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode - | Istore of Cmm.memory_chunk * Arch.addressing_mode + | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool + (* false = initialization, true = assignment *) | Ialloc of int | Iintop of integer_operation | Iintop_imm of integer_operation * int diff --git a/asmcomp/power/CSE.ml b/asmcomp/power/CSE.ml new file mode 100644 index 0000000000..50fefa5e35 --- /dev/null +++ b/asmcomp/power/CSE.ml @@ -0,0 +1,38 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the PowerPC *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Imultaddf | Imultsubf) -> Op_pure + | Ispecific(Ialloc_far _) -> Op_other + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 32767n && n >= -32768n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f + diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index f6ee1a2321..0a26ed1479 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -229,7 +229,7 @@ let record_frame live dbg = (* Record floating-point and large integer literals *) -let float_literals = ref ([] : (string * int) list) +let float_literals = ref ([] : (int64 * int) list) let int_literals = ref ([] : (nativeint * int) list) (* Record external C functions to be called in a position-independent way @@ -333,7 +333,7 @@ let instr_size = function if chunk = Byte_signed then load_store_size addr + 1 else load_store_size addr - | Lop(Istore(chunk, addr)) -> load_store_size addr + | Lop(Istore(chunk, addr, _)) -> load_store_size addr | Lop(Ialloc n) -> 4 | Lop(Ispecific(Ialloc_far n)) -> 5 | Lop(Iintop Imod) -> 3 @@ -466,9 +466,9 @@ let rec emit_instr i dslot = ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` {emit_string lg} {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` end - | Lop(Iconst_float s) -> + | Lop(Iconst_float f) -> let lbl = new_label() in - float_literals := (s, lbl) :: !float_literals; + float_literals := (Int64.bits_of_float f, lbl) :: !float_literals; ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` lfd {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` | Lop(Iconst_symbol s) -> @@ -548,7 +548,7 @@ let rec emit_instr i dslot = emit_load_store loadinstr addr i.arg 0 i.res.(0); if chunk = Byte_signed then ` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> let storeinstr = match chunk with Byte_unsigned | Byte_signed -> "stb" @@ -628,8 +628,7 @@ let rec emit_instr i dslot = ` fcfid {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` end else begin let lbl = new_label() in - float_literals := ("4.503601774854144e15", lbl) :: !float_literals; - (* That float above represents 0x4330000080000000 *) + float_literals := (0x4330000080000000L, lbl) :: !float_literals; ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` lfd {emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n`; ` lis {emit_gpr 0}, 0x4330\n`; @@ -899,11 +898,11 @@ let emit_item = function | Cint n -> ` {emit_string datag} {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> if ppc64 - then emit_float64_directive ".quad" f - else emit_float64_split_directive ".long" f + then emit_float64_directive ".quad" (Int64.bits_of_float f) + else emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` {emit_string datag} {emit_symbol s}\n` | Clabel_address lbl -> diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 203e8a9ef4..77e37deda0 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -224,6 +224,17 @@ let max_register_pressure = function Iextcall(_, _) -> [| 15; 18 |] | _ -> [| 23; 30 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Imultaddf | Imultsubf) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml index 6e594f0283..7adaa2eed3 100644 --- a/asmcomp/power/scheduling.ml +++ b/asmcomp/power/scheduling.ml @@ -44,7 +44,7 @@ method reload_retaddr_latency = 12 method oper_issue_cycles = function Iconst_float _ | Iconst_symbol _ -> 2 | Iload(_, Ibased(_, _)) -> 2 - | Istore(_, Ibased(_, _)) -> 2 + | Istore(_, Ibased(_, _), _) -> 2 | Ialloc _ -> 4 | Iintop(Imod) -> 40 (* assuming full stall *) | Iintop(Icomp _) -> 4 diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml index f4e3b4d93f..b28d749e24 100644 --- a/asmcomp/printclambda.ml +++ b/asmcomp/printclambda.ml @@ -16,17 +16,20 @@ open Asttypes open Clambda let rec structured_constant ppf = function - | Uconst_float x -> fprintf ppf "%s" x - | Uconst_int32 x -> fprintf ppf "%ld" x - | Uconst_int64 x -> fprintf ppf "%Ld" x - | Uconst_nativeint x -> fprintf ppf "%nd" x + | Uconst_float x -> fprintf ppf "%F" x + | Uconst_int32 x -> fprintf ppf "%ldl" x + | Uconst_int64 x -> fprintf ppf "%LdL" x + | Uconst_nativeint x -> fprintf ppf "%ndn" x | Uconst_block (tag, l) -> fprintf ppf "block(%i" tag; List.iter (fun u -> fprintf ppf ",%a" uconstant u) l; fprintf ppf ")" - | Uconst_float_array sl -> - fprintf ppf "floatarray(%s)" - (String.concat "," sl) + | Uconst_float_array [] -> + fprintf ppf "floatarray()" + | Uconst_float_array (f1 :: fl) -> + fprintf ppf "floatarray(%F" f1; + List.iter (fun f -> fprintf ppf ",%F" f) fl; + fprintf ppf ")" | Uconst_string s -> fprintf ppf "%S" s and uconstant ppf = function diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index 008081fb47..89c8582aef 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -89,7 +89,7 @@ let rec expr ppf = function | Cconst_int n -> fprintf ppf "%i" n | Cconst_natint n | Cconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n) - | Cconst_float s -> fprintf ppf "%s" s + | Cconst_float n -> fprintf ppf "%F" n | Cconst_symbol s -> fprintf ppf "\"%s\"" s | Cconst_pointer n -> fprintf ppf "%ia" n | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n) @@ -188,8 +188,8 @@ let data_item ppf = function | Cint16 n -> fprintf ppf "int16 %i" n | Cint32 n -> fprintf ppf "int32 %s" (Nativeint.to_string n) | Cint n -> fprintf ppf "int %s" (Nativeint.to_string n) - | Csingle f -> fprintf ppf "single %s" f - | Cdouble f -> fprintf ppf "double %s" f + | Csingle f -> fprintf ppf "single %F" f + | Cdouble f -> fprintf ppf "double %F" f | Csymbol_address s -> fprintf ppf "addr \"%s\"" s | Clabel_address l -> fprintf ppf "addr L%i" l | Cstring s -> fprintf ppf "string \"%s\"" s diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 824665cd9d..a39160d28c 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -105,7 +105,7 @@ let operation op arg ppf res = | Ireload -> fprintf ppf "%a (reload)" regs arg | Iconst_int n | Iconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n) - | Iconst_float s -> fprintf ppf "%s" s + | Iconst_float f -> fprintf ppf "%F" f | Iconst_symbol s -> fprintf ppf "\"%s\"" s | Icall_ind -> fprintf ppf "call %a" regs arg | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg @@ -119,12 +119,13 @@ let operation op arg ppf res = | Iload(chunk, addr) -> fprintf ppf "%s[%a]" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) arg - | Istore(chunk, addr) -> - fprintf ppf "%s[%a] := %a" + | Istore(chunk, addr, is_assign) -> + fprintf ppf "%s[%a] := %a %s" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) (Array.sub arg 1 (Array.length arg - 1)) reg arg.(0) + (if is_assign then "(assign)" else "(init)") | Ialloc n -> fprintf ppf "alloc %i" n | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1) | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli index 6cc6aedc90..cd3374ab9a 100644 --- a/asmcomp/proc.mli +++ b/asmcomp/proc.mli @@ -40,6 +40,9 @@ val max_register_pressure: Mach.operation -> int array val destroyed_at_oper: Mach.instruction_desc -> Reg.t array val destroyed_at_raise: Reg.t array +(* Pure operations *) +val op_is_pure: Mach.operation -> bool + (* Info for laying out the stack frame *) val num_stack_slots: int array val contains_calls: bool ref diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml index a0fc7dfffa..ef6db5cb6e 100644 --- a/asmcomp/reg.ml +++ b/asmcomp/reg.ml @@ -178,6 +178,16 @@ let inter_set_array s v = else inter_all(i+1) in inter_all 0 +let disjoint_set_array s v = + match Array.length v with + 0 -> true + | 1 -> not (Set.mem v.(0) s) + | n -> let rec disjoint_all i = + if i >= n then true + else if Set.mem v.(i) s then false + else disjoint_all (i+1) + in disjoint_all 0 + let set_of_array v = match Array.length v with 0 -> Set.empty diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli index 34e7498018..e3cb2d9520 100644 --- a/asmcomp/reg.mli +++ b/asmcomp/reg.mli @@ -58,6 +58,7 @@ module Map: Map.S with type key = t val add_set_array: Set.t -> t array -> Set.t val diff_set_array: Set.t -> t array -> Set.t val inter_set_array: Set.t -> t array -> Set.t +val disjoint_set_array: Set.t -> t array -> bool val set_of_array: t array -> Set.t val reset: unit -> unit diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index e04eacd375..eb91854a50 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -165,7 +165,7 @@ method private instr_in_basic_block instr = load or store instructions (e.g. on the I386). *) method is_store = function - Istore(_, _) -> true + Istore(_, _, _) -> true | _ -> false method is_load = function diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index a8f073e53a..e30d6fec39 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -209,8 +209,8 @@ method virtual select_addressing : (* Default instruction selection for stores (of words) *) -method select_store addr arg = - (Istore(Word, addr), arg) +method select_store is_assign addr arg = + (Istore(Word, addr, is_assign), arg) (* call marking methods, documented in selectgen.mli *) @@ -256,10 +256,10 @@ method select_operation op args = | (Cstore chunk, [arg1; arg2]) -> let (addr, eloc) = self#select_addressing chunk arg1 in if chunk = Word then begin - let (op, newarg2) = self#select_store addr arg2 in + let (op, newarg2) = self#select_store true addr arg2 in (op, [newarg2; eloc]) end else begin - (Istore(chunk, addr), [arg2; eloc]) + (Istore(chunk, addr, true), [arg2; eloc]) (* Inversion addr/datum in Istore *) end | (Calloc, _) -> (Ialloc 0, args) @@ -677,16 +677,16 @@ method emit_stores env data regs_addr = ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) in List.iter (fun e -> - let (op, arg) = self#select_store !a e in + let (op, arg) = self#select_store false !a e in match self#emit_expr env arg with None -> assert false | Some regs -> match op with - Istore(_, _) -> + Istore(_, _, _) -> for i = 0 to Array.length regs - 1 do let r = regs.(i) in let kind = if r.typ = Float then Double_u else Word in - self#insert (Iop(Istore(kind, !a))) + self#insert (Iop(Istore(kind, !a, false))) (Array.append [|r|] regs_addr) [||]; a := Arch.offset_addressing !a (size_component r.typ) done diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 7012c900cc..abc6db5ebf 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -35,7 +35,8 @@ class virtual selector_generic : object method select_condition : Cmm.expression -> Mach.test * Cmm.expression (* Can be overridden to deal with special test instructions *) method select_store : - Arch.addressing_mode -> Cmm.expression -> Mach.operation * Cmm.expression + bool -> Arch.addressing_mode -> Cmm.expression -> + Mach.operation * Cmm.expression (* Can be overridden to deal with special store constant instructions *) method regs_for : Cmm.machtype -> Reg.t array (* Return an array of fresh registers of the given type. diff --git a/asmcomp/sparc/CSE.ml b/asmcomp/sparc/CSE.ml new file mode 100644 index 0000000000..c38bab8fe1 --- /dev/null +++ b/asmcomp/sparc/CSE.ml @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for Sparc *) + +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic (* as super *) + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 4095n && n >= -4096n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f + diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index 12d60ed327..877a3d52a0 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -190,7 +190,7 @@ let emit_frame fd = (* Record floating-point constants *) -let float_constants = ref ([] : (int * string) list) +let float_constants = ref ([] : (int * int64) list) let emit_float_constant (lbl, cst) = rodata (); @@ -309,11 +309,11 @@ let rec emit_instr i dslot = ` sethi %hi({emit_nativeint n}), %g1\n`; ` or %g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n` end - | Lop(Iconst_float s) -> + | Lop(Iconst_float f) -> (* On UltraSPARC, the fzero instruction could be used to set a floating point register pair to zero. *) let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; + float_constants := (lbl, Int64.bits_of_float f) :: !float_constants; ` sethi %hi({emit_label lbl}), %g1\n`; ` ldd [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n` | Lop(Iconst_symbol s) -> @@ -375,7 +375,7 @@ let rec emit_instr i dslot = | _ -> "ld" in emit_load loadinstr addr i.arg dest end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> let src = i.arg.(0) in begin match chunk with Double_u -> @@ -612,7 +612,7 @@ let is_one_instr i = | Iconst_int n | Iconst_blockheader n -> is_native_immediate n | Istackoffset _ -> true | Iload(_, Iindexed n) -> i.res.(0).typ <> Float && is_immediate n - | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float && is_immediate n + | Istore(_, Iindexed n, _) -> i.arg.(0).typ <> Float && is_immediate n | Iintop(op) -> is_one_instr_op op | Iintop_imm(op, _) -> is_one_instr_op op | Iaddf | Isubf | Imulf | Idivf -> true @@ -706,9 +706,9 @@ let emit_item = function | Cint n -> ` .word {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".word" f + emit_float32_directive ".word" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_split_directive ".word" f + emit_float64_split_directive ".word" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` | Clabel_address lbl -> diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index ed107a82a7..a538df4345 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -196,6 +196,15 @@ let max_register_pressure = function Iextcall(_, _) -> [| 11; 0 |] | _ -> [| 19; 15 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index ca17fe5bf6..95c49de393 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -233,7 +233,12 @@ let rec reload i before = (i, Reg.Set.empty) | Itrywith(body, handler) -> let (new_body, after_body) = reload body before in - let (new_handler, after_handler) = reload handler handler.live in + (* All registers live at the beginning of the handler are destroyed, + except the exception bucket *) + let before_handler = + Reg.Set.remove Proc.loc_exn_bucket + (Reg.add_set_array handler.live handler.arg) in + let (new_handler, after_handler) = reload handler before_handler in let (new_next, finally) = reload i.next (Reg.Set.union after_body after_handler) in (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, diff --git a/byterun/hash.c b/byterun/hash.c index 3beb0e016e..42cf613738 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -213,7 +213,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) for (i = 0, len = Wosize_val(v) / Double_wosize; i < len; i++) { h = caml_hash_mix_double(h, Double_field(v, i)); num--; - if (num < 0) break; + if (num <= 0) break; } break; case Abstract_tag: @@ -227,6 +227,9 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) goto again; case Forward_tag: v = Forward_val(v); + /* PR#6361: this should count as 1, otherwise we can get into a loop */ + num--; + if (num <= 0) break; goto again; case Object_tag: h = caml_hash_mix_intnat(h, Oid_val(v)); diff --git a/driver/main_args.ml b/driver/main_args.ml index bb03f8cf27..1444ae4571 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -154,6 +154,10 @@ let mk_no_app_funct f = "-no-app-funct", Arg.Unit f, " Deactivate applicative functors" ;; +let mk_no_float_const_prop f = + "-no-float-const-prop", Arg.Unit f, " Deactivate constant propagation for floating-point operations" +;; + let mk_noassert f = "-noassert", Arg.Unit f, " Do not compile assertion checks" ;; @@ -393,6 +397,10 @@ let mk_dcombine f = "-dcombine", Arg.Unit f, " (undocumented)" ;; +let mk_dcse f = + "-dcse", Arg.Unit f, " (undocumented)" +;; + let mk_dlive f = "-dlive", Arg.Unit f, " (undocumented)" ;; @@ -566,6 +574,7 @@ module type Optcomp_options = sig val _labels : unit -> unit val _linkall : unit -> unit val _no_app_funct : unit -> unit + val _no_float_const_prop : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit val _nodynlink : unit -> unit @@ -608,6 +617,7 @@ module type Optcomp_options = sig val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit + val _dcse : unit -> unit val _dlive : unit -> unit val _dspill : unit -> unit val _dsplit : unit -> unit @@ -662,6 +672,7 @@ module type Opttop_options = sig val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit + val _dcse : unit -> unit val _dlive : unit -> unit val _dspill : unit -> unit val _dsplit : unit -> unit @@ -821,6 +832,7 @@ struct mk_labels F._labels; mk_linkall F._linkall; mk_no_app_funct F._no_app_funct; + mk_no_float_const_prop F._no_float_const_prop; mk_noassert F._noassert; mk_noautolink_opt F._noautolink; mk_nodynlink F._nodynlink; @@ -864,6 +876,7 @@ struct mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; + mk_dcse F._dcse; mk_dlive F._dlive; mk_dspill F._dspill; mk_dsplit F._dsplit; @@ -918,6 +931,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; + mk_dcse F._dcse; mk_dlive F._dlive; mk_dspill F._dspill; mk_dsplit F._dsplit; diff --git a/driver/main_args.mli b/driver/main_args.mli index 078008f147..98d294f87d 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -140,6 +140,7 @@ module type Optcomp_options = sig val _labels : unit -> unit val _linkall : unit -> unit val _no_app_funct : unit -> unit + val _no_float_const_prop : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit val _nodynlink : unit -> unit @@ -182,6 +183,7 @@ module type Optcomp_options = sig val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit + val _dcse : unit -> unit val _dlive : unit -> unit val _dspill : unit -> unit val _dsplit : unit -> unit @@ -236,6 +238,7 @@ module type Opttop_options = sig val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit + val _dcse : unit -> unit val _dlive : unit -> unit val _dspill : unit -> unit val _dsplit : unit -> unit diff --git a/driver/optmain.ml b/driver/optmain.ml index fceac7a5d7..8285c6deb7 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -94,6 +94,7 @@ module Options = Main_args.Make_optcomp_options (struct let _labels = clear classic let _linkall = set link_everything let _no_app_funct = clear applicative_functors + let _no_float_const_prop = clear float_const_prop let _noassert = set noassert let _noautolink = set no_auto_link let _nodynlink = clear dlcode @@ -136,6 +137,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dcmm = set dump_cmm let _dsel = set dump_selection let _dcombine = set dump_combine + let _dcse = set dump_cse let _dlive () = dump_live := true; Printmach.print_live := true let _dspill = set dump_spill let _dsplit = set dump_split diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index 6637ab16bc..5e55240948 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -87,7 +87,7 @@ external succ : int -> int = "%succint" external pred : int -> int = "%predint" external ( + ) : int -> int -> int = "%addint" external ( - ) : int -> int -> int = "%subint" -external ( * ) : int -> int -> int = "%mulint" +external ( * ) : int -> int -> int = "%mulint" external ( / ) : int -> int -> int = "%divint" external ( mod ) : int -> int -> int = "%modint" diff --git a/parsing/parser.mly b/parsing/parser.mly index abe2b9ee33..55a7b5c513 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -522,9 +522,9 @@ use_file_tail: | SEMISEMI seq_expr post_item_attributes use_file_tail { Ptop_def[mkstrexp $2 $3] :: $4 } | SEMISEMI structure_item use_file_tail { Ptop_def[$2] :: $3 } - | SEMISEMI toplevel_directive SEMISEMI use_file_tail { $2 :: $4 } + | SEMISEMI toplevel_directive use_file_tail { $2 :: $3 } | structure_item use_file_tail { Ptop_def[$1] :: $2 } - | toplevel_directive SEMISEMI use_file_tail { $1 :: $3 } + | toplevel_directive use_file_tail { $1 :: $2 } ; parse_core_type: core_type EOF { $1 } @@ -1945,23 +1945,15 @@ class_longident: /* Toplevel directives */ toplevel_directive: - SHARP ident toplevel_directive_args { Ptop_dir($2, $3) } -; -toplevel_directive_arg: - | STRING { Pdir_string (fst $1) } - | INT { Pdir_int $1 } - | val_longident { Pdir_ident $1 } - | mod_longident { Pdir_ident $1 } - | keyword { - match $1 with - | "true" -> Pdir_bool true - | "false" -> Pdir_bool false - | s -> Pdir_keyword s - } -toplevel_directive_args: - | /*empty*/ { [] } - | toplevel_directive_arg toplevel_directive_args { $1 :: $2 } + SHARP ident { Ptop_dir($2, Pdir_none) } + | SHARP ident STRING { Ptop_dir($2, Pdir_string (fst $3)) } + | SHARP ident INT { Ptop_dir($2, Pdir_int $3) } + | SHARP ident val_longident { Ptop_dir($2, Pdir_ident $3) } + | SHARP ident mod_longident { Ptop_dir($2, Pdir_ident $3) } + | SHARP ident FALSE { Ptop_dir($2, Pdir_bool false) } + | SHARP ident TRUE { Ptop_dir($2, Pdir_bool true) } ; + /* Miscellaneous */ name_tag: @@ -2017,7 +2009,9 @@ additive: /* Attributes and extensions */ -keyword: +single_attr_id: + LIDENT { $1 } + | UIDENT { $1 } | AND { "and" } | AS { "as" } | ASSERT { "assert" } @@ -2068,11 +2062,6 @@ keyword: | WITH { "with" } /* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */ ; -single_attr_id: - LIDENT { $1 } - | UIDENT { $1 } - | keyword { $1 } -; attr_id: single_attr_id { mkloc $1 (symbol_rloc()) } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 5747f51eb3..ce938dd897 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -763,12 +763,12 @@ and module_binding = type toplevel_phrase = | Ptop_def of structure - | Ptop_dir of string * directive_argument list + | Ptop_dir of string * directive_argument (* #use, #load ... *) and directive_argument = + | Pdir_none | Pdir_string of string | Pdir_int of int | Pdir_ident of Longident.t | Pdir_bool of bool - | Pdir_keyword of string diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 28965bce3d..8b156bafd1 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -1224,12 +1224,12 @@ class printer ()= object(self:'self) pp f "~%s:%a" lbl self#simple_expr e method directive_argument f x = - match x with + (match x with + | Pdir_none -> () | Pdir_string (s) -> pp f "@ %S" s | Pdir_int (i) -> pp f "@ %d" i | Pdir_ident (li) -> pp f "@ %a" self#longident li - | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b) - | Pdir_keyword s -> pp f "@ %s" s + | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)) method toplevel_phrase f x = match x with @@ -1238,8 +1238,7 @@ class printer ()= object(self:'self) self#list self#structure_item f s ; pp_close_box f (); | Ptop_dir (s, da) -> - pp f "@[<hov2>#%s@ %a@]" s - (self#list ~sep:" " self#directive_argument) da + pp f "@[<hov2>#%s@ %a@]" s self#directive_argument da end;; @@ -1253,8 +1252,7 @@ let toplevel_phrase f x = (* pp_print_list structure_item f s ; *) (* pp_close_box f (); *) | Ptop_dir (s, da) -> - pp f "@[<hov2>#%s@ %a@]" s - (default#list ~sep:" " default#directive_argument) da + pp f "@[<hov2>#%s@ %a@]" s default#directive_argument da (* pp f "@[<hov2>#%s@ %a@]" s directive_argument da *) let expression f x = diff --git a/parsing/printast.ml b/parsing/printast.ml index 15de289d54..a8a1671b96 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -838,15 +838,15 @@ let rec toplevel_phrase i ppf x = structure (i+1) ppf s; | Ptop_dir (s, da) -> line i ppf "Ptop_dir \"%s\"\n" s; - list i directive_argument ppf da; + directive_argument i ppf da; and directive_argument i ppf x = match x with + | Pdir_none -> line i ppf "Pdir_none\n" | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s; | Pdir_int (i) -> line i ppf "Pdir_int %d\n" i; | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li; | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b); - | Pdir_keyword s -> line i ppf "Pdir_keyword %s\n" s; ;; let interface ppf x = list 0 signature_item ppf x;; diff --git a/testsuite/external/.ignore b/testsuite/external/.ignore index 8b57bbb1eb..39e14de915 100644 --- a/testsuite/external/.ignore +++ b/testsuite/external/.ignore @@ -26,7 +26,7 @@ camlpdf-0.5 camlp4 camlp4-trunk camlp5 -camlp5-6.10 +camlp5-git camlzip camlzip-1.04 camomile diff --git a/testsuite/external/Makefile b/testsuite/external/Makefile index 33acd2ae64..566aaf3921 100644 --- a/testsuite/external/Makefile +++ b/testsuite/external/Makefile @@ -44,10 +44,10 @@ all-cygwin: findlib ounit res pcre react ocamltext ocamlssl camlzip cryptokit \ all-macos: findlib res pcre react ocamltext \ ocamlssl camlzip cryptokit sqlite menhir hevea \ - xmllight xmlm omake \ + xmllight xmlm omake zen \ altergo boomerang vsyml extlib \ ocamlify calendar \ - dbm framac + dbm geneweb framac coq compcert platform: case `uname -s` in \ @@ -1573,56 +1573,53 @@ distclean:: rm -f ${CSV}.tar.gz all: csv -# disabled: need to be updated for new AST stuff -# # http://pauillac.inria.fr/~ddr/camlp5/ -# CAMLP5=camlp5-6.10 -# ${CAMLP5}.tgz: -# ${WGET} http://pauillac.inria.fr/~ddr/camlp5/distrib/src/$@ -# camlp5: ${CAMLP5}.tgz -# printf "%s " "$@" >/dev/tty -# test -d ${PREFIX} -# rm -rf ${CAMLP5} -# tar zxf ${CAMLP5}.tgz -# ./Patcher.sh ${CAMLP5} -# ( cd ${CAMLP5} && \ -# export PATH=${PREFIX}/bin:$$PATH && \ -# ./configure --transitional && \ -# ${MAKE} world.opt && \ -# ${MAKE} install ) -# echo ${VERSION} >$@ -# clean:: -# rm -rf ${CAMLP5} camlp5 -# distclean:: -# rm -f ${CAMLP5}.tgz -# all: camlp5 - -# disabled: depends on camlp5 -# # http://opensource.geneanet.org/projects/geneweb -# GENEWEB=gw-6.05-src -# ${GENEWEB}.tgz: -# ${WGET} http://opensource.geneanet.org/attachments/download/190/$@ -# geneweb: ${GENEWEB}.tgz camlp5 -# printf "%s " "$@" >/dev/tty -# test -d ${PREFIX} -# rm -rf ${GENEWEB} -# tar zxf ${GENEWEB}.tgz -# ./Patcher.sh ${GENEWEB} -# ( cd ${GENEWEB} && \ -# export PATH=${PREFIX}/bin:$$PATH && \ -# sh ./configure && \ -# ${MAKE} ) -# echo ${VERSION} >$@ -# clean:: -# rm -rf ${GENEWEB} geneweb -# distclean:: -# rm -f ${GENEWEB}.tgz -# all: geneweb +# http://pauillac.inria.fr/~ddr/camlp5/ +CAMLP5=camlp5-git +camlp5: + printf "%s " "$@" >/dev/tty + test -d ${PREFIX} + rm -rf ${CAMLP5} + git clone git://scm.gforge.inria.fr/camlp5/camlp5.git ${CAMLP5} + ./Patcher.sh ${CAMLP5} + ( cd ${CAMLP5} && \ + export PATH=${PREFIX}/bin:$$PATH && \ + ./configure --transitional && \ + ${MAKE} world.opt && \ + ${MAKE} install ) + echo ${VERSION} >$@ +clean:: + rm -rf ${CAMLP5} camlp5 +distclean:: + rm -f ${CAMLP5}-git +all: camlp5 + +disabled: depends on camlp5 +# http://opensource.geneanet.org/projects/geneweb +GENEWEB=gw-6.05-src +${GENEWEB}.tgz: + ${WGET} http://opensource.geneanet.org/attachments/download/190/$@ +geneweb: ${GENEWEB}.tgz camlp5 + printf "%s " "$@" >/dev/tty + test -d ${PREFIX} + rm -rf ${GENEWEB} + tar zxf ${GENEWEB}.tgz + ./Patcher.sh ${GENEWEB} + ( cd ${GENEWEB} && \ + export PATH=${PREFIX}/bin:$$PATH && \ + sh ./configure && \ + ${MAKE} ) + echo ${VERSION} >$@ +clean:: + rm -rf ${GENEWEB} geneweb +distclean:: + rm -f ${GENEWEB}.tgz +all: geneweb # http://coq.inria.fr/download COQ=coq-8.4pl2 ${COQ}.tar.gz: ${WGET} http://coq.inria.fr/distrib/V8.4pl2/files/$@ -xxcoq: ${COQ}.tar.gz camlp5 +coq: ${COQ}.tar.gz camlp5 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${COQ} diff --git a/testsuite/external/camlp5-git.patch b/testsuite/external/camlp5-git.patch new file mode 100644 index 0000000000..8ea012cc5c --- /dev/null +++ b/testsuite/external/camlp5-git.patch @@ -0,0 +1,12 @@ +diff --git a/Makefile b/Makefile +index 13622f7..b33a042 100644 +--- camlp5-git/Makefile.orig ++++ camlp5-git/Makefile +@@ -54,6 +54,7 @@ depend: + cd ocaml_stuff; $(MAKE) depend; cd .. + for i in $(DIRS) compile; do (cd $$i; $(MAKE) depend; cd ..); done + ++.PHONY: install + install: + rm -rf "$(DESTDIR)$(LIBDIR)/$(CAMLP5N)" + for i in $(DIRS) compile; do \ diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly index ad697b6f4b..c81ca619b6 100644 --- a/testsuite/tests/asmcomp/parsecmm.mly +++ b/testsuite/tests/asmcomp/parsecmm.mly @@ -172,7 +172,7 @@ componentlist: ; expr: INTCONST { Cconst_int $1 } - | FLOATCONST { Cconst_float $1 } + | FLOATCONST { Cconst_float (float_of_string $1) } | STRING { Cconst_symbol $1 } | POINTER { Cconst_pointer $1 } | IDENT { Cvar(find_ident $1) } @@ -316,7 +316,7 @@ dataitem: | BYTE INTCONST { Cint8 $2 } | HALF INTCONST { Cint16 $2 } | INT INTCONST { Cint(Nativeint.of_int $2) } - | FLOAT FLOATCONST { Cdouble $2 } + | FLOAT FLOATCONST { Cdouble (float_of_string $2) } | ADDR STRING { Csymbol_address $2 } | ADDR INTCONST { Clabel_address $2 } | KSTRING STRING { Cstring $2 } diff --git a/testsuite/tests/basic/constprop.ml b/testsuite/tests/basic/constprop.ml new file mode 100644 index 0000000000..6661291316 --- /dev/null +++ b/testsuite/tests/basic/constprop.ml @@ -0,0 +1,72 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Test constant propagation through inlining *) + +(* constprop.ml is generated from constprop.mlp using + cpp constprop.mlp > constprop.ml +*) +let do_test msg res1 res2 = + Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED") +(* Hide a constant from the optimizer, preventing constant propagation *) +let hide x = List.nth [x] 0 +let _ = + begin + let x = true and y = false in + let xh = hide x and yh = hide y in + do_test "booleans" ((x && y, x || y, not x)) ((xh && yh, xh || yh, not xh)) + end; + begin + let x = 89809344 and y = 457455773 and s = 7 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "integers" ((-x, x + y, x - y, x * y, x / y, x mod y, x land y, x lor y, x lxor y, x lsl s, x lsr s, x asr s, x = y, x <> y, x < y, x <= y, x > y, x >= y, succ x, pred y)) ((-xh, xh + yh, xh - yh, xh * yh, xh / yh, xh mod yh, xh land yh, xh lor yh, xh lxor yh, xh lsl sh, xh lsr sh, xh asr sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh, succ xh, pred yh)) + end; + begin + let x = 3.141592654 and y = 0.341638588598232096 in + let xh = hide x and yh = hide y in + do_test "floats" ((int_of_float x, x +. y, x -. y, x *. y, x /. y, x = y, x <> y, x < y, x <= y, x > y, x >= y)) ((int_of_float xh, xh +. yh, xh -. yh, xh *. yh, xh /. yh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 781944104l and y = 308219921l and s = 3 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "32-bit integers" (Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Int32.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 1828697041n and y = -521695949n and s = 8 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "native integers" (Nativeint.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Nativeint.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "64-bit integers" (Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Int64.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 1000807289 in + let xh = hide x in + do_test "integer conversions" ((float_of_int x, Int32.of_int x, Nativeint.of_int x, Int64.of_int x)) ((float_of_int xh, Int32.of_int xh, Nativeint.of_int xh, Int64.of_int xh)) + end; + begin + let x = 10486393l in + let xh = hide x in + do_test "32-bit integer conversions" ((Int32.to_int x, Nativeint.of_int32 x, Int64.of_int32 x)) ((Int32.to_int xh, Nativeint.of_int32 xh, Int64.of_int32 xh)) + end; + begin + let x = -131134014n in + let xh = hide x in + do_test "native integer conversions" ((Nativeint.to_int x, Nativeint.to_int32 x, Int64.of_nativeint x)) ((Nativeint.to_int xh, Nativeint.to_int32 xh, Int64.of_nativeint xh)) + end; + begin + let x = 531871273453404175L in + let xh = hide x in + do_test "64-bit integer conversions" ((Int64.to_int x, Int64.to_int32 x, Int64.to_nativeint x)) ((Int64.to_int xh, Int64.to_int32 xh, Int64.to_nativeint xh)) + end diff --git a/testsuite/tests/basic/constprop.mlp b/testsuite/tests/basic/constprop.mlp new file mode 100644 index 0000000000..305a98dd95 --- /dev/null +++ b/testsuite/tests/basic/constprop.mlp @@ -0,0 +1,130 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Test constant propagation through inlining *) + +(* constprop.ml is generated from constprop.mlp using + cpp constprop.mlp > constprop.ml +*) + +#define tbool(x,y) \ + (x && y, x || y, not x) + +#define tint(x,y,s) \ + (-x, x + y, x - y, x * y, x / y, x mod y, \ + x land y, x lor y, x lxor y, \ + x lsl s, x lsr s, x asr s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y, \ + succ x, pred y) + +#define tfloat(x,y) \ + (int_of_float x, \ + x +. y, x -. y, x *. y, x /. y, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +#define tconvint(i) \ + (float_of_int i, \ + Int32.of_int i, \ + Nativeint.of_int i, \ + Int64.of_int i) + +#define tconvint32(i) \ + (Int32.to_int i, \ + Nativeint.of_int32 i, \ + Int64.of_int32 i) + +#define tconvnativeint(i) \ + (Nativeint.to_int i, \ + Nativeint.to_int32 i, \ + Int64.of_nativeint i) + +#define tconvint64(i) \ + (Int64.to_int i, \ + Int64.to_int32 i, \ + Int64.to_nativeint i) \ + +#define tint32(x,y,s) \ + Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \ + logand x y, logor x y, logxor x y, \ + shift_left x s, shift_right x s, shift_right_logical x s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +#define tnativeint(x,y,s) \ + Nativeint.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \ + logand x y, logor x y, logxor x y, \ + shift_left x s, shift_right x s, shift_right_logical x s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +#define tint64(x,y,s) \ + Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \ + logand x y, logor x y, logxor x y, \ + shift_left x s, shift_right x s, shift_right_logical x s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +let do_test msg res1 res2 = + Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED") + +(* Hide a constant from the optimizer, preventing constant propagation *) +let hide x = List.nth [x] 0 + +let _ = + begin + let x = true and y = false in + let xh = hide x and yh = hide y in + do_test "booleans" (tbool(x, y)) (tbool(xh,yh)) + end; + begin + let x = 89809344 and y = 457455773 and s = 7 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "integers" (tint(x, y, s)) (tint(xh,yh,sh)) + end; + begin + let x = 3.141592654 and y = 0.341638588598232096 in + let xh = hide x and yh = hide y in + do_test "floats" (tfloat(x, y)) (tfloat(xh, yh)) + end; + begin + let x = 781944104l and y = 308219921l and s = 3 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "32-bit integers" (tint32(x, y, s)) (tint32(xh, yh, sh)) + end; + begin + let x = 1828697041n and y = -521695949n and s = 8 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "native integers" (tnativeint(x, y, s)) (tnativeint(xh, yh, sh)) + end; + begin + let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "64-bit integers" (tint64(x, y, s)) (tint64(xh, yh, sh)) + end; + begin + let x = 1000807289 in + let xh = hide x in + do_test "integer conversions" (tconvint(x)) (tconvint(xh)) + end; + begin + let x = 10486393l in + let xh = hide x in + do_test "32-bit integer conversions" (tconvint32(x)) (tconvint32(xh)) + end; + begin + let x = -131134014n in + let xh = hide x in + do_test "native integer conversions" (tconvnativeint(x)) (tconvnativeint(xh)) + end; + begin + let x = 531871273453404175L in + let xh = hide x in + do_test "64-bit integer conversions" (tconvint64(x)) (tconvint64(xh)) + end + diff --git a/testsuite/tests/basic/constprop.reference b/testsuite/tests/basic/constprop.reference new file mode 100644 index 0000000000..59590530ae --- /dev/null +++ b/testsuite/tests/basic/constprop.reference @@ -0,0 +1,10 @@ +booleans: passed +integers: passed +floats: passed +32-bit integers: passed +native integers: passed +64-bit integers: passed +integer conversions: passed +32-bit integer conversions: passed +native integer conversions: passed +64-bit integer conversions: passed diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml index a65812e4bb..b77b0c47db 100644 --- a/testsuite/tests/typing-modules/aliases.ml +++ b/testsuite/tests/typing-modules/aliases.ml @@ -204,3 +204,19 @@ module type Alias = sig module N : sig end module M = N end;; module F (X : sig end) = struct type t end;; module type A = Alias with module N := F(List);; module rec Bad : A = Bad;; + +(* Shinwell 2014-04-23 *) +module B = struct + module R = struct + type t = string + end + + module O = R +end + +module K = struct + module E = B + module N = E.O +end;; + +let x : K.N.t = "foo";; diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference index d31516b987..e820b78e28 100644 --- a/testsuite/tests/typing-modules/aliases.ml.reference +++ b/testsuite/tests/typing-modules/aliases.ml.reference @@ -371,4 +371,7 @@ Error: Module type declarations do not match: module rec Bad : A = Bad;; ^ Error: Unbound module type A +# module B : sig module R : sig type t = string end module O = R end +module K : sig module E = B module N = E.O end +# val x : K.N.t = "foo" # diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 43d5f10114..dc0aec9bb5 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -65,6 +65,7 @@ module Options = Main_args.Make_optcomp_options (struct let _labels = option "-labels" let _linkall = option "-linkall" let _no_app_funct = option "-no-app-funct" + let _no_float_const_prop = option "-no-float-const-prop" let _noassert = option "-noassert" let _noautolink = option "-noautolink" let _nodynlink = option "-nodynlink" @@ -107,6 +108,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dcmm = option "-dcmm" let _dsel = option "-dsel" let _dcombine = option "-dcombine" + let _dcse = option "-dcse" let _dlive = option "-dlive" let _dspill = option "-dspill" let _dsplit = option "-dsplit" diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index fe5e393714..f9d383380e 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -340,70 +340,101 @@ let trim_signature = function sg) | mty -> mty -let dir_show ppf args = - let open Parsetree in - let id lid = - let s = match lid with - Longident.Lident s -> s +let show_prim to_sig ppf lid = + let env = !Toploop.toplevel_env in + let loc = Location.none in + try + let s = + match lid with + | Longident.Lident s -> s | Longident.Ldot (_,s) -> s | Longident.Lapply _ -> fprintf ppf "Invalid path %a@." Printtyp.longident lid; raise Exit in - Ident.create_persistent s - in - let env = !Toploop.toplevel_env in - try - let loc = Location.none in - let item = - match args with - | [ Pdir_keyword "val"; Pdir_ident lid ] -> - let id = id lid in - let path, desc = Typetexp.find_value env loc lid in - Sig_value (id, desc) - | [ Pdir_keyword "type"; Pdir_ident lid ] -> - let id = id lid in - let path, desc = Typetexp.find_type env loc lid in - Sig_type (id, desc, Trec_not) - | [ Pdir_keyword "exception"; Pdir_ident lid ] -> - let id = id lid in - let desc = Typetexp.find_constructor env loc lid in - begin match desc.cstr_tag with - | Cstr_constant _ | Cstr_block _ -> - fprintf ppf "@[This constructor is not an exception.@]@."; - raise Exit - | Cstr_exception _ -> - Sig_exception (id, {exn_args=desc.cstr_args; - exn_loc=desc.cstr_loc; - exn_attributes=desc.cstr_attributes; - }) - end - | [ Pdir_keyword "module"; Pdir_ident lid ] -> - let id = id lid in - let path = Typetexp.find_module env loc lid in - let md = Env.find_module path env in - Sig_module (id, {md with md_type = trim_signature md.md_type}, - Trec_not) - | [ Pdir_keyword "module"; Pdir_keyword "type"; Pdir_ident lid ] -> - let id = id lid in - let path, desc = Typetexp.find_modtype env loc lid in - Sig_modtype (id, desc) - | [ Pdir_keyword "class"; Pdir_ident lid ] -> - let id = id lid in - let path, desc = Typetexp.find_class env loc lid in - Sig_class (id, desc, Trec_not) - | [ Pdir_keyword "class"; Pdir_keyword "type"; Pdir_ident lid ] -> - let id = id lid in - let path, desc = Typetexp.find_class_type env loc lid in - Sig_class_type (id, desc, Trec_not) - | _ -> fprintf ppf "@[Bad usage for #show@]@."; raise Exit - in - fprintf ppf "@[%a@]@." Printtyp.signature [item] + let id = Ident.create_persistent s in + let sg = to_sig env loc id lid in + fprintf ppf "@[%a@]@." Printtyp.signature sg with | Not_found -> fprintf ppf "@[Unknown element.@]@." - | Exit -> - () + | Exit -> () + +let all_show_funs = ref [] + +let reg_show_prim name to_sig = + all_show_funs := to_sig :: !all_show_funs; + Hashtbl.add directive_table name (Directive_ident (show_prim to_sig std_out)) + +let () = + reg_show_prim "show_val" + (fun env loc id lid -> + let path, desc = Typetexp.find_value env loc lid in + [ Sig_value (id, desc) ] + ) + +let () = + reg_show_prim "show_type" + (fun env loc id lid -> + let path, desc = Typetexp.find_type env loc lid in + [ Sig_type (id, desc, Trec_not) ] + ) + +let () = + reg_show_prim "show_exception" + (fun env loc id lid -> + let desc = Typetexp.find_constructor env loc lid in + match desc.cstr_tag with + | Cstr_constant _ | Cstr_block _ -> + raise Not_found + | Cstr_exception _ -> + [ Sig_exception (id, {exn_args=desc.cstr_args; + exn_loc=desc.cstr_loc; + exn_attributes=desc.cstr_attributes; + }) ] + ) + +let () = + reg_show_prim "show_module" + (fun env loc id lid -> + let path = Typetexp.find_module env loc lid in + let md = Env.find_module path env in + [ Sig_module (id, {md with md_type = trim_signature md.md_type}, + Trec_not) ] + ) + +let () = + reg_show_prim "show_module_type" + (fun env loc id lid -> + let path, desc = Typetexp.find_modtype env loc lid in + [ Sig_modtype (id, desc) ] + ) + +let () = + reg_show_prim "show_class" + (fun env loc id lid -> + let path, desc = Typetexp.find_class env loc lid in + [ Sig_class (id, desc, Trec_not) ] + ) + +let () = + reg_show_prim "show_class_type" + (fun env loc id lid -> + let path, desc = Typetexp.find_class_type env loc lid in + [ Sig_class_type (id, desc, Trec_not) ] + ) + + +let show env loc id lid = + let sg = + List.fold_left + (fun sg f -> try (f env loc id lid) @ sg with _ -> sg) + [] !all_show_funs + in + if sg = [] then raise Not_found else sg + +let () = + Hashtbl.add directive_table "show" (Directive_ident (show_prim show std_out)) let _ = Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out)); @@ -435,7 +466,4 @@ let _ = Hashtbl.add directive_table "warn_error" (Directive_string (parse_warnings std_out true)); - Hashtbl.add directive_table "show" - (Directive_generic (dir_show std_out)); - () diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 239bfaeac4..e991ee6490 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -28,7 +28,6 @@ type directive_fun = | Directive_int of (int -> unit) | Directive_ident of (Longident.t -> unit) | Directive_bool of (bool -> unit) - | Directive_generic of (Parsetree.directive_argument list -> unit) (* The table of toplevel value bindings and its accessors *) @@ -291,12 +290,11 @@ let execute_phrase print_outcome ppf phr = false | Some d -> match d, dir_arg with - | Directive_none f, [] -> f (); true - | Directive_string f, [Pdir_string s] -> f s; true - | Directive_int f, [Pdir_int n] -> f n; true - | Directive_ident f, [Pdir_ident lid] -> f lid; true - | Directive_bool f, [Pdir_bool b] -> f b; true - | Directive_generic f, l -> f l; true + | Directive_none f, Pdir_none -> f (); true + | Directive_string f, Pdir_string s -> f s; true + | Directive_int f, Pdir_int n -> f n; true + | Directive_ident f, Pdir_ident lid -> f lid; true + | Directive_bool f, Pdir_bool b -> f b; true | _ -> fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name; diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli index dabd18cf81..19bb885c5e 100644 --- a/toplevel/toploop.mli +++ b/toplevel/toploop.mli @@ -39,7 +39,6 @@ type directive_fun = | Directive_int of (int -> unit) | Directive_ident of (Longident.t -> unit) | Directive_bool of (bool -> unit) - | Directive_generic of (Parsetree.directive_argument list -> unit) val directive_table : (string, directive_fun) Hashtbl.t (* Table of known directives, with their execution function *) diff --git a/typing/env.ml b/typing/env.ml index 948ef60c47..7e904fc9fe 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1187,7 +1187,7 @@ and components_of_module_maker (env, sub, path, mty) = c.comp_labels <- add_to_tbl descr.lbl_name (descr, nopos) c.comp_labels) labels; - env := store_type_infos None id path decl !env !env + env := store_type_infos None id (Pident id) decl !env !env | Sig_exception(id, decl) -> let decl' = Subst.exception_declaration sub decl in let cstr = Datarepr.exception_descr path decl' in @@ -1203,13 +1203,13 @@ and components_of_module_maker (env, sub, path, mty) = let comps = components_of_module !env sub path mty in c.comp_components <- Tbl.add (Ident.name id) (comps, !pos) c.comp_components; - env := store_module None id path md !env !env; + env := store_module None id (Pident id) md !env !env; incr pos | Sig_modtype(id, decl) -> let decl' = Subst.modtype_declaration sub decl in c.comp_modtypes <- Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; - env := store_modtype None id path decl !env !env + env := store_modtype None id (Pident id) decl !env !env | Sig_class(id, decl, _) -> let decl' = Subst.class_declaration sub decl in c.comp_classes <- diff --git a/typing/typedecl.mli b/typing/typedecl.mli index b26621012a..16c46890ec 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -20,8 +20,8 @@ val transl_type_decl: Typedtree.type_declaration list * Env.t val transl_exception: - Env.t -> - Parsetree.constructor_declaration -> Typedtree.constructor_declaration * exception_declaration * Env.t + Env.t -> Parsetree.constructor_declaration -> + Typedtree.constructor_declaration * exception_declaration * Env.t val transl_exn_rebind: Env.t -> Parsetree.exception_rebind -> Typedtree.exception_rebind * Env.t diff --git a/utils/clflags.ml b/utils/clflags.ml index fdfcc838ba..aa105c774e 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -58,6 +58,7 @@ and dllpaths = ref ([] : string list) (* -dllpath *) and make_package = ref false (* -pack *) and for_package = ref (None: string option) (* -for-pack *) and error_size = ref 500 (* -error-size *) +and float_const_prop = ref true (* -no-float-const-prop *) and transparent_modules = ref false (* -trans-mod *) let dump_source = ref false (* -dsource *) let dump_parsetree = ref false (* -dparsetree *) @@ -72,6 +73,7 @@ let optimize_for_speed = ref true (* -compact *) and dump_cmm = ref false (* -dcmm *) let dump_selection = ref false (* -dsel *) +let dump_cse = ref false (* -dcse *) let dump_live = ref false (* -dlive *) let dump_spill = ref false (* -dspill *) let dump_split = ref false (* -dsplit *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 96f6f1df64..41043e69bb 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -55,6 +55,7 @@ val dllpaths : string list ref val make_package : bool ref val for_package : string option ref val error_size : int ref +val float_const_prop : bool ref val transparent_modules : bool ref val dump_source : bool ref val dump_parsetree : bool ref @@ -67,6 +68,7 @@ val keep_asm_file : bool ref val optimize_for_speed : bool ref val dump_cmm : bool ref val dump_selection : bool ref +val dump_cse : bool ref val dump_live : bool ref val dump_spill : bool ref val dump_split : bool ref diff --git a/utils/config.mlp b/utils/config.mlp index c83071da14..e4c0d322a8 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -52,8 +52,8 @@ let exec_magic_number = "Caml1999X011" and cmi_magic_number = "Caml1999I016" and cmo_magic_number = "Caml1999O009" and cma_magic_number = "Caml1999A010" -and cmx_magic_number = "Caml1999Y012" -and cmxa_magic_number = "Caml1999Z011" +and cmx_magic_number = "Caml1999Y013" +and cmxa_magic_number = "Caml1999Z012" and ast_impl_magic_number = "Caml1999M016" and ast_intf_magic_number = "Caml1999N015" and cmxs_magic_number = "Caml2007D001" |