diff options
Diffstat (limited to 'ocaml-binary-annot/tools')
37 files changed, 5392 insertions, 0 deletions
diff --git a/ocaml-binary-annot/tools/.cvsignore b/ocaml-binary-annot/tools/.cvsignore new file mode 100644 index 0000000000..cf3c69515d --- /dev/null +++ b/ocaml-binary-annot/tools/.cvsignore @@ -0,0 +1,25 @@ +ocamldep +ocamldep.opt +ocamldep.bak +ocamlprof +opnames.ml +dumpobj +dumpapprox +objinfo +cvt_emit +cvt_emit.bak +cvt_emit.ml +ocamlcp +ocamlmktop +primreq +ocamldumpobj +keywords +lexer299.ml +ocaml299to3 +ocamlmklib +ocamlmklib.ml +lexer301.ml +scrapelabels +addlabels +myocamlbuild_config.ml +objinfo_helper diff --git a/ocaml-binary-annot/tools/.depend b/ocaml-binary-annot/tools/.depend new file mode 100644 index 0000000000..36c177ed43 --- /dev/null +++ b/ocaml-binary-annot/tools/.depend @@ -0,0 +1,62 @@ +depend.cmi: ../parsing/parsetree.cmi +profiling.cmi: +addlabels.cmo: ../parsing/parsetree.cmi ../parsing/parse.cmi \ + ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi +addlabels.cmx: ../parsing/parsetree.cmi ../parsing/parse.cmx \ + ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi +cvt_emit.cmo: +cvt_emit.cmx: +depend.cmo: ../parsing/parsetree.cmi ../parsing/longident.cmi \ + ../parsing/location.cmi depend.cmi +depend.cmx: ../parsing/parsetree.cmi ../parsing/longident.cmx \ + ../parsing/location.cmx depend.cmi +dumpobj.cmo: ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \ + ../parsing/location.cmi ../bytecomp/lambda.cmi ../bytecomp/instruct.cmi \ + ../typing/ident.cmi ../bytecomp/emitcode.cmi ../utils/config.cmi \ + ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmi \ + ../parsing/asttypes.cmi +dumpobj.cmx: ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \ + ../parsing/location.cmx ../bytecomp/lambda.cmx ../bytecomp/instruct.cmx \ + ../typing/ident.cmx ../bytecomp/emitcode.cmx ../utils/config.cmx \ + ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmx \ + ../parsing/asttypes.cmi +myocamlbuild_config.cmo: +myocamlbuild_config.cmx: +objinfo.cmo: ../utils/misc.cmi ../utils/config.cmi ../asmcomp/cmx_format.cmi \ + ../bytecomp/cmo_format.cmi ../asmcomp/clambda.cmi \ + ../bytecomp/bytesections.cmi +objinfo.cmx: ../utils/misc.cmx ../utils/config.cmx ../asmcomp/cmx_format.cmi \ + ../bytecomp/cmo_format.cmi ../asmcomp/clambda.cmx \ + ../bytecomp/bytesections.cmx +ocaml299to3.cmo: +ocaml299to3.cmx: +ocamlcp.cmo: ../driver/main_args.cmi +ocamlcp.cmx: ../driver/main_args.cmx +ocamldep.cmo: ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \ + ../parsing/parse.cmi ../utils/misc.cmi ../parsing/longident.cmi \ + ../parsing/location.cmi ../parsing/lexer.cmi depend.cmi \ + ../utils/config.cmi ../utils/clflags.cmi +ocamldep.cmx: ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \ + ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \ + ../parsing/location.cmx ../parsing/lexer.cmx depend.cmx \ + ../utils/config.cmx ../utils/clflags.cmx +ocamlmklib.cmo: myocamlbuild_config.cmo +ocamlmklib.cmx: myocamlbuild_config.cmx +ocamlmktop.cmo: ../utils/ccomp.cmi +ocamlmktop.cmx: ../utils/ccomp.cmx +ocamlprof.cmo: ../utils/warnings.cmi ../parsing/syntaxerr.cmi \ + ../parsing/parsetree.cmi ../parsing/parse.cmi ../utils/misc.cmi \ + ../parsing/location.cmi ../parsing/lexer.cmi ../utils/config.cmi \ + ../utils/clflags.cmi +ocamlprof.cmx: ../utils/warnings.cmx ../parsing/syntaxerr.cmx \ + ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \ + ../parsing/location.cmx ../parsing/lexer.cmx ../utils/config.cmx \ + ../utils/clflags.cmx +opnames.cmo: +opnames.cmx: +primreq.cmo: ../utils/config.cmi ../bytecomp/cmo_format.cmi +primreq.cmx: ../utils/config.cmx ../bytecomp/cmo_format.cmi +profiling.cmo: profiling.cmi +profiling.cmx: profiling.cmi +scrapelabels.cmo: +scrapelabels.cmx: diff --git a/ocaml-binary-annot/tools/Characters b/ocaml-binary-annot/tools/Characters new file mode 100644 index 0000000000..fb8e6868ab --- /dev/null +++ b/ocaml-binary-annot/tools/Characters @@ -0,0 +1,16 @@ +# Characters + +# $Id$ + +# Usage: +# Characters n1 to n2 +# +# Select the characters in the given interval, counting from the first +# character of the current line, in the active window. +# +# Typical use is an error message of the form: +# File fff; Line lll; Characters yyy to zzz + +exit 1 if {#} 3 + +Find Ƥ!{1}:¤!`evaluate {3} - {1}` "{active}" diff --git a/ocaml-binary-annot/tools/DoMake b/ocaml-binary-annot/tools/DoMake new file mode 100644 index 0000000000..2fce340103 --- /dev/null +++ b/ocaml-binary-annot/tools/DoMake @@ -0,0 +1,61 @@ +# DoMake + +# $Id$ + +# Execute the output of "Make -f Makefile.Mac -f Makefile.Mac.depend" +# or "Make -f Makefile -f Makefile.depend" if "Makefile.Mac" does not exist +# or "Make -f <file>" if the "-f" option is given. + +# usage: domake [-quiet] [-f <file>]É <make arguments> + +set echo 0 + +set domake_quiet 0 +set domake_files "" + +loop + if "{1}" == "-quiet" + set domake_quiet 1 + shift + else if "{1}" == "-f" + set domake_files "{domake_files} -f `quote "{2}"`" + shift 2 + else + break + end +end + +set tempfile "{TempFolder}temp-domake-`Date -n`" +if "`exists "{tempfile}"`" + set i 0 + loop + break if ! "`exists "{tempfile}.{i}"`" + evaluate i += 1 + end + set tempfile "{tempfile}.{i}" +end + +if "{domake_files}" == "" + if "`exists Makefile.Mac`" != "" + set domake_main "Makefile.Mac" + else + set domake_main "Makefile" + end + + if "`exists "{domake_main}".depend`" != "" + set domake_files "-f {domake_main} -f {domake_main}.depend" + else + set domake_files "-f {domake_main}" + end +end + +if {domake_quiet} + echo >"{tempfile}" +else + echo 'set echo 1' >"{tempfile}" +end +make {domake_files} {"Parameters"} >>"{tempfile}" + +"{tempfile}" + +Delete -i "{tempfile}" diff --git a/ocaml-binary-annot/tools/MakeDepend b/ocaml-binary-annot/tools/MakeDepend new file mode 100644 index 0000000000..5693b27e8d --- /dev/null +++ b/ocaml-binary-annot/tools/MakeDepend @@ -0,0 +1,17 @@ +# MakeDepend + +# $Id$ + + +# Usage: MakeDepend fileÉ + +# Generate the Make dependency rules for a set of C files. +# The rules are printed on standard output. + +set echo 0 +set exit 0 + +for i in {"parameters"} + mrc -c -w off -make dev:stdout "{i}" ³ dev:null ¶ + | streamedit -e '/¶"(Å)¨0.c.o¶"/ replace // "¶""¨0".c.o¶" ¶""¨0".c.x¶""' +end diff --git a/ocaml-binary-annot/tools/Makefile b/ocaml-binary-annot/tools/Makefile new file mode 100644 index 0000000000..bad14c7e50 --- /dev/null +++ b/ocaml-binary-annot/tools/Makefile @@ -0,0 +1,21 @@ +######################################################################### +# # +# Objective Caml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id$ + +include Makefile.shared + +# To make custom toplevels + +ocamlmktop: ocamlmktop.tpl ../config/Makefile + sed -e 's|%%BINDIR%%|$(BINDIR)|' ocamlmktop.tpl > ocamlmktop + chmod +x ocamlmktop diff --git a/ocaml-binary-annot/tools/Makefile.nt b/ocaml-binary-annot/tools/Makefile.nt new file mode 100644 index 0000000000..b90c0c4f66 --- /dev/null +++ b/ocaml-binary-annot/tools/Makefile.nt @@ -0,0 +1,23 @@ +######################################################################### +# # +# Objective Caml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id$ + +include Makefile.shared + +# To make custom toplevels + +OCAMLMKTOP=ocamlmktop.cmo +OCAMLMKTOP_IMPORTS=misc.cmo config.cmo clflags.cmo ccomp.cmo + +ocamlmktop: $(OCAMLMKTOP) + $(CAMLC) $(LINKFLAGS) -o ocamlmktop $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP) diff --git a/ocaml-binary-annot/tools/Makefile.shared b/ocaml-binary-annot/tools/Makefile.shared new file mode 100644 index 0000000000..12bf76f0d0 --- /dev/null +++ b/ocaml-binary-annot/tools/Makefile.shared @@ -0,0 +1,280 @@ +######################################################################### +# # +# Objective Caml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id$ + +include ../config/Makefile + +CAMLRUN=../boot/ocamlrun +CAMLC=$(CAMLRUN) ../boot/ocamlc -strict-sequence -nostdlib -I ../boot +CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib +CAMLLEX=$(CAMLRUN) ../boot/ocamllex +INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ + -I ../driver +COMPFLAGS= -warn-error A $(INCLUDES) +LINKFLAGS=$(INCLUDES) + +all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib dumpobj objinfo +# scrapelabels addlabels + +.PHONY: all + +opt.opt: ocamldep.opt +.PHONY: opt.opt + +# The dependency generator + +CAMLDEP_OBJ=depend.cmo ocamldep.cmo +CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ + linenum.cmo warnings.cmo location.cmo longident.cmo \ + syntaxerr.cmo parser.cmo lexer.cmo parse.cmo + +ocamldep: depend.cmi $(CAMLDEP_OBJ) + $(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ) + +ocamldep.opt: depend.cmi $(CAMLDEP_OBJ:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) -o ocamldep.opt $(CAMLDEP_IMPORTS:.cmo=.cmx) \ + $(CAMLDEP_OBJ:.cmo=.cmx) + +# ocamldep is precious: sometimes we are stuck in the middle of a +# bootstrap and we need to remake the dependencies +clean:: + if test -f ocamldep; then mv -f ocamldep ocamldep.bak; else :; fi + rm -f ocamldep.opt + +install:: + cp ocamldep $(BINDIR)/ocamldep$(EXE) + if test -f ocamldep.opt; \ + then cp ocamldep.opt $(BINDIR)/ocamldep.opt$(EXE); else :; fi + +# The profiler + +CSLPROF=ocamlprof.cmo +CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ + linenum.cmo warnings.cmo location.cmo longident.cmo \ + syntaxerr.cmo parser.cmo lexer.cmo parse.cmo + +ocamlprof: $(CSLPROF) profiling.cmo + $(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF) + +ocamlcp: ocamlcp.cmo + $(CAMLC) $(LINKFLAGS) -o ocamlcp warnings.cmo main_args.cmo ocamlcp.cmo + +install:: + cp ocamlprof $(BINDIR)/ocamlprof$(EXE) + cp ocamlcp $(BINDIR)/ocamlcp$(EXE) + cp profiling.cmi profiling.cmo $(LIBDIR) + +clean:: + rm -f ocamlprof ocamlcp + +install:: + cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE) + +clean:: + rm -f ocamlmktop + +# To help building mixed-mode libraries (Caml + C) + +ocamlmklib: myocamlbuild_config.cmo ocamlmklib.cmo + $(CAMLC) $(LINKFLAGS) -o ocamlmklib myocamlbuild_config.cmo \ + ocamlmklib.cmo + +ocamlmklib.cmo: myocamlbuild_config.cmi + +myocamlbuild_config.cmi: myocamlbuild_config.cmo + +myocamlbuild_config.ml: ../config/Makefile ../build/mkmyocamlbuild_config.sh + ../build/mkmyocamlbuild_config.sh + cp ../myocamlbuild_config.ml . + +install:: + cp ocamlmklib $(BINDIR)/ocamlmklib$(EXE) + +clean:: + rm -f ocamlmklib + +ocamlmklib.ml: ocamlmklib.mlp ../config/Makefile + echo '(* THIS FILE IS GENERATED FROM ocamlmklib.mlp *)' >ocamlmklib.ml + sed -e "s|%%BINDIR%%|$(BINDIR)|" \ + -e "s|%%SUPPORTS_SHARED_LIBRARIES%%|$(SUPPORTS_SHARED_LIBRARIES)|" \ + -e "s|%%MKSHAREDLIB%%|$(MKSHAREDLIB)|" \ + -e "s|%%BYTECCRPATH%%|$(BYTECCRPATH)|" \ + -e "s|%%NATIVECCRPATH%%|$(NATIVECCRPATH)|" \ + -e "s|%%MKSHAREDLIBRPATH%%|$(MKSHAREDLIBRPATH)|" \ + -e "s|%%RANLIB%%|$(RANLIB)|" \ + ocamlmklib.mlp >> ocamlmklib.ml + +beforedepend:: ocamlmklib.ml + +clean:: + rm -f ocamlmklib.ml + +# To make custom toplevels (see Makefile/Makefile.nt) + +install:: + cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE) + +clean:: + rm -f ocamlmktop + + +# Converter olabl/ocaml 2.99 to ocaml 3 + +OCAML299TO3= lexer299.cmo ocaml299to3.cmo +LIBRARY3= misc.cmo warnings.cmo linenum.cmo location.cmo + +ocaml299to3: $(OCAML299TO3) + $(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3) + +lexer299.ml: lexer299.mll + $(CAMLLEX) lexer299.mll + +#install:: +# cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE) + +clean:: + rm -f ocaml299to3 lexer299.ml + +# Label remover for interface files (upgrade 3.02 to 3.03) + +SCRAPELABELS= lexer301.cmo scrapelabels.cmo + +scrapelabels: $(SCRAPELABELS) + $(CAMLC) $(LINKFLAGS) -o scrapelabels $(LIBRARY3) $(SCRAPELABELS) + +lexer301.ml: lexer301.mll + $(CAMLLEX) lexer301.mll + +#install:: +# cp scrapelabels $(LIBDIR) + +clean:: + rm -f scrapelabels lexer301.ml + +# Insert labels following an interface file (upgrade 3.02 to 3.03) + +ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ + linenum.cmo warnings.cmo location.cmo longident.cmo \ + syntaxerr.cmo parser.cmo lexer.cmo parse.cmo + +addlabels: addlabels.cmo + $(CAMLC) $(LINKFLAGS) -w sl -o addlabels \ + $(ADDLABELS_IMPORTS) addlabels.cmo + +#install:: +# cp addlabels $(LIBDIR) + +clean:: + rm -f addlabels + +# The preprocessor for asm generators + +CVT_EMIT=cvt_emit.cmo + +cvt_emit: $(CVT_EMIT) + $(CAMLC) $(LINKFLAGS) -o cvt_emit $(CVT_EMIT) + +# cvt_emit is precious: sometimes we are stuck in the middle of a +# bootstrap and we need to remake the dependencies +clean:: + if test -f cvt_emit; then mv -f cvt_emit cvt_emit.bak; else :; fi + +cvt_emit.ml: cvt_emit.mll + $(CAMLLEX) cvt_emit.mll + +clean:: + rm -f cvt_emit.ml + +beforedepend:: cvt_emit.ml + +# The bytecode disassembler + +DUMPOBJ=opnames.cmo dumpobj.cmo + +dumpobj: $(DUMPOBJ) + $(CAMLC) $(LINKFLAGS) -o dumpobj \ + misc.cmo tbl.cmo config.cmo ident.cmo \ + opcodes.cmo bytesections.cmo $(DUMPOBJ) + +clean:: + rm -f dumpobj + +opnames.ml: ../byterun/instruct.h + unset LC_ALL || : ; \ + unset LC_CTYPE || : ; \ + unset LC_COLLATE LANG || : ; \ + sed -e '/\/\*/d' \ + -e '/^#/d' \ + -e 's/enum \(.*\) {/let names_of_\1 = [|/' \ + -e 's/};$$/ |]/' \ + -e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' \ + -e 's/,/;/g' \ + ../byterun/instruct.h > opnames.ml + +clean:: + rm -f opnames.ml + +beforedepend:: opnames.ml + +# Display info on compiled files + +objinfo_helper$(EXE): objinfo_helper.c ../config/s.h + $(BYTECC) -o objinfo_helper$(EXE) $(BYTECCCOMPOPTS) \ + objinfo_helper.c $(LIBBFD_LINK) + +OBJINFO=../utils/misc.cmo ../utils/config.cmo ../bytecomp/bytesections.cmo \ + objinfo.cmo + +objinfo: objinfo_helper$(EXE) $(OBJINFO) + $(CAMLC) -o objinfo $(OBJINFO) + +install:: + cp objinfo $(BINDIR)/ocamlobjinfo$(EXE) + cp objinfo_helper$(EXE) $(LIBDIR)/objinfo_helper$(EXE) + +clean:: + rm -f objinfo objinfo_helper$(EXE) + +# Scan object files for required primitives + +PRIMREQ=primreq.cmo + +primreq: $(PRIMREQ) + $(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ) + +clean:: + rm -f primreq + +# Common stuff + +.SUFFIXES: +.SUFFIXES: .ml .cmo .mli .cmi .cmx + +.ml.cmo: + $(CAMLC) -c $(COMPFLAGS) $< + +.mli.cmi: + $(CAMLC) -c $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) $(COMPFLAGS) -c $< + +clean:: + rm -f *.cmo *.cmi *.cma *.dll *.so *.lib *.a + +depend: beforedepend + $(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend + +.PHONY: clean install beforedepend depend + +include .depend diff --git a/ocaml-binary-annot/tools/OCamlc-custom b/ocaml-binary-annot/tools/OCamlc-custom new file mode 100644 index 0000000000..c389974e2b --- /dev/null +++ b/ocaml-binary-annot/tools/OCamlc-custom @@ -0,0 +1,10 @@ +# OCamlc with option -custom +# Macintosh version + +set echo 0 +set -e ocamlcommands "{tempfolder}"OCaml.temp."`date -n`" +echo >"{ocamlcommands}" +ocamlc -custom {"parameters"} +execute "{ocamlcommands}" + +delete -y "{ocamlcommands}" diff --git a/ocaml-binary-annot/tools/Time b/ocaml-binary-annot/tools/Time new file mode 100644 index 0000000000..0a8267465b --- /dev/null +++ b/ocaml-binary-annot/tools/Time @@ -0,0 +1,10 @@ +# Time # Measure execution time +# Usage: Time command argumentsÉ + +set echo 0 + +set startdate `date -n` +{parameters} +set enddate `date -n` + +echo "# Time: `evaluate {enddate} - {startdate}` s" > dev:stderr diff --git a/ocaml-binary-annot/tools/addlabels.ml b/ocaml-binary-annot/tools/addlabels.ml new file mode 100644 index 0000000000..6a297b9e86 --- /dev/null +++ b/ocaml-binary-annot/tools/addlabels.ml @@ -0,0 +1,453 @@ +(* $Id$ *) + +open StdLabels +open Asttypes +open Parsetree + +let norec = ref false + +let input_file file = + let ic = try open_in file with _ -> failwith ("input_file : " ^ file) in + let b = Buffer.create 1024 in + let buf = String.create 1024 and len = ref 0 in + while len := input ic buf 0 1024; !len > 0 do + Buffer.add_substring b buf 0 !len + done; + close_in ic; + Buffer.contents b + +module SMap = struct + include Map.Make(struct type t = string let compare = compare end) + let rec removes l m = + match l with [] -> m + | k::l -> + let m = try remove k m with Not_found -> m in + removes l m +end + +let rec labels_of_sty sty = + match sty.ptyp_desc with + Ptyp_arrow (lab, _, rem) -> lab :: labels_of_sty rem + | Ptyp_alias (rem, _) -> labels_of_sty rem + | _ -> [] + +let rec labels_of_cty cty = + match cty.pcty_desc with + Pcty_fun (lab, _, rem) -> + let (labs, meths) = labels_of_cty rem in + (lab :: labs, meths) + | Pcty_signature (_, fields) -> + ([], + List.fold_left fields ~init:[] ~f: + begin fun meths -> function + Pctf_meth (s, _, sty, _) -> (s, labels_of_sty sty)::meths + | _ -> meths + end) + | _ -> + ([],[]) + +let rec pattern_vars pat = + match pat.ppat_desc with + Ppat_var s -> [s] + | Ppat_alias (pat, s) -> + s :: pattern_vars pat + | Ppat_tuple l + | Ppat_array l -> + List.concat (List.map pattern_vars l) + | Ppat_construct (_, Some pat, _) + | Ppat_variant (_, Some pat) + | Ppat_constraint (pat, _) -> + pattern_vars pat + | Ppat_record(l, _) -> + List.concat (List.map l ~f:(fun (_,p) -> pattern_vars p)) + | Ppat_or (pat1, pat2) -> + pattern_vars pat1 @ pattern_vars pat2 + | Ppat_lazy pat -> pattern_vars pat + | Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _ + | Ppat_type _ | Ppat_unpack _ -> + [] + +let pattern_name pat = + match pat.ppat_desc with + Ppat_var s -> Some s + | Ppat_constraint ({ppat_desc = Ppat_var s}, _) -> Some s + | _ -> None + +let insertions = ref [] +let add_insertion pos s = insertions := (pos,s) :: !insertions +let sort_insertions () = + List.sort !insertions ~cmp:(fun (pos1,_) (pos2,_) -> pos1 - pos2) + +let is_space = function ' '|'\t'|'\n'|'\r' -> true | _ -> false +let is_alphanum = function 'A'..'Z'|'a'..'z'|'_'|'\192'..'\214'|'\216'..'\246' + | '\248'..'\255'|'\''|'0'..'9' -> true + | _ -> false + +(* Remove "(" or "begin" before a pattern *) +let rec insertion_point pos ~text = + let pos' = ref (pos-1) in + while is_space text.[!pos'] do decr pos' done; + if text.[!pos'] = '(' then insertion_point !pos' ~text else + if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin" + && not (is_alphanum text.[!pos'-5]) then insertion_point (!pos'-4) ~text + else pos + +(* Search "=" or "->" before "function" *) +let rec insertion_point2 pos ~text = + let pos' = ref (pos-1) in + while is_space text.[!pos'] do decr pos' done; + if text.[!pos'] = '(' then insertion_point2 !pos' ~text else + if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin" + && not (is_alphanum text.[!pos'-5]) then insertion_point2 (!pos'-4) ~text + else if text.[!pos'] = '=' then Some !pos' else + if !pos' >= 1 && text.[!pos'-1] = '-' && text.[!pos'] = '>' + then Some (!pos' - 1) + else None + +let rec insert_labels ~labels ~text expr = + match labels, expr.pexp_desc with + l::labels, Pexp_function(l', _, [pat, rem]) -> + if l <> "" && l.[0] <> '?' && l' = "" then begin + let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in + let pos = insertion_point start_c ~text in + match pattern_name pat with + | Some name when l = name -> add_insertion pos "~" + | _ -> add_insertion pos ("~" ^ l ^ ":") + end; + insert_labels ~labels ~text rem + | l::labels, Pexp_function(l', _, lst) -> + let pos = expr.pexp_loc.Location.loc_start.Lexing.pos_cnum in + if l <> "" && l.[0] <> '?' && l' = "" + && String.sub text ~pos ~len:8 = "function" then begin + String.blit ~src:"match th" ~src_pos:0 ~dst:text + ~dst_pos:pos ~len:8; + add_insertion (pos+6) (l ^ " wi"); + match insertion_point2 pos ~text with + Some pos' -> + add_insertion pos' ("~" ^ l ^ " ") + | None -> + add_insertion pos ("fun ~" ^ l ^ " -> ") + end; + List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) + | _, Pexp_match( _, lst) -> + List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) + | _, Pexp_try(expr, lst) -> + insert_labels ~labels ~text expr; + List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) + | _, ( Pexp_let(_,_,e) | Pexp_sequence(_,e) | Pexp_when(_,e) + | Pexp_constraint(e,_,_) | Pexp_letmodule(_,_,e) + | Pexp_ifthenelse(_,e,None) ) -> + insert_labels ~labels ~text e + | _, Pexp_ifthenelse (_, e1, Some e2) -> + insert_labels ~labels ~text e1; + insert_labels ~labels ~text e2 + | _ -> + () + +let rec insert_labels_class ~labels ~text expr = + match labels, expr.pcl_desc with + l::labels, Pcl_fun(l', _, pat, rem) -> + if l <> "" && l.[0] <> '?' && l' = "" then begin + let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in + let pos = insertion_point start_c ~text in + match pattern_name pat with + | Some name when l = name -> add_insertion pos "~" + | _ -> add_insertion pos ("~" ^ l ^ ":") + end; + insert_labels_class ~labels ~text rem + | labels, (Pcl_constraint (expr, _) | Pcl_let (_, _, expr)) -> + insert_labels_class ~labels ~text expr + | _ -> + () + +let rec insert_labels_type ~labels ~text ty = + match labels, ty.ptyp_desc with + l::labels, Ptyp_arrow(l', _, rem) -> + if l <> "" && l.[0] <> '?' && l' = "" then begin + let start_c = ty.ptyp_loc.Location.loc_start.Lexing.pos_cnum in + let pos = insertion_point start_c ~text in + add_insertion pos (l ^ ":") + end; + insert_labels_type ~labels ~text rem + | _ -> + () + +let rec insert_labels_app ~labels ~text args = + match labels, args with + l::labels, (l',arg)::args -> + if l <> "" && l.[0] <> '?' && l' = "" then begin + let pos0 = arg.pexp_loc.Location.loc_start.Lexing.pos_cnum in + let pos = insertion_point pos0 ~text in + match arg.pexp_desc with + | Pexp_ident(Longident.Lident name) when l = name && pos = pos0 -> + add_insertion pos "~" + | _ -> add_insertion pos ("~" ^ l ^ ":") + end; + insert_labels_app ~labels ~text args + | _ -> + () + +let insert_labels_app ~labels ~text args = + let labels, opt_labels = + List.partition labels ~f:(fun l -> l = "" || l.[0] <> '?') in + let nopt_labels = + List.map opt_labels + ~f:(fun l -> String.sub l ~pos:1 ~len:(String.length l - 1)) in + (* avoid ambiguous labels *) + if List.exists labels ~f:(List.mem ~set:nopt_labels) then () else + let aopt_labels = opt_labels @ nopt_labels in + let args, lab_args = List.partition args ~f:(fun (l,_) -> l = "") in + (* only optional arguments are labeled *) + if List.for_all lab_args ~f:(fun (l,_) -> List.mem l ~set:aopt_labels) + then insert_labels_app ~labels ~text args + +let rec add_labels_expr ~text ~values ~classes expr = + let add_labels_rec ?(values=values) expr = + add_labels_expr ~text ~values ~classes expr in + match expr.pexp_desc with + Pexp_apply ({pexp_desc=Pexp_ident(Longident.Lident s)}, args) -> + begin try + let labels = SMap.find s values in + insert_labels_app ~labels ~text args + with Not_found -> () + end; + List.iter args ~f:(fun (_,e) -> add_labels_rec e) + | Pexp_apply ({pexp_desc=Pexp_send + ({pexp_desc=Pexp_ident(Longident.Lident s)},meth)}, args) -> + begin try + if SMap.find s values = ["<object>"] then + let labels = SMap.find (s ^ "#" ^ meth) values in + insert_labels_app ~labels ~text args + with Not_found -> () + end + | Pexp_apply ({pexp_desc=Pexp_new (Longident.Lident s)}, args) -> + begin try + let labels = SMap.find s classes in + insert_labels_app ~labels ~text args + with Not_found -> () + end + | Pexp_let (recp, lst, expr) -> + let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in + let vals = SMap.removes vars values in + List.iter lst ~f: + begin fun (_,e) -> + add_labels_rec e ~values:(if recp = Recursive then vals else values) + end; + add_labels_rec expr ~values:vals + | Pexp_function (_, None, lst) -> + List.iter lst ~f: + (fun (p,e) -> + add_labels_rec e ~values:(SMap.removes (pattern_vars p) values)) + | Pexp_function (_, Some e, lst) + | Pexp_match (e, lst) + | Pexp_try (e, lst) -> + add_labels_rec e; + List.iter lst ~f: + (fun (p,e) -> + add_labels_rec e ~values:(SMap.removes (pattern_vars p) values)) + | Pexp_apply (e, args) -> + List.iter add_labels_rec (e :: List.map snd args) + | Pexp_tuple l | Pexp_array l -> + List.iter add_labels_rec l + | Pexp_construct (_, Some e, _) + | Pexp_variant (_, Some e) + | Pexp_field (e, _) + | Pexp_constraint (e, _, _) + | Pexp_send (e, _) + | Pexp_setinstvar (_, e) + | Pexp_letmodule (_, _, e) + | Pexp_assert e + | Pexp_lazy e + | Pexp_poly (e, _) + | Pexp_newtype (_, e) + | Pexp_open (_, e) -> + add_labels_rec e + | Pexp_record (lst, opt) -> + List.iter lst ~f:(fun (_,e) -> add_labels_rec e); + begin match opt with Some e -> add_labels_rec e | None -> () end + | Pexp_setfield (e1, _, e2) + | Pexp_ifthenelse (e1, e2, None) + | Pexp_sequence (e1, e2) + | Pexp_while (e1, e2) + | Pexp_when (e1, e2) -> + add_labels_rec e1; add_labels_rec e2 + | Pexp_ifthenelse (e1, e2, Some e3) -> + add_labels_rec e1; add_labels_rec e2; add_labels_rec e3 + | Pexp_for (s, e1, e2, _, e3) -> + add_labels_rec e1; add_labels_rec e2; + add_labels_rec e3 ~values:(SMap.removes [s] values) + | Pexp_override lst -> + List.iter lst ~f:(fun (_,e) -> add_labels_rec e) + | Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _ + | Pexp_new _ | Pexp_assertfalse | Pexp_object _ | Pexp_pack _ -> + () + +let rec add_labels_class ~text ~classes ~values ~methods cl = + match cl.pcl_desc with + Pcl_constr _ -> () + | Pcl_structure (p, l) -> + let values = SMap.removes (pattern_vars p) values in + let values = + match pattern_name p with None -> values + | Some s -> + List.fold_left methods + ~init:(SMap.add s ["<object>"] values) + ~f:(fun m (k,l) -> SMap.add (s^"#"^k) l m) + in + ignore (List.fold_left l ~init:values ~f: + begin fun values -> function + | Pcf_val (s, _, _, e, _) -> + add_labels_expr ~text ~classes ~values e; + SMap.removes [s] values + | Pcf_meth (s, _, _, e, _) -> + begin try + let labels = List.assoc s methods in + insert_labels ~labels ~text e + with Not_found -> () + end; + add_labels_expr ~text ~classes ~values e; + values + | Pcf_init e -> + add_labels_expr ~text ~classes ~values e; + values + | Pcf_inher _ | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> values + | Pcf_let _ -> values (* not in the grammar *) + end) + | Pcl_fun (_, opt, pat, cl) -> + begin match opt with None -> () + | Some e -> add_labels_expr ~text ~classes ~values e + end; + let values = SMap.removes (pattern_vars pat) values in + add_labels_class ~text ~classes ~values ~methods cl + | Pcl_apply (cl, args) -> + List.iter args ~f:(fun (_,e) -> add_labels_expr ~text ~classes ~values e); + add_labels_class ~text ~classes ~values ~methods cl + | Pcl_let (recp, lst, cl) -> + let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in + let vals = SMap.removes vars values in + List.iter lst ~f: + begin fun (_,e) -> + add_labels_expr e ~text ~classes + ~values:(if recp = Recursive then vals else values) + end; + add_labels_class cl ~text ~classes ~values:vals ~methods + | Pcl_constraint (cl, _) -> + add_labels_class ~text ~classes ~values ~methods cl + +let add_labels ~intf ~impl ~file = + insertions := []; + let values, classes = + List.fold_left intf ~init:(SMap.empty, SMap.empty) ~f: + begin fun (values, classes as acc) item -> + match item.psig_desc with + Psig_value (name, {pval_type = sty}) -> + (SMap.add name (labels_of_sty sty) values, classes) + | Psig_class l -> + (values, + List.fold_left l ~init:classes ~f: + begin fun classes {pci_name=name; pci_expr=cty} -> + SMap.add name (labels_of_cty cty) classes + end) + | _ -> + acc + end + in + let text = input_file file in + ignore (List.fold_right impl ~init:(values, classes) ~f: + begin fun item (values, classes as acc) -> + match item.pstr_desc with + Pstr_value (recp, l) -> + let names = + List.concat (List.map l ~f:(fun (p,_) -> pattern_vars p)) in + List.iter l ~f: + begin fun (pat, expr) -> + begin match pattern_name pat with + | Some s -> + begin try + let labels = SMap.find s values in + insert_labels ~labels ~text expr; + if !norec then () else + let values = + SMap.fold + (fun s l m -> + if List.mem s names then SMap.add s l m else m) + values SMap.empty in + add_labels_expr expr ~text ~values ~classes:SMap.empty + with Not_found -> () + end + | None -> () + end; + end; + (SMap.removes names values, classes) + | Pstr_primitive (s, {pval_type=sty}) -> + begin try + let labels = SMap.find s values in + insert_labels_type ~labels ~text sty; + (SMap.removes [s] values, classes) + with Not_found -> acc + end + | Pstr_class l -> + let names = List.map l ~f:(fun pci -> pci.pci_name) in + List.iter l ~f: + begin fun {pci_name=name; pci_expr=expr} -> + try + let (labels, methods) = SMap.find name classes in + insert_labels_class ~labels ~text expr; + if !norec then () else + let classes = + SMap.fold + (fun s (l,_) m -> + if List.mem s names then SMap.add s l m else m) + classes SMap.empty in + add_labels_class expr ~text ~classes ~methods + ~values:SMap.empty + with Not_found -> () + end; + (values, SMap.removes names classes) + | _ -> + acc + end); + if !insertions <> [] then begin + let backup = file ^ ".bak" in + if Sys.file_exists backup then Sys.remove file + else Sys.rename file backup; + let oc = open_out file in + let last_pos = + List.fold_left (sort_insertions ()) ~init:0 ~f: + begin fun pos (pos', s) -> + output oc text pos (pos'-pos); + output_string oc s; + pos' + end in + if last_pos < String.length text then + output oc text last_pos (String.length text - last_pos); + close_out oc + end + else prerr_endline ("No labels to insert in " ^ file) + +let process_file file = + prerr_endline ("Processing " ^ file); + if Filename.check_suffix file ".ml" then + let intf = Filename.chop_suffix file ".ml" ^ ".mli" in + let ic = open_in intf in + let lexbuf = Lexing.from_channel ic in + Location.init lexbuf intf; + let intf = Parse.interface lexbuf in + close_in ic; + let ic = open_in file in + let lexbuf = Lexing.from_channel ic in + Location.init lexbuf file; + let impl = Parse.implementation lexbuf in + close_in ic; + add_labels ~intf ~impl ~file + else prerr_endline (file ^ " is not an implementation") + +let main () = + let files = ref [] in + Arg.parse ["-norec", Arg.Set norec, "do not labelize recursive calls"] + (fun f -> files := f :: !files) + "addlabels [-norec] <files>"; + let files = List.rev !files in + List.iter files ~f:process_file + +let () = main () diff --git a/ocaml-binary-annot/tools/checkstack.c b/ocaml-binary-annot/tools/checkstack.c new file mode 100644 index 0000000000..fc760945fc --- /dev/null +++ b/ocaml-binary-annot/tools/checkstack.c @@ -0,0 +1,43 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <stdio.h> +#include <stdlib.h> +#include <sys/types.h> +#include <sys/time.h> +#include <sys/resource.h> + +#define MINSTACKBYTES (384 * 1024 * sizeof (long)) + +int main(int argc, char ** argv) +{ + struct rlimit limit; + int rc; + + rc = getrlimit (RLIMIT_STACK, &limit); + if (rc != 0) exit (0); + if (limit.rlim_cur < MINSTACKBYTES){ + fprintf (stderr, + "\nThe current stack size limit is too low (%luk)\n" + "You must increase it with one of the following commands:\n" + "Under sh, bash, zsh: ulimit -s %lu\n" + "Under csh, tcsh: limit stacksize %lu\n\n", + (unsigned long) (limit.rlim_cur / 1024), + (unsigned long) (MINSTACKBYTES / 1024), + (unsigned long) (MINSTACKBYTES / 1024)); + exit (3); + } + exit (0); +} diff --git a/ocaml-binary-annot/tools/cleanup-header b/ocaml-binary-annot/tools/cleanup-header new file mode 100644 index 0000000000..6c320fb39c --- /dev/null +++ b/ocaml-binary-annot/tools/cleanup-header @@ -0,0 +1,13 @@ +#!/bin/sed -f +# Remove private parts from runtime include files, before installation +# in /usr/local/lib/ocaml/caml + +/\/\* <include \.\.\/config\/m\.h> \*\// { + r ../config/m.h + d +} +/\/\* <include \.\.\/config\/s\.h> \*\// { + r ../config/s.h + d +} +/\/\* <private> \*\//,/\/\* <\/private> \*\//d diff --git a/ocaml-binary-annot/tools/cvt_emit.mll b/ocaml-binary-annot/tools/cvt_emit.mll new file mode 100644 index 0000000000..3e28ae9722 --- /dev/null +++ b/ocaml-binary-annot/tools/cvt_emit.mll @@ -0,0 +1,84 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +{ +let first_item = ref false +let command_beginning = ref 0 + +let add_semicolon () = + if !first_item + then first_item := false + else print_string "; " + +let print_unescaped_string s = + let l = String.length s in + let i = ref 0 in + while !i < l do + if s.[!i] = '\\' + && !i+1 < l + && (let c = s.[!i+1] in c = '{' || c = '`') (* ` *) + then i := !i+1; + print_char s.[!i]; + i := !i + 1 + done +} + +rule main = parse + "`" { command_beginning := Lexing.lexeme_start lexbuf; + first_item := true; + print_char '('; + command lexbuf; + print_char ')'; + main lexbuf } + | "\\`" + { print_string "`"; main lexbuf } + | eof { () } + | _ { print_char(Lexing.lexeme_char lexbuf 0); main lexbuf } + +and command = parse + "`" { () } + | eof { prerr_string "Unterminated `...` at character "; + prerr_int !command_beginning; + prerr_newline(); + exit 2 } + | "{" [^ '}'] * "}" + { let s = Lexing.lexeme lexbuf in + add_semicolon(); + print_string (String.sub s 1 (String.length s - 2)); + command lexbuf } + | ( [^ '`' '{' '\\'] | + '\\' ['\\' '"' 'n' 't' 'b' 'r' '`' '{' ] | + '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] ) + + { let s = Lexing.lexeme lexbuf in + add_semicolon(); + (* Optimise one-character strings *) + if String.length s = 1 && s.[0] <> '\\' && s.[0] <> '\'' + || String.length s = 2 && s.[0] = '\\' && s.[1] <> '`' && s.[1]<>'{' + (* ` *) + then begin + print_string "emit_char '"; + print_unescaped_string s; + print_string "'" + end else begin + print_string "emit_string \""; + print_unescaped_string s; + print_string "\"" + end; + command lexbuf } + +{ +let _ = main(Lexing.from_channel stdin) + +let _ = exit (0) +} diff --git a/ocaml-binary-annot/tools/depend.ml b/ocaml-binary-annot/tools/depend.ml new file mode 100644 index 0000000000..4a0da760b2 --- /dev/null +++ b/ocaml-binary-annot/tools/depend.ml @@ -0,0 +1,306 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Format +open Location +open Longident +open Parsetree + +module StringSet = Set.Make(struct type t = string let compare = compare end) + +(* Collect free module identifiers in the a.s.t. *) + +let free_structure_names = ref StringSet.empty + +let rec addmodule bv lid = + match lid with + Lident s -> + if not (StringSet.mem s bv) + then free_structure_names := StringSet.add s !free_structure_names + | Ldot(l, s) -> addmodule bv l + | Lapply(l1, l2) -> addmodule bv l1; addmodule bv l2 + +let add bv lid = + match lid with + Ldot(l, s) -> addmodule bv l + | _ -> () + +let rec add_type bv ty = + match ty.ptyp_desc with + Ptyp_any -> () + | Ptyp_var v -> () + | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2 + | Ptyp_tuple tl -> List.iter (add_type bv) tl + | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl + | Ptyp_object fl -> List.iter (add_field_type bv) fl + | Ptyp_class(c, tl, _) -> add bv c; List.iter (add_type bv) tl + | Ptyp_alias(t, s) -> add_type bv t + | Ptyp_variant(fl, _, _) -> + List.iter + (function Rtag(_,_,stl) -> List.iter (add_type bv) stl + | Rinherit sty -> add_type bv sty) + fl + | Ptyp_poly(_, t) -> add_type bv t + | Ptyp_package pt -> add_package_type bv pt + +and add_package_type bv (lid, l) = + add bv lid; + List.iter (add_type bv) (List.map snd l) + +and add_field_type bv ft = + match ft.pfield_desc with + Pfield(name, ty) -> add_type bv ty + | Pfield_var -> () + +let add_opt add_fn bv = function + None -> () + | Some x -> add_fn bv x + +let add_type_declaration bv td = + List.iter + (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2) + td.ptype_cstrs; + add_opt add_type bv td.ptype_manifest; + let rec add_tkind = function + Ptype_abstract -> () + | Ptype_variant cstrs -> + List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs + | Ptype_record lbls -> + List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in + add_tkind td.ptype_kind + +let rec add_class_type bv cty = + match cty.pcty_desc with + Pcty_constr(l, tyl) -> + add bv l; List.iter (add_type bv) tyl + | Pcty_signature (ty, fieldl) -> + add_type bv ty; + List.iter (add_class_type_field bv) fieldl + | Pcty_fun(_, ty1, cty2) -> + add_type bv ty1; add_class_type bv cty2 + +and add_class_type_field bv = function + Pctf_inher cty -> add_class_type bv cty + | Pctf_val(_, _, _, ty, _) -> add_type bv ty + | Pctf_virt(_, _, ty, _) -> add_type bv ty + | Pctf_meth(_, _, ty, _) -> add_type bv ty + | Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2 + +let add_class_description bv infos = + add_class_type bv infos.pci_expr + +let add_class_type_declaration = add_class_description + +let rec add_pattern bv pat = + match pat.ppat_desc with + Ppat_any -> () + | Ppat_var _ -> () + | Ppat_alias(p, _) -> add_pattern bv p + | Ppat_constant _ -> () + | Ppat_tuple pl -> List.iter (add_pattern bv) pl + | Ppat_construct(c, op, _) -> add bv c; add_opt add_pattern bv op + | Ppat_record(pl, _) -> + List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl + | Ppat_array pl -> List.iter (add_pattern bv) pl + | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2 + | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty + | Ppat_variant(_, op) -> add_opt add_pattern bv op + | Ppat_type (li) -> add bv li + | Ppat_lazy p -> add_pattern bv p + | Ppat_unpack _ -> () + +let rec add_expr bv exp = + match exp.pexp_desc with + Pexp_ident l -> add bv l + | Pexp_constant _ -> () + | Pexp_let(_, pel, e) -> add_pat_expr_list bv pel; add_expr bv e + | Pexp_function (_, opte, pel) -> + add_opt add_expr bv opte; add_pat_expr_list bv pel + | Pexp_apply(e, el) -> + add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el + | Pexp_match(e, pel) -> add_expr bv e; add_pat_expr_list bv pel + | Pexp_try(e, pel) -> add_expr bv e; add_pat_expr_list bv pel + | Pexp_tuple el -> List.iter (add_expr bv) el + | Pexp_construct(c, opte, _) -> add bv c; add_opt add_expr bv opte + | Pexp_variant(_, opte) -> add_opt add_expr bv opte + | Pexp_record(lblel, opte) -> + List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel; + add_opt add_expr bv opte + | Pexp_field(e, fld) -> add_expr bv e; add bv fld + | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2 + | Pexp_array el -> List.iter (add_expr bv) el + | Pexp_ifthenelse(e1, e2, opte3) -> + add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3 + | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2 + | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2 + | Pexp_for(_, e1, e2, _, e3) -> + add_expr bv e1; add_expr bv e2; add_expr bv e3 + | Pexp_constraint(e1, oty2, oty3) -> + add_expr bv e1; + add_opt add_type bv oty2; + add_opt add_type bv oty3 + | Pexp_when(e1, e2) -> add_expr bv e1; add_expr bv e2 + | Pexp_send(e, m) -> add_expr bv e + | Pexp_new l -> add bv l + | Pexp_setinstvar(v, e) -> add_expr bv e + | Pexp_override sel -> List.iter (fun (s, e) -> add_expr bv e) sel + | Pexp_letmodule(id, m, e) -> + add_module bv m; add_expr (StringSet.add id bv) e + | Pexp_assert (e) -> add_expr bv e + | Pexp_assertfalse -> () + | Pexp_lazy (e) -> add_expr bv e + | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t + | Pexp_object (pat, fieldl) -> + add_pattern bv pat; List.iter (add_class_field bv) fieldl + | Pexp_newtype (_, e) -> add_expr bv e + | Pexp_pack m -> add_module bv m + | Pexp_open (m, e) -> addmodule bv m; add_expr bv e +and add_pat_expr_list bv pel = + List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel + +and add_modtype bv mty = + match mty.pmty_desc with + Pmty_ident l -> add bv l + | Pmty_signature s -> add_signature bv s + | Pmty_functor(id, mty1, mty2) -> + add_modtype bv mty1; add_modtype (StringSet.add id bv) mty2 + | Pmty_with(mty, cstrl) -> + add_modtype bv mty; + List.iter + (function (_, Pwith_type td) -> add_type_declaration bv td + | (_, Pwith_module lid) -> addmodule bv lid + | (_, Pwith_typesubst td) -> add_type_declaration bv td + | (_, Pwith_modsubst lid) -> addmodule bv lid) + cstrl + | Pmty_typeof m -> add_module bv m + +and add_signature bv = function + [] -> () + | item :: rem -> add_signature (add_sig_item bv item) rem + +and add_sig_item bv item = + match item.psig_desc with + Psig_value(id, vd) -> + add_type bv vd.pval_type; bv + | Psig_type dcls -> + List.iter (fun (id, td) -> add_type_declaration bv td) dcls; bv + | Psig_exception(id, args) -> + List.iter (add_type bv) args; bv + | Psig_module(id, mty) -> + add_modtype bv mty; StringSet.add id bv + | Psig_recmodule decls -> + let bv' = List.fold_right StringSet.add (List.map fst decls) bv in + List.iter (fun (id, mty) -> add_modtype bv' mty) decls; + bv' + | Psig_modtype(id, mtyd) -> + begin match mtyd with + Pmodtype_abstract -> () + | Pmodtype_manifest mty -> add_modtype bv mty + end; + bv + | Psig_open lid -> + addmodule bv lid; bv + | Psig_include mty -> + add_modtype bv mty; bv + | Psig_class cdl -> + List.iter (add_class_description bv) cdl; bv + | Psig_class_type cdtl -> + List.iter (add_class_type_declaration bv) cdtl; bv + +and add_module bv modl = + match modl.pmod_desc with + Pmod_ident l -> addmodule bv l + | Pmod_structure s -> ignore (add_structure bv s) + | Pmod_functor(id, mty, modl) -> + add_modtype bv mty; + add_module (StringSet.add id bv) modl + | Pmod_apply(mod1, mod2) -> + add_module bv mod1; add_module bv mod2 + | Pmod_constraint(modl, mty) -> + add_module bv modl; add_modtype bv mty + | Pmod_unpack(e) -> + add_expr bv e + +and add_structure bv item_list = + List.fold_left add_struct_item bv item_list + +and add_struct_item bv item = + match item.pstr_desc with + Pstr_eval e -> + add_expr bv e; bv + | Pstr_value(id, pel) -> + add_pat_expr_list bv pel; bv + | Pstr_primitive(id, vd) -> + add_type bv vd.pval_type; bv + | Pstr_type dcls -> + List.iter (fun (id, td) -> add_type_declaration bv td) dcls; bv + | Pstr_exception(id, args) -> + List.iter (add_type bv) args; bv + | Pstr_exn_rebind(id, l) -> + add bv l; bv + | Pstr_module(id, modl) -> + add_module bv modl; StringSet.add id bv + | Pstr_recmodule bindings -> + let bv' = + List.fold_right StringSet.add + (List.map (fun (id,_,_) -> id) bindings) bv in + List.iter + (fun (id, mty, modl) -> add_modtype bv' mty; add_module bv' modl) + bindings; + bv' + | Pstr_modtype(id, mty) -> + add_modtype bv mty; bv + | Pstr_open l -> + addmodule bv l; bv + | Pstr_class cdl -> + List.iter (add_class_declaration bv) cdl; bv + | Pstr_class_type cdtl -> + List.iter (add_class_type_declaration bv) cdtl; bv + | Pstr_include modl -> + add_module bv modl; bv + +and add_use_file bv top_phrs = + ignore (List.fold_left add_top_phrase bv top_phrs) + +and add_top_phrase bv = function + | Ptop_def str -> add_structure bv str + | Ptop_dir (_, _) -> bv + +and add_class_expr bv ce = + match ce.pcl_desc with + Pcl_constr(l, tyl) -> + add bv l; List.iter (add_type bv) tyl + | Pcl_structure(pat, fieldl) -> + add_pattern bv pat; List.iter (add_class_field bv) fieldl + | Pcl_fun(_, opte, pat, ce) -> + add_opt add_expr bv opte; add_pattern bv pat; add_class_expr bv ce + | Pcl_apply(ce, exprl) -> + add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl + | Pcl_let(_, pel, ce) -> + add_pat_expr_list bv pel; add_class_expr bv ce + | Pcl_constraint(ce, ct) -> + add_class_expr bv ce; add_class_type bv ct + +and add_class_field bv = function + Pcf_inher(_, ce, _) -> add_class_expr bv ce + | Pcf_val(_, _, _, e, _) -> add_expr bv e + | Pcf_valvirt(_, _, ty, _) + | Pcf_virt(_, _, ty, _) -> add_type bv ty + | Pcf_meth(_, _, _, e, _) -> add_expr bv e + | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2 + | Pcf_let(_, pel, _) -> add_pat_expr_list bv pel + | Pcf_init e -> add_expr bv e + +and add_class_declaration bv decl = + add_class_expr bv decl.pci_expr diff --git a/ocaml-binary-annot/tools/depend.mli b/ocaml-binary-annot/tools/depend.mli new file mode 100644 index 0000000000..a13870610b --- /dev/null +++ b/ocaml-binary-annot/tools/depend.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Module dependencies. *) + +module StringSet : Set.S with type elt = string + +val free_structure_names : StringSet.t ref + +val add_use_file : StringSet.t -> Parsetree.toplevel_phrase list -> unit + +val add_signature : StringSet.t -> Parsetree.signature -> unit diff --git a/ocaml-binary-annot/tools/dumpobj.ml b/ocaml-binary-annot/tools/dumpobj.ml new file mode 100644 index 0000000000..2a054ee684 --- /dev/null +++ b/ocaml-binary-annot/tools/dumpobj.ml @@ -0,0 +1,560 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Disassembler for executable and .cmo object files *) + +open Asttypes +open Config +open Emitcode +open Instruct +open Lambda +open Location +open Obj +open Opcodes +open Opnames +open Cmo_format +open Printf + +(* Read signed and unsigned integers *) + +let inputu ic = + let b1 = input_byte ic in + let b2 = input_byte ic in + let b3 = input_byte ic in + let b4 = input_byte ic in + (b4 lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1 + +let inputs ic = + let b1 = input_byte ic in + let b2 = input_byte ic in + let b3 = input_byte ic in + let b4 = input_byte ic in + let b4' = if b4 >= 128 then b4-256 else b4 in + (b4' lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1 + +(* Global variables *) + +type global_table_entry = + Empty + | Global of Ident.t + | Constant of Obj.t + +let start = ref 0 (* Position of beg. of code *) +let reloc = ref ([] : (reloc_info * int) list) (* Relocation table *) +let globals = ref ([||] : global_table_entry array) (* Global map *) +let primitives = ref ([||] : string array) (* Table of primitives *) +let objfile = ref false (* true if dumping a .cmo *) + +(* Events (indexed by PC) *) + +let event_table = (Hashtbl.create 253 : (int, debug_event) Hashtbl.t) + +let relocate_event orig ev = + ev.ev_pos <- orig + ev.ev_pos; + match ev.ev_repr with + Event_parent repr -> repr := ev.ev_pos + | _ -> () + +let record_events orig evl = + List.iter + (fun ev -> + relocate_event orig ev; + Hashtbl.add event_table ev.ev_pos ev) + evl + +(* Print a structured constant *) + +let print_float f = + if String.contains f '.' + then printf "%s" f + else printf "%s." f +;; + +let rec print_struct_const = function + Const_base(Const_int i) -> printf "%d" i + | Const_base(Const_float f) -> print_float f + | Const_base(Const_string s) -> printf "%S" s + | Const_immstring s -> printf "%S" s + | Const_base(Const_char c) -> printf "%C" c + | Const_base(Const_int32 i) -> printf "%ldl" i + | Const_base(Const_nativeint i) -> printf "%ndn" i + | Const_base(Const_int64 i) -> printf "%LdL" i + | Const_pointer n -> printf "%da" n + | Const_block(tag, args) -> + printf "<%d>" tag; + begin match args with + [] -> () + | [a1] -> + printf "("; print_struct_const a1; printf ")" + | a1::al -> + printf "("; print_struct_const a1; + List.iter (fun a -> printf ", "; print_struct_const a) al; + printf ")" + end + | Const_float_array a -> + printf "[|"; + List.iter (fun f -> print_float f; printf "; ") a; + printf "|]" + +(* Print an obj *) + +let same_custom x y = + Obj.field x 0 = Obj.field (Obj.repr y) 0 + +let rec print_obj x = + if Obj.is_block x then begin + let tag = Obj.tag x in + if tag = Obj.string_tag then + printf "%S" (Obj.magic x : string) + else if tag = Obj.double_tag then + printf "%.12g" (Obj.magic x : float) + else if tag = Obj.double_array_tag then begin + let a = (Obj.magic x : float array) in + printf "[|"; + for i = 0 to Array.length a - 1 do + if i > 0 then printf ", "; + printf "%.12g" a.(i) + done; + printf "|]" + end else if tag = Obj.custom_tag && same_custom x 0l then + printf "%ldl" (Obj.magic x : int32) + else if tag = Obj.custom_tag && same_custom x 0n then + printf "%ndn" (Obj.magic x : nativeint) + else if tag = Obj.custom_tag && same_custom x 0L then + printf "%LdL" (Obj.magic x : int64) + else if tag < Obj.no_scan_tag then begin + printf "<%d>" (Obj.tag x); + match Obj.size x with + 0 -> () + | 1 -> + printf "("; print_obj (Obj.field x 0); printf ")" + | n -> + printf "("; print_obj (Obj.field x 0); + for i = 1 to n - 1 do + printf ", "; print_obj (Obj.field x i) + done; + printf ")" + end else + printf "<tag %d>" tag + end else + printf "%d" (Obj.magic x : int) + +(* Current position in input file *) + +let currpos ic = + pos_in ic - !start + +(* Access in the relocation table *) + +let rec rassoc key = function + [] -> raise Not_found + | (a,b) :: l -> if b = key then a else rassoc key l + +let find_reloc ic = + rassoc (pos_in ic - !start) !reloc + +(* Symbolic printing of global names, etc *) + +let print_getglobal_name ic = + if !objfile then begin + begin try + match find_reloc ic with + Reloc_getglobal id -> print_string (Ident.name id) + | Reloc_literal sc -> print_struct_const sc + | _ -> print_string "<wrong reloc>" + with Not_found -> + print_string "<no reloc>" + end; + ignore (inputu ic); + end + else begin + let n = inputu ic in + if n >= Array.length !globals || n < 0 + then print_string "<global table overflow>" + else match !globals.(n) with + Global id -> print_string(Ident.name id) + | Constant obj -> print_obj obj + | _ -> print_string "???" + end + +let print_setglobal_name ic = + if !objfile then begin + begin try + match find_reloc ic with + Reloc_setglobal id -> print_string (Ident.name id) + | _ -> print_string "<wrong reloc>" + with Not_found -> + print_string "<no reloc>" + end; + ignore (inputu ic); + end + else begin + let n = inputu ic in + if n >= Array.length !globals || n < 0 + then print_string "<global table overflow>" + else match !globals.(n) with + Global id -> print_string(Ident.name id) + | _ -> print_string "???" + end + +let print_primitive ic = + if !objfile then begin + begin try + match find_reloc ic with + Reloc_primitive s -> print_string s + | _ -> print_string "<wrong reloc>" + with Not_found -> + print_string "<no reloc>" + end; + ignore (inputu ic); + end + else begin + let n = inputu ic in + if n >= Array.length !primitives || n < 0 + then print_int n + else print_string !primitives.(n) + end + +(* Disassemble one instruction *) + +let currpc ic = + currpos ic / 4 + +type shape = + | Nothing + | Uint + | Sint + | Uint_Uint + | Disp + | Uint_Disp + | Sint_Disp + | Getglobal + | Getglobal_Uint + | Setglobal + | Primitive + | Uint_Primitive + | Switch + | Closurerec + | Pubmet +;; + +let op_shapes = [ + opACC0, Nothing; + opACC1, Nothing; + opACC2, Nothing; + opACC3, Nothing; + opACC4, Nothing; + opACC5, Nothing; + opACC6, Nothing; + opACC7, Nothing; + opACC, Uint; + opPUSH, Nothing; + opPUSHACC0, Nothing; + opPUSHACC1, Nothing; + opPUSHACC2, Nothing; + opPUSHACC3, Nothing; + opPUSHACC4, Nothing; + opPUSHACC5, Nothing; + opPUSHACC6, Nothing; + opPUSHACC7, Nothing; + opPUSHACC, Uint; + opPOP, Uint; + opASSIGN, Uint; + opENVACC1, Nothing; + opENVACC2, Nothing; + opENVACC3, Nothing; + opENVACC4, Nothing; + opENVACC, Uint; + opPUSHENVACC1, Nothing; + opPUSHENVACC2, Nothing; + opPUSHENVACC3, Nothing; + opPUSHENVACC4, Nothing; + opPUSHENVACC, Uint; + opPUSH_RETADDR, Disp; + opAPPLY, Uint; + opAPPLY1, Nothing; + opAPPLY2, Nothing; + opAPPLY3, Nothing; + opAPPTERM, Uint_Uint; + opAPPTERM1, Uint; + opAPPTERM2, Uint; + opAPPTERM3, Uint; + opRETURN, Uint; + opRESTART, Nothing; + opGRAB, Uint; + opCLOSURE, Uint_Disp; + opCLOSUREREC, Closurerec; + opOFFSETCLOSUREM2, Nothing; + opOFFSETCLOSURE0, Nothing; + opOFFSETCLOSURE2, Nothing; + opOFFSETCLOSURE, Sint; (* was Uint *) + opPUSHOFFSETCLOSUREM2, Nothing; + opPUSHOFFSETCLOSURE0, Nothing; + opPUSHOFFSETCLOSURE2, Nothing; + opPUSHOFFSETCLOSURE, Sint; (* was Nothing *) + opGETGLOBAL, Getglobal; + opPUSHGETGLOBAL, Getglobal; + opGETGLOBALFIELD, Getglobal_Uint; + opPUSHGETGLOBALFIELD, Getglobal_Uint; + opSETGLOBAL, Setglobal; + opATOM0, Nothing; + opATOM, Uint; + opPUSHATOM0, Nothing; + opPUSHATOM, Uint; + opMAKEBLOCK, Uint_Uint; + opMAKEBLOCK1, Uint; + opMAKEBLOCK2, Uint; + opMAKEBLOCK3, Uint; + opMAKEFLOATBLOCK, Uint; + opGETFIELD0, Nothing; + opGETFIELD1, Nothing; + opGETFIELD2, Nothing; + opGETFIELD3, Nothing; + opGETFIELD, Uint; + opGETFLOATFIELD, Uint; + opSETFIELD0, Nothing; + opSETFIELD1, Nothing; + opSETFIELD2, Nothing; + opSETFIELD3, Nothing; + opSETFIELD, Uint; + opSETFLOATFIELD, Uint; + opVECTLENGTH, Nothing; + opGETVECTITEM, Nothing; + opSETVECTITEM, Nothing; + opGETSTRINGCHAR, Nothing; + opSETSTRINGCHAR, Nothing; + opBRANCH, Disp; + opBRANCHIF, Disp; + opBRANCHIFNOT, Disp; + opSWITCH, Switch; + opBOOLNOT, Nothing; + opPUSHTRAP, Disp; + opPOPTRAP, Nothing; + opRAISE, Nothing; + opCHECK_SIGNALS, Nothing; + opC_CALL1, Primitive; + opC_CALL2, Primitive; + opC_CALL3, Primitive; + opC_CALL4, Primitive; + opC_CALL5, Primitive; + opC_CALLN, Uint_Primitive; + opCONST0, Nothing; + opCONST1, Nothing; + opCONST2, Nothing; + opCONST3, Nothing; + opCONSTINT, Sint; + opPUSHCONST0, Nothing; + opPUSHCONST1, Nothing; + opPUSHCONST2, Nothing; + opPUSHCONST3, Nothing; + opPUSHCONSTINT, Sint; + opNEGINT, Nothing; + opADDINT, Nothing; + opSUBINT, Nothing; + opMULINT, Nothing; + opDIVINT, Nothing; + opMODINT, Nothing; + opANDINT, Nothing; + opORINT, Nothing; + opXORINT, Nothing; + opLSLINT, Nothing; + opLSRINT, Nothing; + opASRINT, Nothing; + opEQ, Nothing; + opNEQ, Nothing; + opLTINT, Nothing; + opLEINT, Nothing; + opGTINT, Nothing; + opGEINT, Nothing; + opOFFSETINT, Sint; + opOFFSETREF, Sint; + opISINT, Nothing; + opGETMETHOD, Nothing; + opGETDYNMET, Nothing; + opGETPUBMET, Pubmet; + opBEQ, Sint_Disp; + opBNEQ, Sint_Disp; + opBLTINT, Sint_Disp; + opBLEINT, Sint_Disp; + opBGTINT, Sint_Disp; + opBGEINT, Sint_Disp; + opULTINT, Nothing; + opUGEINT, Nothing; + opBULTINT, Uint_Disp; + opBUGEINT, Uint_Disp; + opSTOP, Nothing; + opEVENT, Nothing; + opBREAK, Nothing; +];; + +let print_event ev = + let ls = ev.ev_loc.loc_start in + let le = ev.ev_loc.loc_end in + printf "File \"%s\", line %d, characters %d-%d:\n" ls.Lexing.pos_fname + ls.Lexing.pos_lnum (ls.Lexing.pos_cnum - ls.Lexing.pos_bol) + (le.Lexing.pos_cnum - ls.Lexing.pos_bol) + +let print_instr ic = + let pos = currpos ic in + List.iter print_event (Hashtbl.find_all event_table pos); + printf "%8d " (pos / 4); + let op = inputu ic in + if op >= Array.length names_of_instructions || op < 0 + then (print_string "*** unknown opcode : "; print_int op) + else print_string names_of_instructions.(op); + print_string " "; + begin try match List.assoc op op_shapes with + | Uint -> print_int (inputu ic) + | Sint -> print_int (inputs ic) + | Uint_Uint + -> print_int (inputu ic); print_string ", "; print_int (inputu ic) + | Disp -> let p = currpc ic in print_int (p + inputs ic) + | Uint_Disp + -> print_int (inputu ic); print_string ", "; + let p = currpc ic in print_int (p + inputs ic) + | Sint_Disp + -> print_int (inputs ic); print_string ", "; + let p = currpc ic in print_int (p + inputs ic) + | Getglobal -> print_getglobal_name ic + | Getglobal_Uint + -> print_getglobal_name ic; print_string ", "; print_int (inputu ic) + | Setglobal -> print_setglobal_name ic + | Primitive -> print_primitive ic + | Uint_Primitive + -> print_int(inputu ic); print_string ", "; print_primitive ic + | Switch + -> let n = inputu ic in + let orig = currpc ic in + for i = 0 to (n land 0xFFFF) - 1 do + print_string "\n int "; print_int i; print_string " -> "; + print_int(orig + inputs ic); + done; + for i = 0 to (n lsr 16) - 1 do + print_string "\n tag "; print_int i; print_string " -> "; + print_int(orig + inputs ic); + done; + | Closurerec + -> let nfuncs = inputu ic in + let nvars = inputu ic in + let orig = currpc ic in + print_int nvars; + for i = 0 to nfuncs - 1 do + print_string ", "; + print_int (orig + inputs ic); + done; + | Pubmet + -> let tag = inputs ic in + let _cache = inputu ic in + print_int tag + | Nothing -> () + with Not_found -> print_string "(unknown arguments)" + end; + print_string "\n"; +;; + +(* Disassemble a block of code *) + +let print_code ic len = + start := pos_in ic; + let stop = !start + len in + while pos_in ic < stop do print_instr ic done + +(* Dump relocation info *) + +let print_reloc (info, pos) = + printf " %d (%d) " pos (pos/4); + match info with + Reloc_literal sc -> print_struct_const sc; printf "\n" + | Reloc_getglobal id -> printf "require %s\n" (Ident.name id) + | Reloc_setglobal id -> printf "provide %s\n" (Ident.name id) + | Reloc_primitive s -> printf "prim %s\n" s + +(* Print a .cmo file *) + +let dump_obj filename ic = + let buffer = String.create (String.length cmo_magic_number) in + really_input ic buffer 0 (String.length cmo_magic_number); + if buffer <> cmo_magic_number then begin + prerr_endline "Not an object file"; exit 2 + end; + let cu_pos = input_binary_int ic in + seek_in ic cu_pos; + let cu = (input_value ic : compilation_unit) in + reloc := cu.cu_reloc; + if cu.cu_debug > 0 then begin + seek_in ic cu.cu_debug; + let evl = (input_value ic : debug_event list) in + record_events 0 evl + end; + seek_in ic cu.cu_pos; + print_code ic cu.cu_codesize + +(* Read the primitive table from an executable *) + +let read_primitive_table ic len = + let p = String.create len in + really_input ic p 0 len; + let rec split beg cur = + if cur >= len then [] + else if p.[cur] = '\000' then + String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1) + else + split beg (cur + 1) in + Array.of_list(split 0 0) + +(* Print an executable file *) + +let dump_exe ic = + Bytesections.read_toc ic; + let prim_size = Bytesections.seek_section ic "PRIM" in + primitives := read_primitive_table ic prim_size; + ignore(Bytesections.seek_section ic "DATA"); + let init_data = (input_value ic : Obj.t array) in + globals := Array.create (Array.length init_data) Empty; + for i = 0 to Array.length init_data - 1 do + !globals.(i) <- Constant (init_data.(i)) + done; + ignore(Bytesections.seek_section ic "SYMB"); + let (_, sym_table) = (input_value ic : int * (Ident.t, int) Tbl.t) in + Tbl.iter (fun id pos -> !globals.(pos) <- Global id) sym_table; + begin try + ignore (Bytesections.seek_section ic "DBUG"); + let num_eventlists = input_binary_int ic in + for i = 1 to num_eventlists do + let orig = input_binary_int ic in + let evl = (input_value ic : debug_event list) in + record_events orig evl + done + with Not_found -> () + end; + let code_size = Bytesections.seek_section ic "CODE" in + print_code ic code_size + +let main() = + for i = 1 to Array.length Sys.argv - 1 do + let filnam = Sys.argv.(i) in + let ic = open_in_bin filnam in + if i>1 then print_newline (); + printf "## start of ocaml dump of %S\n%!" filnam; + begin try + objfile := false; dump_exe ic + with Bytesections.Bad_magic_number -> + objfile := true; seek_in ic 0; dump_obj (Sys.argv.(i)) ic + end; + close_in ic; + printf "## end of ocaml dump of %S\n%!" filnam; + done; + exit 0 + +let _ = main () diff --git a/ocaml-binary-annot/tools/lexer299.mll b/ocaml-binary-annot/tools/lexer299.mll new file mode 100644 index 0000000000..9a244721df --- /dev/null +++ b/ocaml-binary-annot/tools/lexer299.mll @@ -0,0 +1,460 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The lexer definition *) + +{ +open Lexing +open Misc + +type token = + AMPERAMPER + | AMPERSAND + | AND + | AS + | ASSERT + | BACKQUOTE + | BAR + | BARBAR + | BARRBRACKET + | BEGIN + | CHAR of (char) + | CLASS + | COLON + | COLONCOLON + | COLONEQUAL + | COLONGREATER + | COMMA + | CONSTRAINT + | DO + | DONE + | DOT + | DOTDOT + | DOWNTO + | ELSE + | END + | EOF + | EQUAL + | EXCEPTION + | EXTERNAL + | FALSE + | FLOAT of (string) + | FOR + | FUN + | FUNCTION + | FUNCTOR + | GREATER + | GREATERRBRACE + | GREATERRBRACKET + | IF + | IN + | INCLUDE + | INFIXOP0 of (string) + | INFIXOP1 of (string) + | INFIXOP2 of (string) + | INFIXOP3 of (string) + | INFIXOP4 of (string) + | INHERIT + | INITIALIZER + | INT of (int) + | LABEL of (string) + | LABELID of (string) + | LAZY + | LBRACE + | LBRACELESS + | LBRACKET + | LBRACKETBAR + | LBRACKETLESS + | LESS + | LESSMINUS + | LET + | LIDENT of (string) + | LPAREN + | MATCH + | METHOD + | MINUSGREATER + | MODULE + | MUTABLE + | NEW + | OBJECT + | OF + | OPEN + | OR + | PARSER + | PREFIXOP of (string) + | PRIVATE + | QUESTION + | QUESTION2 + | QUOTE + | RBRACE + | RBRACKET + | REC + | RPAREN + | SEMI + | SEMISEMI + | SHARP + | SIG + | STAR + | STRING of (string) + | STRUCT + | SUBTRACTIVE of (string) + | THEN + | TO + | TRUE + | TRY + | TYPE + | UIDENT of (string) + | UNDERSCORE + | VAL + | VIRTUAL + | WHEN + | WHILE + | WITH + +type error = + | Illegal_character of char + | Unterminated_comment + | Unterminated_string + | Unterminated_string_in_comment +;; + +exception Error of error * int * int + +(* The table of keywords *) + +let keyword_table = + create_hashtable 149 [ + "and", AND; + "as", AS; + "assert", ASSERT; + "begin", BEGIN; + "class", CLASS; + "constraint", CONSTRAINT; + "do", DO; + "done", DONE; + "downto", DOWNTO; + "else", ELSE; + "end", END; + "exception", EXCEPTION; + "external", EXTERNAL; + "false", FALSE; + "for", FOR; + "fun", FUN; + "function", FUNCTION; + "functor", FUNCTOR; + "if", IF; + "in", IN; + "include", INCLUDE; + "inherit", INHERIT; + "initializer", INITIALIZER; + "lazy", LAZY; + "let", LET; + "match", MATCH; + "method", METHOD; + "module", MODULE; + "mutable", MUTABLE; + "new", NEW; + "object", OBJECT; + "of", OF; + "open", OPEN; + "or", OR; + "parser", PARSER; + "private", PRIVATE; + "rec", REC; + "sig", SIG; + "struct", STRUCT; + "then", THEN; + "to", TO; + "true", TRUE; + "try", TRY; + "type", TYPE; + "val", VAL; + "virtual", VIRTUAL; + "when", WHEN; + "while", WHILE; + "with", WITH; + + "mod", INFIXOP3("mod"); + "land", INFIXOP3("land"); + "lor", INFIXOP3("lor"); + "lxor", INFIXOP3("lxor"); + "lsl", INFIXOP4("lsl"); + "lsr", INFIXOP4("lsr"); + "asr", INFIXOP4("asr") +] + +(* To buffer string literals *) + +let initial_string_buffer = String.create 256 +let string_buff = ref initial_string_buffer +let string_index = ref 0 + +let reset_string_buffer () = + string_buff := initial_string_buffer; + string_index := 0 + +let store_string_char c = + if !string_index >= String.length (!string_buff) then begin + let new_buff = String.create (String.length (!string_buff) * 2) in + String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff)); + string_buff := new_buff + end; + String.unsafe_set (!string_buff) (!string_index) c; + incr string_index + +let get_stored_string () = + let s = String.sub (!string_buff) 0 (!string_index) in + string_buff := initial_string_buffer; + s + +(* To translate escape sequences *) + +let char_for_backslash = function + | 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + +let char_for_decimal_code lexbuf i = + let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in + Char.chr(c land 0xFF) + +(* To store the position of the beginning of a string and comment *) +let string_start_pos = ref 0;; +let comment_start_pos = ref [];; + +(* Error report *) + +open Format + +let report_error ppf = function + | Illegal_character c -> + fprintf ppf "Illegal character (%s)" (Char.escaped c) + | Unterminated_comment -> + fprintf ppf "Comment not terminated" + | Unterminated_string -> + fprintf ppf "String literal not terminated" + | Unterminated_string_in_comment -> + fprintf ppf "This comment contains an unterminated string literal" +;; + +} + +let blank = [' ' '\010' '\013' '\009' '\012'] +let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] +let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] +let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] +let symbolchar = + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] +let symbolchar2 = + ['!' '$' '%' '&' '*' '+' '-' '.' '/' '<' '=' '>' '?' '@' '^' '|' '~'] +(* ['!' '$' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] *) +let decimal_literal = ['0'-'9']+ +let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ +let oct_literal = '0' ['o' 'O'] ['0'-'7']+ +let bin_literal = '0' ['b' 'B'] ['0'-'1']+ +let float_literal = + ['0'-'9']+ ('.' ['0'-'9']* )? (['e' 'E'] ['+' '-']? ['0'-'9']+)? + +rule token = parse + blank + + { token lexbuf } + | "_" + { UNDERSCORE } + | lowercase identchar * ':' [ ^ ':' '=' '>'] + { let s = Lexing.lexeme lexbuf in + lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - 1; + lexbuf.lex_curr_p <- + {lexbuf.lex_curr_p with pos_cnum = lexbuf.lex_curr_p.pos_cnum - 1}; + LABEL (String.sub s 0 (String.length s - 2)) } +(* + | lowercase identchar * ':' + { let s = Lexing.lexeme lexbuf in + LABEL (String.sub s 0 (String.length s - 1)) } + | '%' lowercase identchar * +*) + | ':' lowercase identchar * + { let s = Lexing.lexeme lexbuf in + let l = String.length s - 1 in + LABELID (String.sub s 1 l) } + | lowercase identchar * + { let s = Lexing.lexeme lexbuf in + try + Hashtbl.find keyword_table s + with Not_found -> + LIDENT s } + | uppercase identchar * + { UIDENT(Lexing.lexeme lexbuf) } (* No capitalized keywords *) + | decimal_literal | hex_literal | oct_literal | bin_literal + { INT (int_of_string(Lexing.lexeme lexbuf)) } + | float_literal + { FLOAT (Lexing.lexeme lexbuf) } + | "\"" + { reset_string_buffer(); + let string_start = Lexing.lexeme_start lexbuf in + string_start_pos := string_start; + string lexbuf; + lexbuf.Lexing.lex_start_pos <- + string_start - lexbuf.Lexing.lex_abs_pos; + STRING (get_stored_string()) } + | "'" [^ '\\' '\''] "'" + { CHAR(Lexing.lexeme_char lexbuf 1) } + | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" + { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) } + | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + { CHAR(char_for_decimal_code lexbuf 2) } + | "(*" + { comment_start_pos := [Lexing.lexeme_start lexbuf]; + comment lexbuf; + token lexbuf } + | "(*)" + { let loc = { Location.loc_start = Lexing.lexeme_start_p lexbuf; + Location.loc_end = Lexing.lexeme_end_p lexbuf; + Location.loc_ghost = false } + in + Location.prerr_warning loc (Warnings.Comment_start); + comment_start_pos := [Lexing.lexeme_start lexbuf]; + comment lexbuf; + token lexbuf + } + | "*)" + { let loc = { Location.loc_start = Lexing.lexeme_start_p lexbuf; + Location.loc_end = Lexing.lexeme_end_p lexbuf; + Location.loc_ghost = false } + in + Location.prerr_warning loc Warnings.Comment_not_end; + lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; + STAR + } + | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") + (* # linenum ... *) + { token lexbuf } + | "#" { SHARP } + | "&" { AMPERSAND } + | "&&" { AMPERAMPER } + | "`" { BACKQUOTE } + | "'" { QUOTE } + | "(" { LPAREN } + | ")" { RPAREN } + | "*" { STAR } + | "," { COMMA } + | "?" { QUESTION } + | "??" { QUESTION2 } + | "->" { MINUSGREATER } + | "." { DOT } + | ".." { DOTDOT } + | ":" { COLON } + | "::" { COLONCOLON } + | ":=" { COLONEQUAL } + | ":>" { COLONGREATER } + | ";" { SEMI } + | ";;" { SEMISEMI } + | "<" { LESS } + | "<-" { LESSMINUS } + | "=" { EQUAL } + | "[" { LBRACKET } + | "[|" { LBRACKETBAR } + | "[<" { LBRACKETLESS } + | "]" { RBRACKET } + | "{" { LBRACE } + | "{<" { LBRACELESS } + | "|" { BAR } + | "||" { BARBAR } + | "|]" { BARRBRACKET } + | ">" { GREATER } + | ">]" { GREATERRBRACKET } + | "}" { RBRACE } + | ">}" { GREATERRBRACE } + + | "!=" { INFIXOP0 "!=" } + | "-" { SUBTRACTIVE "-" } + | "-." { SUBTRACTIVE "-." } + + | ['!' '~'] symbolchar * + { PREFIXOP(Lexing.lexeme lexbuf) } + | '?' symbolchar2 * + { PREFIXOP(Lexing.lexeme lexbuf) } + | ['=' '<' '>' '|' '&' '$'] symbolchar * + { INFIXOP0(Lexing.lexeme lexbuf) } + | ['@' '^'] symbolchar * + { INFIXOP1(Lexing.lexeme lexbuf) } + | ['+' '-'] symbolchar * + { INFIXOP2(Lexing.lexeme lexbuf) } + | "**" symbolchar * + { INFIXOP4(Lexing.lexeme lexbuf) } + | ['*' '/' '%'] symbolchar * + { INFIXOP3(Lexing.lexeme lexbuf) } + | eof { EOF } + | _ + { raise (Error(Illegal_character ((Lexing.lexeme lexbuf).[0]), + Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) } + +and comment = parse + "(*" + { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos; + comment lexbuf; + } + | "*)" + { match !comment_start_pos with + | [] -> assert false + | [x] -> () + | _ :: l -> comment_start_pos := l; + comment lexbuf; + } + | "\"" + { reset_string_buffer(); + string_start_pos := Lexing.lexeme_start lexbuf; + begin try string lexbuf + with Error (Unterminated_string, _, _) -> + let st = List.hd !comment_start_pos in + raise (Error (Unterminated_string_in_comment, st, st + 2)) + end; + string_buff := initial_string_buffer; + comment lexbuf } + | "''" + { comment lexbuf } + | "'" [^ '\\' '\''] "'" + { comment lexbuf } + | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'" + { comment lexbuf } + | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + { comment lexbuf } + | eof + { let st = List.hd !comment_start_pos in + raise (Error (Unterminated_comment, st, st + 2)); + } + | _ + { comment lexbuf } + +and string = parse + '"' + { () } + | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] * + { string lexbuf } + | '\\' ['\\' '"' 'n' 't' 'b' 'r'] + { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); + string lexbuf } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + { store_string_char(char_for_decimal_code lexbuf 1); + string lexbuf } + | eof + { raise (Error (Unterminated_string, + !string_start_pos, !string_start_pos+1)) } + | _ + { store_string_char(Lexing.lexeme_char lexbuf 0); + string lexbuf } diff --git a/ocaml-binary-annot/tools/lexer301.mll b/ocaml-binary-annot/tools/lexer301.mll new file mode 100644 index 0000000000..daec549e7e --- /dev/null +++ b/ocaml-binary-annot/tools/lexer301.mll @@ -0,0 +1,461 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The lexer definition *) + +{ +open Misc + +type token = + AMPERAMPER + | AMPERSAND + | AND + | AS + | ASSERT + | BACKQUOTE + | BAR + | BARBAR + | BARRBRACKET + | BEGIN + | CHAR of (char) + | CLASS + | COLON + | COLONCOLON + | COLONEQUAL + | COLONGREATER + | COMMA + | CONSTRAINT + | DO + | DONE + | DOT + | DOTDOT + | DOWNTO + | ELSE + | END + | EOF + | EQUAL + | EXCEPTION + | EXTERNAL + | FALSE + | FLOAT of (string) + | FOR + | FUN + | FUNCTION + | FUNCTOR + | GREATER + | GREATERRBRACE + | GREATERRBRACKET + | IF + | IN + | INCLUDE + | INFIXOP0 of (string) + | INFIXOP1 of (string) + | INFIXOP2 of (string) + | INFIXOP3 of (string) + | INFIXOP4 of (string) + | INHERIT + | INITIALIZER + | INT of (int) + | LABEL of (string) + | LAZY + | LBRACE + | LBRACELESS + | LBRACKET + | LBRACKETBAR + | LBRACKETLESS + | LESS + | LESSMINUS + | LET + | LIDENT of (string) + | LPAREN + | MATCH + | METHOD + | MINUS + | MINUSDOT + | MINUSGREATER + | MODULE + | MUTABLE + | NEW + | OBJECT + | OF + | OPEN + | OPTLABEL of (string) + | OR + | PARSER + | PLUS + | PREFIXOP of (string) + | PRIVATE + | QUESTION + | QUESTION2 + | QUOTE + | RBRACE + | RBRACKET + | REC + | RPAREN + | SEMI + | SEMISEMI + | SHARP + | SIG + | STAR + | STRING of (string) + | STRUCT + | THEN + | TILDE + | TO + | TRUE + | TRY + | TYPE + | UIDENT of (string) + | UNDERSCORE + | VAL + | VIRTUAL + | WHEN + | WHILE + | WITH + +type error = + | Illegal_character of char + | Unterminated_comment + | Unterminated_string + | Unterminated_string_in_comment + | Keyword_as_label of string +;; + +exception Error of error * int * int + +(* The table of keywords *) + +let keyword_table = + create_hashtable 149 [ + "and", AND; + "as", AS; + "assert", ASSERT; + "begin", BEGIN; + "class", CLASS; + "constraint", CONSTRAINT; + "do", DO; + "done", DONE; + "downto", DOWNTO; + "else", ELSE; + "end", END; + "exception", EXCEPTION; + "external", EXTERNAL; + "false", FALSE; + "for", FOR; + "fun", FUN; + "function", FUNCTION; + "functor", FUNCTOR; + "if", IF; + "in", IN; + "include", INCLUDE; + "inherit", INHERIT; + "initializer", INITIALIZER; + "lazy", LAZY; + "let", LET; + "match", MATCH; + "method", METHOD; + "module", MODULE; + "mutable", MUTABLE; + "new", NEW; + "object", OBJECT; + "of", OF; + "open", OPEN; + "or", OR; + "parser", PARSER; + "private", PRIVATE; + "rec", REC; + "sig", SIG; + "struct", STRUCT; + "then", THEN; + "to", TO; + "true", TRUE; + "try", TRY; + "type", TYPE; + "val", VAL; + "virtual", VIRTUAL; + "when", WHEN; + "while", WHILE; + "with", WITH; + + "mod", INFIXOP3("mod"); + "land", INFIXOP3("land"); + "lor", INFIXOP3("lor"); + "lxor", INFIXOP3("lxor"); + "lsl", INFIXOP4("lsl"); + "lsr", INFIXOP4("lsr"); + "asr", INFIXOP4("asr") +] + +(* To buffer string literals *) + +let initial_string_buffer = String.create 256 +let string_buff = ref initial_string_buffer +let string_index = ref 0 + +let reset_string_buffer () = + string_buff := initial_string_buffer; + string_index := 0 + +let store_string_char c = + if !string_index >= String.length (!string_buff) then begin + let new_buff = String.create (String.length (!string_buff) * 2) in + String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff)); + string_buff := new_buff + end; + String.unsafe_set (!string_buff) (!string_index) c; + incr string_index + +let get_stored_string () = + let s = String.sub (!string_buff) 0 (!string_index) in + string_buff := initial_string_buffer; + s + +(* To translate escape sequences *) + +let char_for_backslash = function + | 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + +let char_for_decimal_code lexbuf i = + let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in + Char.chr(c land 0xFF) + +(* To store the position of the beginning of a string and comment *) +let string_start_pos = ref 0;; +let comment_start_pos = ref [];; +let in_comment () = !comment_start_pos <> [];; + +(* Error report *) + +open Format + +let report_error ppf = function + | Illegal_character c -> + fprintf ppf "Illegal character (%s)" (Char.escaped c) + | Unterminated_comment -> + fprintf ppf "Comment not terminated" + | Unterminated_string -> + fprintf ppf "String literal not terminated" + | Unterminated_string_in_comment -> + fprintf ppf "This comment contains an unterminated string literal" + | Keyword_as_label kwd -> + fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd +;; + +} + +let blank = [' ' '\010' '\013' '\009' '\012'] +let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] +let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] +let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] +let symbolchar = + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] +let decimal_literal = ['0'-'9']+ +let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ +let oct_literal = '0' ['o' 'O'] ['0'-'7']+ +let bin_literal = '0' ['b' 'B'] ['0'-'1']+ +let float_literal = + ['0'-'9']+ ('.' ['0'-'9']* )? (['e' 'E'] ['+' '-']? ['0'-'9']+)? + +rule token = parse + blank + + { token lexbuf } + | "_" + { UNDERSCORE } + | "~" { TILDE } + | "~" lowercase identchar * ':' + { let s = Lexing.lexeme lexbuf in + let name = String.sub s 1 (String.length s - 2) in + if Hashtbl.mem keyword_table name then + raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf, + Lexing.lexeme_end lexbuf)); + LABEL name } + | "?" { QUESTION } + | "?" lowercase identchar * ':' + { let s = Lexing.lexeme lexbuf in + let name = String.sub s 1 (String.length s - 2) in + if Hashtbl.mem keyword_table name then + raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf, + Lexing.lexeme_end lexbuf)); + OPTLABEL name } + | lowercase identchar * + { let s = Lexing.lexeme lexbuf in + try + Hashtbl.find keyword_table s + with Not_found -> + LIDENT s } + | uppercase identchar * + { UIDENT(Lexing.lexeme lexbuf) } (* No capitalized keywords *) + | decimal_literal | hex_literal | oct_literal | bin_literal + { INT (int_of_string(Lexing.lexeme lexbuf)) } + | float_literal + { FLOAT (Lexing.lexeme lexbuf) } + | "\"" + { reset_string_buffer(); + let string_start = Lexing.lexeme_start lexbuf in + string_start_pos := string_start; + string lexbuf; + lexbuf.Lexing.lex_start_pos <- + string_start - lexbuf.Lexing.lex_abs_pos; + STRING (get_stored_string()) } + | "'" [^ '\\' '\''] "'" + { CHAR(Lexing.lexeme_char lexbuf 1) } + | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" + { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) } + | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + { CHAR(char_for_decimal_code lexbuf 2) } + | "(*" + { comment_start_pos := [Lexing.lexeme_start lexbuf]; + comment lexbuf; + token lexbuf } + | "(*)" + { let loc = Location.curr lexbuf + and warn = Warnings.Comment_start + in + Location.prerr_warning loc warn; + comment_start_pos := [Lexing.lexeme_start lexbuf]; + comment lexbuf; + token lexbuf + } + | "*)" + { let loc = Location.curr lexbuf + and warn = Warnings.Comment_not_end + in + Location.prerr_warning loc warn; + lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; + STAR + } + | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") + (* # linenum ... *) + { token lexbuf } + | "#" { SHARP } + | "&" { AMPERSAND } + | "&&" { AMPERAMPER } + | "`" { BACKQUOTE } + | "'" { QUOTE } + | "(" { LPAREN } + | ")" { RPAREN } + | "*" { STAR } + | "," { COMMA } + | "??" { QUESTION2 } + | "->" { MINUSGREATER } + | "." { DOT } + | ".." { DOTDOT } + | ":" { COLON } + | "::" { COLONCOLON } + | ":=" { COLONEQUAL } + | ":>" { COLONGREATER } + | ";" { SEMI } + | ";;" { SEMISEMI } + | "<" { LESS } + | "<-" { LESSMINUS } + | "=" { EQUAL } + | "[" { LBRACKET } + | "[|" { LBRACKETBAR } + | "[<" { LBRACKETLESS } + | "]" { RBRACKET } + | "{" { LBRACE } + | "{<" { LBRACELESS } + | "|" { BAR } + | "||" { BARBAR } + | "|]" { BARRBRACKET } + | ">" { GREATER } + | ">]" { GREATERRBRACKET } + | "}" { RBRACE } + | ">}" { GREATERRBRACE } + + | "!=" { INFIXOP0 "!=" } + | "+" { PLUS } + | "-" { MINUS } + | "-." { MINUSDOT } + + | "!" symbolchar * + { PREFIXOP(Lexing.lexeme lexbuf) } + | ['~' '?'] symbolchar + + { PREFIXOP(Lexing.lexeme lexbuf) } + | ['=' '<' '>' '|' '&' '$'] symbolchar * + { INFIXOP0(Lexing.lexeme lexbuf) } + | ['@' '^'] symbolchar * + { INFIXOP1(Lexing.lexeme lexbuf) } + | ['+' '-'] symbolchar * + { INFIXOP2(Lexing.lexeme lexbuf) } + | "**" symbolchar * + { INFIXOP4(Lexing.lexeme lexbuf) } + | ['*' '/' '%'] symbolchar * + { INFIXOP3(Lexing.lexeme lexbuf) } + | eof { EOF } + | _ + { raise (Error(Illegal_character ((Lexing.lexeme lexbuf).[0]), + Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) } + +and comment = parse + "(*" + { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos; + comment lexbuf; + } + | "*)" + { match !comment_start_pos with + | [] -> assert false + | [x] -> comment_start_pos := []; + | _ :: l -> comment_start_pos := l; + comment lexbuf; + } + | "\"" + { reset_string_buffer(); + string_start_pos := Lexing.lexeme_start lexbuf; + begin try string lexbuf + with Error (Unterminated_string, _, _) -> + let st = List.hd !comment_start_pos in + raise (Error (Unterminated_string_in_comment, st, st + 2)) + end; + string_buff := initial_string_buffer; + comment lexbuf } + | "''" + { comment lexbuf } + | "'" [^ '\\' '\''] "'" + { comment lexbuf } + | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'" + { comment lexbuf } + | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + { comment lexbuf } + | eof + { let st = List.hd !comment_start_pos in + raise (Error (Unterminated_comment, st, st + 2)); + } + | _ + { comment lexbuf } + +and string = parse + '"' + { () } + | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] * + { string lexbuf } + | '\\' ['\\' '"' 'n' 't' 'b' 'r'] + { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); + string lexbuf } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + { store_string_char(char_for_decimal_code lexbuf 1); + string lexbuf } + | eof + { raise (Error (Unterminated_string, + !string_start_pos, !string_start_pos+1)) } + | _ + { store_string_char(Lexing.lexeme_char lexbuf 0); + string lexbuf } diff --git a/ocaml-binary-annot/tools/magic b/ocaml-binary-annot/tools/magic new file mode 100644 index 0000000000..7468066e01 --- /dev/null +++ b/ocaml-binary-annot/tools/magic @@ -0,0 +1,11 @@ +# Here are some definitions that can be added to the /usr/share/magic +# database so that the file(1) command recognizes OCaml compiled files. +# Contributed by Sven Luther. +0 string Caml1999 Objective Caml +>8 string X bytecode executable +>8 string I interface data (.cmi) +>8 string O bytecode object data (.cmo) +>8 string A bytecode library data (.cma) +>8 string Y native object data (.cmx) +>8 string Z native library data (.cmxa) +>9 string >\0 (Version %3.3s). diff --git a/ocaml-binary-annot/tools/make-opcodes b/ocaml-binary-annot/tools/make-opcodes new file mode 100644 index 0000000000..c8f573c682 --- /dev/null +++ b/ocaml-binary-annot/tools/make-opcodes @@ -0,0 +1,2 @@ +$1=="enum" {n=0; next; } + {for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}} diff --git a/ocaml-binary-annot/tools/make-package-macosx b/ocaml-binary-annot/tools/make-package-macosx new file mode 100755 index 0000000000..ebdf0eba2c --- /dev/null +++ b/ocaml-binary-annot/tools/make-package-macosx @@ -0,0 +1,129 @@ +#!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Damien Doligez, projet Moscova, INRIA Rocquencourt # +# # +# Copyright 2003 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id$ + +cd package-macosx +rm -rf ocaml.pkg ocaml-rw.dmg + +VERSION=`sed -e 1q ../VERSION` +VERSION_MAJOR=`sed -n -e '1s/^\([0-9]*\)\..*/\1/p' ../VERSION` +VERSION_MINOR=`sed -n -e '1s/^[0-9]*\.\([0-9]*\)[.+].*/\1/p' ../VERSION` + +cat >Description.plist <<EOF + <?xml version="1.0" encoding="UTF-8"?> + <!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" + "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> + <plist version="1.0"> + <dict> + <key>IFPkgDescriptionDeleteWarning</key> + <string></string> + <key>IFPkgDescriptionDescription</key> + <string>The Objective Caml compiler and tools</string> + <key>IFPkgDescriptionTitle</key> + <string>Objective Caml</string> + <key>IFPkgDescriptionVersion</key> + <string>${VERSION}</string> + </dict> + </plist> +EOF + +cat >Info.plist <<EOF +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" + "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> +<plist version="1.0"> +<dict> + <key>CFBundleGetInfoString</key> + <string>Objective Caml ${VERSION}</string> + <key>CFBundleIdentifier</key> + <string>fr.inria.ocaml</string> + <key>CFBundleName</key> + <string>Objective Caml</string> + <key>CFBundleShortVersionString</key> + <string>${VERSION}</string> + <key>IFMajorVersion</key> + <integer>${VERSION_MAJOR}</integer> + <key>IFMinorVersion</key> + <integer>${VERSION_MINOR}</integer> + <key>IFPkgFlagAllowBackRev</key> + <true/> + <key>IFPkgFlagAuthorizationAction</key> + <string>AdminAuthorization</string> + <key>IFPkgFlagDefaultLocation</key> + <string>/usr/local</string> + <key>IFPkgFlagInstallFat</key> + <false/> + <key>IFPkgFlagIsRequired</key> + <false/> + <key>IFPkgFlagRelocatable</key> + <false/> + <key>IFPkgFlagRestartAction</key> + <string>NoRestart</string> + <key>IFPkgFlagRootVolumeOnly</key> + <true/> + <key>IFPkgFlagUpdateInstalledLanguages</key> + <false/> + <key>IFPkgFormatVersion</key> + <real>0.10000000149011612</real> +</dict> +</plist> +EOF + +mkdir -p resources + +# stop here -> | +cat >resources/ReadMe.txt <<EOF +This package installs Objective Caml version ${VERSION}. +You need Mac OS X 10.5.x (Leopard), with the +XCode tools installed (v3.1.1 or later), and +optionally X11. + +Files will be installed in the following directories: + +/usr/local/bin - command-line executables +/usr/local/lib/ocaml - library and support files +/usr/local/man - manual pages +EOF + +chmod -R g-w root +sudo chown -R root:wheel root + +/Developer/Applications/Utilities/PackageMaker.app/Contents/MacOS/PackageMaker \ + -build -p "`pwd`/ocaml.pkg" -f "`pwd`/root" -i "`pwd`/Info.plist" \ + -d "`pwd`/Description.plist" -r "`pwd`/resources" + +size=`du -s ocaml.pkg | cut -f 1` +size=`expr $size + 8192` + +hdiutil create -sectors $size ocaml-rw.dmg +name=`hdid -nomount ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1` +volname="Objective Caml ${VERSION}" +newfs_hfs -v "$volname" $name +hdiutil detach $name + +name=`hdid ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1` +if test -d "/Volumes/$volname"; then + ditto -rsrcFork ocaml.pkg "/Volumes/$volname/ocaml.pkg" + cp resources/ReadMe.txt "/Volumes/$volname/" +else + echo "Unable to mount the disk image as \"/Volumes/$volname\"" >&2 + exit 3 +fi +open "/Volumes/$volname" +sleep 2 +hdiutil detach $name + +rm -rf "ocaml-${VERSION}.dmg" +hdiutil convert ocaml-rw.dmg -format UDZO -o "ocaml-${VERSION}.dmg" diff --git a/ocaml-binary-annot/tools/objinfo.ml b/ocaml-binary-annot/tools/objinfo.ml new file mode 100644 index 0000000000..e9eb403135 --- /dev/null +++ b/ocaml-binary-annot/tools/objinfo.ml @@ -0,0 +1,269 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mehdi Dogguy, PPS laboratory, University Paris Diderot *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. Modifications Copyright 2010 Mehdi Dogguy, *) +(* used and distributed as part of Objective Caml by permission from *) +(* the author. This file is distributed under the terms of the *) +(* Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Dump info on .cmi, .cmo, .cmx, .cma, .cmxa, .cmxs files + and on bytecode executables. *) + +open Printf +open Misc +open Config +open Cmo_format +open Clambda + +let input_stringlist ic len = + let get_string_list sect len = + let rec fold s e acc = + if e != len then + if sect.[e] = '\000' then + fold (e+1) (e+1) (String.sub sect s (e-s) :: acc) + else fold s (e+1) acc + else acc + in fold 0 0 [] + in + let sect = String.create len in + let _ = really_input ic sect 0 len in + get_string_list sect len + +let print_name_crc (name, crc) = + printf "\t%s\t%s\n" (Digest.to_hex crc) name + +let print_line name = + printf "\t%s\n" name + +let print_cmo_infos cu = + printf "Unit name: %s\n" cu.cu_name; + print_string "Interfaces imported:\n"; + List.iter print_name_crc cu.cu_imports; + printf "Uses unsafe features: "; + match cu.cu_primitives with + | [] -> printf "no\n" + | l -> + printf "YES\n"; + printf "Primitives declared in this module:\n"; + List.iter print_line l + +let rec print_approx_infos ppf = function + Value_closure(fundesc, approx) -> + Format.fprintf ppf "@[<2>function %s@ arity %i" + fundesc.fun_label fundesc.fun_arity; + if fundesc.fun_closed then begin + Format.fprintf ppf "@ (closed)" + end; + if fundesc.fun_inline <> None then begin + Format.fprintf ppf "@ (inline)" + end; + Format.fprintf ppf "@ -> @ %a@]" print_approx_infos approx + | Value_tuple approx -> + let tuple ppf approx = + for i = 0 to Array.length approx - 1 do + if i > 0 then Format.fprintf ppf ";@ "; + Format.fprintf ppf "%i: %a" i print_approx_infos approx.(i) + done in + Format.fprintf ppf "@[<hov 1>(%a)@]" tuple approx + | Value_unknown -> + Format.fprintf ppf "_" + | Value_integer n -> + Format.fprintf ppf "%d" n + | Value_constptr n -> + Format.fprintf ppf "%dp" n + +let print_spaced_string s = + printf " %s" s + +let print_cma_infos (lib : Cmo_format.library) = + printf "Force custom: %s\n" (if lib.lib_custom then "YES" else "no"); + printf "Extra C object files:"; + (* PR#4949: print in linking order *) + List.iter print_spaced_string (List.rev lib.lib_ccobjs); + printf "\nExtra C options:"; + List.iter print_spaced_string lib.lib_ccopts; + printf "\n"; + print_string "Extra dynamically-loaded libraries:"; + List.iter print_spaced_string lib.lib_dllibs; + printf "\n"; + List.iter print_cmo_infos lib.lib_units + +let print_cmi_infos name sign comps crcs = + printf "Unit name: %s\n" name; + printf "Interfaces imported:\n"; + List.iter print_name_crc crcs + +let print_general_infos name crc defines cmi cmx = + printf "Name: %s\n" name; + printf "CRC of implementation: %s\n" (Digest.to_hex crc); + printf "Globals defined:\n"; + List.iter print_line defines; + printf "Interfaces imported:\n"; + List.iter print_name_crc cmi; + printf "Implementations imported:\n"; + List.iter print_name_crc cmx + +open Cmx_format + +let print_cmx_infos (ui, crc) = + print_general_infos + ui.ui_name crc ui.ui_defines ui.ui_imports_cmi ui.ui_imports_cmx; + printf "Approximation:\n"; + Format.fprintf Format.std_formatter " %a@." print_approx_infos ui.ui_approx; + let pr_funs _ fns = + List.iter (fun arity -> printf " %d" arity) fns in + printf "Currying functions:%a\n" pr_funs ui.ui_curry_fun; + printf "Apply functions:%a\n" pr_funs ui.ui_apply_fun + +let print_cmxs_infos header = + List.iter + (fun ui -> + print_general_infos + ui.dynu_name + ui.dynu_crc + ui.dynu_defines + ui.dynu_imports_cmi + ui.dynu_imports_cmx) + header.dynu_units + +let p_title title = printf "%s:\n" title + +let p_section title = function + | [] -> () + | l -> + p_title title; + List.iter print_name_crc l + +let p_list title print = function + | [] -> () + | l -> + p_title title; + List.iter print l + +let dump_byte ic = + Bytesections.read_toc ic; + let toc = Bytesections.toc () in + let toc = List.sort Pervasives.compare toc in + List.iter + (fun (section, _) -> + try + let len = Bytesections.seek_section ic section in + if len > 0 then match section with + | "CRCS" -> + p_section + "Imported units" + (input_value ic : (string * Digest.t) list) + | "DLLS" -> + p_list + "Used DLLs" + print_line + (input_stringlist ic len) + | "DLPT" -> + p_list + "Additional DLL paths" + print_line + (input_stringlist ic len) + | "PRIM" -> + p_list + "Primitives used" + print_line + (input_stringlist ic len) + | _ -> () + with _ -> () + ) + toc + +let read_dyn_header filename ic = + let tempfile = Filename.temp_file "objinfo" ".out" in + let helper = Filename.concat Config.standard_library "objinfo_helper" in + try + try_finally + (fun () -> + let rc = Sys.command (sprintf "%s %s > %s" + (Filename.quote helper) + (Filename.quote filename) + tempfile) in + if rc <> 0 then failwith "cannot read"; + let tc = open_in tempfile in + try_finally + (fun () -> + let ofs = Scanf.fscanf tc "%Ld" (fun x -> x) in + LargeFile.seek_in ic ofs; + Some(input_value ic : dynheader)) + (fun () -> close_in tc)) + (fun () -> remove_file tempfile) + with Failure _ | Sys_error _ -> None + +let dump_obj filename = + printf "File %s\n" filename; + let ic = open_in_bin filename in + let len_magic_number = String.length cmo_magic_number in + let magic_number = String.create len_magic_number in + really_input ic magic_number 0 len_magic_number; + if magic_number = cmo_magic_number then begin + let cu_pos = input_binary_int ic in + seek_in ic cu_pos; + let cu = (input_value ic : compilation_unit) in + close_in ic; + print_cmo_infos cu + end else if magic_number = cma_magic_number then begin + let toc_pos = input_binary_int ic in + seek_in ic toc_pos; + let toc = (input_value ic : library) in + close_in ic; + print_cma_infos toc + end else if magic_number = cmi_magic_number then begin + let (name, sign, comps) = input_value ic in + let crcs = input_value ic in + close_in ic; + print_cmi_infos name sign comps crcs + end else if magic_number = cmx_magic_number then begin + let ui = (input_value ic : unit_infos) in + let crc = Digest.input ic in + close_in ic; + print_cmx_infos (ui, crc) + end else if magic_number = cmxa_magic_number then begin + let li = (input_value ic : library_infos) in + close_in ic; + List.iter print_cmx_infos li.lib_units + end else begin + let pos_trailer = in_channel_length ic - len_magic_number in + let _ = seek_in ic pos_trailer in + let _ = really_input ic magic_number 0 len_magic_number in + if magic_number = Config.exec_magic_number then begin + dump_byte ic; + close_in ic + end else if Filename.check_suffix filename ".cmxs" then begin + flush stdout; + match read_dyn_header filename ic with + | None -> + printf "Unable to read info on file %s\n" filename; + exit 2 + | Some header -> + if header.dynu_magic = Config.cmxs_magic_number then + print_cmxs_infos header + else begin + printf "Wrong magic number\n"; exit 2 + end; + close_in ic + end else begin + printf "Not an OCaml object file\n"; exit 2 + end + end + +let main() = + for i = 1 to Array.length Sys.argv - 1 do + dump_obj Sys.argv.(i) + done; + exit 0 + +let _ = main () diff --git a/ocaml-binary-annot/tools/objinfo_helper.c b/ocaml-binary-annot/tools/objinfo_helper.c new file mode 100644 index 0000000000..464720c296 --- /dev/null +++ b/ocaml-binary-annot/tools/objinfo_helper.c @@ -0,0 +1,92 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Mehdi Dogguy, PPS laboratory, University Paris Diderot */ +/* */ +/* Copyright 2010 Mehdi Dogguy. Used and distributed as part of */ +/* Objective Caml by permission from the author. This file is */ +/* distributed under the terms of the Q Public License version 1.0. */ +/***********************************************************************/ + +#include "../config/s.h" +#include "../byterun/mlvalues.h" +#include "../byterun/alloc.h" +#include <stdio.h> + +#ifdef HAS_LIBBFD +#include <stdlib.h> +#include <string.h> +#include <bfd.h> + +int main(int argc, char ** argv) +{ + bfd *fd; + asection *sec; + file_ptr offset; + long st_size; + asymbol ** symbol_table; + long sym_count, i; + + if (argc != 2) { + fprintf(stderr, "Usage: objinfo_helper <dynamic library>\n"); + return 2; + } + + fd = bfd_openr(argv[1], "default"); + if (!fd) { + fprintf(stderr, "Error opening file %s\n", argv[1]); + return 2; + } + if (! bfd_check_format (fd, bfd_object)) { + fprintf(stderr, "Error: wrong format\n"); + bfd_close(fd); + return 2; + } + + sec = bfd_get_section_by_name(fd, ".data"); + if (! sec) { + fprintf(stderr, "Error: section .data not found\n"); + bfd_close(fd); + return 2; + } + + offset = sec->filepos; + st_size = bfd_get_dynamic_symtab_upper_bound (fd); + if (st_size <= 0) { + fprintf(stderr, "Error: size of section .data unknown\n"); + bfd_close(fd); + return 2; + } + + symbol_table = malloc(st_size); + if (! symbol_table) { + fprintf(stderr, "Error: out of memory\n"); + bfd_close(fd); + return 2; + } + + sym_count = bfd_canonicalize_dynamic_symtab (fd, symbol_table); + + for (i = 0; i < sym_count; i++) { + if (strcmp(symbol_table[i]->name, "caml_plugin_header") == 0) { + printf("%ld\n", (long) (offset + symbol_table[i]->value)); + bfd_close(fd); + return 0; + } + } + + fprintf(stderr, "Error: missing symbol caml_plugin_header\n"); + bfd_close(fd); + return 2; +} + +#else + +int main(int argc, char ** argv) +{ + fprintf(stderr, "BFD library unavailable, cannot print info on .cmxs files\n"); + return 2; +} + +#endif diff --git a/ocaml-binary-annot/tools/ocaml-objcopy-macosx b/ocaml-binary-annot/tools/ocaml-objcopy-macosx new file mode 100755 index 0000000000..cb2f703b4d --- /dev/null +++ b/ocaml-binary-annot/tools/ocaml-objcopy-macosx @@ -0,0 +1,54 @@ +#!/bin/bash + +######################################################################### +# # +# Objective Caml # +# # +# Damien Doligez, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 2005 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id$ + + +TMP="${TMPDIR=/tmp}" +TEMP="${TMP}"/ocaml-objcopy-$$.o +UNDEF="${TMP}"/ocaml-objcopy-$$.sym + +usage () { + echo "usage: objcopy {--redefine-sym <old>=<new>} file.o" >&2 + exit 2 +} + +: > "$UNDEF" + +while : ; do + case $# in + 0) break;; + *) case $1 in + --redefine-sym) + case $2 in + *=*) ALIAS="$ALIAS -i${2#*=}:${2%%=*}" + echo ${2%%=*} >>"$UNDEF" + ;; + *) usage;; + esac + shift 2 + ;; + -*) usage;; + *) case $FILE in + "") FILE=$1; shift;; + *) usage;; + esac;; + esac;; + esac +done + +ld -o "$TEMP" -r $ALIAS "$FILE" +ld -o "$FILE" -r -unexported_symbols_list "$UNDEF" "$TEMP" + +rm -f "$TEMP" "$UNDEF" diff --git a/ocaml-binary-annot/tools/ocaml299to3.ml b/ocaml-binary-annot/tools/ocaml299to3.ml new file mode 100644 index 0000000000..b1dca8daaf --- /dev/null +++ b/ocaml-binary-annot/tools/ocaml299to3.ml @@ -0,0 +1,139 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Lexer299 + +let input_buffer = Buffer.create 16383 +let input_function ic buf len = + let len = input ic buf 0 len in + Buffer.add_substring input_buffer buf 0 len; + len + +let output_buffer = Buffer.create 16383 + +let modified = ref false + +let convert buffer = + let input_pos = ref 0 in + let copy_input stop = + Buffer.add_substring output_buffer (Buffer.contents input_buffer) + !input_pos (stop - !input_pos); + input_pos := stop + in + let last = ref (EOF, 0, 0) in + try while true do + let token = Lexer299.token buffer + and start = Lexing.lexeme_start buffer + and stop = Lexing.lexeme_end buffer + and last_token, last_start, last_stop = !last in + begin match token with + | LABEL l0 -> + let l = if l0 = "fun" then "f" else l0 in + begin match last_token with + | PREFIXOP "?(" -> + modified := true; + copy_input last_start; + Buffer.add_char output_buffer '?'; + Buffer.add_string output_buffer l; + Buffer.add_string output_buffer ":("; + input_pos := stop + | QUESTION | LPAREN | LBRACE | SEMI | MINUSGREATER + | EQUAL | COLON | COLONGREATER + | VAL | MUTABLE | EXTERNAL | METHOD | OF -> + if l0 = "fun" then begin + modified := true; + copy_input start; + Buffer.add_string output_buffer l; + Buffer.add_char output_buffer ':'; + input_pos := stop + end + | _ -> + modified := true; + copy_input start; + Buffer.add_char output_buffer '~'; + Buffer.add_string output_buffer l; + Buffer.add_char output_buffer ':'; + input_pos := stop + end + | LABELID l -> + modified := true; + begin match last_token with + | PREFIXOP "?(" -> + copy_input last_start; + Buffer.add_string output_buffer "?("; + Buffer.add_string output_buffer l; + input_pos := stop + | LPAREN -> + copy_input last_start; + Buffer.add_string output_buffer "~("; + Buffer.add_string output_buffer l; + input_pos := stop + | QUESTION -> + copy_input last_stop; + Buffer.add_string output_buffer l; + input_pos := stop + | _ -> + copy_input start; + Buffer.add_char output_buffer '~'; + Buffer.add_string output_buffer l; + input_pos := stop + end + | EOF -> raise End_of_file + | _ -> () + end; + if last_token = QUESTION && token = LPAREN then + last := (PREFIXOP "?(", last_start, stop) + else + last := (token, start, stop) + done with + End_of_file -> + copy_input (Buffer.length input_buffer) + +let convert_file name = + let ic = open_in name in + Buffer.clear input_buffer; + Buffer.clear output_buffer; + modified := false; + begin + try convert (Lexing.from_function (input_function ic)); close_in ic + with exn -> close_in ic; raise exn + end; + if !modified then begin + let backup = name ^ ".bak" in + if Sys.file_exists backup then Sys.remove name + else Sys.rename name backup; + let oc = open_out name in + Buffer.output_buffer oc output_buffer; + close_out oc + end + +let _ = + if Array.length Sys.argv < 2 || Sys.argv.(1) = "-h" || Sys.argv.(1) = "-help" + then begin + print_endline "Usage: ocaml299to3 <source file> ..."; + print_endline "Description:"; + print_endline + "Convert Objective Caml 2.99 O'Labl-style labels in implementation files to"; + print_endline + "a syntax compatible with version 3. Also `fun:' labels are replaced by `f:'."; + print_endline "Other syntactic changes are not handled."; + print_endline "Old files are renamed to <file>.bak."; + print_endline "Interface files do not need label syntax conversion."; + exit 0 + end; + for i = 1 to Array.length Sys.argv - 1 do + let name = Sys.argv.(i) in + prerr_endline ("Converting " ^ name); + Printexc.catch convert_file name + done diff --git a/ocaml-binary-annot/tools/ocamlcp.ml b/ocaml-binary-annot/tools/ocamlcp.ml new file mode 100644 index 0000000000..a86ae352fc --- /dev/null +++ b/ocaml-binary-annot/tools/ocamlcp.ml @@ -0,0 +1,137 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Printf + +let compargs = ref ([] : string list) +let profargs = ref ([] : string list) +let toremove = ref ([] : string list) + +let option opt () = compargs := opt :: !compargs +let option_with_arg opt arg = + compargs := (Filename.quote arg) :: opt :: !compargs +;; + +let make_archive = ref false;; +let with_impl = ref false;; +let with_intf = ref false;; +let with_mli = ref false;; +let with_ml = ref false;; + +let process_file filename = + if Filename.check_suffix filename ".ml" then with_ml := true; + if Filename.check_suffix filename ".mli" then with_mli := true; + compargs := (Filename.quote filename) :: !compargs +;; + +let usage = "Usage: ocamlcp <options> <files>\noptions are:" + +let incompatible o = + fprintf stderr "ocamlcp: profiling is incompatible with the %s option\n" o; + exit 2 + +module Options = Main_args.Make_bytecomp_options (struct + let _a () = make_archive := true; option "-a" () + let _annot = option "-annot" + let _c = option "-c" + let _cc s = option_with_arg "-cc" s + let _cclib s = option_with_arg "-cclib" s + let _ccopt s = option_with_arg "-ccopt" s + let _config = option "-config" + let _custom = option "-custom" + let _dllib = option_with_arg "-dllib" + let _dllpath = option_with_arg "-dllpath" + let _dtypes = option "-dtypes" + let _g = option "-g" + let _i = option "-i" + let _I s = option_with_arg "-I" s + let _impl s = with_impl := true; option_with_arg "-impl" s + let _intf s = with_intf := true; option_with_arg "-intf" s + let _intf_suffix s = option_with_arg "-intf-suffix" s + let _labels = option "-labels" + let _linkall = option "-linkall" + let _make_runtime = option "-make-runtime" + let _no_app_funct = option "-no-app-funct" + let _noassert = option "-noassert" + let _nolabels = option "-nolabels" + let _noautolink = option "-noautolink" + let _nostdlib = option "-nostdlib" + let _o s = option_with_arg "-o" s + let _output_obj = option "-output-obj" + let _pack = option "-pack" + let _pp s = incompatible "-pp" + let _principal = option "-principal" + let _rectypes = option "-rectypes" + let _strict_sequence = option "-strict-sequence" + let _thread () = option "-thread" () + let _vmthread () = option "-vmthread" () + let _unsafe = option "-unsafe" + let _use_prims s = option_with_arg "-use-prims" s + let _use_runtime s = option_with_arg "-use-runtime" s + let _v = option "-v" + let _version = option "-version" + let _vnum = option "-vnum" + let _verbose = option "-verbose" + let _w = option_with_arg "-w" + let _warn_error = option_with_arg "-warn-error" + let _warn_help = option "-warn-help" + let _where = option "-where" + let _nopervasives = option "-nopervasives" + let _dparsetree = option "-dparsetree" + let _drawlambda = option "-drawlambda" + let _dlambda = option "-dlambda" + let _dinstr = option "-dinstr" + let anonymous = process_file +end);; + +let add_profarg s = + profargs := (Filename.quote s) :: "-m" :: !profargs +;; + +let optlist = + ("-p", Arg.String add_profarg, + "[afilmt] Profile constructs specified by argument (default fm):\n\ + \032 a Everything\n\ + \032 f Function calls and method calls\n\ + \032 i if ... then ... else\n\ + \032 l while and for loops\n\ + \032 m match ... with\n\ + \032 t try ... with") + :: Options.list +in +Arg.parse optlist process_file usage; +if !with_impl && !with_intf then begin + fprintf stderr "ocamlcp cannot deal with both \"-impl\" and \"-intf\"\n"; + fprintf stderr "please compile interfaces and implementations separately\n"; + exit 2; +end else if !with_impl && !with_mli then begin + fprintf stderr "ocamlcp cannot deal with both \"-impl\" and .mli files\n"; + fprintf stderr "please compile interfaces and implementations separately\n"; + exit 2; +end else if !with_intf && !with_ml then begin + fprintf stderr "ocamlcp cannot deal with both \"-intf\" and .ml files\n"; + fprintf stderr "please compile interfaces and implementations separately\n"; + exit 2; +end; +if !with_impl then profargs := "-impl" :: !profargs; +if !with_intf then profargs := "-intf" :: !profargs; +let status = + Sys.command + (Printf.sprintf "ocamlc -pp \"ocamlprof -instrument %s\" %s %s" + (String.concat " " (List.rev !profargs)) + (if !make_archive then "" else "profiling.cmo") + (String.concat " " (List.rev !compargs))) +in +exit status +;; diff --git a/ocaml-binary-annot/tools/ocamldep.ml b/ocaml-binary-annot/tools/ocamldep.ml new file mode 100644 index 0000000000..72e03e91f9 --- /dev/null +++ b/ocaml-binary-annot/tools/ocamldep.ml @@ -0,0 +1,310 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Format +open Location +open Longident +open Parsetree + + +(* Print the dependencies *) + +let load_path = ref ([] : (string * string array) list) +let native_only = ref false +let force_slash = ref false +let error_occurred = ref false +let raw_dependencies = ref false + +(* Fix path to use '/' as directory separator instead of '\'. + Only under Windows. *) + +let fix_slash s = + if Sys.os_type = "Unix" then s else begin + let r = String.copy s in + for i = 0 to String.length r - 1 do + if r.[i] = '\\' then r.[i] <- '/' + done; + r + end + +let add_to_load_path dir = + try + let dir = Misc.expand_directory Config.standard_library dir in + let contents = Sys.readdir dir in + load_path := !load_path @ [dir, contents] + with Sys_error msg -> + fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; + error_occurred := true + +let find_file name = + let uname = String.uncapitalize name in + let rec find_in_array a pos = + if pos >= Array.length a then None else begin + let s = a.(pos) in + if s = name || s = uname then Some s else find_in_array a (pos + 1) + end in + let rec find_in_path = function + [] -> raise Not_found + | (dir, contents) :: rem -> + match find_in_array contents 0 with + Some truename -> + if dir = "." then truename else Filename.concat dir truename + | None -> find_in_path rem in + find_in_path !load_path + +let find_dependency modname (byt_deps, opt_deps) = + try + let filename = find_file (modname ^ ".mli") in + let basename = Filename.chop_suffix filename ".mli" in + let optname = + if Sys.file_exists (basename ^ ".ml") + then basename ^ ".cmx" + else basename ^ ".cmi" in + ((basename ^ ".cmi") :: byt_deps, optname :: opt_deps) + with Not_found -> + try + let filename = find_file (modname ^ ".ml") in + let basename = Filename.chop_suffix filename ".ml" in + let bytename = + basename ^ (if !native_only then ".cmx" else ".cmo") in + (bytename :: byt_deps, (basename ^ ".cmx") :: opt_deps) + with Not_found -> + (byt_deps, opt_deps) + +let (depends_on, escaped_eol) = (":", " \\\n ") + +let print_filename s = + let s = if !force_slash then fix_slash s else s in + if not (String.contains s ' ') then begin + print_string s; + end else begin + let rec count n i = + if i >= String.length s then n + else if s.[i] = ' ' then count (n+1) (i+1) + else count n (i+1) + in + let spaces = count 0 0 in + let result = String.create (String.length s + spaces) in + let rec loop i j = + if i >= String.length s then () + else if s.[i] = ' ' then begin + result.[j] <- '\\'; + result.[j+1] <- ' '; + loop (i+1) (j+2); + end else begin + result.[j] <- s.[i]; + loop (i+1) (j+1); + end + in + loop 0 0; + print_string result; + end +;; + +let print_dependencies target_file deps = + print_filename target_file; print_string depends_on; + let rec print_items pos = function + [] -> print_string "\n" + | dep :: rem -> + if pos + 1 + String.length dep <= 77 then begin + print_string " "; print_filename dep; + print_items (pos + String.length dep + 1) rem + end else begin + print_string escaped_eol; print_filename dep; + print_items (String.length dep + 4) rem + end in + print_items (String.length target_file + 1) deps + +let print_raw_dependencies source_file deps = + print_filename source_file; print_string ":"; + Depend.StringSet.iter + (fun dep -> print_char ' '; print_string dep) + deps; + print_char '\n' + +(* Optionally preprocess a source file *) + +let preprocessor = ref None + +exception Preprocessing_error + +let preprocess sourcefile = + match !preprocessor with + None -> sourcefile + | Some pp -> + flush Pervasives.stdout; + let tmpfile = Filename.temp_file "camlpp" "" in + let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in + if Sys.command comm <> 0 then begin + Misc.remove_file tmpfile; + raise Preprocessing_error + end; + tmpfile + +let remove_preprocessed inputfile = + match !preprocessor with + None -> () + | Some _ -> Misc.remove_file inputfile + +(* Parse a file or get a dumped syntax tree in it *) + +let is_ast_file ic ast_magic = + try + let buffer = String.create (String.length ast_magic) in + really_input ic buffer 0 (String.length ast_magic); + if buffer = ast_magic then true + else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then + failwith "Ocaml and preprocessor have incompatible versions" + else false + with End_of_file -> false + +let parse_use_file ic = + if is_ast_file ic Config.ast_impl_magic_number then + let _source_file = input_value ic in + [Ptop_def (input_value ic : Parsetree.structure)] + else begin + seek_in ic 0; + let lb = Lexing.from_channel ic in + Parse.use_file lb + end + +let parse_interface ic = + if is_ast_file ic Config.ast_intf_magic_number then + let _source_file = input_value ic in + (input_value ic : Parsetree.signature) + else begin + seek_in ic 0; + let lb = Lexing.from_channel ic in + Parse.interface lb + end + +(* Process one file *) + +let ml_file_dependencies source_file = + Depend.free_structure_names := Depend.StringSet.empty; + let input_file = preprocess source_file in + let ic = open_in_bin input_file in + try + let ast = parse_use_file ic in + Depend.add_use_file Depend.StringSet.empty ast; + if !raw_dependencies then begin + print_raw_dependencies source_file !Depend.free_structure_names + end else begin + let basename = Filename.chop_extension source_file in + let init_deps = + if Sys.file_exists (basename ^ ".mli") + then let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name]) + else ([], []) in + let (byt_deps, opt_deps) = + Depend.StringSet.fold find_dependency + !Depend.free_structure_names init_deps in + print_dependencies (basename ^ ".cmo") byt_deps; + print_dependencies (basename ^ ".cmx") opt_deps + end; + close_in ic; remove_preprocessed input_file + with x -> + close_in ic; remove_preprocessed input_file; raise x + +let mli_file_dependencies source_file = + Depend.free_structure_names := Depend.StringSet.empty; + let input_file = preprocess source_file in + let ic = open_in_bin input_file in + try + let ast = parse_interface ic in + Depend.add_signature Depend.StringSet.empty ast; + if !raw_dependencies then begin + print_raw_dependencies source_file !Depend.free_structure_names + end else begin + let basename = Filename.chop_extension source_file in + let (byt_deps, opt_deps) = + Depend.StringSet.fold find_dependency + !Depend.free_structure_names ([], []) in + print_dependencies (basename ^ ".cmi") byt_deps + end; + close_in ic; remove_preprocessed input_file + with x -> + close_in ic; remove_preprocessed input_file; raise x + +type file_kind = ML | MLI;; + +let file_dependencies_as kind source_file = + Location.input_name := source_file; + try + if Sys.file_exists source_file then begin + match kind with + | ML -> ml_file_dependencies source_file + | MLI -> mli_file_dependencies source_file + end + with x -> + let report_err = function + | Lexer.Error(err, range) -> + fprintf Format.err_formatter "@[%a%a@]@." + Location.print_error range Lexer.report_error err + | Syntaxerr.Error err -> + fprintf Format.err_formatter "@[%a@]@." + Syntaxerr.report_error err + | Sys_error msg -> + fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg + | Preprocessing_error -> + fprintf Format.err_formatter "@[Preprocessing error on file %s@]@." + source_file + | x -> raise x in + error_occurred := true; + report_err x + +let file_dependencies source_file = + if Filename.check_suffix source_file ".ml" then + file_dependencies_as ML source_file + else if Filename.check_suffix source_file ".mli" then + file_dependencies_as MLI source_file + else () + +(* Entry point *) + +let usage = "Usage: ocamldep [options] <source files>\nOptions are:" + +let print_version () = + printf "ocamldep, version %s@." Sys.ocaml_version; + exit 0; +;; + +let print_version_num () = + printf "%s@." Sys.ocaml_version; + exit 0; +;; + +let _ = + Clflags.classic := false; + add_to_load_path Filename.current_dir_name; + Arg.parse [ + "-I", Arg.String add_to_load_path, + "<dir> Add <dir> to the list of include directories"; + "-impl", Arg.String (file_dependencies_as ML), + "<f> Process <f> as a .ml file"; + "-intf", Arg.String (file_dependencies_as MLI), + "<f> Process <f> as a .mli file"; + "-modules", Arg.Set raw_dependencies, + " Print module dependencies in raw form (not suitable for make)"; + "-native", Arg.Set native_only, + " Generate dependencies for a pure native-code project (no .cmo files)"; + "-pp", Arg.String(fun s -> preprocessor := Some s), + "<cmd> Pipe sources through preprocessor <cmd>"; + "-slash", Arg.Set force_slash, + " (Windows) Use forward slash / instead of backslash \\ in file paths"; + "-version", Arg.Unit print_version, + " Print version and exit"; + "-vnum", Arg.Unit print_version_num, + " Print version number and exit"; + ] file_dependencies usage; + exit (if !error_occurred then 2 else 0) diff --git a/ocaml-binary-annot/tools/ocamlmklib.mlp b/ocaml-binary-annot/tools/ocamlmklib.mlp new file mode 100644 index 0000000000..737749c17f --- /dev/null +++ b/ocaml-binary-annot/tools/ocamlmklib.mlp @@ -0,0 +1,281 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Printf +open Myocamlbuild_config + +(* PR#4783: under Windows, don't use absolute paths because we do + not know where the binary distribution will be installed. *) +let compiler_path name = + if Sys.os_type = "Win32" then name else Filename.concat bindir name + +let bytecode_objs = ref [] (* .cmo,.cma,.ml,.mli files to pass to ocamlc *) +and native_objs = ref [] (* .cmx,.cmxa,.ml,.mli files to pass to ocamlopt *) +and c_objs = ref [] (* .o, .a, .obj, .lib, .dll files to pass to mksharedlib and ar *) +and caml_libs = ref [] (* -cclib to pass to ocamlc, ocamlopt *) +and caml_opts = ref [] (* -ccopt to pass to ocamlc, ocamlopt *) +and dynlink = ref supports_shared_libraries +and failsafe = ref false (* whether to fall back on static build only *) +and c_libs = ref [] (* libs to pass to mksharedlib and ocamlc -cclib *) +and c_opts = ref [] (* options to pass to mksharedlib and ocamlc -ccopt *) +and ld_opts = ref [] (* options to pass only to the linker *) +and ocamlc = ref (compiler_path "ocamlc") +and ocamlopt = ref (compiler_path "ocamlopt") +and output = ref "a" (* Output name for Caml part of library *) +and output_c = ref "" (* Output name for C part of library *) +and rpath = ref [] (* rpath options *) +and verbose = ref false + +let starts_with s pref = + String.length s >= String.length pref && + String.sub s 0 (String.length pref) = pref +let ends_with = Filename.check_suffix +let chop_prefix s pref = + String.sub s (String.length pref) (String.length s - String.length pref) +let chop_suffix = Filename.chop_suffix + +exception Bad_argument of string + +let print_version () = + printf "ocamlmklib, version %s\n" Sys.ocaml_version; + exit 0; +;; + +let print_version_num () = + printf "%s\n" Sys.ocaml_version; + exit 0; +;; + +let parse_arguments argv = + let i = ref 1 in + let next_arg () = + if !i + 1 >= Array.length argv + then raise (Bad_argument("Option " ^ argv.(!i) ^ " expects one argument")); + incr i; argv.(!i) in + while !i < Array.length argv do + let s = argv.(!i) in + if ends_with s ".cmo" || ends_with s ".cma" then + bytecode_objs := s :: !bytecode_objs + else if ends_with s ".cmx" || ends_with s ".cmxa" then + native_objs := s :: !native_objs + else if ends_with s ".ml" || ends_with s ".mli" then + (bytecode_objs := s :: !bytecode_objs; + native_objs := s :: !native_objs) + else if List.exists (ends_with s) [".o"; ".a"; ".obj"; ".lib"; ".dll"] then + c_objs := s :: !c_objs + else if s = "-cclib" then + caml_libs := next_arg () :: "-cclib" :: !caml_libs + else if s = "-ccopt" then + caml_opts := next_arg () :: "-ccopt" :: !caml_opts + else if s = "-custom" then + dynlink := false + else if s = "-I" then + caml_opts := next_arg () :: "-I" :: !caml_opts + else if s = "-failsafe" then + failsafe := true + else if s = "-h" || s = "-help" || s = "--help" then + raise (Bad_argument "") + else if s = "-ldopt" then + ld_opts := next_arg () :: !ld_opts + else if s = "-linkall" then + caml_opts := s :: !caml_opts + else if starts_with s "-l" then + c_libs := s :: !c_libs + else if starts_with s "-L" then + (c_opts := s :: !c_opts; + let l = chop_prefix s "-L" in + if not (Filename.is_relative l) then rpath := l :: !rpath) + else if s = "-ocamlc" then + ocamlc := next_arg () + else if s = "-ocamlopt" then + ocamlopt := next_arg () + else if s = "-o" then + output := next_arg() + else if s = "-oc" then + output_c := next_arg() + else if s = "-dllpath" || s = "-R" || s = "-rpath" then + rpath := next_arg() :: !rpath + else if starts_with s "-R" then + rpath := chop_prefix s "-R" :: !rpath + else if s = "-Wl,-rpath" then + (let a = next_arg() in + if starts_with a "-Wl," + then rpath := chop_prefix a "-Wl," :: !rpath + else raise (Bad_argument("Option -Wl,-rpath expects a -Wl, argument"))) + else if starts_with s "-Wl,-rpath," then + rpath := chop_prefix s "-Wl,-rpath," :: !rpath + else if starts_with s "-Wl,-R" then + rpath := chop_prefix s "-Wl,-R" :: !rpath + else if s = "-v" || s = "-verbose" then + verbose := true + else if s = "-version" then + print_version () + else if s = "-vnum" then + print_version_num () + else if starts_with s "-F" then + c_opts := s :: !c_opts + else if s = "-framework" then + (let a = next_arg() in c_opts := a :: s :: !c_opts) + else if starts_with s "-" then + prerr_endline ("Unknown option " ^ s) + else + raise (Bad_argument("Don't know what to do with " ^ s)); + incr i + done; + List.iter + (fun r -> r := List.rev !r) + [ bytecode_objs; native_objs; caml_libs; caml_opts; + c_libs; c_objs; c_opts; ld_opts; rpath ]; + + if !output_c = "" then output_c := !output + +let usage = "\ +Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll files>\n\ +Options are:\n\ + -cclib <lib> C library passed to ocamlc -a or ocamlopt -a only\n\ + -ccopt <opt> C option passed to ocamlc -a or ocamlopt -a only\n\ + -custom disable dynamic loading\n\ + -dllpath <dir> Add <dir> to the run-time search path for DLLs\n\ + -F<dir> Specify a framework directory (MacOSX)\n\ + -framework <name> Use framework <name> (MacOSX)\n\ + -help Print this help message and exit\n\ + --help Same as -help\n\ + -h Same as -help\n\ + -I <dir> Add <dir> to the path searched for Caml object files\n\ + -failsafe fall back to static linking if DLL construction failed\n\ + -ldopt <opt> C option passed to the shared linker only\n\ + -linkall Build Caml archive with link-all behavior\n\ + -l<lib> Specify a dependent C library\n\ + -L<dir> Add <dir> to the path searched for C libraries\n\ + -ocamlc <cmd> Use <cmd> in place of \"ocamlc\"\n\ + -ocamlopt <cmd> Use <cmd> in place of \"ocamlopt\"\n\ + -o <name> Generated Caml library is named <name>.cma or <name>.cmxa\n\ + -oc <name> Generated C library is named dll<name>.so or lib<name>.a\n\ + -rpath <dir> Same as -dllpath <dir>\n\ + -R<dir> Same as -rpath\n\ + -verbose Print commands before executing them\n\ + -v same as -verbose\n\ + -version Print version and exit\n\ + -vnum Print version number and exit\n\ + -Wl,-rpath,<dir> Same as -dllpath <dir>\n\ + -Wl,-rpath -Wl,<dir> Same as -dllpath <dir>\n\ + -Wl,-R<dir> Same as -dllpath <dir>\n\ +" + +let command cmd = + if !verbose then (print_string "+ "; print_string cmd; print_newline()); + Sys.command cmd + +let scommand cmd = + if command cmd <> 0 then exit 2 + +let safe_remove s = + try Sys.remove s with Sys_error _ -> () + +let make_set l = + let rec merge l = function + [] -> List.rev l + | p :: r -> if List.mem p l then merge l r else merge (p::l) r + in + merge [] l + +let make_rpath flag = + if !rpath = [] || flag = "" + then "" + else flag ^ String.concat ":" (make_set !rpath) + +let make_rpath_ccopt flag = + if !rpath = [] || flag = "" + then "" + else "-ccopt " ^ flag ^ String.concat ":" (make_set !rpath) + +let prefix_list pref l = + List.map (fun s -> pref ^ s) l + +let prepostfix pre name post = + let base = Filename.basename name in + let dir = Filename.dirname name in + Filename.concat dir (pre ^ base ^ post) +;; + +let transl_path s = + match Sys.os_type with + | "Win32" -> + let rec aux i = + if i = String.length s || s.[i] = ' ' then s + else (if s.[i] = '/' then s.[i] <- '\\'; aux (i + 1)) + in aux 0 + | _ -> s + +let build_libs () = + if !c_objs <> [] then begin + if !dynlink then begin + let retcode = command + (Printf.sprintf "%s -o %s %s %s %s %s %s" + mkdll + (prepostfix "dll" !output_c ext_dll) + (String.concat " " !c_objs) + (String.concat " " !c_opts) + (String.concat " " !ld_opts) + (make_rpath mksharedlibrpath) + (String.concat " " !c_libs) + ) + in + if retcode <> 0 then if !failsafe then dynlink := false else exit 2 + end; + safe_remove (prepostfix "lib" !output_c ext_lib); + scommand + (mklib (prepostfix "lib" !output_c ext_lib) + (String.concat " " !c_objs) ""); + end; + if !bytecode_objs <> [] then + scommand + (sprintf "%s -a %s -o %s.cma %s %s -dllib -l%s -cclib -l%s %s %s %s %s" + (transl_path !ocamlc) + (if !dynlink then "" else "-custom") + !output + (String.concat " " !caml_opts) + (String.concat " " !bytecode_objs) + (Filename.basename !output_c) + (Filename.basename !output_c) + (String.concat " " (prefix_list "-ccopt " !c_opts)) + (make_rpath_ccopt byteccrpath) + (String.concat " " (prefix_list "-cclib " !c_libs)) + (String.concat " " !caml_libs)); + if !native_objs <> [] then + scommand + (sprintf "%s -a -o %s.cmxa %s %s -cclib -l%s %s %s %s %s" + (transl_path !ocamlopt) + !output + (String.concat " " !caml_opts) + (String.concat " " !native_objs) + (Filename.basename !output_c) + (String.concat " " (prefix_list "-ccopt " !c_opts)) + (make_rpath_ccopt nativeccrpath) + (String.concat " " (prefix_list "-cclib " !c_libs)) + (String.concat " " !caml_libs)) + +let _ = + try + parse_arguments Sys.argv; + build_libs() + with + | Bad_argument "" -> + prerr_string usage; exit 0 + | Bad_argument s -> + prerr_endline s; prerr_string usage; exit 4 + | Sys_error s -> + prerr_string "System error: "; prerr_endline s; exit 4 + | x -> + raise x diff --git a/ocaml-binary-annot/tools/ocamlmktop.ml b/ocaml-binary-annot/tools/ocamlmktop.ml new file mode 100644 index 0000000000..3d353a8f59 --- /dev/null +++ b/ocaml-binary-annot/tools/ocamlmktop.ml @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +let _ = + let args = Ccomp.quote_files (List.tl (Array.to_list Sys.argv)) in + exit(Sys.command("ocamlc -linkall toplevellib.cma " ^ args ^ " topstart.cmo")) diff --git a/ocaml-binary-annot/tools/ocamlmktop.tpl b/ocaml-binary-annot/tools/ocamlmktop.tpl new file mode 100644 index 0000000000..477f7387ce --- /dev/null +++ b/ocaml-binary-annot/tools/ocamlmktop.tpl @@ -0,0 +1,16 @@ +#!/bin/sh +######################################################################### +# # +# Objective Caml # +# # +# Damien Doligez, projet Para, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id$ + +exec %%BINDIR%%/ocamlc -linkall toplevellib.cma "$@" topstart.cmo diff --git a/ocaml-binary-annot/tools/ocamlprof.ml b/ocaml-binary-annot/tools/ocamlprof.ml new file mode 100644 index 0000000000..f58712ec51 --- /dev/null +++ b/ocaml-binary-annot/tools/ocamlprof.ml @@ -0,0 +1,503 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez and Francois Rouaix, INRIA Rocquencourt *) +(* Ported to Caml Special Light by John Malecki *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Printf + +open Clflags +open Config +open Location +open Misc +open Parsetree + +(* User programs must not use identifiers that start with these prefixes. *) +let idprefix = "__ocaml_prof_";; +let modprefix = "OCAML__prof_";; + +(* Errors specific to the profiler *) +exception Profiler of string + +(* Modes *) +let instr_fun = ref false +and instr_match = ref false +and instr_if = ref false +and instr_loops = ref false +and instr_try = ref false + +let cur_point = ref 0 +and inchan = ref stdin +and outchan = ref stdout + +(* To copy source fragments *) +let copy_buffer = String.create 256 + +let copy_chars_unix nchars = + let n = ref nchars in + while !n > 0 do + let m = input !inchan copy_buffer 0 (min !n 256) in + if m = 0 then raise End_of_file; + output !outchan copy_buffer 0 m; + n := !n - m + done + +let copy_chars_win32 nchars = + for i = 1 to nchars do + let c = input_char !inchan in + if c <> '\r' then output_char !outchan c + done + +let copy_chars = + match Sys.os_type with + "Win32" | "Cygwin" -> copy_chars_win32 + | _ -> copy_chars_unix + +let copy next = + assert (next >= !cur_point); + seek_in !inchan !cur_point; + copy_chars (next - !cur_point); + cur_point := next; +;; + +let prof_counter = ref 0;; + +let instr_mode = ref false + +type insert = Open | Close;; +let to_insert = ref ([] : (insert * int) list);; + +let insert_action st en = + to_insert := (Open, st) :: (Close, en) :: !to_insert +;; + +(* Producing instrumented code *) +let add_incr_counter modul (kind,pos) = + copy pos; + match kind with + | Open -> + fprintf !outchan "(%sProfiling.incr %s%s_cnt %d; " + modprefix idprefix modul !prof_counter; + incr prof_counter; + | Close -> fprintf !outchan ")"; +;; + +let counters = ref (Array.create 0 0) + +(* User defined marker *) +let special_id = ref "" + +(* Producing results of profile run *) +let add_val_counter (kind,pos) = + if kind = Open then begin + copy pos; + fprintf !outchan "(* %s%d *) " !special_id !counters.(!prof_counter); + incr prof_counter; + end +;; + +(* ************* rewrite ************* *) + +let insert_profile rw_exp ex = + let st = ex.pexp_loc.loc_start.Lexing.pos_cnum + and en = ex.pexp_loc.loc_end.Lexing.pos_cnum + and gh = ex.pexp_loc.loc_ghost + in + if gh || st = en then + rw_exp true ex + else begin + insert_action st en; + rw_exp false ex; + end +;; + + +let pos_len = ref 0 + +let init_rewrite modes mod_name = + cur_point := 0; + if !instr_mode then begin + fprintf !outchan "module %sProfiling = Profiling;; " modprefix; + fprintf !outchan "let %s%s_cnt = Array.create 000000000" idprefix mod_name; + pos_len := pos_out !outchan; + fprintf !outchan + " 0;; Profiling.counters := \ + (\"%s\", (\"%s\", %s%s_cnt)) :: !Profiling.counters;; " + mod_name modes idprefix mod_name; + end + +let final_rewrite add_function = + to_insert := Sort.list (fun x y -> snd x < snd y) !to_insert; + prof_counter := 0; + List.iter add_function !to_insert; + copy (in_channel_length !inchan); + if !instr_mode then begin + let len = string_of_int !prof_counter in + if String.length len > 9 then raise (Profiler "too many counters"); + seek_out !outchan (!pos_len - String.length len); + output_string !outchan len + end; + (* Cannot close because outchan is stdout and Format doesn't like + a closed stdout. + close_out !outchan; + *) +;; + +let rec rewrite_patexp_list iflag l = + rewrite_exp_list iflag (List.map snd l) + +and rewrite_patlexp_list iflag l = + rewrite_exp_list iflag (List.map snd l) + +and rewrite_labelexp_list iflag l = + rewrite_exp_list iflag (List.map snd l) + +and rewrite_exp_list iflag l = + List.iter (rewrite_exp iflag) l + +and rewrite_exp iflag sexp = + if iflag then insert_profile rw_exp sexp + else rw_exp false sexp + +and rw_exp iflag sexp = + match sexp.pexp_desc with + Pexp_ident lid -> () + | Pexp_constant cst -> () + + | Pexp_let(_, spat_sexp_list, sbody) -> + rewrite_patexp_list iflag spat_sexp_list; + rewrite_exp iflag sbody + + | Pexp_function (_, _, caselist) -> + if !instr_fun then + rewrite_function iflag caselist + else + rewrite_patlexp_list iflag caselist + + | Pexp_match(sarg, caselist) -> + rewrite_exp iflag sarg; + if !instr_match && not sexp.pexp_loc.loc_ghost then + rewrite_funmatching caselist + else + rewrite_patlexp_list iflag caselist + + | Pexp_try(sbody, caselist) -> + rewrite_exp iflag sbody; + if !instr_try && not sexp.pexp_loc.loc_ghost then + rewrite_trymatching caselist + else + rewrite_patexp_list iflag caselist + + | Pexp_apply(sfunct, sargs) -> + rewrite_exp iflag sfunct; + rewrite_exp_list iflag (List.map snd sargs) + + | Pexp_tuple sexpl -> + rewrite_exp_list iflag sexpl + + | Pexp_construct(_, None, _) -> () + | Pexp_construct(_, Some sarg, _) -> + rewrite_exp iflag sarg + + | Pexp_variant(_, None) -> () + | Pexp_variant(_, Some sarg) -> + rewrite_exp iflag sarg + + | Pexp_record(lid_sexp_list, None) -> + rewrite_labelexp_list iflag lid_sexp_list + | Pexp_record(lid_sexp_list, Some sexp) -> + rewrite_exp iflag sexp; + rewrite_labelexp_list iflag lid_sexp_list + + | Pexp_field(sarg, _) -> + rewrite_exp iflag sarg + + | Pexp_setfield(srecord, _, snewval) -> + rewrite_exp iflag srecord; + rewrite_exp iflag snewval + + | Pexp_array(sargl) -> + rewrite_exp_list iflag sargl + + | Pexp_ifthenelse(scond, sifso, None) -> + rewrite_exp iflag scond; + rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifso + | Pexp_ifthenelse(scond, sifso, Some sifnot) -> + rewrite_exp iflag scond; + rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifso; + rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifnot + + | Pexp_sequence(sexp1, sexp2) -> + rewrite_exp iflag sexp1; + rewrite_exp iflag sexp2 + + | Pexp_while(scond, sbody) -> + rewrite_exp iflag scond; + if !instr_loops && not sexp.pexp_loc.loc_ghost + then insert_profile rw_exp sbody + else rewrite_exp iflag sbody + + | Pexp_for(_, slow, shigh, _, sbody) -> + rewrite_exp iflag slow; + rewrite_exp iflag shigh; + if !instr_loops && not sexp.pexp_loc.loc_ghost + then insert_profile rw_exp sbody + else rewrite_exp iflag sbody + + | Pexp_constraint(sarg, _, _) -> + rewrite_exp iflag sarg + + | Pexp_when(scond, sbody) -> + rewrite_exp iflag scond; + rewrite_exp iflag sbody + + | Pexp_send (sobj, _) -> + rewrite_exp iflag sobj + + | Pexp_new _ -> () + + | Pexp_setinstvar (_, sarg) -> + rewrite_exp iflag sarg + + | Pexp_override l -> + List.iter (fun (_, sexp) -> rewrite_exp iflag sexp) l + + | Pexp_letmodule (_, smod, sexp) -> + rewrite_mod iflag smod; + rewrite_exp iflag sexp + + | Pexp_assert (cond) -> rewrite_exp iflag cond + | Pexp_assertfalse -> () + + | Pexp_lazy (expr) -> rewrite_exp iflag expr + + | Pexp_poly (sexp, _) -> rewrite_exp iflag sexp + + | Pexp_object (_, fieldl) -> + List.iter (rewrite_class_field iflag) fieldl + + | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp + | Pexp_open (_, e) -> rewrite_exp iflag e + | Pexp_pack (smod) -> rewrite_mod iflag smod + +and rewrite_ifbody iflag ghost sifbody = + if !instr_if && not ghost then + insert_profile rw_exp sifbody + else + rewrite_exp iflag sifbody + +(* called only when !instr_fun *) +and rewrite_annotate_exp_list l = + List.iter + (function + | {pexp_desc = Pexp_when(scond, sbody)} + -> insert_profile rw_exp scond; + insert_profile rw_exp sbody; + | {pexp_desc = Pexp_constraint(sbody, _, _)} (* let f x : t = e *) + -> insert_profile rw_exp sbody + | sexp -> insert_profile rw_exp sexp) + l + +and rewrite_function iflag = function + | [spat, ({pexp_desc = Pexp_function _} as sexp)] -> rewrite_exp iflag sexp + | l -> rewrite_funmatching l + +and rewrite_funmatching l = + rewrite_annotate_exp_list (List.map snd l) + +and rewrite_trymatching l = + rewrite_annotate_exp_list (List.map snd l) + +(* Rewrite a class definition *) + +and rewrite_class_field iflag = + function + Pcf_inher (_, cexpr, _) -> rewrite_class_expr iflag cexpr + | Pcf_val (_, _, _, sexp, _) -> rewrite_exp iflag sexp + | Pcf_meth (_, _, _, ({pexp_desc = Pexp_function _} as sexp), _) -> + rewrite_exp iflag sexp + | Pcf_meth (_, _, _, sexp, loc) -> + if !instr_fun && not loc.loc_ghost then insert_profile rw_exp sexp + else rewrite_exp iflag sexp + | Pcf_let(_, spat_sexp_list, _) -> + rewrite_patexp_list iflag spat_sexp_list + | Pcf_init sexp -> + rewrite_exp iflag sexp + | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> () + +and rewrite_class_expr iflag cexpr = + match cexpr.pcl_desc with + Pcl_constr _ -> () + | Pcl_structure (_, fields) -> + List.iter (rewrite_class_field iflag) fields + | Pcl_fun (_, _, _, cexpr) -> + rewrite_class_expr iflag cexpr + | Pcl_apply (cexpr, exprs) -> + rewrite_class_expr iflag cexpr; + List.iter (rewrite_exp iflag) (List.map snd exprs) + | Pcl_let (_, spat_sexp_list, cexpr) -> + rewrite_patexp_list iflag spat_sexp_list; + rewrite_class_expr iflag cexpr + | Pcl_constraint (cexpr, _) -> + rewrite_class_expr iflag cexpr + +and rewrite_class_declaration iflag cl = + rewrite_class_expr iflag cl.pci_expr + +(* Rewrite a module expression or structure expression *) + +and rewrite_mod iflag smod = + match smod.pmod_desc with + Pmod_ident lid -> () + | Pmod_structure sstr -> List.iter (rewrite_str_item iflag) sstr + | Pmod_functor(param, smty, sbody) -> rewrite_mod iflag sbody + | Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2 + | Pmod_constraint(smod, smty) -> rewrite_mod iflag smod + | Pmod_unpack(sexp) -> rewrite_exp iflag sexp + +and rewrite_str_item iflag item = + match item.pstr_desc with + Pstr_eval exp -> rewrite_exp iflag exp + | Pstr_value(_, exps) + -> List.iter (function (_,exp) -> rewrite_exp iflag exp) exps + | Pstr_module(name, smod) -> rewrite_mod iflag smod + | Pstr_class classes -> List.iter (rewrite_class_declaration iflag) classes + | _ -> () + +(* Rewrite a .ml file *) +let rewrite_file srcfile add_function = + inchan := open_in_bin srcfile; + let lb = Lexing.from_channel !inchan in + Location.input_name := srcfile; + Location.init lb srcfile; + List.iter (rewrite_str_item false) (Parse.implementation lb); + final_rewrite add_function; + close_in !inchan + +(* Copy a non-.ml file without change *) +let null_rewrite srcfile = + inchan := open_in_bin srcfile; + copy (in_channel_length !inchan); + close_in !inchan +;; + +(* Setting flags from saved config *) +let set_flags s = + for i = 0 to String.length s - 1 do + match String.get s i with + 'f' -> instr_fun := true + | 'm' -> instr_match := true + | 'i' -> instr_if := true + | 'l' -> instr_loops := true + | 't' -> instr_try := true + | 'a' -> instr_fun := true; instr_match := true; + instr_if := true; instr_loops := true; + instr_try := true + | _ -> () + done + +(* Command-line options *) + +let modes = ref "fm" +let dumpfile = ref "ocamlprof.dump" + +(* Process a file *) + +let process_intf_file filename = null_rewrite filename;; + +let process_impl_file filename = + let modname = Filename.basename(Filename.chop_extension filename) in + (* FIXME should let modname = String.capitalize modname *) + if !instr_mode then begin + (* Instrumentation mode *) + set_flags !modes; + init_rewrite !modes modname; + rewrite_file filename (add_incr_counter modname); + end else begin + (* Results mode *) + let ic = open_in_bin !dumpfile in + let allcounters = + (input_value ic : (string * (string * int array)) list) in + close_in ic; + let (modes, cv) = + try + List.assoc modname allcounters + with Not_found -> + raise(Profiler("Module " ^ modname ^ " not used in this profile.")) + in + counters := cv; + set_flags modes; + init_rewrite modes modname; + rewrite_file filename add_val_counter; + end +;; + +let process_anon_file filename = + if Filename.check_suffix filename ".ml" then + process_impl_file filename + else + process_intf_file filename +;; + +(* Main function *) + +open Format + +let usage = "Usage: ocamlprof <options> <files>\noptions are:" + +let print_version () = + printf "ocamlprof, version %s@." Sys.ocaml_version; + exit 0; +;; + +let print_version_num () = + printf "%s@." Sys.ocaml_version; + exit 0; +;; + +let main () = + try + Warnings.parse_options false "a"; + Arg.parse [ + "-f", Arg.String (fun s -> dumpfile := s), + "<file> Use <file> as dump file (default ocamlprof.dump)"; + "-F", Arg.String (fun s -> special_id := s), + "<s> Insert string <s> with the counts"; + "-impl", Arg.String process_impl_file, + "<file> Process <file> as a .ml file"; + "-instrument", Arg.Set instr_mode, " (undocumented)"; + "-intf", Arg.String process_intf_file, + "<file> Process <file> as a .mli file"; + "-m", Arg.String (fun s -> modes := s), "<flags> (undocumented)"; + "-version", Arg.Unit print_version, + " Print version and exit"; + "-vnum", Arg.Unit print_version_num, + " Print version number and exit"; + ] process_anon_file usage; + exit 0 + with x -> + let report_error ppf = function + | Lexer.Error(err, range) -> + fprintf ppf "@[%a%a@]@." + Location.print_error range Lexer.report_error err + | Syntaxerr.Error err -> + fprintf ppf "@[%a@]@." + Syntaxerr.report_error err + | Profiler msg -> + fprintf ppf "@[%s@]@." msg + | Sys_error msg -> + fprintf ppf "@[I/O error:@ %s@]@." msg + | x -> raise x in + report_error Format.err_formatter x; + exit 2 + +let _ = main () diff --git a/ocaml-binary-annot/tools/ocamlsize b/ocaml-binary-annot/tools/ocamlsize new file mode 100755 index 0000000000..659543d593 --- /dev/null +++ b/ocaml-binary-annot/tools/ocamlsize @@ -0,0 +1,49 @@ +#!/usr/bin/perl + +foreach $f (@ARGV) { + open(FILE, $f) || die("Cannot open $f"); + seek(FILE, -16, 2); + $num_sections = do read_int(); + read(FILE, $magic, 12); + seek(FILE, -16 - 8 * $num_sections, 2); + @secname = (); + @seclength = (); + %length = (); + for ($i = 0; $i < $num_sections; $i++) { + read(FILE, $sec, 4); + $secname[$i] = $sec; + $seclength[$i] = do read_int(); + $length{$sec} = $seclength[$i]; + } + print $f, ":\n" if ($#ARGV > 0); + $path = + $length{'RNTM'} > 0 ? + do read_section('RNTM') : + "(default runtime)\n"; + printf ("\tcode: %-7d data: %-7d symbols: %-7d debug: %-7d\n", + $length{'CODE'}, $length{'DATA'}, + $length{'SYMB'}, $length{'DBUG'}); + printf ("\tmagic number: %s runtime system: %s", + $magic, $path); + close(FILE); +} + +sub read_int { + read(FILE, $buff, 4) == 4 || die("Truncated bytecode file $f"); + @int = unpack("C4", $buff); + return ($int[0] << 24) + ($int[1] << 16) + ($int[2] << 8) + $int[3]; +} + +sub read_section { + local ($sec) = @_; + local ($i, $ofs, $data); + for ($i = $num_sections - 1; $i >= 0; $i--) { + $ofs += $seclength[$i]; + if ($secname[$i] eq $sec) { + seek(FILE, -16 - 8 * $num_sections - $ofs, 2); + read(FILE, $data, $seclength[$i]); + return $data; + } + } + return ''; +} diff --git a/ocaml-binary-annot/tools/primreq.ml b/ocaml-binary-annot/tools/primreq.ml new file mode 100644 index 0000000000..dcace11ba7 --- /dev/null +++ b/ocaml-binary-annot/tools/primreq.ml @@ -0,0 +1,90 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Determine the set of C primitives required by the given .cmo and .cma + files *) + +open Config +open Cmo_format + +module StringSet = Set.Make(struct type t = string let compare = compare end) + +let defined = ref true +let used = ref false +let exclude_file = ref "" + +let primitives = ref StringSet.empty + +let scan_reloc = function + (Reloc_primitive s, _) -> primitives := StringSet.add s !primitives + | _ -> () + +let scan_prim s = + primitives := StringSet.add s !primitives + +let scan_info cu = + if !used then List.iter scan_reloc cu.cu_reloc; + if !defined then List.iter scan_prim cu.cu_primitives + +let scan_obj filename = + let ic = open_in_bin filename in + let buffer = String.create (String.length cmo_magic_number) in + really_input ic buffer 0 (String.length cmo_magic_number); + if buffer = cmo_magic_number then begin + let cu_pos = input_binary_int ic in + seek_in ic cu_pos; + let cu = (input_value ic : compilation_unit) in + close_in ic; + scan_info cu + end else + if buffer = cma_magic_number then begin + let toc_pos = input_binary_int ic in + seek_in ic toc_pos; + let toc = (input_value ic : library) in + close_in ic; + List.iter scan_info toc.lib_units + end else begin + prerr_endline "Not an object file"; exit 2 + end + +let exclude filename = + let ic = open_in filename in + try + while true do + let s = input_line ic in + primitives := StringSet.remove s !primitives + done + with End_of_file -> close_in ic + | x -> close_in ic; raise x + +let main() = + Arg.parse + ["-used", Arg.Unit(fun () -> used := true; defined := false), + "show primitives referenced in the object files"; + "-defined", Arg.Unit(fun () -> defined := true; used := false), + "show primitives defined in the object files (default)"; + "-all", Arg.Unit(fun () -> defined := true; used := true), + "show primitives defined or referenced in the object files"; + "-exclude", Arg.String(fun s -> exclude_file := s), + "<file> don't print the primitives mentioned in <file>"] + scan_obj + "Usage: primreq [options] <.cmo and .cma files>\nOptions are:"; + if String.length !exclude_file > 0 then exclude !exclude_file; + StringSet.iter + (fun s -> + if s.[0] <> '%' then begin print_string s; print_newline() end) + !primitives; + exit 0 + +let _ = main () diff --git a/ocaml-binary-annot/tools/profiling.ml b/ocaml-binary-annot/tools/profiling.ml new file mode 100644 index 0000000000..9c6d9dd02b --- /dev/null +++ b/ocaml-binary-annot/tools/profiling.ml @@ -0,0 +1,56 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez and Francois Rouaix, INRIA Rocquencourt *) +(* Ported to Caml Special Light by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Run-time library for profiled programs *) + +type profiling_counters = (string * (string * int array)) list + +let counters = ref ([] : profiling_counters);; +let incr a i = a.(i) <- a.(i) + 1;; + +exception Bad_profile + +let dump_counters () = + let dumpfile = + try Sys.getenv "OCAMLPROF_DUMP" with Not_found -> "ocamlprof.dump" + in + begin try + let ic = open_in_bin dumpfile in + let prevl = (input_value ic : profiling_counters) in + close_in ic; + List.iter2 + (fun (curname, (curmodes,curcount)) (prevname, (prevmodes,prevcount)) -> + if curname <> prevname + || curmodes <> prevmodes + || Array.length curcount <> Array.length prevcount + then raise Bad_profile) + !counters prevl; + List.iter2 + (fun (curname, (_,curcount)) (prevname, (_,prevcount)) -> + for i = 0 to Array.length curcount - 1 do + curcount.(i) <- curcount.(i) + prevcount.(i) + done) + !counters prevl + with _ -> () + end; + begin try + let oc = open_out_bin dumpfile in + output_value oc !counters; + close_out oc + with _ -> () + end + +let _ = at_exit dump_counters diff --git a/ocaml-binary-annot/tools/profiling.mli b/ocaml-binary-annot/tools/profiling.mli new file mode 100644 index 0000000000..ca8486f436 --- /dev/null +++ b/ocaml-binary-annot/tools/profiling.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez and Francois Rouaix, INRIA Rocquencourt *) +(* Ported to Objective Caml by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Run-time library for profiled programs *) + +val counters: (string * (string * int array)) list ref;; +val incr: int array -> int -> unit;; diff --git a/ocaml-binary-annot/tools/scrapelabels.ml b/ocaml-binary-annot/tools/scrapelabels.ml new file mode 100644 index 0000000000..dc43e97b70 --- /dev/null +++ b/ocaml-binary-annot/tools/scrapelabels.ml @@ -0,0 +1,289 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open StdLabels +open Lexer301 + +let input_buffer = Buffer.create 16383 +let input_function ic buf len = + let len = input ic buf 0 len in + Buffer.add_substring input_buffer buf 0 len; + len + +let output_buffer = Buffer.create 16383 + +let modified = ref false + +let modules = + ref [ "Arg"; "BigArray"; "Buffer"; "Condition"; "Dbm"; "Digest"; "Dynlink"; + "Event"; "Filename"; "Format"; "Gc"; "Genlex"; "Graphics"; + "Lexing"; "Marshal"; "Mutex"; "Parsing"; "Pervasives"; "Queue"; + "Sort"; "Stack"; "Str"; "Stream"; "Sys"; + "Thread"; "ThreadUnix"; "Weak" ] + +let stdlabels = ["Array"; "List"; "String"] +let morelabels = ["Hashtbl"; "Map"; "Set"] +let alllabels = ref false +let noopen = ref false + +exception Closing of token + +let convert_impl buffer = + let input_pos = ref 0 in + let copy_input stop = + Buffer.add_substring output_buffer (Buffer.contents input_buffer) + !input_pos (stop - !input_pos); + input_pos := stop + in + let next_token () = + let token = Lexer301.token buffer + and start = Lexing.lexeme_start buffer + and stop = Lexing.lexeme_end buffer in + match token with + RPAREN | RBRACKET |BARRBRACKET | GREATERRBRACKET | END + | RBRACE | GREATERRBRACE -> + raise (Closing token) + | EOF -> + raise End_of_file + | _ -> + (token, start, stop) + in + let openunix = ref None and openstd = ref None and openmore = ref None in + let rec may_start (token, s, e) = + match token with + LIDENT _ -> search_start (dropext (next_token ())) + | UIDENT m when List.mem m !modules -> + may_discard (dropext (next_token ())) + | UIDENT m -> + List.iter ~f: + (fun (set,r) -> + if !r = None && List.mem m ~set then r := Some true) + [stdlabels, openstd; ["Unix"], openunix; morelabels, openmore]; + search_start (next_token ()) + | _ -> search_start (token, s, e) + + and dropext (token, s, e) = + match token with + DOT -> + let (token, s, e) = next_token () in + begin match token with + LPAREN | LBRACKET | LBRACE -> + process_paren (token, s, e); + dropext (next_token ()) + | UIDENT _ | LIDENT _ -> + dropext (next_token ()) + | _ -> + prerr_endline ("bad index at position " ^ string_of_int s); + (token, s, e) + end + | _ -> + (token, s, e) + + and may_discard (token, s, e) = + match token with + TILDE | LABEL _ -> + modified := true; + copy_input s; input_pos := e; + may_discard (next_token ()) + | _ when !alllabels -> + may_discard (next_token ()) + | LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN + | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT-> + process_paren (token, s, e); + may_discard (next_token ()) + | PREFIXOP _ -> + may_discard (next_token ()) + | LIDENT _ | UIDENT _ -> + may_discard (dropext (next_token ())) + | BACKQUOTE -> + ignore (next_token ()); + may_discard (next_token ()) + | INT _ | CHAR _ | STRING _ | FLOAT _ | FALSE | TRUE -> + may_discard (next_token ()) + | _ -> + search_start (token, s, e) + + and search_start (token, s, e) = + match token with + LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN + | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT -> + process_paren (token, s, e); + search_start (next_token ()) + | EQUAL | SEMI | SEMISEMI | MINUSGREATER | LESSMINUS | COMMA + | IF | THEN | ELSE | WHILE | TO | DOWNTO | DO | IN | MATCH | TRY + | INFIXOP0 _ | INFIXOP1 _ | INFIXOP2 _ | INFIXOP3 _ | INFIXOP4 _ + | PLUS | MINUS | MINUSDOT | STAR | LESS | GREATER + | OR | BARBAR | AMPERSAND | AMPERAMPER | COLONEQUAL -> + may_start (next_token ()) + | OPEN -> + begin match next_token () with + | UIDENT m, _, _ -> + List.iter + ~f:(fun (set,r) -> if List.mem m ~set then r := Some false) + [stdlabels, openstd; ["Unix"], openunix; morelabels, openmore] + | _ -> () + end; + search_start (next_token ()) + | _ -> + search_start (next_token ()) + + and process_paren (token, s, e) = + try match token with + LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN -> + may_start (next_token ()) + | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT -> + search_start (next_token ()) + | _ -> + assert false + with Closing last -> + match token, last with + LPAREN, RPAREN + | (LBRACKET|LBRACKETBAR|LBRACKETLESS), + (RBRACKET|BARRBRACKET|GREATERRBRACKET) + | (BEGIN|STRUCT|SIG|OBJECT), END + | LBRACE, RBRACE + | LBRACELESS, GREATERRBRACE -> () + | _ -> raise (Closing last) + in + let first = next_token () in + try + if !alllabels then may_discard first else may_start first + with End_of_file -> + copy_input (Buffer.length input_buffer); + if not !alllabels + && List.exists (fun r -> !r = Some true) [openstd; openunix; openmore] + then begin + modified := true; + let text = Buffer.contents output_buffer in + Buffer.clear output_buffer; + let (token, s, _) = first in + Buffer.add_substring output_buffer text 0 s; + List.iter ~f: + (fun (r, s) -> + if !r = Some true then Buffer.add_string output_buffer s) + [ openstd, "open StdLabels\n"; openmore, "open MoreLabels\n"; + openunix, "module Unix = UnixLabels\n" ]; + let sep = + if List.mem token [CLASS; EXTERNAL; EXCEPTION; FUNCTOR; LET; + MODULE; FUNCTOR; TYPE; VAL] + then "\n" + else if token = OPEN then "" else ";;\n\n" + in + Buffer.add_string output_buffer sep; + Buffer.add_substring output_buffer text s (String.length text - s) + end + | Closing _ -> + prerr_endline ("bad closing token at position " ^ + string_of_int (Lexing.lexeme_start buffer)); + modified := false + +type state = Out | Enter | In | Escape + +let convert_intf buffer = + let input_pos = ref 0 in + let copy_input stop = + Buffer.add_substring output_buffer (Buffer.contents input_buffer) + !input_pos (stop - !input_pos); + input_pos := stop + in + let last = ref (EOF, 0, 0) in + let state = ref Out in + try while true do + let token = Lexer301.token buffer + and start = Lexing.lexeme_start buffer + and stop = Lexing.lexeme_end buffer + and last_token, last_start, last_stop = !last in + begin match token with + | EXCEPTION | CONSTRAINT -> + state := In + | VAL | EXTERNAL | CLASS | METHOD | TYPE | AND -> + state := Enter + | EQUAL when !state = Enter -> + state := In + | COLON -> + begin match !state, last_token with + | In, LIDENT _ -> + modified := true; + copy_input last_start; + input_pos := stop + | Enter, _ -> + state := In + | Escape, _ -> + state := In + | _ -> + state := Out + end + | LBRACE | SEMI | QUESTION when !state = In -> + state := Escape + | SEMISEMI | SIG | STRUCT | END | OBJECT | OPEN | INCLUDE | MODULE -> + state := Out + | EOF -> raise End_of_file + | _ -> () + end; + last := (token, start, stop) + done with + End_of_file -> + copy_input (Buffer.length input_buffer) + +let convert_file ~intf name = + let ic = open_in name in + Buffer.clear input_buffer; + Buffer.clear output_buffer; + modified := false; + begin + let convert = if intf then convert_intf else convert_impl in + try convert (Lexing.from_function (input_function ic)); close_in ic + with exn -> close_in ic; raise exn + end; + if !modified then begin + let backup = name ^ ".bak" in + if Sys.file_exists backup then Sys.remove name + else Sys.rename name backup; + let oc = open_out name in + Buffer.output_buffer oc output_buffer; + close_out oc + end + else prerr_endline ("No changes in " ^ name) + +let _ = + let files = ref [] and intf = ref false + and keepstd = ref false and keepmore = ref false in + Arg.parse + [ "-intf", Arg.Set intf, + " remove all non-optional labels from an interface;\n" ^ + " other options are ignored"; + "-all", Arg.Set alllabels, + " remove all labels, possibly including optional ones!"; + "-keepstd", Arg.Set keepstd, + " keep labels for Array, List, String and Unix"; + "-keepmore", Arg.Set keepmore, + " keep also labels for Hashtbl, Map and Set; implies -keepstd"; + "-m", Arg.String (fun s -> modules := s :: !modules), + "<module> remove also labels for <module>"; + "-noopen", Arg.Set noopen, + " do not insert `open' statements for -keepstd/-keepmore" ] + (fun s -> files := s :: !files) + ("Usage: scrapelabels <options> <source files>\n" ^ + " Remove labels from function arguments in standard library modules.\n" ^ + " With -intf option below, can also process interfaces.\n" ^ + " Old files are renamed to <file>.bak if there is no backup yet.\n" ^ + "Options are:"); + if !keepmore then keepstd := true; + if not !keepstd then modules := "Unix" :: stdlabels @ !modules; + if not !keepmore then modules := morelabels @ !modules; + List.iter (List.rev !files) ~f: + begin fun name -> + prerr_endline ("Processing " ^ name); + Printexc.catch (convert_file ~intf:!intf) name + end |