summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile3
-rw-r--r--asmcomp/cmm.mli6
-rw-r--r--asmcomp/emit_alpha.mlp14
-rw-r--r--asmcomp/emit_i386.mlp14
-rw-r--r--asmcomp/emit_sparc.mlp14
-rw-r--r--bytecomp/codegen.ml4
-rw-r--r--bytecomp/emitcode.ml7
-rw-r--r--bytecomp/instruct.ml2
-rw-r--r--bytecomp/instruct.mli4
-rw-r--r--bytecomp/lambda.ml1
-rw-r--r--bytecomp/lambda.mli1
-rw-r--r--bytecomp/printinstr.ml2
-rw-r--r--bytecomp/printlambda.ml1
-rw-r--r--bytecomp/translcore.ml3
-rw-r--r--byterun/instruct.h4
-rw-r--r--byterun/interp.c91
-rw-r--r--byterun/mlvalues.h2
-rw-r--r--stdlib/obj.ml1
-rw-r--r--stdlib/obj.mli1
-rw-r--r--stdlib/set.ml5
-rw-r--r--stdlib/set.mli1
-rw-r--r--testasmcomp/Makefile14
-rw-r--r--toplevel/printval.ml19
-rw-r--r--toplevel/topdirs.ml26
24 files changed, 134 insertions, 106 deletions
diff --git a/Makefile b/Makefile
index 11b4e4efb5..20521fde52 100644
--- a/Makefile
+++ b/Makefile
@@ -65,8 +65,7 @@ all: runtime camlc camllex camlyacc library camltop
world: coldstart all
# Complete bootstrapping cycle
-bootstrap: backup promote-cross clean camlc camllex library-cross \
- promote clean all compare
+bootstrap: backup promote-cross clean camlc camllex library-cross promote clean all compare
# backup save the bootstrap compiler
# promote-cross promote the new compiler but keep the old runtime
# (runs on boot/camlrun, produces code for byterun/camlrun)
diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli
index 1ab22144e3..bcb03b0b47 100644
--- a/asmcomp/cmm.mli
+++ b/asmcomp/cmm.mli
@@ -80,12 +80,14 @@ type fundecl =
fun_body: expression }
type data_item =
- Clabel of string
+ Cdefine_symbol of string
+ | Cdefine_label of int
| Cint8 of int
| Cint16 of int
| Cint of int
| Cfloat of string
- | Caddress of string
+ | Csymbol_address of string
+ | Clabel_address of int
| Cstring of string
| Cskip of int
| Calign of int
diff --git a/asmcomp/emit_alpha.mlp b/asmcomp/emit_alpha.mlp
index f6a61714be..cc7689bd98 100644
--- a/asmcomp/emit_alpha.mlp
+++ b/asmcomp/emit_alpha.mlp
@@ -548,9 +548,11 @@ let fundecl fundecl =
(* Emission of data *)
let emit_item = function
- Clabel lbl ->
- ` .globl {emit_symbol lbl}\n`;
- `{emit_symbol lbl}:\n`
+ Cdefine_symbol s ->
+ ` .globl {emit_symbol s}\n`;
+ `{emit_symbol s}:\n`
+ | Cdefine_label lbl ->
+ `{emit_label (10000 + lbl)}:\n`
| Cint8 n ->
` .byte {emit_int n}\n`
| Cint16 n ->
@@ -559,8 +561,10 @@ let emit_item = function
` .quad {emit_int n}\n`
| Cfloat f ->
` .double {emit_string f}\n`
- | Caddress lbl ->
- ` .quad {emit_symbol lbl}\n`
+ | Csymbol_address s ->
+ ` .quad {emit_symbol s}\n`
+ | Clabel_address lbl ->
+ ` .quad {emit_label (10000 + lbl)}\n`
| Cstring s ->
let l = String.length s in
if l = 0 then ()
diff --git a/asmcomp/emit_i386.mlp b/asmcomp/emit_i386.mlp
index e7816f4f27..8f17fbc793 100644
--- a/asmcomp/emit_i386.mlp
+++ b/asmcomp/emit_i386.mlp
@@ -447,9 +447,11 @@ let fundecl fundecl =
(* Emission of data *)
let emit_item = function
- Clabel lbl ->
- ` .globl _{emit_symbol lbl}\n`;
- `_{emit_symbol lbl}:\n`
+ Cdefine_symbol s ->
+ ` .globl _{emit_symbol s}\n`;
+ `_{emit_symbol s}:\n`
+ | Cdefine_label lbl ->
+ `{emit_label (10000 + lbl)}:\n`
| Cint8 n ->
` .byte {emit_int n}\n`
| Cint16 n ->
@@ -458,8 +460,10 @@ let emit_item = function
` .long {emit_int n}\n`
| Cfloat f ->
` .double {emit_string f}\n`
- | Caddress lbl ->
- ` .long _{emit_symbol lbl}\n`
+ | Csymbol_address s ->
+ ` .long _{emit_symbol s}\n`
+ | Clabel_address lbl ->
+ ` .long {emit_label (10000 + lbl)}\n`
| Cstring s ->
let l = String.length s in
if l = 0 then ()
diff --git a/asmcomp/emit_sparc.mlp b/asmcomp/emit_sparc.mlp
index ae6c00a5bb..5b005ea597 100644
--- a/asmcomp/emit_sparc.mlp
+++ b/asmcomp/emit_sparc.mlp
@@ -523,9 +523,11 @@ let fundecl fundecl =
(* Emission of data *)
let emit_item = function
- Clabel lbl ->
- ` .global _{emit_symbol lbl}\n`;
- `_{emit_symbol lbl}:\n`
+ Cdefine_symbol s ->
+ ` .global _{emit_symbol s}\n`;
+ `_{emit_symbol s}:\n`
+ | Cdefine_label lbl ->
+ `{emit_label (lbl + 10000)}:\n`
| Cint8 n ->
` .byte {emit_int n}\n`
| Cint16 n ->
@@ -534,8 +536,10 @@ let emit_item = function
` .word {emit_int n}\n`
| Cfloat f ->
` .double 0r{emit_string f}\n`
- | Caddress lbl ->
- ` .word _{emit_symbol lbl}\n`
+ | Csymbol_address s ->
+ ` .word _{emit_symbol s}\n`
+ | Clabel_address s ->
+ ` .word {emit_label (lbl + 10000)}\n`
| Cstring s ->
let l = String.length s in
if l = 0 then ()
diff --git a/bytecomp/codegen.ml b/bytecomp/codegen.ml
index 0dadbbe508..0f2a88f1b1 100644
--- a/bytecomp/codegen.ml
+++ b/bytecomp/codegen.ml
@@ -169,7 +169,8 @@ let rec comp_expr env exp sz cont =
comp_expr new_env body sz (add_pop ndecl cont)
| (id, exp, blocksize) :: rem ->
comp_expr new_env exp sz
- (Kpush :: Kacc i :: Kupdate :: comp_decl new_env sz (i-1) rem) in
+ (Kpush :: Kacc i :: Kupdate blocksize ::
+ comp_decl new_env sz (i-1) rem) in
let rec comp_init new_env sz = function
[] ->
comp_decl new_env sz ndecl decl
@@ -225,7 +226,6 @@ let rec comp_expr env exp sz cont =
match p with
Pgetglobal id -> Kgetglobal id
| Psetglobal id -> Ksetglobal id
- | Pupdate -> Kupdate
| Pintcomp cmp -> Kintcomp cmp
| Pmakeblock tag -> Kmakeblock(List.length args, tag)
| Pfield n -> Kgetfield n
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index fe81650f83..1fa60e6497 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -132,7 +132,7 @@ let emit_instr = function
| Kacc n ->
if n < 8 then out(opACC0 + n) else (out opACC; out_int n)
| Kenvacc n ->
- if n < 4 then out(opENVACC0 + n) else (out opENVACC; out_int n)
+ if n < 4 then out(opENVACC1 + n) else (out opENVACC; out_int (n+1))
| Kpush ->
out opPUSH
| Kpop n ->
@@ -175,7 +175,7 @@ let emit_instr = function
| Ksetfield n ->
if n < 4 then out(opSETFIELD0 + n) else (out opSETFIELD; out_int n)
| Kdummy n -> out opDUMMY; out_int n
- | Kupdate -> out opUPDATE
+ | Kupdate n -> out opUPDATE
| Kvectlength -> out opVECTLENGTH
| Kgetvectitem -> out opGETVECTITEM
| Ksetvectitem -> out opSETVECTITEM
@@ -228,7 +228,8 @@ let rec emit = function
if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
emit c
| Kpush :: Kenvacc n :: c ->
- if n < 4 then out(opPUSHENVACC0 + n) else (out opPUSHENVACC; out_int n);
+ if n < 4 then out(opPUSHENVACC1 + n)
+ else (out opPUSHENVACC; out_int (n+1));
emit c
| Kpush :: Kgetglobal id :: Kgetfield n :: c ->
out opPUSHGETGLOBALFIELD; slot_for_getglobal id; out n; emit c
diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
index 1ba36990b7..1c91c03e9e 100644
--- a/bytecomp/instruct.ml
+++ b/bytecomp/instruct.ml
@@ -24,7 +24,7 @@ type instruction =
| Kgetfield of int
| Ksetfield of int
| Kdummy of int
- | Kupdate
+ | Kupdate of int
| Kvectlength
| Kgetvectitem
| Ksetvectitem
diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
index 55fee05bb7..4279e0c713 100644
--- a/bytecomp/instruct.mli
+++ b/bytecomp/instruct.mli
@@ -25,8 +25,8 @@ type instruction =
| Kmakeblock of int * int (* size, tag *)
| Kgetfield of int
| Ksetfield of int
- | Kdummy of int
- | Kupdate
+ | Kdummy of int (* block size *)
+ | Kupdate of int (* block size *)
| Kvectlength
| Kgetvectitem
| Ksetvectitem
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index c390826a8c..99243aa9af 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -10,7 +10,6 @@ type primitive =
| Pfield of int
| Psetfield of int
| Pccall of string * int
- | Pupdate
| Praise
| Psequand | Psequor | Pnot
| Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index f61bd2f00f..93c73e4c77 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -10,7 +10,6 @@ type primitive =
| Pfield of int
| Psetfield of int
| Pccall of string * int
- | Pupdate
| Praise
| Psequand | Psequor | Pnot
| Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
index c160d10cb8..0693b6a9e4 100644
--- a/bytecomp/printinstr.ml
+++ b/bytecomp/printinstr.ml
@@ -34,7 +34,7 @@ let instruction = function
| Kgetfield n -> print_string "\tgetfield "; print_int n
| Ksetfield n -> print_string "\tsetfield "; print_int n
| Kdummy n -> print_string "\tdummy "; print_int n
- | Kupdate -> print_string "\tupdate"
+ | Kupdate n -> print_string "\tupdate"; print_int n
| Kvectlength -> print_string "\tvectlength"
| Kgetvectitem -> print_string "\tgetvectitem"
| Ksetvectitem -> print_string "\tsetvectitem"
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 92c4a61fce..5389268129 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -32,7 +32,6 @@ let primitive = function
| Pfield n -> print_string "field "; print_int n
| Psetfield n -> print_string "setfield "; print_int n
| Pccall(name, arity) -> print_string name
- | Pupdate -> print_string "update"
| Praise -> print_string "raise"
| Psequand -> print_string "&&"
| Psequor -> print_string "||"
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index c588845ff3..b403b8772d 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -91,7 +91,6 @@ let primitives_table = create_hashtable 31 [
"%field1", Pfield 1;
"%setfield0", Psetfield 0;
"%makeblock", Pmakeblock 0;
- "%update", Pupdate;
"%raise", Praise;
"%sequand", Psequand;
"%sequor", Psequor;
@@ -164,7 +163,7 @@ exception Unknown
let size_of_lambda id lam =
let rec size = function
- Lfunction(param, body) -> 2
+ Lfunction(param, body) as funct -> 1 + List.length(free_variables funct)
| Lprim(Pmakeblock tag, args) -> List.iter check args; List.length args
| Llet(id, arg, body) -> check arg; size body
| _ -> raise Unknown
diff --git a/byterun/instruct.h b/byterun/instruct.h
index 7b06c95d13..caad6b6ebd 100644
--- a/byterun/instruct.h
+++ b/byterun/instruct.h
@@ -6,8 +6,8 @@ enum instructions {
PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3,
PUSHACC4, PUSHACC5, PUSHACC6, PUSHACC7,
PUSHACC, POP, ASSIGN,
- ENVACC0, ENVACC1, ENVACC2, ENVACC3, ENVACC,
- PUSHENVACC0, PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC,
+ ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC,
+ PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC,
PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3,
APPTERM, APPTERM1, APPTERM2, APPTERM3,
RETURN, RESTART, GRAB,
diff --git a/byterun/interp.c b/byterun/interp.c
index fa6c8435e1..cb9f55d1be 100644
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -199,23 +199,23 @@ value interprete(prog, prog_size)
/* Access in heap-allocated environment */
- Instruct(ENVACC0):
- accu = Field(env, 0); Next;
Instruct(ENVACC1):
accu = Field(env, 1); Next;
Instruct(ENVACC2):
accu = Field(env, 2); Next;
Instruct(ENVACC3):
accu = Field(env, 3); Next;
+ Instruct(ENVACC4):
+ accu = Field(env, 4); Next;
- Instruct(PUSHENVACC0):
- *--sp = accu; accu = Field(env, 0); Next;
Instruct(PUSHENVACC1):
*--sp = accu; accu = Field(env, 1); Next;
Instruct(PUSHENVACC2):
*--sp = accu; accu = Field(env, 2); Next;
Instruct(PUSHENVACC3):
*--sp = accu; accu = Field(env, 3); Next;
+ Instruct(PUSHENVACC4):
+ *--sp = accu; accu = Field(env, 4); Next;
Instruct(PUSHENVACC):
*--sp = accu;
@@ -237,7 +237,7 @@ value interprete(prog, prog_size)
Instruct(APPLY): {
extra_args = *pc++ - 1;
pc = Code_val(accu);
- env = Env_val(accu);
+ env = accu;
goto check_stacks;
}
Instruct(APPLY1): {
@@ -248,7 +248,7 @@ value interprete(prog, prog_size)
sp[2] = env;
sp[3] = Val_long(extra_args);
pc = Code_val(accu);
- env = Env_val(accu);
+ env = accu;
extra_args = 0;
goto check_stacks;
}
@@ -262,7 +262,7 @@ value interprete(prog, prog_size)
sp[3] = env;
sp[4] = Val_long(extra_args);
pc = Code_val(accu);
- env = Env_val(accu);
+ env = accu;
extra_args = 1;
goto check_stacks;
}
@@ -278,7 +278,7 @@ value interprete(prog, prog_size)
sp[4] = env;
sp[5] = Val_long(extra_args);
pc = Code_val(accu);
- env = Env_val(accu);
+ env = accu;
extra_args = 2;
goto check_stacks;
}
@@ -294,7 +294,7 @@ value interprete(prog, prog_size)
for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i];
sp = newsp;
pc = Code_val(accu);
- env = Env_val(accu);
+ env = accu;
extra_args += nargs - 1;
goto check_stacks;
}
@@ -303,7 +303,7 @@ value interprete(prog, prog_size)
sp = sp + *pc++ - 1;
sp[0] = arg1;
pc = Code_val(accu);
- env = Env_val(accu);
+ env = accu;
goto check_stacks;
}
Instruct(APPTERM2): {
@@ -313,7 +313,7 @@ value interprete(prog, prog_size)
sp[0] = arg1;
sp[1] = arg2;
pc = Code_val(accu);
- env = Env_val(accu);
+ env = accu;
extra_args += 1;
goto check_stacks;
}
@@ -326,7 +326,7 @@ value interprete(prog, prog_size)
sp[1] = arg2;
sp[2] = arg3;
pc = Code_val(accu);
- env = Env_val(accu);
+ env = accu;
extra_args += 2;
goto check_stacks;
}
@@ -336,7 +336,7 @@ value interprete(prog, prog_size)
if (extra_args > 0) {
extra_args--;
pc = Code_val(accu);
- env = Env_val(accu);
+ env = accu;
} else {
pc = (code_t)(sp[0]);
env = sp[1];
@@ -347,11 +347,11 @@ value interprete(prog, prog_size)
}
Instruct(RESTART): {
- int num_args = Wosize_val(env) - 1;
+ int num_args = Wosize_val(env) - 2;
int i;
sp -= num_args;
- for (i = 0; i < num_args; i++) sp[i] = Field(env, i);
- env = Field(env, num_args);
+ for (i = 0; i < num_args; i++) sp[i] = Field(env, i + 2);
+ env = Field(env, 1);
extra_args += num_args;
Next;
}
@@ -361,62 +361,43 @@ value interprete(prog, prog_size)
if (extra_args >= required) {
extra_args -= required;
} else {
- value clos;
mlsize_t num_args, i;
num_args = 1 + extra_args; /* arg1 + extra args */
- Alloc_small(accu, num_args + 1, 0);
- for (i = 0; i < num_args; i++) Field(accu, i) = sp[i];
- Field(accu, num_args) = env;
+ Alloc_small(accu, num_args + 2, Closure_tag);
+ Field(accu, 1) = env;
+ for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i];
+ Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */
sp += num_args;
- Alloc_small(clos, Closure_wosize, Closure_tag);
- Code_val(clos) = pc - 3; /* Point to the preceding RESTART instr. */
- Env_val(clos) = accu;
pc = (code_t)(sp[0]);
env = sp[1];
extra_args = Long_val(sp[2]);
sp += 3;
- accu = clos;
}
Next;
}
Instruct(CLOSURE): {
int nvars = *pc++;
- value clos;
int i;
- if (nvars == 0) {
- accu = Val_int(0);
- } else {
- *--sp = accu;
- Alloc_small(accu, nvars, 0);
- for (i = 0; i < nvars; i++) Field(accu, i) = sp[i];
- sp += nvars;
- }
- Alloc_small(clos, Closure_wosize, Closure_tag);
- Code_val(clos) = pc + *pc;
- Env_val(clos) = accu;
- accu = clos;
+ if (nvars > 0) *--sp = accu;
+ Alloc_small(accu, 1 + nvars, Closure_tag);
+ Code_val(accu) = pc + *pc;
+ for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i];
+ sp += nvars;
pc++;
Next;
}
Instruct(CLOSUREREC): {
int nvars = *pc++;
- value fun_clos, fun_env;
int i;
- Alloc_small(fun_env, nvars + 1, 0);
- Field(fun_env, 0) = Val_int(0);
- if (nvars > 0) {
- *--sp = accu;
- for (i = 0; i < nvars; i++) Field(fun_env, i+1) = sp[i];
- sp += nvars;
- }
- accu = fun_env;
- Alloc_small(fun_clos, Closure_wosize, Closure_tag);
- Code_val(fun_clos) = pc + *pc;
- Env_val(fun_clos) = accu;
- modify(&Field(accu, 0), fun_clos);
- accu = fun_clos;
+ if (nvars > 0) *--sp = accu;
+ Alloc_small(accu, 2 + nvars, Closure_tag);
+ Code_val(accu) = pc + *pc;
+ Field(accu, 1) = Val_int(0);
+ for (i = 0; i < nvars; i++) Field(accu, i + 2) = sp[i];
+ sp += nvars;
+ modify(&Field(accu, 1), accu);
pc++;
Next;
}
@@ -550,8 +531,9 @@ value interprete(prog, prog_size)
Instruct(UPDATE): {
value newval = *sp++;
mlsize_t size, n;
- Tag_val(accu) = Tag_val(newval);
size = Wosize_val(newval);
+ Assert(size == Wosize_val(accu));
+ Tag_val(accu) = Tag_val(newval);
for (n = 0; n < size; n++) {
modify(&Field(accu, n), Field(newval, n));
}
@@ -706,8 +688,9 @@ value interprete(prog, prog_size)
sp[1] = (value) pc;
sp[2] = env;
sp[3] = Val_long(extra_args);
- pc = Code_val(Field(signal_handlers, signal_number));
- env = Env_val(Field(signal_handlers, signal_number));
+ /* Branch to the signal handler */
+ env = Field(signal_handlers, signal_number);
+ pc = Code_val(env);
extra_args = 0;
}
}
diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h
index f96ae295f9..b507307347 100644
--- a/byterun/mlvalues.h
+++ b/byterun/mlvalues.h
@@ -145,10 +145,8 @@ bits 63 10 9 8 7 0
typedef int32 opcode_t;
typedef opcode_t * code_t;
-#define Closure_wosize 2
#define Closure_tag (No_scan_tag - 1)
#define Code_val(val) (((code_t *) (val)) [0]) /* Also an l-value. */
-#define Env_val(val) (Field(val, 1)) /* Also an l-value. */
/* 2- If tag >= No_scan_tag : a sequence of bytes. */
diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index 7e2d966bb0..247f4cdf56 100644
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -10,4 +10,3 @@ external size : t -> int = "%array_length"
external field : t -> int -> t = "%array_unsafe_get"
external set_field : t -> int -> t -> unit = "%array_unsafe_set"
external new_block : int -> int -> t = "obj_block"
-external update : t -> t -> unit = "%update"
diff --git a/stdlib/obj.mli b/stdlib/obj.mli
index 7e2d966bb0..247f4cdf56 100644
--- a/stdlib/obj.mli
+++ b/stdlib/obj.mli
@@ -10,4 +10,3 @@ external size : t -> int = "%array_length"
external field : t -> int -> t = "%array_unsafe_get"
external set_field : t -> int -> t -> unit = "%array_unsafe_set"
external new_block : int -> int -> t = "obj_block"
-external update : t -> t -> unit = "%update"
diff --git a/stdlib/set.ml b/stdlib/set.ml
index 84a8a942c8..f0434f265e 100644
--- a/stdlib/set.ml
+++ b/stdlib/set.ml
@@ -22,6 +22,7 @@ module type S =
val equal: t -> t -> bool
val iter: (elt -> 'a) -> t -> unit
val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
+ val cardinal: t -> int
val elements: t -> elt list
val choose: t -> elt
end
@@ -212,6 +213,10 @@ module Make(Ord: OrderedType): (S with elt = Ord.t) =
Empty -> accu
| Node(l, v, r, _) -> fold f l (f v (fold f r accu))
+ let rec cardinal = function
+ Empty -> 0
+ | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
+
let rec elements_aux accu = function
Empty -> accu
| Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
diff --git a/stdlib/set.mli b/stdlib/set.mli
index dff78105ae..f88480b3c4 100644
--- a/stdlib/set.mli
+++ b/stdlib/set.mli
@@ -22,6 +22,7 @@ module type S =
val equal: t -> t -> bool
val iter: (elt -> 'a) -> t -> unit
val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
+ val cardinal: t -> int
val elements: t -> elt list
val choose: t -> elt
end
diff --git a/testasmcomp/Makefile b/testasmcomp/Makefile
index 1f55f6edee..141f7cfaaa 100644
--- a/testasmcomp/Makefile
+++ b/testasmcomp/Makefile
@@ -1,7 +1,7 @@
ARCH=alpha
CODEGEN=../codegen
-ASFLAGS=-O
+ASFLAGS=-O2
CFLAGS=-g
PROGS=fib tak quicksort quicksort2 soli integr
@@ -26,6 +26,18 @@ soli: main.c soli.o $(ARCH).o
integr: main.c integr.o $(ARCH).o
$(CC) $(CFLAGS) -o integr -DINT_FLOAT -DFUN=test main.c integr.o $(ARCH).o
+tagged-fib: main.c tagged-fib.o $(ARCH).o
+ $(CC) $(CFLAGS) -o tagged-fib -DINT_INT -DFUN=fib main.c tagged-fib.o $(ARCH).o
+
+tagged-tak: main.c tagged-tak.o $(ARCH).o
+ $(CC) $(CFLAGS) -o tagged-tak -DUNIT_INT -DFUN=takmain main.c tagged-tak.o $(ARCH).o
+
+tagged-quicksort: main.c tagged-quicksort.o $(ARCH).o
+ $(CC) $(CFLAGS) -o tagged-quicksort -DSORT -DFUN=quicksort main.c tagged-quicksort.o $(ARCH).o
+
+tagged-integr: main.c tagged-integr.o $(ARCH).o
+ $(CC) $(CFLAGS) -o tagged-integr -DINT_FLOAT -DFUN=test main.c tagged-integr.o $(ARCH).o
+
.SUFFIXES:
.SUFFIXES: .cmm .c .o .asm
diff --git a/toplevel/printval.ml b/toplevel/printval.ml
index 5bc5c78d81..b155ed5d87 100644
--- a/toplevel/printval.ml
+++ b/toplevel/printval.ml
@@ -39,11 +39,17 @@ let print_exception obj =
exception Constr_not_found
-let rec find_constr tag = function
+let rec find_constr tag num_const num_nonconst = function
[] ->
raise Constr_not_found
- | constr :: rest ->
- if tag = 0 then constr else find_constr (tag - 1) rest
+ | (name, [] as cstr) :: rem ->
+ if tag = Cstr_constant num_const
+ then cstr
+ else find_constr tag (num_const + 1) num_nonconst rem
+ | (name, _ as cstr) :: rem ->
+ if tag = Cstr_block num_nonconst
+ then cstr
+ else find_constr tag num_const (num_nonconst + 1) rem
(* The user-defined printers. Also used for some builtin types. *)
@@ -166,10 +172,13 @@ let print_value env obj ty =
print_val prio depth obj
(Ctype.substitute decl.type_params ty_list body)
| Type_variant constr_list ->
- let tag = Obj.tag obj in
begin try
+ let tag =
+ if Obj.is_block obj
+ then Cstr_block(Obj.tag obj)
+ else Cstr_constant(Obj.magic obj) in
let (constr_name, constr_args) =
- find_constr tag constr_list in
+ find_constr tag 0 0 constr_list in
let ty_args =
List.map (Ctype.substitute decl.type_params ty_list)
constr_args in
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index ebbc712b25..742b51747b 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -156,6 +156,21 @@ let _ = Hashtbl.add directive_table "install_printer"
let _ = Hashtbl.add directive_table "remove_printer"
(Directive_ident dir_remove_printer)
+(* Make a copy of a closure *)
+
+let copy_closure cls =
+ let sz = Obj.size cls in
+ let new = Obj.new_block 251 sz in
+ for i = 0 to sz - 1 do Obj.set_field new i (Obj.field cls i) done;
+ new
+
+(* Overwrite a closure by another *)
+
+let overwrite_closure dst src =
+ for i = 0 to Obj.size src - 1 do
+ Obj.set_field dst i (Obj.field src i)
+ done
+
(* The trace *)
let rec trace_closure name clos_typ =
@@ -193,16 +208,13 @@ let dir_trace lid =
let clos = eval_path path in
(* Nothing to do if it's not a closure *)
if Obj.is_block clos & Obj.tag clos = 251 then begin
- (* Make a copy of the closure *)
- let old_clos = Obj.new_block 251 2 in
- Obj.set_field old_clos 0 (Obj.field clos 0);
- Obj.set_field old_clos 1 (Obj.field clos 1);
+ let old_clos = copy_closure clos in
(* Instrument the old closure *)
let new_clos =
trace_closure lid (Ctype.instance desc.val_type) old_clos in
trace_env := (path, old_clos) :: !trace_env;
(* Overwrite the old closure *)
- Obj.update clos new_clos;
+ overwrite_closure clos new_clos;
match desc.val_prim with
Not_prim ->
Printtyp.longident lid; print_string " is now traced.";
@@ -231,7 +243,7 @@ let dir_untrace lid =
[]
| (p, oldval) :: rem ->
if Path.same p path then begin
- Obj.update (eval_path path) oldval;
+ overwrite_closure (eval_path path) oldval;
Printtyp.longident lid; print_string " is no longer traced.";
print_newline();
rem
@@ -244,7 +256,7 @@ let dir_untrace lid =
let dir_untrace_all () =
List.iter
(fun (path, oldval) ->
- Obj.update (eval_path path) oldval;
+ overwrite_closure (eval_path path) oldval;
Printtyp.path path; print_string " is no longer traced.";
print_newline())
!trace_env;
View Lorry Controller Status