summaryrefslogtreecommitdiff
path: root/bytecomp
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp')
-rw-r--r--bytecomp/bytegen.ml4
-rw-r--r--bytecomp/dllpath.ml59
-rw-r--r--bytecomp/dllpath.mli25
-rw-r--r--bytecomp/instruct.ml2
-rw-r--r--bytecomp/instruct.mli4
-rw-r--r--bytecomp/lambda.ml116
-rw-r--r--bytecomp/lambda.mli12
-rw-r--r--bytecomp/matching.ml64
-rw-r--r--bytecomp/printinstr.ml8
-rw-r--r--bytecomp/printlambda.ml20
-rw-r--r--bytecomp/simplif.ml2
-rw-r--r--bytecomp/switch.ml3
-rw-r--r--bytecomp/symtable.ml1
-rw-r--r--bytecomp/translclass.ml198
-rw-r--r--bytecomp/translclass.mli1
-rw-r--r--bytecomp/translcore.ml145
-rw-r--r--bytecomp/transljoin.ml4
-rw-r--r--bytecomp/translmod.ml89
18 files changed, 368 insertions, 389 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 01156f4384..65e51dcbcf 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -146,7 +146,7 @@ let rec size_of_lambda = function
let copy_event ev kind info repr =
{ ev_pos = 0; (* patched in emitcode *)
ev_module = ev.ev_module;
- ev_char = ev.ev_char;
+ ev_loc = ev.ev_loc;
ev_kind = kind;
ev_info = info;
ev_typenv = ev.ev_typenv;
@@ -686,7 +686,7 @@ let rec comp_expr env exp sz cont =
let event kind info =
{ ev_pos = 0; (* patched in emitcode *)
ev_module = !compunit_name;
- ev_char = lev.lev_pos;
+ ev_loc = lev.lev_loc;
ev_kind = kind;
ev_info = info;
ev_typenv = lev.lev_env;
diff --git a/bytecomp/dllpath.ml b/bytecomp/dllpath.ml
deleted file mode 100644
index f0626a871b..0000000000
--- a/bytecomp/dllpath.ml
+++ /dev/null
@@ -1,59 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 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. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Handling of load path for dynamically-linked libraries *)
-
-(* Read the [ld.conf] file and return the corresponding list of directories *)
-
-let ld_conf_contents () =
- let path = ref [] in
- begin try
- let ic = open_in (Filename.concat Config.standard_library "ld.conf") in
- begin try
- while true do
- path := input_line ic :: !path
- done
- with End_of_file -> ()
- end;
- close_in ic
- with Sys_error _ -> ()
- end;
- List.rev !path
-
-(* Split the CAML_LD_LIBRARY_PATH environment variable and return
- the corresponding list of directories. *)
-
-let split str sep =
- let rec split_rec pos =
- if pos >= String.length str then [] else begin
- try
- let newpos = String.index_from str pos sep in
- String.sub str pos (newpos - pos) ::
- split_rec (newpos + 1)
- with Not_found ->
- [String.sub str pos (String.length str - pos)]
- end in
- split_rec 0
-
-let ld_library_path_contents () =
- let path_separator =
- match Sys.os_type with
- "Unix" | "Cygwin" -> ':' | "Win32" -> ';' | _ -> assert false in
- try
- split (Sys.getenv "CAML_LD_LIBRARY_PATH") path_separator
- with Not_found ->
- []
-
-let split_dll_path path =
- split path '\000'
diff --git a/bytecomp/dllpath.mli b/bytecomp/dllpath.mli
deleted file mode 100644
index 496fbf4974..0000000000
--- a/bytecomp/dllpath.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 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. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Handling of load path for dynamically-linked libraries *)
-
-(* Read the [ld.conf] file and return the corresponding list of directories *)
-val ld_conf_contents: unit -> string list
-
-(* Split the CAML_LD_LIBRARY_PATH environment variable and return
- the corresponding list of directories *)
-val ld_library_path_contents: unit -> string list
-
-(* Split the given 0-separated path *)
-val split_dll_path: string -> string list
diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
index fd13db5d7a..9fd2cb9409 100644
--- a/bytecomp/instruct.ml
+++ b/bytecomp/instruct.ml
@@ -22,7 +22,7 @@ type compilation_env =
type debug_event =
{ mutable ev_pos: int; (* Position in bytecode *)
ev_module: string; (* Name of defining module *)
- ev_char: Lexing.position; (* Position in source file *)
+ ev_loc: Location.t; (* Location in source file *)
ev_kind: debug_event_kind; (* Before/after event *)
ev_info: debug_event_info; (* Extra information *)
ev_typenv: Env.summary; (* Typing environment *)
diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
index fdedd8fd47..b7dbd7e3ba 100644
--- a/bytecomp/instruct.mli
+++ b/bytecomp/instruct.mli
@@ -23,7 +23,7 @@ type compilation_env =
ce_heap: int Ident.tbl; (* Structure of the heap-allocated env *)
ce_rec: int Ident.tbl } (* Functions bound by the same let rec *)
-(* The ce_stack component gives locations of variables residing
+(* The ce_stack component gives locations of variables residing
in the stack. The locations are offsets w.r.t. the origin of the
stack frame.
The ce_heap component gives the positions of variables residing in the
@@ -39,7 +39,7 @@ type compilation_env =
type debug_event =
{ mutable ev_pos: int; (* Position in bytecode *)
ev_module: string; (* Name of defining module *)
- ev_char: Lexing.position; (* Position in source file *)
+ ev_loc: Location.t; (* Location in source file *)
ev_kind: debug_event_kind; (* Before/after event *)
ev_info: debug_event_info; (* Extra information *)
ev_typenv: Env.summary; (* Typing environment *)
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index dfc26721e0..3a2fe60c18 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -96,7 +96,7 @@ and bigarray_kind =
| Pbigarray_float32 | Pbigarray_float64
| Pbigarray_sint8 | Pbigarray_uint8
| Pbigarray_sint16 | Pbigarray_uint16
- | Pbigarray_int32 | Pbigarray_int64
+ | Pbigarray_int32 | Pbigarray_int64
| Pbigarray_caml_int | Pbigarray_native_int
| Pbigarray_complex32 | Pbigarray_complex64
@@ -110,6 +110,7 @@ type structured_constant =
| Const_pointer of int
| Const_block of int * structured_constant list
| Const_float_array of string list
+ | Const_immstring of string
type function_kind = Curried | Tupled
@@ -148,7 +149,7 @@ and lambda_switch =
sw_failaction : lambda option}
and lambda_event =
- { lev_pos: Lexing.position;
+ { lev_loc: Location.t;
lev_kind: lambda_event_kind;
lev_repr: int ref option;
lev_env: Env.summary }
@@ -163,10 +164,6 @@ let const_unit = Const_pointer 0
let lambda_unit = Lconst const_unit
-let lambda_int i = Lconst (Const_base (Const_int i))
-
-let lambda_string s = Lconst (Const_base (Const_string s))
-
let rec same l1 l2 =
match (l1, l2) with
| Lvar v1, Lvar v2 ->
@@ -205,7 +202,7 @@ let rec same l1 l2 =
| Lsend(k1, a1, b1, cl1), Lsend(k2, a2, b2, cl2) ->
k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2
| Levent(a1, ev1), Levent(a2, ev2) ->
- same a1 a2 && ev1.lev_pos = ev2.lev_pos
+ same a1 a2 && ev1.lev_loc = ev2.lev_loc
| Lifused(id1, a1), Lifused(id2, a2) ->
Ident.same id1 id2 && same a1 a2
| _, _ ->
@@ -240,63 +237,88 @@ let name_lambda_list args fn =
Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in
name_list [] args
-module IdentSet =
- Set.Make(struct
- type t = Ident.t
- let compare = compare
- end)
-
-let free_variables l =
- let fv = ref IdentSet.empty in
- let rec freevars = function
- Lvar id ->
- fv := IdentSet.add id !fv
- | Lconst sc -> ()
+let rec iter f = function
+ Lvar _
+ | Lconst _ -> ()
| Lapply(fn, args) ->
- freevars fn; List.iter freevars args
+ f fn; List.iter f args
| Lfunction(kind, params, body) ->
- freevars body;
- List.iter (fun param -> fv := IdentSet.remove param !fv) params
+ f body
| Llet(str, id, arg, body) ->
- freevars arg; freevars body; fv := IdentSet.remove id !fv
+ f arg; f body
| Lletrec(decl, body) ->
- freevars body;
- List.iter (fun (id, exp) -> freevars exp) decl;
- List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl
+ f body;
+ List.iter (fun (id, exp) -> f exp) decl
| Lprim(p, args) ->
- List.iter freevars args
+ List.iter f args
| Lswitch(arg, sw) ->
- freevars arg;
- List.iter (fun (key, case) -> freevars case) sw.sw_consts;
- List.iter (fun (key, case) -> freevars case) sw.sw_blocks;
+ f arg;
+ List.iter (fun (key, case) -> f case) sw.sw_consts;
+ List.iter (fun (key, case) -> f case) sw.sw_blocks;
begin match sw.sw_failaction with
| None -> ()
- | Some l -> freevars l
+ | Some l -> f l
end
| Lstaticraise (_,args) ->
- List.iter freevars args
+ List.iter f args
| Lstaticcatch(e1, (_,vars), e2) ->
- freevars e1; freevars e2 ;
- List.iter (fun id -> fv := IdentSet.remove id !fv) vars
+ f e1; f e2
| Ltrywith(e1, exn, e2) ->
- freevars e1; freevars e2; fv := IdentSet.remove exn !fv
+ f e1; f e2
| Lifthenelse(e1, e2, e3) ->
- freevars e1; freevars e2; freevars e3
+ f e1; f e2; f e3
| Lsequence(e1, e2) ->
- freevars e1; freevars e2
+ f e1; f e2
| Lwhile(e1, e2) ->
- freevars e1; freevars e2
- | Lfor(v, e1, e2, dir, e3) ->
- freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv
+ f e1; f e2
+ | Lfor(v, e1, e2, dir, e3) ->
+ f e1; f e2; f e3
| Lassign(id, e) ->
- fv := IdentSet.add id !fv; freevars e
+ f e
| Lsend (k, met, obj, args) ->
- List.iter freevars (met::obj::args)
+ List.iter f (met::obj::args)
| Levent (lam, evt) ->
- freevars lam
+ f lam
| Lifused (v, e) ->
- freevars e
- in freevars l; !fv
+ f e
+
+module IdentSet =
+ Set.Make(struct
+ type t = Ident.t
+ let compare = compare
+ end)
+
+let free_ids get l =
+ let fv = ref IdentSet.empty in
+ let rec free l =
+ iter free l;
+ fv := List.fold_right IdentSet.add (get l) !fv;
+ match l with
+ Lfunction(kind, params, body) ->
+ List.iter (fun param -> fv := IdentSet.remove param !fv) params
+ | Llet(str, id, arg, body) ->
+ fv := IdentSet.remove id !fv
+ | Lletrec(decl, body) ->
+ List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl
+ | Lstaticcatch(e1, (_,vars), e2) ->
+ List.iter (fun id -> fv := IdentSet.remove id !fv) vars
+ | Ltrywith(e1, exn, e2) ->
+ fv := IdentSet.remove exn !fv
+ | Lfor(v, e1, e2, dir, e3) ->
+ fv := IdentSet.remove v !fv
+ | Lassign(id, e) ->
+ fv := IdentSet.add id !fv
+ | Lvar _ | Lconst _ | Lapply _
+ | Lprim _ | Lswitch _ | Lstaticraise _
+ | Lifthenelse _ | Lsequence _ | Lwhile _
+ | Lsend _ | Levent _ | Lifused _ -> ()
+ in free l; !fv
+
+let free_variables l =
+ free_ids (function Lvar id -> [id] | _ -> []) l
+
+let free_methods l =
+ free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
(* Check if an action has a "when" guard *)
let raise_count = ref 0
@@ -365,14 +387,14 @@ let subst_lambda s lam =
match sw.sw_failaction with
| None -> None
| Some l -> Some (subst l)})
-
+
| Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args)
| Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2)
| Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2)
| Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3)
| Lsequence(e1, e2) -> Lsequence(subst e1, subst e2)
| Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
- | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
+ | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
| Lassign(id, e) -> Lassign(id, subst e)
| Lsend (k, met, obj, args) ->
Lsend (k, subst met, subst obj, List.map subst args)
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 6709c87d9f..0aa6412fb0 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -110,6 +110,7 @@ type structured_constant =
| Const_pointer of int
| Const_block of int * structured_constant list
| Const_float_array of string list
+ | Const_immstring of string
type function_kind = Curried | Tupled
@@ -156,7 +157,7 @@ and lambda_switch =
sw_blocks: (int * lambda) list; (* Tag block cases *)
sw_failaction : lambda option} (* Action to take if failure *)
and lambda_event =
- { lev_pos: Lexing.position;
+ { lev_loc: Location.t;
lev_kind: lambda_event_kind;
lev_repr: int ref option;
lev_env: Env.summary }
@@ -169,16 +170,15 @@ and lambda_event_kind =
val same: lambda -> lambda -> bool
val const_unit: structured_constant
val lambda_unit: lambda
-val lambda_int : int -> lambda
-val lambda_string : string -> lambda
-
val name_lambda: lambda -> (Ident.t -> lambda) -> lambda
val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
val is_guarded: lambda -> bool
val patch_guarded : lambda -> lambda -> lambda
+val iter: (lambda -> unit) -> lambda -> unit
module IdentSet: Set.S with type elt = Ident.t
val free_variables: lambda -> IdentSet.t
+val free_methods: lambda -> IdentSet.t
val transl_path: Path.t -> lambda
val make_sequence: ('a -> lambda) -> 'a list -> lambda
@@ -200,8 +200,8 @@ val next_raise_count : unit -> int
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 is_guarded: lambda -> bool
+val patch_guarded : lambda -> lambda -> lambda
(*>JOCAML*)
(* Get a runtime location, ie a tuple (filename, line, pos) *)
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 64d0b9e75f..330e91f867 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -101,8 +101,12 @@ let rshift_num n {left=left ; right=right} =
let ctx_rshift_num n ctx = List.map (rshift_num n) ctx
+(* Recombination of contexts (eg: (_,_)::p1::p2::rem -> (p1,p2)::rem)
+ All mutable fields are replaced by '_', since side-effects in
+ guards can alter these fields *)
+
let combine {left=left ; right=right} = match left with
-| p::ps -> {left=ps ; right=set_args p right}
+| p::ps -> {left=ps ; right=set_args_erase_mutable p right}
| _ -> assert false
let ctx_combine ctx = List.map combine ctx
@@ -376,11 +380,11 @@ let pretty_cases cases =
prerr_string " " ;
prerr_string (Format.flush_str_formatter ()))
ps ;
-
+(*
prerr_string " -> " ;
Printlambda.lambda Format.str_formatter l ;
prerr_string (Format.flush_str_formatter ()) ;
-
+*)
prerr_endline "")
cases
@@ -1075,7 +1079,7 @@ let rec matcher_const cst p rem = match p.pat_desc with
| _ -> raise NoMatch
let get_key_constant caller = function
- | {pat_desc= Tpat_constant cst} as p -> cst
+ | {pat_desc= Tpat_constant cst} -> cst
| p ->
prerr_endline ("BAD: "^caller) ;
pretty_pat p ;
@@ -1241,7 +1245,7 @@ let get_key_variant p = match p.pat_desc with
| Tpat_variant(lab, None , _) -> Cstr_constant (Btype.hash_variant lab)
| _ -> assert false
-let divide_variant row ctx ({cases = cl; args = al; default=def} as pm) =
+let divide_variant row ctx {cases = cl; args = al; default=def} =
let row = Btype.row_repr row in
let rec divide = function
({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem ->
@@ -1486,7 +1490,7 @@ let as_int_list cases acts =
let default = max_vals cases acts in
let min_key,_,_ = cases.(0)
and _,max_key,_ = cases.(Array.length cases-1) in
- let offset = max_key-min_key in
+
let rec do_rec i k =
if i >= 0 then
let low, high, act = cases.(i) in
@@ -1636,7 +1640,7 @@ let as_interval_canfail fail low high l =
let rec init_rec = function
| [] -> []
- | (i,act_i)::rem as all ->
+ | (i,act_i)::rem ->
let index = store.act_store act_i in
if index=0 then
fail_rec low i rem
@@ -1795,6 +1799,7 @@ let mk_failaction_neg partial ctx def = match partial with
end
| Total ->
None, [], jumps_empty
+
(* Conforme a l'article et plus simple qu'avant *)
@@ -1894,7 +1899,6 @@ let combine_constructor arg ex_pat cstr partial ctx def
(tag_lambda_list, total1, pats) =
if cstr.cstr_consts < 0 then begin
(* Special cases for exceptions *)
- let cstrs = List.map fst tag_lambda_list in
let fail, to_add, local_jumps =
mk_failaction_neg partial ctx def in
let tag_lambda_list = to_add@tag_lambda_list in
@@ -1921,8 +1925,7 @@ let combine_constructor arg ex_pat cstr partial ctx def
(* Regular concrete type *)
let ncases = List.length tag_lambda_list
and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in
- let sig_complete = ncases = nconstrs
- and cstrs = List.map fst tag_lambda_list in
+ let sig_complete = ncases = nconstrs in
let fails,local_jumps =
if sig_complete then [],jumps_empty
else
@@ -1998,7 +2001,9 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
let sig_complete = List.length tag_lambda_list = !num_constr
and one_action = same_actions tag_lambda_list in
let fail, to_add, local_jumps =
- if sig_complete || (match partial with Total -> true | _ -> false) then
+ if
+ sig_complete || (match partial with Total -> true | _ -> false)
+ then
None, [], jumps_empty
else
mk_failaction_neg partial ctx def in
@@ -2055,7 +2060,7 @@ let rec event_branch repr lam =
lam
| (Levent(lam', ev), Some r) ->
incr r;
- Levent(lam', {lev_pos = ev.lev_pos;
+ Levent(lam', {lev_loc = ev.lev_loc;
lev_kind = ev.lev_kind;
lev_repr = repr;
lev_env = ev.lev_env})
@@ -2299,7 +2304,6 @@ and do_compile_matching_pr repr partial ctx arg x =
pretty_jumps jumps ;
r
*)
-
and do_compile_matching repr partial ctx arg pmh = match pmh with
| Pm pm ->
let pat = what_is_cases pm.cases in
@@ -2356,8 +2360,23 @@ and compile_no_test divide up_ctx repr partial ctx to_match =
(* The entry points *)
+(*
+ If there is a guard in a matching, then
+ set exhaustiveness info to Partial.
+ (because of side effects in guards, assume the worst)
+*)
+
+let check_partial pat_act_list partial =
+ if
+ List.exists
+ (fun (_,lam) -> is_guarded lam)
+ pat_act_list
+ then begin
+ Partial
+ end else
+ partial
-(* had toplevel handler when appropriate *)
+(* have toplevel handler when appropriate *)
let start_ctx n = [{left=[] ; right = omegas n}]
@@ -2369,6 +2388,7 @@ let check_total total lambda i handler_fun =
end
let compile_matching loc repr handler_fun arg pat_act_list partial =
+ let partial = check_partial pat_act_list partial in
match partial with
| Partial ->
let raise_num = next_raise_count () in
@@ -2380,7 +2400,7 @@ let compile_matching loc repr handler_fun arg pat_act_list partial =
let (lambda, total) = compile_match repr partial (start_ctx 1) pm in
check_total total lambda raise_num handler_fun
with
- | Unused -> assert false ; handler_fun()
+ | Unused -> assert false (* ; handler_fun() *)
end
| Total ->
let pm =
@@ -2391,6 +2411,7 @@ let compile_matching loc repr handler_fun arg pat_act_list partial =
assert (jumps_is_empty total) ;
lambda
+
let partial_function loc () =
(* [Location.get_pos_info] is too expensive *)
let fname = match loc.Location.loc_start.Lexing.pos_fname with
@@ -2426,6 +2447,7 @@ let for_let (handler,loc) param pat body =
(* Easy case since variables are available *)
let for_tupled_function loc paraml pats_act_list partial =
+ let partial = check_partial pats_act_list partial in
let raise_num = next_raise_count () in
let omegas = [List.map (fun _ -> omega) paraml] in
let pm =
@@ -2443,7 +2465,7 @@ let for_tupled_function loc paraml pats_act_list partial =
let flatten_pattern size p = match p.pat_desc with
-| Tpat_tuple args -> args
+| Tpat_tuple args -> args
| Tpat_any -> omegas size
| _ -> raise Cannot_flatten
@@ -2451,6 +2473,9 @@ let rec flatten_pat_line size p k = match p.pat_desc with
| Tpat_any -> omegas size::k
| Tpat_tuple args -> args::k
| Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k)
+| Tpat_alias (p,_) -> (* Note: if this 'as' pat is here, then this is a useless
+ binding, solves PR #3780 *)
+ flatten_pat_line size p k
| _ -> fatal_error "Matching.flatten_pat_line"
let flatten_cases size cases =
@@ -2461,7 +2486,7 @@ let flatten_cases size cases =
cases
let flatten_matrix size pss =
- List.fold_right
+ List.fold_right
(fun ps r -> match ps with
| [p] -> flatten_pat_line size p r
| _ -> fatal_error "Matching.flatten_matrix")
@@ -2503,6 +2528,7 @@ let compile_flattened repr partial ctx _ pmh = match pmh with
let for_multiple_match (handler, loc) paraml pat_act_list partial =
let repr = None in
+ let partial = check_partial pat_act_list partial in
let raise_num,pm1 =
match partial with
| Partial ->
@@ -2544,8 +2570,6 @@ let for_multiple_match (handler, loc) paraml pat_act_list partial =
| Total ->
assert (jumps_is_empty total) ;
lam)
-
-
with Cannot_flatten ->
let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in
begin match partial with
@@ -2557,5 +2581,5 @@ let for_multiple_match (handler, loc) paraml pat_act_list partial =
lambda
end
with Unused ->
- assert false ; partial_function loc ()
+ assert false (* ; partial_function loc () *)
diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
index a7c859d847..2f0508b299 100644
--- a/bytecomp/printinstr.ml
+++ b/bytecomp/printinstr.ml
@@ -99,8 +99,10 @@ let instruction ppf = function
| Kgetpubmet n -> fprintf ppf "\tgetpubmet %i" n
| Kgetdynmet -> fprintf ppf "\tgetdynmet"
| Kstop -> fprintf ppf "\tstop"
- | Kevent ev -> fprintf ppf "\tevent \"%s\" %i" ev.ev_char.Lexing.pos_fname
- ev.ev_char.Lexing.pos_cnum
+ | Kevent ev -> fprintf ppf "\tevent \"%s\" %i-%i"
+ ev.ev_loc.Location.loc_start.Lexing.pos_fname
+ ev.ev_loc.Location.loc_start.Lexing.pos_cnum
+ ev.ev_loc.Location.loc_end.Lexing.pos_cnum
let rec instruction_list ppf = function
[] -> ()
@@ -108,6 +110,6 @@ let rec instruction_list ppf = function
fprintf ppf "L%i:%a" lbl instruction_list il
| instr :: il ->
fprintf ppf "%a@ %a" instruction instr instruction_list il
-
+
let instrlist ppf il =
fprintf ppf "@[<v 0>%a@]" instruction_list il
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index fb129ffb75..27c0ff3d55 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -23,6 +23,7 @@ let rec struct_const ppf = function
| Const_base(Const_int n) -> fprintf ppf "%i" n
| Const_base(Const_char c) -> fprintf ppf "%C" c
| Const_base(Const_string s) -> fprintf ppf "%S" s
+ | Const_immstring s -> fprintf ppf "#%S" s
| Const_base(Const_float f) -> fprintf ppf "%s" f
| Const_base(Const_int32 n) -> fprintf ppf "%lil" n
| Const_base(Const_int64 n) -> fprintf ppf "%LiL" n
@@ -172,12 +173,6 @@ let primitive ppf = function
| Pbigarrayref(n, kind, layout) -> print_bigarray "get" kind ppf layout
| Pbigarrayset(n, kind, layout) -> print_bigarray "set" kind ppf layout
-let pstr = function
- | Strict -> "S"
- | StrictOpt -> "SO"
- | Alias -> "A"
- | Variable -> "V"
-
let rec lam ppf = function
| Lvar id ->
Ident.print ppf id
@@ -205,12 +200,10 @@ let rec lam ppf = function
| Llet(str, id, arg, body) ->
let rec letbody = function
| Llet(str, id, arg, body) ->
- fprintf ppf "@ @[<2>%a(%s)@ %a@]"
- Ident.print id (pstr str) lam arg;
+ fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
letbody body
| expr -> expr in
- fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a(%s)@ %a@]"
- Ident.print id (pstr str) lam arg;
+ fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg;
let expr = letbody body in
fprintf ppf ")@]@ %a)@]" lam expr
| Lletrec(id_arg_list, body) ->
@@ -289,12 +282,15 @@ let rec lam ppf = function
if k = Self then "self" else if k = Cached then "cache" else "" in
fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
| Levent(expr, ev) ->
- let kind =
+ let kind =
match ev.lev_kind with
| Lev_before -> "before"
| Lev_after _ -> "after"
| Lev_function -> "funct-body" in
- fprintf ppf "@[<2>(%s %i@ %a)@]" kind ev.lev_pos.Lexing.pos_cnum lam expr
+ fprintf ppf "@[<2>(%s %i-%i@ %a)@]" kind
+ ev.lev_loc.Location.loc_start.Lexing.pos_cnum
+ ev.lev_loc.Location.loc_end.Lexing.pos_cnum
+ lam expr
| Lifused(id, expr) ->
fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index 126aa7772a..ee59cab742 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -370,7 +370,7 @@ let simplify_lets lam =
| Llet(StrictOpt, v, l1, l2) ->
begin match count_var v with
0 -> simplif l2
- | n -> Llet(StrictOpt, v, simplif l1, simplif l2)
+ | n -> Llet(Alias, v, simplif l1, simplif l2)
end
| Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
| Lletrec(bindings, body) ->
diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml
index 38db1d5502..ff58af72e6 100644
--- a/bytecomp/switch.ml
+++ b/bytecomp/switch.ml
@@ -653,7 +653,7 @@ let approx_count cases i j n_actions =
(* Sends back a boolean that says whether is switch is worth or not *)
-let dense ({cases=cases ; actions=actions} as s) i j =
+let dense {cases=cases ; actions=actions} i j =
if i=j then true
else
let l,_,_ = cases.(i)
@@ -775,7 +775,6 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k =
let zyva (low,high) konst arg cases actions =
- let lcases = Array.length cases in
let old_ok = !ok_inter in
ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
if !ok_inter <> old_ok then Hashtbl.clear t ;
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index 4d22e092ab..6a55cabf28 100644
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -212,6 +212,7 @@ let rec transl_const = function
| Const_base(Const_int64 i) -> Obj.repr i
| Const_base(Const_nativeint i) -> Obj.repr i
| Const_pointer i -> Obj.repr i
+ | Const_immstring s -> Obj.repr s
| Const_block(tag, fields) ->
let block = Obj.new_block tag (List.length fields) in
let pos = ref 0 in
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index e635134cfd..b0eeeacfc2 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -46,12 +46,12 @@ let lsequence l1 l2 =
let lfield v i = Lprim(Pfield i, [Lvar v])
-let transl_label l = share (Const_base (Const_string l))
+let transl_label l = share (Const_immstring l)
let rec transl_meth_list lst =
if lst = [] then Lconst (Const_pointer 0) else
share (Const_block
- (0, List.map (fun lab -> Const_base (Const_string lab)) lst))
+ (0, List.map (fun lab -> Const_immstring lab) lst))
let set_inst_var obj id expr =
let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
@@ -71,35 +71,26 @@ let transl_val tbl create name =
Lapply (oo_prim (if create then "new_variable" else "get_variable"),
[Lvar tbl; transl_label name])
-let transl_vals tbl create sure vals rem =
- if create && sure && List.length vals > 1 then
- let (_,id0) = List.hd vals in
- let call =
- Lapply(oo_prim "new_variables",
- [Lvar tbl; transl_meth_list (List.map fst vals)]) in
- let i = ref (List.length vals) in
- Llet(Strict, id0, call,
- List.fold_right
- (fun (name,id) rem ->
- decr i; Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
- (List.tl vals) rem)
- else
+let transl_vals tbl create vals rem =
List.fold_right
(fun (name, id) rem ->
Llet(StrictOpt, id, transl_val tbl create name, rem))
vals rem
-let transl_super tbl meths inh_methods rem =
+let meths_super tbl meths inh_meths =
List.fold_right
(fun (nm, id) rem ->
- begin try
- Llet(StrictOpt, id, Lapply (oo_prim "get_method",
- [Lvar tbl; Lvar (Meths.find nm meths)]),
- rem)
- with Not_found ->
- rem
- end)
- inh_methods rem
+ try
+ (nm, id,
+ Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
+ :: rem
+ with Not_found -> rem)
+ inh_meths []
+
+let bind_super tbl (vals, meths) cl_init =
+ transl_vals tbl false vals
+ (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem))
+ meths cl_init)
let create_object cl obj init =
let obj' = Ident.create "self" in
@@ -217,32 +208,43 @@ let bind_method tbl lab id cl_init =
[Lvar tbl; transl_label lab]),
cl_init)
-let bind_methods tbl meths cl_init =
+let bind_methods tbl meths vals cl_init =
let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
- let len = List.length methl in
- if len < 2 then Meths.fold (bind_method tbl) meths cl_init else
+ let len = List.length methl and nvals = List.length vals in
+ if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
+ if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
let ids = Ident.create "ids" in
let i = ref len in
+ let getter, names, cl_init =
+ match vals with [] -> "get_method_labels", [], cl_init
+ | (_,id0)::vals' ->
+ incr i;
+ let i = ref (List.length vals) in
+ "new_methods_variables",
+ [transl_meth_list (List.map fst vals)],
+ Llet(Strict, id0, lfield ids 0,
+ List.fold_right
+ (fun (name,id) rem ->
+ decr i;
+ Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
+ vals' cl_init)
+ in
Llet(StrictOpt, ids,
- Lapply (oo_prim "get_method_labels",
- [Lvar tbl; transl_meth_list (List.map fst methl)]),
+ Lapply (oo_prim getter,
+ [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
List.fold_right
- (fun (lab,id) lam ->
- decr i; Llet(StrictOpt, id, Lprim(Pfield !i, [Lvar ids]), lam))
+ (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
methl cl_init)
-let output_methods tbl vals methods lam =
- let lam =
- match methods with
- [] -> lam
- | [lab; code] ->
- lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
- | _ ->
- lsequence (Lapply(oo_prim "set_methods",
- [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
- lam
- in
- transl_vals tbl true true vals lam
+let output_methods tbl methods lam =
+ match methods with
+ [] -> lam
+ | [lab; code] ->
+ lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
+ | _ ->
+ lsequence (Lapply(oo_prim "set_methods",
+ [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
+ lam
let rec ignore_cstrs cl =
match cl.cl_desc with
@@ -250,7 +252,12 @@ let rec ignore_cstrs cl =
| Tclass_apply (cl, _) -> ignore_cstrs cl
| _ -> cl
-let rec build_class_init cla cstr inh_init cl_init msubst top cl =
+let rec index a = function
+ [] -> raise Not_found
+ | b :: l ->
+ if b = a then 0 else 1 + index a l
+
+let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
match cl.cl_desc with
Tclass_ident path ->
begin match inh_init with
@@ -260,23 +267,23 @@ let rec build_class_init cla cstr inh_init cl_init msubst top cl =
Llet (Strict, obj_init,
Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
if top then [Lprim(Pfield 3, [lpath])] else []),
- cl_init))
+ bind_super cla super cl_init))
| _ ->
assert false
end
| Tclass_structure str ->
+ let cl_init = bind_super cla super cl_init in
let (inh_init, cl_init, methods, values) =
List.fold_right
(fun field (inh_init, cl_init, methods, values) ->
match field with
Cf_inher (cl, vals, meths) ->
- let cl_init = output_methods cla values methods cl_init in
+ let cl_init = output_methods cla methods cl_init in
let inh_init, cl_init =
- build_class_init cla false inh_init
- (transl_vals cla false false vals
- (transl_super cla str.cl_meths meths cl_init))
- msubst top cl in
- (inh_init, cl_init, [], [])
+ build_class_init cla false
+ (vals, meths_super cla str.cl_meths meths)
+ inh_init cl_init msubst top cl in
+ (inh_init, cl_init, [], values)
| Cf_val (name, id, exp) ->
(inh_init, cl_init, methods, (name, id)::values)
| Cf_meth (name, exp) ->
@@ -291,13 +298,6 @@ let rec build_class_init cla cstr inh_init cl_init msubst top cl =
(inh_init, cl_init,
Lvar (Meths.find name str.cl_meths) :: met_code @ methods,
values)
- (*
- Lsequence(Lapply (oo_prim ("set_method" ^ builtin),
- Lvar cla ::
- Lvar (Meths.find name str.cl_meths) ::
- met_code),
- cl_init))
- *)
| Cf_let (rec_flag, defs, vals) ->
let vals =
List.map (function (id, _) -> (Ident.name id, id)) vals
@@ -312,43 +312,61 @@ let rec build_class_init cla cstr inh_init cl_init msubst top cl =
str.cl_field
(inh_init, cl_init, [], [])
in
- let cl_init = output_methods cla values methods cl_init in
- (inh_init, bind_methods cla str.cl_meths cl_init)
+ let cl_init = output_methods cla methods cl_init in
+ (inh_init, bind_methods cla str.cl_meths values cl_init)
| Tclass_fun (pat, vals, cl, _) ->
let (inh_init, cl_init) =
- build_class_init cla cstr inh_init cl_init msubst top cl
+ build_class_init cla cstr super inh_init cl_init msubst top cl
in
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
- (inh_init, transl_vals cla true false vals cl_init)
+ (inh_init, transl_vals cla true vals cl_init)
| Tclass_apply (cl, exprs) ->
- build_class_init cla cstr inh_init cl_init msubst top cl
+ build_class_init cla cstr super inh_init cl_init msubst top cl
| Tclass_let (rec_flag, defs, vals, cl) ->
let (inh_init, cl_init) =
- build_class_init cla cstr inh_init cl_init msubst top cl
+ build_class_init cla cstr super inh_init cl_init msubst top cl
in
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
- (inh_init, transl_vals cla true false vals cl_init)
+ (inh_init, transl_vals cla true vals cl_init)
| Tclass_constraint (cl, vals, meths, concr_meths) ->
let virt_meths =
List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
+ let concr_meths = Concr.elements concr_meths in
let narrow_args =
[Lvar cla;
transl_meth_list vals;
transl_meth_list virt_meths;
- transl_meth_list (Concr.elements concr_meths)] in
+ transl_meth_list concr_meths] in
let cl = ignore_cstrs cl in
begin match cl.cl_desc, inh_init with
Tclass_ident path, (obj_init, path')::inh_init ->
assert (Path.same path path');
let lpath = transl_path path in
+ let inh = Ident.create "inh"
+ and inh_vals = Ident.create "vals"
+ and inh_meths = Ident.create "meths"
+ and valids, methids = super in
+ let cl_init =
+ List.fold_left
+ (fun init (nm, id, _) ->
+ Llet(StrictOpt, id, lfield inh_meths (index nm concr_meths),
+ init))
+ cl_init methids in
+ let cl_init =
+ List.fold_left
+ (fun init (nm, id) ->
+ Llet(StrictOpt, id, lfield inh_vals (index nm vals), init))
+ cl_init valids in
(inh_init,
- Llet (Strict, obj_init,
+ Llet (Strict, inh,
Lapply(oo_prim "inherits", narrow_args @
[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
- cl_init))
+ Llet(StrictOpt, obj_init, lfield inh 0,
+ Llet(Alias, inh_vals, lfield inh 1,
+ Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
| _ ->
let core cl_init =
- build_class_init cla true inh_init cl_init msubst top cl
+ build_class_init cla true super inh_init cl_init msubst top cl
in
if cstr then core cl_init else
let (inh_init, cl_init) =
@@ -366,6 +384,16 @@ let rec build_class_lets cl =
| _ ->
(cl.cl_env, fun x -> x)
+let rec get_class_meths cl =
+ match cl.cl_desc with
+ Tclass_structure cl ->
+ Meths.fold (fun _ -> IdentSet.add) cl.cl_meths IdentSet.empty
+ | Tclass_ident _ -> IdentSet.empty
+ | Tclass_fun (_, _, cl, _)
+ | Tclass_let (_, _, _, cl)
+ | Tclass_apply (cl, _)
+ | Tclass_constraint (cl, _, _, _) -> get_class_meths cl
+
(*
XXX Il devrait etre peu couteux d'ecrire des classes :
class c x y = d e f
@@ -426,7 +454,6 @@ let transl_class_rebind ids cl =
let cla = Ident.create "class"
and new_init = Ident.create "new_init"
- and arg = Ident.create "arg"
and env_init = Ident.create "env_init"
and table = Ident.create "table"
and envs = Ident.create "envs" in
@@ -478,8 +505,8 @@ let rec builtin_meths self env env2 body =
| _ -> raise Not_found
in
match body with
- | Llet(Alias, s', Lvar s, body) when List.mem s self ->
- builtin_meths self env env2 body
+ | Llet(_, s', Lvar s, body) when List.mem s self ->
+ builtin_meths (s'::self) env env2 body
| Lapply(f, [arg]) when const_path f ->
let s, args = conv arg in ("app_"^s, f :: args)
| Lapply(f, [arg; p]) when const_path f && const_path p ->
@@ -504,7 +531,7 @@ let rec builtin_meths self env env2 body =
| Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
when Ident.same x x' && List.mem s self ->
("set_var", [Lvar n])
- | Llet(Alias, s', Lvar s, body) when List.mem s self ->
+ | Llet(_, s', Lvar s, body) when List.mem s self ->
enter (s'::self) body
| _ -> raise Not_found
in enter self body
@@ -579,11 +606,18 @@ let transl_class ids cl_id arity pub_meths cl =
let cl_env, llets = build_class_lets cl in
let new_ids = if top then [] else Env.diff top_env cl_env in
let env2 = Ident.create "env" in
+ let meth_ids = get_class_meths cl in
let subst env lam i0 new_ids' =
let fv = free_variables lam in
let fv = List.fold_right IdentSet.remove !new_ids' fv in
- let fv =
- IdentSet.filter (fun id -> List.mem id new_ids) fv in
+ (* IdentSet.iter
+ (fun id ->
+ if not (List.mem id new_ids) then prerr_endline (Ident.name id))
+ fv; *)
+ let fv = IdentSet.filter (fun id -> List.mem id new_ids) fv in
+ (* need to handle methods specially (PR#3576) *)
+ let fm = IdentSet.diff (free_methods lam) meth_ids in
+ let fv = IdentSet.union fv fm in
new_ids' := !new_ids' @ IdentSet.elements fv;
let i = ref (i0-1) in
List.fold_left
@@ -633,8 +667,9 @@ let transl_class ids cl_id arity pub_meths cl =
build_object_init_0 cla [] cl copy_env subst_env top ids in
if not (Translcore.check_recursive_lambda ids obj_init) then
raise(Error(cl.cl_loc, Illegal_class_expr));
+ let inh_init' = List.rev inh_init in
let (inh_init', cl_init) =
- build_class_init cla true (List.rev inh_init) obj_init msubst top cl
+ build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
in
assert (inh_init' = []);
let table = Ident.create "table"
@@ -691,8 +726,8 @@ let transl_class ids cl_id arity pub_meths cl =
if top then llets (lbody_virt lambda_unit) else
(* Now for the hard stuff: prepare for table cacheing *)
- let env_index = Ident.create "env_index"
- and envs = Ident.create "envs" in
+ let envs = Ident.create "envs"
+ and cached = Ident.create "cached" in
let lenvs =
if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
then lambda_unit
@@ -719,8 +754,6 @@ let transl_class ids cl_id arity pub_meths cl =
Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
lam)
in
- let obj_init2 = Ident.create "obj_init"
- and cached = Ident.create "cached" in
let inh_paths =
List.filter
(fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
@@ -767,11 +800,6 @@ let transl_class ids cl_id arity pub_meths cl =
else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
)))))
-(* Dummy for recursive modules *)
-
-let dummy_class undef_fn =
- Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; undef_fn; lambda_unit])
-
(* Wrapper for class compilation *)
let transl_class ids cl_id arity pub_meths cl =
diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli
index 85d5f74bcd..8b74d29811 100644
--- a/bytecomp/translclass.mli
+++ b/bytecomp/translclass.mli
@@ -15,7 +15,6 @@
open Typedtree
open Lambda
-val dummy_class : lambda -> lambda
val transl_class :
Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index ccd5d202e4..21e4f887ea 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -53,7 +53,8 @@ let comparisons_table = create_hashtable 11 [
prim_native_name = ""; prim_native_float = false},
Pbintcomp(Pnativeint, Ceq),
Pbintcomp(Pint32, Ceq),
- Pbintcomp(Pint64, Ceq));
+ Pbintcomp(Pint64, Ceq),
+ true);
"%notequal",
(Pccall{prim_name = "caml_notequal"; prim_arity = 2; prim_alloc = true;
prim_native_name = ""; prim_native_float = false},
@@ -64,7 +65,8 @@ let comparisons_table = create_hashtable 11 [
prim_native_float = false},
Pbintcomp(Pnativeint, Cneq),
Pbintcomp(Pint32, Cneq),
- Pbintcomp(Pint64, Cneq));
+ Pbintcomp(Pint64, Cneq),
+ true);
"%lessthan",
(Pccall{prim_name = "caml_lessthan"; prim_arity = 2; prim_alloc = true;
prim_native_name = ""; prim_native_float = false},
@@ -75,7 +77,8 @@ let comparisons_table = create_hashtable 11 [
prim_native_float = false},
Pbintcomp(Pnativeint, Clt),
Pbintcomp(Pint32, Clt),
- Pbintcomp(Pint64, Clt));
+ Pbintcomp(Pint64, Clt),
+ false);
"%greaterthan",
(Pccall{prim_name = "caml_greaterthan"; prim_arity = 2; prim_alloc = true;
prim_native_name = ""; prim_native_float = false},
@@ -86,7 +89,8 @@ let comparisons_table = create_hashtable 11 [
prim_native_float = false},
Pbintcomp(Pnativeint, Cgt),
Pbintcomp(Pint32, Cgt),
- Pbintcomp(Pint64, Cgt));
+ Pbintcomp(Pint64, Cgt),
+ false);
"%lessequal",
(Pccall{prim_name = "caml_lessequal"; prim_arity = 2; prim_alloc = true;
prim_native_name = ""; prim_native_float = false},
@@ -97,7 +101,8 @@ let comparisons_table = create_hashtable 11 [
prim_native_float = false},
Pbintcomp(Pnativeint, Cle),
Pbintcomp(Pint32, Cle),
- Pbintcomp(Pint64, Cle));
+ Pbintcomp(Pint64, Cle),
+ false);
"%greaterequal",
(Pccall{prim_name = "caml_greaterequal"; prim_arity = 2;
prim_alloc = true;
@@ -109,7 +114,8 @@ let comparisons_table = create_hashtable 11 [
prim_native_float = false},
Pbintcomp(Pnativeint, Cge),
Pbintcomp(Pint32, Cge),
- Pbintcomp(Pint64, Cge));
+ Pbintcomp(Pint64, Cge),
+ false);
"%compare",
(Pccall{prim_name = "caml_compare"; prim_arity = 2; prim_alloc = true;
prim_native_name = ""; prim_native_float = false},
@@ -130,7 +136,8 @@ let comparisons_table = create_hashtable 11 [
prim_native_float = false},
Pccall{prim_name = "caml_int64_compare"; prim_arity = 2;
prim_alloc = false; prim_native_name = "";
- prim_native_float = false})
+ prim_native_float = false},
+ false)
]
let primitives_table = create_hashtable 57 [
@@ -262,12 +269,15 @@ let prim_obj_dup =
let transl_prim prim args =
try
let (gencomp, intcomp, floatcomp, stringcomp,
- nativeintcomp, int32comp, int64comp) =
+ nativeintcomp, int32comp, int64comp,
+ simplify_constant_constructor) =
Hashtbl.find comparisons_table prim.prim_name in
begin match args with
- [arg1; {exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}] ->
+ [arg1; {exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}]
+ when simplify_constant_constructor ->
intcomp
- | [{exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}; arg2] ->
+ | [{exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}; arg2]
+ when simplify_constant_constructor ->
intcomp
| [arg1; arg2] when has_base_type arg1 Predef.path_int
|| has_base_type arg1 Predef.path_char ->
@@ -325,7 +335,7 @@ let make_sequence lam1 lam2 =
let simple_prim p =
let prim =
try
- let (gencomp, _, _, _, _, _, _) =
+ let (gencomp, _, _, _, _, _, _, _) =
Hashtbl.find comparisons_table p.prim_name in
gencomp
with Not_found ->
@@ -344,7 +354,7 @@ let () = Transljoin.simple_prim := simple_prim
let transl_primitive p =
let prim =
try
- let (gencomp, _, _, _, _, _, _) =
+ let (gencomp, _, _, _, _, _, _, _) =
Hashtbl.find comparisons_table p.prim_name in
gencomp
with Not_found ->
@@ -456,8 +466,8 @@ let rec push_defaults loc bindings pat_expr_list partial =
[pat, ({exp_desc = Texp_function(pl,partial)} as exp)] ->
let pl = push_defaults exp.exp_loc bindings pl partial in
[pat, {exp with exp_desc = Texp_function(pl, partial)}]
- | [pat, ({exp_desc = Texp_let
- (Default, cases, ({exp_desc = Texp_function _} as e2))} as e1)] ->
+ | [pat, {exp_desc = Texp_let
+ (Default, cases, ({exp_desc = Texp_function _} as e2))}] ->
push_defaults loc (cases :: bindings) [pat, e2] partial
| [pat, exp] ->
let exp =
@@ -488,7 +498,7 @@ let event_before exp lam = match lam with
| Lstaticraise (_,_) -> lam
| _ ->
if !Clflags.debug
- then Levent(lam, {lev_pos = exp.exp_loc.Location.loc_start;
+ then Levent(lam, {lev_loc = exp.exp_loc;
lev_kind = Lev_before;
lev_repr = None;
lev_env = Env.summary exp.exp_env})
@@ -496,20 +506,18 @@ let event_before exp lam = match lam with
let event_after exp lam =
if !Clflags.debug
- then Levent(lam, {lev_pos = exp.exp_loc.Location.loc_end;
+ then Levent(lam, {lev_loc = exp.exp_loc;
lev_kind = Lev_after exp.exp_type;
lev_repr = None;
lev_env = Env.summary exp.exp_env})
else lam
-let no_event exp lam = lam
-
let event_function exp lam =
if !Clflags.debug then
let repr = Some (ref 0) in
let (info, body) = lam repr in
(info,
- Levent(body, {lev_pos = exp.exp_loc.Location.loc_start;
+ Levent(body, {lev_loc = exp.exp_loc;
lev_kind = Lev_function;
lev_repr = repr;
lev_env = Env.summary exp.exp_env}))
@@ -528,13 +536,6 @@ let primitive_is_ccall = function
let assert_failed loc =
(* [Location.get_pos_info] is too expensive *)
- let fname = match loc.Location.loc_start.Lexing.pos_fname with
- | "" -> !Location.input_name
- | x -> x
- in
- let pos = loc.Location.loc_start in
- let line = pos.Lexing.pos_lnum in
- let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
[transl_path Predef.path_assert_failure;
transl_location loc])])
@@ -545,6 +546,11 @@ let assert_failed loc =
let id_lam lam = lam
;;
+let rec cut n l =
+ if n = 0 then ([],l) else
+ match l with [] -> failwith "Translcore.cut"
+ | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2)
+
(* Translation of expressions *)
let rec transl_exp e =
@@ -588,7 +594,6 @@ and transl_exp0 e =
| Texp_def (d,body) ->
do_transl_def d (transl_exp body)
| Texp_loc (d,body) -> assert false
-(*< JOCAML *)
| Texp_function (pat_expr_list, partial) ->
let ((kind, params), body) =
event_function e
@@ -611,8 +616,13 @@ and transl_exp0 e =
Transljoin.local_send_sync auto idx (transl_exp arg)
(*<JOCAML*)
| Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, args)
- when List.length args = p.prim_arity
+ when List.length args >= p.prim_arity
&& List.for_all (fun (arg,_) -> arg <> None) args ->
+ let args, args' = cut p.prim_arity args in
+ let wrap f =
+ event_after e (if args' = [] then f else transl_apply f args') in
+ let wrap0 f =
+ if args' = [] then f else wrap f in
let args = List.map (function Some x, _ -> x | _ -> assert false) args in
let argl = transl_list transl_exp args in
let public_send = p.prim_name = "%send"
@@ -620,39 +630,38 @@ and transl_exp0 e =
if public_send || p.prim_name = "%sendself" then
let kind = if public_send then Public else Self in
let obj = List.hd argl in
- event_after e (Lsend (kind, List.nth argl 1, obj, []))
+ wrap (Lsend (kind, List.nth argl 1, obj, []))
else if p.prim_name = "%sendcache" then
match argl with [obj; meth; cache; pos] ->
- event_after e (Lsend(Cached, meth, obj, [cache; pos]))
+ wrap (Lsend(Cached, meth, obj, [cache; pos]))
| _ -> assert false
else begin
let prim = transl_prim p args in
match (prim, args) with
(Praise, [arg1]) ->
- Lprim(Praise, [event_after arg1 (List.hd argl)])
+ wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)]))
| (_, _) ->
- if primitive_is_ccall prim
- then event_after e (Lprim(prim, argl))
- else Lprim(prim, argl)
+ let p = Lprim(prim, argl) in
+ if primitive_is_ccall prim then wrap p else wrap0 p
end
| Texp_apply(funct, oargs) ->
event_after e (transl_apply (transl_exp funct) oargs)
- | Texp_match({exp_desc = Texp_tuple argl} as arg, pat_expr_list, partial) ->
+ | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
Matching.for_multiple_match (id_lam,e.exp_loc)
(transl_list transl_exp argl)
- (transl_cases event_before transl_exp pat_expr_list) partial
+ (transl_cases transl_exp pat_expr_list) partial
| Texp_match(arg, pat_expr_list, partial) ->
Matching.for_function
(id_lam,e.exp_loc) None
(transl_exp arg)
- (transl_cases event_before transl_exp pat_expr_list) partial
+ (transl_cases transl_exp pat_expr_list) partial
| 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 event_before transl_exp pat_expr_list))
+ (transl_cases transl_exp pat_expr_list))
| Texp_tuple el ->
let ll = transl_list transl_exp el in
begin try
@@ -731,11 +740,7 @@ and transl_exp0 e =
event_before ifso (transl_exp ifso),
lambda_unit)
| Texp_sequence(expr1, expr2) ->
- let lam1 = transl_exp expr1 in
- if lam1 = lambda_unit then
- transl_exp expr2
- else
- Lsequence(lam1, event_before expr2 (transl_exp expr2))
+ Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2))
| Texp_while(cond, body) ->
Lwhile(transl_exp cond, event_before body (transl_exp body))
| Texp_for(param, low, high, dir, body) ->
@@ -779,15 +784,15 @@ and transl_exp0 e =
else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc)
| Texp_assertfalse -> assert_failed e.exp_loc
| Texp_lazy e ->
- let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
- Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
+ let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
+ Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
| Texp_object (cs, cty, meths) ->
let cl = Ident.create "class" in
!transl_object cl meths
- { cl_desc = Tclass_structure cs;
- cl_loc = e.exp_loc;
- cl_type = Tcty_signature cty;
- cl_env = e.exp_env }
+ { cl_desc = Tclass_structure cs;
+ cl_loc = e.exp_loc;
+ cl_type = Tcty_signature cty;
+ cl_env = e.exp_env }
(*> JOCAML *)
| Texp_spawn (e) -> transl_spawn e
(*< JOCAML *)
@@ -832,17 +837,17 @@ and transl_proc die sync p = match p.exp_desc with
Lifthenelse
(Transljoin.reply_handler sync p transl_exp cond,
transl_proc die sync body, staticfail)
-| Texp_match({exp_desc = Texp_tuple argl} as arg, pat_expr_list, partial) ->
+| Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
Matching.for_multiple_match
(Transljoin.lambda_reply_handler sync p, p.exp_loc)
(transl_list (Transljoin.reply_handler sync p transl_exp) argl)
- (transl_cases no_event (transl_proc die sync) pat_expr_list) partial
+ (transl_cases (transl_proc die sync) pat_expr_list) partial
| Texp_match(arg, pat_expr_list, partial) ->
Matching.for_function
(Transljoin.lambda_reply_handler sync p, p.exp_loc)
None
(Transljoin.reply_handler sync p transl_exp arg)
- (transl_cases no_event (transl_proc die sync) pat_expr_list) partial
+ (transl_cases (transl_proc die sync) pat_expr_list) partial
| Texp_for(param, low, high, dir, body) ->
assert (sync = None) ;
let lam_low = transl_exp low
@@ -913,15 +918,14 @@ and transl_simple_proc die sync p = match p.exp_desc with
| Texp_when(cond, body) ->
(Lifthenelse
(transl_exp cond, transl_simple_proc die sync body, staticfail))
-| Texp_match({exp_desc = Texp_tuple argl} as arg, pat_expr_list, partial) ->
+| Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
Matching.for_multiple_match (id_lam, p.exp_loc)
(transl_list transl_exp argl)
- (transl_cases no_event
- (transl_simple_proc die sync) pat_expr_list) partial
+ (transl_cases (transl_simple_proc die sync) pat_expr_list) partial
| Texp_match(arg, pat_expr_list, partial) ->
Matching.for_function (id_lam, p.exp_loc) None
(transl_exp arg)
- (transl_cases no_event
+ (transl_cases
(transl_simple_proc die sync) pat_expr_list) partial
| Texp_for(param, low, high, dir, body) ->
assert (sync=None) ;
@@ -969,11 +973,6 @@ and transl_simple_proc die sync p = match p.exp_desc with
and transl_reaction (name,_) (Reac reac) =
let (x, _ , actuals, idpats, p) = reac in
-(*
- let dump_oid fp = function
- | Some id -> Printf.fprintf fp "+%s" (Ident.unique_name id)
- | None -> Printf.fprintf fp "-" in
-*)
(* Principal continuation, as computed by typing *)
let sync = Transljoin.principal p in
(* Important: argument order comes from actual pattern order,
@@ -984,12 +983,6 @@ and transl_reaction (name,_) (Reac reac) =
| p::_ -> p | [] -> assert false)
actuals in
let konts = List.map (fun jp -> !(jp.jpat_kont)) jpats in
-(*
-
- Printf.eprintf "Principal: %a\n" dump_oid sync ;
- List.iter (fun k -> dump_oid stderr k) konts ;
- prerr_endline "" ;
-*)
let body =
List.fold_right
(fun (param, pat) lam ->
@@ -1043,7 +1036,10 @@ and transl_dispatcher disp =
| [] -> assert false
| (auto,_)::_ ->
let cls =
- List.map (fun (_,(p,i)) -> p,lambda_int i) allchans in
+ List.map
+ (fun (_,(p,i)) ->
+ p,Lconst (Const_base (Const_int i)))
+ allchans in
(if chan.jchannel_sync then
Transljoin.local_send_sync2
else
@@ -1100,13 +1096,15 @@ and transl_as_seq die es k = match es with
make_sequence
(transl_simple_proc false None e)
(transl_as_seq die rem k)
-(*< JOCAML *)
-and transl_list comp_fun expr_list = List.map comp_fun expr_list
-and transl_cases event_before transl_exp pat_expr_list =
+and transl_list transl_exp expr_list =
+ List.map transl_exp expr_list
+
+and transl_cases transl_exp pat_expr_list =
List.map
(fun (pat, expr) -> (pat, event_before expr (transl_exp expr)))
pat_expr_list
+(*< JOCAML *)
and transl_tupled_cases patl_expr_list =
List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list
@@ -1185,13 +1183,13 @@ and transl_function loc untuplify_fn repr partial pat_expr_list =
let param = name_pattern "param" pat_expr_list in
((Curried, [param]),
Matching.for_function (id_lam,loc) repr (Lvar param)
- (transl_cases event_before transl_exp pat_expr_list) partial)
+ (transl_cases transl_exp pat_expr_list) partial)
end
| _ ->
let param = name_pattern "param" pat_expr_list in
((Curried, [param]),
Matching.for_function (id_lam,loc) repr (Lvar param)
- (transl_cases event_before transl_exp pat_expr_list) partial)
+ (transl_cases transl_exp pat_expr_list) partial)
and transl_let reply_handler transl_exp rec_flag pat_expr_list body =
match rec_flag with
@@ -1275,7 +1273,6 @@ and do_transl_def autos body =
List.fold_right Transljoin.create_auto autos r in
r
-(*< JOCAML *)
and transl_setinstvar self var expr =
Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
diff --git a/bytecomp/transljoin.ml b/bytecomp/transljoin.ml
index 23ca1ae455..806db53c43 100644
--- a/bytecomp/transljoin.ml
+++ b/bytecomp/transljoin.ml
@@ -99,6 +99,9 @@ let mk_apply f args = match Lazy.force f with
| path,_ -> Lapply (transl_path path, args)
+let lambda_int i = Lconst (Const_base (Const_int i))
+and lambda_string s = Lconst (Const_immstring s)
+
let init_unit_queue auto idx =
mk_apply lambda_init_unit_queue [Lvar auto ; lambda_int idx]
@@ -717,7 +720,6 @@ let create_table auto gs r =
(fun bd jpat r -> match bd with
| None,lam -> lam::r
| Some y,_ ->
- let k = jpat.jpat_kont in
if !(jpat.jpat_kont) = sync then
Lprim (Pfield 1, [Lvar y])::r
else
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 1a3113d39c..bc74712f8c 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -17,6 +17,7 @@
open Misc
open Asttypes
+open Longident
open Path
open Types
open Typedtree
@@ -95,7 +96,15 @@ let field_path path field =
(* Utilities for compiling "module rec" definitions *)
-let undefined_exception loc =
+let mod_prim name =
+ try
+ transl_path
+ (fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name))
+ Env.empty))
+ with Not_found ->
+ fatal_error ("Primitive " ^ name ^ " not found.")
+
+let undefined_location loc =
(* Confer Translcore.assert_failed *)
let fname = match loc.Location.loc_start.Lexing.pos_fname with
| "" -> !Location.input_name
@@ -103,61 +112,50 @@ let undefined_exception loc =
let pos = loc.Location.loc_start in
let line = pos.Lexing.pos_lnum in
let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
- Lprim(Pmakeblock(0, Immutable),
- [transl_path Predef.path_undefined_recursive_module;
- Lconst(Const_block(0,
- [Const_base(Const_string fname);
- Const_base(Const_int line);
- Const_base(Const_int char)]))])
-
-let undefined_function loc =
- Lfunction(Curried, [Ident.create "undef"],
- Lprim(Praise, [undefined_exception loc]))
-
-let init_value modl =
- let undef_exn_id = Ident.create "undef_exception" in
- let undef_function_id = Ident.create "undef_function" in
- let rec init_value_mod env mty =
+ Lconst(Const_block(0,
+ [Const_base(Const_string fname);
+ Const_base(Const_int line);
+ Const_base(Const_int char)]))
+
+let init_shape modl =
+ let rec init_shape_mod env mty =
match Mtype.scrape env mty with
Tmty_ident _ ->
raise Not_found
| Tmty_signature sg ->
- Lprim(Pmakeblock(0, Mutable), init_value_struct env sg)
+ Const_block(0, [Const_block(0, init_shape_struct env sg)])
| Tmty_functor(id, arg, res) ->
- raise Not_found (* to be fixed? *)
- and init_value_struct env sg =
+ raise Not_found (* can we do better? *)
+ and init_shape_struct env sg =
match sg with
[] -> []
| Tsig_value(id, vdesc) :: rem ->
let init_v =
match Ctype.expand_head env vdesc.val_type with
{desc = Tarrow(_,_,_,_)} ->
- Lvar undef_function_id
+ Const_pointer 0 (* camlinternalMod.Function *)
| {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t ->
- Lprim(Pmakeblock(Config.lazy_tag, Immutable),
- [Lvar undef_function_id])
+ Const_pointer 1 (* camlinternalMod.Lazy *)
| _ -> raise Not_found in
- init_v :: init_value_struct env rem
+ init_v :: init_shape_struct env rem
| Tsig_type(id, tdecl, _) :: rem ->
- init_value_struct (Env.add_type id tdecl env) rem
+ init_shape_struct (Env.add_type id tdecl env) rem
| Tsig_exception(id, edecl) :: rem ->
- transl_exception
- id (Some Predef.path_undefined_recursive_module) edecl ::
- init_value_struct env rem
+ raise Not_found
| Tsig_module(id, mty, _) :: rem ->
- init_value_mod env mty ::
- init_value_struct (Env.add_module id mty env) rem
+ init_shape_mod env mty ::
+ init_shape_struct (Env.add_module id mty env) rem
| Tsig_modtype(id, minfo) :: rem ->
- init_value_struct (Env.add_modtype id minfo env) rem
+ init_shape_struct (Env.add_modtype id minfo env) rem
| Tsig_class(id, cdecl, _) :: rem ->
- Translclass.dummy_class (Lvar undef_function_id) ::
- init_value_struct env rem
+ Const_pointer 2 (* camlinternalMod.Class *)
+ :: init_shape_struct env rem
| Tsig_cltype(id, ctyp, _) :: rem ->
- init_value_struct env rem
+ init_shape_struct env rem
in
try
- Some(Llet(Alias, undef_function_id, undefined_function modl.mod_loc,
- init_value_mod modl.mod_env modl.mod_type))
+ Some(undefined_location modl.mod_loc,
+ Lconst(init_shape_mod modl.mod_env modl.mod_type))
with Not_found ->
None
@@ -197,35 +195,30 @@ let reorder_rec_bindings bindings =
(* Generate lambda-code for a reordered list of bindings *)
-let prim_update =
- { prim_name = "caml_update_dummy";
- prim_arity = 2;
- prim_alloc = true;
- prim_native_name = "";
- prim_native_float = false }
-
let eval_rec_bindings bindings cont =
let rec bind_inits = function
[] ->
bind_strict bindings
| (id, None, rhs) :: rem ->
bind_inits rem
- | (id, Some init, rhs) :: rem ->
- Llet(Strict, id, init, bind_inits rem)
+ | (id, Some(loc, shape), rhs) :: rem ->
+ Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape]),
+ bind_inits rem)
and bind_strict = function
[] ->
patch_forwards bindings
| (id, None, rhs) :: rem ->
Llet(Strict, id, rhs, bind_strict rem)
- | (id, Some init, rhs) :: rem ->
+ | (id, Some(loc, shape), rhs) :: rem ->
bind_strict rem
and patch_forwards = function
[] ->
cont
| (id, None, rhs) :: rem ->
patch_forwards rem
- | (id, Some init, rhs) :: rem ->
- Lsequence(Lprim(Pccall prim_update, [Lvar id; rhs]), patch_forwards rem)
+ | (id, Some(loc, shape), rhs) :: rem ->
+ Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs]),
+ patch_forwards rem)
in
bind_inits bindings
@@ -234,7 +227,7 @@ let compile_recmodule compile_rhs bindings cont =
(reorder_rec_bindings
(List.map
(fun (id, modl) ->
- (id, modl.mod_loc, init_value modl, compile_rhs id modl))
+ (id, modl.mod_loc, init_shape modl, compile_rhs id modl))
bindings))
cont
View Lorry Controller Status