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

141
bytecomp/bytegen.ml
View File

@ -43,7 +43,7 @@ let add_var id pos env =
let rec add_vars idlist pos env =
match idlist with
[] -> env
| id :: rem -> add_vars rem (pos + 1) (add_var id pos env)
| id :: rem -> add_vars rem (pos + 1) (add_var id pos env)
(**** Examination of the continuation ****)
@ -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
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
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
Kbranchif label :: cont
| _ ->
match code_as_jump ifnot sz with
| Some label ->
let cont = comp_expr env ifso sz cont in
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) 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

778
bytecomp/matching.ml
View File

File diff suppressed because it is too large Load Diff

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

129
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
0
and incr_var v =
try
incr(Hashtbl.find occ v)
with Not_found ->
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 ->
begin try
incr(Hashtbl.find occ v)
with Not_found ->
Hashtbl.add occ v (ref 1)
end
| 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:

7
byterun/instruct.h
View File

@ -44,7 +44,10 @@ enum instructions {
NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT,
ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT,
EQ, NEQ, LTINT, LEINT, GTINT, GEINT,
OFFSETINT, OFFSETREF, ISINT,
OFFSETINT, OFFSETREF, ISINT,
GETMETHOD,
STOP, EVENT, BREAK
BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT,
ULTINT, UGEINT,
BULTINT, BUGEINT, STOP,
EVENT, BREAK,
};

39
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;
@ -951,7 +970,7 @@ value interprete(code_t prog, asize_t prog_size)
Instruct(ISINT):
accu = Val_long(accu & 1);
Next;
/* Object-oriented operations */
#define Lookup(obj, lab) \

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