diff options
50 files changed, 496 insertions, 289 deletions
@@ -747,22 +747,24 @@ toplevel/topdirs.cmx: utils/warnings.cmx typing/types.cmx toplevel/trace.cmx \ bytecomp/emitcode.cmx bytecomp/dll.cmx typing/ctype.cmx \ utils/consistbl.cmx utils/config.cmx utils/clflags.cmx \ toplevel/topdirs.cmi -toplevel/toploop.cmo: utils/warnings.cmi typing/types.cmi typing/typemod.cmi \ - typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \ - bytecomp/symtable.cmi bytecomp/simplif.cmi typing/printtyp.cmi \ - bytecomp/printlambda.cmi bytecomp/printinstr.cmi parsing/printast.cmi \ - typing/predef.cmi typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \ +toplevel/toploop.cmo: utils/warnings.cmi typing/unused_var.cmi \ + typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \ + typing/typecore.cmi bytecomp/translmod.cmi bytecomp/symtable.cmi \ + bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ + bytecomp/printinstr.cmi parsing/printast.cmi typing/predef.cmi \ + typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \ typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi \ parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \ typing/ident.cmi toplevel/genprintval.cmi driver/errors.cmi \ typing/env.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ utils/config.cmi driver/compile.cmi utils/clflags.cmi \ bytecomp/bytegen.cmi typing/btype.cmi toplevel/toploop.cmi -toplevel/toploop.cmx: utils/warnings.cmx typing/types.cmx typing/typemod.cmx \ - typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ - bytecomp/symtable.cmx bytecomp/simplif.cmx typing/printtyp.cmx \ - bytecomp/printlambda.cmx bytecomp/printinstr.cmx parsing/printast.cmx \ - typing/predef.cmx typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \ +toplevel/toploop.cmx: utils/warnings.cmx typing/unused_var.cmx \ + typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \ + typing/typecore.cmx bytecomp/translmod.cmx bytecomp/symtable.cmx \ + bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ + bytecomp/printinstr.cmx parsing/printast.cmx typing/predef.cmx \ + typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \ typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx \ parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \ typing/ident.cmx toplevel/genprintval.cmx driver/errors.cmx \ @@ -7,6 +7,36 @@ Language features: definition replaces the old one, rather than creating a new variable. +Objective Caml 3.09.2: +---------------------- + +Bug fixes: +- Makefile: problem with "make world.opt" PR#3954 +- compilers: problem compiling several modules with one command line PR#3979 +- compilers,ocamldoc: error message that Emacs cannot parse +- compilers: crash when printing type error PR#3968 +- compilers: -dtypes wrong for monomorphic type variables PR#3894 +- compilers: wrong warning on optional arguments PR#3980 +- compilers: crash when wrong use of type constructor in let rec PR#3976 +- compilers: better wording of "statement never returns" warning PR#3889 +- runtime: inefficiency of signal handling PR#3990 +- runtime: crashes with I/O in multithread programs PR#3906 +- camlp4: empty file name in error messages PR#3886 +- camlp4: stack overflow PR#3948 +- otherlibs/labltk: ocamlbrowser ignores its command line options PR#3961 +- otherlibs/unix: Unix.times wrong under Mac OS X PR#3960 +- otherlibs/unix: wrong doc for execvp and execvpe PR#3973 +- otherlibs/win32unix: random crash in Unix.stat PR#3998 +- stdlib: update_mod not found under Windows PR#3847 +- stdlib: Filename.dirname/basename wrong on Win32 PR#3933 +- stdlib: incomplete documentation of Pervasives.abs PR#3967 +- stdlib: Printf bugs PR#3902, PR#3955 +- tools/checkstack.c missing include +- yacc: crash when given argument "-" PR#3956 + +New features: +- ported to MacOS X on Intel PR#3985 +- configure: added support for GNU Hurd PR#3991 Objective Caml 3.09.1: ---------------------- @@ -16,7 +46,7 @@ Bug fixes: - compilers: assert failure in typeclass.cml PR#3856 - compilers: assert failure in typing/ctype.ml PR#3909 - compilers: fatal error exception Ctype.Unify PR#3918 -- compilers: spurious warning Y PR#3868 +- compilers: spurious warning Y in objects PR#3868 - compilers: spurious warning Z on loop index PR#3907 - compilers: error message that emacs cannot parse - ocamlopt: problems with -for-pack/-pack PR#3825, PR#3826, PR#3919 @@ -70,7 +100,7 @@ Both compilers: Native-code compiler (ocamlopt): * Revised implementation of the -pack option (packing of several compilation - units into one). The .cmx files that are to be packed with + units into one). The .cmx files that are to be packed with "ocamlopt -pack -o P.cmx" must be compiled with "ocamlopt -for-pack P". In exchange for this additional constraint, ocamlopt -pack is now available on all platforms (no need for binutils). @@ -290,7 +320,7 @@ Both compilers: .cmi / .cmo / .cmx files. Bytecode compiler: -- Option -output-obj is now compatible with Dynlink and +- Option -output-obj is now compatible with Dynlink and with embedded toplevels. Native-code compiler: @@ -373,7 +403,7 @@ Language features: (written with an 'l', 'n' or 'L' suffix respectively). Type-checking: -- Allow polymorphic generalization of covariant parts of expansive +- Allow polymorphic generalization of covariant parts of expansive expressions. For instance, if f: unit -> 'a list, "let x = f ()" gives "x" the generalized type forall 'a. 'a list, instead of '_a list as before. @@ -432,7 +462,7 @@ Native-code compiler: Small performance tweaks for the Pentium 4. Fixed illegal "imul" instruction generated by reloading phase. - Sparc port: - Enhanced code generation for Sparc V8 (option -march=v8) and + Enhanced code generation for Sparc V8 (option -march=v8) and Sparc V9 (option -march=v9). Profiling support added for Solaris. - PowerPC port: @@ -590,7 +620,7 @@ Run-time system: - Better support for lazy data in the garbage collector. - Fixed issues with the heap compactor. - Fixed issues with finalized Caml values. -- The type "int64" is now supported on all platforms: we use software +- The type "int64" is now supported on all platforms: we use software emulation if the C compiler doesn't support 64-bit integers. - Support for float formats that are neither big-endian nor little-endian (one known example: the ARM). @@ -636,12 +666,12 @@ Standard library: Other libraries: - Bigarray: - support for bigarrays of complex numbers; + support for bigarrays of complex numbers; added functions Genarray.dims, {Genarray,Array1,Array2,Array3}.{kind,layout}. - Dynlink: fixed bug with loading of mixed-mode Caml/C libraries. - LablTK: - now supports also the CamlTK API (no labels); + now supports also the CamlTK API (no labels); support for Activate and Deactivate events; support for virtual events; added UTF conversion; @@ -672,7 +702,7 @@ Windows port: - Graphics library: fixed several bugs in event handling. - Threads library: fixed preemption bug. - Unix library: better handling of the underlying differences between - sockets and regular file descriptors; + sockets and regular file descriptors; added Unix.lockf and a better Unix.rename (thanks to Tracy Camp). - LablTk library: fixed a bug in Fileinput @@ -718,15 +748,15 @@ Standard library: - Pervasives.float_of_string: now raises Failure on ill-formed input. - Pervasives: added useful float constants max_float, min_float, epsilon_float. - printf functions in Printf and Format: added % formats for int32, nativeint, - int64; "*" in width and precision specifications now supported + int64; "*" in width and precision specifications now supported (contributed by Thorsten Ohl). - Added Hashtbl.copy, Stack.copy. -- Hashtbl: revised resizing strategy to avoid quadratic behavior +- Hashtbl: revised resizing strategy to avoid quadratic behavior on Hashtbl.add. - New module MoreLabels providing labelized versions of modules Hashtbl, Map and Set. - Pervasives.output_value and Marshal.to_* : improved hashing strategy - for internal data structures, avoid excessive slowness on + for internal data structures, avoid excessive slowness on quasi-linearly-allocated inputs. Other libraries: @@ -839,7 +869,7 @@ Byte-code compiler: variables. Native-code compiler: -- Removed re-sharing of string literals, causes too many surprises with +- Removed re-sharing of string literals, causes too many surprises with in-place string modifications. - Corrected wrong compilation of toplevel "include" statements. - Fixed bug in runtime function "callbackN_exn". @@ -908,11 +938,11 @@ New ports: - Cygwin under MS Windows. This port is an alternative to the earlier Windows port of OCaml, which relied on MS compilers; the Cygwin Windows port does not need MS Visual C++ nor MASM, runs faster - in bytecode, and has a better implementation of the Unix library, + in bytecode, and has a better implementation of the Unix library, but currently lacks threads and COM component support. Type-checking: -- Relaxed "monomorphic restriction" on type constructors in a +- Relaxed "monomorphic restriction" on type constructors in a mutually-recursive type definition, e.g. the following is again allowed type u = C of int t | D of string t and 'a t = ... - Fixed name-capture bug in "include SIG" and "SIG with ..." constructs. @@ -926,7 +956,7 @@ Type-checking: Both compilers: - Revised compilation of pattern matching. - Option -I +<subdir> to search a subdirectory <subdir> of the standard - library directory (i.e. write "ocamlc -I +labltk" instead of + library directory (i.e. write "ocamlc -I +labltk" instead of "ocamlc -I /usr/local/lib/ocaml/labltk"). - Option -warn-error to turn warnings into errors. - Option -where to print the location of the standard library directory. @@ -970,7 +1000,7 @@ Standard library: - Module Hashtbl: added Hashtbl.replace. - Module Int64: added bits_of_float, float_of_bits (access to IEEE 754 representation of floats). -- Module List: List.partition now tail-rec; +- Module List: List.partition now tail-rec; improved memory behavior of List.stable_sort. - Module Nativeint: added Nativeint.size (number of bits in a nativeint). - Module Obj: fixed incorrect resizing of float arrays in Obj.resize. @@ -1107,7 +1137,7 @@ Other libraries: - Dbm: fixed bug with Dbm.iter on empty database. New or updated ports: -- Alpha/Digital Unix: lifted 256M limitation on total memory space +- Alpha/Digital Unix: lifted 256M limitation on total memory space induced by -taso - Port to AIX 4.3 on PowerPC - Port to HPUX 10 on HPPA @@ -1150,8 +1180,8 @@ Syntax: the equivalent "# LINENO" is still supported. Typing: -- When an incomplete pattern-matching is detected, report also a - value or value template that is not covered by the cases of +- When an incomplete pattern-matching is detected, report also a + value or value template that is not covered by the cases of the pattern-matching. - Several bugs in class type matching and in type error reporting fixed. - Added an option -rectypes to support general recursive types, @@ -1520,7 +1550,7 @@ Objective Caml 1.06: in class type declared in module signature). - Objects can be compared using generic comparison functions. - Fixed compilation of partial application of object constructors. - + * Type system: - Occur-check now more strict (all recursions must traverse an object). - A few bugs fixed. @@ -1635,7 +1665,7 @@ Objective Caml 1.04: - At toplevel, allow several phrases without intermediate ";;". * Typing: - - Allow constraints on datatype parameters, e.g. + - Allow constraints on datatype parameters, e.g. type 'a foo = ... constraint 'a = 'b * 'c. - Fixed bug in signature matching in presence of free type variables '_a. - Extensive cleanup of internals of type inference. @@ -1737,7 +1767,7 @@ Objective Caml 1.03: Objective Caml 1.02: -------------------- -* Typing: +* Typing: - fixed bug with type names escaping their scope via unification with non-generalized type variables '_a; - keep #class abbreviations longer; @@ -1781,7 +1811,7 @@ Objective Caml 1.02: - added -thread option to select a thread-safe version of the standard library, the ThreadIO module is no longer needed. -* The "graph" library: avoid invalid pixmaps when doing +* The "graph" library: avoid invalid pixmaps when doing open_graph/close_graph several times. * The "dynlink" library: support for "private" (no re-export) dynamic loading. @@ -1794,7 +1824,7 @@ Objective Caml 1.02: Objective Caml 1.01: -------------------- -* Typing: better report of type incompatibilities; +* Typing: better report of type incompatibilities; non-generalizable type variables in a struct...end no longer flagged immediately as an error; name clashes during "open" avoided. @@ -2001,7 +2031,7 @@ Caml Special Light 1.07: * Syntax: optional ;; allowed in compilation units and structures (back by popular demand) -* cslopt: +* cslopt: generic handling of float arrays fixed direct function application when the function expr is not a path fixed compilation of "let rec" over values fixed @@ -226,8 +226,8 @@ opt-core:runtimeopt ocamlopt libraryopt opt: runtimeopt ocamlopt libraryopt otherlibrariesopt camlp4opt # Native-code versions of the tools -opt.opt: checkstack core ocaml opt-core ocamlc.opt otherlibraries camlp4out \ - $(DEBUGGER) ocamldoc ocamlopt.opt otherlibrariesopt \ +opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ + camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt otherlibrariesopt \ camlp4opt ocamllex.opt ocamltoolsopt.opt camlp4optopt ocamldoc.opt # Installation diff --git a/asmcomp/alpha/emit.mlp b/asmcomp/alpha/emit.mlp index 23c38d477..b3890a448 100644 --- a/asmcomp/alpha/emit.mlp +++ b/asmcomp/alpha/emit.mlp @@ -281,7 +281,7 @@ let emit_call_gc gc = let rdata_section = match Config.system with "digital" -> ".rdata" - | "linux" | "openbsd" | "netbsd" | "freebsd" -> ".section .rodata" + | "linux" | "openbsd" | "netbsd" | "freebsd" | "gnu" -> ".section .rodata" | _ -> assert false (* Names of various instructions *) diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 74ce9c24a..ea9363e7b 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -65,11 +65,11 @@ let emit_label lbl = let emit_align n = ` .align {emit_int n}\n` - + let emit_Llabel fallthrough lbl = if not fallthrough && !fastcode_flag then emit_align 4; emit_label lbl - + (* Output a pseudo-register *) let emit_reg = function @@ -84,13 +84,13 @@ let emit_reg = function (* Output a reference to the lower 8, 16 or 32 bits of a register *) let reg_low_8_name = - [| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b"; + [| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b"; "%r10b"; "%r11b"; "%bpl"; "%r12b"; "%r13b" |] let reg_low_16_name = - [| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w"; + [| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w"; "%r10w"; "%r11w"; "%bp"; "%r12w"; "%r13w" |] let reg_low_32_name = - [| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d"; + [| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d"; "%r10d"; "%r11d"; "%ebp"; "%r12d"; "%r13d" |] let emit_subreg tbl r = @@ -217,7 +217,7 @@ let name_for_cond_branch = function | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" - + (* Output an = 0 or <> 0 test. *) let output_test_zero arg = @@ -578,11 +578,11 @@ let emit_float_constant (lbl, cst) = let emit_profile () = match Config.system with - | "linux" -> + | "linux" | "gnu" -> (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly and rbx, rbp, r12-r15 like all C functions. We need to preserve r10 and r11 ourselves, since Caml can - use them for argument passing. *) + use them for argument passing. *) ` pushq %r10\n`; ` movq %rsp, %rbp\n`; ` pushq %r11\n`; diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index a94af5f1e..b91a8c9b9 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -1684,6 +1684,7 @@ let emit_all_constants cont = (fun (lbl, cst) -> c := Cdata(emit_constant lbl cst []) :: !c) !structured_constants; structured_constants := []; + Hashtbl.clear immstrings; (* PR#3979 *) List.iter (fun (symb, fundecls) -> c := Cdata(emit_constant_closure symb fundecls []) :: !c) diff --git a/asmcomp/hppa/emit.mlp b/asmcomp/hppa/emit.mlp index 5ee5ad7be..b8880fc4f 100644 --- a/asmcomp/hppa/emit.mlp +++ b/asmcomp/hppa/emit.mlp @@ -922,7 +922,7 @@ let fundecl fundecl = else ` .callinfo frame={emit_int n}, no_calls\n`; ` .entry\n` - | "linux" -> + | "linux" | "gnu" -> ` .text\n`; ` .align 8\n`; ` .globl {emit_symbol fundecl.fun_name}\n`; diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index bcbfb5f3f..81f94c8fb 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -145,3 +145,10 @@ let print_specific_operation printreg op ppf arg = printreg ppf arg.(i) done +(* Stack alignment constraints *) + +let stack_alignment = + match Config.system with + | "macosx" -> 16 + | _ -> 4 + diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 9a585c1e7..b04b1e9cd 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -14,6 +14,8 @@ (* Emission of Intel 386 assembly code *) +module StringSet = Set.Make(struct type t = string let compare = compare end) + open Location open Misc open Cmm @@ -33,7 +35,9 @@ let stack_offset = ref 0 (* Layout of the stack frame *) let frame_size () = (* includes return address *) - !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 + let sz = + !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 + in Misc.align sz stack_alignment let slot_offset loc cl = match loc with @@ -48,6 +52,8 @@ let slot_offset loc cl = assert (n >= 0); n +let trap_frame_size = Misc.align 8 stack_alignment + (* Prefixing of symbols with "_" *) let symbol_prefix = @@ -56,6 +62,7 @@ let symbol_prefix = | "bsd_elf" -> "" | "solaris" -> "" | "beos" -> "" + | "gnu" -> "" | _ -> "_" let emit_symbol s = @@ -69,6 +76,7 @@ let label_prefix = | "bsd_elf" -> ".L" | "solaris" -> ".L" | "beos" -> ".L" + | "gnu" -> ".L" | _ -> "L" let emit_label lbl = @@ -90,13 +98,21 @@ let use_ascii_dir = "solaris" -> false | _ -> true +(* MacOSX has its own way to reference symbols potentially defined in + shared objects *) + +let macosx = + match Config.system with + | "macosx" -> true + | _ -> false + (* Output a .align directive. The numerical argument to .align is log2 of alignment size, except under ELF, where it is the alignment size... *) let emit_align = match Config.system with - "linux_elf" | "bsd_elf" | "solaris" | "beos" | "cygwin" | "mingw" -> + "linux_elf" | "bsd_elf" | "solaris" | "beos" | "cygwin" | "mingw" | "gnu" -> (fun n -> ` .align {emit_int n}\n`) | _ -> (fun n -> ` .align {emit_int(Misc.log2 n)}\n`) @@ -378,6 +394,9 @@ let tailrec_entry_point = ref 0 let range_check_trap = ref 0 (* Record float literals to be emitted later *) let float_constants = ref ([] : (int * string) list) +(* Record references to external C functions (for MacOSX) *) +let external_symbols_direct = ref StringSet.empty +let external_symbols_indirect = ref StringSet.empty let emit_instr fallthrough i = match i.desc with @@ -439,11 +458,23 @@ let emit_instr fallthrough i = end | Lop(Iextcall(s, alloc)) -> if alloc then begin - ` movl ${emit_symbol s}, %eax\n`; + if not macosx then + ` movl ${emit_symbol s}, %eax\n` + else begin + external_symbols_indirect := + StringSet.add s !external_symbols_indirect; + ` movl L{emit_symbol s}$non_lazy_ptr, %eax\n` + end; ` call {emit_symbol "caml_c_call"}\n`; record_frame i.live end else begin - ` call {emit_symbol s}\n` + if not macosx then + ` call {emit_symbol s}\n` + else begin + external_symbols_direct := + StringSet.add s !external_symbols_direct; + ` call L{emit_symbol s}$stub\n` + end end | Lop(Istackoffset n) -> if n < 0 @@ -734,16 +765,20 @@ let emit_instr fallthrough i = | Lsetuptrap lbl -> ` call {emit_label lbl}\n` | Lpushtrap -> + if trap_frame_size > 8 then + ` subl ${emit_int (trap_frame_size - 8)}, %esp\n`; ` pushl {emit_symbol "caml_exception_pointer"}\n`; ` movl %esp, {emit_symbol "caml_exception_pointer"}\n`; - stack_offset := !stack_offset + 8 + stack_offset := !stack_offset + trap_frame_size | Lpoptrap -> ` popl {emit_symbol "caml_exception_pointer"}\n`; - ` addl $4, %esp\n`; - stack_offset := !stack_offset - 8 + ` addl ${emit_int (trap_frame_size - 4)}, %esp\n`; + stack_offset := !stack_offset - trap_frame_size | Lraise -> ` movl {emit_symbol "caml_exception_pointer"}, %esp\n`; ` popl {emit_symbol "caml_exception_pointer"}\n`; + if trap_frame_size > 8 then + ` addl ${emit_int (trap_frame_size - 8)}, %esp\n`; ` ret\n` let rec emit_all fallthrough i = @@ -762,11 +797,31 @@ let emit_float_constant (lbl, cst) = ` .data\n`; `{emit_label lbl}: .double {emit_string cst}\n` +(* Emission of external symbol references (for MacOSX) *) + +let emit_external_symbol_direct s = + `L{emit_symbol s}$stub:\n`; + ` .indirect_symbol {emit_symbol s}\n`; + ` hlt ; hlt ; hlt ; hlt ; hlt\n` + +let emit_external_symbol_indirect s = + `L{emit_symbol s}$non_lazy_ptr:\n`; + ` .indirect_symbol {emit_symbol s}\n`; + ` .long 0\n` + +let emit_external_symbols () = + ` .section __IMPORT,__pointers,non_lazy_symbol_pointers\n`; + StringSet.iter emit_external_symbol_indirect !external_symbols_indirect; + external_symbols_indirect := StringSet.empty; + ` .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5\n`; + StringSet.iter emit_external_symbol_direct !external_symbols_direct; + external_symbols_direct := StringSet.empty + (* Emission of the profiling prelude *) let emit_profile () = match Config.system with - "linux_elf" -> + "linux_elf" | "gnu" -> ` pushl %eax\n`; ` movl %esp, %ebp\n`; ` pushl %ecx\n`; @@ -791,7 +846,7 @@ let emit_profile () = let declare_function_symbol name = ` .globl {emit_symbol name}\n`; match Config.system with - "linux_elf" | "bsd_elf" -> + "linux_elf" | "bsd_elf" | "gnu" -> ` .type {emit_symbol name},@function\n` | _ -> () @@ -886,4 +941,5 @@ let end_assembly() = `{emit_symbol lbl}:\n`; ` .long {emit_int (List.length !frame_descriptors)}\n`; List.iter emit_frame !frame_descriptors; - frame_descriptors := [] + frame_descriptors := []; + if macosx then emit_external_symbols () diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index f2f79ca5e..85cd18e1e 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -159,6 +159,15 @@ inherit Selectgen.selector_generic as super method is_immediate (n : int) = true +method is_simple_expr e = + match e with + | Cop(Cextcall(fn, _, alloc), args) + when !fast_math && List.mem fn inline_float_ops -> + (* inlined float ops are simple if their arguments are *) + List.for_all self#is_simple_expr args + | _ -> + super#is_simple_expr e + method select_addressing exp = match select_addr exp with (Asymbol s, d) -> @@ -291,18 +300,23 @@ method select_push exp = | _ -> (Ispecific(Ipush), exp) method emit_extcall_args env args = + let rec size_pushes = function + | [] -> 0 + | e :: el -> Selectgen.size_expr env e + size_pushes el in + let sz1 = size_pushes args in + let sz2 = Misc.align sz1 stack_alignment in let rec emit_pushes = function - [] -> 0 + | [] -> + if sz2 > sz1 then + self#insert (Iop (Istackoffset (sz2 - sz1))) [||] [||] | e :: el -> - let ofs = emit_pushes el in + emit_pushes el; let (op, arg) = self#select_push e in - begin match self#emit_expr env arg with - None -> ofs - | Some r -> - self#insert (Iop op) r [||]; - ofs + Selectgen.size_expr env e - end - in ([||], emit_pushes args) + match self#emit_expr env arg with + | None -> () + | Some r -> self#insert (Iop op) r [||] in + emit_pushes args; + ([||], sz2) end diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 4ea85fa51..7cb2c387d 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -76,46 +76,6 @@ let size_expr env exp = fatal_error "Selection.size_expr" in size Tbl.empty exp -(* These are C library functions that are known to be pure - (no side effects at all) and worth not pre-computing. *) - -let pure_external_functions = - ["acos"; "asin"; "atan"; "atan2"; "cos"; "exp"; "log"; - "log10"; "sin"; "sqrt"; "tan"] - -(* Says if an expression is "simple". A "simple" expression has no - side-effects and its execution can be delayed until its value - is really needed. In the case of e.g. an [alloc] instruction, - the non-simple arguments are computed in right-to-left order - first, then the block is allocated, then the simple arguments are - evaluated and stored. *) - -let rec is_simple_expr = function - Cconst_int _ -> true - | Cconst_natint _ -> true - | Cconst_float _ -> true - | Cconst_symbol _ -> true - | Cconst_pointer _ -> true - | Cconst_natpointer _ -> true - | Cvar _ -> true - | Ctuple el -> List.for_all is_simple_expr el - | Clet(id, arg, body) -> is_simple_expr arg && is_simple_expr body - | Csequence(e1, e2) -> is_simple_expr e1 && is_simple_expr e2 - | Cop(op, args) -> - begin match op with - (* The following may have side effects *) - | Capply _ | Calloc | Cstore _ | Craise -> false - (* External C functions normally have side effects, unless known *) - | Cextcall(fn, _, alloc) -> - not alloc && - List.mem fn pure_external_functions && - List.for_all is_simple_expr args - (* The remaining operations are simple if their args are *) - | _ -> - List.for_all is_simple_expr args - end - | _ -> false - (* Swap the two arguments of an integer comparison *) let swap_intcomp = function @@ -201,6 +161,34 @@ let current_function_name = ref "" class virtual selector_generic = object (self) +(* Says if an expression is "simple". A "simple" expression has no + side-effects and its execution can be delayed until its value + is really needed. In the case of e.g. an [alloc] instruction, + the non-simple arguments are computed in right-to-left order + first, then the block is allocated, then the simple arguments are + evaluated and stored. *) + +method is_simple_expr = function + Cconst_int _ -> true + | Cconst_natint _ -> true + | Cconst_float _ -> true + | Cconst_symbol _ -> true + | Cconst_pointer _ -> true + | Cconst_natpointer _ -> true + | Cvar _ -> true + | Ctuple el -> List.for_all self#is_simple_expr el + | Clet(id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body + | Csequence(e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2 + | Cop(op, args) -> + begin match op with + (* The following may have side effects *) + | Capply _ | Cextcall(_, _, _) | Calloc | Cstore _ | Craise -> false + (* The remaining operations are simple if their args are *) + | _ -> + List.for_all self#is_simple_expr args + end + | _ -> false + (* Says whether an integer constant is a suitable immediate argument *) method virtual is_immediate : int -> bool @@ -591,7 +579,7 @@ method private bind_let env v r1 = end method private emit_parts env exp = - if is_simple_expr exp then + if self#is_simple_expr exp then Some (exp, env) else begin match self#emit_expr env exp with diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 1a45e99c5..7ec1724c4 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -28,6 +28,8 @@ class virtual selector_generic : object method virtual select_addressing : Cmm.expression -> Arch.addressing_mode * Cmm.expression (* Must be defined to select addressing modes *) + method is_simple_expr: Cmm.expression -> bool + (* Can be overriden to reflect special extcalls known to be pure *) method select_operation : Cmm.operation -> Cmm.expression list -> Mach.operation * Cmm.expression list diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index dbca9c394..7393d9084 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -76,7 +76,8 @@ let emit_size lbl = ` .size {emit_symbol lbl},.-{emit_symbol lbl}\n` let rodata () = - if Config.system = "solaris" (* || Config.system = "linux" *) then + if Config.system = "solaris" (* || Config.system = "linux" *) + (* || Config.system = "gnu" *) then ` .section \".rodata\"\n` else ` .data\n` diff --git a/asmrun/hppa.S b/asmrun/hppa.S index c8a265e20..b795f52b0 100644 --- a/asmrun/hppa.S +++ b/asmrun/hppa.S @@ -30,7 +30,7 @@ #define LOWLABEL(x) RR%x #endif -#ifdef SYS_linux +#if defined(SYS_linux) || defined(SYS_gnu) #define G(x) x #define CODESPACE .text #define CODE_ALIGN 8 @@ -69,7 +69,7 @@ caml_exception_pointer .comm 8 caml_required_size .comm 8 #endif -#ifdef SYS_linux +#if defined(SYS_linux) || defined(SYS_gnu) .align 8 .comm G(young_limit), 4 .comm G(young_ptr), 4 diff --git a/asmrun/i386.S b/asmrun/i386.S index 5bac7304a..f47d43aca 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -26,7 +26,7 @@ #endif #if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \ - || defined(SYS_solaris) || defined(SYS_beos) + || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_gnu) #define G(x) x #define LBL(x) CONCAT(.L,x) #else @@ -36,14 +36,14 @@ #if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \ || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_cygwin) \ - || defined(SYS_mingw) + || defined(SYS_mingw) || defined(SYS_gnu) #define FUNCTION_ALIGN 4 #else #define FUNCTION_ALIGN 2 #endif #if defined(PROFILING) -#if defined(SYS_linux_elf) +#if defined(SYS_linux_elf) || defined(SYS_gnu) #define PROFILE_CAML \ pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \ call mcount; \ @@ -208,8 +208,12 @@ LBL(106): pushl G(caml_gc_regs) pushl G(caml_last_return_address) pushl G(caml_bottom_of_stack) + /* Note: 16-alignment preserved on MacOSX at this point */ /* Build an exception handler */ pushl $ LBL(108) +#ifdef SYS_macosx + subl $8, %esp /* 16-alignment */ +#endif pushl G(caml_exception_pointer) movl %esp, G(caml_exception_pointer) /* Call the Caml code */ @@ -217,7 +221,11 @@ LBL(106): LBL(107): /* Pop the exception handler */ popl G(caml_exception_pointer) - popl %esi /* dummy register */ +#ifdef SYS_macosx + addl $12, %esp +#else + addl $4, %esp +#endif LBL(109): /* Pop the callback link, restoring the global variables */ popl G(caml_bottom_of_stack) @@ -245,6 +253,9 @@ G(caml_raise_exception): movl 4(%esp), %eax movl G(caml_exception_pointer), %esp popl G(caml_exception_pointer) +#ifdef SYS_macosx + addl $8, %esp +#endif ret /* Callback from C to Caml */ diff --git a/asmrun/signals.c b/asmrun/signals.c index 0262f237a..5f3046514 100644 --- a/asmrun/signals.c +++ b/asmrun/signals.c @@ -52,18 +52,23 @@ extern char * caml_code_area_start, * caml_code_area_end; ((char *)(pc) >= caml_code_area_start && \ (char *)(pc) <= caml_code_area_end) +intnat volatile caml_signals_are_pending = 0; volatile intnat caml_pending_signals[NSIG]; volatile int caml_force_major_slice = 0; value caml_signal_handlers = 0; static void caml_process_pending_signals(void) { - int signal_num; - intnat signal_state; + int i; - for (signal_num = 0; signal_num < NSIG; signal_num++) { - Read_and_clear(signal_state, caml_pending_signals[signal_num]); - if (signal_state) caml_execute_signal(signal_num, 0); + if (caml_signals_are_pending) { + caml_signals_are_pending = 0; + for (i = 0; i < NSIG; i++) { + if (caml_pending_signals[i]) { + caml_pending_signals[i] = 0; + caml_execute_signal(i, 0); + } + } } } @@ -132,6 +137,7 @@ void caml_execute_signal(int signal_number, int in_signal_handler) void caml_record_signal(int signal_number) { caml_pending_signals[signal_number] = 1; + caml_signals_are_pending = 1; caml_young_limit = caml_young_end; } @@ -153,10 +159,7 @@ void caml_garbage_collection(void) if (caml_young_ptr < caml_young_start || caml_force_major_slice) { caml_minor_collection(); } - for (signal_number = 0; signal_number < NSIG; signal_number++) { - Read_and_clear(signal_state, caml_pending_signals[signal_number]); - if (signal_state) caml_execute_signal(signal_number, 0); - } + caml_process_pending_signals(); } /* Trigger a garbage collection as soon as possible */ @@ -173,18 +176,13 @@ void caml_urge_major_slice (void) void caml_enter_blocking_section(void) { - int i; - intnat pending; - while (1){ /* Process all pending signals now */ caml_process_pending_signals(); caml_enter_blocking_section_hook (); - /* Check again for pending signals. */ - pending = 0; - for (i = 0; i < NSIG; i++) pending |= caml_pending_signals[i]; - /* If none, done; otherwise, try again */ - if (!pending) break; + /* Check again for pending signals. + If none, done; otherwise, try again */ + if (! caml_signals_are_pending) break; caml_leave_blocking_section_hook (); } } diff --git a/asmrun/stack.h b/asmrun/stack.h index a28711983..9805bfb69 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -34,8 +34,12 @@ #ifdef TARGET_i386 #define Saved_return_address(sp) *((intnat *)((sp) - 4)) +#ifdef SYS_macosx +#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) +#else #define Callback_link(sp) ((struct caml_context *)((sp) + 8)) #endif +#endif #ifdef TARGET_mips #define Saved_return_address(sp) *((intnat *)((sp) - 4)) diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex dd881efe0..159483667 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex e3d9c5a53..937f6b8fd 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index a0860b6c2..d9be85e0c 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -107,7 +107,7 @@ let create_object cl obj init = Lsequence(obj_init, if not has_init then Lvar obj' else Lapply (oo_prim "run_initializers_opt", - [obj; Lvar obj'; Lvar cl])))) + [obj; Lvar obj'; Lvar cl])))) end let rec build_object_init cl_table obj params inh_init obj_init cl = @@ -198,7 +198,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = let ((_,inh_init), obj_init) = build_object_init cl_table obj params (envs,[]) (copy_env env) cl in let obj_init = - if ids = [] then obj_init else lfunction [self] obj_init in + if ids = [] then obj_init else lfunction [self] obj_init in (inh_init, lfunction [env] (subst_env env inh_init obj_init)) @@ -251,11 +251,11 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = Tclass_ident path -> begin match inh_init with (obj_init, path')::inh_init -> - let lpath = transl_path path in + let lpath = transl_path path in (inh_init, - Llet (Strict, obj_init, + Llet (Strict, obj_init, Lapply(Lprim(Pfield 1, [lpath]), Lvar cla :: - if top then [Lprim(Pfield 3, [lpath])] else []), + if top then [Lprim(Pfield 3, [lpath])] else []), bind_super cla super cl_init)) | _ -> assert false @@ -323,15 +323,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in let concr_meths = Concr.elements concr_meths in let narrow_args = - [Lvar cla; + [Lvar cla; transl_meth_list vals; transl_meth_list virt_meths; transl_meth_list concr_meths] in let cl = ignore_cstrs cl in begin match cl.cl_desc, inh_init with - Tclass_ident path, (obj_init, path')::inh_init -> - assert (Path.same path path'); - let lpath = transl_path path in + Tclass_ident path, (obj_init, path')::inh_init -> + assert (Path.same path path'); + let lpath = transl_path path in let inh = Ident.create "inh" and ofs = List.length vals + 1 and valids, methids = super in @@ -347,15 +347,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = Llet(StrictOpt, id, lfield inh (index nm vals + 1), init)) cl_init valids in (inh_init, - Llet (Strict, inh, - Lapply(oo_prim "inherits", narrow_args @ - [lpath; Lconst(Const_pointer(if top then 1 else 0))]), + Llet (Strict, inh, + Lapply(oo_prim "inherits", narrow_args @ + [lpath; Lconst(Const_pointer(if top then 1 else 0))]), Llet(StrictOpt, obj_init, lfield inh 0, cl_init))) | _ -> - let core cl_init = + let core cl_init = build_class_init cla true super inh_init cl_init msubst top cl - in - if cstr then core cl_init else + in + if cstr then core cl_init else let (inh_init, cl_init) = core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init)) in @@ -625,6 +625,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = begin try (* Doesn't seem to improve size for bytecode *) (* if not !Clflags.native_code then raise Not_found; *) + if !Clflags.debug then raise Not_found; builtin_meths arr [self] env env2 (lfunction args body') with Not_found -> [lfunction (self :: args) @@ -695,7 +696,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = and lbody fv = if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then Lapply (oo_prim "make_class",[transl_meth_list pub_meths; - Lvar class_init]) + Lvar class_init]) else ltable table ( Llet( @@ -703,8 +704,8 @@ let transl_class ids cl_id arity pub_meths cl vflag = Lsequence( Lapply (oo_prim "init_class", [Lvar table]), Lprim(Pmakeblock(0, Immutable), - [Lapply(Lvar env_init, [lambda_unit]); - Lvar class_init; Lvar env_init; lambda_unit])))) + [Lapply(Lvar env_init, [lambda_unit]); + Lvar class_init; Lvar env_init; lambda_unit])))) and lbody_virt lenvs = Lprim(Pmakeblock(0, Immutable), [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs]) diff --git a/byterun/io.c b/byterun/io.c index e875e7476..944bac87b 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -230,7 +230,7 @@ CAMLexport int caml_putblock(struct channel *channel, char *p, intnat len) } } -CAMLexport void caml_really_putblock(struct channel *channel, +CAMLexport void caml_really_putblock(struct channel *channel, char *p, intnat len) { int written; @@ -450,7 +450,7 @@ CAMLprim value caml_ml_out_channels_list (value unit) res = Val_emptylist; for (channel = caml_all_opened_channels; channel != NULL; - channel = channel->next) + channel = channel->next) /* Testing channel->fd >= 0 looks unnecessary, as caml_ml_close_channel changes max when setting fd to -1. */ if (channel->max == NULL) { @@ -530,6 +530,7 @@ CAMLprim value caml_ml_set_binary_mode(value vchannel, value mode) CAMLprim value caml_ml_flush_partial(value vchannel) { + CAMLparam1 (vchannel); struct channel * channel = Channel(vchannel); int res; @@ -537,36 +538,41 @@ CAMLprim value caml_ml_flush_partial(value vchannel) Lock(channel); res = caml_flush_partial(channel); Unlock(channel); - return Val_bool(res); + CAMLreturn (Val_bool(res)); } CAMLprim value caml_ml_flush(value vchannel) { + CAMLparam1 (vchannel); struct channel * channel = Channel(vchannel); if (channel->fd == -1) return Val_unit; Lock(channel); caml_flush(channel); Unlock(channel); - return Val_unit; + CAMLreturn (Val_unit); } CAMLprim value caml_ml_output_char(value vchannel, value ch) { + CAMLparam2 (vchannel, ch); struct channel * channel = Channel(vchannel); + Lock(channel); putch(channel, Long_val(ch)); Unlock(channel); - return Val_unit; + CAMLreturn (Val_unit); } CAMLprim value caml_ml_output_int(value vchannel, value w) { + CAMLparam2 (vchannel, w); struct channel * channel = Channel(vchannel); + Lock(channel); caml_putword(channel, Long_val(w)); Unlock(channel); - return Val_unit; + CAMLreturn (Val_unit); } CAMLprim value caml_ml_output_partial(value vchannel, value buff, value start, @@ -602,20 +608,24 @@ CAMLprim value caml_ml_output(value vchannel, value buff, value start, CAMLprim value caml_ml_seek_out(value vchannel, value pos) { + CAMLparam2 (vchannel, pos); struct channel * channel = Channel(vchannel); + Lock(channel); caml_seek_out(channel, Long_val(pos)); Unlock(channel); - return Val_unit; + CAMLreturn (Val_unit); } CAMLprim value caml_ml_seek_out_64(value vchannel, value pos) { + CAMLparam2 (vchannel, pos); struct channel * channel = Channel(vchannel); + Lock(channel); caml_seek_out(channel, File_offset_val(pos)); Unlock(channel); - return Val_unit; + CAMLreturn (Val_unit); } CAMLprim value caml_ml_pos_out(value vchannel) @@ -632,17 +642,19 @@ CAMLprim value caml_ml_pos_out_64(value vchannel) CAMLprim value caml_ml_input_char(value vchannel) { + CAMLparam1 (vchannel); struct channel * channel = Channel(vchannel); unsigned char c; Lock(channel); c = getch(channel); Unlock(channel); - return Val_long(c); + CAMLreturn (Val_long(c)); } CAMLprim value caml_ml_input_int(value vchannel) { + CAMLparam1 (vchannel); struct channel * channel = Channel(vchannel); intnat i; @@ -652,7 +664,7 @@ CAMLprim value caml_ml_input_int(value vchannel) #ifdef ARCH_SIXTYFOUR i = (i << 32) >> 32; /* Force sign extension */ #endif - return Val_long(i); + CAMLreturn (Val_long(i)); } CAMLprim value caml_ml_input(value vchannel, value buff, value vstart, @@ -692,20 +704,24 @@ CAMLprim value caml_ml_input(value vchannel, value buff, value vstart, CAMLprim value caml_ml_seek_in(value vchannel, value pos) { + CAMLparam2 (vchannel, pos); struct channel * channel = Channel(vchannel); + Lock(channel); caml_seek_in(channel, Long_val(pos)); Unlock(channel); - return Val_unit; + CAMLreturn (Val_unit); } CAMLprim value caml_ml_seek_in_64(value vchannel, value pos) { + CAMLparam2 (vchannel, pos); struct channel * channel = Channel(vchannel); + Lock(channel); caml_seek_in(channel, File_offset_val(pos)); Unlock(channel); - return Val_unit; + CAMLreturn (Val_unit); } CAMLprim value caml_ml_pos_in(value vchannel) @@ -722,13 +738,14 @@ CAMLprim value caml_ml_pos_in_64(value vchannel) CAMLprim value caml_ml_input_scan_line(value vchannel) { + CAMLparam1 (vchannel); struct channel * channel = Channel(vchannel); intnat res; Lock(channel); res = caml_input_scan_line(channel); Unlock(channel); - return Val_long(res); + CAMLreturn (Val_long(res)); } /* Conversion between file_offset and int64 */ diff --git a/byterun/md5.c b/byterun/md5.c index aa18b7240..9d2481fe9 100644 --- a/byterun/md5.c +++ b/byterun/md5.c @@ -17,6 +17,7 @@ #include "alloc.h" #include "fail.h" #include "md5.h" +#include "memory.h" #include "mlvalues.h" #include "io.h" #include "reverse.h" @@ -36,6 +37,7 @@ CAMLprim value caml_md5_string(value str, value ofs, value len) CAMLprim value caml_md5_chan(value vchan, value len) { + CAMLparam2 (vchan, len); struct channel * chan = Channel(vchan); struct MD5Context ctx; value res; @@ -63,7 +65,7 @@ CAMLprim value caml_md5_chan(value vchan, value len) res = caml_alloc_string(16); caml_MD5Final(&Byte_u(res, 0), &ctx); Unlock(chan); - return res; + CAMLreturn (res); } /* @@ -163,7 +165,7 @@ CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf, } /* - * Final wrapup - pad to 64-byte boundary with the bit pattern + * Final wrapup - pad to 64-byte boundary with the bit pattern * 1 0* (64-bit count of bits processed, MSB-first) */ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx) diff --git a/byterun/signals.c b/byterun/signals.c index a02f6b859..1f0d1284e 100644 --- a/byterun/signals.c +++ b/byterun/signals.c @@ -36,6 +36,7 @@ extern sighandler caml_win32_signal(int sig, sighandler action); #define signal(sig,act) caml_win32_signal(sig,act) #endif +CAMLexport intnat volatile caml_signals_are_pending = 0; CAMLexport intnat volatile caml_pending_signals[NSIG]; CAMLexport int volatile caml_something_to_do = 0; int volatile caml_force_major_slice = 0; @@ -44,12 +45,16 @@ CAMLexport void (* volatile caml_async_action_hook)(void) = NULL; static void caml_process_pending_signals(void) { - int signal_num; - intnat signal_state; + int i; - for (signal_num = 0; signal_num < NSIG; signal_num++) { - Read_and_clear(signal_state, caml_pending_signals[signal_num]); - if (signal_state) caml_execute_signal(signal_num, 0); + if (caml_signals_are_pending) { + caml_signals_are_pending = 0; + for (i = 0; i < NSIG; i++) { + if (caml_pending_signals[i]) { + caml_pending_signals[i] = 0; + caml_execute_signal(i, 0); + } + } } } @@ -60,8 +65,11 @@ void caml_process_event(void) if (caml_force_major_slice) caml_minor_collection (); /* FIXME should be [caml_check_urgent_gc] */ caml_process_pending_signals(); - Read_and_clear(async_action, caml_async_action_hook); - if (async_action != NULL) (*async_action)(); + async_action = caml_async_action_hook; + if (async_action != NULL) { + caml_async_action_hook = NULL; + (*async_action)(); + } } static intnat volatile caml_async_signal_mode = 0; @@ -129,6 +137,7 @@ void caml_execute_signal(int signal_number, int in_signal_handler) void caml_record_signal(int signal_number) { caml_pending_signals[signal_number] = 1; + caml_signals_are_pending = 1; caml_something_to_do = 1; } @@ -154,18 +163,13 @@ void caml_urge_major_slice (void) CAMLexport void caml_enter_blocking_section(void) { - int i; - intnat pending; - while (1){ /* Process all pending signals now */ caml_process_pending_signals(); caml_enter_blocking_section_hook (); - /* Check again for pending signals. */ - pending = 0; - for (i = 0; i < NSIG; i++) pending |= caml_pending_signals[i]; - /* If none, done; otherwise, try again */ - if (!pending) break; + /* Check again for pending signals. + If none, done; otherwise, try again */ + if (! caml_signals_are_pending) break; caml_leave_blocking_section_hook (); } } diff --git a/byterun/signals.h b/byterun/signals.h index e1b5df190..b3d20bb02 100644 --- a/byterun/signals.h +++ b/byterun/signals.h @@ -24,6 +24,7 @@ /* <private> */ extern value caml_signal_handlers; +CAMLextern intnat volatile caml_signals_are_pending; CAMLextern intnat volatile caml_pending_signals[]; CAMLextern int volatile caml_something_to_do; extern int volatile caml_force_major_slice; diff --git a/camlp4/etc/pr_o.ml b/camlp4/etc/pr_o.ml index 210494383..dc2d60a45 100644 --- a/camlp4/etc/pr_o.ml +++ b/camlp4/etc/pr_o.ml @@ -1408,8 +1408,8 @@ pr_expr.pr_levels := <:expr< while $_$ do { $list:_$ } >> | <:expr< ($list: _$) >> | <:expr< let $opt:_$ $list:_$ in $_$ >> | <:expr< let module $_$ = $_$ in $_$ >> | - (* Note: `new' is treated differently in pa_o and in pa_r, - and should not occur at this level *) + (* Note: `new' is treated differently in pa_o and in pa_r, + and should not occur at this level *) <:expr< assert $_$ >> | <:expr< lazy $_$ >> as e -> fun curr next dg k -> [: `S LO "("; `expr e "" [: `HVbox [: `S RO ")"; k :] :] :] @@ -42,7 +42,7 @@ gcc_warnings="-Wall" # Try to turn internationalization off, can cause config.guess to malfunction! unset LANG -unset LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME +unset LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME # Turn off some MacOS X debugging stuff, same reason unset RC_TRACE_ARCHIVES RC_TRACE_DYLIBS RC_TRACE_PREBINDING_DISABLED @@ -408,7 +408,7 @@ case "$host" in # alignment is not reliable (PR#1521), hence force it. # Same goes for hppa. # But there's a knack (PR#2572): - # if we're in 64-bit mode (sizeof(long) == 8), + # if we're in 64-bit mode (sizeof(long) == 8), # we must not doubleword-align floats... if test $2 = 8; then echo "Doubles can be word-aligned." @@ -483,7 +483,7 @@ mksharedlibrpath='' if test $withsharedlibs = "yes"; then case "$host" in - *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*) + *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-gnu*) sharedcccompopts="-fPIC" mksharedlib="$bytecc -shared -o" bytecclinkopts="$bytecclinkopts -Wl,-E" @@ -562,6 +562,7 @@ system=unknown case "$host" in alpha*-*-osf*) arch=alpha; system=digital;; alpha*-*-linux*) arch=alpha; system=linux;; + alpha*-*-gnu*) arch=alpha; system=gnu;; alpha*-*-freebsd*) arch=alpha; system=freebsd;; alpha*-*-netbsd*) arch=alpha; system=netbsd;; alpha*-*-openbsd*) arch=alpha; system=openbsd;; @@ -569,24 +570,31 @@ case "$host" in sparc*-*-solaris2.*) arch=sparc; system=solaris;; sparc*-*-*bsd*) arch=sparc; system=bsd;; sparc*-*-linux*) arch=sparc; system=linux;; + sparc*-*-gnu*) arch=sparc; system=gnu;; i[3456]86-*-linux*) arch=i386; system=linux_`sh ./runtest elf.c`;; i[3456]86-*-*bsd*) arch=i386; system=bsd_`sh ./runtest elf.c`;; i[3456]86-*-nextstep*) arch=i386; system=nextstep;; i[3456]86-*-solaris*) arch=i386; system=solaris;; i[3456]86-*-beos*) arch=i386; system=beos;; i[3456]86-*-cygwin*) arch=i386; system=cygwin;; + i[3456]86-*-darwin*) arch=i386; system=macosx;; + i[3456]86-*-gnu*) arch=i386; system=gnu;; mips-*-irix6*) arch=mips; system=irix;; hppa1.1-*-hpux*) arch=hppa; system=hpux;; hppa2.0*-*-hpux*) arch=hppa; system=hpux;; - hppa*-*-linux*) arch=hppa; system=linux;; + hppa*-*-linux*) arch=hppa; system=linux;; + hppa*-*-gnu*) arch=hppa; system=gnu;; powerpc-*-linux*) arch=power; model=ppc; system=elf;; powerpc-*-netbsd*) arch=power; model=ppc; system=bsd;; powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;; powerpc-*-darwin*) arch=power; model=ppc; system=rhapsody;; arm*-*-linux*) arch=arm; system=linux;; + arm*-*-gnu*) arch=arm; system=gnu;; ia64-*-linux*) arch=ia64; system=linux;; + ia64-*-gnu*) arch=ia64; system=gnu;; ia64-*-freebsd*) arch=ia64; system=freebsd;; x86_64-*-linux*) arch=amd64; system=linux;; + x86_64-*-gnu*) arch=amd64; system=gnu;; x86_64-*-freebsd*) arch=amd64; system=freebsd;; x86_64-*-netbsd*) arch=amd64; system=netbsd;; x86_64-*-openbsd*) arch=amd64; system=openbsd;; @@ -629,12 +637,14 @@ case "$arch,$model,$system" in alpha,*,digital) asflags='-O2'; asppflags='-O2 -DSYS_$(SYSTEM)'; asppprofflags='-pg -DPROFILING';; alpha,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; + alpha,*,gnu) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; alpha,*,freebsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; alpha,*,netbsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; alpha,*,openbsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; mips,*,irix) asflags='-n32 -O2'; asppflags="$asflags";; sparc,*,bsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; sparc,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; + sparc,*,gnu) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; sparc,*,*) case "$cc" in gcc*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; *) asppflags='-P -DSYS_$(SYSTEM)';; @@ -646,6 +656,7 @@ case "$arch,$model,$system" in power,*,bsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; power,*,rhapsody) ;; arm,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; + arm,*,gnu) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; ia64,*,*) asflags=-xexplicit aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM) -Wa,-xexplicit';; amd64,*,*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; @@ -655,11 +666,13 @@ cc_profile='-pg' case "$arch,$model,$system" in alpha,*,digital) profiling='prof';; i386,*,linux_elf) profiling='prof';; + i386,*,gnu) profiling='prof';; i386,*,bsd_elf) profiling='prof';; sparc,*,solaris) profiling='prof' case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;; amd64,*,linux) profiling='prof';; + amd64,*,gnu) profiling='prof';; *) profiling='noprof';; esac @@ -1242,7 +1255,7 @@ for dir in /usr/include /usr/include/db1 /usr/include/gdbm; do elif sh ./hasgot -lgdbm dbm_open; then dbm_link="-lgdbm" elif sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then - dbm_link="-lgdbm_compat -lgdbm" + dbm_link="-lgdbm_compat -lgdbm" fi break fi @@ -1252,7 +1265,7 @@ for dir in /usr/include /usr/include/db1 /usr/include/gdbm; do if sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then dbm_link="-lgdbm_compat -lgdbm" fi - break + break fi done if test "$dbm_include" = "not found" || test "$dbm_link" = "not found"; then @@ -1523,4 +1536,3 @@ fi echo echo "** Objective Caml configuration completed successfully **" echo - diff --git a/driver/opterrors.ml b/driver/opterrors.ml index a59e6f265..6a5f032e0 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -65,7 +65,7 @@ let report_error ppf exn = | Sys_error msg -> fprintf ppf "I/O error: %s" msg | Warnings.Errors (n) -> - fprintf ppf "@.Error: %d error-enabled warnings occurred." n + fprintf ppf "@.Error: error-enabled warnings (%d occurrences)" n | x -> fprintf ppf "@]"; raise x in fprintf ppf "@[%a@]@." report exn diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 28cdf08a5..b9b27e288 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -186,7 +186,7 @@ let process_error exn = | Translclass.Error(loc, err) -> Location.print ppf loc; Translclass.report_error ppf err | Warnings.Errors (n) -> - fprintf ppf "@.Error: %d error-enabled warnings occurred." n + fprintf ppf "@.Error: error-enabled warnings (%d occurrences)" n | x -> fprintf ppf "@]"; fprintf ppf "Compilation error. Use the OCaml compiler to get more details." @@ -290,7 +290,7 @@ let process_file ppf sourcefile = Odoc_module.m_top_deps = [] ; Odoc_module.m_code = None ; Odoc_module.m_code_intf = None ; - Odoc_module.m_text_only = true ; + Odoc_module.m_text_only = true ; } in Some m diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml index bc7de439f..e55ce989a 100644 --- a/otherlibs/labltk/browser/main.ml +++ b/otherlibs/labltk/browser/main.ml @@ -117,7 +117,7 @@ let _ = "points to the Objective Caml library." Config.standard_library) end; - + Searchpos.view_defined_ref := (fun s ~env -> Viewer.view_defined s ~env); Searchpos.editor_ref := Editor.f; @@ -126,7 +126,7 @@ let _ = (* bind top ~events:[`Destroy] ~action:(fun _ -> exit 0); *) at_exit Shell.kill_all; - + if !st then Viewer.st_viewer ~on:top () else Viewer.f ~on:top (); diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index 460a396bc..fcd0f505d 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -305,7 +305,8 @@ static void * caml_thread_tick(void * arg) select(0, NULL, NULL, NULL, &timeout); /* This signal should never cause a callback, so don't go through handle_signal(), tweak the global variable directly. */ - pending_signals[SIGVTALRM] = 1; + caml_pending_signals[SIGVTALRM] = 1; + caml_signals_are_pending = 1; #ifdef NATIVE_CODE young_limit = young_end; #else diff --git a/otherlibs/systhreads/win32.c b/otherlibs/systhreads/win32.c index 7ef5f49ce..b505a0f98 100644 --- a/otherlibs/systhreads/win32.c +++ b/otherlibs/systhreads/win32.c @@ -256,7 +256,8 @@ static DWORD WINAPI caml_thread_tick(void * arg) { while(1) { Sleep(Thread_timeout); - pending_signals[SIGTIMER] = 1; + caml_pending_signals[SIGTIMER] = 1; + caml_signals_are_pending = 1; #ifdef NATIVE_CODE young_limit = young_end; #else diff --git a/otherlibs/unix/times.c b/otherlibs/unix/times.c index 9952cb7ac..aa32f10db 100644 --- a/otherlibs/unix/times.c +++ b/otherlibs/unix/times.c @@ -20,6 +20,10 @@ #include <time.h> #include <sys/types.h> #include <sys/times.h> +#ifdef HAS_GETRUSAGE +#include <sys/time.h> +#include <sys/resource.h> +#endif #ifndef CLK_TCK #ifdef HZ @@ -31,6 +35,23 @@ CAMLprim value unix_times(value unit) { +#ifdef HAS_GETRUSAGE + + value res; + struct rusage ru; + + res = alloc_small(4 * Double_wosize, Double_array_tag); + + getrusage (RUSAGE_SELF, &ru); + Store_double_field (res, 0, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6); + Store_double_field (res, 1, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6); + getrusage (RUSAGE_CHILDREN, &ru); + Store_double_field (res, 2, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6); + Store_double_field (res, 3, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6); + return res; + +#else + value res; struct tms buffer; @@ -41,4 +62,6 @@ CAMLprim value unix_times(value unit) Store_double_field(res, 2, (double) buffer.tms_cutime / CLK_TCK); Store_double_field(res, 3, (double) buffer.tms_cstime / CLK_TCK); return res; + +#endif } diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index eeb5411de..daa3c9d9d 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -165,11 +165,11 @@ val execve : string -> string array -> string array -> 'a environment to the program executed. *) val execvp : string -> string array -> 'a -(** Same as {!Unix.execv} respectively, except that +(** Same as {!Unix.execv}, except that the program is searched in the path. *) val execvpe : string -> string array -> string array -> 'a -(** Same as {!Unix.execvp} respectively, except that +(** Same as {!Unix.execve}, except that the program is searched in the path. *) val fork : unit -> int diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c index 6a1259acd..a0ba3ca8d 100644 --- a/otherlibs/win32unix/stat.c +++ b/otherlibs/win32unix/stat.c @@ -42,30 +42,25 @@ static int file_kind_table[] = { static value stat_aux(int use_64, struct _stati64 *buf) { - value v; - value atime = Val_unit, mtime = Val_unit, ctime = Val_unit; + CAMLparam0 (); + CAMLlocal1 (v); - Begin_roots3(atime,mtime,ctime) - atime = copy_double((double) buf->st_atime); - mtime = copy_double((double) buf->st_mtime); - ctime = copy_double((double) buf->st_ctime); - v = alloc_small(12, 0); - Field (v, 0) = Val_int (buf->st_dev); - Field (v, 1) = Val_int (buf->st_ino); - Field (v, 2) = cst_to_constr(buf->st_mode & S_IFMT, file_kind_table, - sizeof(file_kind_table) / sizeof(int), 0); - Field (v, 3) = Val_int(buf->st_mode & 07777); - Field (v, 4) = Val_int (buf->st_nlink); - Field (v, 5) = Val_int (buf->st_uid); - Field (v, 6) = Val_int (buf->st_gid); - Field (v, 7) = Val_int (buf->st_rdev); - Field (v, 8) = - use_64 ? copy_int64(buf->st_size) : Val_int (buf->st_size); - Field (v, 9) = atime; - Field (v, 10) = mtime; - Field (v, 11) = ctime; - End_roots(); - return v; + v = caml_alloc (12, 0); + Store_field (v, 0, Val_int (buf->st_dev)); + Store_field (v, 1, Val_int (buf->st_ino)); + Store_field (v, 2, cst_to_constr (buf->st_mode & S_IFMT, file_kind_table, + sizeof(file_kind_table) / sizeof(int), 0)); + Store_field (v, 3, Val_int(buf->st_mode & 07777)); + Store_field (v, 4, Val_int (buf->st_nlink)); + Store_field (v, 5, Val_int (buf->st_uid)); + Store_field (v, 6, Val_int (buf->st_gid)); + Store_field (v, 7, Val_int (buf->st_rdev)); + Store_field (v, 8, + use_64 ? copy_int64(buf->st_size) : Val_int (buf->st_size)); + Store_field (v, 9, copy_double((double) buf->st_atime)); + Store_field (v, 10, copy_double((double) buf->st_mtime)); + Store_field (v, 11, copy_double((double) buf->st_ctime)); + CAMLreturn (v); } CAMLprim value unix_stat(value path) diff --git a/parsing/.cvsignore b/parsing/.cvsignore index 260727a78..5602bf8a2 100644 --- a/parsing/.cvsignore +++ b/parsing/.cvsignore @@ -5,3 +5,5 @@ lexer_tmp.mll lexer_tmp.ml linenum.ml parser.output +parser.automaton +parser.conflicts diff --git a/parsing/parser.mly b/parsing/parser.mly index a0dc9ddcd..74200717b 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -180,7 +180,7 @@ let bigarray_set arr arg newval = ["", arr; "", c1; "", c2; "", c3; "", newval])) | coords -> mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")), - ["", arr; + ["", arr; "", ghexp(Pexp_array coords); "", newval])) %} @@ -1308,6 +1308,10 @@ simple_core_type2: { mktyp(Ptyp_class($5, List.rev $2, $6)) } | LBRACKET tag_field RBRACKET { mktyp(Ptyp_variant([$2], true, None)) } +/* PR#3835: this is not LR(1), would need lookahead=2 + | LBRACKET simple_core_type2 RBRACKET + { mktyp(Ptyp_variant([$2], true, None)) } +*/ | LBRACKET BAR row_field_list RBRACKET { mktyp(Ptyp_variant(List.rev $3, true, None)) } | LBRACKET row_field BAR row_field_list RBRACKET diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt index 9ef5c8a18..ba34029d3 100644 --- a/stdlib/Makefile.nt +++ b/stdlib/Makefile.nt @@ -32,7 +32,8 @@ OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \ printf.cmo format.cmo scanf.cmo \ arg.cmo printexc.cmo gc.cmo \ - digest.cmo random.cmo callback.cmo camlinternalOO.cmo oo.cmo \ + digest.cmo random.cmo callback.cmo \ + camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ genlex.cmo weak.cmo \ lazy.cmo filename.cmo complex.cmo \ arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo diff --git a/stdlib/filename.ml b/stdlib/filename.ml index d6c24fc1b..3883a40a9 100644 --- a/stdlib/filename.ml +++ b/stdlib/filename.ml @@ -25,6 +25,24 @@ let generic_quote quotequote s = Buffer.add_char b '\''; Buffer.contents b +let generic_basename rindex_dir_sep current_dir_name name = + let raw_name = + try + let p = rindex_dir_sep name + 1 in + String.sub name p (String.length name - p) + with Not_found -> + name + in + if raw_name = "" then current_dir_name else raw_name + +let generic_dirname rindex_dir_sep current_dir_name dir_sep name = + try + match rindex_dir_sep name with + 0 -> dir_sep + | n -> String.sub name 0 n + with Not_found -> + current_dir_name + module Unix = struct let current_dir_name = "." let parent_dir_name = ".." @@ -43,6 +61,8 @@ module Unix = struct let temp_dir_name = try Sys.getenv "TMPDIR" with Not_found -> "/tmp" let quote = generic_quote "'\\''" + let basename = generic_basename rindex_dir_sep current_dir_name + let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep end module Win32 = struct @@ -53,7 +73,7 @@ module Win32 = struct let rindex_dir_sep s = let rec pos i = if i < 0 then raise Not_found - else if (let c = s.[i] in c = '/' || c = '\\' || c = ':') then i + else if is_dir_sep s i then i else pos (i - 1) in pos (String.length s - 1) let is_relative n = @@ -87,6 +107,23 @@ module Win32 = struct done; Buffer.add_char b '\"'; Buffer.contents b + let has_drive s = + let is_letter = function + | 'A' .. 'Z' | 'a' .. 'z' -> true + | _ -> false + in + String.length s >= 2 && is_letter s.[0] && s.[1] = ':' + let drive_and_path s = + if has_drive s + then (String.sub s 0 2, String.sub s 2 (String.length s - 2)) + else ("", s) + let dirname s = + let (drive, path) = drive_and_path s in + let dir = generic_dirname rindex_dir_sep current_dir_name dir_sep path in + drive ^ dir + let basename s = + let (drive, path) = drive_and_path s in + generic_basename rindex_dir_sep current_dir_name path end module Cygwin = struct @@ -100,26 +137,29 @@ module Cygwin = struct let check_suffix = Win32.check_suffix let temp_dir_name = Unix.temp_dir_name let quote = Unix.quote + let basename = generic_basename rindex_dir_sep current_dir_name + let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep end let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep, rindex_dir_sep, - is_relative, is_implicit, check_suffix, temp_dir_name, quote) = + is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename, + dirname) = match Sys.os_type with "Unix" -> (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep, Unix.is_dir_sep, Unix.rindex_dir_sep, Unix.is_relative, Unix.is_implicit, Unix.check_suffix, - Unix.temp_dir_name, Unix.quote) + Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname) | "Win32" -> (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep, Win32.is_dir_sep, Win32.rindex_dir_sep, Win32.is_relative, Win32.is_implicit, Win32.check_suffix, - Win32.temp_dir_name, Win32.quote) + Win32.temp_dir_name, Win32.quote, Win32.basename, Win32.dirname) | "Cygwin" -> (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep, Cygwin.is_dir_sep, Cygwin.rindex_dir_sep, Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix, - Cygwin.temp_dir_name, Cygwin.quote) + Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname) | _ -> assert false let concat dirname filename = @@ -128,24 +168,6 @@ let concat dirname filename = then dirname ^ filename else dirname ^ dir_sep ^ filename -let basename name = - let raw_name = - try - let p = rindex_dir_sep name + 1 in - String.sub name p (String.length name - p) - with Not_found -> - name - in - if raw_name = "" then current_dir_name else raw_name - -let dirname name = - try - match rindex_dir_sep name with - 0 -> dir_sep - | n -> String.sub name 0 n - with Not_found -> - current_dir_name - let chop_suffix name suff = let n = String.length name - String.length suff in if n < 0 then invalid_arg "Filename.chop_suffix" else String.sub name 0 n diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 1af15bd4a..7ed1b5aec 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -172,10 +172,12 @@ external ( mod ) : int -> int -> int = "%modint" [x = (x / y) * y + x mod y] and [abs(x mod y) <= abs(y)-1]. If [y = 0], [x mod y] raises [Division_by_zero]. - Notice that [x mod y] is negative if and only if [x < 0]. *) + Notice that [x mod y] is nonpositive if and only if [x < 0]. + Raise [Division_by_zero] if [y] is zero. *) val abs : int -> int -(** Return the absolute value of the argument. *) +(** Return the absolute value of the argument. Note that this may be + negative if the argument is [min_int]. *) val max_int : int (** The greatest representable integer. *) diff --git a/stdlib/printf.ml b/stdlib/printf.ml index 69c2ecf63..872fc076c 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -296,7 +296,7 @@ let kapr kpr fmt = else Obj.magic (fun x -> loop (succ i) (x :: args)) in loop 0 [];; -type param_spec = Spec_none | Spec_index of index;; +type param_spec = Spec_none | Spec_index of index;; (* To scan an optional positional parameter specification, i.e. an integer followed by a $. diff --git a/stdlib/sys.ml b/stdlib/sys.ml index 7ed1a5071..2bf16cc39 100644 --- a/stdlib/sys.ml +++ b/stdlib/sys.ml @@ -78,4 +78,4 @@ let catch_break on = (* OCaml version string, must be in the format described in sys.mli. *) -let ocaml_version = "3.10+dev6 (2006-04-05)";; +let ocaml_version = "3.10+dev7 (2006-04-17)";; diff --git a/tools/checkstack.c b/tools/checkstack.c index 14b5726fb..5250e29d6 100644 --- a/tools/checkstack.c +++ b/tools/checkstack.c @@ -14,6 +14,7 @@ /* $Id$ */ #include <stdio.h> +#include <stdlib.h> #include <sys/types.h> #include <sys/time.h> #include <sys/resource.h> diff --git a/typing/printtyp.ml b/typing/printtyp.ml index a1ac5c483..1f2be9a10 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -130,7 +130,7 @@ and raw_type_desc ppf = function fprintf ppf "@[<hov1>Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f (safe_kind_repr [] k) raw_type t1 raw_type t2 - | Tnil -> fprintf ppf "Tnil" + | Tnil -> fprintf ppf "Tnil" | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t | Tunivar -> fprintf ppf "Tunivar" @@ -180,7 +180,7 @@ let reset_names () = names := []; name_counter := 0 let new_name () = let name = if !name_counter < 26 - then String.make 1 (Char.chr(97 + !name_counter)) + then String.make 1 (Char.chr(97 + !name_counter)) else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^ string_of_int(!name_counter / 26) in incr name_counter; @@ -195,7 +195,7 @@ let name_of_type t = let check_name_of_type t = ignore(name_of_type t) let non_gen_mark sch ty = - if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else "" + if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else "" let print_name_of_type sch ppf t = fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t) @@ -456,7 +456,7 @@ and type_sch ppf ty = typexp true 0 ppf ty and type_scheme ppf ty = reset_and_mark_loops ty; typexp true 0 ppf ty (* Maxence *) -let type_scheme_max ?(b_reset_names=true) ppf ty = +let type_scheme_max ?(b_reset_names=true) ppf ty = if b_reset_names then reset_names () ; typexp true 0 ppf ty (* Fin Maxence *) @@ -515,7 +515,7 @@ let rec tree_of_type_decl id decl = in mark_loops ty; Some ty - in + in begin match decl.type_kind with | Type_abstract -> () | Type_variant ([], _) -> () @@ -564,7 +564,7 @@ let rec tree_of_type_decl id decl = begin match ty_manifest with | None -> (Otyp_abstract, Public) | Some ty -> - tree_of_typexp false ty, + tree_of_typexp false ty, (if has_constr_row ty then Private else Public) end | Type_variant(cstrs, priv) -> @@ -589,7 +589,7 @@ let type_declaration id ppf decl = (* Print an exception declaration *) let tree_of_exception_declaration id decl = - reset_and_mark_loops_list decl; + reset_and_mark_loops_list decl; let tyl = tree_of_typlist false decl in Osig_exception (Ident.name id, tyl) @@ -820,7 +820,7 @@ and tree_of_modtype_declaration id decl = in Osig_modtype (Ident.name id, mty) -let tree_of_module id mty rs = +let tree_of_module id mty rs = Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) @@ -839,7 +839,7 @@ let signature ppf sg = let type_expansion t ppf t' = if t == t' then type_expr ppf t else - let t' = if proxy t = proxy t' then unalias t' else t' in + let t' = if proxy t == proxy t' then unalias t' else t' in fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t' let rec trace fst txt ppf = function diff --git a/typing/printtyp.mli b/typing/printtyp.mli index d645d15c0..5e3402ff8 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -29,6 +29,7 @@ val reset_and_mark_loops: type_expr -> unit val reset_and_mark_loops_list: type_expr list -> unit val type_expr: formatter -> type_expr -> unit val tree_of_type_scheme: type_expr -> out_type +val type_sch : formatter -> type_expr -> unit val type_scheme: formatter -> type_expr -> unit (* Maxence *) val reset_names: unit -> unit diff --git a/typing/stypes.ml b/typing/stypes.ml index ab0477b4b..d762b576c 100644 --- a/typing/stypes.ml +++ b/typing/stypes.ml @@ -107,7 +107,7 @@ let print_info pp ti = fprintf pp "@.type(@. "; printtyp_reset_maybe loc; Printtyp.mark_loops typ; - Printtyp.type_expr pp typ; + Printtyp.type_sch pp typ; fprintf pp "@.)@."; ;; diff --git a/typing/typeclass.ml b/typing/typeclass.ml index d6439cafa..74aec1e61 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -57,7 +57,7 @@ exception Error of Location.t * error (**********************) (* Useful constants *) (**********************) - + (* Self type have a dummy private method, thus preventing it to become @@ -75,7 +75,7 @@ let unbound_class = Path.Pident (Ident.create "") (************************************) (* Some operations on class types *) (************************************) - + (* Fully expand the head of a class type *) let rec scrape_class_type = @@ -190,7 +190,7 @@ let rc node = (***********************************) (* Primitives for typing classes *) (***********************************) - + (* Enter a value in the method environment only *) let enter_met_env lab kind ty val_env met_env par_env = @@ -294,7 +294,7 @@ let make_method cl_num expr = (*******************************) -let add_val env loc lab (mut, virt, ty) val_sig = +let add_val env loc lab (mut, virt, ty) val_sig = let virt = try let (mut', virt', ty') = Vars.find lab val_sig in @@ -339,7 +339,7 @@ let rec class_type_field env self_type meths (val_sig, concr_meths, inher) = and class_signature env sty sign = let meths = ref Meths.empty in let self_type = transl_simple_type env false sty in - + (* Check that the binder is a correct type, and introduce a dummy method preventing self type from being closed. *) let dummy_obj = Ctype.newvar () in @@ -350,14 +350,14 @@ and class_signature env sty sign = with Ctype.Unify _ -> raise(Error(sty.ptyp_loc, Pattern_type_clash self_type)) end; - + (* Class type fields *) let (val_sig, concr_meths, inher) = List.fold_left (class_type_field env self_type meths) (Vars.empty, Concr.empty, []) sign in - + {cty_self = self_type; cty_vars = val_sig; cty_concr = concr_meths; @@ -389,7 +389,7 @@ and class_type env scty = | Pcty_signature (sty, sign) -> Tcty_signature (class_signature env sty sign) - + | Pcty_fun (l, sty, scty) -> let ty = transl_simple_type env false sty in let cty = class_type env scty in @@ -441,11 +441,11 @@ let rec class_field cl_num self_type meths vars cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals) in (* Inherited concrete methods *) - let inh_meths = + let inh_meths = Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem) cl_sig.cty_concr [] in - (* Super *) + (* Super *) let (val_env, met_env, par_env) = match super with None -> @@ -731,7 +731,7 @@ and class_expr cl_num val_env met_env scl = try Ctype.unify val_env ty' ty with Ctype.Unify trace -> raise(Error(loc, Parameter_mismatch trace))) tyl params; - let cl = + let cl = rc {cl_desc = Tclass_ident path; cl_loc = scl.pcl_loc; cl_type = clty'; @@ -790,9 +790,8 @@ and class_expr cl_num val_env met_env scl = pexp_loc = Location.none})) pv in - let rec all_labeled = function - Tcty_fun ("", _, _) -> false - | Tcty_fun (l, _, ty_fun) -> l.[0] <> '?' && all_labeled ty_fun + let rec not_function = function + Tcty_fun _ -> false | _ -> true in let partial = @@ -805,7 +804,7 @@ and class_expr cl_num val_env met_env scl = Ctype.raise_nongen_level (); let cl = class_expr cl_num val_env met_env scl' in Ctype.end_def (); - if Btype.is_optional l && all_labeled cl.cl_type then + if Btype.is_optional l && not_function cl.cl_type then Location.prerr_warning pat.pat_loc Warnings.Unerasable_optional_argument; rc {cl_desc = Tclass_fun (pat, pv, cl, partial); @@ -1012,7 +1011,7 @@ let rec initial_env define_class approx let arity = List.length (fst cl.pci_params) in let (obj_params, obj_ty, env) = temp_abbrev env obj_id arity in let (cl_params, cl_ty, env) = temp_abbrev env cl_id arity in - + (* Temporary type for the class constructor *) let constr_type = approx cl.pci_expr in if !Clflags.principal then Ctype.generalize_spine constr_type; @@ -1059,7 +1058,7 @@ let class_infos define_class kind reset_type_variables (); Ctype.begin_class_def (); - + (* Introduce class parameters *) let params = try @@ -1071,7 +1070,7 @@ let class_infos define_class kind (* Allow self coercions (only for class declarations) *) let coercion_locs = ref [] in - + (* Type the class expression *) let (expr, typ) = try @@ -1083,9 +1082,9 @@ let class_infos define_class kind with exn -> Typecore.self_coercion := []; raise exn in - + Ctype.end_def (); - + let sty = Ctype.self_type typ in (* Generalize the row variable *) @@ -1115,7 +1114,7 @@ let class_infos define_class kind Abbrev_type_clash (constr, ty, Ctype.expand_head env constr))) end end; - + (* Check the other temporary abbreviation (#-type) *) begin let (cl_params', cl_type) = Ctype.instance_class params typ in @@ -1190,7 +1189,7 @@ let class_infos define_class kind in List.map (function (lab, _, _) -> lab) fields in - + (* Final definitions *) let (params', typ') = Ctype.instance_class params typ in let cltydef = @@ -1421,7 +1420,7 @@ let approx_class sdecl = let self' = { ptyp_desc = Ptyp_any; ptyp_loc = Location.none } in let clty' = - { pcty_desc = Pcty_signature(self', []); + { pcty_desc = Pcty_signature(self', []); pcty_loc = sdecl.pci_expr.pcty_loc } in { sdecl with pci_expr = clty' } diff --git a/typing/typecore.ml b/typing/typecore.ml index 59801ca48..6fe7882e3 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -782,8 +782,9 @@ let rec approx_type env sty = newty (Ttuple (List.map (approx_type env) args)) | Ptyp_constr (lid, ctl) -> begin try + let (path, decl) = Env.lookup_type lid env in + if List.length ctl <> decl.type_arity then raise Not_found; let tyl = List.map (approx_type env) ctl in - let (path, _) = Env.lookup_type lid env in newconstr path tyl with Not_found -> newvar () end @@ -1628,7 +1629,7 @@ and type_application env funct sargs = else begin may_warn sarg0.pexp_loc (Warnings.Not_principal "using an optional argument here"); - Some (fun () -> option_some (type_argument env sarg0 + Some (fun () -> option_some (type_argument env sarg0 (extract_option_type env ty))) end with Not_found -> @@ -1796,11 +1797,11 @@ and type_expect ?in_function env sexp ty_expected = let cases, partial = type_cases ~in_function:(loc,ty_fun) env ty_arg ty_res (Some sexp.pexp_loc) caselist in - let all_labeled ty = + let not_function ty = let ls, tvar = list_labels env ty in - not (tvar || List.exists (fun l -> l = "" || l.[0] = '?') ls) + ls = [] && not tvar in - if is_optional l && all_labeled ty_res then + if is_optional l && not_function ty_res then Location.prerr_warning (fst (List.hd cases)).pat_loc Warnings.Unerasable_optional_argument; re { diff --git a/utils/warnings.ml b/utils/warnings.ml index a55d3171b..abca47859 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -147,7 +147,8 @@ let message = function | Not_principal s -> s^" is not principal." | Without_principality s -> s^" without principality." | Unused_argument -> "this argument will not be used by the function." - | Nonreturning_statement -> "this statement never returns." + | Nonreturning_statement -> + "this statement never returns (or has an unsound type.)" | Camlp4 s -> s | All_clauses_guarded -> "bad style, all clauses in this pattern-matching are guarded." diff --git a/yacc/.cvsignore b/yacc/.cvsignore index 535d61a9d..d7fa25cf9 100644 --- a/yacc/.cvsignore +++ b/yacc/.cvsignore @@ -2,3 +2,4 @@ ocamlyacc *.c.x ocamlyacc.xcoff version.h +.gdb_history diff --git a/yacc/main.c b/yacc/main.c index 41e1cb7bc..49dd7b47d 100644 --- a/yacc/main.c +++ b/yacc/main.c @@ -157,6 +157,7 @@ void getargs(int argc, char **argv) { case '\0': input_file = stdin; + file_prefix = "stdin"; if (i + 1 < argc) usage(); return; |