Dans les .cmo, on garde trace des primitives declarees dans le module…

…. Du coup, cslmktop -custom se remet a marcher.

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

Makefile.config

@@ -33,19 +33,19 @@ BYTECC=gcc
 ### Additional compile-time options for $(BYTECC).
 # If using gcc on Intel 386 or Motorola 68k:
 # (the -fno-defer-pop option circumvents a gcc bug)
-#BYTECCCOMPOPTS=-fno-defer-pop -Wall
+BYTECCCOMPOPTS=-fno-defer-pop -Wall
 # If using gcc and being superstitious:
-BYTECCCOMPOPTS=-Wall
+#BYTECCCOMPOPTS=-Wall
 # Otherwise:
 #BYTECCCOMPOPTS=
 
 ### Additional link-time options for $(BYTECC)
 BYTECCLINKOPTS=
 
 ### If using GCC on a Dec Alpha under OSF1:
-LOWADDRESSES=-Xlinker -taso
+#LOWADDRESSES=-Xlinker -taso
 # Otherwise:
-#LOWADDRESSES=
+LOWADDRESSES=
 
 ### Libraries needed
 # On most platforms:
@@ -72,9 +72,9 @@ RANLIB=ranlib
 ### mips        DecStation 3100 and 5000 under Ultrix 4
 ###
 ### Set ARCH=none if your machine is not supported
-ARCH=alpha
+#ARCH=alpha
 #ARCH=sparc
-#ARCH=i386
+ARCH=i386
 #ARCH=mips
 #ARCH=none
 
@@ -93,24 +93,24 @@ ARCH=alpha
 ###
 #SYSTEM=sunos
 #SYSTEM=solaris
-#SYSTEM=linux
+SYSTEM=linux
 #SYSTEM=linux_elf
 #SYSTEM=bsd
 #SYSTEM=nextstep
-SYSTEM=unknown
+#SYSTEM=unknown
 
 ### Which C compiler to use for the native-code compiler.
 ### cc is better than gcc on the Mips and Alpha.
-NATIVECC=cc
-#NATIVECC=gcc
+#NATIVECC=cc
+NATIVECC=gcc
 
 ### Additional compile-time options for $(NATIVECC).
 # For cc on the Alpha:
-NATIVECCCOMPOPTS=-std1
+#NATIVECCCOMPOPTS=-std1
 # For cc on the Mips:
 #NATIVECCCOMPOPTS=-std
 # For gcc if superstitious:
-#NATIVECCCOMPOPTS=-Wall
+NATIVECCCOMPOPTS=-Wall
 
 ### Additional link-time options for $(NATIVECC)
 # For the i386 running under NextStep:
@@ -120,8 +120,8 @@ NATIVECCLINKOPTS=
 
 ### Flags for the assembler
 # For the Alpha or the Mips:
-ASFLAGS=-O2
+#ASFLAGS=-O2
 # For the Sparc:
 #ASFLAGS=-P -DSYS_$(SYSTEM)
 # For the Intel 386:
-#ASFLAGS=-DSYS_$(SYSTEM)
+ASFLAGS=-DSYS_$(SYSTEM)

asmrun/i386.S

@@ -19,8 +19,10 @@
 
 #ifdef SYS_linux_elf
 #define G(x) x
+#define FUNCTION_ALIGN 16
 #else
 #define G(x) _##x
+#define FUNCTION_ALIGN 4
 #endif
 
         .comm   G(young_start), 4
@@ -42,7 +44,7 @@
         .globl  G(caml_alloc)
 	.globl  G(caml_call_gc)
 
-        .align  4
+        .align  FUNCTION_ALIGN
 G(caml_alloc1):
         movl    G(young_ptr), %eax
         subl    $8, %eax
@@ -53,7 +55,7 @@ G(caml_alloc1):
 L100:   movl    $8, %eax
         jmp     L105
 
-        .align  4
+        .align  FUNCTION_ALIGN
 G(caml_alloc2):
         movl    G(young_ptr), %eax
         subl    $12, %eax
@@ -64,7 +66,7 @@ G(caml_alloc2):
 L101:   movl    $12, %eax
         jmp     L105
 
-        .align  4
+        .align  FUNCTION_ALIGN
 G(caml_alloc3):
         movl    G(young_ptr), %eax
         subl    $16, %eax
@@ -75,7 +77,7 @@ G(caml_alloc3):
 L102:   movl    $16, %eax
         jmp     L105
 
-        .align  4
+        .align  FUNCTION_ALIGN
 G(caml_alloc):
         pushl   %eax
         movl    G(young_ptr), %eax
@@ -129,22 +131,20 @@ L105:
 
         .globl  G(caml_c_call)
 
-        .align  4
+        .align  FUNCTION_ALIGN
 G(caml_c_call):
     /* Record lowest stack address and return address */
         movl    (%esp), %edx
         movl    %edx, G(caml_last_return_address)
         leal    4(%esp), %edx
         movl    %edx, G(caml_bottom_of_stack)
-    /* Free the floating-point register stack */
-        finit
     /* Call the function (address in %eax) */
         jmp     *%eax
 
 /* Start the Caml program */
 
         .globl  G(caml_start_program)
-        .align  4
+        .align  FUNCTION_ALIGN
 G(caml_start_program):
     /* Save callee-save registers */
         pushl   %ebx
@@ -174,7 +174,7 @@ L104:
 /* Raise an exception from C */
 
         .globl  G(raise_caml_exception)
-        .align  4
+        .align  FUNCTION_ALIGN
 G(raise_caml_exception):
         movl    4(%esp), %eax
         movl    G(caml_exception_pointer), %esp

bytecomp/bytelink.ml

@@ -135,7 +135,9 @@ let link_compunit outchan inchan file_name compunit =
   let code_block = String.create compunit.cu_codesize in
   really_input inchan code_block 0 compunit.cu_codesize;
   Symtable.patch_object code_block compunit.cu_reloc;
-  output outchan code_block 0 compunit.cu_codesize
+  output outchan code_block 0 compunit.cu_codesize;
+  if !Clflags.link_everything then
+    List.iter Symtable.require_primitive compunit.cu_primitives
 
 (* Link in a .cmo file *)
 

bytecomp/emitcode.ml

@@ -38,7 +38,7 @@ type compilation_unit =
     cu_reloc: (reloc_info * int) list;  (* Relocation information *)
     cu_interface: Digest.t;             (* CRC of interface implemented *)
     cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *)
-    cu_unsafe: bool }                   (* Uses unsafe features? *)
+    cu_primitives: string list }        (* Primitives declared inside *)
 
 (* Format of a .cmo file:
      magic number (Config.cmo_magic_number)
@@ -293,7 +293,7 @@ let to_file outchan unit_name crc_interface code =
       cu_reloc = List.rev !reloc_info;
       cu_interface = crc_interface;
       cu_imports = Env.imported_units();
-      cu_unsafe = !Translmod.unsafe_implementation } in
+      cu_primitives = !Translmod.primitive_declarations } in
   init();                               (* Free out_buffer and reloc_info *)
   let pos_compunit = pos_out outchan in
   output_value outchan compunit;

bytecomp/emitcode.mli

@@ -33,7 +33,7 @@ type compilation_unit =
     cu_reloc: (reloc_info * int) list;  (* Relocation information *)
     cu_interface: Digest.t;             (* CRC of interface implemented *)
     cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *)
-    cu_unsafe: bool }                   (* Uses unsafe features? *)
+    cu_primitives: string list }        (* Primitives declared inside *)
 
 (* Format of a .cmo file:
      Obj.magic number (Config.cmo_magic_number)

bytecomp/symtable.ml

@@ -79,6 +79,9 @@ let num_of_prim name =
     then enter_numtable c_prim_table name
     else raise(Error(Unavailable_primitive name))
 
+let require_primitive name =
+  if name.[0] <> '%' then begin num_of_prim name; () end
+
 open Printf
 
 let output_primitives prim_file_name =

bytecomp/symtable.mli

@@ -19,6 +19,7 @@ open Emitcode
 
 val init: unit -> unit
 val patch_object: string -> (reloc_info * int) list -> unit
+val require_primitive: string -> unit
 val initial_global_table: unit -> Obj.t array
 val output_global_map: out_channel -> unit
 val output_primitives: string -> unit

bytecomp/translmod.ml

@@ -63,10 +63,9 @@ let rec compose_coercions c1 c2 =
   | (_, _) ->
       fatal_error "Translmod.compose_coercions"
 
-(* Record whether unsafe features (-fast or primitive declarations)
-   were used while compiling this module *)
+(* Record the primitive declarations occuring in the module compiled *)
 
-let unsafe_implementation = ref false
+let primitive_declarations = ref ([] : string list)
 
 (* Compile a module expression *)
 
@@ -117,7 +116,11 @@ and transl_structure env fields cc = function
       let (ext_env, add_let) = transl_let env rec_flag pat_expr_list in
       add_let(transl_structure ext_env ext_fields cc rem)
   | Tstr_primitive(id, descr) :: rem ->
-      unsafe_implementation := true;
+      begin match descr.val_prim with
+        None -> ()
+      | Some p -> primitive_declarations :=
+                    p.Primitive.prim_name :: !primitive_declarations
+      end;
       transl_structure env fields cc rem
   | Tstr_type(decls) :: rem ->
       transl_structure env fields cc rem
@@ -135,7 +138,7 @@ and transl_structure env fields cc = function
 (* Compile an implementation *)
 
 let transl_implementation module_name str cc =
-  unsafe_implementation := !Clflags.fast;
+  primitive_declarations := [];
   let module_id = Ident.new_persistent module_name in
   Lprim(Psetglobal module_id, [transl_structure empty_env [] cc str])
 

bytecomp/translmod.mli

@@ -20,4 +20,4 @@ open Lambda
 val transl_implementation: string -> structure -> module_coercion -> lambda
 val transl_toplevel_definition: structure -> lambda
 
-val unsafe_implementation: bool ref
+val primitive_declarations: string list ref

otherlibs/dynlink/dynlink.ml

@@ -80,7 +80,7 @@ let allow_unsafe_modules b =
   unsafe_allowed := b
 
 let check_unsafe_module cu =
-  if (not !unsafe_allowed) & cu.cu_unsafe
+  if (not !unsafe_allowed) & cu.cu_primitives <> []
   then raise(Error(Unsafe_file))
 
 (* Load in-core and execute a bytecode object file *)

test/Makefile

@@ -1,3 +1,5 @@
+include ../Makefile.config
+
 CAMLC=../boot/cslrun ../cslc -I ../stdlib -I KB -I Lex
 CAMLOPT=../boot/cslrun ../cslopt -I ../stdlib -I KB -I Lex
 OPTFLAGS=-S
@@ -15,6 +17,17 @@ CODE_EXE=$(BYTE_EXE:.byt=.out)
 
 all: $(BYTE_EXE) $(CODE_EXE)
 
+# Nucleic
+
+nucleic.out: nucleic.ml
+	case $(ARCH) in \
+          i386) sed -e '/<HAND_CSE>/,/<\/HAND_CSE>/d' -e '/NO_CSE>/d' \
+                nucleic.ml > nucleic.mlt; \
+	        $(CAMLOPT) $(OPTFLAGS) -o nucleic.out nucleic.mlt; \
+	        rm -f nucleic.mlt;; \
+             *) $(CAMLOPT) $(OPTFLAGS) -o nucleic.out nucleic.ml;; \
+        esac
+
 # KB
 
 BYTE_KB=KB/terms.cmo KB/equations.cmo KB/kb.cmo KB/orderings.cmo KB/kbmain.cmo

test/nucleic.ml

@@ -94,13 +94,14 @@ tfo_apply t p
       z = ((p.x * t.c) + (p.y * t.f) + (p.z * t.i) + t.tz) }
 
 (*
-   The function "tfo-List.combine" multiplies two transformation matrices A and B.
+   The function "tfo-combine" multiplies two transformation matrices A and B.
    The result is a new matrix which cumulates the transformations described
    by A and B.
 *)
 
 let
 tfo_combine a b =
+(* <HAND_CSE> *)
   (* Hand elimination of common subexpressions.
      Assumes lots of float registers (32 is perfect, 16 still OK).
      Loses on the I386, of course. *)
@@ -123,7 +124,9 @@ tfo_combine a b =
       ty = ((a_tx * b_b) + (a_ty * b_e) + (a_tz * b_h) + b_ty);
       tz = ((a_tx * b_c) + (a_ty * b_f) + (a_tz * b_i) + b_tz)
     }
-(*** Original without CSE:
+(* </HAND_CSE> *)
+ (* Original without CSE *)
+(* <NO_CSE> *) (***
     { a = ((a.a * b.a) + (a.b * b.d) + (a.c * b.g));
       b = ((a.a * b.b) + (a.b * b.e) + (a.c * b.h));
       c = ((a.a * b.c) + (a.b * b.f) + (a.c * b.i));
@@ -137,7 +140,7 @@ tfo_combine a b =
       ty = ((a.tx * b.b) + (a.ty * b.e) + (a.tz * b.h) + b.ty);
       tz = ((a.tx * b.c) + (a.ty * b.f) + (a.tz * b.i) + b.tz)
     }
-****)
+  ***) (* </NO_CSE> *)
 
 (*
    The function "tfo-inv-ortho" computes the inverse of a homogeneous

tools/objinfo.ml

@@ -43,8 +43,15 @@ let dump_obj filename =
       print_string name; print_newline())
     cu.cu_imports;
   print_string "  Uses unsafe features: ";
-  print_string (if cu.cu_unsafe then "YES" else "no");
-  print_newline()
+  begin match cu.cu_primitives with
+    [] -> print_string "no"; print_newline()
+  | l  -> print_string "YES"; print_newline();
+          print_string "  Primitives declared in this module:";
+          print_newline();
+          List.iter
+            (fun name -> print_string "\t"; print_string name; print_newline())
+            l
+  end
 
 let main() =
   for i = 1 to Array.length Sys.argv - 1 do