diff options
Diffstat (limited to 'bytecomp')
| -rw-r--r-- | bytecomp/bytegen.ml | 8 | ||||
| -rw-r--r-- | bytecomp/emitcode.ml | 4 | ||||
| -rw-r--r-- | bytecomp/instruct.ml | 2 | ||||
| -rw-r--r-- | bytecomp/instruct.mli | 2 | ||||
| -rw-r--r-- | bytecomp/lambda.ml | 12 | ||||
| -rw-r--r-- | bytecomp/lambda.mli | 9 | ||||
| -rw-r--r-- | bytecomp/matching.ml | 16 | ||||
| -rw-r--r-- | bytecomp/printinstr.ml | 2 | ||||
| -rw-r--r-- | bytecomp/printlambda.ml | 2 | ||||
| -rw-r--r-- | bytecomp/symtable.ml | 10 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 52 | ||||
| -rw-r--r-- | bytecomp/translcore.mli | 2 | ||||
| -rw-r--r-- | bytecomp/translmod.ml | 19 |
13 files changed, 102 insertions, 38 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index e933df532..6ecd41dde 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -74,7 +74,7 @@ let make_branch cont = match cont with (Kbranch _ as branch) :: _ -> (branch, cont) | (Kreturn _ as return) :: _ -> (return, cont) - | Kraise :: _ -> (Kraise, cont) + | Kraise k :: _ -> (Kraise k, cont) | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont | _ -> make_branch_2 (None) 0 cont cont @@ -108,7 +108,7 @@ let rec add_pop n cont = match cont with Kpop m :: cont -> add_pop (n + m) cont | Kreturn m :: cont -> Kreturn(n + m) :: cont - | Kraise :: _ -> cont + | Kraise _ :: _ -> cont | _ -> Kpop n :: cont (* Add the constant "unit" in front of a continuation *) @@ -584,8 +584,8 @@ let rec comp_expr env exp sz cont = comp_expr env exp1 sz (Kstrictbranchif lbl :: comp_expr env exp2 sz cont1) end - | Lprim(Praise, [arg]) -> - comp_expr env arg sz (Kraise :: discard_dead_code cont) + | Lprim(Praise k, [arg]) -> + comp_expr env arg sz (Kraise k :: discard_dead_code cont) | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))]) when is_immed n -> comp_expr env arg sz (Koffsetint n :: cont) diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 2f1d58599..9911de882 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -243,7 +243,9 @@ let emit_instr = function | Kboolnot -> out opBOOLNOT | Kpushtrap lbl -> out opPUSHTRAP; out_label lbl | Kpoptrap -> out opPOPTRAP - | Kraise -> out opRAISE + | Kraise Raise_regular -> out opRAISE + | Kraise Raise_reraise -> out opRERAISE + | Kraise Raise_notrace -> out opRAISE_NOTRACE | Kcheck_signals -> out opCHECK_SIGNALS | Kccall(name, n) -> if n <= 5 diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index 5edcacd27..70d622299 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -85,7 +85,7 @@ type instruction = | Kboolnot | Kpushtrap of label | Kpoptrap - | Kraise + | Kraise of raise_kind | Kcheck_signals | Kccall of string * int | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index d81228ac7..024dba13c 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -105,7 +105,7 @@ type instruction = | Kboolnot | Kpushtrap of label | Kpoptrap - | Kraise + | Kraise of raise_kind | Kcheck_signals | Kccall of string * int | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 1b6b805d0..aa56c31fa 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -41,7 +41,7 @@ type primitive = (* External call *) | Pccall of Primitive.description (* Exceptions *) - | Praise + | Praise of raise_kind (* Boolean operations *) | Psequand | Psequor | Pnot (* Integer operations *) @@ -137,6 +137,11 @@ and bigarray_layout = | Pbigarray_c_layout | Pbigarray_fortran_layout +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + type structured_constant = Const_base of constant | Const_pointer of int @@ -457,3 +462,8 @@ and negate_comparison = function | Ceq -> Cneq| Cneq -> Ceq | Clt -> Cge | Cle -> Cgt | Cgt -> Cle | Cge -> Clt + +let raise_kind = function + | Raise_regular -> "raise" + | Raise_reraise -> "reraise" + | Raise_notrace -> "raise_notrace" diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 7f5db6906..904ea6fd7 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -41,7 +41,7 @@ type primitive = (* External call *) | Pccall of Primitive.description (* Exceptions *) - | Praise + | Praise of raise_kind (* Boolean operations *) | Psequand | Psequor | Pnot (* Integer operations *) @@ -137,6 +137,11 @@ and bigarray_layout = | Pbigarray_c_layout | Pbigarray_fortran_layout +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + type structured_constant = Const_base of constant | Const_pointer of int @@ -233,3 +238,5 @@ val staticfail : lambda (* Anticipated static failure *) (* Check anticipated failure, substitute its final value *) val is_guarded: lambda -> bool val patch_guarded : lambda -> lambda -> lambda + +val raise_kind: raise_kind -> string diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 3b06070d5..b6ba0ac86 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1678,7 +1678,7 @@ let rec do_tests_nofail tst arg = function let make_test_sequence fail tst lt_tst arg const_lambda_list = let rec make_test_sequence const_lambda_list = - if List.length const_lambda_list >= 4 && lt_tst <> Praise then + if List.length const_lambda_list >= 4 && lt_tst <> Pignore then split_sequence const_lambda_list else match fail with | None -> do_tests_nofail tst arg const_lambda_list @@ -2098,7 +2098,7 @@ let combine_constant arg cst partial ctx def fail arg 0 255 int_lambda_list | Const_string _ -> make_test_sequence - fail prim_string_notequal Praise arg const_lambda_list + fail prim_string_notequal Pignore arg const_lambda_list | Const_float _ -> make_test_sequence fail @@ -2155,10 +2155,15 @@ let combine_constructor arg ex_pat cstr partial ctx def | Some fail -> fail, tag_lambda_list in List.fold_right (fun (ex, act) rem -> + assert(ex = cstr.cstr_tag); match ex with | Cstr_exception (path, _) -> + let slot = + if cstr.cstr_arity = 0 then arg + else Lprim(Pfield 0, [arg]) + in Lifthenelse(Lprim(Pintcomp Ceq, - [Lprim(Pfield 0, [arg]); + [slot; transl_path ~loc:ex_pat.pat_loc ex_pat.pat_env path]), act, rem) @@ -2730,7 +2735,7 @@ let compile_matching loc repr handler_fun arg pat_act_list partial = let partial_function loc () = (* [Location.get_pos_info] is too expensive *) let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - Lprim(Praise, [Lprim(Pmakeblock(0, Immutable), + Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable), [transl_normal_path Predef.path_match_failure; Lconst(Const_block(0, [Const_base(Const_string (fname, None)); @@ -2742,7 +2747,8 @@ let for_function loc repr param pat_act_list partial = (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = - compile_matching Location.none None (fun () -> Lprim(Praise, [param])) + compile_matching Location.none None + (fun () -> Lprim(Praise Raise_reraise, [param])) param pat_act_list Partial let for_let loc param pat body = diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml index a5cd7e05d..43d8d3606 100644 --- a/bytecomp/printinstr.ml +++ b/bytecomp/printinstr.ml @@ -67,7 +67,7 @@ let instruction ppf = function | Kboolnot -> fprintf ppf "\tboolnot" | Kpushtrap lbl -> fprintf ppf "\tpushtrap L%i" lbl | Kpoptrap -> fprintf ppf "\tpoptrap" - | Kraise -> fprintf ppf "\traise" + | Kraise k-> fprintf ppf "\t%s" (Lambda.raise_kind k) | Kcheck_signals -> fprintf ppf "\tcheck_signals" | Kccall(s, n) -> fprintf ppf "\tccall %s, %i" s n diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 46e47ec08..beb268480 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -105,7 +105,7 @@ let primitive ppf = function | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size | Plazyforce -> fprintf ppf "force" | Pccall p -> fprintf ppf "%s" p.prim_name - | Praise -> fprintf ppf "raise" + | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) | Psequand -> fprintf ppf "&&" | Psequor -> fprintf ppf "||" | Pnot -> fprintf ppf "not" diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 9c94c9046..baff51c48 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -134,13 +134,17 @@ let output_primitive_table outchan = let init () = (* Enter the predefined exceptions *) - Array.iter - (fun name -> + Array.iteri + (fun i name -> let id = try List.assoc name Predef.builtin_values with Not_found -> fatal_error "Symtable.init" in let c = slot_for_setglobal id in - let cst = Const_block(0, [Const_base(Const_string (name, None))]) in + let cst = Const_block(Obj.object_tag, + [Const_base(Const_string (name, None)); + Const_base(Const_int (-i-1)) + ]) + in literal_table := (c, cst) :: !literal_table) Runtimedef.builtin_exceptions; (* Initialize the known C primitives *) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 12e0e26de..3a6cf7187 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -146,7 +146,9 @@ let primitives_table = create_hashtable 57 [ "%setfield0", Psetfield(0, true); "%makeblock", Pmakeblock(0, Immutable); "%makemutable", Pmakeblock(0, Mutable); - "%raise", Praise; + "%raise", Praise Raise_regular; + "%reraise", Praise Raise_reraise; + "%raise_notrace", Praise Raise_notrace; "%sequand", Psequand; "%sequor", Psequor; "%boolnot", Pnot; @@ -585,7 +587,7 @@ let primitive_is_ccall = function let assert_failed exp = let (fname, line, char) = Location.get_pos_info exp.exp_loc.Location.loc_start in - Lprim(Praise, [event_after exp + Lprim(Praise Raise_regular, [event_after exp (Lprim(Pmakeblock(0, Immutable), [transl_normal_path Predef.path_assert_failure; Lconst(Const_block(0, @@ -601,6 +603,8 @@ let rec cut n l = (* Translation of expressions *) +let try_ids = Hashtbl.create 8 + let rec transl_exp e = let eval_once = (* Whether classes for immediate objects must be cached *) @@ -679,8 +683,17 @@ and transl_exp0 e = (Warnings.Deprecated "operator (or); you should use (||) instead"); let prim = transl_prim e.exp_loc p args in match (prim, args) with - (Praise, [arg1]) -> - wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)])) + (Praise k, [arg1]) -> + let targ = List.hd argl in + let k = + match k, targ with + | Raise_regular, Lvar id + when Hashtbl.mem try_ids id -> + Raise_reraise + | _ -> + k + in + wrap0 (Lprim(Praise k, [event_after arg1 targ])) | (_, _) -> begin match (prim, argl) with | (Plazyforce, [a]) -> @@ -701,7 +714,7 @@ and transl_exp0 e = | Texp_try(body, pat_expr_list) -> let id = name_pattern "exn" pat_expr_list in Ltrywith(transl_exp body, id, - Matching.for_trywith (Lvar id) (transl_cases pat_expr_list)) + Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list)) | Texp_tuple el -> let ll = transl_list el in begin try @@ -721,8 +734,9 @@ and transl_exp0 e = Lprim(Pmakeblock(n, Immutable), ll) end | Cstr_exception (path, _) -> - Lprim(Pmakeblock(0, Immutable), - transl_path ~loc:e.exp_loc e.exp_env path :: ll) + let slot = transl_path ~loc:e.exp_loc e.exp_env path in + if cstr.cstr_arity = 0 then slot + else Lprim(Pmakeblock(0, Immutable), slot :: ll) end | Texp_variant(l, arg) -> let tag = Btype.hash_variant l in @@ -904,6 +918,20 @@ and transl_case {c_lhs; c_guard; c_rhs} = and transl_cases cases = List.map transl_case cases +and transl_case_try {c_lhs; c_guard; c_rhs} = + match c_lhs.pat_desc with + | Tpat_var (id, _) + | Tpat_alias (_, id, _) -> + Hashtbl.replace try_ids id (); + Misc.try_finally + (fun () -> c_lhs, transl_guard c_guard c_rhs) + (fun () -> Hashtbl.remove try_ids id) + | _ -> + c_lhs, transl_guard c_guard c_rhs + +and transl_cases_try cases = + List.map transl_case_try cases + and transl_tupled_cases patl_expr_list = List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr)) patl_expr_list @@ -1098,16 +1126,6 @@ let transl_let rec_flag pat_expr_list body = (transl_let rec_flag pat_expr_list) body *) -(* Compile an exception definition *) - -let transl_exception path decl = - let name = - match path with - None -> Ident.name decl.cd_id - | Some p -> Path.name p in - Lprim(Pmakeblock(0, Immutable), - [Lconst(Const_base(Const_string (name,None)))]) - (* Error report *) open Format diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 842ed78dc..70f700fce 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -22,8 +22,6 @@ val transl_apply: lambda -> (label * expression option * optional) list -> Location.t -> lambda val transl_let: rec_flag -> value_binding list -> lambda -> lambda val transl_primitive: Location.t -> Primitive.description -> lambda -val transl_exception: - Path.t option -> constructor_declaration -> lambda val check_recursive_lambda: Ident.t list -> lambda -> bool diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index dac713c5a..9825e5065 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -27,8 +27,27 @@ open Translclass type error = Circular_dependency of Ident.t + exception Error of Location.t * error +(* Compile an exception definition *) + +let prim_set_oo_id = + Pccall {Primitive.prim_name = "caml_set_oo_id"; prim_arity = 1; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false} + +let transl_exception path decl = + let name = + match path with + None -> Ident.name decl.cd_id + | Some p -> Path.name p + in + Lprim(prim_set_oo_id, + [Lprim(Pmakeblock(Obj.object_tag, Immutable), + [Lconst(Const_base(Const_string (name,None))); + Lconst(Const_base(Const_int 0))])]) + (* Compile a coercion *) let rec apply_coercion strict restr arg = |