Commits

xleroy  committed a9b78a3

Fermetures representees en un seul bloc

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@49f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

  • Participants
  • Parent commits 168b923

Comments (0)

Files changed (24)

 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)

File asmcomp/cmm.mli

     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

File asmcomp/emit_alpha.mlp

 (* 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 ->
       `	.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 ()

File asmcomp/emit_i386.mlp

 (* 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 ->
       `	.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 ()

File asmcomp/emit_sparc.mlp

 (* 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 ->
       `	.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 ()

File bytecomp/codegen.ml

             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
         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

File bytecomp/emitcode.ml

   | 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 ->
   | 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
       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

File bytecomp/instruct.ml

   | Kgetfield of int
   | Ksetfield of int
   | Kdummy of int
-  | Kupdate
+  | Kupdate of int
   | Kvectlength
   | Kgetvectitem
   | Ksetvectitem

File bytecomp/instruct.mli

   | 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

File bytecomp/lambda.ml

   | Pfield of int
   | Psetfield of int
   | Pccall of string * int
-  | Pupdate
   | Praise
   | Psequand | Psequor | Pnot
   | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint

File bytecomp/lambda.mli

   | Pfield of int
   | Psetfield of int
   | Pccall of string * int
-  | Pupdate
   | Praise
   | Psequand | Psequor | Pnot
   | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint

File bytecomp/printinstr.ml

   | 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"

File bytecomp/printlambda.ml

   | 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 "||"

File bytecomp/translcore.ml

   "%field1", Pfield 1;
   "%setfield0", Psetfield 0;
   "%makeblock", Pmakeblock 0;
-  "%update", Pupdate;
   "%raise", Praise;
   "%sequand", Psequand;
   "%sequor", Psequor;
 
 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

File byterun/instruct.h

   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,

File byterun/interp.c

 
 /* 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;
     Instruct(APPLY): {
       extra_args = *pc++ - 1;
       pc = Code_val(accu);
-      env = Env_val(accu);
+      env = accu;
       goto check_stacks;
     }
     Instruct(APPLY1): {
       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;
     }
       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;
     }
       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;
     }
       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;
     }
       sp = sp + *pc++ - 1;
       sp[0] = arg1;
       pc = Code_val(accu);
-      env = Env_val(accu);
+      env = accu;
       goto check_stacks;
     }
     Instruct(APPTERM2): {
       sp[0] = arg1;
       sp[1] = arg2;
       pc = Code_val(accu);
-      env = Env_val(accu);
+      env = accu;
       extra_args += 1;
       goto check_stacks;
     }
       sp[1] = arg2;
       sp[2] = arg3;
       pc = Code_val(accu);
-      env = Env_val(accu);
+      env = accu;
       extra_args += 2;
       goto check_stacks;
     }
       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];
     }
 
     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;
     }
       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;
     }
     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));
       }
           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;
         }
       }

File byterun/mlvalues.h

 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. */

File stdlib/obj.ml

 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"

File stdlib/obj.mli

 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"

File stdlib/set.ml

     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
         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

File stdlib/set.mli

     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

File testasmcomp/Makefile

 ARCH=alpha
 
 CODEGEN=../codegen
-ASFLAGS=-O
+ASFLAGS=-O2
 CFLAGS=-g
 
 PROGS=fib tak quicksort quicksort2 soli integr
 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
 

File toplevel/printval.ml

 
 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. *)
 
               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

File toplevel/topdirs.ml

 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 =
     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.";
         []
     | (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
 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;