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

or-pat avec variables et compil du switch 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3304 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Luc Maranget 2000-10-02 14:18:05 +00:00
parent 89f252d93e
commit ab97fd0dcc
27 changed files with 1945 additions and 320 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

133
bytecomp/bytegen.ml
View File

@ -79,6 +79,12 @@ let make_branch cont =
| Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont
| _ -> make_branch_2 (None) 0 cont cont
(* Avoid a branch to a label that follows immediately *)
let branch_to label cont = match cont with
| Klabel label0::_ when label = label0 -> cont
| _ -> Kbranch label::cont
(* Discard all instructions up to the next label.
This function is to be applied to the continuation before adding a
non-terminating instruction (branch, raise, return) in front of it. *)
@ -106,6 +112,25 @@ let rec add_pop n cont =
| Kraise :: _ -> cont
| _ -> Kpop n :: cont
(* Translates the accumulator + n-1 positions, m places down on the stack *)
let rec squeeze_rec i n m cont =
if i <= 1 then
Kacc 0::add_pop (if m <= n then m+1 else m-n+1) (Kpush::cont)
else
Kacc (i-1)::
Kassign (m+i-1)::
squeeze_rec (i-1) n m cont
let add_squeeze n m cont =
if n=0 then add_pop m cont
else if n=1 then add_pop m (Kpush::cont)
else if m=0 then Kpush::cont
else
Kpush::
squeeze_rec n n m cont
(* Add the constant "unit" in front of a continuation *)
let add_const_unit = function
@ -204,6 +229,30 @@ and sz_staticfail = ref 0
(* Same information as a stack for Lstaticraise *)
let sz_static_raises = ref []
let find_raise_label i =
try
List.assoc i !sz_static_raises
with
| Not_found ->
Misc.fatal_error
("exit("^string_of_int i^") outside appropriated catch")
(* Will the translation of l lead to a jump to label ? *)
let code_as_jump l sz = match l with
| Lstaticfail ->
if sz = !sz_staticfail then
match !lbl_staticfail with
| Some label -> Some label
| None -> Misc.fatal_error "exit outside appropriated catch"
else
None
| Lstaticraise (i,[]) ->
let label,size = find_raise_label i in
if sz = size then
Some label
else
None
| _ -> None
(* Function bodies that remain to be compiled *)
@ -290,6 +339,7 @@ let comp_primitive p args =
| Parraysetu Pfloatarray -> Kccall("array_unsafe_set_float", 3)
| Parraysetu _ -> Ksetvectitem
| Pisint -> Kisint
| Pisout -> Kisout
| Pbittest -> Kccall("bitvect_test", 2)
| Pbintofint bi -> comp_bint_primitive bi "of_int" args
| Pintofbint bi -> comp_bint_primitive bi "to_int" args
@ -321,6 +371,14 @@ let comp_primitive p args =
| Pbigarrayset(n, _, _) -> Kccall("bigarray_set_" ^ string_of_int n, n + 2)
| _ -> fatal_error "Bytegen.comp_primitive"
let is_immed n = immed_min <= n && n <= immed_max
let explode_isout arg l h =
Lprim
(Psequor,
[Lprim (Pintcomp Clt,[arg ; Lconst (Const_base (Const_int 0))]) ;
Lprim (Pintcomp Cgt,[arg ; Lconst (Const_base (Const_int h))])])
(* Compile an expression.
The value of the expression is left in the accumulator.
env = compilation environment
@ -478,10 +536,18 @@ let rec comp_expr env exp sz cont =
end
| Lprim(Praise, [arg]) ->
comp_expr env arg sz (Kraise :: discard_dead_code cont)
| Lprim((Paddint | Psubint as prim), [arg; Lconst(Const_base(Const_int n))])
when n >= immed_min & n <= immed_max ->
let ofs = if prim == Paddint then n else -n in
comp_expr env arg sz (Koffsetint ofs :: cont)
| Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))])
when is_immed n ->
comp_expr env arg sz (Koffsetint n :: cont)
| Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))])
when is_immed (-n) ->
comp_expr env arg sz (Koffsetint (-n) :: cont)
| Lprim (Poffsetint n, [arg])
when not (is_immed n) ->
comp_expr env arg sz
(Kpush::
Kconst (Const_base (Const_int n))::
Kaddint::cont)
| Lprim(Pmakearray kind, args) ->
begin match kind with
Pintarray | Paddrarray ->
@ -495,6 +561,11 @@ let rec comp_expr env exp sz cont =
(Kmakeblock(List.length args, 0) ::
Kccall("make_array", 1) :: cont)
end
(* Integer first for enabling futher optimization (cf. emitcode.ml) *)
| Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) ->
let p = Pintcomp (commute_comparison c)
and args = [k ; arg] in
comp_args env args sz (comp_primitive p args :: cont)
| Lprim(p, args) ->
comp_args env args sz (comp_primitive p args :: cont)
| Lcatch(body, Lstaticfail) ->
@ -511,24 +582,24 @@ let rec comp_expr env exp sz cont =
sz_staticfail := saved_sz_staticfail;
cont3
| Lstaticfail -> comp_static_fail sz cont
| Lstaticcatch (body, i, handler) ->
let branch1, cont1 = make_branch cont in
| Lstaticcatch (body, (i, vars) , handler) ->
let branch1, cont1 = make_branch cont
and nvars = List.length vars in
let lbl_handler, cont2 =
label_code (comp_expr env handler sz cont1) in
sz_static_raises := (i, (lbl_handler, sz)) :: !sz_static_raises ;
label_code
(comp_expr
(add_vars vars (sz+1) env)
handler (sz+nvars) (add_pop nvars cont1)) in
sz_static_raises := (i, (lbl_handler, sz+nvars)) :: !sz_static_raises ;
let cont3 = comp_expr env body sz (branch1 :: cont2) in
sz_static_raises := List.tl !sz_static_raises ;
cont3
| Lstaticraise i ->
| Lstaticraise (i, args) ->
let cont = discard_dead_code cont in
let label, size =
try
List.assoc i !sz_static_raises
with
| Not_found ->
Misc.fatal_error
("exit("^string_of_int i^") outside appropriated catch") in
add_pop (sz-size) (Kbranch label :: cont)
let label,size = find_raise_label i in
comp_expr_list env args sz
(add_squeeze (List.length args) (sz+List.length args-size)
(branch_to label cont))
| Ltrywith(body, id, handler) ->
let (branch1, cont1) = make_branch cont in
let lbl_handler = new_label() in
@ -656,7 +727,7 @@ and comp_static_fail sz cont =
| None ->
Misc.fatal_error "exit outside appropriated catch"
| Some label ->
add_pop (sz - !sz_staticfail) (Kbranch label :: cont)
add_pop (sz - !sz_staticfail) (branch_to label cont)
end
(* Compile a list of arguments [e1; ...; eN] to a primitive operation.
@ -681,24 +752,21 @@ and comp_binary_test env cond ifso ifnot sz cont =
let (lbl_end, cont1) = label_code cont in
Kstrictbranchifnot lbl_end :: comp_expr env ifso sz cont1
end else
if ifso = Lstaticfail && sz = !sz_staticfail
then
match code_as_jump ifso sz with
| Some label ->
let cont = comp_expr env ifnot sz cont in
match !lbl_staticfail with
| None -> Misc.fatal_error "exit outside appropriated catch"
| Some label -> Kbranchif label :: cont
else
if ifnot = Lstaticfail && sz = !sz_staticfail
then
Kbranchif label :: cont
| _ ->
match code_as_jump ifnot sz with
| Some label ->
let cont = comp_expr env ifso sz cont in
match !lbl_staticfail with
| None -> Misc.fatal_error "exit outside appropriated catch"
| Some label -> Kbranchifnot label :: cont
else begin
Kbranchifnot label :: cont
| _ ->
let (branch_end, cont1) = make_branch cont in
let (lbl_not, cont2) = label_code(comp_expr env ifnot sz cont1) in
Kbranchifnot lbl_not :: comp_expr env ifso sz (branch_end :: cont2)
end in
Kbranchifnot lbl_not ::
comp_expr env ifso sz (branch_end :: cont2) in
comp_expr env cond sz cont_cond
(**** Compilation of functions ****)
@ -737,6 +805,7 @@ let compile_implementation modulename expr =
label_counter := 0;
lbl_staticfail := None;
sz_staticfail := 0;
sz_static_raises := [] ;
compunit_name := modulename;
let init_code = comp_expr empty_env expr 0 [] in
if Stack.length functions_to_compile > 0 then begin

70
bytecomp/emitcode.ml
View File

@ -73,9 +73,33 @@ let out_word b1 b2 b3 b4 =
let out opcode =
out_word opcode 0 0 0
exception AsInt
let const_as_int = function
| Const_base(Const_int i) -> i
| Const_base(Const_char c) -> Char.code c
| Const_pointer i -> i
| _ -> raise AsInt
let is_immed i = immed_min <= i && i <= immed_max
let is_immed_const k =
try
is_immed (const_as_int k)
with
| AsInt -> false
let out_int n =
out_word n (n asr 8) (n asr 16) (n asr 24)
let out_const c =
try
out_int (const_as_int c)
with
| AsInt -> Misc.fatal_error "Emitcode.const_as_int"
(* Handling of local labels and backpatching *)
type label_definition =
@ -157,6 +181,16 @@ let init () =
(* Emission of one instruction *)
let emit_comp = function
| Ceq -> out opEQ | Cneq -> out opNEQ
| Clt -> out opLTINT | Cle -> out opLEINT
| Cgt -> out opGTINT | Cge -> out opGEINT
and emit_branch_comp = function
| Ceq -> out opBEQ | Cneq -> out opBNEQ
| Clt -> out opBLTINT | Cle -> out opBLEINT
| Cgt -> out opBGTINT | Cge -> out opBGEINT
let emit_instr = function
Klabel lbl -> define_label lbl
| Kacc n ->
@ -193,7 +227,7 @@ let emit_instr = function
| Ksetglobal q -> out opSETGLOBAL; slot_for_setglobal q
| Kconst sc ->
begin match sc with
Const_base(Const_int i) when i >= immed_min & i <= immed_max ->
Const_base(Const_int i) when is_immed i ->
if i >= 0 & i <= 3
then out (opCONST0 + i)
else (out opCONSTINT; out_int i)
@ -252,12 +286,11 @@ let emit_instr = function
| Kandint -> out opANDINT | Korint -> out opORINT
| Kxorint -> out opXORINT | Klslint -> out opLSLINT
| Klsrint -> out opLSRINT | Kasrint -> out opASRINT
| Kintcomp Ceq -> out opEQ | Kintcomp Cneq -> out opNEQ
| Kintcomp Clt -> out opLTINT | Kintcomp Cle -> out opLEINT
| Kintcomp Cgt -> out opGTINT | Kintcomp Cge -> out opGEINT
| Kintcomp c -> emit_comp c
| Koffsetint n -> out opOFFSETINT; out_int n
| Koffsetref n -> out opOFFSETREF; out_int n
| Kisint -> out opISINT
| Kisout -> out opULTINT
| Kgetmethod -> out opGETMETHOD
| Kevent ev -> record_event ev
| Kstop -> out opSTOP
@ -267,6 +300,33 @@ let emit_instr = function
let rec emit = function
[] -> ()
(* Peephole optimizations *)
(* optimization of integer tests *)
| Kpush::Kconst k::Kintcomp c::Kbranchif lbl::rem
when is_immed_const k ->
emit_branch_comp c ;
out_const k ;
out_label lbl ;
emit rem
| Kpush::Kconst k::Kintcomp c::Kbranchifnot lbl::rem
when is_immed_const k ->
emit_branch_comp (negate_comparison c) ;
out_const k ;
out_label lbl ;
emit rem
(* same for range tests *)
| Kpush::Kconst k::Kisout::Kbranchif lbl::rem
when is_immed_const k ->
out opBULTINT ;
out_const k ;
out_label lbl ;
emit rem
| Kpush::Kconst k::Kisout::Kbranchifnot lbl::rem
when is_immed_const k ->
out opBUGEINT ;
out_const k ;
out_label lbl ;
emit rem
| Kpush :: Kacc n :: c ->
if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
emit c
@ -286,7 +346,7 @@ let rec emit = function
out opPUSHGETGLOBAL; slot_for_getglobal id; emit c
| Kpush :: Kconst sc :: c ->
begin match sc with
Const_base(Const_int i) when i >= immed_min & i <= immed_max ->
Const_base(Const_int i) when is_immed i ->
if i >= 0 & i <= 3
then out (opPUSHCONST0 + i)
else (out opPUSHCONSTINT; out_int i)

1
bytecomp/instruct.ml
View File

@ -95,6 +95,7 @@ type instruction =
| Koffsetint of int
| Koffsetref of int
| Kisint
| Kisout
| Kgetmethod
| Kevent of debug_event
| Kstop

1
bytecomp/instruct.mli
View File

@ -114,6 +114,7 @@ type instruction =
| Koffsetint of int
| Koffsetref of int
| Kisint
| Kisout
| Kgetmethod
| Kevent of debug_event
| Kstop

40
bytecomp/lambda.ml
View File

@ -57,6 +57,8 @@ type primitive =
| Parraysets of array_kind
(* Test if the argument is a block or an immediate integer *)
| Pisint
(* Test if the (integer) argument is outside an interval *)
| Pisout
(* Bitvect operations *)
| Pbittest
(* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
@ -125,8 +127,8 @@ type lambda =
| Lswitch of lambda * lambda_switch
| Lstaticfail
| Lcatch of lambda * lambda
| Lstaticraise of int
| Lstaticcatch of lambda * int * lambda
| Lstaticraise of int * lambda list
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
| Ltrywith of lambda * Ident.t * lambda
| Lifthenelse of lambda * lambda * lambda
| Lsequence of lambda * lambda
@ -207,9 +209,11 @@ let free_variables l =
| Lstaticfail -> ()
| Lcatch(e1, e2) ->
freevars e1; freevars e2
| Lstaticraise _ -> ()
| Lstaticcatch(e1, _, e2) ->
freevars e1; freevars e2
| Lstaticraise (_,args) ->
List.iter freevars args
| Lstaticcatch(e1, (_,vars), e2) ->
freevars e1; freevars e2 ;
List.iter (fun id -> fv := IdentSet.remove id !fv) vars
| Ltrywith(e1, exn, e2) ->
freevars e1; freevars e2; fv := IdentSet.remove exn !fv
| Lifthenelse(e1, e2, e3) ->
@ -278,7 +282,7 @@ let subst_lambda s lam =
sw_blocks = List.map subst_case sw.sw_blocks})
| Lstaticfail as l -> l
| Lcatch(e1, e2) -> Lcatch(subst e1, subst e2)
| Lstaticraise i as l -> l
| Lstaticraise _ as l -> l
| 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)
@ -292,3 +296,27 @@ let subst_lambda s lam =
and subst_decl (id, exp) = (id, subst exp)
and subst_case (key, case) = (key, subst case)
in subst lam
(* To let-bind expressions to variables *)
let bind str var exp body =
match exp with
Lvar var' when Ident.same var var' -> body
| _ -> Llet(str, var, exp, body)
and commute_comparison = function
| Ceq -> Ceq| Cneq -> Cneq
| Clt -> Cgt | Cle -> Cge
| Cgt -> Clt | Cge -> Cle
and negate_comparison = function
| Ceq -> Cneq| Cneq -> Ceq
| Clt -> Cge | Cle -> Cgt
| Cgt -> Cle | Cge -> Clt
let raise_count = ref 0
let next_raise_count () =
incr raise_count ; (* Done before, since 0 is for partial matches *)
!raise_count

12
bytecomp/lambda.mli
View File

@ -57,6 +57,8 @@ type primitive =
| Parraysets of array_kind
(* Test if the argument is a block or an immediate integer *)
| Pisint
(* Test if the (integer) argument is outside an interval *)
| Pisout
(* Bitvect operations *)
| Pbittest
(* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
@ -134,8 +136,8 @@ type lambda =
| Lswitch of lambda * lambda_switch
| Lstaticfail
| Lcatch of lambda * lambda
| Lstaticraise of int
| Lstaticcatch of lambda * int * lambda
| Lstaticraise of int * lambda list
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
| Ltrywith of lambda * Ident.t * lambda
| Lifthenelse of lambda * lambda * lambda
| Lsequence of lambda * lambda
@ -177,3 +179,9 @@ val transl_path: Path.t -> lambda
val make_sequence: ('a -> lambda) -> 'a list -> lambda
val subst_lambda: lambda Ident.tbl -> lambda -> lambda
val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
val commute_comparison : comparison -> comparison
val negate_comparison : comparison -> comparison
val next_raise_count : unit -> int

710
bytecomp/matching.ml
View File

@ -56,12 +56,6 @@ let rec name_pattern default = function
end
| _ -> Ident.create default
(* To let-bind expressions to variables *)
let bind str var exp body =
match exp with
Lvar var' when Ident.same var var' -> body
| _ -> Llet(str, var, exp, body)
(* To remove aliases and bind named components *)
@ -69,46 +63,58 @@ let any_pat =
{ pat_desc = Tpat_any; pat_loc = Location.none;
pat_type = Ctype.none; pat_env = Env.empty }
exception Var
;;
exception Var of pattern
let simplify_or p =
let rec simpl_rec = function
| {pat_desc = Tpat_any} -> raise Var
| {pat_desc = Tpat_any|Tpat_var _} as p -> raise (Var p)
| {pat_desc = Tpat_alias (q,id)} as p ->
begin try
simpl_rec q
with
| Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id)})
end
| {pat_desc = Tpat_or (p1,p2)} ->
simpl_rec p1 ; simpl_rec p2
| _ -> () in
try
simpl_rec p ; p
with
| Var -> any_pat
| Var p -> p
let simplify_matching m = match m.args with
| [] -> m
| (arg, mut) :: argl ->
| (arg, _) :: _ ->
let rec simplify = function
(pat :: patl, action as patl_action) :: rem ->
begin match pat.pat_desc with
| Tpat_var id ->
(any_pat :: patl, bind Alias id arg action) ::
simplify rem
(any_pat :: patl, bind Alias id arg action) :: simplify rem
| Tpat_alias(p, id) ->
simplify ((p :: patl, bind Alias id arg action) :: rem)
| Tpat_record [] ->
(any_pat :: patl, action) :: simplify rem
| Tpat_or (_,_) ->
(simplify_or pat :: patl, action) ::
let pat_simple = simplify_or pat in
begin match pat_simple.pat_desc with
| Tpat_or (_,_) ->
(pat_simple :: patl, action) ::
simplify rem
| _ ->
simplify ((pat_simple::patl,action) :: rem)
end
| _ ->
patl_action :: simplify rem
end
| cases -> cases in
{ args = m.args; cases = simplify m.cases }
{m with cases = simplify m.cases }
let rec what_is_or = function
| {pat_desc = Tpat_or (p1,_)} -> what_is_or p1
| {pat_desc = (Tpat_alias (_,_)|Tpat_var _|Tpat_any)} ->
Misc.fatal_error "Mathing.what_is_or"
| {pat_desc = Tpat_or (p,_)} -> what_is_or p
| {pat_desc = (Tpat_alias (p,_))} -> what_is_or p
| {pat_desc=(Tpat_var _|Tpat_any)} -> fatal_error "Matching.what_is_or"
| p -> p
let rec upper_left_pattern pm = match pm.cases with
@ -118,27 +124,60 @@ let rec upper_left_pattern pm = match pm.cases with
(* Optimize breaks *)
let raise_count = ref 0
let next_raise_count () =
incr raise_count ; (* Done before, since 0 is for partial matches *)
!raise_count
let rec group_or group = function
| {pat_desc = Tpat_or (p1, p2)} -> group_or group p1 && group_or group p2
| {pat_desc = Tpat_alias (p,_)} -> group_or group p
| p -> group p
let rec explode_or_pat patl action rem = function
let rec extract_vars r p = match p.pat_desc with
| Tpat_var id -> IdentSet.add id r
| Tpat_alias (p, id) ->
extract_vars (IdentSet.add id r) p
| Tpat_tuple pats ->
List.fold_left extract_vars r pats
| Tpat_record lpats ->
List.fold_left
(fun r (_,p) -> extract_vars r p)
r lpats
| Tpat_construct (_,pats) ->
List.fold_left extract_vars r pats
| Tpat_array pats ->
List.fold_left extract_vars r pats
| Tpat_variant (_,Some p, _) -> extract_vars r p
| Tpat_or (p,_) -> extract_vars r p
| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r
exception Cannot_flatten
let mk_alpha_env arg aliases ids =
List.map
(fun id -> id,
if List.mem id aliases then
match arg with
| Some v -> v
| _ -> raise Cannot_flatten
else
Ident.create (Ident.name id))
ids
let rec explode_or_pat arg patl mk_action rem vars aliases = function
| {pat_desc = Tpat_or (p1,p2)} ->
explode_or_pat
patl action
(explode_or_pat patl action rem p1)
p2
| p -> (p::patl,action)::rem
arg patl mk_action
(explode_or_pat arg patl mk_action rem vars aliases p1)
vars aliases p2
| {pat_desc = Tpat_alias (p,id)} ->
explode_or_pat arg patl mk_action rem vars (id::aliases) p
| p ->
let env = mk_alpha_env arg aliases vars in
(alpha_pat env p::patl,mk_action (List.map snd env))::rem
let more group ({cases=cl ; args = al} as m) = match al with
| [] -> assert false
| _ ->
| (Lvar arg,_)::_ ->
let rec more_rec yes no = function
| (pat::_ as patl, action) as full :: rem ->
if
@ -159,25 +198,47 @@ let more group ({cases=cl ; args = al} as m) = match al with
| ({pat_desc=Tpat_or (_,_)} as p::patl, action)::rem
when group_or group p
&& not (List.exists (fun q -> Parmatch.compat q p) prev) ->
let vars =
IdentSet.elements
(IdentSet.inter
(extract_vars IdentSet.empty p)
(free_variables action)) in
begin match action with
| Lstaticraise _ | Lstaticfail
when List.for_all
| Lstaticraise (_,[]) | Lstaticfail
when
vars = [] &&
List.for_all
(function {pat_desc=Tpat_any} -> true
| _ -> false)
patl ->
let new_yes,new_to_catch,new_others =
add_or (p::prev) rem in
explode_or_pat patl action new_yes p,
explode_or_pat
(Some arg) patl (fun _ -> action) new_yes vars [] p,
new_to_catch,
new_others
| _ ->
let raise_num = next_raise_count () in
let new_patl = Parmatch.omega_list patl
and new_action = Lstaticraise raise_num in
let new_patl = Parmatch.omega_list patl in
(* Compilation assigne, pas bo
let mk_new_action vs =
List.fold_right2
(fun dest src lambda ->
Lsequence (Lassign (dest, Lvar src),lambda))
vars vs
(Lstaticraise (raise_num,[])) in
*)
let mk_new_action vs =
Lstaticraise
(raise_num, List.map (fun v -> Lvar v) vs) in
let new_yes,new_to_catch,new_others =
add_or (p::prev) rem in
explode_or_pat new_patl new_action new_yes p,
((raise_num, {cases=[patl, action] ; args = List.tl al})::
explode_or_pat
(Some arg) new_patl mk_new_action new_yes vars [] p,
((raise_num, vars ,
{cases=[patl, action] ; args = List.tl al})::
new_to_catch),
new_others
end
@ -187,7 +248,7 @@ let more group ({cases=cl ; args = al} as m) = match al with
{cases=rem ; args = al} in
let yes,to_catch,others = add_or [] no in
List.rev yes, to_catch, others
| _ -> assert false
(* General divide functions *)
let divide group make get_key get_args ({args=al} as pm) =
@ -399,21 +460,6 @@ let divide_record all_labels pm =
(get_args_record (Array.length all_labels))
pm
(* Matching against an or pattern. *)
let rec flatten_orpat_match pat =
match pat.pat_desc with
Tpat_or(p1, p2) -> flatten_orpat_match p1 @ flatten_orpat_match p2
| _ -> [[pat], lambda_unit]
let divide_orpat = function
{cases = (orpat :: patl, act) :: casel; args = arg1 :: argl as args} ->
({cases = flatten_orpat_match orpat; args = [arg1]},
{cases = [patl, act]; args = argl},
{cases = casel; args = args})
| _ ->
fatal_error "Matching.divide_orpat"
(* Matching against an array pattern *)
let group_array = function
| {pat_desc=Tpat_array _} -> true
@ -445,26 +491,55 @@ let divide_array kind pm =
(* To combine sub-matchings together *)
let rec raw_action = function
| Llet(Alias,_,_, body) -> raw_action body
| l -> l
exception Not_simple
let rec raw_rec env = function
| Llet(Alias,x,ex, body) -> raw_rec ((x,ex)::env) body
| Lstaticfail as l -> l
| Lvar id as l ->
begin try List.assoc id env with
| Not_found -> l
end
| Lprim (Pfield i,args) ->
Lprim (Pfield i, List.map (raw_rec env) args)
| Lconst _ as l -> l
| Lstaticraise (i,args) ->
Lstaticraise (i, List.map (raw_rec env) args)
| _ -> raise Not_simple
let raw_action l = try raw_rec [] l with Not_simple -> l
let same_actions = function
| [] -> None
| [_,act] -> Some act
| (_,act0) :: rem ->
let raw_act0 = raw_action act0 in
match raw_act0 with
| Lstaticfail | Lstaticraise _ ->
try
let raw_act0 = raw_rec [] act0 in
let rec s_rec = function
| [] -> Some raw_act0
| [] -> Some act0
| (_,act)::rem ->
if raw_act0 = raw_action act then
if raw_act0 = raw_rec [] act then
s_rec rem
else
None in
s_rec rem
| _ -> None
with
| Not_simple -> None
let equal_action act1 act2 =
try
let raw1 = raw_rec [] act1
and raw2 = raw_rec [] act2 in
raw1 = raw2
with
| Not_simple -> false
let sort_lambda_list l =
List.sort
(fun (x,_) (y,_) -> x - y)
l
let add_catch (lambda1,total1) (c_catch,(lambda_default,total_default)) =
let rec do_rec r total_r = function
@ -475,20 +550,32 @@ let add_catch (lambda1,total1) (c_catch,(lambda_default,total_default)) =
| Lstaticfail -> r,total_r
| _ -> Lcatch (r,lambda_default),total_default
end
| (i,(handler_i,total_i))::rem ->
| (i,vars,(handler_i,total_i))::rem ->
(* Compilation assign, pas bo
do_rec
(match raw_action r with
| Lstaticraise j when i=j -> handler_i
| _ -> Lstaticcatch(r,i,handler_i))
(List.fold_right
(fun v lambda ->
bind StrictOpt v (Lconst const_unit) lambda)
vars (Lstaticcatch (r,(i,[]), handler_i)))
(total_i && total_r) rem in
*)
match raw_action r with
| Lstaticraise (j,args) ->
if j <> i then
do_rec r total_r rem
else if args=[] then
do_rec handler_i total_i rem
else
do_rec
(Lstaticcatch (r,(i,vars), handler_i))
(total_i && total_r) rem
| _ ->
do_rec
(Lstaticcatch (r,(i,vars), handler_i))
(total_i && total_r) rem in
do_rec lambda1 total1 c_catch
let combine_var (lambda1, total1) (lambda2, total2) =
if total1 then (lambda1, true)
else if lambda2 = Lstaticfail then (lambda1, total1)
else (Lcatch(lambda1, lambda2), total2)
let combine_line (lambda1, total1) c_catch =
add_catch (lambda1, total1) c_catch
@ -506,7 +593,7 @@ let make_test_sequence nofail check tst lt_tst arg const_lambda_list =
List.fold_right
(fun (c, act) rem ->
if rem = Lstaticfail && (not check || nofail) then act else
Lifthenelse(Lprim(tst, [arg; Lconst(Const_base c)]), act, rem))
Lifthenelse(Lprim(tst, [arg; Lconst(Const_base c)]), rem, act))
const_lambda_list
Lstaticfail
and split_sequence const_lambda_list =
@ -518,6 +605,19 @@ let make_test_sequence nofail check tst lt_tst arg const_lambda_list =
(Sort.list (fun (c1,_) (c2,_) -> c1 < c2) const_lambda_list)
let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg])
let make_switch_offset nofail check arg min_key max_key int_lambda_list =
let numcases = max_key - min_key + 1 in
let cases =
List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in
let offsetarg = make_offset (-min_key) arg in
Lswitch(offsetarg,
{sw_numconsts = numcases; sw_consts = cases;
sw_numblocks = 0; sw_blocks = []; sw_checked = check ;
sw_nofail = nofail})
let make_switch_or_test_sequence
nofail check arg const_lambda_list int_lambda_list =
if const_lambda_list = [] then
@ -531,30 +631,22 @@ let make_switch_or_test_sequence
overflow in the following comparison *)
if List.length int_lambda_list <= 1 + max_key / 4 - min_key / 4 then
(* Sparse matching -- use a sequence of tests *)
make_test_sequence nofail check (Pintcomp Ceq) (Pintcomp Clt)
make_test_sequence nofail check (Pintcomp Cneq) (Pintcomp Clt)
arg const_lambda_list
else begin
(* Dense matching -- use a jump table
(2 bytecode instructions + 1 word per entry in the table) *)
let numcases = max_key - min_key + 1 in
let cases =
List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in
let offsetarg =
if min_key = 0 then arg else Lprim(Poffsetint(-min_key), [arg]) in
Lswitch(offsetarg,
{sw_numconsts = numcases; sw_consts = cases;
sw_numblocks = 0; sw_blocks = []; sw_checked = check ;
sw_nofail = nofail})
make_switch_offset nofail check arg min_key max_key int_lambda_list
end
let make_test_sequence_variant_constant check arg int_lambda_list =
make_test_sequence false check (Pintcomp Ceq) (Pintcomp Clt) arg
make_test_sequence false check (Pintcomp Cneq) (Pintcomp Clt) arg
(List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list)
let make_test_sequence_variant_constr check arg int_lambda_list =
let v = Ident.create "variant" in
Llet(Alias, v, Lprim(Pfield 0, [arg]),
make_test_sequence false check (Pintcomp Ceq) (Pintcomp Clt) (Lvar v)
make_test_sequence false check (Pintcomp Cneq) (Pintcomp Clt) (Lvar v)
(List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list))
let make_bitvect_check arg int_lambda_list lambda =
@ -566,30 +658,215 @@ let make_bitvect_check arg int_lambda_list lambda =
Lifthenelse(Lprim(Pbittest, [Lconst(Const_base(Const_string bv)); arg]),
lambda, Lstaticfail)
let prim_string_equal =
Pccall{prim_name = "string_equal";
let prim_string_notequal =
Pccall{prim_name = "string_notequal";
prim_arity = 2; prim_alloc = false;
prim_native_name = ""; prim_native_float = false}
let is_default act = match raw_action act with
| Lstaticfail -> true
| _ -> false
let rec explode_inter offset i j act k =
if i <= j then
explode_inter offset i (j-1) act ((j-offset,act)::k)
else
k
let as_int_list cases acts =
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
if is_default acts.(act) then
do_rec (i-1) k
else
do_rec (i-1) (explode_inter min_key low high acts.(act) k)
else
k in
min_key, max_key,do_rec (Array.length cases-1) []
let make_switch_switcher arg cases acts =
let min_key, max_key, clauses = as_int_list cases acts in
make_switch_offset false false arg 0 (max_key-min_key) clauses
module SArg = struct
type primitive = Lambda.primitive
let eqint = Pintcomp Ceq
let neint = Pintcomp Cneq
let leint = Pintcomp Cle
let ltint = Pintcomp Clt
let geint = Pintcomp Cge
let gtint = Pintcomp Cgt
type act = Lambda.lambda
let default = Lstaticfail
(* let equal_action = equal_action *)
let make_prim p args = Lprim (p,args)
let make_offset arg n = match n with
| 0 -> arg
| _ -> Lprim (Poffsetint n,[arg])
let bind arg body =
let newvar,newarg = match arg with
| Lvar v -> v,arg
| _ ->
let newvar = Ident.create "switcher" in
newvar,Lvar newvar in
bind Alias newvar arg (body newarg)
let make_isout h arg = Lprim (Pisout, [h ; arg])
let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
let make_switch = make_switch_switcher
end
module Switcher = Switch.Make(SArg)
open Switch
let lambda_of_int i = Lconst (Const_base (Const_int i))
(* Store for actions in object style *)
exception Found of int
type t_store =
{get : unit -> lambda array ; store : lambda -> int}
let mk_store () =
let r_acts = ref [] in
let store act =
let rec store_rec i = function
| [] -> i,[act]
| act0::rem ->
if equal_action act act0 then raise (Found i)
else
let i,rem = store_rec (i+1) rem in
i,act0::rem in
try
let i,acts = store_rec 0 !r_acts in
r_acts := acts ;
i
with
| Found i -> i
and get () = Array.of_list !r_acts in
{store=store ; get=get}
let as_interval_canfail low high l =
let store = mk_store () in
let rec nofail_rec cur_low cur_high cur_act = function
| [] -> begin match high with
| TooMuch -> [cur_low,cur_high,cur_act]
| Int h ->
if cur_high = h then
[cur_low,cur_high,cur_act]
else
[(cur_low,cur_high,cur_act) ; (cur_high+1,h, 0)]
end
| ((i,act_i)::rem) as all ->
let act_index = store.store act_i in
if cur_high+1= i then
if act_index=cur_act then
nofail_rec cur_low i cur_act rem
else if is_default act_i then
(cur_low,i-1, cur_act)::fail_rec i i rem
else
(cur_low, i-1, cur_act)::nofail_rec i i act_index rem
else
(cur_low, cur_high, cur_act)::
fail_rec ((cur_high+1)) (cur_high+1) all
and fail_rec cur_low cur_high = function
| [] -> [(cur_low, cur_high, 0)]
| (i,act_i)::rem ->
if is_default act_i then fail_rec cur_low i rem
else
(cur_low,i-1,0)::
nofail_rec i i (store.store act_i) rem in
let rec init_rec = function
| [] -> []
| (i,act_i)::rem as all ->
if is_default act_i then
match low with
| TooMuch -> init_rec rem
| Int low -> fail_rec low i rem
else begin match low with
| TooMuch -> nofail_rec i i (store.store act_i) rem
| Int low ->
if low < i then
(low,i-1,0)::nofail_rec i i (store.store act_i) rem
else
nofail_rec i i (store.store act_i) rem
end in
ignore (store.store Lstaticfail) ; (* Lstaticfail has action index 0 *)
let r = init_rec (sort_lambda_list l) in
low, high, Array.of_list r, store.get ()
let as_interval_nofail l =
let store = mk_store ()
and high = ref (-1)
and low = ref (-1) in
let rec i_rec cur_low cur_high cur_act = function
| [] ->
high := cur_high ;
[cur_low, cur_high, cur_act]
| (i,act)::rem ->
let act_index = store.store act in
if act_index = cur_act then
i_rec cur_low i cur_act rem
else
(cur_low, cur_high, cur_act)::
i_rec i i act_index rem in
let inters = match sort_lambda_list l with
| (i,act)::rem ->
low := i ;
let act_index = store.store act in
i_rec i i act_index rem
| _ -> assert false in
Int !low, Int !high, Array.of_list inters, store.get ()
let as_interval nofail low high l =
if nofail then
as_interval_nofail l
else
as_interval_canfail low high l
let call_switcher konst nofail arg low high int_lambda_list =
let real_low, real_high, cases, actions =
as_interval nofail low high int_lambda_list in
Switcher.zyva
konst arg real_low real_high cases actions
let combine_constant arg cst partial (const_lambda_list, total1) c_catch =
let nofail = partial=Total
and one_action = same_actions const_lambda_list in
match nofail,one_action with
| true, Some act -> act,total1
| _, _ ->
let nofail = partial=Total in
let lambda1 =
match cst with
Const_int _ ->
| Const_int _ ->
let int_lambda_list =
List.map (function Const_int n, l -> n,l | _ -> assert false)
const_lambda_list in
make_switch_or_test_sequence
nofail true arg const_lambda_list int_lambda_list
call_switcher
lambda_of_int nofail arg
Switch.TooMuch Switch.TooMuch
int_lambda_list
| Const_char _ ->
let int_lambda_list =
List.map (function Const_char c, l -> (Char.code c, l)
| _ -> assert false)
const_lambda_list in
call_switcher
(fun i -> Lconst (Const_base (Const_int i)))
nofail arg
(Switch.Int 0) (Switch.Int 255)
int_lambda_list
(*
begin match one_action with
| Some lambda when List.length int_lambda_list > 8 ->
make_bitvect_check arg int_lambda_list lambda
@ -597,24 +874,76 @@ let combine_constant arg cst partial (const_lambda_list, total1) c_catch =
make_switch_or_test_sequence nofail true arg
const_lambda_list int_lambda_list
end
*)
| Const_string _ ->
make_test_sequence
nofail true prim_string_equal Praise arg const_lambda_list
nofail true prim_string_notequal Praise arg const_lambda_list
| Const_float _ ->
make_test_sequence
nofail
true (Pfloatcomp Ceq) (Pfloatcomp Clt)
true (Pfloatcomp Cneq) (Pfloatcomp Clt)
arg const_lambda_list in
add_catch (lambda1, nofail) c_catch
let rec split_cases = function
let split_cases tag_lambda_list =
let rec split_rec = function
[] -> ([], [])
| (cstr, act) :: rem ->
let (consts, nonconsts) = split_cases rem in
let (consts, nonconsts) = split_rec rem in
match cstr with
Cstr_constant n -> ((n, act) :: consts, nonconsts)
| Cstr_block n -> (consts, (n, act) :: nonconsts)
| _ -> assert false
| _ -> assert false in
let const, nonconst = split_rec tag_lambda_list in
sort_lambda_list const,
sort_lambda_list nonconst
let prerr_c l =
List.iter (fun (i,_) -> Printf.fprintf stderr "%d " i) l
let prerr_i l =
List.iter (fun i -> Printf.fprintf stderr "%d " i) l
let rec interval min max k =
if min >= max then k
else min::interval (min+1) max k
let find_missing n l =
let rec find_rec = function
| [] -> []
| [n1,_] -> interval (n1+1) n []
| (n1,_)::((n2,_)::_ as rem) ->
interval (n1+1) n2 (find_rec rem) in
let r = match l with
| [] -> interval 0 n []
| (n1,_)::_ ->
interval 0 n1 (find_rec l) in
(*
Printf.fprintf stderr "Find missing %d " n;
prerr_c l ;
prerr_string " -> " ;
prerr_i r ;
prerr_endline "" ;
*)
r
let test_fail arg cstr const nonconst =
let miss_const =
find_missing cstr.cstr_consts const
and miss_nonconst =
find_missing cstr.cstr_nonconsts nonconst
in
match const, miss_const, nonconst, miss_nonconst with
| _,[n],_,[] ->
Some (Lprim (Pintcomp Ceq, [arg ; Lconst (Const_base (Const_int n))]))
| [n,_],_,[],_ ->
Some (Lprim (Pintcomp Cneq, [arg ; Lconst (Const_base (Const_int n))]))
| _,[],[],_::_ -> Some (Lprim (Pnot, [Lprim (Pisint, [arg])]))
| [],_::_,_,[] -> Some (Lprim (Pisint, [arg]))
| _, _, _, _ -> None
let combine_constructor arg cstr partial (tag_lambda_list, total1) c_catch =
let nofail = partial=Total in
@ -640,29 +969,21 @@ let combine_constructor arg cstr partial (tag_lambda_list, total1) c_catch =
in add_catch (lambda1, nofail) c_catch
end else begin
(* Regular concrete type *)
let sig_complete =
List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts
let ncases = List.length tag_lambda_list
and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in
let sig_complete = ncases = nconstrs
and one_action = same_actions tag_lambda_list in
let total_loc = sig_complete || nofail in
let lambda1 =
match total_loc, one_action with
| true, Some act -> act
| _,_ ->
let (consts, nonconsts) = split_cases tag_lambda_list in
let lambda1 =
match total_loc, one_action, test_fail arg cstr consts nonconsts with
| true, Some act, _ -> act
| false, Some act, Some (Lprim (Pnot,[test])) ->
Lifthenelse (test, act, Lstaticfail)
| false, Some act, Some test ->
Lifthenelse (test, Lstaticfail, act)
| _,_, _ ->
match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with
(1, 0, [0, act], []) -> act
| (0, 1, [], [0, act]) -> act
| (2, 0, [(n1, act1) ; (n2, act2)], []) ->
let act_true, act_false =
if n1=0 then act2, act1 else act1, act2 in
Lifthenelse (arg, act_true, act_false)
| (2, 0, [(n, act) ], []) ->
if total_loc then
act
else
let act_true, act_false =
if n=0 then Lstaticfail , act else act, Lstaticfail in
Lifthenelse (arg, act_true, act_false)
| (1, 1, [0, act1], [0, act2]) ->
Lifthenelse(arg, act2, act1)
| (1, 1, [0, act1], []) ->
@ -675,6 +996,23 @@ let combine_constructor arg cstr partial (tag_lambda_list, total1) c_catch =
act2
else
Lifthenelse(arg, act2, Lstaticfail)
| n,m,l,[] ->
if total_loc || m=0 then
call_switcher
(fun i -> Lconst (Const_base (Const_int i)))
nofail arg
(Switch.Int 0) (Switch.Int (n-1))
l
else
Lifthenelse
(Lprim (Pisint,[arg]),
call_switcher
(fun i -> Lconst (Const_base (Const_int i)))
nofail arg
(Switch.Int 0) (Switch.Int (n-1))
l,
Lstaticfail)
| (_, _, _, _) ->
Lswitch(arg, {sw_numconsts = cstr.cstr_consts;
sw_consts = consts;
@ -732,20 +1070,15 @@ let combine_variant row arg partial (tag_lambda_list, total1)
let combine_array arg kind _ (len_lambda_list, total1) c_catch =
let lambda1 =
match len_lambda_list with
[] -> Lstaticfail (* does not happen? *)
| [n, act] ->
Lifthenelse(Lprim(Pintcomp Ceq,
[Lprim(Parraylength kind, [arg]);
Lconst(Const_base(Const_int n))]),
act, Lstaticfail)
| _ ->
let max_len =
List.fold_left (fun m (n, act) -> max m n) 0 len_lambda_list in
Lswitch(Lprim(Parraylength kind, [arg]),
{sw_numblocks = 0; sw_blocks = []; sw_checked = true;
sw_numconsts = max_len + 1; sw_consts = len_lambda_list;
sw_nofail=false}) in
let newvar = Ident.create "len" in
let switch =
call_switcher
lambda_of_int
false (Lvar newvar)
(Switch.Int 0) Switch.TooMuch
len_lambda_list in
bind
Alias newvar (Lprim(Parraylength kind, [arg])) switch in
add_catch (lambda1,false) c_catch
(* Insertion of debugging events *)
@ -791,9 +1124,9 @@ let compile_catch compile_fun repr partial to_catch others =
if others.cases = [] then partial else Partial in
let rec c_rec = function
| [] -> [],compile_fun repr partial others
| (i,m)::rem ->
| (i,vars,m)::rem ->
let c_catch, c_others = c_rec rem in
(i, compile_fun repr partial_catch m)::c_catch,
(i, vars, compile_fun repr partial_catch m)::c_catch,
c_others in
c_rec to_catch
@ -805,6 +1138,56 @@ let compile_test compile_match repr partial divide combine pm =
(compile_list (compile_match repr partial') this_match)
(compile_catch compile_match repr partial to_catch others)
(* Attempt to avoid some useless bindinds by lowering them *)
(* Approximation of v present in lam *)
let rec approx_present v = function
| Lconst _ -> false
| Lstaticfail -> false
| Lstaticraise (_,args) ->
List.exists (fun lam -> approx_present v lam) args
| Lprim (_,args) ->
List.exists (fun lam -> approx_present v lam) args
| Llet (Alias, _, l1, l2) ->
approx_present v l1 || approx_present v l2
| Lvar vv -> Ident.same v vv
| _ -> true
let string_of_lam lam =
Printlambda.lambda Format.str_formatter lam ;
Format.flush_str_formatter ()
let rec lower_bind v arg lam = match lam with
| Lifthenelse (cond, ifso, ifnot) ->
let pcond = approx_present v cond
and pso = approx_present v ifso
and pnot = approx_present v ifnot in
begin match pcond, pso, pnot with
| false, false, false -> lam
| false, true, false ->
Lifthenelse (cond, lower_bind v arg ifso, ifnot)
| false, false, true ->
Lifthenelse (cond, ifso, lower_bind v arg ifnot)
| _,_,_ -> bind Alias v arg lam
end
| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw))
when not (approx_present v ls) ->
Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]})
| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw))
when not (approx_present v ls) ->
Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]})
| Llet (Alias, vv, lv, l) ->
if approx_present v lv then
bind Alias v arg lam
else
Llet (Alias, vv, lv, lower_bind v arg l)
| _ ->
bind Alias v arg lam
let bind_check str v arg lam = match str,arg with
| _, Lvar _ ->bind str v arg lam
| Alias,_ -> lower_bind v arg lam
| _,_ -> bind str v arg lam
let rec compile_match repr partial m = match m with
{ cases = [] } ->
@ -820,8 +1203,12 @@ let rec compile_match repr partial m = match m with
end else
(event_branch repr action, true)
| { args = (arg, str)::argl ; cases = (pat::_, _)::_ } ->
let v,newarg =
match arg with
| Lvar v -> v,arg
| _ ->
let v = name_pattern "match" m.cases in
let newarg = Lvar v in
v,Lvar v in
let pm =
simplify_matching
{ cases = m.cases; args = (newarg, Alias) :: argl } in
@ -830,7 +1217,7 @@ let rec compile_match repr partial m = match m with
repr partial newarg
(upper_left_pattern pm)
pm in
bind str v arg lam, total
bind_check str v arg lam, total
| _ -> assert false
and do_compile_matching repr partial newarg pat pm = match pat.pat_desc with
@ -862,7 +1249,6 @@ and do_compile_matching repr partial newarg pat pm = match pat.pat_desc with
(combine_variant row newarg)
pm
| _ ->
Location.prerr_warning pat.pat_loc (Warnings.Other "ICI") ;
fatal_error "Matching.do_compile_matching"
and compile_no_test divide repr partial pm =
@ -876,11 +1262,9 @@ and compile_no_test divide repr partial pm =
(* The entry points *)
(*
Use the match-compiler infered exhaustiveness information,
*)
(* had toplevel handler when appropriate *)
let check_total loc partial total lambda handler_fun =
let check_total loc total lambda handler_fun =
if total then
lambda
else
@ -891,7 +1275,7 @@ let compile_matching loc repr handler_fun arg pat_act_list partial =
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
args = [arg, Strict] } in
let (lambda, total) = compile_match repr partial pm in
check_total loc partial total lambda handler_fun
check_total loc total lambda handler_fun
let partial_function loc () =
Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
@ -914,7 +1298,6 @@ let for_let loc param pat body =
(* Handling of tupled functions and matches *)
exception Cannot_flatten
let flatten_pattern size p =
match p.pat_desc with
@ -923,16 +1306,36 @@ let flatten_pattern size p =
| _ -> raise Cannot_flatten
let flatten_cases size cases =
List.map (function (pat :: _, act) -> (flatten_pattern size pat, act)
| _ -> assert false)
cases
let rec flat_rec = function
| [] -> [],[]
| ({pat_desc=Tpat_or (_,_)} as pat :: _, act) :: rem ->
let vars =
IdentSet.elements
(IdentSet.inter
(extract_vars IdentSet.empty pat)
(free_variables act)) in
let raise_num = next_raise_count () in
let mk_new_action vs =
Lstaticraise
(raise_num, List.map (fun v -> Lvar v) vs) in
let new_cases,to_catch =
flat_rec
(explode_or_pat None [] mk_new_action rem vars [] pat) in
new_cases,
(raise_num,vars,(act,true))::to_catch
| (pat :: _, act)::rem ->
let new_cases, to_catch = flat_rec rem in
(flatten_pattern size pat, act)::new_cases,
to_catch
| _ -> assert false in
flat_rec cases
let for_tupled_function loc paraml pats_act_list partial =
let pm =
{ cases = pats_act_list;
args = List.map (fun id -> (Lvar id, Strict)) paraml } in
let (lambda, total) = compile_match None partial pm in
check_total loc partial total lambda (partial_function loc)
check_total loc total lambda (partial_function loc)
let for_multiple_match loc paraml pat_act_list partial =
let pm1 =
@ -942,13 +1345,18 @@ let for_multiple_match loc paraml pat_act_list partial =
simplify_matching pm1 in
try
let idl = List.map (fun _ -> Ident.create "match") paraml in
let new_cases, to_catch = flatten_cases (List.length paraml) pm2.cases in
let pm3 =
{ cases = flatten_cases (List.length paraml) pm2.cases;
{ cases = new_cases ;
args = List.map (fun id -> (Lvar id, Alias)) idl } in
let (lambda, total) = compile_match None partial pm3 in
let lambda2 = check_total loc partial total lambda (partial_function loc) in
let (lambda, total) =
add_catch
(compile_match None partial pm3)
(to_catch,(Lstaticfail,true)) in
let lambda2 =
check_total loc total lambda (partial_function loc) in
List.fold_right2 (bind Strict) idl paraml lambda2
with Cannot_flatten ->
let (lambda, total) = compile_match None partial pm2 in
check_total loc partial total lambda (partial_function loc)
check_total loc total lambda (partial_function loc)

1
bytecomp/printinstr.ml
View File

@ -94,6 +94,7 @@ let instruction ppf = function
| Koffsetint n -> fprintf ppf "\toffsetint %i" n
| Koffsetref n -> fprintf ppf "\toffsetref %i" n
| Kisint -> fprintf ppf "\tisint"
| Kisout -> fprintf ppf "\tisout"
| Kgetmethod -> fprintf ppf "\tgetmethod"
| Kstop -> fprintf ppf "\tstop"
| Kevent ev -> fprintf ppf "\tevent %i" ev.ev_char

21
bytecomp/printlambda.ml
View File

@ -144,6 +144,7 @@ let primitive ppf = function
| Parrayrefs _ -> fprintf ppf "array.get"
| Parraysets _ -> fprintf ppf "array.set"
| Pisint -> fprintf ppf "isint"
| Pisout -> fprintf ppf "isout"
| Pbittest -> fprintf ppf "testbit"
| Pbintofint bi -> print_boxed_integer "of_int" ppf bi
| Pintofbint bi -> print_boxed_integer "to_int" ppf bi
@ -236,13 +237,23 @@ let rec lam ppf = function
lam larg switch sw
| Lstaticfail ->
fprintf ppf "exit"
| Lstaticraise i ->
fprintf ppf "exit(%d)" i
| Lstaticraise (i, ls) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
| Lcatch(lbody, lhandler) ->
fprintf ppf "@[<2>(catch@ %a@;<1 -1>with@ %a)@]" lam lbody lam lhandler
| Lstaticcatch(lbody, i, lhandler) ->
fprintf ppf "@[<2>(catch@ %a@;<1 -1>with(%d)@ %a)@]"
lam lbody i lam lhandler
| Lstaticcatch(lbody, (i, vars), lhandler) ->
fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
lam lbody i
(fun ppf vars -> match vars with
| [] -> ()
| _ ->
List.iter
(fun x -> fprintf ppf " %a" Ident.print x)
vars)
vars
lam lhandler
| Ltrywith(lbody, param, lhandler) ->
fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
lam lbody Ident.print param lam lhandler

127
bytecomp/simplif.ml
View File

@ -83,23 +83,43 @@ let rec eliminate_ref id = function
| Lifused(v, e) ->
Lifused(v, eliminate_ref id e)
(* Simplification of lets *)
let simplify_lambda lam =
(* First pass: count the occurrences of all identifiers *)
let occ = Hashtbl.create 83 in
let count_var v =
try
!(Hashtbl.find occ v)
with Not_found ->
0 in
let rec count = function
Lvar v ->
begin try
0
and incr_var v =
try
incr(Hashtbl.find occ v)
with Not_found ->
Hashtbl.add occ v (ref 1)
end
Hashtbl.add occ v (ref 1) in
(* Also count occurrences of (exit n) statements with no arguments *)
let exits = Hashtbl.create 17 in
let count_exit i =
try
!(Hashtbl.find exits i)
with
| Not_found -> 0
and incr_exit i =
try
incr(Hashtbl.find exits i)
with
| Not_found -> Hashtbl.add exits i (ref 1) in
(* And occurences of Lstaticfail, in every staticcatch scope *)
let count_fail = ref (ref 0) in
let at_catch = ref [] in
let rec count = function
| Lvar v -> incr_var v
| Lconst cst -> ()
| Lapply(l1, ll) -> count l1; List.iter count ll
| Lfunction(kind, params, l) -> count l
@ -122,31 +142,60 @@ let simplify_lambda lam =
count body
| Lprim(p, ll) -> List.iter count ll
| Lswitch(l, sw) ->
(* switch may generate Lstaticfail *)
if
(not sw.sw_nofail) &&
(sw.sw_numconsts > List.length sw.sw_consts ||
sw.sw_numblocks > List.length sw.sw_blocks)
then
!count_fail := !(!count_fail) + 2 ;
count l;
List.iter (fun (n, l) -> count l) sw.sw_consts;
List.iter (fun (n, l) -> count l) sw.sw_blocks
| Lstaticfail -> ()
| Lstaticraise _ -> ()
| Lcatch(l1, l2) -> count l1; count l2
| Lstaticcatch(l1, _, l2) -> count l1; count l2
List.iter (fun (n, l) -> count l) sw.sw_blocks ;
| Lstaticfail -> incr !count_fail
| Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls
| Lcatch(l1, l2) as l ->
let save_count_fail = !count_fail in
count_fail := ref 0 ;
count l1;
let this_count = !(!count_fail) in
at_catch := (l,!(!count_fail)) :: !at_catch ;
count_fail := save_count_fail ;
(* If l1 does not contain staticfail,
l2 will be removed, so don't count its variables *)
if this_count > 0 then
count l2
| Lstaticcatch(l1, (i,_), l2) ->
count l1;
(* If l1 does not contain (exit i),
l2 will be removed, so don't count its variables *)
if count_exit i > 0 then
count l2
| Ltrywith(l1, v, l2) -> count l1; count l2
| Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3
| Lsequence(l1, l2) -> count l1; count l2
| Lwhile(l1, l2) -> count l1; count l2
| Lfor(v, l1, l2, dir, l3) -> count l1; count l2; count l3
| Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3
| Lassign(v, l) ->
(* Lalias-bound variables are never assigned, so don't increase
v's refcount *)
count l
| Lsend(m, o, ll) -> List.iter count (m::o::ll)
| Levent(l, ev) -> count l
| Levent(l, _) -> count l
| Lifused(v, l) ->
if count_var v > 0 then count l
in
count lam;
(* Second pass: remove Lalias bindings of unused variables,
and substitute the bindings of variables used exactly once. *)
let subst = Hashtbl.create 83 in
(* Also treat ``catch body with (i) handler''
- if (exit i) does not occur in body, suppress catch
- if (exit i) occurs exactly once in body,
substitute it with handler *)
let subst = Hashtbl.create 83
and subst_exit = Hashtbl.create 17
and subst_fail = ref Lstaticfail in
let rec simplif = function
Lvar v as l ->
begin try
@ -191,10 +240,52 @@ let simplify_lambda lam =
and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks in
Lswitch
(new_l,{sw with sw_consts = new_consts ; sw_blocks = new_blocks})
| Lstaticfail as l -> l
| Lstaticraise _ as l -> l
| Lcatch(l1, l2) -> Lcatch(simplif l1, simplif l2)
| Lstaticcatch(l1, i, l2) -> Lstaticcatch(simplif l1, i, simplif l2)
| Lstaticfail as l -> !subst_fail
| Lstaticraise (i,[]) as l ->
begin try
Hashtbl.find subst_exit i
with
| Not_found -> l
end
| Lstaticraise (i,ls) ->
Lstaticraise (i, List.map simplif ls)
| Lcatch(l1, l2) as l ->
let nfail =
try
List.assq l !at_catch
with
| Not_found -> Misc.fatal_error "Simplif: catch" in
begin match nfail with
| 0 -> simplif l1
| 1 ->
let new_l2 = simplif l2 in
let save_subst_fail = !subst_fail in
subst_fail := new_l2 ;
let r = simplif l1 in
subst_fail := save_subst_fail ;
r
| _ ->
let save_subst_fail = !subst_fail in
subst_fail := Lstaticfail ;
let r = simplif l1 in
subst_fail := save_subst_fail ;
Lcatch (r,simplif l2)
end
| Lstaticcatch (l1,(i,[]),l2) ->
begin match count_exit i with
| 0 -> simplif l1
| 1 ->
Hashtbl.add subst_exit i (simplif l2) ;
simplif l1
| _ ->
Lstaticcatch (simplif l1, (i,[]), simplif l2)
end
| Lstaticcatch(l1, (i,args), l2) ->
begin match count_exit i with
| 0 -> simplif l1
| _ ->
Lstaticcatch (simplif l1, (i,args), simplif l2)
end
| Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
| Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
| Lsequence(Lifused(v, l1), l2) ->

750
bytecomp/switch.ml Normal file
View File

@ -0,0 +1,750 @@
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2000 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. *)
(* *)
(***********************************************************************)
type iext = TooMuch | Int of int
module type S =
sig
type primitive
val eqint : primitive
val neint : primitive
val leint : primitive
val ltint : primitive
val geint : primitive
val gtint : primitive
type act
val default : act
val bind : act -> (act -> act) -> act
val make_offset : act -> int -> act
val make_prim : primitive -> act list -> act
val make_isout : act -> act -> act
val make_if : act -> act -> act -> act
val make_switch :
act -> (int * int * int) array -> act array -> act
end
module Make (Arg : S) =
struct
type l_status = Linter | Lsimple
type t_status =
Linear of l_status | Switch | ToCluster | Empty
let string_of_status = function
| Linear Linter -> "Linter"
| Linear Lsimple -> "L"
| Empty -> "E"
| Switch -> "S"
| ToCluster -> "?"
type 'a inter =
{low : iext ; high : iext ;
icases : (int * int * int) array ;
iacts : 'a array ;
status : t_status}
let prerr_icases t =
prerr_string "{ " ;
for i = 0 to Array.length t-1 do
let l,h,act = t.(i) in
Printf.fprintf stderr "(%d,%d,%d) " l h act
done ;
prerr_string "}"
let string_of_iext = function
| TooMuch -> "oo"
| Int i -> string_of_int i
let prerr_inter i =
Printf.fprintf stderr
"status=%s, low=%s, high=%s, cases="
(string_of_status i.status)
(string_of_iext i.low) (string_of_iext i.high) ;
prerr_icases i.icases
let inter_default _ = function
| 0 -> true
| _ -> false
let is_closed i = match i.low, i.high with
| Int _, Int _ -> true
| _,_ -> false
type 'a t_ctx =
{ctx_low : iext ; ctx_high : iext ; off : int ;
arg : 'a}
let find_staticfail _ = 0
(*
let as_checked i = match i.low, i.high with
| Int _, Int _ ->
let cases = i.icases in
let len = Array.length cases in
let l0,h0,a0 = cases.(0)
and ln,hn,an = cases.(len-1) in
if inter_default i a0 && inter_default i an then
{i with low=TooMuch ; high=TooMuch ;
icases=Array.sub cases 1 (len-2)}
else
i
| TooMuch,Int _ ->
let cases = i.icases in
let len = Array.length cases in
let ln,hn,an = cases.(len-1) in
if inter_default i an then
{i with high=TooMuch ; icases = Array.sub cases 0 (len-1)}
else
i
| Int _,TooMuch ->
let cases = i.icases in
let len = Array.length cases in
let l0,h0,a0 = cases.(0) in
if inter_default i a0 then
{i with low=TooMuch ; icases = Array.sub cases 1 (len-1)}
else
i
| _,_ -> i
*)
let ninters {low=low ; high=high ; icases = cases} =
Array.length cases +
(match low,high with
| Int _, Int _ -> 0
| _,_ -> 1)
let min_key i = match i.low with
| TooMuch ->
let low,_,_ = i.icases.(0) in
low
| Int low -> low
and max_key i = match i.high with
| TooMuch ->
let _,high,_ = i.icases.(Array.length i.icases-1) in
high
| Int high -> high
let nlabels i = max_key i/4 - min_key i/4
let count_bornes i = if is_closed i then 0 else 1
exception NoSuch
let single_values i =
let singles = ref []
and def = ref None
and cases = i.icases in
for i = 0 to Array.length cases-1 do
let low,high,act = cases.(i) in
if low=high then begin
match !def with
| Some def when def=act -> ()
| _ ->
singles := (low,act) :: !singles
end else match !def with
| None ->
def := Some act ;
singles :=
List.filter (fun (_,act0) -> act0 <> act) !singles
| Some def ->
if def <> act then raise NoSuch
done ;
match i.low,i.high,!def,!singles with
| Int _, Int _, None,(_,x)::r -> r,x
| Int _, Int _, Some x,r -> r,x
| _,_,Some x,r when inter_default i x -> r,x
| _,_,None,r -> r,find_staticfail i
| _,_,_,_ -> raise NoSuch
let count_by_action i =
let low = i.low and high = i.high in
let t = Array.create (Array.length i.iacts) (0,0,0) in
let add l h act =
let old_n,old_itests,old_ztests = t.(act) in
t.(act) <-
(old_n+1,
old_itests +
(if l=h then 0
else if Int l = low then 0
else if Int h = high then 0
else 1),
old_ztests +
(if l=h && Int l = low then 1 else 0)) in
Array.iter (fun (l,h,act) -> add l h act) i.icases ;
t
and group_by_action i =
let t = Array.create (Array.length i.iacts) [] in
let add l h act = t.(act) <- (l,h)::t.(act) in
Array.iter (fun (l,h,act) -> add l h act) i.icases ;
t
and low_action i =
let _,_,act = i.icases.(0) in
act
and high_action i =
let cases = i.icases in
let _,_,act = cases.(Array.length cases-1) in
act
let array_iteri_rev f t =
for i = Array.length t-1 downto 0 do
f i t.(i)
done
exception Found of int
let inter_values i =
if is_closed i then begin
let find_max t =
let max = ref (-1) and max_itests = ref (-1) and max_ztests = ref (-1)
and max_act = ref (-1) in
array_iteri_rev
(fun act (n,itests,ztests) ->
if
n > !max ||(* choose action with maximum number of intervals *)
(* then with maximal number of actual interval tests *)
(n = !max && itests > !max_itests) ||
(* then with minimal number of tests against zero *)
(n = !max && itests = !max_itests && ztests < !max_ztests)
then begin
max := n ;
max_itests := itests ;
max_ztests := ztests ;
max_act := act
end) t ;
!max_act in
let max_act = find_max (count_by_action i) in
List.filter
(fun (l,h,act) -> act <> max_act)
(Array.to_list i.icases),
max_act
end else
List.filter
(fun (l,h,act) -> not (inter_default i act))
(Array.to_list i.icases),
find_staticfail i
let count_tests i = match i.icases with
| [| _ |] -> count_bornes i, Lsimple
| _ ->
let count_inter =
try
let l,_ = inter_values i in
List.length l
with
| NoSuch -> 1000
and count_simple =
let cases,low,high = i.icases, i.low, i.high in
let n = Array.length cases-1 in
n + count_bornes i in
if count_inter <= count_simple then
count_inter, Linter
else
count_simple, Lsimple
let make_if_test konst test arg i ifso ifnot =
Arg.make_if
(Arg.make_prim test [arg.arg ; konst (i+arg.off)])
ifso ifnot
let inter_ctx off l h arg =
{off=off ; ctx_low = Int l ; ctx_high = Int h ; arg = arg}
let make_if_inter konst arg l h mk_ifin ifout =
if l=h then
make_if_test konst Arg.neint arg l ifout
(mk_ifin (inter_ctx arg.off l h arg.arg))
else
let new_off = arg.off-l in
Arg.bind
(Arg.make_offset arg.arg (-l))
(fun arg ->
Arg.make_if
(Arg.make_isout (konst (h-l)) arg)
ifout (mk_ifin (inter_ctx new_off l h arg)))
and make_if_inter_last konst arg l h mk_ifin ifout =
if l=h then
make_if_test konst Arg.eqint arg l
(mk_ifin (inter_ctx arg.off l h arg.arg))
ifout
else
let new_off = arg.off-l in
Arg.bind
(Arg.make_offset arg.arg (-l))
(fun arg ->
Arg.make_if
(Arg.make_isout (konst (h-l)) arg)
ifout (mk_ifin (inter_ctx new_off l h arg)))
let make_inters_ifs konst arg ({iacts = acts} as i) =
try
let l,def = inter_values i in
let rec if_rec arg = function
| [] -> acts.(def) arg
| (l1,h1,act1)::rem ->
if Int l1 = arg.ctx_low then
make_if_test konst (if l1=h1 then Arg.neint else Arg.gtint) arg h1
(if_rec {arg with ctx_low=Int (h1+1)} rem)
(acts.(act1) arg)
else if Int h1 = arg.ctx_high then
make_if_test konst (if l1=h1 then Arg.neint else Arg.ltint) arg l1
(if_rec {arg with ctx_high = Int (l1-1)} rem)
(acts.(act1) arg)
else
make_if_inter konst arg l1 h1 acts.(act1) (if_rec arg rem) in
if_rec arg l
with
| NoSuch -> assert false
let make_linear_ifs l_status konst arg ({iacts = acts} as i) =
match l_status with
| Linter -> make_inters_ifs konst arg i
| Lsimple ->
let cases,low,high = i.icases,arg.ctx_low,arg.ctx_high in
let n = Array.length cases-1 in
let rec do_rec arg i =
if i=n then
let _,_,act = cases.(i) in
acts.(act) arg
else
let _,high,act = cases.(i) in
make_if_test konst
Arg.leint arg high (acts.(act) arg)
(do_rec arg (i+1)) in
match low,high with
| TooMuch, TooMuch ->
let l = min_key i
and h = max_key i in
make_if_inter konst arg l h (fun arg -> do_rec arg 0) Arg.default
| TooMuch,_ ->
let l = min_key i in
make_if_test konst Arg.ltint arg l Arg.default (do_rec arg 0)
| _, TooMuch ->
let h = max_key i in
make_if_test konst Arg.gtint arg h Arg.default (do_rec arg 0)
| _,_ -> do_rec arg 0
let special_case i = match i.low, i.high with
| Int 0, Int 2 -> begin match i.icases with
| [| (0,0,act1) ; (1,1,act2) ; (2,2,act3) |] -> act1 <> act3
| _ -> false
end
| _ -> false
exception Ends
exception NoCut of t_status
(*
let debug = ref false
*)
let cut_here i =
let c_if, l_status = count_tests i in
(*
if !debug then
Printf.fprintf stderr "Attempt: %d as %s\n" c_if
(string_of_status (Linear l_status)) ;
*)
if c_if=0 then raise (NoCut Empty) ;
if special_case i then raise (NoCut Switch) ;
if c_if - count_bornes i <= !Clflags.limit_switch then
raise (NoCut (Linear l_status)) ;
let icases = i.icases in
let len = Array.length icases
and c_switch = nlabels i + 1 in
if c_switch <= c_if then raise (NoCut Switch) ;
let r = ref (-1) and max = ref (-1) in
for j = 0 to len-1 do
let low,high,_ = icases.(j) in
if high-low+1 > !max then begin
max := high-low ;
r := j
end
done ;
if len > 2 then begin
let l0,h0,act0 = icases.(0)
and ln,hn,actn = icases.(len-1) in
if
act0 = actn &&
(h0-l0+hn-ln+2 > !max)
then
raise Ends
end ;
!r
let sub_cases from_here len cases =
if len <= 0 then [||]
else
Array.sub cases from_here len
let present act i len cases =
let rec do_rec i =
if i < len then
let _,_,act0 = cases.(i) in
act0=act || do_rec (i+1)
else
false in
do_rec i
let explode_linear i k =
let acts = i.iacts
and cases = i.icases in
let last = Array.length cases-1 in
let rec explode_rec j = match last-j with
| 0 ->
let (l,_,_) as x = cases.(j) in
{i with low = Int l ; icases = [| x |] ; status = Empty}::k
| _ ->
let (l,h,_) as x = cases.(j) in
{i with low = Int l ; high = Int h ;
icases = [| x |] ; status = Empty}::
explode_rec (j+1) in
match cases with
| [| |] | [| _ |] -> {i with status=Empty}::k
| _ ->
let (_,h0,_) as x = cases.(0) in
{i with high = Int h0 ; icases = [| x |] ; status = Empty}::
explode_rec 1
let rec do_cluster i k =
(*
if !debug then begin
prerr_string "++++++++++++++++\nCluster " ; prerr_inter i ;
prerr_endline ""
end ;
*)
let cases = i.icases in
if i.high = TooMuch && inter_default i (low_action i) then
let l0,h0,act0 = cases.(0) in
let rest = sub_cases 1 (Array.length cases-1) cases in
{i with high=Int h0 ; icases = [| cases.(0) |] ; status=Empty}::
do_cluster
{i with low=Int (h0+1) ; icases = rest}
k
else
try
match cases with
| [| _,_,act |] ->
if is_closed i || inter_default i act then
{i with status=Empty}::k
else
let _,status = count_tests i in
raise (NoCut (Linear status))
| _ ->
let j = cut_here i in
let c_low,c_high,c_act = cases.(j) in
if false (* c_low=c_high *) then begin
let left,right =
if j=0 || present c_act 0 j cases then
sub_cases 0 (j+1) cases,
sub_cases (j+1) (Array.length cases-j-1) cases
else
sub_cases 0 j cases,
sub_cases j (Array.length cases-j) cases in
(*
if !debug then begin
prerr_string "Left = " ; prerr_icases left ; prerr_endline "" ;
prerr_string "Right = " ; prerr_icases right ; prerr_endline ""
end ;
*)
do_cluster
{i with high = Int (c_low-1) ; icases=left}
(do_cluster
{i with low = Int c_low ; icases=right} k)
end else begin
let left = sub_cases 0 j cases
and center = [| cases.(j) |]
and right = sub_cases (j+1) (Array.length cases-j-1) cases in
(*
if !debug then begin
prerr_string "Left = " ; prerr_icases left ; prerr_endline "" ;
prerr_string "Center = " ; prerr_icases center ; prerr_endline "" ;
prerr_string "Right = " ; prerr_icases right ; prerr_endline ""
end ;
*)
if j=0 then
{i with low=i.low ; high = Int c_high ;
icases = center ; status=Empty}::
do_cluster
{i with low = Int (c_high+1) ; high=i.high ; icases = right} k
else if j = Array.length cases-1 then
do_cluster
{i with low = i.low ; high= Int (c_low-1) ; icases = left}
({i with low = Int c_low ; high = i.high ;
icases=center ; status=Empty}::k)
else
do_cluster
{i with low = i.low ; high= Int (c_low-1) ; icases = left}
({i with low = Int c_low ; high = Int c_high ;
icases=center ; status=Empty}::
do_cluster
{i with low = Int (c_high+1) ; high=i.high ; icases = right}
k)
end
with
| NoCut status ->
(*
if !debug then
Printf.fprintf stderr "%s\n" (string_of_status status) ;
*)
begin match status with
| Linear _ -> explode_linear i k
| _ -> {i with status=status}::k
end
| Ends ->
let cases = i.icases in
let len = Array.length cases in
let _,h0,act0 = cases.(0)
and center = sub_cases 1 (len-2) cases
and ln,_,actn = cases.(len-1) in
(*
if !debug then begin
prerr_string "Left = " ; prerr_icases [| cases.(0) |] ;
prerr_endline "" ;
prerr_string "Center = " ; prerr_icases center ; prerr_endline "" ;
prerr_string "Right = " ; prerr_icases [| cases.(len-1) |] ;
prerr_endline ""
end ;
*)
{i with high = Int h0 ; status = Empty ; icases = [| cases.(0) |]}::
do_cluster
{i with low = Int (h0+1) ; high = Int (ln-1) ; icases = center}
({i with low = Int ln ; status = Empty ; icases = [| cases.(len-1) |]}::k)
let do_merge_clusters i1 i2 =
{low=i1.low ; high = i2.high ;
icases = Array.append i1.icases i2.icases ;
iacts= i1.iacts ;
status = ToCluster}
exception NoMerge
let merge_clusters i1 i2 = match i1.status, i2.status with
| Linear _, Linear _ -> do_merge_clusters i1 i2
| _,_ -> raise NoMerge
let simpl_clusters l =
match l with
| [] -> l
| [_] -> l
| _ ->
(*
if !debug then begin
prerr_endline "------------------- Clusters --------------" ;
List.iter
(fun i -> prerr_inter i ; prerr_endline "") l
end ;
*)
l
let cluster i =
simpl_clusters (do_cluster i [])
let fail_out inter =
let t = inter.icases in
let j = ref 1
and len = Array.length t in
let new_low =
let _,high,act0 as all0 = t.(0) in
if inter_default inter act0 then begin
t.(0) <- t.(1) ;
Int (high+1)
end else begin
inter.low
end in
for i = 1 to Array.length t-1 do
let (_,high,act as all) = t.(i)
and low0,_,act0 = t.(!j-1) in
if inter_default inter act || act0=act then
t.(!j-1) <- low0, high, act0
else begin
t.(!j) <- all ;
incr j
end
done ;
let new_t =
if !j <> len then
Array.sub t 0 !j
else
t in
let _,new_high,_ = new_t.(!j-1) in
{inter with low = new_low ; high = Int new_high ; icases = new_t}
let as_int_int_acts i =
let acts = i.iacts in
Array.map
(fun (l,h,act) -> (l,h,acts.(act)))
i.icases
let comp_leaf konst arg i = match i.status with
| Linear l_status -> make_linear_ifs l_status konst arg i
| Empty ->
let _,_,act = i.icases.(0) in
i.iacts.(act) arg
| Switch ->
let min_key = min_key i in
let mk_switch arg =
let acts = Array.map (fun act -> act arg) i.iacts in
Arg.make_switch arg.arg i.icases acts in
mk_switch {arg with arg = Arg.make_offset arg.arg (-arg.off-min_key)}
| ToCluster -> Misc.fatal_error "Matching.comp_leaf"
type 'a action = | Unique of 'a | Shared of int * 'a
let same_cluster_action c1 c2 = match c1.status, c2 with
| Empty, Shared (i2,_) -> low_action c1=i2
| _,_ -> false
let cluster_clusters konst arg cls =
let actions = ref [Shared (0, cls.(0).iacts.(0))]
and n_actions = ref 1 in
let rec store_rec act i = function
| [] -> begin match act.status with
| Empty ->
let index = low_action act in
[Shared (index, act.iacts.(index))]
| _ -> [Unique (fun arg -> comp_leaf konst arg act)]
end
| act0::rem ->
if same_cluster_action act act0 then
raise (Found i)
else
act0::store_rec act (i+1) rem in
let store act =
try
actions := store_rec act 0 !actions ;
let r = !n_actions in
incr n_actions ;
r
with
| Found i -> i in
let cases =
Array.map
(fun c -> min_key c, max_key c,store c) cls in
let low = cls.(0).low
and high = cls.(Array.length cls-1).high in
{high = high ; low = low ;
icases = cases ;
iacts = Array.map
(function
| Unique act -> act
| Shared (_,act) -> act)
(Array.of_list !actions) ;
status = ToCluster}
let final_tests konst arg cl =
let rec comp_tree cl =
let n,status = count_tests cl in
(*
if !debug then begin
prerr_inter cl ;
Printf.fprintf stderr "\nFinally : %d tests as %s\n" n
(string_of_status (Linear status)) ;
flush stderr
end ;
*)
if n <= !Clflags.limit_tree then
comp_leaf konst
{arg with ctx_low = cl.low ; ctx_high = cl.high}
{cl with status = Linear status}
else
let cases = cl.icases in
let len = Array.length cases in
let half = match cl.low, cl.high with
| TooMuch,Int _ -> (len-1)/2
| Int _, TooMuch -> (len+1)/2
| _,_ -> len/2 in
let left = sub_cases 0 half cases
and right = sub_cases half (len-half) cases in
let _,key,_ = left.(half-1) in
make_if_test konst
Arg.leint arg key
(comp_tree {cl with high=Int key ; icases = left})
(comp_tree {cl with low=Int (key+1) ; icases=right}) in
comp_tree cl
let comp_clusters konst arg l =
let cls = Array.of_list l in
let cl = cluster_clusters konst arg cls in
final_tests konst arg cl
let comp_inter konst arg i = comp_clusters konst arg (cluster i)
let zyva konst arg low high cases acts =
let cl =
{low = low ; high = high ;
icases = cases ;
iacts=Array.map (fun act -> (fun _ -> act)) acts ;
status = ToCluster} in
(*
let old_debug = !debug in
if fst (count_tests cl) > 2 then debug := true ;
if !debug then begin
prerr_endline "******** zyva **********" ;
prerr_inter cl ;
prerr_endline ""
end ;
*)
let r = comp_inter konst
{ctx_low=low ; ctx_high=high ; off=0 ; arg=arg} cl in
(*
if !debug then prerr_endline "************************" ;
debug := old_debug ;
*)
r
end

76
bytecomp/switch.mli Normal file
View File

@ -0,0 +1,76 @@
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2000 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. *)
(* *)
(***********************************************************************)
(*
This module transforms generic switches in combinations
of if tests and switches.
*)
(* integer plus infinity, for interval limits *)
type iext = TooMuch | Int of int
(* Arguments to the Make functor *)
module type S =
sig
(* type of basic tests *)
type primitive
(* basic tests themselves *)
val eqint : primitive
val neint : primitive
val leint : primitive
val ltint : primitive
val geint : primitive
val gtint : primitive
(* type of actions *)
type act
(* default action *)
val default : act
(* Various constructors, for making a binder,
adding one integer, etc. *)
val bind : act -> (act -> act) -> act
val make_offset : act -> int -> act
val make_prim : primitive -> act list -> act
val make_isout : act -> act -> act
val make_if : act -> act -> act -> act
(* construct an actual switch :
make_switch arg cases acts
NB: cases is in the interval form *)
val make_switch :
act -> (int * int * int) array -> act array -> act
end
(*
Make.zyva mk_const arg low high cases actions where
- mk_const takes an integer sends a constant action.
- arg is the argument of the switch.
- low, high are the interval limits.
- cases is a list of sub-interval and action indices
- action is an array of actions.
All these arguments specify a switch construct and zyva
returns an action that performs the switch,
*)
module Make :
functor (Arg : S) ->
sig
val zyva :
(int -> Arg.act) ->
Arg.act ->
iext -> iext ->
(int * int * int) array ->
Arg.act array ->
Arg.act
end

1
bytecomp/translcore.ml
View File

@ -276,6 +276,7 @@ let transl_prim prim args =
with Not_found ->
Pccall prim
(* Eta-expand a primitive without knowing the types of its arguments *)
let transl_primitive p =

6
byterun/fix_code.c
View File

@ -108,8 +108,9 @@ void thread_code (code_t code, asize_t len)
/* Instructions with two operands */
l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] =
l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = 2;
l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] =
l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] =
l[BULTINT] = l[BUGEINT] = 2;
len /= sizeof(opcode_t);
for (p = code; p < code + len; /*nothing*/) {
opcode_t instr = *p;
@ -117,6 +118,7 @@ void thread_code (code_t code, asize_t len)
fatal_error_arg ("Fatal error in fix_code: bad opcode (%lx)\n",
(char *)(long)instr);
}
*p++ = (opcode_t)(instr_table[instr] - instr_base);
if (instr == SWITCH) {
uint32 sizes = *p++;

2
byterun/instrtrace.c
View File

@ -54,6 +54,8 @@ void disasm_instr(pc)
/* Instructions with two operands */
case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD:
case GETGLOBALFIELD: case MAKEBLOCK:
case BEQ: case BNEQ: case BLTINT: case BLEINT: case BGTINT: case BGEINT:
case BULTINT: case BUGEINT:
printf(" %d, %d\n", pc[0], pc[1]); break;
/* Instructions with a C primitive as operand */
case C_CALL1: case C_CALL2: case C_CALL3: case C_CALL4: case C_CALL5:

5
byterun/instruct.h
View File

@ -46,5 +46,8 @@ enum instructions {
EQ, NEQ, LTINT, LEINT, GTINT, GEINT,
OFFSETINT, OFFSETREF, ISINT,
GETMETHOD,
STOP, EVENT, BREAK
BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT,
ULTINT, UGEINT,
BULTINT, BUGEINT, STOP,
EVENT, BREAK,
};

37
byterun/interp.c
View File

@ -13,7 +13,7 @@
/* $Id$ */
/* The bytecode interpreter */
#include<stdio.h>
#include "alloc.h"
#include "callback.h"
#include "debugger.h"
@ -928,16 +928,35 @@ value interprete(code_t prog, asize_t prog_size)
Instruct(ASRINT):
accu = (value)((((long) accu - 1) >> Long_val(*sp++)) | 1); Next;
#define Integer_comparison(opname,tst) \
#define Integer_comparison(sign,opname,tst) \
Instruct(opname): \
accu = Val_int((long) accu tst (long) *sp++); Next;
accu = Val_int((sign long) accu tst (sign long) *sp++); Next;
Integer_comparison(EQ, ==)
Integer_comparison(NEQ, !=)
Integer_comparison(LTINT, <)
Integer_comparison(LEINT, <=)
Integer_comparison(GTINT, >)
Integer_comparison(GEINT, >=)
Integer_comparison(signed,EQ, ==)
Integer_comparison(signed,NEQ, !=)
Integer_comparison(signed,LTINT, <)
Integer_comparison(signed,LEINT, <=)
Integer_comparison(signed,GTINT, >)
Integer_comparison(signed,GEINT, >=)
Integer_comparison(unsigned,ULTINT, <)
Integer_comparison(unsigned,UGEINT, >=)
#define Integer_branch_comparison(sign,opname,tst,debug) \
Instruct(opname): \
if ( *pc++ tst ((sign long)Long_val(accu))) { \
pc += *pc ; \
} else { \
pc++ ; \
} ; Next;
Integer_branch_comparison(signed,BEQ, ==, "==")
Integer_branch_comparison(signed,BNEQ, !=, "!=")
Integer_branch_comparison(signed,BLTINT, <, "<")
Integer_branch_comparison(signed,BLEINT, <=, "<=")
Integer_branch_comparison(signed,BGTINT, >, ">")
Integer_branch_comparison(signed,BGEINT, >=, ">=")
Integer_branch_comparison(unsigned,BULTINT, <, "<")
Integer_branch_comparison(unsigned,BUGEINT, >=, ">=")
Instruct(OFFSETINT):
accu += *pc << 1;

3
driver/optmain.ml
View File

@ -146,6 +146,9 @@ let main () =
"-dlinear", Arg.Set dump_linear, " (undocumented)";
"-dstartup", Arg.Set keep_startup_file, " (undocumented)";
"-switch", Arg.Int (fun i -> limit_switch := i), " (undocumented)";
"-tree", Arg.Int (fun i -> limit_tree := i), " (undocumented)";
"-", Arg.String (process_file ppf),
"<file> Treat <file> as a file name (even if it starts with `-')"
] (process_file ppf) usage;

6
tools/Makefile
View File

@ -26,13 +26,13 @@ all: ocamldep ocamlprof ocamlcp ocamlmktop
# The dependency generator
CAMLDEP=ocamldep.cmo
CAMLDEP_OBJ=ocamldep.cmo
CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
linenum.cmo warnings.cmo location.cmo longident.cmo pstream.cmo \
syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
ocamldep: $(CAMLDEP)
$(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP)
ocamldep: $(CAMLDEP_OBJ)
$(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ)
clean::
rm -f ocamldep

2
tools/cvt_emit.mll
View File

@ -79,4 +79,6 @@ and command = parse
{
let _ = main(Lexing.from_channel stdin)
let _ = exit (0)
}

64
typing/parmatch.ml
View File

@ -710,35 +710,6 @@ let get_mins ps =
else select_rec (p::r) ps in
select_rec [] (select_rec [] ps)
let rec compat p q = match p.pat_desc,q.pat_desc with
| Tpat_alias (p,_),_ -> compat p q
| _,Tpat_alias (q,_) -> compat p q
| (Tpat_any|Tpat_var _),_ -> true
| _,(Tpat_any|Tpat_var _) -> true
| Tpat_or (p1,p2),_ -> compat p1 q || compat p2 q
| _,Tpat_or (q1,q2) -> compat p q1 || compat p q2
| Tpat_constant c1, Tpat_constant c2 -> c1=c2
| Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) ->
c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
l1=l2 && compat p1 p2
| Tpat_variant (l1,None,_), Tpat_variant(l2,None,_) -> l1 = l2
| Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false
| Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false
| Tpat_record l1,Tpat_record l2 ->
let ps,qs = records_args l1 l2 in
compats ps qs
| Tpat_array ps, Tpat_array qs ->
List.length ps = List.length qs &&
compats ps qs
| _,_ -> assert false
and compats ps qs = match ps,qs with
| [], [] -> true
| p::ps, q::qs -> compat p q && compats ps qs
| _,_ -> assert false
(*************************************)
(* Values as patterns pretty printer *)
(*************************************)
@ -841,6 +812,41 @@ let top_pretty ppf v =
fprintf ppf "@[%a@]@?" pretty_val v
let rec compat p q = match p.pat_desc,q.pat_desc with
| Tpat_alias (p,_),_ -> compat p q
| _,Tpat_alias (q,_) -> compat p q
| (Tpat_any|Tpat_var _),_ -> true
| _,(Tpat_any|Tpat_var _) -> true
| Tpat_or (p1,p2),_ -> compat p1 q || compat p2 q
| _,Tpat_or (q1,q2) -> compat p q1 || compat p q2
| Tpat_constant c1, Tpat_constant c2 -> c1=c2
| Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
| Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) ->
c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
l1=l2 && compat p1 p2
| Tpat_variant (l1,None,_), Tpat_variant(l2,None,_) -> l1 = l2
| Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false
| Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false
| Tpat_record l1,Tpat_record l2 ->
let ps,qs = records_args l1 l2 in
compats ps qs
| Tpat_array ps, Tpat_array qs ->
List.length ps = List.length qs &&
compats ps qs
| _,_ ->
top_pretty Format.str_formatter p ;
prerr_endline (Format.flush_str_formatter ()) ;
top_pretty Format.str_formatter q ;
prerr_endline (Format.flush_str_formatter ()) ;
assert false
and compats ps qs = match ps,qs with
| [], [] -> true
| p::ps, q::qs -> compat p q && compats ps qs
| _,_ -> assert false
(******************************)
(* Entry points *)
(* - Partial match *)

64
typing/typecore.ml
View File

@ -31,7 +31,7 @@ type error =
| Label_mismatch of Longident.t * (type_expr * type_expr) list
| Pattern_type_clash of (type_expr * type_expr) list
| Multiply_bound_variable
| Orpat_not_closed
| Orpat_vars of Ident.t
| Expr_type_clash of (type_expr * type_expr) list
| Apply_non_function of type_expr
| Apply_wrong_label of label * type_expr
@ -110,12 +110,47 @@ let unify_pat' env pat expected_ty =
let pattern_variables = ref ([]: (Ident.t * type_expr) list)
let enter_variable loc name ty =
if List.exists (fun (id, ty) -> Ident.name id = name) !pattern_variables
if List.exists (fun (id, _) -> Ident.name id = name) !pattern_variables
then raise(Error(loc, Multiply_bound_variable));
let id = Ident.create name in
pattern_variables := (id, ty) :: !pattern_variables;
id
let sort_pattern_variables vs =
List.sort
(fun (x,_) (y,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
vs
let enter_orpat_variables loc env p1_vs p2_vs =
(* unify_vars operate on sorted lists *)
let p1_vs = sort_pattern_variables p1_vs
and p2_vs = sort_pattern_variables p2_vs in
let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
| (x1,t1)::rem1, (x2,t2)::rem2 when Ident.equal x1 x2 ->
if x1==x2 then
unify_vars rem1 rem2
else begin
begin try
unify_strict env t1 t2
with
| Unify trace ->
raise(Error(loc, Pattern_type_clash(trace)))
end ;
(x2,x1)::unify_vars rem1 rem2
end
| [],[] -> []
| (x,_)::_, [] -> raise (Error (loc, Orpat_vars x))
| [],(x,_)::_ -> raise (Error (loc, Orpat_vars x))
| (x,_)::_, (y,_)::_ ->
let min_var =
if Ident.name x < Ident.name y then x
else y in
raise (Error (loc, Orpat_vars min_var)) in
unify_vars p1_vs p2_vs
let rec build_as_type env p =
match p.pat_desc with
Tpat_alias(p1, _) -> build_as_type env p1
@ -216,16 +251,16 @@ let rec type_pat env sp =
pat_loc = sp.ppat_loc;
pat_type = ty;
pat_env = env }
| Ppat_alias(sp, name) ->
let p = type_pat env sp in
| Ppat_alias(sq, name) ->
let q = type_pat env sq in
begin_def ();
let ty_var = build_as_type env p in
let ty_var = build_as_type env q in
end_def ();
generalize ty_var;
let id = enter_variable sp.ppat_loc name ty_var in
{ pat_desc = Tpat_alias(p, id);
{ pat_desc = Tpat_alias(q, id);
pat_loc = sp.ppat_loc;
pat_type = p.pat_type;
pat_type = q.pat_type;
pat_env = env }
| Ppat_constant cst ->
{ pat_desc = Tpat_constant cst;
@ -314,11 +349,15 @@ let rec type_pat env sp =
| Ppat_or(sp1, sp2) ->
let initial_pattern_variables = !pattern_variables in
let p1 = type_pat env sp1 in
let p1_variables = !pattern_variables in
pattern_variables := initial_pattern_variables ;
let p2 = type_pat env sp2 in
if !pattern_variables != initial_pattern_variables then
raise(Error(sp.ppat_loc, Orpat_not_closed));
let p2_variables = !pattern_variables in
unify_pat env p2 p1.pat_type;
{ pat_desc = Tpat_or(p1, p2);
let alpha_env =
enter_orpat_variables sp.ppat_loc env p1_variables p2_variables in
pattern_variables := p1_variables ;
{ pat_desc = Tpat_or(p1, alpha_pat alpha_env p2);
pat_loc = sp.ppat_loc;
pat_type = p1.pat_type;
pat_env = env }
@ -1361,8 +1400,9 @@ let report_error ppf = function
fprintf ppf "but is here used to match values of type")
| Multiply_bound_variable ->
fprintf ppf "This variable is bound several times in this matching"
| Orpat_not_closed ->
fprintf ppf "A pattern with | must not bind variables"
| Orpat_vars id ->
fprintf ppf "Variable %s must occur on both sides of this | pattern"
(Ident.name id)
| Expr_type_clash trace ->
report_unification_error ppf trace
(function ppf ->

2
typing/typecore.mli
View File

@ -61,7 +61,7 @@ type error =
| Label_mismatch of Longident.t * (type_expr * type_expr) list
| Pattern_type_clash of (type_expr * type_expr) list
| Multiply_bound_variable
| Orpat_not_closed
| Orpat_vars of Ident.t
| Expr_type_clash of (type_expr * type_expr) list
| Apply_non_function of type_expr
| Apply_wrong_label of label * type_expr

39
typing/typedtree.ml
View File

@ -161,7 +161,9 @@ let rec bound_idents pat =
| Tpat_record lbl_pat_list ->
List.iter (fun (lbl, pat) -> bound_idents pat) lbl_pat_list
| Tpat_array patl -> List.iter bound_idents patl
| Tpat_or(p1, p2) -> bound_idents p1; bound_idents p2
| Tpat_or(p1, _) ->
(* Invariant : both arguments binds the same variables *)
bound_idents p1
let pat_bound_idents pat =
idents := []; bound_idents pat; let res = !idents in idents := []; res
@ -173,3 +175,38 @@ let rev_let_bound_idents pat_expr_list =
let let_bound_idents pat_expr_list =
List.rev(rev_let_bound_idents pat_expr_list)
let alpha_var env id = List.assoc id env
let rec alpha_pat env p = match p.pat_desc with
| Tpat_var id -> (* note the ``Not_found'' case *)
{p with pat_desc =
try Tpat_var (alpha_var env id) with
| Not_found -> Tpat_any}
| Tpat_alias (p, id) ->
let new_p = alpha_pat env p in
begin try
{p with pat_desc = Tpat_alias (new_p, alpha_var env id)}
with
| Not_found -> new_p
end
| Tpat_tuple pats ->
{p with pat_desc =
Tpat_tuple (List.map (alpha_pat env) pats)}
| Tpat_record lpats ->
{p with pat_desc =
Tpat_record (List.map (fun (l,p) -> l,alpha_pat env p) lpats)}
| Tpat_construct (c,pats) ->
{p with pat_desc =
Tpat_construct (c,List.map (alpha_pat env) pats)}
| Tpat_array pats ->
{p with pat_desc =
Tpat_array (List.map (alpha_pat env) pats)}
| Tpat_variant (x1, Some p, x2) ->
{p with pat_desc =
Tpat_variant (x1, Some (alpha_pat env p), x2)}
| Tpat_or (p1,p2) ->
{p with pat_desc =
Tpat_or (alpha_pat env p1, alpha_pat env p2)}
| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> p

5
typing/typedtree.mli
View File

@ -146,6 +146,9 @@ and module_coercion =
(* Auxiliary functions over the a.s.t. *)
val pat_bound_idents: pattern -> Ident.t list
val let_bound_idents: (pattern * expression) list -> Ident.t list
val rev_let_bound_idents: (pattern * expression) list -> Ident.t list
(* Alpha conversion of patterns *)
val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern

3
utils/clflags.ml
View File

@ -70,3 +70,6 @@ let dump_combine = ref false (* -dcombine *)
let native_code = ref false (* set to true under ocamlopt *)
let inline_threshold = ref 10
let limit_tree = ref 3
and limit_switch = ref 2

2
utils/config.mlp
View File

@ -12,7 +12,7 @@
(* $Id$ *)
let version = "3.00+14 (2000-09-06)"
let version = "3.00+15 (2000-10-02)"
let standard_library =
try