diff options
Diffstat (limited to 'asmcomp')
32 files changed, 1140 insertions, 321 deletions
diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 674ed2adb2..bdcc3a18d3 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -22,6 +22,7 @@ open Emitaux let macosx = (Config.system = "macosx") let mingw64 = (Config.system = "mingw64") +let cygwin = (Config.system = "cygwin") let fp = Config.with_frame_pointers @@ -61,17 +62,17 @@ let emit_symbol s = Emitaux.emit_symbol '$' s let emit_call s = - if !Clflags.dlcode && not macosx && not mingw64 + if !Clflags.dlcode && not macosx && not mingw64 && not cygwin then `call {emit_symbol s}@PLT` else `call {emit_symbol s}` let emit_jump s = - if !Clflags.dlcode && not macosx && not mingw64 + if !Clflags.dlcode && not macosx && not mingw64 && not cygwin then `jmp {emit_symbol s}@PLT` else `jmp {emit_symbol s}` let load_symbol_addr s = - if !Clflags.dlcode && not mingw64 + if !Clflags.dlcode && not mingw64 && not cygwin then `movq {emit_symbol s}@GOTPCREL(%rip)` else if !pic_code then `leaq {emit_symbol s}(%rip)` @@ -372,7 +373,7 @@ let emit_instr fallthrough i = | _ -> ` movq {emit_reg src}, {emit_reg dst}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xorq {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` @@ -636,7 +637,7 @@ let emit_instr fallthrough i = ` jmp *{emit_reg tmp1}\n`; if macosx then ` .const\n` - else if mingw64 then + else if mingw64 || cygwin then ` .section .rdata,\"dr\"\n` else ` .section .rodata\n`; @@ -790,7 +791,7 @@ let begin_assembly() = (* from amd64.S; could emit these constants on demand *) if macosx then ` .literal16\n` - else if mingw64 then + else if mingw64 || cygwin then ` .section .rdata,\"dr\"\n` else ` .section .rodata.cst8,\"a\",@progbits\n`; @@ -813,7 +814,7 @@ let end_assembly() = if !float_constants <> [] then begin if macosx then ` .literal8\n` - else if mingw64 then + else if mingw64 || cygwin then ` .section .rdata,\"dr\"\n` else ` .section .rodata.cst8,\"a\",@progbits\n`; diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index cb023bb8c0..77156b8f01 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -15,7 +15,6 @@ module StringSet = Set.Make(struct type t = string let compare (x:t) y = compare x y end) -open Misc open Cmm open Arch open Proc @@ -378,7 +377,7 @@ let emit_instr fallthrough i = | _ -> ` mov {emit_reg dst}, {emit_reg src}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index ddec43db79..b6e0fa94ab 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -24,7 +24,7 @@ let fp = Config.with_frame_pointers let win64 = match Config.system with - | "win64" | "mingw64" -> true + | "win64" | "mingw64" | "cygwin" -> true | _ -> false (* Which asm conventions to use *) diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index a7cb86028b..49070d299f 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -22,7 +22,8 @@ open Mach Operation Res Arg1 Arg2 Imove R S or S R - Iconst_int S if 32-bit signed, R otherwise + Iconst_int ] S if 32-bit signed, R otherwise + Iconst_blockheader ] Iconst_float R Iconst_symbol (not PIC) S Iconst_symbol (PIC) R @@ -87,7 +88,7 @@ method! reload_operation op arg res = | Ifloatofint | Iintoffloat -> (* Result must be in register, but argument can be on stack *) (arg, (if stackp res.(0) then [| self#makereg res.(0) |] else res)) - | Iconst_int n -> + | Iconst_int n | Iconst_blockheader n -> if n <= 0x7FFFFFFFn && n >= -0x80000000n then (arg, res) else super#reload_operation op arg res diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 55a8f96b06..2f20ecf61a 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -387,7 +387,7 @@ let emit_instr i = ` ldr {emit_reg dst}, {emit_stack src}\n` end; 1 end - | Lop(Iconst_int n) -> + | 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`; diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index bc03c5d521..274e6ffcaf 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -323,7 +323,7 @@ let emit_instr i = | _ -> assert false end - | Lop(Iconst_int n) -> + | 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 @@ -604,7 +604,7 @@ let emit_instr i = ` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`; cfi_adjust_cfa_offset (-16); stack_offset := !stack_offset - 16 - | Lraise -> + | Lraise k -> begin match !Clflags.debug, k with | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> ` bl {emit_symbol "caml_raise_exn"}\n`; diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index dd53020d72..c4baf6cf9c 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -18,9 +18,23 @@ open Lambda type function_label = string +type ustructured_constant = + | Uconst_float of string + | 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_string of string + +and uconstant = + | Uconst_ref of string * ustructured_constant + | Uconst_int of int + | Uconst_ptr of int + type ulambda = Uvar of Ident.t - | Uconst of structured_constant * string option + | Uconst of uconstant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list @@ -29,6 +43,7 @@ type ulambda = | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch + | Ustringswitch of ulambda * (string * ulambda) list * ulambda | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda @@ -67,5 +82,5 @@ type value_approximation = Value_closure of function_description * value_approximation | Value_tuple of value_approximation array | Value_unknown - | Value_integer of int - | Value_constptr of int + | Value_const of uconstant + | Value_global_field of string * int diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 737965db86..1853933c91 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -18,9 +18,23 @@ open Lambda type function_label = string +type ustructured_constant = + | Uconst_float of string + | 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_string of string + +and uconstant = + | Uconst_ref of string * ustructured_constant + | Uconst_int of int + | Uconst_ptr of int + type ulambda = Uvar of Ident.t - | Uconst of structured_constant * string option + | Uconst of uconstant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list @@ -29,6 +43,7 @@ type ulambda = | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch + | Ustringswitch of ulambda * (string * ulambda) list * ulambda | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda @@ -67,5 +82,5 @@ type value_approximation = Value_closure of function_description * value_approximation | Value_tuple of value_approximation array | Value_unknown - | Value_integer of int - | Value_constptr of int + | Value_const of uconstant + | Value_global_field of string * int diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index aca36cbe95..78357d3b11 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -48,7 +48,7 @@ let getglobal id = let occurs_var var u = let rec occurs = function Uvar v -> v = var - | Uconst (cst,_) -> false + | Uconst _ -> false | Udirect_apply(lbl, args, _) -> List.exists occurs args | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args | Uclosure(fundecls, clos) -> List.exists occurs clos @@ -60,6 +60,10 @@ let occurs_var var u = | Uswitch(arg, s) -> occurs arg || occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks + | Ustringswitch(arg,sw,d) -> + occurs arg || + List.exists (fun (_,e) -> occurs e) sw || + occurs d | Ustaticfail (_, args) -> List.exists occurs args | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr @@ -81,6 +85,52 @@ let occurs_var var u = true in occurs u +(* Split a function with default parameters into a wrapper and an + inner function. The wrapper fills in missing optional parameters + with their default value and tail-calls the inner function. The + wrapper can then hopefully be inlined on most call sites to avoid + the overhead associated with boxing an optional argument with a + 'Some' constructor, only to deconstruct it immediately in the + function's body. *) + +let split_default_wrapper fun_id kind params body = + let rec aux map = function + | Llet(Strict, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when + Ident.name optparam = "*opt*" && List.mem optparam params + && not (List.mem_assoc optparam map) + -> + let wrapper_body, inner = aux ((optparam, id) :: map) rest in + Llet(Strict, id, def, wrapper_body), inner + | _ when map = [] -> raise Exit + | body -> + (* Check that those *opt* identifiers don't appear in the remaining + body. This should not appear, but let's be on the safe side. *) + let fv = Lambda.free_variables body in + List.iter (fun (id, _) -> if IdentSet.mem id fv then raise Exit) map; + + let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in + let map_param p = try List.assoc p map with Not_found -> p in + let args = List.map (fun p -> Lvar (map_param p)) params in + let wrapper_body = Lapply (Lvar inner_id, args, Location.none) in + + let inner_params = List.map map_param params in + let new_ids = List.map Ident.rename inner_params in + let subst = List.fold_left2 + (fun s id new_id -> + Ident.add id (Lvar new_id) s) + Ident.empty inner_params new_ids + in + let body = Lambda.subst_lambda subst body in + let inner_fun = Lfunction(Curried, new_ids, body) in + (wrapper_body, (inner_id, inner_fun)) + in + try + let wrapper_body, inner = aux [] body in + [(fun_id, Lfunction(kind, params, wrapper_body)); inner] + with Exit -> + [(fun_id, Lfunction(kind, params, body))] + + (* Determine whether the estimated size of a clambda term is below some threshold *) @@ -118,14 +168,7 @@ let lambda_smaller lam threshold = if !size > threshold then raise Exit; match lam with Uvar v -> () - | Uconst( - (Const_base(Const_int _ | Const_char _ | Const_float _ | - Const_int32 _ | Const_int64 _ | Const_nativeint _) | - Const_pointer _), _) -> incr size -(* Structured Constants are now emitted during closure conversion. *) - | Uconst (_, Some _) -> incr size - | Uconst _ -> - raise Exit (* avoid duplication of structured constants *) + | Uconst _ -> incr size | Udirect_apply(fn, args, _) -> size := !size + 4; lambda_list_size args | Ugeneric_apply(fn, args, _) -> @@ -147,6 +190,15 @@ let lambda_smaller lam threshold = lambda_size lam; lambda_array_size cases.us_actions_consts ; lambda_array_size cases.us_actions_blocks + | Ustringswitch (lam,sw,d) -> + lambda_size lam ; + (* as ifthenelse *) + List.iter + (fun (_,lam) -> + size := !size+2 ; + lambda_size lam) + sw ; + lambda_size d | Ustaticfail (_,args) -> lambda_list_size args | Ucatch(_, _, body, handler) -> incr size; lambda_size body; lambda_size handler @@ -187,8 +239,10 @@ let rec is_pure_clambda = function (* Simplify primitive operations on integers *) -let make_const_int n = (Uconst(Const_base(Const_int n), None), Value_integer n) -let make_const_ptr n = (Uconst(Const_pointer n, None), Value_constptr n) +let make_const c = (Uconst c, Value_const 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) = make_const_bool @@ -200,9 +254,9 @@ let make_comparison cmp (x: int) (y: int) = | Cle -> x <= y | Cge -> x >= y) -let simplif_prim_pure p (args, approxs) dbg = +let simplif_int_prim_pure p (args, approxs) dbg = match approxs with - [Value_integer x] -> + [Value_const (Uconst_int x)] -> begin match p with Pidentity -> make_const_int x | Pnegint -> make_const_int (-x) @@ -212,7 +266,7 @@ let simplif_prim_pure p (args, approxs) dbg = | Poffsetint y -> make_const_int (x + y) | _ -> (Uprim(p, args, dbg), Value_unknown) end - | [Value_integer x; Value_integer y] -> + | [Value_const (Uconst_int x); Value_const (Uconst_int y)] -> begin match p with Paddint -> make_const_int(x + y) | Psubint -> make_const_int(x - y) @@ -228,7 +282,7 @@ let simplif_prim_pure p (args, approxs) dbg = | Pintcomp cmp -> make_comparison cmp x y | _ -> (Uprim(p, args, dbg), Value_unknown) end - | [Value_constptr x] -> + | [Value_const (Uconst_ptr x)] -> begin match p with Pidentity -> make_const_ptr x | Pnot -> make_const_bool(x = 0) @@ -244,19 +298,19 @@ let simplif_prim_pure p (args, approxs) dbg = end | _ -> (Uprim(p, args, dbg), Value_unknown) end - | [Value_constptr x; Value_constptr y] -> + | [Value_const (Uconst_ptr x); Value_const (Uconst_ptr y)] -> 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) end - | [Value_constptr x; Value_integer y] -> + | [Value_const (Uconst_ptr x); Value_const (Uconst_int y)] -> begin match p with | Pintcomp cmp -> make_comparison cmp x y | _ -> (Uprim(p, args, dbg), Value_unknown) end - | [Value_integer x; Value_constptr y] -> + | [Value_const (Uconst_int x); Value_const (Uconst_ptr y)] -> begin match p with | Pintcomp cmp -> make_comparison cmp x y | _ -> (Uprim(p, args, dbg), Value_unknown) @@ -264,10 +318,57 @@ let simplif_prim_pure p (args, approxs) dbg = | _ -> (Uprim(p, args, dbg), Value_unknown) + +let field_approx n = function + | Value_tuple a when n < Array.length a -> a.(n) + | Value_const (Uconst_ref(_, Uconst_block(_, l))) when n < List.length l -> + Value_const (List.nth l n) + | _ -> Value_unknown + +let simplif_prim_pure p (args, approxs) dbg = + match p, args, approxs with + | Pmakeblock(tag, Immutable), _, _ -> + let field = function + | Value_const c -> c + | _ -> raise Exit + in + begin try + let cst = Uconst_block (tag, List.map field approxs) in + let name = + Compilenv.new_structured_constant cst ~shared:true + in + make_const (Uconst_ref (name, cst)) + with Exit -> + (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs)) + end + | 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)) ] + -> + make_const_int (String.length s) + + | _ -> + simplif_int_prim_pure p (args, approxs) dbg + let simplif_prim p (args, approxs as args_approxs) dbg = if List.for_all is_pure_clambda args then simplif_prim_pure p args_approxs dbg - else (Uprim(p, args, dbg), Value_unknown) + else + (* XXX : always return the same approxs as simplif_prim_pure? *) + let approx = + match p with + | Pmakeblock(_, Immutable) -> + Value_tuple (Array.of_list approxs) + | _ -> + Value_unknown + in + (Uprim(p, args, dbg), approx) (* Substitute variables in a [ulambda] term (a body of an inlined function) and perform some more simplifications on integer primitives. @@ -279,9 +380,7 @@ let simplif_prim p (args, approxs as args_approxs) dbg = over functions. *) let approx_ulam = function - Uconst(Const_base(Const_int n),_) -> Value_integer n - | Uconst(Const_base(Const_char c),_) -> Value_integer(Char.code c) - | Uconst(Const_pointer n,_) -> Value_constptr n + Uconst c -> Value_const c | _ -> Value_unknown let rec substitute sb ulam = @@ -329,6 +428,11 @@ let rec substitute sb ulam = us_actions_blocks = Array.map (substitute sb) sw.us_actions_blocks; }) + | Ustringswitch(arg,sw,d) -> + Ustringswitch + (substitute sb arg, + List.map (fun (s,act) -> s,substitute sb act) sw, + substitute sb d) | Ustaticfail (nfail, args) -> Ustaticfail (nfail, List.map (substitute sb) args) | Ucatch(nfail, ids, u1, u2) -> @@ -338,8 +442,10 @@ let rec substitute sb ulam = Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2) | Uifthenelse(u1, u2, u3) -> begin match substitute sb u1 with - Uconst(Const_pointer n, _) -> + Uconst (Uconst_ptr n) -> if n <> 0 then substitute sb u2 else substitute sb u3 + | Uprim(Pmakeblock _, _, _) -> + substitute sb u2 | su1 -> Uifthenelse(su1, substitute sb u2, substitute sb u3) end @@ -363,16 +469,11 @@ let rec substitute sb ulam = (* Perform an inline expansion *) let is_simple_argument = function - Uvar _ -> true - | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ | - Const_int32 _ | Const_int64 _ | Const_nativeint _),_) -> - true - | Uconst(Const_pointer _, _) -> true + | Uvar _ | Uconst _ -> true | _ -> false let no_effects = function - Uclosure _ -> true - | Uconst(Const_base(Const_string _),_) -> true + | Uclosure _ -> true | u -> is_simple_argument u let rec bind_params_rec subst params args body = @@ -383,9 +484,16 @@ let rec bind_params_rec subst params args body = bind_params_rec (Tbl.add p1 a1 subst) pl al body else begin let p1' = Ident.rename p1 in + let u1, u2 = + match Ident.name p1, a1 with + | "*opt*", Uprim(Pmakeblock(0, Immutable), [a], dbg) -> + a, Uprim(Pmakeblock(0, Immutable), [Uvar p1'], dbg) + | _ -> + a1, Uvar p1' + in let body' = - bind_params_rec (Tbl.add p1 (Uvar p1') subst) pl al body in - if occurs_var p1 body then Ulet(p1', a1, body') + bind_params_rec (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 @@ -432,7 +540,8 @@ let direct_apply fundesc funct ufunct uargs = let strengthen_approx appl approx = match approx_ulam appl with - (Value_integer _ | Value_constptr _) as intapprox -> intapprox + (Value_const _) as intapprox -> + intapprox | _ -> approx (* If a term has approximation Value_integer or Value_constptr and is pure, @@ -440,8 +549,16 @@ let strengthen_approx appl approx = let check_constant_result lam ulam approx = match approx with - Value_integer n when is_pure lam -> make_const_int n - | Value_constptr n when is_pure lam -> make_const_ptr n + Value_const c when is_pure lam -> make_const c + | Value_global_field (id, i) when is_pure lam -> + begin match ulam with + | Uprim(Pfield _, [Uprim(Pgetglobal _, _, _)], _) -> (ulam, approx) + | _ -> + let glb = + Uprim(Pgetglobal (Ident.create_persistent id), [], Debuginfo.none) + in + Uprim(Pfield i, [glb], Debuginfo.none), approx + end | _ -> (ulam, approx) (* Evaluate an expression with known value for its side effects only, @@ -492,13 +609,12 @@ let rec add_debug_info ev u = The closure environment [cenv] maps idents to [ulambda] terms. It is used to substitute environment accesses for free identifiers. *) +exception NotClosed + let close_approx_var fenv cenv id = let approx = try Tbl.find id fenv with Not_found -> Value_unknown in match approx with - Value_integer n -> - make_const_int n - | Value_constptr n -> - make_const_ptr n + Value_const c -> make_const c | approx -> let subst = try Tbl.find id cenv with Not_found -> Uvar id in (subst, approx) @@ -510,14 +626,33 @@ let rec close fenv cenv = function Lvar id -> close_approx_var fenv cenv id | Lconst cst -> - begin match cst with - Const_base(Const_int n) -> (Uconst (cst,None), Value_integer n) - | Const_base(Const_char c) -> (Uconst (cst,None), - Value_integer(Char.code c)) - | Const_pointer n -> (Uconst (cst, None), Value_constptr n) - | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), - Value_unknown) - end + let str ?(shared = true) cst = + let name = + Compilenv.new_structured_constant cst ~shared + in + Uconst_ref (name, cst) + in + let rec transl = function + | Const_base(Const_int n) -> Uconst_int n + | Const_base(Const_char c) -> Uconst_int (Char.code c) + | Const_pointer n -> Uconst_ptr n + | Const_block (tag, fields) -> + str (Uconst_block (tag, List.map transl fields)) + | Const_float_array sl -> + (* constant float arrays are really immutable *) + str (Uconst_float_array 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_int32 x) -> str (Uconst_int32 x) + | Const_base(Const_int64 x) -> str (Uconst_int64 x) + | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) + in + make_const (transl cst) | Lfunction(kind, params, body) as funct -> close_one_function fenv cenv (Ident.create "fun") funct @@ -581,7 +716,7 @@ let rec close fenv cenv = function (Variable, _) -> let (ubody, abody) = close fenv cenv body in (Ulet(id, ulam, ubody), abody) - | (_, (Value_integer _ | Value_constptr _)) + | (_, Value_const _) when str = Alias || is_pure lam -> close (Tbl.add id alam fenv) cenv body | (_, _) -> @@ -627,24 +762,14 @@ let rec close fenv cenv = function check_constant_result lam (getglobal id) (Compilenv.global_approx id) - | Lprim(Pmakeblock(tag, mut) as prim, lams) -> - let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in - (Uprim(prim, ulams, Debuginfo.none), - begin match mut with - Immutable -> Value_tuple(Array.of_list approxs) - | Mutable -> Value_unknown - end) | Lprim(Pfield n, [lam]) -> let (ulam, approx) = close fenv cenv lam in - let fieldapprox = - match approx with - Value_tuple a when n < Array.length a -> a.(n) - | _ -> Value_unknown in check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) - fieldapprox + (field_approx n approx) | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) -> let (ulam, approx) = close fenv cenv lam in - (!global_approx).(n) <- approx; + if approx <> Value_unknown then + (!global_approx).(n) <- approx; (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none), Value_unknown) | Lprim(Praise k, [Levent(arg, ev)]) -> @@ -666,6 +791,16 @@ let rec close fenv cenv = function us_index_blocks = block_index; us_actions_blocks = block_actions}), Value_unknown) + | Lstringswitch(arg,sw,d) -> + let uarg,_ = close fenv cenv arg in + let usw = + List.map + (fun (s,act) -> + let uact,_ = close fenv cenv act in + s,uact) + sw in + let ud,_ = close fenv cenv d in + Ustringswitch (uarg,usw,ud),Value_unknown | Lstaticraise (i, args) -> (Ustaticfail (i, close_list fenv cenv args), Value_unknown) | Lstaticcatch(body, (i, vars), handler) -> @@ -678,7 +813,7 @@ let rec close fenv cenv = function (Utrywith(ubody, id, uhandler), Value_unknown) | Lifthenelse(arg, ifso, ifnot) -> begin match close fenv cenv arg with - (uarg, Value_constptr n) -> + (uarg, Value_const (Uconst_ptr n)) -> sequence_constant_expr arg uarg (close fenv cenv (if n = 0 then ifnot else ifso)) | (uarg, _ ) -> @@ -730,6 +865,17 @@ and close_named fenv cenv id = function (* Build a shared closure for a set of mutually recursive functions *) and close_functions fenv cenv fun_defs = + let fun_defs = + List.flatten + (List.map + (function + | (id, Lfunction(kind, params, body)) -> + split_default_wrapper id kind params body + | _ -> assert false + ) + fun_defs) + in + (* Update and check nesting depth *) incr function_nesting_depth; let initially_closed = @@ -783,31 +929,52 @@ and close_functions fenv cenv fun_defs = build_closure_env env_param (fv_pos - env_pos) fv in let cenv_body = List.fold_right2 - (fun (id, params, arity, body) pos env -> + (fun (id, params, body, fundesc) pos env -> Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env) uncurried_defs clos_offsets cenv_fv in let (ubody, approx) = close fenv_rec cenv_body body in - if !useless_env && occurs_var env_param ubody then useless_env := false; + if !useless_env && occurs_var env_param ubody then raise NotClosed; let fun_params = if !useless_env then params else params @ [env_param] in - ({ label = fundesc.fun_label; - arity = fundesc.fun_arity; - params = fun_params; - body = ubody; - dbg }, - (id, env_pos, Value_closure(fundesc, approx))) in + let f = + { + label = fundesc.fun_label; + arity = fundesc.fun_arity; + params = fun_params; + body = ubody; + dbg; + } + in + (* give more chance of function with default parameters (i.e. + their wrapper functions) to be inlined *) + let n = + List.fold_left + (fun n id -> n + if Ident.name id = "*opt*" then 8 else 1) + 0 + fun_params + in + if lambda_smaller ubody + (!Clflags.inline_threshold + n) + then fundesc.fun_inline <- Some(fun_params, ubody); + + (f, (id, env_pos, Value_closure(fundesc, approx))) in (* Translate all function definitions. *) let clos_info_list = if initially_closed then begin - let cl = List.map2 clos_fundef uncurried_defs clos_offsets in + let snap = Compilenv.snapshot () in + try List.map2 clos_fundef uncurried_defs clos_offsets + with NotClosed -> (* If the hypothesis that the environment parameters are useless has been invalidated, then set [fun_closed] to false in all descriptions and recompile *) - if !useless_env then cl else begin + Compilenv.backtrack snap; (* PR#6337 *) List.iter - (fun (id, params, body, fundesc) -> fundesc.fun_closed <- false) + (fun (id, params, body, fundesc) -> + fundesc.fun_closed <- false; + fundesc.fun_inline <- None; + ) uncurried_defs; + useless_env := false; List.map2 clos_fundef uncurried_defs clos_offsets - end end else (* Excessive closure nesting: assume environment parameter is used *) List.map2 clos_fundef uncurried_defs clos_offsets @@ -817,20 +984,15 @@ and close_functions fenv cenv fun_defs = (* Return the Uclosure node and the list of all identifiers defined, with offsets and approximations. *) let (clos, infos) = List.split clos_info_list in + let fv = if !useless_env then [] else fv in (Uclosure(clos, List.map (close_var fenv cenv) fv), infos) (* Same, for one non-recursive function *) and close_one_function fenv cenv id funct = match close_functions fenv cenv [id, funct] with - ((Uclosure([f], _) as clos), - [_, _, (Value_closure(fundesc, _) as approx)]) -> - (* See if the function can be inlined *) - if lambda_smaller f.body - (!Clflags.inline_threshold + List.length f.params) - then fundesc.fun_inline <- Some(f.params, f.body); - (clos, approx) - | _ -> fatal_error "Closure.close_one_function" + | (clos, (i, _, approx) :: _) when id = i -> (clos, approx) + | _ -> fatal_error "Closure.close_one_function" (* Close a switch *) @@ -861,12 +1023,69 @@ and close_switch fenv cenv cases num_keys default = | _ -> index, actions +(* Collect exported symbols for structured constants *) + +let collect_exported_structured_constants a = + let rec approx = function + | Value_closure (fd, a) -> + approx a; + begin match fd.fun_inline with + | Some (_, u) -> ulam u + | None -> () + end + | Value_tuple a -> Array.iter approx a + | Value_const c -> const c + | Value_unknown | Value_global_field _ -> () + and const = function + | Uconst_ref (s, c) -> + Compilenv.add_exported_constant s; + structured_constant c + | Uconst_int _ | Uconst_ptr _ -> () + and structured_constant = function + | Uconst_block (_, ul) -> List.iter const ul + | Uconst_float _ | Uconst_int32 _ + | Uconst_int64 _ | Uconst_nativeint _ + | Uconst_float_array _ | Uconst_string _ -> () + and ulam = function + | Uvar _ -> () + | Uconst c -> const c + | Udirect_apply (_, ul, _) -> List.iter ulam ul + | Ugeneric_apply (u, ul, _) -> ulam u; List.iter ulam ul + | Uclosure (fl, ul) -> + List.iter (fun f -> ulam f.body) fl; + List.iter ulam ul + | Uoffset(u, _) -> ulam u + | Ulet (_, u1, u2) -> ulam u1; ulam u2 + | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u + | Uprim (_, ul, _) -> List.iter ulam ul + | Uswitch (u, sl) -> + ulam u; + Array.iter ulam sl.us_actions_consts; + Array.iter ulam sl.us_actions_blocks + | Ustringswitch (u,sw,d) -> + ulam u ; + List.iter (fun (_,act) -> ulam act) sw ; + ulam d + | Ustaticfail (_, ul) -> List.iter ulam ul + | Ucatch (_, _, u1, u2) + | Utrywith (u1, _, u2) + | Usequence (u1, u2) + | Uwhile (u1, u2) -> ulam u1; ulam u2 + | Uifthenelse (u1, u2, u3) + | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3 + | Uassign (_, u) -> ulam u + | Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul + in + approx a + (* The entry point *) let intro size lam = function_nesting_depth := 0; - global_approx := Array.create size Value_unknown; + let id = Compilenv.make_symbol None in + global_approx := Array.init size (fun i -> Value_global_field (id, i)); Compilenv.set_global_approx(Value_tuple !global_approx); let (ulam, approx) = close Tbl.empty Tbl.empty lam in + collect_exported_structured_constants (Value_tuple !global_approx); global_approx := [||]; ulam diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index cdb8338960..9a5f3ec6b8 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -89,6 +89,7 @@ type expression = | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint + | Cconst_blockheader of nativeint | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 2ae9eb6584..be2bd41457 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -75,6 +75,7 @@ type expression = | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint + | Cconst_blockheader of nativeint | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 591822f560..a953ba924c 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -27,18 +27,19 @@ open Cmx_format let bind name arg fn = match arg with Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ - | Cconst_pointer _ | Cconst_natpointer _ -> fn arg + | Cconst_pointer _ | Cconst_natpointer _ + | Cconst_blockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) let bind_nonvar name arg fn = match arg with Cconst_int _ | Cconst_natint _ | Cconst_symbol _ - | Cconst_pointer _ | Cconst_natpointer _ -> fn arg + | Cconst_pointer _ | Cconst_natpointer _ + | Cconst_blockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) (* Block headers. Meaning of the tag field: see stdlib/obj.ml *) -let float_tag = Cconst_int Obj.double_tag let floatarray_tag = Cconst_int Obj.double_array_tag let block_header tag sz = @@ -55,14 +56,14 @@ let boxedint32_header = block_header Obj.custom_tag 2 let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr) let boxedintnat_header = block_header Obj.custom_tag 2 -let alloc_block_header tag sz = Cconst_natint(block_header tag sz) -let alloc_float_header = Cconst_natint(float_header) -let alloc_floatarray_header len = Cconst_natint(floatarray_header len) -let alloc_closure_header sz = Cconst_natint(closure_header sz) -let alloc_infix_header ofs = Cconst_natint(infix_header ofs) -let alloc_boxedint32_header = Cconst_natint(boxedint32_header) -let alloc_boxedint64_header = Cconst_natint(boxedint64_header) -let alloc_boxedintnat_header = Cconst_natint(boxedintnat_header) +let alloc_block_header tag sz = Cconst_blockheader(block_header tag sz) +let alloc_float_header = Cconst_blockheader(float_header) +let alloc_floatarray_header len = Cconst_blockheader(floatarray_header len) +let alloc_closure_header sz = Cconst_blockheader(closure_header sz) +let alloc_infix_header ofs = Cconst_blockheader(infix_header ofs) +let alloc_boxedint32_header = Cconst_blockheader(boxedint32_header) +let alloc_boxedint64_header = Cconst_blockheader(boxedint64_header) +let alloc_boxedintnat_header = Cconst_blockheader(boxedintnat_header) (* Integers *) @@ -536,13 +537,15 @@ let float_array_set arr ofs newval = (* String length *) +(* Length of string block *) + let string_length exp = bind "str" exp (fun str -> let tmp_var = Ident.create "tmp" in Clet(tmp_var, Cop(Csubi, [Cop(Clsl, - [Cop(Clsr, [header str; Cconst_int 10]); + [get_size str; Cconst_int log2_size_addr]); Cconst_int 1]), Cop(Csubi, @@ -574,7 +577,7 @@ let call_cached_method obj tag cache pos args dbg = let make_alloc_generic set_fn tag wordsize args = if wordsize <= Config.max_young_wosize then - Cop(Calloc, Cconst_natint(block_header tag wordsize) :: args) + Cop(Calloc, Cconst_blockheader(block_header tag wordsize) :: args) else begin let id = Ident.create "alloc" in let rec fill_fields idx = function @@ -660,32 +663,20 @@ let transl_comparison = function (* Translate structured constants *) -(* Fabrice: moved to compilenv.ml ---- -let const_label = ref 0 - -let new_const_label () = - incr const_label; - !const_label - -let new_const_symbol () = - incr const_label; - Compilenv.make_symbol (Some (string_of_int !const_label)) - -let structured_constants = ref ([] : (string * structured_constant) list) -*) - let transl_constant = function - Const_base(Const_int n) -> + | Uconst_int n -> int_const n - | Const_base(Const_char c) -> - Cconst_int(((Char.code c) lsl 1) + 1) - | Const_pointer n -> + | Uconst_ptr n -> if n <= max_repr_int && n >= min_repr_int then Cconst_pointer((n lsl 1) + 1) else Cconst_natpointer (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) - | cst -> - Cconst_symbol (Compilenv.new_structured_constant cst false) + | Uconst_ref (label, _) -> + Cconst_symbol label + +let transl_structured_constant cst = + let label = Compilenv.new_structured_constant cst ~shared:true in + Cconst_symbol label (* Translate constant closures *) @@ -696,9 +687,9 @@ let constant_closures = let box_int_constant bi n = match bi with - Pnativeint -> Const_base(Const_nativeint n) - | Pint32 -> Const_base(Const_int32 (Nativeint.to_int32 n)) - | Pint64 -> Const_base(Const_int64 (Int64.of_nativeint n)) + Pnativeint -> Uconst_nativeint n + | Pint32 -> Uconst_int32 (Nativeint.to_int32 n) + | Pint64 -> Uconst_int64 (Int64.of_nativeint n) let operations_boxed_int bi = match bi with @@ -715,9 +706,9 @@ let alloc_header_boxed_int bi = let box_int bi arg = match arg with Cconst_int n -> - transl_constant (box_int_constant bi (Nativeint.of_int n)) + transl_structured_constant (box_int_constant bi (Nativeint.of_int n)) | Cconst_natint n -> - transl_constant (box_int_constant bi n) + transl_structured_constant (box_int_constant bi n) | _ -> let arg' = if bi = Pint32 && size_int = 8 && big_endian @@ -1114,6 +1105,41 @@ end module SwitcherBlocks = Switch.Make(SArgBlocks) +(* Int switcher, arg in [low..high], + cases is list of individual cases, and is sorted by first component *) + +let transl_int_switch arg low high cases default = match cases with +| [] -> assert false +| (k0,_)::_ -> + let nacts = List.length cases + 1 in + let actions = Array.create nacts default in + let rec set_acts idx = function + | [] -> assert false + | [i,act] -> + actions.(idx) <- act ; + if i = high then [(i,i,idx)] + else [(i,i,idx); (i+1,max_int,0)] + | (i,act)::((j,_)::_ as rem) -> + actions.(idx) <- act ; + let inters = set_acts (idx+1) rem in + (i,i,idx):: + begin + if j = i+1 then inters + else (i+1,j-1,0)::inters + end in + let inters = set_acts 1 cases in + let inters = + if k0 = low then inters else (low,k0-1,0)::inters in + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (low,high) + (fun i -> Cconst_int i) + a + (Array.of_list inters) actions) + + + (* Auxiliary functions for optimizing "let" of boxed numbers (floats and boxed integers *) @@ -1122,8 +1148,8 @@ type unboxed_number_kind = | Boxed_float | Boxed_integer of boxed_integer -let is_unboxed_number = function - Uconst(Const_base(Const_float f), _) -> +let rec is_unboxed_number = function + Uconst(Uconst_ref(_, Uconst_float _)) -> Boxed_float | Uprim(p, _, _) -> begin match simplif_primitive p with @@ -1164,6 +1190,7 @@ let is_unboxed_number = function | Pbbswap bi -> Boxed_integer bi | _ -> No_unboxing end + | Ulet (_, _, e) | Usequence (_, e) -> is_unboxed_number e | _ -> No_unboxing let subst_boxed_number unbox_fn boxed_id unboxed_id box_chunk box_offset exp = @@ -1205,12 +1232,19 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id box_chunk box_offset exp = let functions = (Queue.create() : ufunction Queue.t) +let strmatch_compile = + let module S = + Strmatch.Make + (struct + let string_block_length = get_size + let transl_switch = transl_int_switch + end) in + S.compile + let rec transl = function Uvar id -> Cvar id - | Uconst (sc, Some const_label) -> - Cconst_symbol const_label - | Uconst (sc, None) -> + | Uconst sc -> transl_constant sc | Uclosure(fundecls, []) -> let lbl = Compilenv.new_const_symbol() in @@ -1295,7 +1329,7 @@ let rec transl = function (Pgetglobal id, []) -> Cconst_symbol (Ident.name id) | (Pmakeblock(tag, mut), []) -> - transl_constant(Const_block(tag, [])) + assert false | (Pmakeblock(tag, mut), args) -> make_alloc tag (List.map transl args) | (Pccall prim, args) -> @@ -1308,7 +1342,7 @@ let rec transl = function dbg), List.map transl args) | (Pmakearray kind, []) -> - transl_constant(Const_block(0, [])) + transl_structured_constant (Uconst_block(0, [])) | (Pmakearray kind, args) -> begin match kind with Pgenarray -> @@ -1380,6 +1414,11 @@ let rec transl = function (untag_int arg) s.us_index_consts s.us_actions_consts, transl_switch (get_tag arg) s.us_index_blocks s.us_actions_blocks)) + | Ustringswitch(arg,sw,d) -> + bind "switch" (transl arg) + (fun arg -> + strmatch_compile arg (transl d) + (List.map (fun (s,act) -> s,transl act) sw)) | Ustaticfail (nfail, args) -> Cexit (nfail, List.map transl args) | Ucatch(nfail, [], body, handler) -> @@ -1492,7 +1531,7 @@ and transl_prim_1 p arg dbg = if no_overflow_lsl n then add_const (transl arg) (n lsl 1) else - transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n), None)) + transl_prim_2 Paddint arg (Uconst (Uconst_int n)) Debuginfo.none | Poffsetref n -> return_unit @@ -1922,17 +1961,17 @@ and transl_prim_3 p arg1 arg2 arg3 dbg = fatal_error "Cmmgen.transl_prim_3" and transl_unbox_float = function - Uconst(Const_base(Const_float f), _) -> Cconst_float f + Uconst(Uconst_ref(_, Uconst_float f)) -> Cconst_float f | exp -> unbox_float(transl exp) and transl_unbox_int bi = function - Uconst(Const_base(Const_int32 n), _) -> + Uconst(Uconst_ref(_, Uconst_int32 n)) -> Cconst_natint (Nativeint.of_int32 n) - | Uconst(Const_base(Const_nativeint n), _) -> + | Uconst(Uconst_ref(_, Uconst_nativeint n)) -> Cconst_natint n - | Uconst(Const_base(Const_int64 n), _) -> + | Uconst(Uconst_ref(_, Uconst_int64 n)) -> assert (size_int = 8); Cconst_natint (Int64.to_nativeint n) - | Uprim(Pbintofint bi',[Uconst(Const_base(Const_int i),_)],_) when bi = bi' -> + | Uprim(Pbintofint bi',[Uconst(Uconst_int i)],_) when bi = bi' -> Cconst_int i | exp -> unbox_int bi (transl exp) @@ -1966,8 +2005,8 @@ and make_catch2 mk_body handler = match handler with and exit_if_true cond nfail otherwise = match cond with - | Uconst (Const_pointer 0, _) -> otherwise - | Uconst (Const_pointer 1, _) -> Cexit (nfail,[]) + | Uconst (Uconst_ptr 0) -> otherwise + | Uconst (Uconst_ptr 1) -> Cexit (nfail,[]) | Uprim(Psequor, [arg1; arg2], _) -> exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise) | Uprim(Psequand, _, _) -> @@ -1996,8 +2035,8 @@ and exit_if_true cond nfail otherwise = and exit_if_false cond otherwise nfail = match cond with - | Uconst (Const_pointer 0, _) -> Cexit (nfail,[]) - | Uconst (Const_pointer 1, _) -> otherwise + | Uconst (Uconst_ptr 0) -> Cexit (nfail,[]) + | Uconst (Uconst_ptr 1) -> otherwise | Uprim(Psequand, [arg1; arg2], _) -> exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail | Uprim(Psequor, _, _) -> @@ -2117,99 +2156,38 @@ let rec transl_all_functions already_translated cont = (* Emit structured constants *) -let immstrings = Hashtbl.create 17 +let emit_block header symb cont = + Cint header :: Cdefine_symbol symb :: cont -let rec emit_constant symb cst cont = +let rec emit_structured_constant symb cst cont = match cst with - Const_base(Const_float s) -> - Cint(float_header) :: Cdefine_symbol symb :: Cdouble s :: cont - | Const_base(Const_string (s, _)) | Const_immstring s -> - Cint(string_header (String.length s)) :: - Cdefine_symbol symb :: - emit_string_constant s cont - | Const_base(Const_int32 n) -> - Cint(boxedint32_header) :: Cdefine_symbol symb :: - emit_boxed_int32_constant n cont - | Const_base(Const_int64 n) -> - Cint(boxedint64_header) :: Cdefine_symbol symb :: - emit_boxed_int64_constant n cont - | Const_base(Const_nativeint n) -> - Cint(boxedintnat_header) :: Cdefine_symbol symb :: - emit_boxed_nativeint_constant n cont - | Const_block(tag, fields) -> - let (emit_fields, cont1) = emit_constant_fields fields cont in - Cint(block_header tag (List.length fields)) :: - Cdefine_symbol symb :: - emit_fields @ cont1 - | Const_float_array(fields) -> - Cint(floatarray_header (List.length fields)) :: - Cdefine_symbol symb :: - Misc.map_end (fun f -> Cdouble f) fields cont - | _ -> fatal_error "gencmm.emit_constant" - -and emit_constant_fields fields cont = - match fields with - [] -> ([], cont) - | f1 :: fl -> - let (data1, cont1) = emit_constant_field f1 cont in - let (datal, contl) = emit_constant_fields fl cont1 in - (data1 :: datal, contl) - -and emit_constant_field field cont = - match field with - Const_base(Const_int n) -> - (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), - cont) - | Const_base(Const_char c) -> - (Cint(Nativeint.of_int(((Char.code c) lsl 1) + 1)), cont) - | Const_base(Const_float s) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont) - | Const_base(Const_string (s, _)) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(string_header (String.length s)) :: Cdefine_label lbl :: - emit_string_constant s cont) - | Const_immstring s -> - begin try - (Clabel_address (Hashtbl.find immstrings s), cont) - with Not_found -> - let lbl = Compilenv.new_const_label() in - Hashtbl.add immstrings s lbl; - (Clabel_address lbl, - Cint(string_header (String.length s)) :: Cdefine_label lbl :: - emit_string_constant s cont) - end - | Const_base(Const_int32 n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedint32_header) :: Cdefine_label lbl :: - emit_boxed_int32_constant n cont) - | Const_base(Const_int64 n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedint64_header) :: Cdefine_label lbl :: - emit_boxed_int64_constant n cont) - | Const_base(Const_nativeint n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedintnat_header) :: Cdefine_label lbl :: - emit_boxed_nativeint_constant n cont) - | Const_pointer n -> - (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), - cont) - | Const_block(tag, fields) -> - let lbl = Compilenv.new_const_label() in - let (emit_fields, cont1) = emit_constant_fields fields cont in - (Clabel_address lbl, - Cint(block_header tag (List.length fields)) :: Cdefine_label lbl :: - emit_fields @ cont1) - | Const_float_array(fields) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(floatarray_header (List.length fields)) :: Cdefine_label lbl :: - Misc.map_end (fun f -> Cdouble f) fields cont) + | Uconst_float s-> + emit_block float_header symb (Cdouble s :: cont) + | Uconst_string s -> + emit_block (string_header (String.length s)) symb + (emit_string_constant s cont) + | Uconst_int32 n -> + emit_block boxedint32_header symb + (emit_boxed_int32_constant n cont) + | Uconst_int64 n -> + emit_block boxedint64_header symb + (emit_boxed_int64_constant n cont) + | Uconst_nativeint n -> + emit_block boxedintnat_header symb + (emit_boxed_nativeint_constant n cont) + | Uconst_block (tag, csts) -> + let cont = List.fold_right emit_constant csts cont in + emit_block (block_header tag (List.length csts)) symb cont + | Uconst_float_array fields -> + emit_block (floatarray_header (List.length fields)) symb + (Misc.map_end (fun f -> Cdouble f) fields cont) + +and emit_constant cst cont = + match cst with + | Uconst_int n | Uconst_ptr n -> + Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) :: cont + | Uconst_ref (label, _) -> + Csymbol_address label :: cont and emit_string_constant s cont = let n = size_int - 1 - (String.length s) mod size_int in @@ -2275,14 +2253,12 @@ let emit_all_constants cont = let c = ref cont in List.iter (fun (lbl, global, cst) -> - let cst = emit_constant lbl cst [] in + let cst = emit_structured_constant lbl cst [] in let cst = if global then Cglobal_symbol lbl :: cst else cst in c:= Cdata(cst):: !c) (Compilenv.structured_constants()); -(* structured_constants := []; done in Compilenv.reset() *) - Hashtbl.clear immstrings; (* PR#3979 *) List.iter (fun (symb, fundecls) -> c := Cdata(emit_constant_closure symb fundecls []) :: !c) @@ -2648,8 +2624,8 @@ let reference_symbols namelist = let global_data name v = Cdata(Cglobal_symbol name :: - emit_constant name - (Const_base (Const_string (Marshal.to_string v [], None))) []) + emit_structured_constant name + (Uconst_string (Marshal.to_string v [])) []) let globals_map v = global_data "caml_globals_map" v @@ -2686,12 +2662,16 @@ let code_segment_table namelist = let predef_exception i name = let symname = "caml_exn_" ^ name in + let cst = Uconst_string name in + let label = Compilenv.new_const_symbol () in + let cont = emit_structured_constant label cst [] in Cdata(Cglobal_symbol symname :: - emit_constant symname - (Const_block(Obj.object_tag, - [Const_base(Const_string (name, None)); - Const_base(Const_int (-i-1)) - ])) []) + emit_structured_constant symname + (Uconst_block(Obj.object_tag, + [ + Uconst_ref(label, cst); + Uconst_int (-i-1); + ])) cont) (* Header for a plugin *) diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 48d6be7d47..80be94e9f7 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -27,8 +27,30 @@ exception Error of error let global_infos_table = (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t) -let structured_constants = - ref ([] : (string * bool * Lambda.structured_constant) list) +module CstMap = + Map.Make(struct + type t = Clambda.ustructured_constant + let compare = Pervasives.compare + (* could use a better version, comparing on the + first arg of Uconst_ref *) + end) + +type structured_constants = + { + strcst_shared: string CstMap.t; + strcst_all: (string * Clambda.ustructured_constant) list; + } + +let structured_constants_empty = + { + strcst_shared = CstMap.empty; + strcst_all = []; + } + +let structured_constants = ref structured_constants_empty + + +let exported_constants = Hashtbl.create 17 let current_unit = { ui_name = ""; @@ -69,7 +91,8 @@ let reset ?packname name = current_unit.ui_apply_fun <- []; current_unit.ui_send_fun <- []; current_unit.ui_force_link <- false; - structured_constants := [] + Hashtbl.clear exported_constants; + structured_constants := structured_constants_empty let current_unit_infos () = current_unit @@ -223,12 +246,39 @@ let new_const_symbol () = incr const_label; make_symbol (Some (string_of_int !const_label)) -let new_structured_constant cst global = - let lbl = new_const_symbol() in - structured_constants := (lbl, global, cst) :: !structured_constants; - lbl +let snapshot () = !structured_constants +let backtrack s = structured_constants := s -let structured_constants () = !structured_constants +let new_structured_constant cst ~shared = + let {strcst_shared; strcst_all} = !structured_constants in + if shared then + try + CstMap.find cst strcst_shared + with Not_found -> + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared = CstMap.add cst lbl strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + else + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + +let add_exported_constant s = + Hashtbl.replace exported_constants s () + +let structured_constants () = + List.map + (fun (lbl, cst) -> + (lbl, Hashtbl.mem exported_constants lbl, cst) + ) (!structured_constants).strcst_all (* Error report *) diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 9ffb145a85..9c2eb62975 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -54,9 +54,18 @@ val need_send_fun: int -> unit val new_const_symbol : unit -> string val new_const_label : unit -> int -val new_structured_constant : Lambda.structured_constant -> bool -> string -val structured_constants : - unit -> (string * bool * Lambda.structured_constant) list + +val new_structured_constant: + Clambda.ustructured_constant -> + shared:bool -> (* can be shared with another structually equal constant *) + string +val structured_constants: unit -> (string * bool * Clambda.ustructured_constant) list +val add_exported_constant: string -> unit + +type structured_constants +val snapshot: unit -> structured_constants +val backtrack: structured_constants -> unit + val read_unit_info: string -> unit_infos * Digest.t (* Read infos and MD5 from a [.cmx] file. *) diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index 3ad467cbff..ccfa977ffa 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -221,9 +221,9 @@ let reset_debug_info () = let emit_debug_info dbg = if is_cfi_enabled () && (!Clflags.debug || Config.with_frame_pointers) - && not (Debuginfo.is_none dbg) then begin + && dbg.Debuginfo.dinfo_line > 0 (* PR#6243 *) + then begin let line = dbg.Debuginfo.dinfo_line in - assert (line <> 0); (* clang errors out on zero line numbers *) let file_name = dbg.Debuginfo.dinfo_file in let file_num = try List.assoc file_name !file_pos_nums diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 3c77529ab7..2b90d37f64 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -458,7 +458,7 @@ let emit_instr fallthrough i = else ` movl {emit_reg src}, {emit_reg dst}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xorl {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index 145241d95c..495a29aecc 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -419,7 +419,7 @@ let emit_instr i = else ` mov {emit_reg dst}, {emit_reg src}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 58d0c10769..a11910ec73 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -38,6 +38,7 @@ type operation = | Iconst_int of nativeint | Iconst_float of string | Iconst_symbol of string + | Iconst_blockheader of nativeint | Icall_ind | Icall_imm of string | Itailcall_ind diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index 03028b2ca8..000c3cf9f1 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -38,6 +38,7 @@ type operation = | Iconst_int of nativeint | Iconst_float of string | Iconst_symbol of string + | Iconst_blockheader of nativeint | Icall_ind | Icall_imm of string | Itailcall_ind diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index e82f5ff790..f6ee1a2321 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -45,13 +45,6 @@ let slot_offset loc cls = | Incoming n -> frame_size() + n | Outgoing n -> n -(* Whether stack backtraces are supported *) - -let supports_backtraces = - match Config.system with - | "rhapsody" -> true - | _ -> false - (* Output a symbol *) let emit_symbol = @@ -267,7 +260,7 @@ let name_for_int_comparison = function let name_for_intop = function Iadd -> "add" - | Imul - > if ppc64 then "mulld" else "mullw" + | Imul -> if ppc64 then "mulld" else "mullw" | Imulh -> if ppc64 then "mulhd" else "mulhw" | Idiv -> if ppc64 then "divd" else "divw" | Iand -> "and" @@ -325,7 +318,8 @@ let load_store_size = function let instr_size = function Lend -> 0 | Lop(Imove | Ispill | Ireload) -> 1 - | Lop(Iconst_int n) -> if is_native_immediate n then 1 else 2 + | Lop(Iconst_int n | Iconst_blockheader n) -> + if is_native_immediate n then 1 else 2 | Lop(Iconst_float s) -> 2 | Lop(Iconst_symbol s) -> 2 | Lop(Icall_ind) -> 2 @@ -459,7 +453,7 @@ let rec emit_instr i dslot = | (_, _) -> fatal_error "Emit: Imove" end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if is_native_immediate n then ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin @@ -596,7 +590,7 @@ let rec emit_instr i dslot = emit_set_comp c i.res.(0) end | Lop(Iintop Icheckbound) -> - if !Clflags.debug && supports_backtraces then + if !Clflags.debug then record_frame Reg.Set.empty i.dbg; ` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> @@ -614,7 +608,7 @@ let rec emit_instr i dslot = emit_set_comp c i.res.(0) end | Lop(Iintop_imm(Icheckbound, n)) -> - if !Clflags.debug && supports_backtraces then + if !Clflags.debug then record_frame Reg.Set.empty i.dbg; ` {emit_string tglle}i {emit_reg i.arg.(0)}, {emit_int n}\n` | Lop(Iintop_imm(op, n)) -> @@ -757,18 +751,21 @@ let rec emit_instr i dslot = ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; stack_offset := !stack_offset - 16 | Lraise k -> - begin match !Clflags.debug && supports_backtraces, k with - | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> ` bl {emit_symbol "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg + | true, Lambda.Raise_reraise -> + ` bl {emit_symbol "caml_reraise_exn"}\n`; + record_frame Reg.Set.empty i.dbg | false, _ | true, Lambda.Raise_notrace -> ` {emit_string lg} {emit_gpr 0}, 0({emit_gpr 29})\n`; ` mr {emit_gpr 1}, {emit_gpr 29}\n`; - ` mtlr {emit_gpr 0}\n`; + ` mtctr {emit_gpr 0}\n`; ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; - ` blr\n` + ` bctr\n` end and emit_delay = function diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml index a5081fc47e..3d4c32c0ae 100644 --- a/asmcomp/printclambda.ml +++ b/asmcomp/printclambda.ml @@ -15,15 +15,30 @@ open Format open Asttypes open Clambda -let rec pr_idents ppf = function - | [] -> () - | h::t -> fprintf ppf "%a %a" Ident.print h pr_idents t +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_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_string s -> fprintf ppf "%S" s + +and uconstant ppf = function + | Uconst_ref (s, c) -> + fprintf ppf "%S=%a" s structured_constant c + | Uconst_int i -> fprintf ppf "%i" i + | Uconst_ptr i -> fprintf ppf "%ia" i let rec lam ppf = function | Uvar id -> Ident.print ppf id - | Uconst (cst,_) -> - Printlambda.structured_constant ppf cst + | Uconst c -> uconstant ppf c | Udirect_apply(f, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in @@ -85,6 +100,19 @@ let rec lam ppf = function fprintf ppf "@[<1>(switch %a@ @[<v 0>%a@])@]" lam larg switch sw + | Ustringswitch(larg,sw,d) -> + let switch ppf sw = + let spc = ref false in + List.iter + (fun (s,l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<hv 1>case \"%s\":@ %a@]" + (String.escaped s) lam l) + sw ; + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<hv 1>default:@ %a@]" lam d in + fprintf ppf + "@[<1>(switch %a@ @[<v 0>%a@])@]" lam larg switch sw | Ustaticfail (i, ls) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in @@ -132,3 +160,30 @@ and sequence ppf ulam = match ulam with let clambda ppf ulam = fprintf ppf "%a@." lam ulam + + +let rec approx ppf = function + Value_closure(fundesc, a) -> + Format.fprintf ppf "@[<2>function %s@ arity %i" + fundesc.fun_label fundesc.fun_arity; + if fundesc.fun_closed then begin + Format.fprintf ppf "@ (closed)" + end; + if fundesc.fun_inline <> None then begin + Format.fprintf ppf "@ (inline)" + end; + Format.fprintf ppf "@ -> @ %a@]" approx a + | Value_tuple a -> + let tuple ppf a = + for i = 0 to Array.length a - 1 do + if i > 0 then Format.fprintf ppf ";@ "; + Format.fprintf ppf "%i: %a" i approx a.(i) + done in + Format.fprintf ppf "@[<hov 1>(%a)@]" tuple a + | Value_unknown -> + Format.fprintf ppf "_" + | Value_const c -> + fprintf ppf "@[const(%a)@]" uconstant c + | Value_global_field (s, i) -> + fprintf ppf "@[global(%s,%i)@]" s i + diff --git a/asmcomp/printclambda.mli b/asmcomp/printclambda.mli index ddc233af06..d138b958ac 100644 --- a/asmcomp/printclambda.mli +++ b/asmcomp/printclambda.mli @@ -14,3 +14,5 @@ open Clambda open Format val clambda: formatter -> ulambda -> unit +val approx: formatter -> value_approximation -> unit +val structured_constant: formatter -> ustructured_constant -> unit diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index f1c9243a08..008081fb47 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -87,7 +87,8 @@ let operation = function let rec expr ppf = function | Cconst_int n -> fprintf ppf "%i" n - | Cconst_natint n -> fprintf ppf "%s" (Nativeint.to_string n) + | Cconst_natint n | Cconst_blockheader n -> + fprintf ppf "%s" (Nativeint.to_string n) | Cconst_float s -> fprintf ppf "%s" s | Cconst_symbol s -> fprintf ppf "\"%s\"" s | Cconst_pointer n -> fprintf ppf "%ia" n diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index f260c3df78..824665cd9d 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -18,8 +18,8 @@ open Reg open Mach let reg ppf r = - if String.length r.name > 0 then - fprintf ppf "%s" r.name + if not (Reg.anonymous r) then + fprintf ppf "%s" (Reg.name r) else fprintf ppf "%s" (match r.typ with Addr -> "A" | Int -> "I" | Float -> "F"); fprintf ppf "/%i" r.stamp; @@ -103,7 +103,8 @@ let operation op arg ppf res = | Imove -> regs ppf arg | Ispill -> fprintf ppf "%a (spill)" regs arg | Ireload -> fprintf ppf "%a (reload)" regs arg - | Iconst_int n -> fprintf ppf "%s" (Nativeint.to_string n) + | Iconst_int n + | Iconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n) | Iconst_float s -> fprintf ppf "%s" s | Iconst_symbol s -> fprintf ppf "\"%s\"" s | Icall_ind -> fprintf ppf "call %a" regs arg diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml index 1ec0bf9eb9..a0fc7dfffa 100644 --- a/asmcomp/reg.ml +++ b/asmcomp/reg.ml @@ -12,12 +12,30 @@ open Cmm +module Raw_name = struct + type t = + | Anon + | R + | Ident of Ident.t + + let create_from_ident ident = Ident ident + + let to_string t = + match t with + | Anon -> None + | R -> Some "R" + | Ident ident -> + let name = Ident.name ident in + if String.length name <= 0 then None else Some name +end + type t = - { mutable name: string; + { mutable raw_name: Raw_name.t; stamp: int; typ: Cmm.machtype_component; mutable loc: location; mutable spill: bool; + mutable part: int option; mutable interf: t list; mutable prefer: (t * int) list; mutable degree: int; @@ -37,16 +55,18 @@ and stack_location = type reg = t let dummy = - { name = ""; stamp = 0; typ = Int; loc = Unknown; spill = false; - interf = []; prefer = []; degree = 0; spill_cost = 0; visited = false } + { raw_name = Raw_name.Anon; stamp = 0; typ = Int; loc = Unknown; + spill = false; interf = []; prefer = []; degree = 0; spill_cost = 0; + visited = false; part = None; + } let currstamp = ref 0 let reg_list = ref([] : t list) let create ty = - let r = { name = ""; stamp = !currstamp; typ = ty; loc = Unknown; - spill = false; interf = []; prefer = []; degree = 0; - spill_cost = 0; visited = false } in + let r = { raw_name = Raw_name.Anon; stamp = !currstamp; typ = ty; + loc = Unknown; spill = false; interf = []; prefer = []; degree = 0; + spill_cost = 0; visited = false; part = None; } in reg_list := r :: !reg_list; incr currstamp; r @@ -65,16 +85,35 @@ let createv_like rv = let clone r = let nr = create r.typ in - nr.name <- r.name; + nr.raw_name <- r.raw_name; nr let at_location ty loc = - let r = { name = "R"; stamp = !currstamp; typ = ty; loc = loc; spill = false; - interf = []; prefer = []; degree = 0; spill_cost = 0; - visited = false } in + let r = { raw_name = Raw_name.R; stamp = !currstamp; typ = ty; loc; + spill = false; interf = []; prefer = []; degree = 0; + spill_cost = 0; visited = false; part = None; } in incr currstamp; r +let anonymous t = + match Raw_name.to_string t.raw_name with + | None -> true + | Some _raw_name -> false + +let name t = + match Raw_name.to_string t.raw_name with + | None -> "" + | Some raw_name -> + let with_spilled = + if t.spill then + "spilled-" ^ raw_name + else + raw_name + in + match t.part with + | None -> with_spilled + | Some part -> with_spilled ^ "#" ^ string_of_int part + let first_virtual_reg_stamp = ref (-1) let reset() = diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli index 889e026f2f..34e7498018 100644 --- a/asmcomp/reg.mli +++ b/asmcomp/reg.mli @@ -12,12 +12,18 @@ (* Pseudo-registers *) +module Raw_name : sig + type t + val create_from_ident : Ident.t -> t +end + type t = - { mutable name: string; (* Name (for printing) *) + { mutable raw_name: Raw_name.t; (* Name *) stamp: int; (* Unique stamp *) typ: Cmm.machtype_component; (* Type of contents *) mutable loc: location; (* Actual location *) mutable spill: bool; (* "true" to force stack allocation *) + mutable part: int option; (* Zero-based index of part of value *) mutable interf: t list; (* Other regs live simultaneously *) mutable prefer: (t * int) list; (* Preferences for other regs *) mutable degree: int; (* Number of other regs live sim. *) @@ -41,6 +47,11 @@ val createv_like: t array -> t array val clone: t -> t val at_location: Cmm.machtype_component -> location -> t +val anonymous : t -> bool + +(* Name for printing *) +val name : t -> string + module Set: Set.S with type elt = t module Map: Map.S with type key = t diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index 885c945404..e04eacd375 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -336,8 +336,8 @@ method private reschedule ready_queue date cont = if son.emitted_ancestors = son.ancestors then new_queue := son :: !new_queue) node.sons; - instr_cons node.instr.desc node.instr.arg node.instr.res - (self#reschedule !new_queue (date + issue_cycles) cont) + { node.instr with next = + self#reschedule !new_queue (date + issue_cycles) cont } end (* Entry point *) diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 8f1277a17e..0f1277f758 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -85,7 +85,7 @@ let swap_intcomp = function let all_regs_anonymous rv = try for i = 0 to Array.length rv - 1 do - if String.length rv.(i).name > 0 then raise Exit + if not (Reg.anonymous rv.(i)) then raise Exit done; true with Exit -> @@ -93,10 +93,11 @@ let all_regs_anonymous rv = let name_regs id rv = if Array.length rv = 1 then - rv.(0).name <- Ident.name id + rv.(0).raw_name <- Raw_name.create_from_ident id else for i = 0 to Array.length rv - 1 do - rv.(i).name <- Ident.name id ^ "#" ^ string_of_int i + rv.(i).raw_name <- Raw_name.create_from_ident id; + rv.(i).part <- Some i done (* "Join" two instruction sequences, making sure they return their results @@ -111,10 +112,10 @@ let join opt_r1 seq1 opt_r2 seq2 = assert (l1 = Array.length r2); let r = Array.create l1 Reg.dummy in for i = 0 to l1-1 do - if String.length r1.(i).name = 0 then begin + if Reg.anonymous r1.(i) then begin r.(i) <- r1.(i); seq2#insert_move r2.(i) r1.(i) - end else if String.length r2.(i).name = 0 then begin + end else if Reg.anonymous r2.(i) then begin r.(i) <- r2.(i); seq1#insert_move r1.(i) r2.(i) end else begin @@ -391,6 +392,9 @@ method emit_expr env exp = | Cconst_natint n -> let r = self#regs_for typ_int in Some(self#insert_op (Iconst_int n) [||] r) + | Cconst_blockheader n -> + let r = self#regs_for typ_int in + Some(self#insert_op (Iconst_blockheader n) [||] r) | Cconst_float n -> let r = self#regs_for typ_float in Some(self#insert_op (Iconst_float n) [||] r) @@ -433,6 +437,8 @@ method emit_expr env exp = Some(self#emit_tuple ext_env simple_list) end | Cop(Craise (k, dbg), [arg]) -> + if !Clflags.debug && k <> Lambda.Raise_notrace then + Proc.contains_calls := true; (* PR#6239 *) begin match self#emit_expr env arg with None -> None | Some r1 -> diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index 1d0699fb44..12d60ed327 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -302,7 +302,7 @@ let rec emit_instr i dslot = | (_, _) -> fatal_error "Emit: Imove" end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if is_native_immediate n then ` mov {emit_nativeint n}, {emit_reg i.res.(0)}\n` else begin @@ -609,7 +609,7 @@ let is_one_instr i = begin match op with Imove | Ispill | Ireload -> i.arg.(0).typ <> Float && i.res.(0).typ <> Float - | Iconst_int n -> is_native_immediate n + | 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 diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 0d8fcdc9c5..ca17fe5bf6 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -40,7 +40,7 @@ let spill_reg r = with Not_found -> let spill_r = Reg.create r.typ in spill_r.spill <- true; - if String.length r.name > 0 then spill_r.name <- "spilled-" ^ r.name; + if not (Reg.anonymous r) then spill_r.raw_name <- r.raw_name; spill_env := Reg.Map.add r spill_r !spill_env; spill_r diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml new file mode 100644 index 0000000000..760540d8a3 --- /dev/null +++ b/asmcomp/strmatch.ml @@ -0,0 +1,386 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 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. *) +(* *) +(***********************************************************************) + +(* Translation of string matching from closed lambda to C-- *) + +open Lambda +open Cmm + +module type I = sig + val string_block_length : Cmm.expression -> Cmm.expression + val transl_switch : + Cmm.expression -> int -> int -> + (int * Cmm.expression) list -> Cmm.expression -> + Cmm.expression +end + +module Make(I:I) = struct + +(* Debug *) + + let dbg = false + + let mask = + let open Nativeint in + sub (shift_left one 8) one + + let pat_as_string p = + let rec digits k n p = + if n <= 0 then k + else + let d = Nativeint.to_int (Nativeint.logand mask p) in + let d = Char.escaped (Char.chr d) in + digits (d::k) (n-1) (Nativeint.shift_right_logical p 8) in + let ds = digits [] Arch.size_addr p in + let ds = + if Arch.big_endian then ds else List.rev ds in + String.concat "" ds + + let do_pp_cases chan cases = + List.iter + (fun (ps,_) -> + Printf.fprintf chan " [%s]\n" + (String.concat "; " (List.map pat_as_string ps))) + cases + + let pp_cases chan tag cases = + Printf.eprintf "%s:\n" tag ; + do_pp_cases chan cases + + let pp_match chan tag idxs cases = + Printf.eprintf + "%s: idx=[%s]\n" tag + (String.concat "; " (List.map string_of_int idxs)) ; + do_pp_cases chan cases + +(* Utilities *) + + let gen_cell_id () = Ident.create "cell" + let gen_size_id () = Ident.create "size" + + let mk_let_cell id str ind body = + let cell = + Cop(Cload Word,[Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)])]) in + Clet(id, cell, body) + + let mk_let_size id str body = + let size = I.string_block_length str in + Clet(id, size, body) + + let mk_cmp_gen cmp_op id nat ifso ifnot = + let test = Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ]) in + Cifthenelse (test, ifso, ifnot) + + let mk_lt = mk_cmp_gen Clt + let mk_eq = mk_cmp_gen Ceq + + module IntArg = + struct + type t = int + let compare (x:int) (y:int) = + if x < y then -1 + else if x > y then 1 + else 0 + end + + let interval m0 n = + let rec do_rec m = + if m >= n then [] + else m::do_rec (m+1) in + do_rec m0 + + +(*****************************************************) +(* Compile strings to a lists of words [native ints] *) +(*****************************************************) + + let pat_of_string str = + let len = String.length str in + let n = len / Arch.size_addr + 1 in + let get_byte i = + if i < len then int_of_char str.[i] + else if i < n * Arch.size_addr - 1 then 0 + else n * Arch.size_addr - 1 - len in + let mk_word ind = + let w = ref 0n in + let imin = ind * Arch.size_addr + and imax = (ind + 1) * Arch.size_addr - 1 in + if Arch.big_endian then + for i = imin to imax do + w := Nativeint.logor (Nativeint.shift_left !w 8) + (Nativeint.of_int (get_byte i)); + done + else + for i = imax downto imin do + w := Nativeint.logor (Nativeint.shift_left !w 8) + (Nativeint.of_int (get_byte i)); + done; + !w in + let rec mk_words ind = + if ind >= n then [] + else mk_word ind::mk_words (ind+1) in + mk_words 0 + +(*****************************) +(* Discriminating heuristics *) +(*****************************) + + module IntSet = Set.Make(IntArg) + module NativeSet = Set.Make(Nativeint) + + let rec add_one sets ps = match sets,ps with + | [],[] -> [] + | set::sets,p::ps -> + let sets = add_one sets ps in + NativeSet.add p set::sets + | _,_ -> assert false + + let count_arities cases = match cases with + | [] -> assert false + | (ps,_)::_ -> + let sets = + List.fold_left + (fun sets (ps,_) -> add_one sets ps) + (List.map (fun _ -> NativeSet.empty) ps) cases in + List.map NativeSet.cardinal sets + + let count_arities_first cases = + let set = + List.fold_left + (fun set case -> match case with + | (p::_,_) -> NativeSet.add p set + | _ -> assert false) + NativeSet.empty cases in + NativeSet.cardinal set + + let count_arities_length cases = + let set = + List.fold_left + (fun set (ps,_) -> IntSet.add (List.length ps) set) + IntSet.empty cases in + IntSet.cardinal set + + let best_col = + let rec do_rec kbest best k = function + | [] -> kbest + | x::xs -> + if x < best then + do_rec k x (k+1) xs + else + do_rec kbest best (k+1) xs in + let smallest = do_rec (-1) max_int 0 in + fun cases -> + let ars = count_arities cases in + smallest ars + + let swap_list = + let rec do_rec k xs = match xs with + | [] -> assert false + | x::xs -> + if k <= 0 then [],x,xs + else + let xs,mid,ys = do_rec (k-1) xs in + x::xs,mid,ys in + fun k xs -> + let xs,x,ys = do_rec k xs in + x::xs @ ys + + let swap k idxs cases = + if k = 0 then idxs,cases + else + let idxs = swap_list k idxs + and cases = + List.map + (fun (ps,act) -> swap_list k ps,act) + cases in + if dbg then begin + pp_match stderr "SWAP" idxs cases + end ; + idxs,cases + + let best_first idxs cases = match idxs with + | []|[_] -> idxs,cases (* optimisation: one column only *) + | _ -> + let k = best_col cases in + swap k idxs cases + +(************************************) +(* Divide according to first column *) +(************************************) + + module Divide(O:Set.OrderedType) = struct + + module OMap = Map.Make(O) + + let do_find key env = + try OMap.find key env + with Not_found -> assert false + + + let divide cases = + let env = + List.fold_left + (fun env (p,psact) -> + let old = + try OMap.find p env + with Not_found -> [] in + OMap.add p ((psact)::old) env) + OMap.empty cases in + let r = OMap.fold (fun key v k -> (key,v)::k) env [] in + List.rev r (* Now sorted *) + end + +(***************) +(* Compilation *) +(***************) + +(* Group by cell *) + + module DivideNative = Divide(Nativeint) + + let by_cell cases = + DivideNative.divide + (List.map + (fun case -> match case with + | (p::ps),act -> p,(ps,act) + | [],_ -> assert false) + cases) + +(* Split into two halves *) + + let rec do_split idx env = match env with + | [] -> assert false + | (midkey,_ as x)::rem -> + if idx <= 0 then [],midkey,env + else + let lt,midkey,ge = do_split (idx-1) rem in + x::lt,midkey,ge + + let split_env len env = do_split (len/2) env + +(* Switch according to one cell *) + +(* + Emit the switch, here as a comparison tree. + Argument compile_rec is to be called to compile the rest of patterns, + as match_on_cell can be called in two different contexts : + from do_compile_pats and top_compile below. + *) + let match_oncell compile_rec str default idx env = + let id = gen_cell_id () in + let rec comp_rec env = + let len = List.length env in + if len <= 3 then + List.fold_right + (fun (key,cases) ifnot -> + mk_eq id key + (compile_rec str default cases) + ifnot) + env default + else + let lt,midkey,ge = split_env len env in + mk_lt id midkey (comp_rec lt) (comp_rec ge) in + mk_let_cell id str idx (comp_rec env) + + +(* + Recursive 'list of cells' compile function: + - choose the matched cell and switch on it + - notice: patterns (and idx) all have the same length + *) + + let rec do_compile_pats idxs str default cases = + if dbg then begin + pp_match stderr "COMPILE" idxs cases + end ; + match idxs with + | [] -> + begin match cases with + | [] -> default + | (_,e)::_ -> e + end + | _::_ -> + let idxs,cases = best_first idxs cases in + begin match idxs with + | [] -> assert false + | idx::idxs -> + match_oncell + (do_compile_pats idxs) str default idx (by_cell cases) + end + + +(* Group by size *) + + module DivideInt = Divide(IntArg) + + + let by_size cases = + DivideInt.divide + (List.map + (fun (ps,_ as case) -> List.length ps,case) + cases) +(* + Switch according to pattern size + Argument from_ind is the starting index, it can be zero + or one (when the swicth on the cell 0 has already been performed. + In that latter case pattern len is string length-1 and is corrected. + *) + + let compile_by_size from_ind str default cases = + let size_cases = + List.map + (fun (len,cases) -> + let len = len+from_ind in + let act = + do_compile_pats + (interval from_ind len) + str default cases in + (len,act)) + (by_size cases) in + let id = gen_size_id () in + let switch = I.transl_switch (Cvar id) 1 max_int size_cases default in + mk_let_size id str switch + +(* + Compilation entry point: we choose to switch + either on size or on first cell, using the + 'least discriminant' heuristics. + *) + let top_compile str default cases = + let a_len = count_arities_length cases + and a_fst = count_arities_first cases in + if a_len <= a_fst then begin + if dbg then pp_cases stderr "SIZE" cases ; + compile_by_size 0 str default cases + end else begin + if dbg then pp_cases stderr "FIRST COL" cases ; + let compile_size_rest str default cases = + compile_by_size 1 str default cases in + match_oncell compile_size_rest str default 0 (by_cell cases) + end + +(* Module entry point *) + + let catch arg k = match arg with + | Cexit (e,[]) -> k arg + | _ -> + let e = next_raise_count () in + Ccatch (e,[],k (Cexit (e,[])),arg) + + let compile str default cases = + let cases = + List.rev_map + (fun (s,act) -> pat_of_string s,act) + cases in + catch default (fun default -> top_compile str default cases) + + end diff --git a/asmcomp/strmatch.mli b/asmcomp/strmatch.mli new file mode 100644 index 0000000000..9be2b69451 --- /dev/null +++ b/asmcomp/strmatch.mli @@ -0,0 +1,28 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 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. *) +(* *) +(***********************************************************************) + +(* Translation of string matching from closed lambda to C-- *) + +module type I = sig + val string_block_length : Cmm.expression -> Cmm.expression + val transl_switch : + Cmm.expression -> int -> int -> + (int * Cmm.expression) list -> Cmm.expression -> + Cmm.expression +end + +module Make(I:I) : sig + (* Compile stringswitch (arg,cases,d) + Note: cases should not contain string duplicates *) + val compile : Cmm.expression (* arg *) -> Cmm.expression (* d *) -> + (string * Cmm.expression) list (* cases *)-> Cmm.expression +end |