diff options
121 files changed, 5097 insertions, 495 deletions
@@ -29,13 +29,20 @@ interp/syntax_def.cmi: kernel/names.cmi pretyping/rawterm.cmi \ interp/topconstr.cmi: lib/bignat.cmi lib/dyn.cmi pretyping/evd.cmi \ library/libnames.cmi kernel/names.cmi lib/pp.cmi pretyping/rawterm.cmi \ kernel/term.cmi lib/util.cmi +kernel/cbytecodes.cmi: kernel/names.cmi kernel/term.cmi +kernel/cbytegen.cmi: kernel/cbytecodes.cmi kernel/cemitcodes.cmi \ + kernel/declarations.cmi kernel/environ.cmi kernel/names.cmi \ + kernel/term.cmi +kernel/cemitcodes.cmi: kernel/cbytecodes.cmi kernel/names.cmi kernel/closure.cmi: kernel/environ.cmi kernel/esubst.cmi kernel/names.cmi \ lib/pp.cmi kernel/term.cmi -kernel/conv_oracle.cmi: kernel/closure.cmi kernel/names.cmi +kernel/conv_oracle.cmi: kernel/names.cmi kernel/cooking.cmi: kernel/declarations.cmi kernel/environ.cmi \ kernel/names.cmi kernel/term.cmi kernel/univ.cmi -kernel/declarations.cmi: kernel/names.cmi lib/rtree.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/univ.cmi +kernel/csymtable.cmi: kernel/environ.cmi kernel/names.cmi kernel/term.cmi +kernel/declarations.cmi: kernel/cbytecodes.cmi kernel/cemitcodes.cmi \ + kernel/names.cmi lib/rtree.cmi kernel/sign.cmi kernel/term.cmi \ + kernel/univ.cmi kernel/entries.cmi: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \ kernel/univ.cmi kernel/environ.cmi: kernel/declarations.cmi kernel/names.cmi kernel/sign.cmi \ @@ -46,10 +53,10 @@ kernel/indtypes.cmi: kernel/declarations.cmi kernel/entries.cmi \ kernel/univ.cmi kernel/inductive.cmi: kernel/declarations.cmi kernel/environ.cmi \ kernel/names.cmi kernel/term.cmi kernel/univ.cmi -kernel/mod_typing.cmi: kernel/declarations.cmi kernel/entries.cmi \ - kernel/environ.cmi kernel/modops.cmi: kernel/declarations.cmi kernel/entries.cmi \ kernel/environ.cmi kernel/names.cmi kernel/univ.cmi lib/util.cmi +kernel/mod_typing.cmi: kernel/declarations.cmi kernel/entries.cmi \ + kernel/environ.cmi kernel/names.cmi: lib/pp.cmi lib/predicate.cmi kernel/reduction.cmi: kernel/environ.cmi kernel/sign.cmi kernel/term.cmi \ kernel/univ.cmi @@ -67,11 +74,12 @@ kernel/type_errors.cmi: kernel/environ.cmi kernel/names.cmi kernel/term.cmi kernel/typeops.cmi: kernel/entries.cmi kernel/environ.cmi kernel/names.cmi \ kernel/sign.cmi kernel/term.cmi kernel/univ.cmi kernel/univ.cmi: kernel/names.cmi lib/pp.cmi +kernel/vconv.cmi: kernel/environ.cmi kernel/names.cmi kernel/reduction.cmi \ + kernel/term.cmi +kernel/vm.cmi: kernel/cbytecodes.cmi kernel/cemitcodes.cmi kernel/names.cmi \ + kernel/term.cmi lib/bignat.cmi: lib/pp.cmi lib/pp.cmi: lib/pp_control.cmi -lib/rtree.cmi: lib/pp.cmi -lib/system.cmi: lib/pp.cmi -lib/util.cmi: lib/compat.cmo lib/pp.cmi library/declare.cmi: kernel/cooking.cmi library/decl_kinds.cmo \ kernel/declarations.cmi library/dischargedhypsmap.cmi kernel/entries.cmi \ kernel/indtypes.cmi library/libnames.cmi library/libobject.cmi \ @@ -100,6 +108,9 @@ library/library.cmi: library/libnames.cmi library/libobject.cmi \ library/nameops.cmi: kernel/names.cmi lib/pp.cmi kernel/term.cmi library/nametab.cmi: library/libnames.cmi kernel/names.cmi lib/pp.cmi \ lib/util.cmi +lib/rtree.cmi: lib/pp.cmi +lib/system.cmi: lib/pp.cmi +lib/util.cmi: lib/compat.cmo lib/pp.cmi parsing/ast.cmi: parsing/coqast.cmi lib/dyn.cmi interp/genarg.cmi \ library/libnames.cmi kernel/names.cmi lib/pp.cmi interp/topconstr.cmi \ lib/util.cmi @@ -171,7 +182,8 @@ pretyping/evarutil.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \ pretyping/rawterm.cmi pretyping/reductionops.cmi kernel/sign.cmi \ kernel/term.cmi pretyping/termops.cmi lib/util.cmi pretyping/evd.cmi: kernel/environ.cmi library/libnames.cmi kernel/names.cmi \ - lib/pp.cmi kernel/sign.cmi kernel/term.cmi lib/util.cmi + lib/pp.cmi kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \ + lib/util.cmi pretyping/indrec.cmi: kernel/declarations.cmi kernel/environ.cmi \ pretyping/evd.cmi pretyping/inductiveops.cmi kernel/names.cmi \ kernel/term.cmi @@ -325,11 +337,11 @@ toplevel/recordobj.cmi: library/libnames.cmi proofs/tacexpr.cmo toplevel/searchisos.cmi: library/libobject.cmi kernel/names.cmi \ kernel/term.cmi toplevel/toplevel.cmi: parsing/pcoq.cmi lib/pp.cmi -toplevel/vernac.cmi: parsing/pcoq.cmi lib/util.cmi toplevel/vernacexpr.cmo toplevel/vernacentries.cmi: kernel/environ.cmi pretyping/evd.cmi \ library/libnames.cmi kernel/names.cmi kernel/term.cmi \ interp/topconstr.cmi toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi toplevel/vernacinterp.cmi: proofs/tacexpr.cmo +toplevel/vernac.cmi: parsing/pcoq.cmi lib/util.cmi toplevel/vernacexpr.cmo translate/ppconstrnew.cmi: parsing/coqast.cmi kernel/environ.cmi \ parsing/extend.cmi interp/genarg.cmi library/libnames.cmi \ kernel/names.cmi pretyping/pattern.cmi parsing/pcoq.cmi lib/pp.cmi \ @@ -349,9 +361,9 @@ contrib/cc/ccalgo.cmi: kernel/names.cmi kernel/term.cmi contrib/cc/ccproof.cmi: contrib/cc/ccalgo.cmi kernel/names.cmi contrib/correctness/past.cmi: kernel/names.cmi kernel/term.cmi \ interp/topconstr.cmi lib/util.cmi -contrib/correctness/pcic.cmi: pretyping/rawterm.cmi contrib/correctness/pcicenv.cmi: kernel/names.cmi kernel/sign.cmi \ kernel/term.cmi +contrib/correctness/pcic.cmi: pretyping/rawterm.cmi contrib/correctness/pdb.cmi: kernel/names.cmi contrib/correctness/peffect.cmi: kernel/names.cmi lib/pp.cmi contrib/correctness/penv.cmi: library/libnames.cmi kernel/names.cmi \ @@ -453,22 +465,24 @@ config/coq_config.cmo: config/coq_config.cmi config/coq_config.cmx: config/coq_config.cmi dev/db_printers.cmo: kernel/names.cmi lib/pp.cmi dev/db_printers.cmx: kernel/names.cmx lib/pp.cmx -dev/top_printers.cmo: parsing/ast.cmi toplevel/cerrors.cmi \ - pretyping/clenv.cmi kernel/closure.cmi interp/constrextern.cmi \ - kernel/declarations.cmi kernel/environ.cmi pretyping/evd.cmi \ - library/libnames.cmi library/libobject.cmi library/nameops.cmi \ - kernel/names.cmi lib/pp.cmi parsing/pptactic.cmi parsing/printer.cmi \ - proofs/proof_trees.cmi proofs/refiner.cmi kernel/sign.cmi lib/system.cmi \ - proofs/tacmach.cmi parsing/tactic_printer.cmi kernel/term.cmi \ - pretyping/termops.cmi kernel/univ.cmi -dev/top_printers.cmx: parsing/ast.cmx toplevel/cerrors.cmx \ - pretyping/clenv.cmx kernel/closure.cmx interp/constrextern.cmx \ - kernel/declarations.cmx kernel/environ.cmx pretyping/evd.cmx \ - library/libnames.cmx library/libobject.cmx library/nameops.cmx \ - kernel/names.cmx lib/pp.cmx parsing/pptactic.cmx parsing/printer.cmx \ - proofs/proof_trees.cmx proofs/refiner.cmx kernel/sign.cmx lib/system.cmx \ - proofs/tacmach.cmx parsing/tactic_printer.cmx kernel/term.cmx \ - pretyping/termops.cmx kernel/univ.cmx +dev/top_printers.cmo: parsing/ast.cmi kernel/cbytecodes.cmi \ + kernel/cemitcodes.cmi toplevel/cerrors.cmi pretyping/clenv.cmi \ + kernel/closure.cmi interp/constrextern.cmi kernel/declarations.cmi \ + kernel/environ.cmi pretyping/evd.cmi library/libnames.cmi \ + library/libobject.cmi library/nameops.cmi kernel/names.cmi lib/pp.cmi \ + parsing/pptactic.cmi parsing/printer.cmi proofs/proof_trees.cmi \ + proofs/refiner.cmi kernel/sign.cmi lib/system.cmi proofs/tacmach.cmi \ + parsing/tactic_printer.cmi kernel/term.cmi pretyping/termops.cmi \ + kernel/univ.cmi +dev/top_printers.cmx: parsing/ast.cmx kernel/cbytecodes.cmx \ + kernel/cemitcodes.cmx toplevel/cerrors.cmx pretyping/clenv.cmx \ + kernel/closure.cmx interp/constrextern.cmx kernel/declarations.cmx \ + kernel/environ.cmx pretyping/evd.cmx library/libnames.cmx \ + library/libobject.cmx library/nameops.cmx kernel/names.cmx lib/pp.cmx \ + parsing/pptactic.cmx parsing/printer.cmx proofs/proof_trees.cmx \ + proofs/refiner.cmx kernel/sign.cmx lib/system.cmx proofs/tacmach.cmx \ + parsing/tactic_printer.cmx kernel/term.cmx pretyping/termops.cmx \ + kernel/univ.cmx doc/parse.cmo: parsing/ast.cmi doc/parse.cmx: parsing/ast.cmx ide/blaster_window.cmo: ide/coq.cmi ide/ideutils.cmi @@ -481,6 +495,14 @@ ide/config_lexer.cmo: ide/config_parser.cmi lib/util.cmi ide/config_lexer.cmx: ide/config_parser.cmx lib/util.cmx ide/config_parser.cmo: lib/util.cmi ide/config_parser.cmi ide/config_parser.cmx: lib/util.cmx ide/config_parser.cmi +ide/coqide.cmo: ide/blaster_window.cmo ide/command_windows.cmi ide/coq.cmi \ + ide/coq_commands.cmo ide/find_phrase.cmo ide/highlight.cmo \ + ide/ideutils.cmi proofs/pfedit.cmi ide/preferences.cmi lib/system.cmi \ + ide/undo.cmi lib/util.cmi toplevel/vernacexpr.cmo ide/coqide.cmi +ide/coqide.cmx: ide/blaster_window.cmx ide/command_windows.cmx ide/coq.cmx \ + ide/coq_commands.cmx ide/find_phrase.cmx ide/highlight.cmx \ + ide/ideutils.cmx proofs/pfedit.cmx ide/preferences.cmx lib/system.cmx \ + ide/undo.cmx lib/util.cmx toplevel/vernacexpr.cmx ide/coqide.cmi ide/coq.cmo: toplevel/cerrors.cmi config/coq_config.cmi toplevel/coqtop.cmi \ kernel/declarations.cmi kernel/environ.cmi pretyping/evarutil.cmi \ pretyping/evd.cmi library/global.cmi tactics/hipattern.cmi \ @@ -503,14 +525,6 @@ ide/coq.cmx: toplevel/cerrors.cmx config/coq_config.cmx toplevel/coqtop.cmx \ toplevel/vernacentries.cmx toplevel/vernacexpr.cmx ide/coq.cmi ide/coq_tactics.cmo: ide/coq_tactics.cmi ide/coq_tactics.cmx: ide/coq_tactics.cmi -ide/coqide.cmo: ide/blaster_window.cmo ide/command_windows.cmi ide/coq.cmi \ - ide/coq_commands.cmo ide/find_phrase.cmo ide/highlight.cmo \ - ide/ideutils.cmi proofs/pfedit.cmi ide/preferences.cmi lib/system.cmi \ - ide/undo.cmi lib/util.cmi toplevel/vernacexpr.cmo ide/coqide.cmi -ide/coqide.cmx: ide/blaster_window.cmx ide/command_windows.cmx ide/coq.cmx \ - ide/coq_commands.cmx ide/find_phrase.cmx ide/highlight.cmx \ - ide/ideutils.cmx proofs/pfedit.cmx ide/preferences.cmx lib/system.cmx \ - ide/undo.cmx lib/util.cmx toplevel/vernacexpr.cmx ide/coqide.cmi ide/find_phrase.cmo: ide/ideutils.cmi ide/find_phrase.cmx: ide/ideutils.cmx ide/highlight.cmo: ide/ideutils.cmi @@ -623,26 +637,44 @@ interp/topconstr.cmx: lib/bignat.cmx lib/dyn.cmx pretyping/evd.cmx \ library/libnames.cmx library/nameops.cmx kernel/names.cmx lib/options.cmx \ lib/pp.cmx pretyping/rawterm.cmx kernel/term.cmx lib/util.cmx \ interp/topconstr.cmi +kernel/cbytecodes.cmo: kernel/names.cmi kernel/term.cmi kernel/cbytecodes.cmi +kernel/cbytecodes.cmx: kernel/names.cmx kernel/term.cmx kernel/cbytecodes.cmi +kernel/cbytegen.cmo: kernel/cbytecodes.cmi kernel/cemitcodes.cmi \ + kernel/declarations.cmi kernel/environ.cmi kernel/names.cmi \ + kernel/term.cmi lib/util.cmi kernel/cbytegen.cmi +kernel/cbytegen.cmx: kernel/cbytecodes.cmx kernel/cemitcodes.cmx \ + kernel/declarations.cmx kernel/environ.cmx kernel/names.cmx \ + kernel/term.cmx lib/util.cmx kernel/cbytegen.cmi +kernel/cemitcodes.cmo: kernel/cbytecodes.cmi kernel/copcodes.cmo \ + kernel/names.cmi kernel/term.cmi kernel/cemitcodes.cmi +kernel/cemitcodes.cmx: kernel/cbytecodes.cmx kernel/copcodes.cmx \ + kernel/names.cmx kernel/term.cmx kernel/cemitcodes.cmi kernel/closure.cmo: kernel/declarations.cmi kernel/environ.cmi \ kernel/esubst.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \ lib/util.cmi kernel/closure.cmi kernel/closure.cmx: kernel/declarations.cmx kernel/environ.cmx \ kernel/esubst.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \ lib/util.cmx kernel/closure.cmi -kernel/conv_oracle.cmo: kernel/closure.cmi kernel/names.cmi \ - kernel/conv_oracle.cmi -kernel/conv_oracle.cmx: kernel/closure.cmx kernel/names.cmx \ - kernel/conv_oracle.cmi -kernel/cooking.cmo: kernel/declarations.cmi kernel/environ.cmi \ - kernel/names.cmi lib/pp.cmi kernel/reduction.cmi kernel/sign.cmi \ - kernel/term.cmi lib/util.cmi kernel/cooking.cmi -kernel/cooking.cmx: kernel/declarations.cmx kernel/environ.cmx \ - kernel/names.cmx lib/pp.cmx kernel/reduction.cmx kernel/sign.cmx \ - kernel/term.cmx lib/util.cmx kernel/cooking.cmi -kernel/declarations.cmo: kernel/names.cmi lib/rtree.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/univ.cmi lib/util.cmi kernel/declarations.cmi -kernel/declarations.cmx: kernel/names.cmx lib/rtree.cmx kernel/sign.cmx \ - kernel/term.cmx kernel/univ.cmx lib/util.cmx kernel/declarations.cmi +kernel/conv_oracle.cmo: kernel/names.cmi kernel/conv_oracle.cmi +kernel/conv_oracle.cmx: kernel/names.cmx kernel/conv_oracle.cmi +kernel/cooking.cmo: kernel/cemitcodes.cmi kernel/declarations.cmi \ + kernel/environ.cmi kernel/names.cmi lib/pp.cmi kernel/reduction.cmi \ + kernel/sign.cmi kernel/term.cmi lib/util.cmi kernel/cooking.cmi +kernel/cooking.cmx: kernel/cemitcodes.cmx kernel/declarations.cmx \ + kernel/environ.cmx kernel/names.cmx lib/pp.cmx kernel/reduction.cmx \ + kernel/sign.cmx kernel/term.cmx lib/util.cmx kernel/cooking.cmi +kernel/csymtable.cmo: kernel/cbytecodes.cmi kernel/cbytegen.cmi \ + kernel/cemitcodes.cmi kernel/declarations.cmi kernel/environ.cmi \ + kernel/names.cmi kernel/term.cmi kernel/vm.cmi kernel/csymtable.cmi +kernel/csymtable.cmx: kernel/cbytecodes.cmx kernel/cbytegen.cmx \ + kernel/cemitcodes.cmx kernel/declarations.cmx kernel/environ.cmx \ + kernel/names.cmx kernel/term.cmx kernel/vm.cmx kernel/csymtable.cmi +kernel/declarations.cmo: kernel/cbytecodes.cmi kernel/cemitcodes.cmi \ + kernel/names.cmi lib/rtree.cmi kernel/sign.cmi kernel/term.cmi \ + kernel/univ.cmi lib/util.cmi kernel/declarations.cmi +kernel/declarations.cmx: kernel/cbytecodes.cmx kernel/cemitcodes.cmx \ + kernel/names.cmx lib/rtree.cmx kernel/sign.cmx kernel/term.cmx \ + kernel/univ.cmx lib/util.cmx kernel/declarations.cmi kernel/entries.cmo: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \ kernel/univ.cmi kernel/entries.cmi kernel/entries.cmx: kernel/names.cmx kernel/sign.cmx kernel/term.cmx \ @@ -667,6 +699,12 @@ kernel/inductive.cmo: kernel/declarations.cmi kernel/environ.cmi \ kernel/inductive.cmx: kernel/declarations.cmx kernel/environ.cmx \ kernel/names.cmx kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \ kernel/type_errors.cmx kernel/univ.cmx lib/util.cmx kernel/inductive.cmi +kernel/modops.cmo: kernel/declarations.cmi kernel/entries.cmi \ + kernel/environ.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \ + kernel/univ.cmi lib/util.cmi kernel/modops.cmi +kernel/modops.cmx: kernel/declarations.cmx kernel/entries.cmx \ + kernel/environ.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \ + kernel/univ.cmx lib/util.cmx kernel/modops.cmi kernel/mod_typing.cmo: kernel/declarations.cmi kernel/entries.cmi \ kernel/environ.cmi kernel/modops.cmi kernel/names.cmi \ kernel/reduction.cmi kernel/subtyping.cmi kernel/term_typing.cmi \ @@ -675,12 +713,6 @@ kernel/mod_typing.cmx: kernel/declarations.cmx kernel/entries.cmx \ kernel/environ.cmx kernel/modops.cmx kernel/names.cmx \ kernel/reduction.cmx kernel/subtyping.cmx kernel/term_typing.cmx \ kernel/typeops.cmx kernel/univ.cmx lib/util.cmx kernel/mod_typing.cmi -kernel/modops.cmo: kernel/declarations.cmi kernel/entries.cmi \ - kernel/environ.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \ - kernel/univ.cmi lib/util.cmi kernel/modops.cmi -kernel/modops.cmx: kernel/declarations.cmx kernel/entries.cmx \ - kernel/environ.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \ - kernel/univ.cmx lib/util.cmx kernel/modops.cmi kernel/names.cmo: lib/hashcons.cmi lib/options.cmi lib/pp.cmi \ lib/predicate.cmi lib/util.cmi kernel/names.cmi kernel/names.cmx: lib/hashcons.cmx lib/options.cmx lib/pp.cmx \ @@ -723,16 +755,18 @@ kernel/term.cmo: kernel/esubst.cmi lib/hashcons.cmi kernel/names.cmi \ lib/pp.cmi kernel/univ.cmi lib/util.cmi kernel/term.cmi kernel/term.cmx: kernel/esubst.cmx lib/hashcons.cmx kernel/names.cmx \ lib/pp.cmx kernel/univ.cmx lib/util.cmx kernel/term.cmi -kernel/term_typing.cmo: kernel/cooking.cmi kernel/declarations.cmi \ - kernel/entries.cmi kernel/environ.cmi kernel/indtypes.cmi \ - kernel/inductive.cmi kernel/names.cmi kernel/reduction.cmi \ - kernel/sign.cmi kernel/term.cmi kernel/type_errors.cmi kernel/typeops.cmi \ - kernel/univ.cmi lib/util.cmi kernel/term_typing.cmi -kernel/term_typing.cmx: kernel/cooking.cmx kernel/declarations.cmx \ - kernel/entries.cmx kernel/environ.cmx kernel/indtypes.cmx \ - kernel/inductive.cmx kernel/names.cmx kernel/reduction.cmx \ - kernel/sign.cmx kernel/term.cmx kernel/type_errors.cmx kernel/typeops.cmx \ - kernel/univ.cmx lib/util.cmx kernel/term_typing.cmi +kernel/term_typing.cmo: kernel/cbytegen.cmi kernel/cemitcodes.cmi \ + kernel/cooking.cmi kernel/declarations.cmi kernel/entries.cmi \ + kernel/environ.cmi kernel/indtypes.cmi kernel/inductive.cmi \ + kernel/names.cmi kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \ + kernel/type_errors.cmi kernel/typeops.cmi kernel/univ.cmi lib/util.cmi \ + kernel/term_typing.cmi +kernel/term_typing.cmx: kernel/cbytegen.cmx kernel/cemitcodes.cmx \ + kernel/cooking.cmx kernel/declarations.cmx kernel/entries.cmx \ + kernel/environ.cmx kernel/indtypes.cmx kernel/inductive.cmx \ + kernel/names.cmx kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \ + kernel/type_errors.cmx kernel/typeops.cmx kernel/univ.cmx lib/util.cmx \ + kernel/term_typing.cmi kernel/type_errors.cmo: kernel/environ.cmi kernel/names.cmi \ kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \ kernel/type_errors.cmi @@ -751,6 +785,20 @@ kernel/univ.cmo: lib/hashcons.cmi kernel/names.cmi lib/pp.cmi lib/util.cmi \ kernel/univ.cmi kernel/univ.cmx: lib/hashcons.cmx kernel/names.cmx lib/pp.cmx lib/util.cmx \ kernel/univ.cmi +kernel/vconv.cmo: kernel/cbytecodes.cmi kernel/closure.cmi \ + kernel/conv_oracle.cmi kernel/csymtable.cmi kernel/declarations.cmi \ + kernel/environ.cmi kernel/inductive.cmi kernel/names.cmi \ + kernel/reduction.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi \ + kernel/vm.cmi kernel/vconv.cmi +kernel/vconv.cmx: kernel/cbytecodes.cmx kernel/closure.cmx \ + kernel/conv_oracle.cmx kernel/csymtable.cmx kernel/declarations.cmx \ + kernel/environ.cmx kernel/inductive.cmx kernel/names.cmx \ + kernel/reduction.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx \ + kernel/vm.cmx kernel/vconv.cmi +kernel/vm.cmo: kernel/cbytecodes.cmi kernel/conv_oracle.cmi kernel/names.cmi \ + kernel/term.cmi lib/util.cmi kernel/vm.cmi +kernel/vm.cmx: kernel/cbytecodes.cmx kernel/conv_oracle.cmx kernel/names.cmx \ + kernel/term.cmx lib/util.cmx kernel/vm.cmi lib/bignat.cmo: lib/pp.cmi lib/bignat.cmi lib/bignat.cmx: lib/pp.cmx lib/bignat.cmi lib/bstack.cmo: lib/util.cmi lib/bstack.cmi @@ -761,10 +809,10 @@ lib/edit.cmo: lib/bstack.cmi lib/pp.cmi lib/util.cmi lib/edit.cmi lib/edit.cmx: lib/bstack.cmx lib/pp.cmx lib/util.cmx lib/edit.cmi lib/explore.cmo: lib/explore.cmi lib/explore.cmx: lib/explore.cmi -lib/gmap.cmo: lib/gmap.cmi -lib/gmap.cmx: lib/gmap.cmi lib/gmapl.cmo: lib/gmap.cmi lib/util.cmi lib/gmapl.cmi lib/gmapl.cmx: lib/gmap.cmx lib/util.cmx lib/gmapl.cmi +lib/gmap.cmo: lib/gmap.cmi +lib/gmap.cmx: lib/gmap.cmi lib/gset.cmo: lib/gset.cmi lib/gset.cmx: lib/gset.cmi lib/hashcons.cmo: lib/hashcons.cmi @@ -773,24 +821,14 @@ lib/heap.cmo: lib/heap.cmi lib/heap.cmx: lib/heap.cmi lib/options.cmo: lib/util.cmi lib/options.cmi lib/options.cmx: lib/util.cmx lib/options.cmi -lib/pp.cmo: lib/pp_control.cmi lib/pp.cmi -lib/pp.cmx: lib/pp_control.cmx lib/pp.cmi lib/pp_control.cmo: lib/pp_control.cmi lib/pp_control.cmx: lib/pp_control.cmi +lib/pp.cmo: lib/pp_control.cmi lib/pp.cmi +lib/pp.cmx: lib/pp_control.cmx lib/pp.cmi lib/predicate.cmo: lib/predicate.cmi lib/predicate.cmx: lib/predicate.cmi lib/profile.cmo: lib/profile.cmi lib/profile.cmx: lib/profile.cmi -lib/rtree.cmo: lib/pp.cmi lib/util.cmi lib/rtree.cmi -lib/rtree.cmx: lib/pp.cmx lib/util.cmx lib/rtree.cmi -lib/stamps.cmo: lib/stamps.cmi -lib/stamps.cmx: lib/stamps.cmi -lib/system.cmo: config/coq_config.cmi lib/pp.cmi lib/util.cmi lib/system.cmi -lib/system.cmx: config/coq_config.cmx lib/pp.cmx lib/util.cmx lib/system.cmi -lib/tlm.cmo: lib/gmap.cmi lib/gset.cmi lib/tlm.cmi -lib/tlm.cmx: lib/gmap.cmx lib/gset.cmx lib/tlm.cmi -lib/util.cmo: lib/compat.cmo lib/pp.cmi lib/util.cmi -lib/util.cmx: lib/compat.cmx lib/pp.cmx lib/util.cmi library/declare.cmo: library/decl_kinds.cmo kernel/declarations.cmi \ library/dischargedhypsmap.cmi kernel/entries.cmi kernel/environ.cmi \ library/global.cmi library/impargs.cmi kernel/indtypes.cmi \ @@ -897,6 +935,16 @@ library/states.cmx: library/lib.cmx library/library.cmx library/summary.cmx \ lib/system.cmx library/states.cmi library/summary.cmo: lib/dyn.cmi lib/pp.cmi lib/util.cmi library/summary.cmi library/summary.cmx: lib/dyn.cmx lib/pp.cmx lib/util.cmx library/summary.cmi +lib/rtree.cmo: lib/pp.cmi lib/util.cmi lib/rtree.cmi +lib/rtree.cmx: lib/pp.cmx lib/util.cmx lib/rtree.cmi +lib/stamps.cmo: lib/stamps.cmi +lib/stamps.cmx: lib/stamps.cmi +lib/system.cmo: config/coq_config.cmi lib/pp.cmi lib/util.cmi lib/system.cmi +lib/system.cmx: config/coq_config.cmx lib/pp.cmx lib/util.cmx lib/system.cmi +lib/tlm.cmo: lib/gmap.cmi lib/gset.cmi lib/tlm.cmi +lib/tlm.cmx: lib/gmap.cmx lib/gset.cmx lib/tlm.cmi +lib/util.cmo: lib/compat.cmo lib/pp.cmi lib/util.cmi +lib/util.cmx: lib/compat.cmx lib/pp.cmx lib/util.cmi parsing/argextend.cmo: parsing/ast.cmi interp/genarg.cmi parsing/pcoq.cmi \ parsing/q_coqast.cmo parsing/q_util.cmi lib/util.cmi \ toplevel/vernacexpr.cmo @@ -1257,12 +1305,12 @@ pretyping/cases.cmx: pretyping/coercion.cmx kernel/declarations.cmx \ pretyping/reductionops.cmx pretyping/retyping.cmx kernel/sign.cmx \ kernel/term.cmx pretyping/termops.cmx kernel/type_errors.cmx \ kernel/typeops.cmx lib/util.cmx pretyping/cases.cmi -pretyping/cbv.cmo: kernel/closure.cmi kernel/environ.cmi kernel/esubst.cmi \ - pretyping/evd.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \ - kernel/univ.cmi lib/util.cmi pretyping/cbv.cmi -pretyping/cbv.cmx: kernel/closure.cmx kernel/environ.cmx kernel/esubst.cmx \ - pretyping/evd.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \ - kernel/univ.cmx lib/util.cmx pretyping/cbv.cmi +pretyping/cbv.cmo: kernel/closure.cmi kernel/conv_oracle.cmi \ + kernel/environ.cmi kernel/esubst.cmi pretyping/evd.cmi kernel/names.cmi \ + lib/pp.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi pretyping/cbv.cmi +pretyping/cbv.cmx: kernel/closure.cmx kernel/conv_oracle.cmx \ + kernel/environ.cmx kernel/esubst.cmx pretyping/evd.cmx kernel/names.cmx \ + lib/pp.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx pretyping/cbv.cmi pretyping/classops.cmo: library/decl_kinds.cmo kernel/environ.cmi \ pretyping/evd.cmi library/global.cmi lib/gmap.cmi library/goptions.cmi \ library/lib.cmi library/libnames.cmi library/libobject.cmi \ @@ -1280,7 +1328,7 @@ pretyping/classops.cmx: library/decl_kinds.cmx kernel/environ.cmx \ pretyping/clenv.cmo: pretyping/coercion.cmi kernel/environ.cmi \ pretyping/evarutil.cmi pretyping/evd.cmi library/global.cmi \ library/nameops.cmi kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi \ - pretyping/pretype_errors.cmi pretyping/rawterm.cmi \ + pretyping/pretype_errors.cmi pretyping/rawterm.cmi kernel/reduction.cmi \ pretyping/reductionops.cmi pretyping/retyping.cmi kernel/sign.cmi \ proofs/tacexpr.cmo pretyping/tacred.cmi kernel/term.cmi \ pretyping/termops.cmi pretyping/typing.cmi pretyping/unification.cmi \ @@ -1288,7 +1336,7 @@ pretyping/clenv.cmo: pretyping/coercion.cmi kernel/environ.cmi \ pretyping/clenv.cmx: pretyping/coercion.cmx kernel/environ.cmx \ pretyping/evarutil.cmx pretyping/evd.cmx library/global.cmx \ library/nameops.cmx kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx \ - pretyping/pretype_errors.cmx pretyping/rawterm.cmx \ + pretyping/pretype_errors.cmx pretyping/rawterm.cmx kernel/reduction.cmx \ pretyping/reductionops.cmx pretyping/retyping.cmx kernel/sign.cmx \ proofs/tacexpr.cmx pretyping/tacred.cmx kernel/term.cmx \ pretyping/termops.cmx pretyping/typing.cmx pretyping/unification.cmx \ @@ -1329,22 +1377,24 @@ pretyping/evarconv.cmx: pretyping/classops.cmx kernel/closure.cmx \ pretyping/typing.cmx lib/util.cmx pretyping/evarconv.cmi pretyping/evarutil.cmo: kernel/environ.cmi pretyping/evd.cmi \ library/nameops.cmi kernel/names.cmi lib/pp.cmi \ - pretyping/pretype_errors.cmi pretyping/reductionops.cmi kernel/sign.cmi \ - kernel/term.cmi pretyping/termops.cmi kernel/type_errors.cmi \ - kernel/typeops.cmi pretyping/typing.cmi kernel/univ.cmi lib/util.cmi \ - pretyping/evarutil.cmi + pretyping/pretype_errors.cmi kernel/reduction.cmi \ + pretyping/reductionops.cmi kernel/sign.cmi kernel/term.cmi \ + pretyping/termops.cmi kernel/type_errors.cmi kernel/typeops.cmi \ + pretyping/typing.cmi kernel/univ.cmi lib/util.cmi pretyping/evarutil.cmi pretyping/evarutil.cmx: kernel/environ.cmx pretyping/evd.cmx \ library/nameops.cmx kernel/names.cmx lib/pp.cmx \ - pretyping/pretype_errors.cmx pretyping/reductionops.cmx kernel/sign.cmx \ - kernel/term.cmx pretyping/termops.cmx kernel/type_errors.cmx \ - kernel/typeops.cmx pretyping/typing.cmx kernel/univ.cmx lib/util.cmx \ - pretyping/evarutil.cmi + pretyping/pretype_errors.cmx kernel/reduction.cmx \ + pretyping/reductionops.cmx kernel/sign.cmx kernel/term.cmx \ + pretyping/termops.cmx kernel/type_errors.cmx kernel/typeops.cmx \ + pretyping/typing.cmx kernel/univ.cmx lib/util.cmx pretyping/evarutil.cmi pretyping/evd.cmo: kernel/environ.cmi library/global.cmi library/libnames.cmi \ - library/nameops.cmi kernel/names.cmi lib/pp.cmi kernel/sign.cmi \ - kernel/term.cmi pretyping/termops.cmi lib/util.cmi pretyping/evd.cmi + library/nameops.cmi kernel/names.cmi lib/pp.cmi kernel/reduction.cmi \ + kernel/sign.cmi kernel/term.cmi pretyping/termops.cmi lib/util.cmi \ + pretyping/evd.cmi pretyping/evd.cmx: kernel/environ.cmx library/global.cmx library/libnames.cmx \ - library/nameops.cmx kernel/names.cmx lib/pp.cmx kernel/sign.cmx \ - kernel/term.cmx pretyping/termops.cmx lib/util.cmx pretyping/evd.cmi + library/nameops.cmx kernel/names.cmx lib/pp.cmx kernel/reduction.cmx \ + kernel/sign.cmx kernel/term.cmx pretyping/termops.cmx lib/util.cmx \ + pretyping/evd.cmi pretyping/indrec.cmo: kernel/declarations.cmi kernel/entries.cmi \ kernel/environ.cmi library/global.cmi kernel/indtypes.cmi \ kernel/inductive.cmi pretyping/inductiveops.cmi library/libnames.cmi \ @@ -1459,16 +1509,16 @@ pretyping/tacred.cmo: pretyping/cbv.cmi kernel/closure.cmi \ library/libnames.cmi library/nameops.cmi kernel/names.cmi \ library/nametab.cmi lib/pp.cmi pretyping/rawterm.cmi \ pretyping/reductionops.cmi pretyping/retyping.cmi library/summary.cmi \ - kernel/term.cmi pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \ - pretyping/tacred.cmi + kernel/term.cmi pretyping/termops.cmi kernel/typeops.cmi \ + pretyping/typing.cmi lib/util.cmi kernel/vconv.cmi pretyping/tacred.cmi pretyping/tacred.cmx: pretyping/cbv.cmx kernel/closure.cmx \ kernel/conv_oracle.cmx kernel/declarations.cmx kernel/environ.cmx \ pretyping/evd.cmx library/global.cmx kernel/inductive.cmx \ library/libnames.cmx library/nameops.cmx kernel/names.cmx \ library/nametab.cmx lib/pp.cmx pretyping/rawterm.cmx \ pretyping/reductionops.cmx pretyping/retyping.cmx library/summary.cmx \ - kernel/term.cmx pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \ - pretyping/tacred.cmi + kernel/term.cmx pretyping/termops.cmx kernel/typeops.cmx \ + pretyping/typing.cmx lib/util.cmx kernel/vconv.cmx pretyping/tacred.cmi pretyping/termops.cmo: kernel/environ.cmi library/global.cmi library/lib.cmi \ library/libnames.cmi library/nameops.cmi kernel/names.cmi \ library/nametab.cmi lib/pp.cmi kernel/sign.cmi kernel/term.cmi \ @@ -1488,31 +1538,35 @@ pretyping/typing.cmx: kernel/environ.cmx pretyping/evd.cmx \ pretyping/unification.cmo: kernel/environ.cmi pretyping/evarutil.cmi \ pretyping/evd.cmi library/global.cmi library/nameops.cmi kernel/names.cmi \ pretyping/pattern.cmi lib/pp.cmi pretyping/pretype_errors.cmi \ - pretyping/rawterm.cmi pretyping/reductionops.cmi pretyping/retyping.cmi \ - kernel/sign.cmi kernel/term.cmi pretyping/termops.cmi \ - pretyping/typing.cmi lib/util.cmi pretyping/unification.cmi + pretyping/rawterm.cmi kernel/reduction.cmi pretyping/reductionops.cmi \ + pretyping/retyping.cmi kernel/sign.cmi kernel/term.cmi \ + pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \ + pretyping/unification.cmi pretyping/unification.cmx: kernel/environ.cmx pretyping/evarutil.cmx \ pretyping/evd.cmx library/global.cmx library/nameops.cmx kernel/names.cmx \ pretyping/pattern.cmx lib/pp.cmx pretyping/pretype_errors.cmx \ - pretyping/rawterm.cmx pretyping/reductionops.cmx pretyping/retyping.cmx \ - kernel/sign.cmx kernel/term.cmx pretyping/termops.cmx \ - pretyping/typing.cmx lib/util.cmx pretyping/unification.cmi + pretyping/rawterm.cmx kernel/reduction.cmx pretyping/reductionops.cmx \ + pretyping/retyping.cmx kernel/sign.cmx kernel/term.cmx \ + pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \ + pretyping/unification.cmi proofs/clenvtac.cmo: pretyping/clenv.cmi kernel/environ.cmi \ proofs/evar_refiner.cmi pretyping/evarutil.cmi pretyping/evd.cmi \ proofs/logic.cmi library/nameops.cmi kernel/names.cmi \ pretyping/pattern.cmi lib/pp.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi pretyping/rawterm.cmi pretyping/reductionops.cmi \ - proofs/refiner.cmi kernel/sign.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \ - kernel/term.cmi pretyping/termops.cmi pretyping/typing.cmi \ - pretyping/unification.cmi lib/util.cmi proofs/clenvtac.cmi + proofs/proof_type.cmi pretyping/rawterm.cmi kernel/reduction.cmi \ + pretyping/reductionops.cmi proofs/refiner.cmi kernel/sign.cmi \ + proofs/tacexpr.cmo proofs/tacmach.cmi kernel/term.cmi \ + pretyping/termops.cmi pretyping/typing.cmi pretyping/unification.cmi \ + lib/util.cmi proofs/clenvtac.cmi proofs/clenvtac.cmx: pretyping/clenv.cmx kernel/environ.cmx \ proofs/evar_refiner.cmx pretyping/evarutil.cmx pretyping/evd.cmx \ proofs/logic.cmx library/nameops.cmx kernel/names.cmx \ pretyping/pattern.cmx lib/pp.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx pretyping/rawterm.cmx pretyping/reductionops.cmx \ - proofs/refiner.cmx kernel/sign.cmx proofs/tacexpr.cmx proofs/tacmach.cmx \ - kernel/term.cmx pretyping/termops.cmx pretyping/typing.cmx \ - pretyping/unification.cmx lib/util.cmx proofs/clenvtac.cmi + proofs/proof_type.cmx pretyping/rawterm.cmx kernel/reduction.cmx \ + pretyping/reductionops.cmx proofs/refiner.cmx kernel/sign.cmx \ + proofs/tacexpr.cmx proofs/tacmach.cmx kernel/term.cmx \ + pretyping/termops.cmx pretyping/typing.cmx pretyping/unification.cmx \ + lib/util.cmx proofs/clenvtac.cmi proofs/evar_refiner.cmo: interp/constrintern.cmi pretyping/evarutil.cmi \ pretyping/evd.cmi kernel/names.cmi pretyping/pretyping.cmi \ proofs/proof_trees.cmi proofs/refiner.cmi kernel/sign.cmi kernel/term.cmi \ @@ -1983,10 +2037,10 @@ tactics/tactics.cmo: pretyping/clenv.cmi proofs/clenvtac.cmi \ library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \ proofs/pfedit.cmi lib/pp.cmi pretyping/pretype_errors.cmi \ proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \ - pretyping/reductionops.cmi proofs/refiner.cmi kernel/sign.cmi \ - proofs/tacexpr.cmo proofs/tacmach.cmi pretyping/tacred.cmi \ - tactics/tacticals.cmi kernel/term.cmi pretyping/termops.cmi lib/util.cmi \ - tactics/tactics.cmi + kernel/reduction.cmi pretyping/reductionops.cmi proofs/refiner.cmi \ + kernel/sign.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \ + pretyping/tacred.cmi tactics/tacticals.cmi kernel/term.cmi \ + pretyping/termops.cmi lib/util.cmi tactics/tactics.cmi tactics/tactics.cmx: pretyping/clenv.cmx proofs/clenvtac.cmx \ interp/constrintern.cmx interp/coqlib.cmx library/decl_kinds.cmx \ kernel/declarations.cmx library/declare.cmx kernel/entries.cmx \ @@ -1997,10 +2051,10 @@ tactics/tactics.cmx: pretyping/clenv.cmx proofs/clenvtac.cmx \ library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \ proofs/pfedit.cmx lib/pp.cmx pretyping/pretype_errors.cmx \ proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \ - pretyping/reductionops.cmx proofs/refiner.cmx kernel/sign.cmx \ - proofs/tacexpr.cmx proofs/tacmach.cmx pretyping/tacred.cmx \ - tactics/tacticals.cmx kernel/term.cmx pretyping/termops.cmx lib/util.cmx \ - tactics/tactics.cmi + kernel/reduction.cmx pretyping/reductionops.cmx proofs/refiner.cmx \ + kernel/sign.cmx proofs/tacexpr.cmx proofs/tacmach.cmx \ + pretyping/tacred.cmx tactics/tacticals.cmx kernel/term.cmx \ + pretyping/termops.cmx lib/util.cmx tactics/tactics.cmi tactics/tauto.cmo: parsing/ast.cmi toplevel/cerrors.cmi parsing/coqast.cmi \ parsing/egrammar.cmi interp/genarg.cmi tactics/hipattern.cmi \ library/libnames.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \ @@ -2096,15 +2150,17 @@ toplevel/coqtop.cmo: toplevel/cerrors.cmi config/coq_config.cmi \ library/global.cmi library/lib.cmi library/libnames.cmi \ library/library.cmi toplevel/mltop.cmi library/nameops.cmi \ kernel/names.cmi lib/options.cmi lib/pp.cmi lib/profile.cmi \ - library/states.cmi lib/system.cmi toplevel/toplevel.cmi \ - toplevel/usage.cmi lib/util.cmi toplevel/vernac.cmi toplevel/coqtop.cmi + kernel/reduction.cmi library/states.cmi lib/system.cmi \ + toplevel/toplevel.cmi toplevel/usage.cmi lib/util.cmi toplevel/vernac.cmi \ + kernel/vm.cmi toplevel/coqtop.cmi toplevel/coqtop.cmx: toplevel/cerrors.cmx config/coq_config.cmx \ toplevel/coqinit.cmx library/declaremods.cmx kernel/environ.cmx \ library/global.cmx library/lib.cmx library/libnames.cmx \ library/library.cmx toplevel/mltop.cmx library/nameops.cmx \ kernel/names.cmx lib/options.cmx lib/pp.cmx lib/profile.cmx \ - library/states.cmx lib/system.cmx toplevel/toplevel.cmx \ - toplevel/usage.cmx lib/util.cmx toplevel/vernac.cmx toplevel/coqtop.cmi + kernel/reduction.cmx library/states.cmx lib/system.cmx \ + toplevel/toplevel.cmx toplevel/usage.cmx lib/util.cmx toplevel/vernac.cmx \ + kernel/vm.cmx toplevel/coqtop.cmi toplevel/discharge.cmo: toplevel/class.cmi pretyping/classops.cmi \ kernel/cooking.cmi library/decl_kinds.cmo kernel/declarations.cmi \ library/declare.cmi library/dischargedhypsmap.cmi kernel/entries.cmi \ @@ -2231,20 +2287,6 @@ toplevel/toplevel.cmx: toplevel/cerrors.cmx library/lib.cmx \ toplevel/vernac.cmx toplevel/vernacexpr.cmx toplevel/toplevel.cmi toplevel/usage.cmo: config/coq_config.cmi toplevel/usage.cmi toplevel/usage.cmx: config/coq_config.cmx toplevel/usage.cmi -toplevel/vernac.cmo: interp/constrextern.cmi interp/constrintern.cmi \ - parsing/coqast.cmi parsing/lexer.cmi library/lib.cmi library/library.cmi \ - kernel/names.cmi lib/options.cmi parsing/pcoq.cmi proofs/pfedit.cmi \ - lib/pp.cmi translate/ppvernacnew.cmi proofs/refiner.cmi \ - library/states.cmi lib/system.cmi tactics/tacinterp.cmi \ - proofs/tacmach.cmi lib/util.cmi toplevel/vernacentries.cmi \ - toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi toplevel/vernac.cmi -toplevel/vernac.cmx: interp/constrextern.cmx interp/constrintern.cmx \ - parsing/coqast.cmx parsing/lexer.cmx library/lib.cmx library/library.cmx \ - kernel/names.cmx lib/options.cmx parsing/pcoq.cmx proofs/pfedit.cmx \ - lib/pp.cmx translate/ppvernacnew.cmx proofs/refiner.cmx \ - library/states.cmx lib/system.cmx tactics/tacinterp.cmx \ - proofs/tacmach.cmx lib/util.cmx toplevel/vernacentries.cmx \ - toplevel/vernacexpr.cmx toplevel/vernacinterp.cmx toplevel/vernac.cmi toplevel/vernacentries.cmo: tactics/auto.cmi toplevel/class.cmi \ pretyping/classops.cmi toplevel/command.cmi interp/constrextern.cmi \ interp/constrintern.cmi library/decl_kinds.cmo library/declaremods.cmi \ @@ -2258,15 +2300,15 @@ toplevel/vernacentries.cmo: tactics/auto.cmi toplevel/class.cmi \ lib/pp_control.cmi parsing/prettyp.cmi pretyping/pretyping.cmi \ parsing/printer.cmi parsing/printmod.cmi proofs/proof_trees.cmi \ proofs/proof_type.cmi pretyping/rawterm.cmi toplevel/record.cmi \ - toplevel/recordobj.cmi pretyping/reductionops.cmi interp/reserve.cmi \ - kernel/safe_typing.cmi parsing/search.cmi tactics/setoid_replace.cmi \ - library/states.cmi interp/symbols.cmi interp/syntax_def.cmi \ - lib/system.cmi proofs/tacexpr.cmo tactics/tacinterp.cmi \ - proofs/tacmach.cmi pretyping/tacred.cmi proofs/tactic_debug.cmi \ - parsing/tactic_printer.cmi tactics/tactics.cmi kernel/term.cmi \ - interp/topconstr.cmi kernel/typeops.cmi kernel/univ.cmi lib/util.cmi \ - toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi \ - toplevel/vernacentries.cmi + toplevel/recordobj.cmi kernel/reduction.cmi pretyping/reductionops.cmi \ + interp/reserve.cmi kernel/safe_typing.cmi parsing/search.cmi \ + tactics/setoid_replace.cmi library/states.cmi interp/symbols.cmi \ + interp/syntax_def.cmi lib/system.cmi proofs/tacexpr.cmo \ + tactics/tacinterp.cmi proofs/tacmach.cmi pretyping/tacred.cmi \ + proofs/tactic_debug.cmi parsing/tactic_printer.cmi tactics/tactics.cmi \ + kernel/term.cmi interp/topconstr.cmi kernel/typeops.cmi kernel/univ.cmi \ + lib/util.cmi toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi \ + kernel/vm.cmi toplevel/vernacentries.cmi toplevel/vernacentries.cmx: tactics/auto.cmx toplevel/class.cmx \ pretyping/classops.cmx toplevel/command.cmx interp/constrextern.cmx \ interp/constrintern.cmx library/decl_kinds.cmx library/declaremods.cmx \ @@ -2280,15 +2322,15 @@ toplevel/vernacentries.cmx: tactics/auto.cmx toplevel/class.cmx \ lib/pp_control.cmx parsing/prettyp.cmx pretyping/pretyping.cmx \ parsing/printer.cmx parsing/printmod.cmx proofs/proof_trees.cmx \ proofs/proof_type.cmx pretyping/rawterm.cmx toplevel/record.cmx \ - toplevel/recordobj.cmx pretyping/reductionops.cmx interp/reserve.cmx \ - kernel/safe_typing.cmx parsing/search.cmx tactics/setoid_replace.cmx \ - library/states.cmx interp/symbols.cmx interp/syntax_def.cmx \ - lib/system.cmx proofs/tacexpr.cmx tactics/tacinterp.cmx \ - proofs/tacmach.cmx pretyping/tacred.cmx proofs/tactic_debug.cmx \ - parsing/tactic_printer.cmx tactics/tactics.cmx kernel/term.cmx \ - interp/topconstr.cmx kernel/typeops.cmx kernel/univ.cmx lib/util.cmx \ - toplevel/vernacexpr.cmx toplevel/vernacinterp.cmx \ - toplevel/vernacentries.cmi + toplevel/recordobj.cmx kernel/reduction.cmx pretyping/reductionops.cmx \ + interp/reserve.cmx kernel/safe_typing.cmx parsing/search.cmx \ + tactics/setoid_replace.cmx library/states.cmx interp/symbols.cmx \ + interp/syntax_def.cmx lib/system.cmx proofs/tacexpr.cmx \ + tactics/tacinterp.cmx proofs/tacmach.cmx pretyping/tacred.cmx \ + proofs/tactic_debug.cmx parsing/tactic_printer.cmx tactics/tactics.cmx \ + kernel/term.cmx interp/topconstr.cmx kernel/typeops.cmx kernel/univ.cmx \ + lib/util.cmx toplevel/vernacexpr.cmx toplevel/vernacinterp.cmx \ + kernel/vm.cmx toplevel/vernacentries.cmi toplevel/vernacexpr.cmo: library/decl_kinds.cmo parsing/extend.cmi \ interp/genarg.cmi library/goptions.cmi library/libnames.cmi \ kernel/names.cmi library/nametab.cmi interp/ppextend.cmi \ @@ -2309,6 +2351,20 @@ toplevel/vernacinterp.cmx: parsing/ast.cmx parsing/coqast.cmx \ kernel/names.cmx lib/options.cmx lib/pp.cmx proofs/proof_type.cmx \ proofs/tacexpr.cmx tactics/tacinterp.cmx lib/util.cmx \ toplevel/vernacexpr.cmx toplevel/vernacinterp.cmi +toplevel/vernac.cmo: interp/constrextern.cmi interp/constrintern.cmi \ + parsing/coqast.cmi parsing/lexer.cmi library/lib.cmi library/library.cmi \ + kernel/names.cmi lib/options.cmi parsing/pcoq.cmi proofs/pfedit.cmi \ + lib/pp.cmi translate/ppvernacnew.cmi proofs/refiner.cmi \ + library/states.cmi lib/system.cmi tactics/tacinterp.cmi \ + proofs/tacmach.cmi lib/util.cmi toplevel/vernacentries.cmi \ + toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi toplevel/vernac.cmi +toplevel/vernac.cmx: interp/constrextern.cmx interp/constrintern.cmx \ + parsing/coqast.cmx parsing/lexer.cmx library/lib.cmx library/library.cmx \ + kernel/names.cmx lib/options.cmx parsing/pcoq.cmx proofs/pfedit.cmx \ + lib/pp.cmx translate/ppvernacnew.cmx proofs/refiner.cmx \ + library/states.cmx lib/system.cmx tactics/tacinterp.cmx \ + proofs/tacmach.cmx lib/util.cmx toplevel/vernacentries.cmx \ + toplevel/vernacexpr.cmx toplevel/vernacinterp.cmx toplevel/vernac.cmi translate/ppconstrnew.cmo: parsing/ast.cmi lib/bignat.cmi \ interp/constrextern.cmi interp/constrintern.cmi parsing/coqast.cmi \ pretyping/evd.cmi interp/genarg.cmi library/global.cmi library/lib.cmi \ @@ -2397,6 +2453,12 @@ contrib/cc/cctac.cmx: contrib/cc/ccalgo.cmx contrib/cc/ccproof.cmx \ proofs/refiner.cmx kernel/sign.cmx proofs/tacexpr.cmx \ tactics/tacinterp.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ tactics/tactics.cmx kernel/term.cmx pretyping/termops.cmx lib/util.cmx +contrib/correctness/pcicenv.cmo: library/global.cmi kernel/names.cmi \ + kernel/sign.cmi kernel/term.cmi kernel/univ.cmi \ + contrib/correctness/pcicenv.cmi +contrib/correctness/pcicenv.cmx: library/global.cmx kernel/names.cmx \ + kernel/sign.cmx kernel/term.cmx kernel/univ.cmx \ + contrib/correctness/pcicenv.cmi contrib/correctness/pcic.cmo: kernel/declarations.cmi library/declare.cmi \ pretyping/detyping.cmi kernel/entries.cmi library/global.cmi \ kernel/indtypes.cmi library/libnames.cmi library/nameops.cmi \ @@ -2411,12 +2473,6 @@ contrib/correctness/pcic.cmx: kernel/declarations.cmx library/declare.cmx \ toplevel/record.cmx kernel/sign.cmx kernel/term.cmx pretyping/termops.cmx \ interp/topconstr.cmx kernel/typeops.cmx lib/util.cmx \ toplevel/vernacexpr.cmx contrib/correctness/pcic.cmi -contrib/correctness/pcicenv.cmo: library/global.cmi kernel/names.cmi \ - kernel/sign.cmi kernel/term.cmi kernel/univ.cmi \ - contrib/correctness/pcicenv.cmi -contrib/correctness/pcicenv.cmx: library/global.cmx kernel/names.cmx \ - kernel/sign.cmx kernel/term.cmx kernel/univ.cmx \ - contrib/correctness/pcicenv.cmi contrib/correctness/pdb.cmo: interp/constrintern.cmi library/global.cmi \ kernel/names.cmi library/nametab.cmi kernel/term.cmi \ pretyping/termops.cmi contrib/correctness/pdb.cmi @@ -2999,6 +3055,14 @@ contrib/interface/pbp.cmx: interp/coqlib.cmx kernel/environ.cmx \ proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ kernel/term.cmx pretyping/termops.cmx interp/topconstr.cmx \ pretyping/typing.cmx lib/util.cmx contrib/interface/pbp.cmi +contrib/interface/showproof_ct.cmo: contrib/interface/ascent.cmi \ + parsing/esyntax.cmi library/global.cmi toplevel/metasyntax.cmi lib/pp.cmi \ + parsing/printer.cmi contrib/interface/translate.cmi \ + contrib/interface/vtp.cmi contrib/interface/xlate.cmi +contrib/interface/showproof_ct.cmx: contrib/interface/ascent.cmi \ + parsing/esyntax.cmx library/global.cmx toplevel/metasyntax.cmx lib/pp.cmx \ + parsing/printer.cmx contrib/interface/translate.cmx \ + contrib/interface/vtp.cmx contrib/interface/xlate.cmx contrib/interface/showproof.cmo: pretyping/clenv.cmi interp/constrintern.cmi \ parsing/coqast.cmi kernel/declarations.cmi kernel/environ.cmi \ pretyping/evd.cmi interp/genarg.cmi library/global.cmi \ @@ -3023,14 +3087,6 @@ contrib/interface/showproof.cmx: pretyping/clenv.cmx interp/constrintern.cmx \ pretyping/termops.cmx contrib/interface/translate.cmx \ pretyping/typing.cmx lib/util.cmx toplevel/vernacinterp.cmx \ contrib/interface/showproof.cmi -contrib/interface/showproof_ct.cmo: contrib/interface/ascent.cmi \ - parsing/esyntax.cmi library/global.cmi toplevel/metasyntax.cmi lib/pp.cmi \ - parsing/printer.cmi contrib/interface/translate.cmi \ - contrib/interface/vtp.cmi contrib/interface/xlate.cmi -contrib/interface/showproof_ct.cmx: contrib/interface/ascent.cmi \ - parsing/esyntax.cmx library/global.cmx toplevel/metasyntax.cmx lib/pp.cmx \ - parsing/printer.cmx contrib/interface/translate.cmx \ - contrib/interface/vtp.cmx contrib/interface/xlate.cmx contrib/interface/translate.cmo: contrib/interface/ascent.cmi parsing/ast.cmi \ interp/constrextern.cmi contrib/interface/ctast.cmo kernel/environ.cmi \ pretyping/evarutil.cmi pretyping/evd.cmi library/libobject.cmi \ @@ -3213,12 +3269,12 @@ contrib/romega/refl_omega.cmx: contrib/romega/const_omega.cmx \ proofs/logic.cmx kernel/names.cmx contrib/romega/omega2.cmx \ lib/options.cmx lib/pp.cmx parsing/printer.cmx proofs/tacmach.cmx \ tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx lib/util.cmx -contrib/xml/acic.cmo: kernel/names.cmi kernel/term.cmi -contrib/xml/acic.cmx: kernel/names.cmx kernel/term.cmx contrib/xml/acic2Xml.cmo: contrib/xml/acic.cmo contrib/xml/cic2acic.cmo \ kernel/names.cmi kernel/term.cmi lib/util.cmi contrib/xml/xml.cmi contrib/xml/acic2Xml.cmx: contrib/xml/acic.cmx contrib/xml/cic2acic.cmx \ kernel/names.cmx kernel/term.cmx lib/util.cmx contrib/xml/xml.cmx +contrib/xml/acic.cmo: kernel/names.cmi kernel/term.cmi +contrib/xml/acic.cmx: kernel/names.cmx kernel/term.cmx contrib/xml/cic2acic.cmo: contrib/xml/acic.cmo kernel/declarations.cmi \ library/declare.cmi library/dischargedhypsmap.cmi \ contrib/xml/doubleTypeInference.cmi kernel/environ.cmi pretyping/evd.cmi \ @@ -3279,8 +3335,6 @@ contrib/xml/proofTree2Xml.cmx: contrib/xml/acic.cmx contrib/xml/acic2Xml.cmx \ contrib/xml/unshare.cmx lib/util.cmx contrib/xml/xml.cmx contrib/xml/unshare.cmo: contrib/xml/unshare.cmi contrib/xml/unshare.cmx: contrib/xml/unshare.cmi -contrib/xml/xml.cmo: contrib/xml/xml.cmi -contrib/xml/xml.cmx: contrib/xml/xml.cmi contrib/xml/xmlcommand.cmo: contrib/xml/acic.cmo contrib/xml/acic2Xml.cmo \ contrib/xml/cic2acic.cmo config/coq_config.cmi library/decl_kinds.cmo \ kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \ @@ -3309,10 +3363,8 @@ contrib/xml/xmlentries.cmo: toplevel/cerrors.cmi parsing/egrammar.cmi \ contrib/xml/xmlentries.cmx: toplevel/cerrors.cmx parsing/egrammar.cmx \ parsing/extend.cmx interp/genarg.cmx parsing/pcoq.cmx lib/pp.cmx \ lib/util.cmx toplevel/vernacinterp.cmx contrib/xml/xmlcommand.cmx -ide/utils/configwin.cmo: ide/utils/configwin_ihm.cmo \ - ide/utils/configwin_types.cmo ide/utils/configwin.cmi -ide/utils/configwin.cmx: ide/utils/configwin_ihm.cmx \ - ide/utils/configwin_types.cmx ide/utils/configwin.cmi +contrib/xml/xml.cmo: contrib/xml/xml.cmi +contrib/xml/xml.cmx: contrib/xml/xml.cmi ide/utils/configwin_html_config.cmo: ide/utils/configwin_ihm.cmo \ ide/utils/configwin_messages.cmo ide/utils/configwin_types.cmo \ ide/utils/uoptions.cmi @@ -3323,6 +3375,10 @@ ide/utils/configwin_ihm.cmo: ide/utils/configwin_messages.cmo \ ide/utils/configwin_types.cmo ide/utils/okey.cmi ide/utils/uoptions.cmi ide/utils/configwin_ihm.cmx: ide/utils/configwin_messages.cmx \ ide/utils/configwin_types.cmx ide/utils/okey.cmx ide/utils/uoptions.cmx +ide/utils/configwin.cmo: ide/utils/configwin_ihm.cmo \ + ide/utils/configwin_types.cmo ide/utils/configwin.cmi +ide/utils/configwin.cmx: ide/utils/configwin_ihm.cmx \ + ide/utils/configwin_types.cmx ide/utils/configwin.cmi ide/utils/configwin_types.cmo: ide/utils/configwin_keys.cmo \ ide/utils/uoptions.cmi ide/utils/configwin_types.cmx: ide/utils/configwin_keys.cmx \ @@ -3447,3 +3503,51 @@ tools/coq_makefile.cmo: tools/coq_makefile.cmx: tools/coq-tex.cmo: tools/coq-tex.cmx: +coq_fix_code.o: kernel/byterun/coq_fix_code.c \ + /usr/lib/ocaml/caml/config.h /usr/lib/ocaml/caml/misc.h \ + /usr/lib/ocaml/caml/mlvalues.h /usr/lib/ocaml/caml/fail.h \ + /usr/lib/ocaml/caml/memory.h kernel/byterun/coq_instruct.h \ + kernel/byterun/coq_fix_code.h +coq_interp.o: kernel/byterun/coq_interp.c kernel/byterun/coq_gc.h \ + /usr/lib/ocaml/caml/mlvalues.h /usr/lib/ocaml/caml/config.h \ + /usr/lib/ocaml/caml/misc.h /usr/lib/ocaml/caml/alloc.h \ + kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ + kernel/byterun/coq_memory.h /usr/lib/ocaml/caml/fail.h \ + /usr/lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \ + kernel/byterun/coq_jumptbl.h +coq_memory.o: kernel/byterun/coq_memory.c kernel/byterun/coq_gc.h \ + /usr/lib/ocaml/caml/mlvalues.h /usr/lib/ocaml/caml/config.h \ + /usr/lib/ocaml/caml/misc.h /usr/lib/ocaml/caml/alloc.h \ + kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ + kernel/byterun/coq_memory.h /usr/lib/ocaml/caml/fail.h \ + /usr/lib/ocaml/caml/memory.h +coq_values.o: kernel/byterun/coq_values.c kernel/byterun/coq_fix_code.h \ + /usr/lib/ocaml/caml/mlvalues.h /usr/lib/ocaml/caml/config.h \ + /usr/lib/ocaml/caml/misc.h kernel/byterun/coq_instruct.h \ + kernel/byterun/coq_memory.h /usr/lib/ocaml/caml/fail.h \ + /usr/lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \ + /usr/lib/ocaml/caml/alloc.h +coq_fix_code.d.o: kernel/byterun/coq_fix_code.c \ + /usr/lib/ocaml/caml/config.h /usr/lib/ocaml/caml/misc.h \ + /usr/lib/ocaml/caml/mlvalues.h /usr/lib/ocaml/caml/fail.h \ + /usr/lib/ocaml/caml/memory.h kernel/byterun/coq_instruct.h \ + kernel/byterun/coq_fix_code.h +coq_interp.d.o: kernel/byterun/coq_interp.c kernel/byterun/coq_gc.h \ + /usr/lib/ocaml/caml/mlvalues.h /usr/lib/ocaml/caml/config.h \ + /usr/lib/ocaml/caml/misc.h /usr/lib/ocaml/caml/alloc.h \ + kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ + kernel/byterun/coq_memory.h /usr/lib/ocaml/caml/fail.h \ + /usr/lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \ + kernel/byterun/coq_jumptbl.h +coq_memory.d.o: kernel/byterun/coq_memory.c kernel/byterun/coq_gc.h \ + /usr/lib/ocaml/caml/mlvalues.h /usr/lib/ocaml/caml/config.h \ + /usr/lib/ocaml/caml/misc.h /usr/lib/ocaml/caml/alloc.h \ + kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ + kernel/byterun/coq_memory.h /usr/lib/ocaml/caml/fail.h \ + /usr/lib/ocaml/caml/memory.h +coq_values.d.o: kernel/byterun/coq_values.c kernel/byterun/coq_fix_code.h \ + /usr/lib/ocaml/caml/mlvalues.h /usr/lib/ocaml/caml/config.h \ + /usr/lib/ocaml/caml/misc.h kernel/byterun/coq_instruct.h \ + kernel/byterun/coq_memory.h /usr/lib/ocaml/caml/fail.h \ + /usr/lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \ + /usr/lib/ocaml/caml/alloc.h @@ -63,7 +63,7 @@ else endif LOCALINCLUDES=-I config -I tools -I tools/coqdoc \ - -I scripts -I lib -I kernel -I library \ + -I scripts -I lib -I kernel -I kernel/byterun -I library \ -I proofs -I tactics -I pretyping \ -I interp -I toplevel -I parsing -I ide/utils \ -I ide -I translate \ @@ -73,7 +73,7 @@ LOCALINCLUDES=-I config -I tools -I tools/coqdoc \ -I contrib/interface -I contrib/fourier \ -I contrib/jprover -I contrib/cc \ -I contrib/funind -I contrib/first-order \ - -I contrib/field + -I contrib/field MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB) @@ -90,15 +90,21 @@ CAMLP4DEPS=sed -n -e 's|^(\*.*camlp4deps: "\(.*\)".*\*)$$|\1|p' COQINCLUDES= # coqtop includes itself the needed paths GLOB= # is "-dump-glob file" when making the doc COQ_XML= # is "-xml" when building XML library -COQOPTS=$(GLOB) $(COQ_XML) +VM= # is "-no-vm" to not use the vm" +UNBOXEDVALUES= # is "-unboxed-values" to use unboxed values +COQOPTS=$(GLOB) $(COQ_XML) $(VM) $(UNBOXEDVALUES) TRANSLATE=-translate -strict-implicit +TIME= # is "'time -p'" to get compilation time of .v + +BOOTCOQTOP= $(TIME) $(BESTCOQTOP) -boot $(COQOPTS) -BOOTCOQTOP=$(BESTCOQTOP) -boot $(COQOPTS) ########################################################################### # Objects files ########################################################################### +LIBCOQRUN=kernel/byterun/libcoqrun.a + CLIBS=unix.cma CAMLP4OBJS=gramlib.cma @@ -114,13 +120,21 @@ LIBREP=\ lib/predicate.cmo lib/rtree.cmo lib/heap.cmo # Rem: Cygwin already uses variable LIB +BYTERUN=\ + kernel/byterun/coq_fix_code.o kernel/byterun/coq_memory.o \ + kernel/byterun/coq_values.o kernel/byterun/coq_interp.o + KERNEL=\ kernel/names.cmo kernel/univ.cmo \ kernel/esubst.cmo kernel/term.cmo kernel/sign.cmo \ - kernel/declarations.cmo kernel/environ.cmo kernel/closure.cmo \ - kernel/conv_oracle.cmo kernel/reduction.cmo kernel/entries.cmo \ + kernel/cbytecodes.cmo kernel/copcodes.cmo \ + kernel/cemitcodes.cmo kernel/vm.cmo \ + kernel/declarations.cmo kernel/environ.cmo kernel/conv_oracle.cmo \ + kernel/closure.cmo kernel/reduction.cmo kernel/type_errors.cmo\ + kernel/entries.cmo \ + kernel/cbytegen.cmo kernel/csymtable.cmo \ kernel/modops.cmo \ - kernel/type_errors.cmo kernel/inductive.cmo kernel/typeops.cmo \ + kernel/inductive.cmo kernel/vconv.cmo kernel/typeops.cmo \ kernel/indtypes.cmo kernel/cooking.cmo kernel/term_typing.cmo \ kernel/subtyping.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo @@ -304,6 +318,41 @@ OBJSCMO=$(CONFIG) $(LIBREP) $(KERNEL) $(LIBRARY) $(PRETYPING) $(INTERP) \ $(HIGHPARSINGNEW) $(HIGHTACTICS) $(USERTACMO) $(CONTRIB) ########################################################################### +# Compilation option for .c files +########################################################################### + +CINCLUDES= -I $(CAMLHLIB) +CC=gcc +AR=ar +RANLIB=ranlib +BYTECCCOMPOPTS=-fno-defer-pop -Wall -Wno-unused + +# libcoqrun.a + +$(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN) + $(AR) rc $(LIBCOQRUN) $(BYTERUN) + $(RANLIB) $(LIBCOQRUN) + +#coq_jumptbl.h is required only if you have GCC 2.0 or later +kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h + sed -n -e '/^ /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' \ + -e '/^}/q' kernel/byterun/coq_instruct.h > \ + kernel/byterun/coq_jumptbl.h + + +kernel/copcodes.ml: kernel/byterun/coq_instruct.h + sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' \ + kernel/byterun/coq_instruct.h | \ + awk -f kernel/make-opcodes > kernel/copcodes.ml + +bytecompfile : kernel/byterun/coq_jumptbl.h kernel/copcodes.ml + +beforedepend:: bytecompfile + +clean :: + rm -f kernel/byterun/coq_jumptbl.h kernel/copcodes.ml + +########################################################################### # Main targets (coqmktop, coqtop.opt, coqtop.byte) ########################################################################### @@ -332,12 +381,12 @@ states7:: states7/initial.coq states:: states/initial.coq -$(COQTOPOPT): $(COQMKTOP) $(LINKCMX) $(USERTACCMX) +$(COQTOPOPT): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(USERTACCMX) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(COQMKTOP) -opt $(OPTFLAGS) -o $@ $(STRIP) $@ -$(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(USERTACCMO) +$(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(USERTACCMO) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(COQMKTOP) -top $(LOCALINCLUDES) $(CAMLDEBUG) -o $@ @@ -356,7 +405,7 @@ $(COQMKTOP): $(COQMKTOPCMO) scripts/tolink.ml: Makefile $(SHOW)"ECHO... >" $@ - $(HIDE)echo "let core_libs = \""$(LINKCMO)"\"" > $@ + $(HIDE)echo "let core_libs = \""$(LIBCOQRUN) $(LINKCMO)"\"" > $@ $(HIDE)echo "let core_objs = \""$(OBJSCMO)"\"" >> $@ $(HIDE)echo "let ide = \""$(COQIDECMO)"\"" >> $@ @@ -381,6 +430,7 @@ archclean:: lib: $(LIBREP) kernel: $(KERNEL) +byterun: $(BYTERUN) library: $(LIBRARY) proofs: $(PROOFS) tactics: $(TACTICS) @@ -644,7 +694,7 @@ INTERFACECMX=$(INTERFACE:.cmo=.cmx) ML4FILES += contrib/interface/debug_tac.ml4 contrib/interface/centaur.ml4 -PARSERREQUIRES=$(LINKCMO) # Solution de facilité... +PARSERREQUIRES=$(LINKCMO) $(LIBCOQRUN) # Solution de facilité... PARSERREQUIRESCMX=$(LINKCMX) ifeq ($(BEST),opt) @@ -676,7 +726,7 @@ bin/parser$(EXE): $(PARSERCMO) bin/parser.opt$(EXE): $(PARSERCMX) $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) -linkall -cclib -lunix $(OPTFLAGS) -o $@ \ - $(CMXA) $(PARSERCMX) + $(LIBCOQRUN) $(CMXA) $(PARSERCMX) INTERFACEVO= @@ -1027,9 +1077,13 @@ contrib/extraction/%.vo: contrib/extraction/%.v states/barestate.coq $(COQC) contrib7/extraction/%.vo: contrib7/extraction/%.v states/barestate.coq $(COQC) $(BOOTCOQTOP) $(TRANSLATE) -is states7/barestate.coq -compile $* -clean:: +cleantheories: rm -f states/*.coq states7/*.coq rm -f theories/*/*.vo theories7/*/*.vo + +clean :: cleantheories + +clean :: rm -f contrib/*/*.cm[io] contrib/*.cma contrib/*/*.vo contrib7/*/*.vo archclean:: @@ -1297,7 +1351,17 @@ GRAMMARNEEDEDCMO=\ lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/util.cmo lib/bignat.cmo \ lib/dyn.cmo lib/options.cmo lib/hashcons.cmo lib/predicate.cmo \ lib/rtree.cmo \ - $(KERNEL) \ + kernel/names.cmo kernel/univ.cmo \ + kernel/esubst.cmo kernel/term.cmo kernel/sign.cmo \ + kernel/cbytecodes.cmo kernel/copcodes.cmo kernel/cemitcodes.cmo \ + kernel/declarations.cmo kernel/environ.cmo kernel/conv_oracle.cmo \ + kernel/closure.cmo kernel/reduction.cmo kernel/type_errors.cmo\ + kernel/entries.cmo \ + kernel/cbytegen.cmo \ + kernel/modops.cmo \ + kernel/inductive.cmo kernel/typeops.cmo \ + kernel/indtypes.cmo kernel/cooking.cmo kernel/term_typing.cmo \ + kernel/subtyping.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo \ library/nameops.cmo library/libnames.cmo library/summary.cmo \ library/nametab.cmo library/libobject.cmo library/lib.cmo \ library/goptions.cmo library/decl_kinds.cmo library/global.cmo \ @@ -1439,7 +1503,10 @@ parsing/lexer.cmo: parsing/lexer.ml4 # Default rules ########################################################################### -.SUFFIXES: .ml .mli .cmo .cmi .cmx .mll .mly .ml4 .v .vo .el .elc +.SUFFIXES: .ml .mli .cmo .cmi .cmx .mll .mly .ml4 .v .vo .el .elc .h .c .o + +.c.o: + $(CC) -o $@ $(CFLAGS) $(CINCLUDES) -c $< .ml.cmo: $(SHOW)'OCAMLC $<' @@ -1489,7 +1556,9 @@ parsing/lexer.cmo: parsing/lexer.ml4 archclean:: rm -f config/*.cmx* config/*.[soa] rm -f lib/*.cmx* lib/*.[soa] - rm -f kernel/*.cmx* kernel/*.[soa] + rm -f kernel/*.cmx* kernel/*.[soa] + rm -f kernel/byterun/*.o + rm -f kernel/byterun/libcoqrun.a rm -f library/*.cmx* library/*.[soa] rm -f proofs/*.cmx* proofs/*.[soa] rm -f tactics/*.cmx* tactics/*.[soa] @@ -1548,6 +1617,7 @@ dependcoq:: beforedepend # .ml4 files not using fancy parsers. This is sufficient to get beforedepend # and depend targets successfully built scratchdepend:: dependp4 + $(OCAMLDEP) $(DEPFLAGS) */*.mli */*/*.mli */*.ml */*/*.ml > .depend -$(MAKE) -k -f Makefile.dep $(ML4FILESML) $(OCAMLDEP) $(DEPFLAGS) */*.mli */*/*.mli */*.ml */*/*.ml > .depend $(MAKE) depend @@ -1582,9 +1652,13 @@ depend: beforedepend dependp4 ml4filesml printf "%s" `dirname $$f`/`basename $$f .ml4`".cmx: " >> .depend; \ echo `$(CAMLP4DEPS) $$f` >> .depend; \ done -# 5. Finally, we erase the generated .ml files +# 5. We express dependencies of .o files + gcc -MM $(CINCLUDES) kernel/byterun/*.c >> .depend + gcc -MM $(CINCLUDES) kernel/byterun/*.c | sed -e 's/\.o/.d.o/' >> \ + .depend +# 6. Finally, we erase the generated .ml files rm -f $(ML4FILESML) -# 6. Since .depend contains correct dependencies .depend.devel can be deleted +# 7. Since .depend contains correct dependencies .depend.devel can be deleted # (see dev/Makefile.dir for details about this file) if [ -e makefile ]; then >.depend.devel; else rm -f .depend.devel; fi diff --git a/config/Makefile.template b/config/Makefile.template index cd49db893..f05caeff9 100644 --- a/config/Makefile.template +++ b/config/Makefile.template @@ -40,6 +40,9 @@ CAMLP4BIN=CAMLP4BINDIRECTORY # Ocaml version number CAMLVERSION=CAMLTAG +# Ocaml .h directory +CAMLHLIB=CAMLLIBDIRECTORY/caml + # Camlp4 library directory (avoid CAMLP4LIB used on Windows) CAMLP4O=CAMLP4TOOL MYCAMLP4LIB=CAMLP4LIBDIRECTORY @@ -321,9 +321,8 @@ if [ "$best_compiler" = "opt" ] ; then esac fi -# For coqmktop +# For coqmktop & bytecode compiler -#CAMLLIB=`"$CAMLC" -v | sed -n -e 's|.*directory:* *\(.*\)$|\1|p' ` CAMLLIB=`"$CAMLC" -where` # Camlp4 (greatly simplified since merged with ocaml) diff --git a/contrib/funind/tacinv.ml4 b/contrib/funind/tacinv.ml4 index 717cf6421..7d7de9de4 100644 --- a/contrib/funind/tacinv.ml4 +++ b/contrib/funind/tacinv.ml4 @@ -815,7 +815,8 @@ let declareFunScheme f fname mutflist = let ce = { const_entry_body = scheme; const_entry_type = None; - const_entry_opaque = false } in + const_entry_opaque = false; + const_entry_boxed = true } in let _= ignore (declare_constant fname (DefinitionEntry ce,IsDefinition)) in () diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli index d246e7323..88ffb2bce 100644 --- a/contrib/interface/ascent.mli +++ b/contrib/interface/ascent.mli @@ -531,6 +531,7 @@ and ct_RED_COM = | CT_lazy of ct_CONVERSION_FLAG_LIST * ct_CONV_SET | CT_pattern of ct_PATTERN_NE_LIST | CT_red + | CT_cbvvm | CT_simpl of ct_PATTERN_OPT | CT_unfold of ct_UNFOLD_NE_LIST and ct_RETURN_INFO = @@ -638,6 +639,7 @@ and ct_TACTIC_COM = | CT_elim of ct_FORMULA * ct_SPEC_LIST * ct_USING | CT_elim_type of ct_FORMULA | CT_exact of ct_FORMULA + | CT_exact_no_check of ct_FORMULA | CT_exists of ct_SPEC_LIST | CT_fail of ct_ID_OR_INT * ct_STRING_OPT | CT_first of ct_TACTIC_COM * ct_TACTIC_COM list diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml index eaff09688..a08f2cd6f 100644 --- a/contrib/interface/name_to_ast.ml +++ b/contrib/interface/name_to_ast.ml @@ -160,7 +160,7 @@ let make_variable_ast name typ implicits = let make_definition_ast name c typ implicits = - VernacDefinition ((Global,Definition), (dummy_loc,name), DefineBody ([], None, + VernacDefinition ((Global,Definition false), (dummy_loc,name), DefineBody ([], None, (constr_to_ast c), Some (constr_to_ast (body_of_type typ))), (fun _ _ -> ())) ::(implicits_to_ast_list implicits);; diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml index 675b024ce..48047cf96 100644 --- a/contrib/interface/vtp.ml +++ b/contrib/interface/vtp.ml @@ -1282,6 +1282,7 @@ and fRED_COM = function fPATTERN_NE_LIST x1; fNODE "pattern" 1 | CT_red -> fNODE "red" 0 +| CT_cbvvm -> fNODE "vm_compute" 0 | CT_simpl(x1) -> fPATTERN_OPT x1; fNODE "simpl" 1 @@ -1546,6 +1547,9 @@ and fTACTIC_COM = function | CT_exact(x1) -> fFORMULA x1; fNODE "exact" 1 +| CT_exact_no_check(x1) -> + fFORMULA x1; + fNODE "exact_no_check" 1 | CT_exists(x1) -> fSPEC_LIST x1; fNODE "exists" 1 diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index c7ab08526..a997e3095 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -725,6 +725,7 @@ and xlate_red_tactic = function | Red true -> xlate_error "" | Red false -> CT_red + | CbvVm -> CT_cbvvm | Hnf -> CT_hnf | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE | Simpl (Some (l,c)) -> @@ -1018,6 +1019,7 @@ and xlate_tac = | TacTransitivity c -> CT_transitivity (xlate_formula c) | TacAssumption -> CT_assumption | TacExact c -> CT_exact (xlate_formula c) + | TacExactNoCheck c -> CT_exact_no_check (xlate_formula c) | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id) | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id) | TacDestructConcl -> CT_dconcl @@ -1345,8 +1347,9 @@ let xlate_thm x = CT_thm (match x with let xlate_defn x = CT_defn (match x with - | (Local, Definition) -> "Local" - | (Global, Definition) -> "Definition" + | (Local, Definition _) -> "Local" + | (Global, Definition true) -> "Boxed Definition" + | (Global, Definition false) -> "Definition" | (Global, SubClass) -> "SubClass" | (Global, Coercion) -> "Coercion" | (Local, SubClass) -> "Local SubClass" @@ -1858,8 +1861,8 @@ let rec xlate_vernac = translate_opt_notation_decl notopt) in CT_mind_decl (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi)) - | VernacFixpoint [] -> xlate_error "mutual recursive" - | VernacFixpoint (lm :: lmi) -> + | VernacFixpoint ([],_) -> xlate_error "mutual recursive" + | VernacFixpoint ((lm :: lmi),boxed) -> let strip_mutrec ((fid, n, bl, arf, ardef), ntn) = let (struct_arg,bl,arf,ardef) = if bl = [] then @@ -1876,8 +1879,8 @@ let rec xlate_vernac = | _ -> xlate_error "mutual recursive" in CT_fix_decl (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi)) - | VernacCoFixpoint [] -> xlate_error "mutual corecursive" - | VernacCoFixpoint (lm :: lmi) -> + | VernacCoFixpoint ([],boxed) -> xlate_error "mutual corecursive" + | VernacCoFixpoint ((lm :: lmi),boxed) -> let strip_mutcorec (fid, bl, arf, ardef) = CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, xlate_formula arf, xlate_formula ardef) in diff --git a/dev/base_include b/dev/base_include index 172937766..969637c42 100644 --- a/dev/base_include +++ b/dev/base_include @@ -25,7 +25,7 @@ #install_printer (* qualid *) prqualid;; #install_printer (* kernel_name *) prkn;; #install_printer (* constr *) print_pure_constr;; - +#install_printer (* patch *) ppripos;; (* parsing of names *) let qid = Libnames.qualid_of_string;; diff --git a/dev/top_printers.ml b/dev/top_printers.ml index df31c6d9a..70aaccf0c 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -295,3 +295,18 @@ let _ = | _ -> bad_vernac_args "PrintPureConstr") *) +let ppfconstr c = ppterm (Closure.term_of_fconstr c) + +open Cbytecodes +open Cemitcodes +let ppripos (ri,pos) = + (match ri with + | Reloc_annot a -> + let sp,i = a.ci.ci_ind in + print_string + ("annot : MutInd("^(string_of_kn sp)^","^(string_of_int i)^")\n") + | Reloc_const _ -> + print_string "structured constant\n" + | Reloc_getglobal kn -> + print_string ("getglob "^(string_of_kn kn)^"\n")); + print_flush () diff --git a/kernel/.cvsignore b/kernel/.cvsignore new file mode 100644 index 000000000..81f20377e --- /dev/null +++ b/kernel/.cvsignore @@ -0,0 +1 @@ +copcodes.ml diff --git a/kernel/byterun/.cvsignore b/kernel/byterun/.cvsignore new file mode 100644 index 000000000..bc5f347b0 --- /dev/null +++ b/kernel/byterun/.cvsignore @@ -0,0 +1 @@ +coq_jumptbl.h diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c new file mode 100644 index 000000000..55ad3aa5e --- /dev/null +++ b/kernel/byterun/coq_fix_code.c @@ -0,0 +1,180 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +#include <stdio.h> +#include <stdlib.h> +#include "config.h" +#include "misc.h" +#include "mlvalues.h" +#include "fail.h" +#include "memory.h" +#include "coq_instruct.h" +#include "coq_fix_code.h" + +void * coq_stat_alloc (asize_t sz) +{ + void * result = malloc (sz); + if (result == NULL) raise_out_of_memory (); + return result; +} + +#ifdef THREADED_CODE + +char ** coq_instr_table; +char * coq_instr_base; + +value coq_makeaccu (value i) { + code_t q; + code_t res = coq_stat_alloc(8); + q = res; + *q++ = (opcode_t)(coq_instr_table[MAKEACCU] - coq_instr_base); + *q = (opcode_t)Int_val(i); + return (value)res; +} + +value coq_pushpop (value i) { + code_t res; + int n; + n = Int_val(i); + if (n == 0) { + res = coq_stat_alloc(4); + *res = (opcode_t)(coq_instr_table[STOP] - coq_instr_base); + return (value)res; + } + else { + code_t q; + res = coq_stat_alloc(12); + q = res; + *q++ = (opcode_t)(coq_instr_table[POP] - coq_instr_base); + *q++ = (opcode_t)n; + *q = (opcode_t)(coq_instr_table[STOP] - coq_instr_base); + return (value)res; + } +} + +code_t coq_thread_code (code_t code, asize_t len){ + opcode_t instr; + code_t p, q; + code_t res = coq_stat_alloc(len); + int i; + q = res; + len /= sizeof(opcode_t); + for (p=code; p < code + len; /*nothing*/) { + instr = *p++; + *q++ = (opcode_t)(coq_instr_table[instr] - coq_instr_base); + switch(instr){ + /* instruction with zero operand */ + case ACC0: case ACC1: case ACC2: case ACC3: case ACC4: case ACC5: + case ACC6: case ACC7: case PUSH: case PUSHACC0: case PUSHACC1: + case PUSHACC2: case PUSHACC3: case PUSHACC4: case PUSHACC5: case PUSHACC6: + case PUSHACC7: case ENVACC1: case ENVACC2: case ENVACC3: case ENVACC4: + case PUSHENVACC1: case PUSHENVACC2: case PUSHENVACC3: case PUSHENVACC4: + case APPLY1: case APPLY2: case APPLY3: case RESTART: case OFFSETCLOSUREM2: + case OFFSETCLOSURE0: case OFFSETCLOSURE2: case PUSHOFFSETCLOSUREM2: + case PUSHOFFSETCLOSURE0: case PUSHOFFSETCLOSURE2: + case CONST0: case CONST1: case CONST2: case CONST3: + case PUSHCONST0: case PUSHCONST1: case PUSHCONST2: case PUSHCONST3: + case ACCUMULATE: case STOP: case FORCE: case MAKEPROD: + break; + + /* instruction with one operand */ + case ACC: case PUSHACC: case POP: case ENVACC: case PUSHENVACC: + case PUSH_RETADDR: + case APPLY: case APPTERM1: case APPTERM2: case APPTERM3: case RETURN: + case GRAB: case COGRAB: + case OFFSETCLOSURE: case PUSHOFFSETCLOSURE: + case GETGLOBAL: case PUSHGETGLOBAL: + case GETGLOBALBOXED: case PUSHGETGLOBALBOXED: + case MAKEBLOCK1: case MAKEBLOCK2: case MAKEBLOCK3: case MAKEACCU: + case CONSTINT: case PUSHCONSTINT: case GRABREC: case PUSHFIELD: + *q++ = *p++; + break; + + /* instruction with two operands */ + case APPTERM: case MAKEBLOCK: case CLOSURE: + *q++ = *p++; *q++ = *p++; + break; + + /* instruction with four operands */ + case MAKESWITCHBLOCK: + *q++ = *p++; *q++ = *p++; *q++ = *p++; *q++ = *p++; + break; + + /* instruction with arbitrary operands */ + case CLOSUREREC: { + int i; + uint32 n = 2*(*p) + 3; /* ndefs, nvars, start, typlbls,lbls*/ + for(i=0; i < n; i++) *q++ = *p++; + } + break; + + case SWITCH: { + int i; + uint32 sizes = *p; + uint32 const_size = sizes & 0xFFFF; + uint32 block_size = sizes >> 16; + sizes = const_size + block_size + 1 ;/* sizes */ + for(i=0; i < sizes; i++) *q++ = *p++; + } + break; + + default: + invalid_argument("Fatal error in coq_thread_code : bad opcode"); + break; + } + } + if (p != code + len) fprintf(stderr, "error thread code\n"); + return res; +} + +value coq_tcode_of_code(value code, value len){ + return (value)coq_thread_code((code_t)code,(asize_t) Long_val(len)); +} +#else + +value coq_makeaccu (value i) { + code_t q; + code_t res = coq_stat_alloc(8); + q = res; + *q++ = (opcode_t)MAKEACCU; + *q = (opcode_t)Int_val(i); + return (value)res; +} + +value coq_pushpop (value i) { + code_t res; + int n; + n = Int_val(i); + if (n == 0) { + res = coq_stat_alloc(4); + *res = (opcode_t)STOP; + return (value)res; + } + else { + res = coq_stat_alloc(12); + q = res; + *q++ = (opcode_t)POP; + *q++ = (opcode_t)n; + *q = (opcode_t)STOP; + return (value)res; + } +} + +value coq_tcode_of_code(value s, value size) +{ + void * new_s = coq_stat_alloc(Int_val(size)); + memmove(new_s, &Byte(s, 0), Int_val(size)); + return (value)new_s; +} + +#endif /* THREADED_CODE */ + + + diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h new file mode 100644 index 000000000..bceb104e9 --- /dev/null +++ b/kernel/byterun/coq_fix_code.h @@ -0,0 +1,30 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + + +#ifndef _COQ_FIX_CODE_ +#define _COQ_FIX_CODE_ + +#include "mlvalues.h" +void * coq_stat_alloc (asize_t sz); + +#ifdef THREADED_CODE +extern char ** coq_instr_table; +extern char * coq_instr_base; +#define Is_instruction(i1,i2) \ + (*i1 == (opcode_t)(coq_instr_table[i2] - coq_instr_base)) +#else +#define Is_instruction(i1,i2) (*i1 == i2) +#endif + +value coq_tcode_of_code(value code, value len); +value coq_makeaccu (value i); +value coq_pushpop (value i); +#endif /* _COQ_FIX_CODE_ */ diff --git a/kernel/byterun/coq_gc.h b/kernel/byterun/coq_gc.h new file mode 100644 index 000000000..2f0853264 --- /dev/null +++ b/kernel/byterun/coq_gc.h @@ -0,0 +1,48 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +#ifndef _COQ_CAML_GC_ +#define _COQ_CAML_GC_ +#include "mlvalues.h" +#include "alloc.h" + +typedef void (*scanning_action) (value, value *); + + +CAMLextern char *young_ptr; +CAMLextern char *young_limit; +CAMLextern void (*scan_roots_hook) (scanning_action); +CAMLextern void minor_collection (void); + +#define Caml_white (0 << 8) +#define Caml_black (3 << 8) + +#define Make_header(wosize, tag, color) \ + (((header_t) (((header_t) (wosize) << 10) \ + + (color) \ + + (tag_t) (tag))) \ + ) + + +#define Alloc_small(result, wosize, tag) do{ \ + young_ptr -= Bhsize_wosize (wosize); \ + if (young_ptr < young_limit){ \ + young_ptr += Bhsize_wosize (wosize); \ + Setup_for_gc; \ + minor_collection (); \ + Restore_after_gc; \ + young_ptr -= Bhsize_wosize (wosize); \ + } \ + Hd_hp (young_ptr) = Make_header ((wosize), (tag), Caml_black); \ + (result) = Val_hp (young_ptr); \ + }while(0) + + +#endif /*_COQ_CAML_GC_ */ diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h new file mode 100644 index 000000000..2c23a4c89 --- /dev/null +++ b/kernel/byterun/coq_instruct.h @@ -0,0 +1,40 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +#ifndef _COQ_INSTRUCT_ +#define _COQ_INSTRUCT_ + +enum instructions { + ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC, + PUSH, + PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, PUSHACC4, + PUSHACC5, PUSHACC6, PUSHACC7, PUSHACC, + POP, + ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, + PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, + PUSH_RETADDR, + APPLY, APPLY1, APPLY2, APPLY3, + APPTERM, APPTERM1, APPTERM2, APPTERM3, + RETURN, RESTART, GRAB, GRABREC, COGRAB, + CLOSURE, CLOSUREREC, + OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, + PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, PUSHOFFSETCLOSURE2, + PUSHOFFSETCLOSURE, + GETGLOBAL, PUSHGETGLOBAL, + GETGLOBALBOXED, PUSHGETGLOBALBOXED, + MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, + MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, + FORCE, SWITCH, PUSHFIELD, + CONST0, CONST1, CONST2, CONST3, CONSTINT, + PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, + ACCUMULATE, STOP +}; + +#endif /* _COQ_INSTRUCT_ */ diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c new file mode 100644 index 000000000..a5f6f01d7 --- /dev/null +++ b/kernel/byterun/coq_interp.c @@ -0,0 +1,857 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +/* The bytecode interpreter */ + +#include <stdio.h> +#include "coq_gc.h" +#include "coq_instruct.h" +#include "coq_fix_code.h" +#include "coq_memory.h" +#include "coq_values.h" + + +/* Registers for the abstract machine: + pc the code pointer + sp the stack pointer (grows downward) + accu the accumulator + env heap-allocated environment + trapsp pointer to the current trap frame + extra_args number of extra arguments provided by the caller + +sp is a local copy of the global variable extern_sp. */ + + + +/* Instruction decoding */ + + +#ifdef THREADED_CODE +# define Instruct(name) coq_lbl_##name: +# if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) +# define coq_Jumptbl_base ((char *) &&coq_lbl_ACC0) +# else +# define coq_Jumptbl_base ((char *) 0) +# define coq_jumptbl_base ((char *) 0) +# endif +# ifdef DEBUG +# define Next goto next_instr +# else +# ifdef __ia64__ +# define Next goto *(void *)(coq_jumptbl_base + *((uint32 *) pc)++) +# else +# define Next goto *(void *)(coq_jumptbl_base + *pc++) +# endif +# endif +#else +# define Instruct(name) case name: print_instr(name); +# define Next break +#endif + +/* GC interface */ +#define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; } +#define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; } + + +/* Register optimization. + Some compilers underestimate the use of the local variables representing + the abstract machine registers, and don't put them in hardware registers, + which slows down the interpreter considerably. + For GCC, Xavier Leroy have hand-assigned hardware registers for + several architectures. +*/ + +#if defined(__GNUC__) && !defined(DEBUG) +#ifdef __mips__ +#define PC_REG asm("$16") +#define SP_REG asm("$17") +#define ACCU_REG asm("$18") +#endif +#ifdef __sparc__ +#define PC_REG asm("%l0") +#define SP_REG asm("%l1") +#define ACCU_REG asm("%l2") +#endif +#ifdef __alpha__ +#ifdef __CRAY__ +#define PC_REG asm("r9") +#define SP_REG asm("r10") +#define ACCU_REG asm("r11") +#define JUMPTBL_BASE_REG asm("r12") +#else +#define PC_REG asm("$9") +#define SP_REG asm("$10") +#define ACCU_REG asm("$11") +#define JUMPTBL_BASE_REG asm("$12") +#endif +#endif +#ifdef __i386__ +#define PC_REG asm("%esi") +#define SP_REG asm("%edi") +#define ACCU_REG +#endif +#if defined(PPC) || defined(_POWER) || defined(_IBMR2) +#define PC_REG asm("26") +#define SP_REG asm("27") +#define ACCU_REG asm("28") +#endif +#ifdef __hppa__ +#define PC_REG asm("%r18") +#define SP_REG asm("%r17") +#define ACCU_REG asm("%r16") +#endif +#ifdef __mc68000__ +#define PC_REG asm("a5") +#define SP_REG asm("a4") +#define ACCU_REG asm("d7") +#endif +#ifdef __arm__ +#define PC_REG asm("r9") +#define SP_REG asm("r8") +#define ACCU_REG asm("r7") +#endif +#ifdef __ia64__ +#define PC_REG asm("36") +#define SP_REG asm("37") +#define ACCU_REG asm("38") +#define JUMPTBL_BASE_REG asm("39") +#endif +#endif + +/* The interpreter itself */ + +value coq_interprete +(code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args) +{ + /*Declaration des variables */ +#ifdef PC_REG + register code_t pc PC_REG; + register value * sp SP_REG; + register value accu ACCU_REG; +#else + register code_t pc; + register value * sp; + register value accu; +#endif +#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) +#ifdef JUMPTBL_BASE_REG + register char * coq_jumptbl_base JUMPTBL_BASE_REG; +#else + register char * coq_jumptbl_base; +#endif +#endif +#ifdef THREADED_CODE + static void * coq_jumptable[] = { +# include "coq_jumptbl.h" + }; +#else + opcode_t curr_instr; +#endif + value * global_transp; + + if (coq_pc == NULL) { /* Interpreter is initializing */ +#ifdef THREADED_CODE + coq_instr_table = (char **) coq_jumptable; + coq_instr_base = coq_Jumptbl_base; +#endif + return Val_unit; + } +#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) + coq_jumptbl_base = coq_Jumptbl_base; +#endif + + /* Initialisation */ + if (default_transp == BOXED) global_transp = &coq_global_boxed; + else global_transp = &coq_global_transp; + sp = coq_sp; + pc = coq_pc; + accu = coq_accu; +#ifdef THREADED_CODE + goto *(void *)(coq_jumptbl_base + *pc++); /* Jump to the first instruction */ +#else + while(1) { + curr_instr = *pc++; + switch(curr_instr) { +#endif +/* Basic stack operations */ + + Instruct(ACC0){ + accu = sp[0]; Next; + } + Instruct(ACC1){ + accu = sp[1]; Next; + } + Instruct(ACC2){ + accu = sp[2]; Next; + } + Instruct(ACC3){ + accu = sp[3]; Next; + } + Instruct(ACC4){ + accu = sp[4]; Next; + } + Instruct(ACC5){ + accu = sp[5]; Next; + } + Instruct(ACC6){ + accu = sp[6]; Next; + } + Instruct(ACC7){ + accu = sp[7]; Next; + } + Instruct(PUSH){ + *--sp = accu; Next; + } + Instruct(PUSHACC0) { + *--sp = accu; Next; + } + Instruct(PUSHACC1){ + *--sp = accu; accu = sp[1]; Next; + } + Instruct(PUSHACC2){ + *--sp = accu; accu = sp[2]; Next; + } + Instruct(PUSHACC3){ + *--sp = accu; accu = sp[3]; Next; + } + Instruct(PUSHACC4){ + *--sp = accu; accu = sp[4]; Next; + } + Instruct(PUSHACC5){ + *--sp = accu; accu = sp[5]; Next; + } + Instruct(PUSHACC6){ + *--sp = accu; accu = sp[6]; Next; + } + Instruct(PUSHACC7){ + *--sp = accu; accu = sp[7]; Next; + } + Instruct(PUSHACC){ + *--sp = accu; + } + /* Fallthrough */ + + Instruct(ACC){ + accu = sp[*pc++]; + Next; + } + + Instruct(POP){ + sp += *pc++; + Next; + } + /* Access in heap-allocated environment */ + + Instruct(ENVACC1){ + accu = Field(coq_env, 1); Next; + } + Instruct(ENVACC2){ + accu = Field(coq_env, 2); Next; + } + Instruct(ENVACC3){ + accu = Field(coq_env, 3); Next; + } + Instruct(ENVACC4){ + accu = Field(coq_env, 4); Next; + } + Instruct(PUSHENVACC1){ + *--sp = accu; accu = Field(coq_env, 1); Next; + } + Instruct(PUSHENVACC2){ + *--sp = accu; accu = Field(coq_env, 2); Next; + } + Instruct(PUSHENVACC3){ + *--sp = accu; accu = Field(coq_env, 3); Next; + } + Instruct(PUSHENVACC4){ + *--sp = accu; accu = Field(coq_env, 4); Next; + } + Instruct(PUSHENVACC){ + *--sp = accu; + } + /* Fallthrough */ + Instruct(ENVACC){ + accu = Field(coq_env, *pc++); + Next; + } + /* Function application */ + + Instruct(PUSH_RETADDR) { + sp -= 3; + sp[0] = (value) (pc + *pc); + sp[1] = coq_env; + sp[2] = Val_long(coq_extra_args); + coq_extra_args = 0; + pc++; + Next; + } + Instruct(APPLY) { + coq_extra_args = *pc - 1; + pc = Code_val(accu); + coq_env = accu; + goto check_stacks; + } + Instruct(APPLY1) { + value arg1 = sp[0]; + sp -= 3; + sp[0] = arg1; + sp[1] = (value)pc; + sp[2] = coq_env; + sp[3] = Val_long(coq_extra_args); + pc = Code_val(accu); + coq_env = accu; + coq_extra_args = 0; + goto check_stacks; + } + Instruct(APPLY2) { + value arg1 = sp[0]; + value arg2 = sp[1]; + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = (value)pc; + sp[3] = coq_env; + sp[4] = Val_long(coq_extra_args); + pc = Code_val(accu); + coq_env = accu; + coq_extra_args = 1; + goto check_stacks; + } + Instruct(APPLY3) { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + sp[3] = (value)pc; + sp[4] = coq_env; + sp[5] = Val_long(coq_extra_args); + pc = Code_val(accu); + coq_env = accu; + coq_extra_args = 2; + goto check_stacks; + } + + Instruct(APPTERM) { + int nargs = *pc++; + int slotsize = *pc; + value * newsp; + int i; + /* Slide the nargs bottom words of the current frame to the top + of the frame, and discard the remainder of the frame */ + newsp = sp + slotsize - nargs; + for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i]; + sp = newsp; + pc = Code_val(accu); + coq_env = accu; + coq_extra_args += nargs - 1; + goto check_stacks; + } + Instruct(APPTERM1) { + value arg1 = sp[0]; + sp = sp + *pc - 1; + sp[0] = arg1; + pc = Code_val(accu); + coq_env = accu; + goto check_stacks; + } + Instruct(APPTERM2) { + value arg1 = sp[0]; + value arg2 = sp[1]; + sp = sp + *pc - 2; + sp[0] = arg1; + sp[1] = arg2; + pc = Code_val(accu); + coq_env = accu; + coq_extra_args += 1; + goto check_stacks; + } + Instruct(APPTERM3) { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + sp = sp + *pc - 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + pc = Code_val(accu); + coq_env = accu; + coq_extra_args += 2; + goto check_stacks; + } + + Instruct(RETURN) { + sp += *pc++; + if (coq_extra_args > 0) { + coq_extra_args--; + pc = Code_val(accu); + coq_env = accu; + } else { + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + + Instruct(RESTART) { + int num_args = Wosize_val(coq_env) - 2; + int i; + sp -= num_args; + for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2); + coq_env = Field(coq_env, 1); + coq_extra_args += num_args; + Next; + } + + Instruct(GRAB) { + int required = *pc++; + if (coq_extra_args >= required) { + coq_extra_args -= required; + } else { + mlsize_t num_args, i; + num_args = 1 + coq_extra_args; /* arg1 + extra args */ + Alloc_small(accu, num_args + 2, Closure_tag); + Field(accu, 1) = coq_env; + for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ + sp += num_args; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + + Instruct(COGRAB){ + int required = *pc++; + if(forcable == Val_true) { + /* L'instruction précédante est FORCE */ + if (coq_extra_args > 0) coq_extra_args--; + pc++; + } else { /* L'instruction précédante est APPLY */ + mlsize_t num_args, i; + num_args = 1 + coq_extra_args; /* arg1 + extra args */ + Alloc_small(accu, num_args + 2, Closure_tag); + Field(accu, 1) = coq_env; + for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ + sp += num_args; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + Instruct(GRABREC) { + int rec_pos = *pc++; /* commence a zero */ + if (rec_pos <= coq_extra_args && !Is_accu(sp[rec_pos])) { + pc++;/* On saute le Restart */ + } else { + if (coq_extra_args < rec_pos) { + mlsize_t num_args, i; + num_args = 1 + coq_extra_args; /* arg1 + extra args */ + Alloc_small(accu, num_args + 2, Closure_tag); + Field(accu, 1) = coq_env; + for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc - 3; + sp += num_args; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } else { + /* L'argument recursif est un accumulateur */ + mlsize_t num_args, i; + /* Construction du PF partiellement appliqué */ + Alloc_small(accu, rec_pos + 2, Closure_tag); + Field(accu, 1) = coq_env; + for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc; + sp += rec_pos; + *--sp = accu; + /* Construction de l'atom */ + Alloc_small(accu, 2, ATOM_FIX_TAG); + Field(accu,1) = sp[0]; + Field(accu,0) = sp[1]; + sp++; sp[0] = accu; + /* Construction de l'accumulateur */ + num_args = coq_extra_args - rec_pos; + Alloc_small(accu, 2+num_args, Accu_tag); + Code_val(accu) = accumulate; + Field(accu,1) = sp[0]; sp++; + for (i = 0; i < num_args;i++)Field(accu, i + 2) = sp[i]; + sp += num_args; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } + } + Next; + } + + Instruct(CLOSURE) { + int nvars = *pc++; + int i; + if (nvars > 0) *--sp = accu; + Alloc_small(accu, 1 + nvars, Closure_tag); + Code_val(accu) = pc + *pc; + pc++; + for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; + sp += nvars; + Next; + } + + Instruct(CLOSUREREC) { + int nfuncs = *pc++; + int nvars = *pc++; + int start = *pc++; + int i; + value * p; + if (nvars > 0) *--sp = accu; + /* construction du vecteur de type */ + Alloc_small(accu, nfuncs, 0); + for(i = 0; i < nfuncs; i++) { + Field(accu,i) = (value)(pc+pc[i]); + } + pc += nfuncs; + *--sp=accu; + Alloc_small(accu, nfuncs * 2 + nvars, Closure_tag); + Field(accu, nfuncs * 2 + nvars - 1) = *sp++; + /* On remplie la partie pour les variables libres */ + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++) { + *p++ = *sp++; + } + p = &Field(accu, 0); + *p = (value) (pc + pc[0]); + p++; + for (i = 1; i < nfuncs; i++) { + *p = Make_header(i * 2, Infix_tag, Caml_white); + p++; /* color irrelevant. */ + *p = (value) (pc + pc[i]); + p++; + } + pc += nfuncs; + accu = accu + 2 * start * sizeof(value); + Next; + } + + Instruct(PUSHOFFSETCLOSURE) { + *--sp = accu; + } /* fallthrough */ + Instruct(OFFSETCLOSURE) { + accu = coq_env + *pc++ * sizeof(value); Next; + } + Instruct(PUSHOFFSETCLOSUREM2) { + *--sp = accu; + } /* fallthrough */ + Instruct(OFFSETCLOSUREM2) { + accu = coq_env - 2 * sizeof(value); Next; + } + Instruct(PUSHOFFSETCLOSURE0) { + *--sp = accu; + }/* fallthrough */ + Instruct(OFFSETCLOSURE0) { + accu = coq_env; Next; + } + Instruct(PUSHOFFSETCLOSURE2){ + *--sp = accu; /* fallthrough */ + } + Instruct(OFFSETCLOSURE2) { + accu = coq_env + 2 * sizeof(value); Next; + } + +/* Access to global variables */ + + Instruct(PUSHGETGLOBAL) { + *--sp = accu; + } + /* Fallthrough */ + Instruct(GETGLOBAL){ + accu = Field(coq_global_data, *pc); + pc++; + Next; + } + Instruct(PUSHGETGLOBALBOXED) { + *--sp = accu; + } + /* Fallthrough */ + Instruct(GETGLOBALBOXED){ + + accu = Field(*global_transp, *pc); + pc++; + Next; + } +/* Allocation of blocks */ + + Instruct(MAKEBLOCK) { + mlsize_t wosize = *pc++; + tag_t tag = *pc++; + mlsize_t i; + value block; + Alloc_small(block, wosize, tag); + Field(block, 0) = accu; + for (i = 1; i < wosize; i++) Field(block, i) = *sp++; + accu = block; + Next; + } + Instruct(MAKEBLOCK1) { + + tag_t tag = *pc++; + value block; + Alloc_small(block, 1, tag); + Field(block, 0) = accu; + accu = block; + Next; + } + Instruct(MAKEBLOCK2) { + + tag_t tag = *pc++; + value block; + Alloc_small(block, 2, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + sp += 1; + accu = block; + Next; + } + Instruct(MAKEBLOCK3) { + tag_t tag = *pc++; + value block; + Alloc_small(block, 3, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + Field(block, 2) = sp[1]; + sp += 2; + accu = block; + Next; + } + + +/* Access to components of blocks */ + + +/* Branches and conditional branches */ + Instruct(FORCE) { + if (Is_block(accu) && Tag_val(accu) == Closure_tag) { + /* On pousse l'addresse de retour et l'argument */ + sp -= 3; + sp[0] = (value) (pc); + sp[1] = coq_env; + sp[2] = Val_long(coq_extra_args); + /* On evalue le cofix */ + coq_extra_args = 0; + pc = Code_val(accu); + coq_env = accu; + goto check_stacks; + } + Next; + } + + + Instruct(SWITCH) { + uint32 sizes = *pc++; + if (Is_block(accu)) { + long index = Tag_val(accu); + pc += pc[(sizes & 0xFFFF) + index]; + } else { + long index = Long_val(accu); + pc += pc[index]; + } + Next; + } + Instruct(PUSHFIELD){ + int i; + int size = *pc++; + sp -= size; + for(i=0;i<size;i++)sp[i] = Field(accu,i); + Next; + } + + Instruct(MAKESWITCHBLOCK) { + mlsize_t sz; + int i, annot; + code_t typlbl,swlbl; + typlbl = (code_t)pc + *pc; + pc++; + swlbl = (code_t)pc + *pc; + pc++; + annot = *pc++; + sz = *pc++; + *--sp = accu; + *--sp=Field(coq_global_data, annot); + /* On sauve la pile */ + if (sz == 0) accu = Atom(0); + else { + Alloc_small(accu, sz, Default_tag); + if (Field(*sp, 2) == Val_true) { + for (i = 0; i < sz; i++) Field(accu, i) = sp[i+2]; + }else{ + for (i = 0; i < sz; i++) Field(accu, i) = sp[i+5]; + } + } + *--sp = accu; + /* On cree le zipper switch */ + Alloc_small(accu, 5, Default_tag); + Field(accu, 0) = (value)typlbl; Field(accu, 1) = (value)swlbl; + Field(accu, 2) = sp[1]; Field(accu, 3) = sp[0]; + Field(accu, 4) = coq_env; + sp++;sp[0] = accu; + /* On cree l'atome */ + Alloc_small(accu, 2, ATOM_SWITCH_TAG); + Field(accu, 0) = sp[1]; Field(accu, 1) = sp[0]; + sp++;sp[0] = accu; + /* On cree l'accumulateur */ + Alloc_small(accu, 2, Accu_tag); + Code_val(accu) = accumulate; + Field(accu,1) = *sp++; + Next; + } + + /* Stack checks */ + + check_stacks: + if (sp < coq_stack_threshold) { + coq_sp = sp; + realloc_coq_stack(Coq_stack_threshold); + sp = coq_sp; + } + Next; + /* Fall through CHECK_SIGNALS */ + +/* Integer constants */ + + Instruct(CONST0){ + accu = Val_int(0); Next;} + Instruct(CONST1){ + accu = Val_int(1); Next;} + Instruct(CONST2){ + accu = Val_int(2); Next;} + Instruct(CONST3){ + accu = Val_int(3); Next;} + + Instruct(PUSHCONST0){ + *--sp = accu; accu = Val_int(0); Next; + } + Instruct(PUSHCONST1){ + *--sp = accu; accu = Val_int(1); Next; + } + Instruct(PUSHCONST2){ + *--sp = accu; accu = Val_int(2); Next; + } + Instruct(PUSHCONST3){ + *--sp = accu; accu = Val_int(3); Next; + } + + Instruct(PUSHCONSTINT){ + *--sp = accu; + } + /* Fallthrough */ + Instruct(CONSTINT) { + accu = Val_int(*pc); + pc++; + Next; + } + +/* Debugging and machine control */ + + Instruct(STOP){ + coq_sp = sp; + return accu; + } + + Instruct(ACCUMULATE) { + mlsize_t i, size; + size = Wosize_val(coq_env); + Alloc_small(accu, size + coq_extra_args + 1, Accu_tag); + for(i = 0; i < size; i++) Field(accu, i) = Field(coq_env, i); + for(i = size; i <= coq_extra_args + size; i++) + Field(accu, i) = *sp++; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + Next; + } + + Instruct(MAKEACCU) { + int i; + Alloc_small(accu, coq_extra_args + 3, Accu_tag); + Code_val(accu) = accumulate; + Field(accu,1) = Field(coq_atom_tbl, *pc); + for(i = 2; i < coq_extra_args + 3; i++) Field(accu, i) = *sp++; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + Next; + } + + Instruct(MAKEPROD) { + *--sp=accu; + Alloc_small(accu,2,0); + Field(accu, 0) = sp[0]; + Field(accu, 1) = sp[1]; + sp += 2; + Next; + } + +#ifndef THREADED_CODE + default: + /*fprintf(stderr, "%d\n", *pc);*/ + failwith("Coq VM: Fatal error: bad opcode"); + } + } +#endif +} + +value coq_push_ra(value tcode) { + coq_sp -= 3; + coq_sp[0] = (value) tcode; + coq_sp[1] = Val_unit; + coq_sp[2] = Val_long(0); + return Val_unit; +} + +value coq_push_val(value v) { + *--coq_sp = v; + return Val_unit; +} + +value coq_push_arguments(value args) { + int nargs,i; + nargs = Wosize_val(args) - 2; + coq_sp -= nargs; + for(i = 0; i < nargs; i++) coq_sp[i] = Field(args, i+2); + return Val_unit; +} + +value coq_push_vstack(value stk) { + int len,i; + len = Wosize_val(stk); + coq_sp -= len; + for(i = 0; i < len; i++) coq_sp[i] = Field(stk,i); + return Val_unit; +} + +value coq_interprete_ml(value tcode, value a, value e, value ea) { + return coq_interprete((code_t)tcode, a, e, Long_val(ea)); +} + +value coq_eval_tcode (value tcode, value e) { + return coq_interprete_ml(tcode, Val_unit, e, 0); +} diff --git a/kernel/byterun/coq_interp.h b/kernel/byterun/coq_interp.h new file mode 100644 index 000000000..76e689440 --- /dev/null +++ b/kernel/byterun/coq_interp.h @@ -0,0 +1,23 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + + +value coq_push_ra(value tcode); + +value coq_push_val(value v); + +value coq_push_arguments(value args); + +value coq_push_vstack(value stk); + +value coq_interprete_ml(value tcode, value a, value e, value ea); + +value coq_eval_tcode (value tcode, value e); + diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c new file mode 100644 index 000000000..233397b02 --- /dev/null +++ b/kernel/byterun/coq_memory.c @@ -0,0 +1,270 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +#include <stdio.h> +#include <string.h> +#include "coq_gc.h" +#include "coq_instruct.h" +#include "coq_fix_code.h" +#include "coq_memory.h" + +/* stack */ + +value * coq_stack_low; +value * coq_stack_high; +value * coq_stack_threshold; +asize_t coq_max_stack_size = Coq_max_stack_size; +/* global_data */ + + +value coq_global_data; +value coq_global_transp; +value coq_global_boxed; +int default_transp; +value coq_atom_tbl; + +/* interp state */ + +long coq_saved_sp_offset; +value * coq_sp; +value forcable; +/* Some predefined pointer code */ +code_t accumulate; + +/* functions over global environment */ + +void coq_stat_free (void * blk) +{ + free (blk); +} + +value coq_static_alloc(value size) /* ML */ +{ + return (value) coq_stat_alloc((asize_t) Long_val(size)); +} + +value coq_static_free(value blk) /* ML */ +{ + coq_stat_free((void *) blk); + return Val_unit; +} + +value accumulate_code(value unit) /* ML */ +{ + return (value) accumulate; +} + +static void (*coq_prev_scan_roots_hook) (scanning_action); + +static void coq_scan_roots(scanning_action action) +{ + register value * i; + /* Scan the global variables */ + (*action)(coq_global_data, &coq_global_data); + (*action)(coq_global_transp, &coq_global_transp); + (*action)(coq_global_boxed, &coq_global_boxed); + (*action)(coq_atom_tbl, &coq_atom_tbl); + /* Scan the stack */ + for (i = coq_sp; i < coq_stack_high; i++) { + (*action) (*i, i); + }; + /* Hook */ + if (coq_prev_scan_roots_hook != NULL) (*coq_prev_scan_roots_hook)(action); + + +} + +void init_coq_stack() +{ + coq_stack_low = (value *) coq_stat_alloc(Coq_stack_size); + coq_stack_high = coq_stack_low + Coq_stack_size / sizeof (value); + coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value); + coq_max_stack_size = Coq_max_stack_size; +} + +void init_coq_global_data(long requested_size) +{ + int i; + + coq_global_data = alloc_shr(requested_size, 0); + for (i = 0; i < requested_size; i++) + Field (coq_global_data, i) = Val_unit; + + default_transp = BOXED; + + coq_global_transp = alloc_shr(requested_size, 0); + for (i = 0; i < requested_size; i++) + Field (coq_global_transp, i) = Val_unit; + + coq_global_boxed = alloc_shr(requested_size, 0); + for (i = 0; i < requested_size; i++) + Field (coq_global_boxed, i) = Val_unit; +} + +void init_coq_atom_tbl(long requested_size){ + int i; + coq_atom_tbl = alloc_shr(requested_size, 0); + for (i = 0; i < requested_size; i++) Field (coq_atom_tbl, i) = Val_unit; +} + +void init_coq_interpreter() +{ + coq_sp = coq_stack_high; + coq_interprete(NULL, Val_unit, Val_unit, 0); +} + +static int coq_vm_initialized = 0; + +value init_coq_vm(value unit) /* ML */ +{ + int i; + if (coq_vm_initialized == 1) { + fprintf(stderr,"already open \n");fflush(stderr);} + else { + + /* Allocate the table of global and the stack */ + init_coq_stack(); + init_coq_global_data(Coq_global_data_Size); + init_coq_atom_tbl(40); + /* Initialing the interpreter */ + forcable = Val_true; + init_coq_interpreter(); + + /* Some predefined pointer code */ + accumulate = (code_t) coq_stat_alloc(sizeof(opcode_t)); + *accumulate = ACCUMULATE; + accumulate = + (code_t) coq_tcode_of_code((value)accumulate, Val_int(sizeof(opcode_t))); + + /* Initialize GC */ + if (coq_prev_scan_roots_hook == NULL) + coq_prev_scan_roots_hook = scan_roots_hook; + scan_roots_hook = coq_scan_roots; + coq_vm_initialized = 1; + } + return Val_unit;; +} + +void realloc_coq_stack(asize_t required_space) +{ + asize_t size; + value * new_low, * new_high, * new_sp; + value * p; + size = coq_stack_high - coq_stack_low; + do { + size *= 2; + } while (size < coq_stack_high - coq_sp + required_space); + new_low = (value *) coq_stat_alloc(size * sizeof(value)); + new_high = new_low + size; + +#define shift(ptr) \ + ((char *) new_high - ((char *) coq_stack_high - (char *) (ptr))) + + new_sp = (value *) shift(coq_sp); + memmove((char *) new_sp, + (char *) coq_sp, + (coq_stack_high - coq_sp) * sizeof(value)); + coq_stat_free(coq_stack_low); + coq_stack_low = new_low; + coq_stack_high = new_high; + coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value); + coq_sp = new_sp; +#undef shift +} + +value get_coq_global_data(value unit) /* ML */ +{ + return coq_global_data; +} + +value get_coq_atom_tbl(value unit) /* ML */ +{ + return coq_atom_tbl; +} + +value get_coq_global_transp(value unit) /* ML */ +{ + return coq_global_transp; +} + +value get_coq_global_boxed(value unit) /* ML */ +{ + return coq_global_boxed; +} + +value realloc_coq_global_data(value size) /* ML */ +{ + mlsize_t requested_size, actual_size, i; + value new_global_data; + requested_size = Long_val(size); + actual_size = Wosize_val(coq_global_data); + if (requested_size >= actual_size) { + requested_size = (requested_size + 0x100) & 0xFFFFFF00; + new_global_data = alloc_shr(requested_size, 0); + for (i = 0; i < actual_size; i++) + initialize(&Field(new_global_data, i), Field(coq_global_data, i)); + for (i = actual_size; i < requested_size; i++){ + Field (new_global_data, i) = Val_long (0); + } + coq_global_data = new_global_data; + } + return Val_unit; +} + +value realloc_coq_global_boxed(value size) /* ML */ +{ + mlsize_t requested_size, actual_size, i; + value new_global_transp, new_global_boxed; + requested_size = Long_val(size); + actual_size = Wosize_val(coq_global_transp); + if (requested_size >= actual_size) { + requested_size = (requested_size + 0x100) & 0xFFFFFF00; + new_global_transp = alloc_shr(requested_size, 0); + new_global_boxed = alloc_shr(requested_size, 0); + for (i = 0; i < actual_size; i++){ + initialize(&Field(new_global_transp, i), Field(coq_global_transp, i)); + initialize(&Field(new_global_boxed, i), + Field(coq_global_boxed, i)); + } + for (i = actual_size; i < requested_size; i++){ + Field (new_global_transp, i) = Val_long (0); + Field (new_global_boxed, i) = Val_long (0); + } + coq_global_transp = new_global_transp; + coq_global_boxed = new_global_boxed; + } + return Val_unit; +} + +value realloc_coq_atom_tbl(value size) /* ML */ +{ + mlsize_t requested_size, actual_size, i; + value new_atom_tbl; + requested_size = Long_val(size); + actual_size = Wosize_val(coq_atom_tbl); + if (requested_size >= actual_size) { + requested_size = (requested_size + 0x100) & 0xFFFFFF00; + new_atom_tbl = alloc_shr(requested_size, 0); + for (i = 0; i < actual_size; i++) + initialize(&Field(new_atom_tbl, i), Field(coq_atom_tbl, i)); + for (i = actual_size; i < requested_size; i++){ + Field (new_atom_tbl, i) = Val_long (0); + } + coq_atom_tbl = new_atom_tbl; + } + return Val_unit; +} + +value swap_coq_global_transp (value unit){ + if (default_transp==BOXED) default_transp = TRANSP; + else default_transp = BOXED; + return Val_unit; +} + diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h new file mode 100644 index 000000000..0884f06a8 --- /dev/null +++ b/kernel/byterun/coq_memory.h @@ -0,0 +1,68 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +#ifndef _COQ_MEMORY_ +#define _COQ_MEMORY_ + +#include "config.h" +#include "fail.h" +#include "misc.h" +#include "memory.h" +#include "mlvalues.h" + + +#define Coq_stack_size (4096 * sizeof(value)) +#define Coq_stack_threshold (256 * sizeof(value)) +#define Coq_global_data_Size (4096 * sizeof(value)) +#define Coq_max_stack_size (256 * 1024) + +#define TRANSP 0 +#define BOXED 1 + +/* stack */ + +extern value * coq_stack_low; +extern value * coq_stack_high; +extern value * coq_stack_threshold; + +/* global_data */ + +extern value coq_global_data; +extern value coq_global_transp; +extern value coq_global_boxed; +extern int default_transp; +extern value coq_atom_tbl; +/* interp state */ + +extern value * coq_sp; +extern value forcable; +/* Some predefined pointer code */ +extern code_t accumulate; + +/* functions over global environment */ + +value coq_static_alloc(value size); /* ML */ +value coq_static_free(value string); /* ML */ + +value init_coq_vm(value unit); /* ML */ +value re_init_coq_vm(value unit); /* ML */ + +void realloc_coq_stack(asize_t required_space); +value get_coq_global_data(value unit); /* ML */ +value realloc_coq_global_data(value size); /* ML */ +value get_coq_global_transp(value unit); /* ML */ +value get_coq_global_boxed(value unit); +value realloc_coq_global_boxed(value size); /* ML */ +value get_coq_atom_tbl(value unit); /* ML */ +value realloc_coq_atom_tbl(value size); /* ML */ + +#endif /* _COQ_MEMORY_ */ + + diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c new file mode 100644 index 000000000..baf3ab090 --- /dev/null +++ b/kernel/byterun/coq_values.c @@ -0,0 +1,69 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +#include <stdio.h> +#include "coq_fix_code.h" +#include "coq_instruct.h" +#include "coq_memory.h" +#include "coq_values.h" +#include "memory.h" +/* KIND OF VALUES */ + +#define Setup_for_gc +#define Restore_after_gc + +value coq_kind_of_closure(value v) { + opcode_t * c; + int res; + int is_app = 0; + c = Code_val(v); + if (Is_instruction(c, GRAB)) return Val_int(0); + if (Is_instruction(c, RESTART)) {is_app = 1; c++;} + if (Is_instruction(c, GRABREC)) return Val_int(1+is_app); + if (Is_instruction(c, COGRAB)) return Val_int(3+is_app); + if (Is_instruction(c, MAKEACCU)) return Val_int(5); + return Val_int(0); +} + + +/* DESTRUCT ACCU */ + +value coq_closure_arity(value clos) { + opcode_t * c = Code_val(clos); + if (Is_instruction(c,RESTART)) { + c++; + if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos)); + else { + if (Wosize_val(clos) != 2) failwith("Coq Values : coq_closure_arity"); + return Val_int(1); + } + } + if (Is_instruction(c,GRAB)) return Val_int(1 + c[1]); + return Val_int(1); +} + +/* Fonction sur les fix */ + +value coq_offset(value v) { + if (Tag_val(v) == Closure_tag) return Val_int(0); + else return Val_long(-Wsize_bsize(Infix_offset_val(v))); +} + +value coq_offset_closure(value v, value offset){ + return (value)&Field(v, Int_val(offset)); +} + +value coq_offset_tcode(value code,value offset){ + return((value)((code_t)code + Int_val(offset))); +} + +value coq_int_tcode(value code, value offset) { + return Val_int(*((code_t) code + Int_val(offset))); +} diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h new file mode 100644 index 000000000..a186d62aa --- /dev/null +++ b/kernel/byterun/coq_values.h @@ -0,0 +1,28 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +#ifndef _COQ_VALUES_ +#define _COQ_VALUES_ + +#include "alloc.h" +#include "mlvalues.h" + +#define ATOM_FIX_TAG 3 +#define ATOM_SWITCH_TAG 4 + +#define Accu_tag 0 +#define Default_tag 0 + +/* Les blocs accumulate */ +#define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag)) + +#endif /* _COQ_VALUES_ */ + + diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml new file mode 100644 index 000000000..48331a687 --- /dev/null +++ b/kernel/cbytecodes.ml @@ -0,0 +1,64 @@ +open Names +open Term + +type tag = int + +type structured_constant = + | Const_sorts of sorts + | Const_ind of inductive + | Const_b0 of tag + | Const_bn of tag * structured_constant array + +type reloc_table = (tag * int) array + +type annot_switch = + {ci : case_info; rtbl : reloc_table; tailcall : bool} + +module Label = + struct + type t = int + let no = -1 + let counter = ref no + let create () = incr counter; !counter + let reset_label_counter () = counter := no + end + + +type instruction = + | Klabel of Label.t + | Kacc of int + | Kenvacc of int + | Koffsetclosure of int + | Kpush + | Kpop of int + | Kpush_retaddr of Label.t + | Kapply of int (* number of arguments *) + | Kappterm of int * int (* number of arguments, slot size *) + | Kreturn of int (* slot size *) + | Kjump + | Krestart + | Kgrab of int (* number of arguments *) + | Kgrabrec of int (* rec arg *) + | Kcograb of int (* number of arguments *) + | Kclosure of Label.t * int (* label, number of free variables *) + | Kclosurerec of int * int * Label.t array * Label.t array + (* nb fv, init, lbl types, lbl bodies *) + | Kgetglobal of constant + | Kconst of structured_constant + | Kmakeblock of int * tag (* size, tag *) + | Kmakeprod + | Kmakeswitchblock of Label.t * Label.t * annot_switch * int + | Kforce + | Kswitch of Label.t array * Label.t array (* consts,blocks *) + | Kpushfield of int + | Kstop + | Ksequence of bytecodes * bytecodes + +and bytecodes = instruction list + +type fv_elem = FVnamed of identifier | FVrel of int + +type fv = fv_elem array + + + diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli new file mode 100644 index 000000000..84882358a --- /dev/null +++ b/kernel/cbytecodes.mli @@ -0,0 +1,60 @@ +open Names +open Term + +type tag = int + +type structured_constant = + | Const_sorts of sorts + | Const_ind of inductive + | Const_b0 of tag + | Const_bn of tag * structured_constant array + +type reloc_table = (tag * int) array + +type annot_switch = + {ci : case_info; rtbl : reloc_table; tailcall : bool} + +module Label : + sig + type t = int + val no : t + val create : unit -> t + val reset_label_counter : unit -> unit + end + +type instruction = + | Klabel of Label.t + | Kacc of int + | Kenvacc of int + | Koffsetclosure of int + | Kpush + | Kpop of int + | Kpush_retaddr of Label.t + | Kapply of int (* number of arguments *) + | Kappterm of int * int (* number of arguments, slot size *) + | Kreturn of int (* slot size *) + | Kjump + | Krestart + | Kgrab of int (* number of arguments *) + | Kgrabrec of int (* rec arg *) + | Kcograb of int (* number of arguments *) + | Kclosure of Label.t * int (* label, number of free variables *) + | Kclosurerec of int * int * Label.t array * Label.t array + (* nb fv, init, lbl types, lbl bodies *) + | Kgetglobal of constant + | Kconst of structured_constant + | Kmakeblock of int * tag (* size, tag *) + | Kmakeprod + | Kmakeswitchblock of Label.t * Label.t * annot_switch * int + | Kforce + | Kswitch of Label.t array * Label.t array (* consts,blocks *) + | Kpushfield of int + | Kstop + | Ksequence of bytecodes * bytecodes + +and bytecodes = instruction list + +type fv_elem = FVnamed of identifier | FVrel of int + +type fv = fv_elem array + diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml new file mode 100644 index 000000000..033f07319 --- /dev/null +++ b/kernel/cbytegen.ml @@ -0,0 +1,483 @@ +open Util +open Names +open Cbytecodes +open Cemitcodes +open Term +open Declarations +open Environ + +(*i Compilation des variables + calcul des variables libres *) + +(* Representation des environnements machines : *) +(*[t0|C0| ... |tc|Cc| ... |t(nbr-1)|C(nbr-1)| fv1 | fv1 | .... | fvn] *) +(* ^<----------offset---------> *) + + +type fv = fv_elem list + +type vm_env = {size : int; fv_rev : fv} + (* size = n; fv_rev = [fvn; ... ;fv1] *) + +type t = { + nb_stack : int; (* nbre de variables sur la pile *) + in_stack : int list; (* position dans la pile *) + nb_rec : int; (* nbre de fonctions mutuellement recursives = + nbr *) + pos_rec : int; (* position de la fonction courante = c *) + offset : int; + in_env : vm_env ref + } + +let empty_fv = {size= 0; fv_rev = []} + +let fv r = !(r.in_env) + +(* [add_param n] rend la liste [sz+1;sz+2;...;sz+n] *) +let rec add_param n sz l = + if n = 0 then l else add_param (n - 1) sz (n+sz::l) + +(* [push_param ] ajoute les parametres de fonction dans la pile *) +let push_param n sz r = + { r with + nb_stack = r.nb_stack + n; + in_stack = add_param n sz r.in_stack } + +(* [push_local e sz] ajoute une nouvelle variable dans la pile a la position *) +let push_local sz r = + { r with + nb_stack = r.nb_stack + 1; + in_stack = (sz + 1) :: r.in_stack } + + +(* Table de relocation initiale *) +let empty () = + { nb_stack = 0; in_stack = []; + nb_rec = 0;pos_rec = 0; + offset = 0; in_env = ref empty_fv } + +let init_fun arity = + { nb_stack = arity; in_stack = add_param arity 0 []; + nb_rec = 0; pos_rec = 0; + offset = 1; in_env = ref empty_fv } + +let init_type ndef rfv = + { nb_stack = 0; in_stack = []; + nb_rec = 0; pos_rec = 0; + offset = 2*(ndef-1)+1; in_env = rfv } + +let init_fix ndef pos_rec arity rfv = + { nb_stack = arity; in_stack = add_param arity 0 []; + nb_rec = ndef; pos_rec = pos_rec; + offset = 2 * (ndef - pos_rec - 1)+1; in_env = rfv} + +let find_at el l = + let rec aux n = function + | [] -> raise Not_found + | hd :: tl -> if hd = el then n else aux (n+1) tl + in aux 1 l + +let pos_named id r = + let env = !(r.in_env) in + let cid = FVnamed id in + try Kenvacc(r.offset + env.size - (find_at cid env.fv_rev)) + with Not_found -> + let pos = env.size in + r.in_env := { size = pos+1; fv_rev = cid:: env.fv_rev}; + Kenvacc (r.offset + pos) + +let pos_rel i r sz = + if i <= r.nb_stack then + Kacc(sz - (List.nth r.in_stack (i-1))) + else if i <= r.nb_stack + r.nb_rec + then Koffsetclosure (2 * (r.nb_rec + r.nb_stack - r.pos_rec - i)) + else + let db = FVrel(i - r.nb_stack - r.nb_rec) in + let env = !(r.in_env) in + try Kenvacc(r.offset + env.size - (find_at db env.fv_rev)) + with Not_found -> + let pos = env.size in + r.in_env := { size = pos+1; fv_rev = db:: env.fv_rev}; + Kenvacc(r.offset + pos) + + +(*i Examination of the continuation *) + +(* Discard all instructions up to the next label. + This function is to be applied to the continuation before adding a + non-terminating instruction (branch, raise, return, appterm) + in front of it. *) + +let rec discard_dead_code cont = cont +(*function + [] -> [] + | (Klabel _ | Krestart ) :: _ as cont -> cont + | _ :: cont -> discard_dead_code cont +*) + +(* Return a label to the beginning of the given continuation. + If the sequence starts with a branch, use the target of that branch + as the label, thus avoiding a jump to a jump. *) + +let label_code = function + | Klabel lbl :: _ as cont -> (lbl, cont) + | cont -> let lbl = Label.create() in (lbl, Klabel lbl :: cont) + +(* Return a branch to the continuation. That is, an instruction that, + when executed, branches to the continuation or performs what the + continuation performs. We avoid generating branches to returns. *) + +let make_branch cont = + match cont with + | (Kreturn _ as return) :: _ -> return, cont + | Klabel lbl as b :: _ -> b, cont + | _ -> let b = Klabel(Label.create()) in b,b::cont + +(* Check if we're in tailcall position *) + +let rec is_tailcall = function + | Kreturn k :: _ -> Some k + | Klabel _ :: c -> is_tailcall c + | _ -> None + +(* Extention of the continuation ****) + +(* Add a Kpop n instruction in front of a continuation *) +let rec add_pop n = function + | Kpop m :: cont -> add_pop (n+m) cont + | Kreturn m:: cont -> Kreturn (n+m) ::cont + | cont -> if n = 0 then cont else Kpop n :: cont + +let add_grab arity lbl cont = + if arity = 1 then Klabel lbl :: cont + else Krestart :: Klabel lbl :: Kgrab (arity - 1) :: cont + + +(* Environnement global *****) + +let global_env = ref empty_env + +let set_global_env env = global_env := env + + +(* Code des fermetures ****) +let fun_code = ref [] + +let init_fun_code () = fun_code := [] + +(* Compilation des constructeurs et des inductifs *) + +(* Inv : nparam + arity > 0 *) +let code_construct tag nparams arity cont = + let f_cont = + add_pop nparams + (if arity = 0 then + [Kconst (Const_b0 tag); Kreturn 0] + else [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0]) + in + let lbl = Label.create() in + fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)]; + Kclosure(lbl,0) :: cont + +type block = + | Bconstr of constr + | Bstrconst of structured_constant + | Bmakeblock of int * block array + | Bconstruct_app of int * int * int * block array + (* tag , nparams, arity *) + +let get_strcst = function + | Bstrconst sc -> sc + | _ -> raise Not_found + +let rec str_const c = + match kind_of_term c with + | Sort s -> Bstrconst (Const_sorts s) + | Cast(c,_) -> str_const c + | App(f,args) -> + begin + match kind_of_term f with + | Construct((kn,j),i) -> + let oib = (lookup_mind kn !global_env).mind_packets.(j) in + let num,arity = oib.mind_reloc_tbl.(i-1) in + let nparams = oib.mind_nparams in + if nparams + arity = Array.length args then + if arity = 0 then Bstrconst(Const_b0 num) + else + let rargs = Array.sub args nparams arity in + let b_args = Array.map str_const rargs in + try + let sc_args = Array.map get_strcst b_args in + Bstrconst(Const_bn(num, sc_args)) + with Not_found -> + Bmakeblock(num,b_args) + else + let b_args = Array.map str_const args in + Bconstruct_app(num, nparams, arity, b_args) + | _ -> Bconstr c + end + | Ind ind -> Bstrconst (Const_ind ind) + | Construct ((kn,j),i) -> + let oib = (lookup_mind kn !global_env).mind_packets.(j) in + let num,arity = oib.mind_reloc_tbl.(i-1) in + let nparams = oib.mind_nparams in + if nparams + arity = 0 then Bstrconst(Const_b0 num) + else Bconstruct_app(num,nparams,arity,[||]) + | _ -> Bconstr c + +(* compilation des applications *) +let comp_args comp_expr reloc args sz cont = + let nargs_m_1 = Array.length args - 1 in + let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in + for i = 1 to nargs_m_1 do + c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c) + done; + !c + +let comp_app comp_fun comp_arg reloc f args sz cont = + let nargs = Array.length args in + match is_tailcall cont with + | Some k -> + comp_args comp_arg reloc args sz + (Kpush :: + comp_fun reloc f (sz + nargs) + (Kappterm(nargs, k + nargs) :: (discard_dead_code cont))) + | None -> + if nargs < 4 then + comp_args comp_arg reloc args sz + (Kpush :: (comp_fun reloc f (sz+nargs) (Kapply nargs :: cont))) + else + let lbl,cont1 = label_code cont in + Kpush_retaddr lbl :: + (comp_args comp_arg reloc args (sz + 3) + (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1)))) + +(* Compilation des variables libres *) + +let compile_fv_elem reloc fv sz cont = + match fv with + | FVrel i -> pos_rel i reloc sz :: cont + | FVnamed id -> pos_named id reloc :: cont + +(* compilation des constantes *) + +let rec get_allias env kn = + let tps = (lookup_constant kn env).const_body_code in + match Cemitcodes.force tps with + | BCallias kn' -> get_allias env kn' + | _ -> kn + +(* compilation des expressions *) + +let rec compile_constr reloc c sz cont = + match kind_of_term c with + | Meta _ -> raise (Invalid_argument "Cbytegen.gen_lam : Meta") + | Evar _ -> raise (Invalid_argument "Cbytegen.gen_lam : Evar") + + | Cast(c,_) -> compile_constr reloc c sz cont + + | Rel i -> pos_rel i reloc sz :: cont + | Var id -> pos_named id reloc :: cont + | Const kn -> Kgetglobal (get_allias !global_env kn) :: cont + + | Sort _ | Ind _ | Construct _ -> + compile_str_cst reloc (str_const c) sz cont + + | LetIn(_,xb,_,body) -> + compile_constr reloc xb sz + (Kpush :: + (compile_constr (push_local sz reloc) body (sz+1) (add_pop 1 cont))) + | Prod(id,dom,codom) -> + let cont1 = + Kpush :: compile_constr reloc dom (sz+1) (Kmakeprod :: cont) in + compile_constr reloc (mkLambda(id,dom,codom)) sz cont1 + | Lambda _ -> + let params, body = decompose_lam c in + let arity = List.length params in + let r_fun = init_fun arity in + let lbl_fun = Label.create() in + let cont_fun = + compile_constr r_fun body arity [Kreturn arity] in + fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; + let fv = fv r_fun in + compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) + + | App(f,args) -> + begin + match kind_of_term f with + | Construct _ -> compile_str_cst reloc (str_const c) sz cont + | _ -> comp_app compile_constr compile_constr reloc f args sz cont + end + | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) -> + let ndef = Array.length type_bodies in + let rfv = ref empty_fv in + let lbl_types = Array.create ndef Label.no in + let lbl_bodies = Array.create ndef Label.no in + (* Compilation des types *) + let rtype = init_type ndef rfv in + for i = 0 to ndef - 1 do + let lbl,fcode = + label_code + (compile_constr rtype type_bodies.(i) 0 [Kstop]) in + lbl_types.(i) <- lbl; + fun_code := [Ksequence(fcode,!fun_code)] + done; + (* Compilation des corps *) + for i = 0 to ndef - 1 do + let params,body = decompose_lam rec_bodies.(i) in + let arity = List.length params in + let rbody = init_fix ndef i arity rfv in + let cont1 = + compile_constr rbody body arity [Kreturn arity] in + let lbl = Label.create () in + lbl_bodies.(i) <- lbl; + let fcode = + if arity = 1 then + Klabel lbl :: Kgrabrec 0 :: Krestart :: cont1 + else + Krestart :: Klabel lbl :: Kgrabrec rec_args.(i) :: + Krestart :: Kgrab (arity - 1) :: cont1 + in + fun_code := [Ksequence(fcode,!fun_code)] + done; + let fv = !rfv in + compile_fv reloc fv.fv_rev sz + (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) + + | CoFix(init,(_,type_bodies,rec_bodies)) -> + let ndef = Array.length type_bodies in + let rfv = ref empty_fv in + let lbl_types = Array.create ndef Label.no in + let lbl_bodies = Array.create ndef Label.no in + (* Compilation des types *) + let rtype = init_type ndef rfv in + for i = 0 to ndef - 1 do + let lbl,fcode = + label_code + (compile_constr rtype type_bodies.(i) 0 [Kstop]) in + lbl_types.(i) <- lbl; + fun_code := [Ksequence(fcode,!fun_code)] + done; + (* Compilation des corps *) + for i = 0 to ndef - 1 do + let params,body = decompose_lam rec_bodies.(i) in + let arity = List.length params in + let rbody = init_fix ndef i arity rfv in + let lbl = Label.create () in + + let cont1 = + compile_constr rbody body arity [Kreturn(arity)] in + let cont2 = + if arity <= 1 then cont1 else Kgrab (arity - 1) :: cont1 in + let cont3 = + Krestart :: Klabel lbl :: Kcograb arity :: Krestart :: cont2 in + fun_code := [Ksequence(cont3,!fun_code)]; + lbl_bodies.(i) <- lbl + done; + let fv = !rfv in + compile_fv reloc fv.fv_rev sz + (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) + + | Case(ci,t,a,branchs) -> + let ind = ci.ci_ind in + let mib = lookup_mind (fst ind) !global_env in + let oib = mib.mind_packets.(snd ind) in + let tbl = oib.mind_reloc_tbl in + let lbl_consts = Array.create oib.mind_nb_constant Label.no in + let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in + let branch1,cont = make_branch cont in + (* Compilation du type *) + let lbl_typ,fcode = + label_code (compile_constr reloc t sz [Kpop sz; Kstop]) + in fun_code := [Ksequence(fcode,!fun_code)]; + (* Compilation des branches *) + let lbl_sw = Label.create () in + let sz_b,branch,is_tailcall = + match branch1 with + | Kreturn k -> assert (k = sz); sz, branch1, true + | _ -> sz+3, Kjump, false + in + let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in + (* Compilation de la branche accumulate *) + let lbl_accu, code_accu = + label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) + in + lbl_blocks.(0) <- lbl_accu; + let c = ref code_accu in + (* Compilation des branches constructeurs *) + for i = 0 to Array.length tbl - 1 do + let tag, arity = tbl.(i) in + if arity = 0 then + let lbl_b,code_b = + label_code(compile_constr reloc branchs.(i) sz_b (branch :: !c)) in + lbl_consts.(tag) <- lbl_b; + c := code_b + else + let args, body = decompose_lam branchs.(i) in + let nargs = List.length args in + let lbl_b,code_b = + label_code( + if nargs = arity then + Kpushfield arity :: + compile_constr (push_param arity sz_b reloc) + body (sz_b+arity) (add_pop arity (branch :: !c)) + else + let sz_appterm = if is_tailcall then sz_b + arity else arity in + Kpushfield arity :: + compile_constr reloc branchs.(i) (sz_b+arity) + (Kappterm(arity,sz_appterm) :: !c)) + in + lbl_blocks.(tag) <- lbl_b; + c := code_b + done; + c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c; + let code_sw = + match branch1 with + | Klabel lbl -> Kpush_retaddr lbl :: !c + | _ -> !c + in + let cont_a = if mib.mind_finite then code_sw else Kforce :: code_sw in + compile_constr reloc a sz cont_a + +and compile_fv reloc l sz cont = + match l with + | [] -> cont + | [fvn] -> compile_fv_elem reloc fvn sz cont + | fvn :: tl -> + compile_fv_elem reloc fvn sz + (Kpush :: compile_fv reloc tl (sz + 1) cont) + +and compile_str_cst reloc sc sz cont = + match sc with + | Bconstr c -> compile_constr reloc c sz cont + | Bstrconst sc -> Kconst sc :: cont + | Bmakeblock(tag,args) -> + let nargs = Array.length args in + comp_args compile_str_cst reloc args sz (Kmakeblock(nargs,tag) :: cont) + | Bconstruct_app(tag,nparams,arity,args) -> + if args = [||] then code_construct tag nparams arity cont + else + comp_app + (fun _ _ _ cont -> code_construct tag nparams arity cont) + compile_str_cst reloc () args sz cont + +let compile env c = + set_global_env env; + init_fun_code (); + Label.reset_label_counter (); + let reloc = empty () in + let init_code = compile_constr reloc c 0 [Kstop] in + let fv = List.rev (!(reloc.in_env).fv_rev) in + init_code,!fun_code, Array.of_list fv + +let compile_constant_body env kn body opaque boxed = + if opaque then BCconstant + else match body with + | None -> BCconstant + | Some sb -> + let body = Declarations.force sb in + match kind_of_term body with + | Const kn' -> BCallias (get_allias env kn') + | _ -> + let to_patch = to_memory (compile env body) in + BCdefined (boxed,to_patch) + diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli new file mode 100644 index 000000000..407edea44 --- /dev/null +++ b/kernel/cbytegen.mli @@ -0,0 +1,16 @@ +open Names +open Cbytecodes +open Cemitcodes +open Term +open Declarations +open Environ + + + +val compile : env -> constr -> bytecodes * bytecodes * fv + (* init, fun, fv *) + +val compile_constant_body : + env -> constant -> constr_substituted option -> bool -> bool -> body_code + (* opaque *) (* boxed *) + diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml new file mode 100644 index 000000000..ab1f00d11 --- /dev/null +++ b/kernel/cemitcodes.ml @@ -0,0 +1,339 @@ +open Names +open Term +open Cbytecodes +open Copcodes + +(* Relocation information *) +type reloc_info = + | Reloc_annot of annot_switch + | Reloc_const of structured_constant + | Reloc_getglobal of constant + +type patch = reloc_info * int + +let patch_int buff pos n = + String.unsafe_set buff pos (Char.unsafe_chr n); + String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8)); + String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16)); + String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24)) + +let cGETGLOBALBOXED = Char.unsafe_chr opGETGLOBALBOXED +let cGETGLOBAL = Char.unsafe_chr opGETGLOBAL + +let cPUSHGETGLOBALBOXED = Char.unsafe_chr opPUSHGETGLOBALBOXED +let cPUSHGETGLOBAL = Char.unsafe_chr opPUSHGETGLOBAL + +let is_PUSHGET c = + c = cPUSHGETGLOBAL || c = cPUSHGETGLOBALBOXED + +let patch_getglobal buff pos (boxed,n) = + let posinstr = pos - 4 in + let c = String.unsafe_get buff posinstr in + begin match is_PUSHGET c, boxed with + | true, true -> String.unsafe_set buff posinstr cPUSHGETGLOBALBOXED + | true, false -> String.unsafe_set buff posinstr cPUSHGETGLOBAL + | false, true -> String.unsafe_set buff posinstr cGETGLOBALBOXED + | false,false -> String.unsafe_set buff posinstr cGETGLOBAL + end; + patch_int buff pos n + +(* Buffering of bytecode *) + +let out_buffer = ref(String.create 1024) +and out_position = ref 0 + +let out_word b1 b2 b3 b4 = + let p = !out_position in + if p >= String.length !out_buffer then begin + let len = String.length !out_buffer in + let new_buffer = String.create (2 * len) in + String.blit !out_buffer 0 new_buffer 0 len; + out_buffer := new_buffer + end; + String.unsafe_set !out_buffer p (Char.unsafe_chr b1); + String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2); + String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3); + String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4); + out_position := p + 4 + +let out opcode = + out_word opcode 0 0 0 + +let out_int n = + out_word n (n asr 8) (n asr 16) (n asr 24) + +(* Handling of local labels and backpatching *) + +type label_definition = + Label_defined of int + | Label_undefined of (int * int) list + +let label_table = ref ([| |] : label_definition array) +(* le ieme element de la table = Label_defined n signifie que l'on a + deja rencontrer le label i et qu'il est a l'offset n. + = Label_undefined l signifie que l'on a + pas encore rencontrer ce label, le premier entier indique ou est l'entier + a patcher dans la string, le deuxieme son origine *) + +let extend_label_table needed = + let new_size = ref(Array.length !label_table) in + while needed >= !new_size do new_size := 2 * !new_size done; + let new_table = Array.create !new_size (Label_undefined []) in + Array.blit !label_table 0 new_table 0 (Array.length !label_table); + label_table := new_table + +let backpatch (pos, orig) = + let displ = (!out_position - orig) asr 2 in + !out_buffer.[pos] <- Char.unsafe_chr displ; + !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8); + !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16); + !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24) + +let define_label lbl = + if lbl >= Array.length !label_table then extend_label_table lbl; + match (!label_table).(lbl) with + Label_defined _ -> + raise(Failure "CEmitcode.define_label") + | Label_undefined patchlist -> + List.iter backpatch patchlist; + (!label_table).(lbl) <- Label_defined !out_position + +let out_label_with_orig orig lbl = + if lbl >= Array.length !label_table then extend_label_table lbl; + match (!label_table).(lbl) with + Label_defined def -> + out_int((def - orig) asr 2) + | Label_undefined patchlist -> + if patchlist = [] then + (!label_table).(lbl) <- + Label_undefined((!out_position, orig) :: patchlist); + out_int 0 + +let out_label l = out_label_with_orig !out_position l + +(* Relocation information *) + +let reloc_info = ref ([] : (reloc_info * int) list) + +let enter info = + reloc_info := (info, !out_position) :: !reloc_info + +let slot_for_const c = + enter (Reloc_const c); + out_int 0 + +and slot_for_annot a = + enter (Reloc_annot a); + out_int 0 + +and slot_for_getglobal id = + enter (Reloc_getglobal id); + out_int 0 + + +(* Emission of one instruction *) + + +let emit_instr = function + | Klabel lbl -> define_label lbl + | Kacc n -> + if n < 8 then out(opACC0 + n) else (out opACC; out_int n) + | Kenvacc n -> + if n >= 1 && n <= 4 + then out(opENVACC1 + n - 1) + else (out opENVACC; out_int n) + | Koffsetclosure ofs -> + if ofs = -2 || ofs = 0 || ofs = 2 + then out (opOFFSETCLOSURE0 + ofs / 2) + else (out opOFFSETCLOSURE; out_int ofs) + | Kpush -> + out opPUSH + | Kpop n -> + out opPOP; out_int n + | Kpush_retaddr lbl -> + out opPUSH_RETADDR; out_label lbl + | Kapply n -> + if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n) + | Kappterm(n, sz) -> + if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz) + else (out opAPPTERM; out_int n; out_int sz) + | Kreturn n -> + out opRETURN; out_int n + | Kjump -> + out opRETURN; out_int 0 + | Krestart -> + out opRESTART + | Kgrab n -> + out opGRAB; out_int n + | Kgrabrec(rec_arg) -> + out opGRABREC; out_int rec_arg + | Kcograb n -> + out opCOGRAB; out_int n + | Kclosure(lbl, n) -> + out opCLOSURE; out_int n; out_label lbl + | Kclosurerec(nfv,init,lbl_types,lbl_bodies) -> + out opCLOSUREREC;out_int (Array.length lbl_bodies); + out_int nfv; out_int init; + let org = !out_position in + Array.iter (out_label_with_orig org) lbl_types; + let org = !out_position in + Array.iter (out_label_with_orig org) lbl_bodies + | Kgetglobal q -> + out opGETGLOBAL; slot_for_getglobal q + | Kconst((Const_b0 i)) -> + if i >= 0 && i <= 3 + then out (opCONST0 + i) + else (out opCONSTINT; out_int i) + | Kconst c -> + out opGETGLOBAL; slot_for_const c + | Kmakeblock(n, t) -> + if n = 0 then raise (Invalid_argument "emit_instr : block size = 0") + else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t) + else (out opMAKEBLOCK; out_int n; out_int t) + | Kmakeprod -> + out opMAKEPROD + | Kmakeswitchblock(typlbl,swlbl,annot,sz) -> + out opMAKESWITCHBLOCK; + out_label typlbl; out_label swlbl; + slot_for_annot annot;out_int sz + | Kforce -> + out opFORCE + | Kswitch (tbl_const, tbl_block) -> + out opSWITCH; + out_int (Array.length tbl_const + (Array.length tbl_block lsl 16)); + let org = !out_position in + Array.iter (out_label_with_orig org) tbl_const; + Array.iter (out_label_with_orig org) tbl_block + | Kpushfield n -> + out opPUSHFIELD;out_int n + | Kstop -> + out opSTOP + | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr") + +(* Emission of a list of instructions. Include some peephole optimization. *) + +let rec emit = function + | [] -> () + (* Peephole optimizations *) + | Kpush :: Kacc n :: c -> + if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); + emit c + | Kpush :: Kenvacc n :: c -> + if n >= 1 && n <= 4 + then out(opPUSHENVACC1 + n - 1) + else (out opPUSHENVACC; out_int n); + emit c + | Kpush :: Koffsetclosure ofs :: c -> + if ofs = -2 || ofs = 0 || ofs = 2 + then out(opPUSHOFFSETCLOSURE0 + ofs / 2) + else (out opPUSHOFFSETCLOSURE; out_int ofs); + emit c + | Kpush :: Kgetglobal id :: c -> + out opPUSHGETGLOBAL; slot_for_getglobal id; emit c + | Kpush :: Kconst (Const_b0 i) :: c -> + if i >= 0 && i <= 3 + then out (opPUSHCONST0 + i) + else (out opPUSHCONSTINT; out_int i); + emit c + | Kpush :: Kconst const :: c -> + out opPUSHGETGLOBAL; slot_for_const const; + emit c + | Kpop n :: Kjump :: c -> + out opRETURN; out_int n; emit c + | Ksequence(c1,c2)::c -> + emit c1; emit c2;emit c + (* Default case *) + | instr :: c -> + emit_instr instr; emit c + +(* Initialization *) + +let init () = + out_position := 0; + label_table := Array.create 16 (Label_undefined []); + reloc_info := [] + +type emitcodes = string + +let length = String.length + +type to_patch = emitcodes * (patch list) * fv + +(* Substitution *) +let rec subst_strcst s sc = + match sc with + | Const_sorts _ | Const_b0 _ -> sc + | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) + | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_kn s kn, i)) + +let subst_patch s (ri,pos) = + match ri with + | Reloc_annot a -> + let (kn,i) = a.ci.ci_ind in + let ci = {a.ci with ci_ind = (subst_kn s kn,i)} in + (Reloc_annot {a with ci = ci},pos) + | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) + | Reloc_getglobal kn -> (Reloc_getglobal (subst_kn s kn), pos) + +let subst_to_patch s (code,pl,fv) = code,List.map (subst_patch s) pl,fv + +type body_code = + | BCdefined of bool * to_patch + | BCallias of constant + | BCconstant + +let subst_body_code s = function + | BCdefined (b,tp) -> BCdefined (b,subst_to_patch s tp) + | BCallias kn -> BCallias (subst_kn s kn) + | BCconstant -> BCconstant + +type to_patch_substituted = body_code substituted + +let from_val = from_val + +let force = force subst_body_code + +let subst_to_patch_subst = subst_substituted + +let is_boxed tps = + match force tps with + | BCdefined(b,_) -> b + | _ -> false + +let to_memory (init_code, fun_code, fv) = + init(); + emit init_code; + emit fun_code; + let code = String.create !out_position in + String.unsafe_blit !out_buffer 0 code 0 !out_position; + let reloc = List.rev !reloc_info in + Array.iter (fun lbl -> + (match lbl with + Label_defined _ -> assert true + | Label_undefined patchlist -> + assert (patchlist = []))) !label_table; + (code, reloc, fv) + + + + + + + +(* Code pour la machine virtuelle *) +let mkAccu_code n = + init (); + out opMAKEACCU; out_int n; + let code = String.create !out_position in + String.unsafe_blit !out_buffer 0 code 0 !out_position; + code + +let mkPopStop_code n = + init(); + if n = 0 then out opSTOP + else (out opPOP; out_int n; out opSTOP); + let code = String.create !out_position in + String.unsafe_blit !out_buffer 0 code 0 !out_position; + code + + diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli new file mode 100644 index 000000000..fed577158 --- /dev/null +++ b/kernel/cemitcodes.mli @@ -0,0 +1,41 @@ +open Names +open Cbytecodes + +type reloc_info = + | Reloc_annot of annot_switch + | Reloc_const of structured_constant + | Reloc_getglobal of constant + +type patch = reloc_info * int +(* A virer *) +val subst_patch : substitution -> patch -> patch + +type emitcodes + +val length : emitcodes -> int + +val patch_int : emitcodes -> (*pos*)int -> int -> unit +val patch_getglobal : emitcodes -> (*pos*)int -> (bool*int) -> unit + +type to_patch = emitcodes * (patch list) * fv + +val subst_to_patch : substitution -> to_patch -> to_patch + +type body_code = + | BCdefined of bool*to_patch + | BCallias of constant + | BCconstant + + +type to_patch_substituted + +val from_val : body_code -> to_patch_substituted + +val force : to_patch_substituted -> body_code + +val is_boxed : to_patch_substituted -> bool + +val subst_to_patch_subst : substitution -> to_patch_substituted -> to_patch_substituted + +val to_memory : bytecodes * bytecodes * fv -> to_patch + (* init code, fun code, fv *) diff --git a/kernel/closure.ml b/kernel/closure.ml index f4db948a0..51c355c9a 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -16,7 +16,6 @@ open Declarations open Environ open Esubst - let stats = ref false let share = ref true @@ -52,8 +51,6 @@ let with_stats c = end else Lazy.force c -type transparent_state = Idpred.t * KNpred.t - let all_opaque = (Idpred.empty, KNpred.empty) let all_transparent = (Idpred.full, KNpred.full) @@ -326,11 +323,7 @@ fin obsolète **************) * instantiations (cbv or lazy) are. *) -type table_key = - | ConstKey of constant - | VarKey of identifier - | FarRelKey of int - (* FarRel: index in the rel_context part of _initial_ environment *) +type table_key = id_key type 'a infos = { i_flags : reds; @@ -349,7 +342,7 @@ let ref_value_cache info ref = try let body = match ref with - | FarRelKey n -> + | RelKey n -> let (s,l) = info.i_rels in lift n (List.assoc (s-n) l) | VarKey id -> List.assoc id info.i_vars | ConstKey cst -> constant_value info.i_env cst @@ -573,7 +566,7 @@ let clos_rel e i = | Inl(n,mt) -> lift_fconstr n mt | Inr(k,None) -> {norm=Norm; term= FRel k} | Inr(k,Some p) -> - lift_fconstr (k-p) {norm=Norm;term=FFlex(FarRelKey p)} + lift_fconstr (k-p) {norm=Norm;term=FFlex(RelKey p)} (* since the head may be reducible, we might introduce lifts of 0 *) let compact_stack head stk = @@ -730,7 +723,7 @@ let mk_clos2 = mk_clos_deep mk_clos let rec to_constr constr_fun lfts v = match v.term with | FRel i -> mkRel (reloc_rel i lfts) - | FFlex (FarRelKey p) -> mkRel (reloc_rel p lfts) + | FFlex (RelKey p) -> mkRel (reloc_rel p lfts) | FFlex (VarKey x) -> mkVar x | FAtom c -> (match kind_of_term c with @@ -1023,8 +1016,8 @@ let rec knr info m stk = (match ref_value_cache info (VarKey id) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) - | FFlex(FarRelKey k) when red_set info.i_flags fDELTA -> - (match ref_value_cache info (FarRelKey k) with + | FFlex(RelKey k) when red_set info.i_flags fDELTA -> + (match ref_value_cache info (RelKey k) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FConstruct(ind,c) when red_set info.i_flags fIOTA -> diff --git a/kernel/closure.mli b/kernel/closure.mli index e0cfe7b51..dae168941 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -27,7 +27,7 @@ val with_stats: 'a Lazy.t -> 'a Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) -type transparent_state = Idpred.t * KNpred.t + val all_opaque : transparent_state val all_transparent : transparent_state @@ -82,13 +82,8 @@ val betadeltaiotanolet : reds val unfold_red : evaluable_global_reference -> reds -(************************************************************************) - -type table_key = - | ConstKey of constant - | VarKey of identifier - | FarRelKey of int - (* FarRel: index in the [rel_context] part of {\em initial} environment *) +(***********************************************************************) +type table_key = id_key type 'a infos val ref_value_cache: 'a infos -> table_key -> 'a option diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index 11d4435c2..1504220ac 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -9,7 +9,6 @@ (* $Id$ *) open Names -open Closure (* Opaque constants *) let cst_transp = ref KNpred.full @@ -31,13 +30,13 @@ let is_opaque_var kn = not (Idpred.mem kn !var_transp) let is_opaque = function | ConstKey cst -> is_opaque_cst cst | VarKey id -> is_opaque_var id - | FarRelKey _ -> false + | RelKey _ -> false (* Unfold the first only if it is not opaque and the second is opaque *) let oracle_order k1 k2 = is_opaque k2 & not (is_opaque k1) (* summary operations *) - +type transparent_state = Idpred.t * KNpred.t let init() = (cst_transp := KNpred.full; var_transp := Idpred.full) let freeze () = (!var_transp, !cst_transp) let unfreeze (vo,co) = (cst_transp := co; var_transp := vo) diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index 8dad2e2bd..351df9d86 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -9,13 +9,13 @@ (* $Id$ *) open Names -open Closure + (* Order on section paths for unfolding. If [oracle_order kn1 kn2] is true, then unfold kn1 first. Note: the oracle does not introduce incompleteness, it only tries to postpone unfolding of "opaque" constants. *) -val oracle_order : table_key -> table_key -> bool +val oracle_order : 'a tableKey -> 'a tableKey -> bool (* Changing the oracle *) val set_opaque_const : kernel_name -> unit diff --git a/kernel/cooking.ml b/kernel/cooking.ml index c37c81cf6..5c058b466 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -169,4 +169,5 @@ let cook_constant env r = cb.const_hyps ~init:empty_named_context in let body,typ = abstract_constant r.d_abstract hyps (body,typ) in - (body, typ, cb.const_constraints, cb.const_opaque) + let boxed = Cemitcodes.is_boxed cb.const_body_code in + (body, typ, cb.const_constraints, cb.const_opaque, boxed) diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 7bd64d326..289373eff 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -32,7 +32,8 @@ type recipe = { d_modlist : work_list } val cook_constant : - env -> recipe -> constr_substituted option * constr * constraints * bool + env -> recipe -> + constr_substituted option * constr * constraints * bool * bool (*s Utility functions used in module [Discharge]. *) diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml new file mode 100644 index 000000000..3cc6f49d5 --- /dev/null +++ b/kernel/csymtable.ml @@ -0,0 +1,163 @@ +open Names +open Term +open Vm +open Cemitcodes +open Cbytecodes +open Declarations +open Environ +open Cbytegen +open Cemitcodes + +external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code" +external free_tcode : tcode -> unit = "coq_static_free" +external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" + +(*******************) +(* Linkage du code *) +(*******************) + +(* Table des globaux *) + +(* [global_data] contient les valeurs des constantes globales + (axiomes,definitions), les annotations des switch et les structured + constant *) +external global_data : unit -> values array = "get_coq_global_data" + +(* [realloc_global_data n] augmente de n la taille de [global_data] *) +external realloc_global_data : int -> unit = "realloc_coq_global_data" + +let check_global_data n = + if n >= Array.length (global_data()) then realloc_global_data n + +let num_global = ref 0 + +let set_global v = + let n = !num_global in + check_global_data n; + (global_data()).(n) <- v; + incr num_global; + n + +(* [global_transp],[global_boxed] contiennent les valeurs des + definitions gelees. Les deux versions sont maintenues en //. + [global_transp] contient la version transparente. + [global_boxed] contient la version gelees. *) + +external global_transp : unit -> values array = "get_coq_global_transp" +external global_boxed : unit -> values array = "get_coq_global_boxed" + +(* [realloc_global_data n] augmente de n la taille de [global_data] *) +external realloc_global_boxed : int -> unit = "realloc_coq_global_boxed" + +let check_global_boxed n = + if n >= Array.length (global_boxed()) then realloc_global_boxed n + +let num_boxed = ref 0 + +let set_boxed kn v = + let n = !num_boxed in + check_global_boxed n; + (global_transp()).(n) <- v; + let vb = val_of_constant_def kn v in + (global_boxed()).(n) <- vb; + incr num_boxed; + n + +(* table pour les structured_constant et les annotations des switchs *) + +let str_cst_tbl = Hashtbl.create 31 + (* (structured_constant * int) Hashtbl.t*) + +let annot_tbl = Hashtbl.create 31 + (* (annot_switch * int) Hashtbl.t *) + +(************************) +(* traduction des patch *) + +(* slot_for_*, calcul la valeur de l'objet, la place + dans la table global, rend sa position dans la table *) + +let slot_for_str_cst key = + try Hashtbl.find str_cst_tbl key + with Not_found -> + let n = set_global (val_of_str_const key) in + Hashtbl.add str_cst_tbl key n; + n + +let slot_for_annot key = + try Hashtbl.find annot_tbl key + with Not_found -> + let n = set_global (Obj.magic key) in + Hashtbl.add annot_tbl key n; + n + +let rec slot_for_getglobal env kn = + let ck = lookup_constant_key kn env in + try constant_key_pos ck + with NotEvaluated -> + match force (constant_key_body ck).const_body_code with + | BCdefined(boxed,(code,pl,fv)) -> + let v = eval_to_patch env (code,pl,fv) in + let pos = + if boxed then set_boxed kn v + else set_global v in + let bpos = boxed,pos in + set_pos_constant ck bpos; + bpos + | BCallias kn' -> + let bpos = slot_for_getglobal env kn' in + set_pos_constant ck bpos; + bpos + | BCconstant -> + let v = val_of_constant kn in + let pos = set_global v in + let bpos = false,pos in + set_pos_constant ck bpos; + bpos + +and slot_for_fv env fv= + match fv with + | FVnamed id -> + let nv = lookup_namedval id env in + begin + match kind_of_named nv with + | VKvalue v -> v + | VKaxiom id -> + let v = val_of_named id in + set_namedval nv v; v + | VKdef(c,e) -> + let v = val_of_constr e c in + set_namedval nv v; v + end + | FVrel i -> + let rv = lookup_relval i env in + begin + match kind_of_rel rv with + | VKvalue v -> v + | VKaxiom k -> + let v = val_of_rel k in + set_relval rv v; v + | VKdef(c,e) -> + let v = val_of_constr e c in + let k = nb_rel e in + set_relval rv v; v + end + +and eval_to_patch env (buff,pl,fv) = + let patch = function + | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a) + | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc) + | Reloc_getglobal kn, pos -> + patch_getglobal buff pos (slot_for_getglobal env kn) + in + List.iter patch pl; + let nfv = Array.length fv in + let vm_env = Array.map (slot_for_fv env) fv in + let tc = tcode_of_code buff (length buff) in + eval_tcode tc vm_env + +and val_of_constr env c = + let (_,fun_code,_ as ccfv) = compile env c in + eval_to_patch env (to_memory ccfv) + + diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli new file mode 100644 index 000000000..8bb0b890c --- /dev/null +++ b/kernel/csymtable.mli @@ -0,0 +1,6 @@ +open Names +open Term +open Environ + +val val_of_constr : env -> constr -> values + diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 152c1e5bf..b5505bce3 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -21,33 +21,22 @@ open Sign (*s Constants (internal representation) (Definition/Axiom) *) -type subst_internal = - | Constr of constr - | LazyConstr of substitution * constr +type constr_substituted = constr substituted -type constr_substituted = subst_internal ref +let from_val = from_val -let from_val c = ref (Constr c) +let force = force subst_mps -let force cs = match !cs with - Constr c -> c - | LazyConstr (subst,c) -> - let c' = subst_mps subst c in - cs := Constr c'; - c' - -let subst_constr_subst subst cs = match !cs with - Constr c -> ref (LazyConstr (subst,c)) - | LazyConstr (subst',c) -> - let subst'' = join subst' subst in - ref (LazyConstr (subst'',c)) +let subst_constr_subst = subst_substituted type constant_body = { - const_hyps : section_context; (* New: younger hyp at top *) - const_body : constr_substituted option; - const_type : types; - const_constraints : constraints; - const_opaque : bool } + const_hyps : section_context; (* New: younger hyp at top *) + const_body : constr_substituted option; + const_type : types; + const_body_code : Cemitcodes.to_patch_substituted; + (* const_type_code : Cemitcodes.to_patch; *) + const_constraints : constraints; + const_opaque : bool } (*s Inductive types (internal representation with redundant information). *) @@ -89,38 +78,43 @@ let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p inductives *) type one_inductive_body = { - mind_typename : identifier; - mind_nparams : int; - mind_params_ctxt : rel_context; - mind_nrealargs : int; - mind_nf_arity : types; - mind_user_arity : types; - mind_sort : sorts; - mind_kelim : sorts_family list; - mind_consnames : identifier array; - mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *) - mind_user_lc : types array; - mind_recargs : wf_paths; - } + mind_typename : identifier; + mind_nparams : int; + mind_params_ctxt : rel_context; + mind_nrealargs : int; + mind_nf_arity : types; + mind_user_arity : types; + mind_sort : sorts; + mind_kelim : sorts_family list; + mind_consnames : identifier array; + mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *) + mind_user_lc : types array; + mind_recargs : wf_paths; + mind_nb_constant : int; (* number of constant constructor *) + mind_nb_args : int; (* number of no constant constructor *) + mind_reloc_tbl : Cbytecodes.reloc_table; + } type mutual_inductive_body = { - mind_record : bool; - mind_finite : bool; - mind_ntypes : int; - mind_hyps : section_context; - mind_packets : one_inductive_body array; - mind_constraints : constraints; - mind_equiv : kernel_name option - } + mind_record : bool; + mind_finite : bool; + mind_ntypes : int; + mind_hyps : section_context; + mind_packets : one_inductive_body array; + mind_constraints : constraints; + mind_equiv : kernel_name option + } (* TODO: should be changed to non-coping after Term.subst_mps *) -let subst_const_body sub cb = - { const_body = option_app (subst_constr_subst sub) cb.const_body; - const_type = type_app (Term.subst_mps sub) cb.const_type; +let subst_const_body sub cb = { const_hyps = (assert (cb.const_hyps=[]); []); + const_body = option_app (subst_constr_subst sub) cb.const_body; + const_type = type_app (Term.subst_mps sub) cb.const_type; + const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code; + (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*) const_constraints = cb.const_constraints; - const_opaque = cb.const_opaque} - + const_opaque = cb.const_opaque } + let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; mind_typename = mbp.mind_typename; @@ -136,8 +130,11 @@ let subst_mind_packet sub mbp = mind_nparams = mbp.mind_nparams; mind_params_ctxt = map_rel_context (Term.subst_mps sub) mbp.mind_params_ctxt; - mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); -} + mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); + mind_nb_constant = mbp.mind_nb_constant; + mind_nb_args = mbp.mind_nb_args; + mind_reloc_tbl = mbp.mind_reloc_tbl } + let subst_mind sub mib = { mind_record = mib.mind_record ; @@ -146,8 +143,7 @@ let subst_mind sub mib = mind_hyps = (assert (mib.mind_hyps=[]); []) ; mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; mind_constraints = mib.mind_constraints ; - mind_equiv = option_app (subst_kn sub) mib.mind_equiv; -} + mind_equiv = option_app (subst_kn sub) mib.mind_equiv } (*s Modules: signature component specifications, module types, and @@ -171,7 +167,6 @@ and module_specification_body = msb_equiv : module_path option; msb_constraints : constraints } - type structure_elem_body = | SEBconst of constant_body | SEBmind of mutual_inductive_body diff --git a/kernel/declarations.mli b/kernel/declarations.mli index a168abdfb..50c866014 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -12,6 +12,7 @@ open Names open Univ open Term +open Cemitcodes open Sign (*i*) @@ -27,11 +28,13 @@ val from_val : constr -> constr_substituted val force : constr_substituted -> constr type constant_body = { - const_hyps : section_context; (* New: younger hyp at top *) - const_body : constr_substituted option; - const_type : types; - const_constraints : constraints; - const_opaque : bool } + const_hyps : section_context; (* New: younger hyp at top *) + const_body : constr_substituted option; + const_type : types; + const_body_code : to_patch_substituted; + (* const_type_code : to_patch;*) + const_constraints : constraints; + const_opaque : bool } val subst_const_body : substitution -> constant_body -> constant_body @@ -62,29 +65,34 @@ val subst_wf_paths : substitution -> wf_paths -> wf_paths inductives *) type one_inductive_body = { - mind_typename : identifier; - mind_nparams : int; - mind_params_ctxt : rel_context; - mind_nrealargs : int; - mind_nf_arity : types; - mind_user_arity : types; - mind_sort : sorts; - mind_kelim : sorts_family list; - mind_consnames : identifier array; - mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *) - mind_user_lc : types array; - mind_recargs : wf_paths; - } + mind_typename : identifier; + mind_nparams : int; + mind_params_ctxt : rel_context; + mind_nrealargs : int; + mind_nf_arity : types; + mind_user_arity : types; + mind_sort : sorts; + mind_kelim : sorts_family list; + mind_consnames : identifier array; + mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *) + mind_user_lc : types array; + mind_recargs : wf_paths; + mind_nb_constant : int; (* number of constant constructor *) + mind_nb_args : int; (* number of no constant constructor *) + mind_reloc_tbl : Cbytecodes.reloc_table; + } + + type mutual_inductive_body = { - mind_record : bool; - mind_finite : bool; - mind_ntypes : int; - mind_hyps : section_context; - mind_packets : one_inductive_body array; - mind_constraints : constraints; - mind_equiv : kernel_name option; - } + mind_record : bool; + mind_finite : bool; + mind_ntypes : int; + mind_hyps : section_context; + mind_packets : one_inductive_body array; + mind_constraints : constraints; + mind_equiv : kernel_name option; + } val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body diff --git a/kernel/entries.ml b/kernel/entries.ml index 4d485ff8c..504c11fdf 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -59,7 +59,8 @@ type mutual_inductive_entry = { type definition_entry = { const_entry_body : constr; const_entry_type : types option; - const_entry_opaque : bool } + const_entry_opaque : bool; + const_entry_boxed : bool} type parameter_entry = types diff --git a/kernel/entries.mli b/kernel/entries.mli index 4d485ff8c..4b4cee03a 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -59,7 +59,8 @@ type mutual_inductive_entry = { type definition_entry = { const_entry_body : constr; const_entry_type : types option; - const_entry_opaque : bool } + const_entry_opaque : bool; + const_entry_boxed : bool } type parameter_entry = types diff --git a/kernel/environ.ml b/kernel/environ.ml index 41b664309..3563a1340 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -23,10 +23,13 @@ type compilation_unit_name = dir_path * checksum type global = Constant | Inductive +type key = (bool*int) option ref +type constant_key = constant_body * key + type engagement = ImpredicativeSet type globals = { - env_constants : constant_body KNmap.t; + env_constants : constant_key KNmap.t; env_inductives : mutual_inductive_body KNmap.t; env_modules : module_body MPmap.t; env_modtypes : module_type_body KNmap.t } @@ -36,10 +39,20 @@ type stratification = { env_engagement : engagement option } -type env = { - env_globals : globals; - env_named_context : named_context; - env_rel_context : rel_context; +type 'a val_kind = + | VKvalue of values + | VKaxiom of 'a + | VKdef of constr * env + +and 'a lazy_val = 'a val_kind ref + +and env = { + env_globals : globals; + env_named_context : named_context; + env_named_val : (identifier * (identifier lazy_val)) list; + env_rel_context : rel_context; + env_rel_val : inv_rel_key lazy_val list; + env_nb_rel : int; env_stratification : stratification } let empty_env = { @@ -49,11 +62,16 @@ let empty_env = { env_modules = MPmap.empty; env_modtypes = KNmap.empty }; env_named_context = empty_named_context; + env_named_val = []; env_rel_context = empty_rel_context; + env_rel_val = []; + env_nb_rel = 0; env_stratification = { env_universes = initial_universes; env_engagement = None } } + + let engagement env = env.env_stratification.env_engagement let universes env = env.env_stratification.env_universes let named_context env = env.env_named_context @@ -63,6 +81,9 @@ let empty_context env = env.env_rel_context = empty_rel_context && env.env_named_context = empty_named_context +exception NotEvaluated +exception AllReadyEvaluated + (* Rel context *) let lookup_rel n env = Sign.lookup_rel n env.env_rel_context @@ -75,68 +96,135 @@ let evaluable_rel n env = with Not_found -> false +let nb_rel env = env.env_nb_rel + let push_rel d env = + let _,body,_ = d in + let rval = + match body with + | None -> ref (VKaxiom env.env_nb_rel) + | Some c -> ref (VKdef(c,env)) + in { env with - env_rel_context = add_rel_decl d env.env_rel_context } + env_rel_context = add_rel_decl d env.env_rel_context; + env_rel_val = rval :: env.env_rel_val; + env_nb_rel = env.env_nb_rel + 1 } + let push_rel_context ctxt x = Sign.fold_rel_context push_rel ctxt ~init:x + let push_rec_types (lna,typarray,_) env = let ctxt = array_map2_i (fun i na t -> (na, None, type_app (lift i) t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt - + let reset_rel_context env = { env with - env_rel_context = empty_rel_context } + env_rel_context = empty_rel_context; + env_rel_val = []; + env_nb_rel = 0 } let fold_rel_context f env ~init = snd (Sign.fold_rel_context (fun d (env,e) -> (push_rel d env, f env d e)) (rel_context env) ~init:(reset_rel_context env,init)) - - + +(* Abstract machine rel values *) +type relval = int lazy_val + +let kind_of_rel r = !r + +let set_relval r v = + match !r with + | VKvalue _ -> raise AllReadyEvaluated + | _ -> r := VKvalue v + +let lookup_relval n env = + try List.nth env.env_rel_val (n - 1) + with _ -> raise Not_found + (* Named context *) let lookup_named id env = Sign.lookup_named id env.env_named_context + -(* A local const is evaluable if it is defined and not opaque *) + +(* A local const is evaluable if it is defined *) let evaluable_named id env = try match lookup_named id env with - (_,Some _,_) -> true - | _ -> false + (_,Some _,_) -> true + | _ -> false with Not_found -> false - -let push_named d env = - { env with - env_named_context = Sign.add_named_decl d env.env_named_context } + +let push_named d env = + let id,body,_ = d in + let rval = + match body with + | None -> ref (VKaxiom id) + | Some c -> ref (VKdef(c,env)) + in + { env with + env_named_context = Sign.add_named_decl d env.env_named_context; + env_named_val = (id,rval):: env.env_named_val } let reset_context env = { env with - env_named_context = empty_named_context; - env_rel_context = empty_rel_context } + env_named_context = empty_named_context; + env_named_val = []; + env_rel_context = empty_rel_context; + env_rel_val = []; + env_nb_rel = 0 } let reset_with_named_context ctxt env = - { env with - env_named_context = ctxt; - env_rel_context = empty_rel_context } - + Sign.fold_named_context push_named ctxt ~init:(reset_context env) + let fold_named_context f env ~init = snd (Sign.fold_named_context (fun d (env,e) -> (push_named d env, f env d e)) (named_context env) ~init:(reset_context env,init)) - + let fold_named_context_reverse f ~init env = Sign.fold_named_context_reverse f ~init:init (named_context env) - + +(* Abstract machine values of local vars referred by names *) +type namedval = identifier lazy_val + +let kind_of_named r = !r + +let set_namedval r v = + match !r with + | VKvalue _ -> raise AllReadyEvaluated + | _ -> r := VKvalue v + +let lookup_namedval id env = + snd (List.find (fun (id',_) -> id = id') env.env_named_val) + (* Global constants *) -let lookup_constant kn env = + +let notevaluated = None + +let constant_key_pos (cb,r) = + match !r with + | None -> raise NotEvaluated + | Some key -> key + +let constant_key_body = fst + +let set_pos_constant (cb,r) bpos = + if !r = notevaluated then r := Some bpos + else raise AllReadyEvaluated + +let lookup_constant_key kn env = KNmap.find kn env.env_globals.env_constants -let add_constant kn cb env = - let new_constants = KNmap.add kn cb env.env_globals.env_constants in +let lookup_constant kn env = constant_key_body (lookup_constant_key kn env) + +let add_constant kn cs env = + let new_constants = + KNmap.add kn (cs,ref notevaluated) env.env_globals.env_constants in let new_globals = { env.env_globals with env_constants = new_constants } in diff --git a/kernel/environ.mli b/kernel/environ.mli index 71fc8e6d8..d570655ee 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -22,7 +22,9 @@ open Sign (* Environments have the following components: - a context for de Bruijn variables + - a context for de Bruijn variables vm values - a context for section variables and goal assumptions + - a context for section variables and goal assumptions vm values - a context for global constants and axioms - a context for inductive definitions - a set of universe constraints @@ -54,6 +56,18 @@ val push_rec_types : rec_declaration -> env -> env val lookup_rel : int -> env -> rel_declaration val evaluable_rel : int -> env -> bool +(* Abstract machine rel values *) +type 'a val_kind = + | VKvalue of values + | VKaxiom of 'a + | VKdef of constr * env + +type relval + +val kind_of_rel : relval -> inv_rel_key val_kind +val set_relval : relval -> values -> unit +val lookup_relval : int -> env -> relval +val nb_rel : env -> int (*s Recurrence on [rel_context] *) val fold_rel_context : (env -> rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a @@ -67,6 +81,13 @@ val push_named : named_declaration -> env -> env val lookup_named : variable -> env -> named_declaration val evaluable_named : variable -> env -> bool +(* Abstract machine values of local vars referred by names *) +type namedval + +val kind_of_named : namedval -> identifier val_kind +val set_namedval : namedval -> values -> unit +val lookup_namedval : identifier -> env -> namedval + (*s Recurrence on [named_context]: older declarations processed first *) val fold_named_context : (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a @@ -87,6 +108,15 @@ val add_constant : constant -> constant_body -> env -> env (* Looks up in the context of global constant names *) (* raises [Not_found] if the required path is not found *) +type constant_key +exception NotEvaluated +exception AllReadyEvaluated + +val constant_key_pos : constant_key -> bool*int +val constant_key_body : constant_key -> constant_body +val set_pos_constant : constant_key -> (bool*int) -> unit + +val lookup_constant_key : constant -> env -> constant_key val lookup_constant : constant -> env -> constant_body val evaluable_constant : constant -> env -> bool diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index dbf7bc58e..5f9f907f5 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -511,6 +511,19 @@ let build_inductive env env_ar record finite inds recargs cst = (* Elimination sorts *) let isunit = isunit && ntypes = 1 && (not (is_recursive recargs.(0))) in let kelim = allowed_sorts env issmall isunit ar_sort in + let nconst, nblock = ref 0, ref 0 in + let transf num = + let arity = List.length (dest_subterms recarg).(num) in + if arity = 0 then + let p = (!nconst, 0) in + incr nconst; p + else + let p = (!nblock + 1, arity) in + incr nblock; p + (* les tag des constructeur constant commence a 0, + les tag des constructeur non constant a 1 (0 => accumulator) *) + in + let rtbl = Array.init (List.length cnames) transf in (* Build the inductive packet *) { mind_typename = id; mind_nparams = nparamargs; @@ -523,7 +536,10 @@ let build_inductive env env_ar record finite inds recargs cst = mind_consnames = Array.of_list cnames; mind_user_lc = lc; mind_nf_lc = nf_lc; - mind_recargs = recarg; + mind_recargs = recarg; + mind_nb_constant = !nconst; + mind_nb_args = !nblock; + mind_reloc_tbl = rtbl; } in let packets = array_map2 build_one_packet inds recargs in (* Build the mutual inductive *) diff --git a/kernel/make-opcodes b/kernel/make-opcodes new file mode 100644 index 000000000..c8f573c68 --- /dev/null +++ b/kernel/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/kernel/mod_typing.ml b/kernel/mod_typing.ml index a96bc52fc..a3639ef98 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -145,7 +145,7 @@ and translate_entry_list env msid is_definition sig_e = let kn = make_kn mp empty_dirpath l in match e with | SPEconst ce -> - let cb = translate_constant env ce in + let cb = translate_constant env kn ce in begin match cb.const_hyps with | (_::_) -> error_local_context (Some l) | [] -> diff --git a/kernel/names.ml b/kernel/names.ml index 68622703d..8211cf845 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -203,8 +203,29 @@ let occur_uid uid sub = let occur_msid = occur_uid let occur_mbid = occur_uid - - + +type 'a lazy_subst = + | LSval of 'a + | LSlazy of substitution * 'a + +type 'a substituted = 'a lazy_subst ref + +let from_val a = ref (LSval a) + +let force fsubst r = + match !r with + | LSval a -> a + | LSlazy(s,a) -> + let a' = fsubst s a in + r := LSval a'; + a' + +let subst_substituted s r = + match !r with + | LSval a -> ref (LSlazy(s,a)) + | LSlazy(s',a) -> + let s'' = join s' s in + ref (LSlazy(s'',a)) (* Kernel names *) @@ -353,3 +374,23 @@ let hcons_names () = let hmod = Hashcons.simple_hcons Hmod.f (hdir,huniqid,hstring) in let hkn = Hashcons.simple_hcons Hkn.f (hmod,hdir,hstring) in (hkn,hdir,hname,hident,hstring) + + +(*******) + +type transparent_state = Idpred.t * KNpred.t + +type 'a tableKey = + | ConstKey of constant + | VarKey of identifier + | RelKey of 'a + + +type inv_rel_key = int (* index in the [rel_context] part of environment + starting by the end, {\em inverse} + of de Bruijn indice *) + +type id_key = inv_rel_key tableKey + + + diff --git a/kernel/names.mli b/kernel/names.mli index bd7b52687..a08d1be23 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -103,6 +103,11 @@ val map_mbid : mod_bound_id -> module_path -> substitution *) val join : substitution -> substitution -> substitution +type 'a substituted +val from_val : 'a -> 'a substituted +val force : (substitution -> 'a -> 'a) -> 'a substituted -> 'a +val subst_substituted : substitution -> 'a substituted -> 'a substituted + (*i debugging *) val debug_string_of_subst : substitution -> string val debug_pr_subst : substitution -> Pp.std_ppcmds @@ -174,3 +179,19 @@ type evaluable_global_reference = val hcons_names : unit -> (kernel_name -> kernel_name) * (dir_path -> dir_path) * (name -> name) * (identifier -> identifier) * (string -> string) + + +(******) + +type 'a tableKey = + | ConstKey of constant + | VarKey of identifier + | RelKey of 'a + +type transparent_state = Idpred.t * KNpred.t + +type inv_rel_key = int (* index in the [rel_context] part of environment + starting by the end, {\em inverse} + of de Bruijn indice *) + +type id_key = inv_rel_key tableKey diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 28628cbda..85d668f7a 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -317,16 +317,15 @@ and convert_vect infos lft1 lft2 v1 v2 cuniv = fold 0 cuniv else raise NotConvertible - +let clos_fconv cv_pb env t1 t2 = + let infos = create_clos_infos betaiotazeta env in + ccnv cv_pb infos ELID ELID (inject t1) (inject t2) Constraint.empty let fconv cv_pb env t1 t2 = - if eq_constr t1 t2 then - Constraint.empty - else - let infos = create_clos_infos betaiotazeta env in - ccnv cv_pb infos ELID ELID (inject t1) (inject t2) - Constraint.empty + if eq_constr t1 t2 then Constraint.empty + else clos_fconv cv_pb env t1 t2 +let conv_cmp = fconv let conv = fconv CONV let conv_leq = fconv CUMUL @@ -341,6 +340,32 @@ let conv_leq_vecti env v1 v2 = v1 v2 +(* option for conversion *) +let use_vm = ref true +let vm_fconv = ref (fun _ _ _ _ -> error "VM not installed") +let set_vm_conv_cmp f = vm_fconv := f + +let vm_conv cv_pb env t1 t2 = + if eq_constr t1 t2 then + Constraint.empty + else if !use_vm then + try !vm_fconv cv_pb env t1 t2 + with Not_found | Invalid_argument _ -> + (* If compilation fails, fall-back to closure conversion *) + clos_fconv cv_pb env t1 t2 + else clos_fconv cv_pb env t1 t2 + +let vm_conv_leq_vecti env v1 v2 = + array_fold_left2_i + (fun i c t1 t2 -> + let c' = + try vm_conv CUMUL env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i) in + Constraint.union c c') + Constraint.empty + v1 + v2 + (* let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";; let conv_leq env t1 t2 = diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 4f519fff7..ca4ab8c94 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -29,13 +29,26 @@ exception NotConvertible exception NotConvertibleVect of int type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints +type conv_pb = CONV | CUMUL + +val sort_cmp : + conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints + val conv_sort : sorts conversion_function val conv_sort_leq : sorts conversion_function -val conv : types conversion_function +val conv_cmp : conv_pb -> constr conversion_function + +val conv : constr conversion_function val conv_leq : types conversion_function val conv_leq_vecti : types array conversion_function +(* option for conversion *) +val use_vm : bool ref +val set_vm_conv_cmp : (conv_pb -> types conversion_function) -> unit +val vm_conv : conv_pb -> types conversion_function +val vm_conv_leq_vecti : types array conversion_function + (************************************************************************) (* Builds an application node, reducing beta redexes it may produce. *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 0182b3907..1ca0fec4a 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -132,15 +132,15 @@ let hcons_constant_body cb = let add_constant dir l decl senv = check_label l senv.labset; - let cb = match decl with - ConstantEntry ce -> translate_constant senv.env ce + let kn = make_kn senv.modinfo.modpath dir l in + let cb = + match decl with + | ConstantEntry ce -> translate_constant senv.env kn ce | GlobalRecipe r -> - let cb = translate_recipe senv.env r in - if dir = empty_dirpath then hcons_constant_body cb else cb + let cb = translate_recipe senv.env kn r in + if dir = empty_dirpath then hcons_constant_body cb else cb in -(* let cb = if dir = empty_dirpath then hcons_constant_body cb else cb in*) let env' = Environ.add_constraints cb.const_constraints senv.env in - let kn = make_kn senv.modinfo.modpath dir l in let env'' = Environ.add_constant kn cb env' in kn, { old = senv.old; env = env''; @@ -417,7 +417,6 @@ let check_engagement env c = let set_engagement c senv = {senv with env = Environ.set_engagement c senv.env} - (* Libraries = Compiled modules *) type compiled_library = diff --git a/kernel/sign.ml b/kernel/sign.ml index d448ea310..aebb420f4 100644 --- a/kernel/sign.ml +++ b/kernel/sign.ml @@ -53,13 +53,11 @@ let empty_rel_context = [] let add_rel_decl d ctxt = d::ctxt -let lookup_rel n sign = - let rec lookrec = function - | (1, decl :: _) -> decl - | (n, _ :: sign) -> lookrec (n-1,sign) - | (_, []) -> raise Not_found - in - lookrec (n,sign) +let rec lookup_rel n sign = + match n, sign with + | 1, decl :: _ -> decl + | n, _ :: sign -> lookup_rel (n-1) sign + | _, [] -> raise Not_found let rel_context_length = List.length diff --git a/kernel/term.ml b/kernel/term.ml index 08bcd1ddd..1855858ca 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -1137,6 +1137,7 @@ let nb_prod = let rec eq_constr m n = (m==n) or compare_constr eq_constr m n + let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *) (*******************) @@ -1184,3 +1185,11 @@ let hcons_constr (hkn,hdir,hname,hident,hstr) = (hcci,htcci) let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names()) + + +(*******) +(* Type of abstract machine values *) +type values + + + diff --git a/kernel/term.mli b/kernel/term.mli index 8c72a9ff3..5ef42f96c 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -523,3 +523,7 @@ val hcons_constr: val hcons1_constr : constr -> constr val hcons1_types : types -> types + +(**************************************) + +type values diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index b2ecfa599..291c409e9 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -19,6 +19,8 @@ open Inductive open Environ open Entries open Type_errors +open Cemitcodes +open Cbytegen open Indtypes open Typeops @@ -85,33 +87,38 @@ let infer_declaration env dcl = | DefinitionEntry c -> let (j,cst) = infer env c.const_entry_body in let (typ,cst) = constrain_type env j cst c.const_entry_type in - Some (Declarations.from_val j.uj_val), typ, cst, c.const_entry_opaque + Some (Declarations.from_val j.uj_val), typ, cst, + c.const_entry_opaque, c.const_entry_boxed | ParameterEntry t -> let (j,cst) = infer env t in - None, Typeops.assumption_of_judgment env j, cst, false + None, Typeops.assumption_of_judgment env j, cst, false, false -let build_constant_declaration env (body,typ,cst,op) = - let ids = match body with +let build_constant_declaration env kn (body,typ,cst,op,boxed) = + let ids = + match body with | None -> global_vars_set env typ | Some b -> Idset.union (global_vars_set env (Declarations.force b)) - (global_vars_set env typ) + (global_vars_set env typ) in + let tps = from_val (compile_constant_body env kn body op boxed) in let hyps = keep_hyps env ids in - { const_body = body; + { const_hyps = hyps; + const_body = body; const_type = typ; - const_hyps = hyps; + const_body_code = tps; + (* const_type_code = to_patch env typ;*) const_constraints = cst; const_opaque = op } (*s Global and local constant declaration. *) -let translate_constant env ce = - build_constant_declaration env (infer_declaration env ce) +let translate_constant env kn ce = + build_constant_declaration env kn (infer_declaration env ce) -let translate_recipe env r = - build_constant_declaration env (Cooking.cook_constant env r) +let translate_recipe env kn r = + build_constant_declaration env kn (Cooking.cook_constant env r) (* Insertion of inductive types. *) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 74dc9dc8c..e3105fb90 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -24,11 +24,11 @@ val translate_local_def : env -> constr * types option -> val translate_local_assum : env -> types -> types * Univ.constraints - -val translate_constant : env -> constant_entry -> constant_body + +val translate_constant : env -> constant -> constant_entry -> constant_body val translate_mind : env -> mutual_inductive_entry -> mutual_inductive_body val translate_recipe : - env -> Cooking.recipe -> constant_body + env -> constant -> Cooking.recipe -> constant_body diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 46cf163bf..05b7619e5 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -20,6 +20,9 @@ open Reduction open Inductive open Type_errors +let conv = vm_conv CONV +let conv_leq = vm_conv CUMUL +let conv_leq_vecti = vm_conv_leq_vecti (* This should be a type (a priori without intension to be an assumption) *) let type_judgment env j = diff --git a/kernel/vconv.ml b/kernel/vconv.ml new file mode 100644 index 000000000..41817c3e0 --- /dev/null +++ b/kernel/vconv.ml @@ -0,0 +1,537 @@ +open Names +open Declarations +open Term +open Vm +open Environ +open Conv_oracle +open Reduction +open Closure +open Vm +open Csymtable +open Univ +open Cbytecodes + + +(**** Test la structure des piles ****) + +let compare_zipper z1 z2 = + match z1, z2 with + | Zapp args1, Zapp args2 -> nargs args1 = nargs args2 + | Zfix _, Zfix _ -> true + | Zswitch _, Zswitch _ -> true + | _ , _ -> false + +let rec compare_stack stk1 stk2 = + match stk1, stk2 with + | [], [] -> true + | z1::stk1, z2::stk2 -> + if compare_zipper z1 z2 then compare_stack stk1 stk2 + else false + | _, _ -> false + +(**** Conversion ****) +let conv_vect fconv vect1 vect2 cu = + let n = Array.length vect1 in + if n = Array.length vect2 then + let rcu = ref cu in + for i = 0 to n - 1 do + rcu := fconv vect1.(i) vect2.(i) !rcu + done; + !rcu + else raise NotConvertible + +let rec conv_val infos pb k v1 v2 cu = + if v1 == v2 then cu else conv_whd infos pb k (whd_val v1) (whd_val v2) cu + +and conv_whd infos pb k whd1 whd2 cu = + match whd1, whd2 with + | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu + | Vprod p1, Vprod p2 -> + let cu = conv_val infos CONV k (dom p1) (dom p2) cu in + conv_fun infos pb k (codom p1) (codom p2) cu + | Vfun f1, Vfun f2 -> conv_fun infos CONV k f1 f2 cu + | Vfix f1, Vfix f2 -> conv_fix infos k f1 f2 cu + | Vfix_app fa1, Vfix_app fa2 -> + let f1 = fix fa1 in + let args1 = args_of_fix fa1 in + let f2 = fix fa2 in + let args2 = args_of_fix fa2 in + conv_arguments infos k args1 args2 (conv_fix infos k f1 f2 cu) + | Vcofix cf1, Vcofix cf2 -> + conv_cofix infos k cf1 cf2 cu + | Vcofix_app cfa1, Vcofix_app cfa2 -> + let cf1 = cofix cfa1 in + let args1 = args_of_cofix cfa1 in + let cf2 = cofix cfa2 in + let args2 = args_of_cofix cfa2 in + conv_arguments infos k args1 args2 (conv_cofix infos k cf1 cf2 cu) + | Vconstr_const i1, Vconstr_const i2 -> + if i1 = i2 then cu else raise NotConvertible + | Vconstr_block b1, Vconstr_block b2 -> + let sz = bsize b1 in + if btag b1 = btag b2 && sz = bsize b2 then + let rcu = ref cu in + for i = 0 to sz - 1 do + rcu := conv_val infos CONV k (bfield b1 i) (bfield b2 i) !rcu + done; + !rcu + else raise NotConvertible + | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> + conv_atom infos pb k a1 stk1 a2 stk2 cu + | _, Vatom_stk(Aiddef(_,v),stk) -> + conv_whd infos pb k whd1 (whd_stack v stk) cu + | Vatom_stk(Aiddef(_,v),stk), _ -> + conv_whd infos pb k (whd_stack v stk) whd2 cu + | _, _ -> raise NotConvertible + +and conv_atom infos pb k a1 stk1 a2 stk2 cu = + match a1, a2 with + | Aind (kn1,i1), Aind(kn2,i2) -> + if i1 = i2 && mind_equiv infos kn1 kn2 then + conv_stack infos k stk1 stk2 cu + else raise NotConvertible + | Aid ik1, Aid ik2 -> + if ik1 = ik2 then conv_stack infos k stk1 stk2 cu + else raise NotConvertible + | Aiddef(ik1,v1), Aiddef(ik2,v2) -> + begin + try + if ik1 = ik2 then conv_stack infos k stk1 stk2 cu + else raise NotConvertible + with NotConvertible -> + if oracle_order ik1 ik2 then + conv_whd infos pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu + else conv_whd infos pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu + end + | Aiddef(ik1,v1), _ -> + conv_whd infos pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu + | _, Aiddef(ik2,v2) -> + conv_whd infos pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu + | Afix_app _, _ | _, Afix_app _ | Aswitch _, _ | _, Aswitch _ -> + Util.anomaly "Vconv.conv_atom : Vm.whd_val doesn't work" + | _, _ -> raise NotConvertible + +and conv_stack infos k stk1 stk2 cu = + if compare_stack stk1 stk2 then + let rec conv_rec stk1 stk2 cu = + match stk1, stk2 with + | [], [] -> cu + | Zapp args1 :: stk1, Zapp args2 :: stk2 -> + conv_rec stk1 stk2 (conv_arguments infos k args1 args2 cu) + | Zfix fa1 :: stk1, Zfix fa2 :: stk2 -> + let f1 = fix fa1 in + let args1 = args_of_fix fa1 in + let f2 = fix fa2 in + let args2 = args_of_fix fa2 in + conv_rec stk1 stk2 + (conv_arguments infos k args1 args2 (conv_fix infos k f1 f2 cu)) + | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 -> + if eq_tbl sw1 sw2 then + let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in + let rcu = ref (conv_val infos CONV k vt1 vt2 cu) in + let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in + for i = 0 to Array.length b1 - 1 do + rcu := + conv_val infos CONV (k + fst b1.(i)) + (snd b1.(i)) (snd b2.(i)) !rcu + done; + conv_rec stk1 stk2 !rcu + else raise NotConvertible + | _, _ -> raise NotConvertible + in conv_rec stk1 stk2 cu + else raise NotConvertible + +and conv_fun infos pb k f1 f2 cu = + if f1 == f2 then cu + else + let arity,b1,b2 = decompose_vfun2 k f1 f2 in + conv_val infos pb (k+arity) b1 b2 cu + +and conv_fix infos k f1 f2 cu = + if f1 == f2 then cu + else + if check_fix f1 f2 then + let tf1 = types_of_fix f1 in + let tf2 = types_of_fix f2 in + let cu = conv_vect (conv_val infos CONV k) tf1 tf2 cu in + let bf1 = bodies_of_fix k f1 in + let bf2 = bodies_of_fix k f2 in + conv_vect (conv_fun infos CONV (k + (fix_ndef f1))) bf1 bf2 cu + else raise NotConvertible + +and conv_cofix infos k cf1 cf2 cu = + if cf1 == cf2 then cu + else + if check_cofix cf1 cf2 then + let tcf1 = types_of_cofix cf1 in + let tcf2 = types_of_cofix cf2 in + let cu = conv_vect (conv_val infos CONV k) tcf1 tcf2 cu in + let bcf1 = bodies_of_cofix k cf1 in + let bcf2 = bodies_of_cofix k cf2 in + conv_vect (conv_val infos CONV (k + (cofix_ndef cf1))) bcf1 bcf2 cu + else raise NotConvertible + +and conv_arguments infos k args1 args2 cu = + if args1 == args2 then cu + else + let n = nargs args1 in + if n = nargs args2 then + let rcu = ref cu in + for i = 0 to n - 1 do + rcu := conv_val infos CONV k (arg args1 i) (arg args2 i) !rcu + done; + !rcu + else raise NotConvertible + +let rec conv_eq pb t1 t2 cu = + if t1 == t2 then cu + else + match kind_of_term t1, kind_of_term t2 with + | Rel n1, Rel n2 -> + if n1 = n2 then cu else raise NotConvertible + | Meta m1, Meta m2 -> + if m1 = m2 then cu else raise NotConvertible + | Var id1, Var id2 -> + if id1 = id2 then cu else raise NotConvertible + | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu + | Cast (c1,_), _ -> conv_eq pb c1 t2 cu + | _, Cast (c2,_) -> conv_eq pb t1 c2 cu + | Prod (_,t1,c1), Prod (_,t2,c2) -> + conv_eq pb c1 c2 (conv_eq CONV t1 t2 cu) + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq CONV c1 c2 cu + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> + conv_eq pb c1 c2 (conv_eq CONV b1 b2 cu) + | App (c1,l1), App (c2,l2) -> + conv_eq_vect l1 l2 (conv_eq CONV c1 c2 cu) + | Evar (e1,l1), Evar (e2,l2) -> + if e1 = e2 then conv_eq_vect l1 l2 cu + else raise NotConvertible + | Const c1, Const c2 -> + if c1 = c2 then cu else raise NotConvertible + | Ind c1, Ind c2 -> + if c1 = c2 then cu else raise NotConvertible + | Construct c1, Construct c2 -> + if c1 = c2 then cu else raise NotConvertible + | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> + let pcu = conv_eq CONV p1 p2 cu in + let ccu = conv_eq CONV c1 c2 pcu in + conv_eq_vect bl1 bl2 ccu + | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> + if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu) + else raise NotConvertible + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> + if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu) + else raise NotConvertible + | _ -> raise NotConvertible + +and conv_eq_vect vt1 vt2 cu = + let len = Array.length vt1 in + if len = Array.length vt2 then + let rcu = ref cu in + for i = 0 to len-1 do + rcu := conv_eq CONV vt1.(i) vt2.(i) !rcu + done; !rcu + else raise NotConvertible + +let vconv pb env t1 t2 = + let cu = + try conv_eq pb t1 t2 Constraint.empty + with NotConvertible -> + let infos = create_clos_infos betaiotazeta env in + let v1 = val_of_constr env t1 in + let v2 = val_of_constr env t2 in + let cu = conv_val infos pb (nb_rel env) v1 v2 Constraint.empty in + cu + in cu + +let _ = Reduction.set_vm_conv_cmp vconv + +(*******************************************) +(**** Calcul de la forme normal d'un terme *) +(*******************************************) + +let crazy_type = mkSet + +let decompose_prod env t = + let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in + if name = Anonymous then (Name (id_of_string "x"),dom,codom) + else res + +exception Find_at of int + +(* rend le numero du constructeur correspondant au tag [tag], + [cst] = true si c'est un constructeur constant *) + +let invert_tag cst tag reloc_tbl = + try + for j = 0 to Array.length reloc_tbl - 1 do + let tagj,arity = reloc_tbl.(j) in + if tag = tagj && (cst && arity = 0 || not(cst || arity = 0)) then + raise (Find_at j) + else () + done;raise Not_found + with Find_at j -> (j+1) + (*** Argggg, ces constructeurs de ... qui commencent a 1*) + +(* Build the substitution that replaces Rels by the appropriate + inductives *) +let ind_subst mind mib = + let ntypes = mib.mind_ntypes in + let make_Ik k = mkInd (mind,ntypes-k-1) in + Util.list_tabulate make_Ik ntypes + +(* Instantiate inductives and parameters in constructor type + in normal form *) +let constructor_instantiate mind mib params ctyp = + let si = ind_subst mind mib in + let ctyp1 = substl si ctyp in + let nparams = Array.length params in + if nparams = 0 then ctyp1 + else + let _,ctyp2 = decompose_prod_n nparams ctyp1 in + let sp = Array.to_list params in substl sp ctyp2 + +let destApplication t = + try destApplication t + with _ -> t,[||] + +let construct_of_constr_const env tag typ = + let cind,params = destApplication (whd_betadeltaiota env typ) in + let ind = destInd cind in + let (_,mip) = Inductive.lookup_mind_specif env ind in + let rtbl = mip.mind_reloc_tbl in + let i = invert_tag true tag rtbl in + mkApp(mkConstruct(ind,i), params) + +let find_rectype typ = + let cind,args = destApplication typ in + let ind = destInd cind in + ind, args + +let construct_of_constr_block env tag typ = + let (mind,_ as ind),allargs = find_rectype (whd_betadeltaiota env typ) in + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let nparams = mip.mind_nparams in + let rtbl = mip.mind_reloc_tbl in + let i = invert_tag false tag rtbl in + let params = Array.sub allargs 0 nparams in + let specif = mip.mind_nf_lc in + let ctyp = constructor_instantiate mind mib params specif.(i-1) in + (mkApp(mkConstruct(ind,i), params), ctyp) + +let constr_type_of_idkey env idkey = + match idkey with + | ConstKey cst -> + let ty = (lookup_constant cst env).const_type in + mkConst cst, ty + | VarKey id -> + let (_,_,ty) = lookup_named id env in + mkVar id, ty + | RelKey i -> + let n = (nb_rel env - i) in + let (_,_,ty) = lookup_rel n env in + mkRel n, lift n ty + +let type_of_ind env ind = + let (_,mip) = Inductive.lookup_mind_specif env ind in + mip.mind_nf_arity + +let build_branches_type (mind,_ as ind) mib mip params dep p rtbl = + (* [build_one_branch i cty] construit le type de la ieme branche (commence + a 0) et les lambda correspondant aux realargs *) + let build_one_branch i cty = + let typi = constructor_instantiate mind mib params cty in + let decl,indapp = Term.decompose_prod typi in + let ind,cargs = find_rectype indapp in + let nparams = Array.length params in + let carity = snd (rtbl.(i)) in + let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in + let codom = + let papp = mkApp(p,crealargs) in + if dep then + let cstr = ith_constructor_of_inductive ind (i+1) in + let relargs = Array.init carity (fun i -> mkRel (carity-i)) in + let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in + mkApp(papp,[|dep_cstr|]) + else papp + in + decl, codom + in Array.mapi build_one_branch mip.mind_nf_lc + +(** La fonction de normalisation *) + +let rec nf_val env v t = nf_whd env (whd_val v) t + +and nf_whd env whd typ = + match whd with + | Vsort s -> mkSort s + | Vprod p -> + let dom = nf_val env (dom p) crazy_type in + let name = Name (id_of_string "x") in + let vc = body_of_vfun (nb_rel env) (codom p) in + let codom = nf_val (push_rel (name,None,dom) env) vc crazy_type in + mkProd(name,dom,codom) + | Vfun f -> nf_fun env f typ + | Vfix f -> nf_fix env f + | Vfix_app fa -> + let f = fix fa in + let vargs = args_of_fix fa in + let fd = nf_fix env f in + let (_,i),(_,ta,_) = destFix fd in + let t = ta.(i) in + let _, args = nf_args env vargs t in + mkApp(fd,args) + | Vcofix cf -> nf_cofix env cf + | Vcofix_app cfa -> + let cf = cofix cfa in + let vargs = args_of_cofix cfa in + let cfd = nf_cofix env cf in + let i,(_,ta,_) = destCoFix cfd in + let t = ta.(i) in + let _, args = nf_args env vargs t in + mkApp(cfd,args) + | Vconstr_const n -> construct_of_constr_const env n typ + | Vconstr_block b -> + let capp,ctyp = construct_of_constr_block env (btag b) typ in + let args = nf_bargs env b ctyp in + mkApp(capp,args) + | Vatom_stk(Aid idkey, stk) -> + let c,typ = constr_type_of_idkey env idkey in + nf_stk env c typ stk + | Vatom_stk(Aiddef(idkey,_), stk) -> + let c,typ = constr_type_of_idkey env idkey in + nf_stk env c typ stk + | Vatom_stk(Aind ind, stk) -> + nf_stk env (mkInd ind) (type_of_ind env ind) stk + | Vatom_stk(_,stk) -> assert false + +and nf_stk env c t stk = + match stk with + | [] -> c + | Zapp vargs :: stk -> + let t, args = nf_args env vargs t in + nf_stk env (mkApp(c,args)) t stk + | Zfix fa :: stk -> + let f = fix fa in + let vargs = args_of_fix fa in + let fd = nf_fix env f in + let (_,i),(_,ta,_) = destFix fd in + let tf = ta.(i) in + let typ, args = nf_args env vargs tf in + let _,_,codom = decompose_prod env typ in + nf_stk env (mkApp(mkApp(fd,args),[|c|])) (subst1 c codom) stk + | Zswitch sw :: stk -> + + let (mind,_ as ind),allargs = find_rectype (whd_betadeltaiota env t) in + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let nparams = mip.mind_nparams in + let params,realargs = Util.array_chop nparams allargs in + (* calcul du predicat du case, + [dep] indique si c'est un case dependant *) + let dep,p = + let dep = ref false in + let rec nf_predicate env v pT = + match whd_val v, kind_of_term pT with + | Vfun f, Prod _ -> + let k = nb_rel env in + let vb = body_of_vfun k f in + let name,dom,codom = decompose_prod env pT in + let body = + nf_predicate (push_rel (name,None,dom) env) vb codom in + mkLambda(name,dom,body) + | Vfun f, _ -> + dep := true; + let k = nb_rel env in + let vb = body_of_vfun k f in + let name = Name (id_of_string "c") in + let n = mip.mind_nrealargs in + let rargs = Array.init n (fun i -> mkRel (n-i)) in + let dom = mkApp(mkApp(mkInd ind,params),rargs) in + let body = + nf_val (push_rel (name,None,dom) env) vb crazy_type in + mkLambda(name,dom,body) + | _, _ -> nf_val env v crazy_type + in + let aux = nf_predicate env (type_of_switch sw) mip.mind_nf_arity in + !dep,aux in + (* Calcul du type des branches *) + let btypes = + build_branches_type ind mib mip params dep p mip.mind_reloc_tbl in + (* calcul des branches *) + let bsw = branch_of_switch (nb_rel env) sw in + let mkbranch i (n,v) = + let decl,codom = btypes.(i) in + let env = + List.fold_right + (fun (name,t) env -> push_rel (name,None,t) env) decl env in + let b = nf_val env v codom in + compose_lam decl b + in + let branchs = Array.mapi mkbranch bsw in + let tcase = + if dep then mkApp(mkApp(p, params), [|c|]) + else mkApp(p, params) + in + let ci = case_info sw in + nf_stk env (mkCase(ci, p, c, branchs)) tcase stk + +and nf_args env vargs t = + let t = ref t in + let len = nargs vargs in + let targs = + Array.init len + (fun i -> + let _,dom,codom = decompose_prod env !t in + let c = nf_val env (arg vargs i) dom in + t := subst1 c codom; c) in + !t,targs + +and nf_bargs env b t = + let t = ref t in + let len = bsize b in + Array.init len + (fun i -> + let _,dom,codom = decompose_prod env !t in + let c = nf_val env (bfield b i) dom in + t := subst1 c codom; c) + +and nf_fun env f typ = + let k = nb_rel env in + let vb = body_of_vfun k f in + let name,dom,codom = decompose_prod env typ in + let body = nf_val (push_rel (name,None,dom) env) vb codom in + mkLambda(name,dom,body) + +and nf_fix env f = + let init = fix_init f in + let rec_args = rec_args f in + let ndef = fix_ndef f in + let vt = types_of_fix f in + let ft = Array.map (fun v -> nf_val env v crazy_type) vt in + let name = Array.init ndef (fun _ -> (Name (id_of_string "Ffix"))) in + let k = nb_rel env in + let vb = bodies_of_fix k f in + let env = push_rec_types (name,ft,ft) env in + let fb = Util.array_map2 (fun v t -> nf_fun env v t) vb ft in + mkFix ((rec_args,init),(name,ft,fb)) + +and nf_cofix env cf = + let init = cofix_init cf in + let ndef = cofix_ndef cf in + let vt = types_of_cofix cf in + let cft = Array.map (fun v -> nf_val env v crazy_type) vt in + let name = Array.init ndef (fun _ -> (Name (id_of_string "Fcofix"))) in + let k = nb_rel env in + let vb = bodies_of_cofix k cf in + let env = push_rec_types (name,cft,cft) env in + let cfb = Util.array_map2 (fun v t -> nf_val env v t) vb cft in + mkCoFix (init,(name,cft,cfb)) + +let cbv_vm env c t = + if not (transp_values ()) then swap_global_transp (); + let v = val_of_constr env c in + let c = nf_val env v t in + if not (transp_values ()) then swap_global_transp (); + c + + diff --git a/kernel/vconv.mli b/kernel/vconv.mli new file mode 100644 index 000000000..21fd4601b --- /dev/null +++ b/kernel/vconv.mli @@ -0,0 +1,14 @@ +(*i*) +open Names +open Term +open Environ +open Reduction +(*i*) + +(***********************************************************************) +(*s conversion functions *) +val vconv : conv_pb -> types conversion_function + +(***********************************************************************) +(*s Reduction functions *) +val cbv_vm : env -> constr -> types -> constr diff --git a/kernel/vm.ml b/kernel/vm.ml new file mode 100644 index 000000000..80ecdf369 --- /dev/null +++ b/kernel/vm.ml @@ -0,0 +1,593 @@ +open Obj +open Names +open Term +open Conv_oracle +open Cbytecodes + +(* use transparant constant or not *) + +external swap_global_transp : unit -> unit = "swap_coq_global_transp" + +let transp_values = ref false + +let set_transp_values b = + if b = !transp_values then () + else ( + transp_values := not !(transp_values); + swap_global_transp ()) + +let transp_values _ = !transp_values + + + +(******************************************) +(* Fonctions en plus du module Obj ********) +(******************************************) + + + +external offset_closure : t -> int -> t = "coq_offset_closure" +external offset : t -> int = "coq_offset" +let first o = (offset_closure o (offset o)) +let last o = (field o (size o - 1)) + +let accu_tag = 0 + +(*******************************************) +(* Initalisation de la machine abstraite ***) +(*******************************************) + +external init_vm : unit -> unit = "init_coq_vm" + +let _ = init_vm () + +(*******************************************) +(* Le code machine ************************) +(*******************************************) + +type tcode +let tcode_of_obj v = ((obj v):tcode) +let fun_code v = tcode_of_obj (field (repr v) 0) + +external mkAccuCode : int -> tcode = "coq_makeaccu" +external mkPopStopCode : int -> tcode = "coq_pushpop" + +external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode" +external int_tcode : tcode -> int -> int = "coq_int_tcode" + +external accumulate : unit -> tcode = "accumulate_code" +let accumulate = accumulate () + +let popstop_tbl = ref (Array.init 30 mkPopStopCode) + +let popstop_code i = + let len = Array.length !popstop_tbl in + if i < len then !popstop_tbl.(i) + else + begin + popstop_tbl := + Array.init (i+10) + (fun j -> if j < len then !popstop_tbl.(j) else mkPopStopCode j); + !popstop_tbl.(i) + end + +let stop = popstop_code 0 + +(******************************************************) +(* Types de donnees abstraites et fonctions associees *) +(******************************************************) + +(* Values of the abstract machine *) +let val_of_obj v = ((obj v):values) +let crasy_val = (val_of_obj (repr 0)) + + +(* Functions *) +type vfun +(* v = [Tc | c | fv1 | ... | fvn ] *) +(* ^ *) +(* [Tc | (Restart : c) | v | a1 | ... an] *) +(* ^ *) + +(* Products *) +type vprod +(* [0 | dom : codom] *) +(* ^ *) +let dom : vprod -> values = fun p -> val_of_obj (field (repr p) 0) +let codom : vprod -> vfun = fun p -> (obj (field (repr p) 1)) + +(* Arguments *) +type arguments +(* arguments = [_ | _ | _ | a1 | ... | an] *) +(* ^ *) +let nargs : arguments -> int = fun args -> (size (repr args)) - 2 + +let unsafe_arg : arguments -> int -> values = + fun args i -> val_of_obj (field (repr args) (i+2)) + +let arg args i = + if 0 <= i && i < (nargs args) then unsafe_arg args i + else raise (Invalid_argument + ("Vm.arg size = "^(string_of_int (nargs args))^ + " acces "^(string_of_int i))) + +(* Fixpoints *) +type vfix + +(* [Tc|c0|Ti|c1|...|Ti|cn|fv1|...|fvn| [ct0|...|ctn]] *) +(* ^ *) +type vfix_block + +let fix_init : vfix -> int = fun vf -> (offset (repr vf)/2) + +let block_of_fix : vfix -> vfix_block = fun vf -> obj (first (repr vf)) + +let fix_block_type : vfix_block -> tcode array = + fun fb -> (obj (last (repr fb))) + +let fix_block_ndef : vfix_block -> int = + fun fb -> size (last (repr fb)) + +let fix_ndef vf = fix_block_ndef (block_of_fix vf) + +let unsafe_fb_code : vfix_block -> int -> tcode = + fun fb i -> tcode_of_obj (field (repr fb) (2 * i)) + +let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 + +let rec_args vf = + let fb = block_of_fix vf in + let size = fix_block_ndef fb in + Array.init size (unsafe_rec_arg fb) + +exception FALSE + +let check_fix f1 f2 = + let i1, i2 = fix_init f1, fix_init f2 in + (* Verification du point de depart *) + if i1 = i2 then + let fb1,fb2 = block_of_fix f1, block_of_fix f2 in + let n = fix_block_ndef fb1 in + (* Verification du nombre de definition *) + if n = fix_block_ndef fb2 then + (* Verification des arguments recursifs *) + try + for i = 0 to n - 1 do + if not (unsafe_rec_arg fb1 i = unsafe_rec_arg fb2 i) then + raise FALSE + done; + true + with FALSE -> false + else false + else false + +(* Partials applications of Fixpoints *) +type vfix_app +let fix : vfix_app -> vfix = + fun vfa -> ((obj (field (repr vfa) 1)):vfix) +let args_of_fix : vfix_app -> arguments = + fun vfa -> ((magic vfa) : arguments) + +(* CoFixpoints *) +type vcofix +type vcofix_block +let cofix_init : vcofix -> int = fun vcf -> (offset (repr vcf)/2) + +let block_of_cofix : vcofix -> vcofix_block = fun vcf -> obj (first (repr vcf)) + +let cofix_block_ndef : vcofix_block -> int = + fun fb -> size (last (repr fb)) + +let cofix_ndef vcf= cofix_block_ndef (block_of_cofix vcf) + +let cofix_block_type : vcofix_block -> tcode array = + fun cfb -> (obj (last (repr cfb))) + +let check_cofix cf1 cf2 = + cofix_init cf1 = cofix_init cf2 && + cofix_ndef cf1 = cofix_ndef cf2 + +let cofix_arity c = int_tcode c 1 + +let unsafe_cfb_code : vcofix_block -> int -> tcode = + fun cfb i -> tcode_of_obj (field (repr cfb) (2 * i)) + +(* Partials applications of CoFixpoints *) +type vcofix_app +let cofix : vcofix_app -> vcofix = + fun vcfa -> ((obj (field (repr vcfa) 1)):vcofix) +let args_of_cofix : vcofix_app -> arguments = + fun vcfa -> ((magic vcfa) : arguments) + +(* Blocks *) +type vblock (* la representation Ocaml *) +let btag : vblock -> int = fun b -> tag (repr b) +let bsize : vblock -> int = fun b -> size (repr b) +let bfield b i = + if 0 <= i && i < (bsize b) then + val_of_obj (field (repr b) i) + else raise (Invalid_argument "Vm.bfield") + +(* Accumulators and atoms *) + +type accumulator +(* [Ta | accumulate | at | a1 | ... | an ] *) + +type inv_rel_key = int + +type id_key = inv_rel_key tableKey + +type vstack = values array + +type vm_env + +type vswitch = { + sw_type_code : tcode; + sw_code : tcode; + sw_annot : annot_switch; + sw_stk : vstack; + sw_env : vm_env + } + +type atom = + | Aid of id_key + | Aiddef of id_key * values + | Aind of inductive + | Afix_app of accumulator * vfix_app + | Aswitch of accumulator * vswitch + +let atom_of_accu : accumulator -> atom = + fun a -> ((obj (field (repr a) 1)) : atom) + +let args_of_accu : accumulator -> arguments = + fun a -> ((magic a) : arguments) + +let nargs_of_accu a = nargs (args_of_accu a) + +(* Les zippers *) + +type zipper = + | Zapp of arguments + | Zfix of vfix_app + | Zswitch of vswitch + +type stack = zipper list + +type whd = + | Vsort of sorts + | Vprod of vprod + | Vfun of vfun + | Vfix of vfix + | Vfix_app of vfix_app + | Vcofix of vcofix + | Vcofix_app of vcofix_app + | Vconstr_const of int + | Vconstr_block of vblock + | Vatom_stk of atom * stack +(* Les atomes sont forcement Aid Aiddef Aind *) + +(**********************************************) +(* Constructeurs ******************************) +(**********************************************) +(* obj_of_atom : atom -> t *) +let obj_of_atom : atom -> t = + fun a -> + let res = Obj.new_block accu_tag 2 in + set_field res 0 (repr accumulate); + set_field res 1 (repr a); + res + +(* obj_of_str_const : structured_constant -> t *) +let rec obj_of_str_const str = + match str with + | Const_sorts s -> repr (Vsort s) + | Const_ind ind -> obj_of_atom (Aind ind) + | Const_b0 tag -> repr tag + | Const_bn(tag, args) -> + let len = Array.length args in + let res = new_block tag len in + for i = 0 to len - 1 do + set_field res i (obj_of_str_const args.(i)) + done; + res + +let val_of_obj o = ((obj o) : values) + +let val_of_str_const str = val_of_obj (obj_of_str_const str) + +let val_of_atom a = val_of_obj (obj_of_atom a) + +let idkey_tbl = Hashtbl.create 31 + +let val_of_idkey key = + try Hashtbl.find idkey_tbl key + with Not_found -> + let v = val_of_atom (Aid key) in + Hashtbl.add idkey_tbl key v; + v + +let val_of_rel k = val_of_idkey (RelKey k) +let val_of_rel_def k v = val_of_atom(Aiddef(RelKey k, v)) + +let val_of_named id = val_of_idkey (VarKey id) +let val_of_named_def id v = val_of_atom(Aiddef(VarKey id, v)) + +let val_of_constant c = val_of_idkey (ConstKey c) +let val_of_constant_def c v = val_of_atom(Aiddef(ConstKey c, v)) + + +(*************************************************) +(* Destructors ***********************************) +(*************************************************) + + +let rec whd_accu a stk = + let n = nargs_of_accu a in + let stk = + if nargs_of_accu a = 0 then stk + else Zapp (args_of_accu a) :: stk in + + let at = atom_of_accu a in + match at with + | Aid _ | Aiddef _ | Aind _ -> Vatom_stk(at, stk) + | Afix_app(a,fa) -> whd_accu a (Zfix fa :: stk) + | Aswitch(a,sw) -> whd_accu a (Zswitch sw :: stk) + +external kind_of_closure : t -> int = "coq_kind_of_closure" + + +let whd_val : values -> whd = + fun v -> + let o = repr v in + if is_int o then Vconstr_const (obj o) + else + let tag = tag o in + if tag = accu_tag then + if fun_code o == accumulate then whd_accu (obj o) [] + else + if size o = 1 then Vsort(obj (field o 0)) + else Vprod(obj o) + else + if tag = closure_tag || tag = infix_tag then + match kind_of_closure o with + | 0 -> Vfun(obj o) + | 1 -> Vfix(obj o) + | 2 -> Vfix_app(obj o) + | 3 -> Vcofix(obj o) + | 4 -> Vcofix_app(obj o) + | 5 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) + | _ -> Util.anomaly "Vm.whd : kind_of_closure does not work" + else Vconstr_block(obj o) + + + +(************************************************) +(* La machine abstraite *************************) +(************************************************) + + +(* gestion de la pile *) +external push_ra : tcode -> unit = "coq_push_ra" +external push_val : values -> unit = "coq_push_val" +external push_arguments : arguments -> unit = "coq_push_arguments" +external push_vstack : vstack -> unit = "coq_push_vstack" + + +(* interpreteur *) +external interprete : tcode -> values -> vm_env -> int -> values = + "coq_interprete_ml" + +let apply_arguments vf vargs = + let n = nargs vargs in + if n = 0 then vf + else + begin + push_ra stop; + push_arguments vargs; + interprete (fun_code vf) vf (magic vf) (n - 1) + end + +let apply_vstack vf vstk = + let n = Array.length vstk in + if n = 0 then vf + else + begin + push_ra stop; + push_vstack vstk; + interprete (fun_code vf) vf (magic vf) (n - 1) + end + +let apply_fix_app vfa arg = + let vf = fix vfa in + let vargs = args_of_fix vfa in + push_ra stop; + push_val arg; + push_arguments vargs; + interprete (fun_code vf) (magic vf) (magic vf) (nargs vargs) + +let apply_switch sw arg = + + let tc = sw.sw_annot.tailcall in + if tc then + (push_ra stop;push_vstack sw.sw_stk) + else + (push_vstack sw.sw_stk; push_ra (popstop_code (Array.length sw.sw_stk))); + interprete sw.sw_code arg sw.sw_env 0 + +let is_accu v = + is_block (repr v) && tag (repr v) = accu_tag && + fun_code v == accumulate + +let rec whd_stack v stk = + match stk with + | [] -> whd_val v + | Zapp a :: stkt -> whd_stack (apply_arguments v a) stkt + | Zfix fa :: stkt -> + if is_accu v then whd_accu (magic v) stk + else whd_stack (apply_fix_app fa v) stkt + | Zswitch sw :: stkt -> + if is_accu v then whd_accu (magic v) stk + else whd_stack (apply_switch sw v) stkt + + + +(* Function *) +external closure_arity : vfun -> int = "coq_closure_arity" + +(* [apply_rel v k arity] applique la valeurs [v] aux arguments + [k],[k+1], ... , [k+arity-1] *) +let mkrel_vstack k arity = + let max = k + arity - 1 in + Array.init arity (fun i -> val_of_rel (max - i)) + +let body_of_vfun k vf = + let vargs = mkrel_vstack k 1 in + apply_vstack (magic vf) vargs + +let decompose_vfun2 k vf1 vf2 = + let arity = min (closure_arity vf1) (closure_arity vf2) in + assert (0 <= arity && arity < Sys.max_array_length); + let vargs = mkrel_vstack k arity in + let v1 = apply_vstack (magic vf1) vargs in + let v2 = apply_vstack (magic vf2) vargs in + arity, v1, v2 + + +(* Fix *) +external atom_rel : unit -> atom array = "get_coq_atom_tbl" +external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl" + +let relaccu_tbl = + let atom_rel = atom_rel() in + let len = Array.length atom_rel in + for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done; + ref (Array.init len mkAccuCode) + +let relaccu_code i = + let len = Array.length !relaccu_tbl in + if i < len then !relaccu_tbl.(i) + else + begin + realloc_atom_rel i; + let atom_rel = atom_rel () in + let nl = Array.length atom_rel in + for j = len to nl - 1 do atom_rel.(j) <- Aid(RelKey j) done; + relaccu_tbl := + Array.init nl + (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j); + !relaccu_tbl.(i) + end + +let jump_grabrec c = offset_tcode c 2 +let jump_grabrecrestart c = offset_tcode c 3 + +let bodies_of_fix k vf = + let fb = block_of_fix vf in + let ndef = fix_block_ndef fb in + (* Construction de l' environnement des corps des points fixes *) + let e = dup (repr fb) in + for i = 0 to ndef - 1 do + set_field e (2 * i) (repr (relaccu_code (k + i))) + done; + let fix_body i = + let c = jump_grabrec (unsafe_fb_code fb i) in + let res = Obj.new_block closure_tag 2 in + set_field res 0 (repr c); + set_field res 1 (offset_closure e (2*i)); + ((obj res) : vfun) + in Array.init ndef fix_body + +let types_of_fix vf = + let fb = block_of_fix vf in + let type_code = fix_block_type fb in + let type_val c = interprete c crasy_val (magic fb) 0 in + Array.map type_val type_code + + +(* CoFix *) +let jump_cograb c = offset_tcode c 2 +let jump_cograbrestart c = offset_tcode c 3 + +let bodies_of_cofix k vcf = + let cfb = block_of_cofix vcf in + let ndef = cofix_block_ndef cfb in + (* Construction de l' environnement des corps des cofix *) + let e = dup (repr cfb) in + for i = 0 to ndef - 1 do + set_field e (2 * i) (repr (relaccu_code (k + i))) + done; + let cofix_body i = + let c = unsafe_cfb_code cfb i in + let arity = int_tcode c 1 in + if arity = 0 then + begin + push_ra stop; + interprete (jump_cograbrestart c) crasy_val + (obj (offset_closure e (2*i))) 0 + end + else + let res = Obj.new_block closure_tag 2 in + set_field res 0 (repr (jump_cograb c)); + set_field res 1 (offset_closure e (2*i)); + ((obj res) : values) + in Array.init ndef cofix_body + +let types_of_cofix vcf = + let cfb = block_of_cofix vcf in + let type_code = cofix_block_type cfb in + let type_val c = interprete c crasy_val (magic cfb) 0 in + Array.map type_val type_code + +(* Switch *) + +let eq_tbl sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl + +let case_info sw = sw.sw_annot.ci + +let type_of_switch sw = + push_vstack sw.sw_stk; + interprete sw.sw_type_code crasy_val sw.sw_env 0 + +let branch_arg k (tag,arity) = + if arity = 0 then ((magic tag):values) + else + let b = new_block tag arity in + for i = 0 to arity - 1 do + set_field b i (repr (val_of_rel (k+i))) + done; + val_of_obj b + + +let branch_of_switch k sw = + let eval_branch (_,arity as ta) = + let arg = branch_arg k ta in + let v = apply_switch sw arg in + (arity, v) + in + Array.map eval_branch sw.sw_annot.rtbl + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/kernel/vm.mli b/kernel/vm.mli new file mode 100644 index 000000000..d6e7f6eee --- /dev/null +++ b/kernel/vm.mli @@ -0,0 +1,108 @@ +open Names +open Term +open Cbytecodes +open Cemitcodes + +(* option for virtual machine *) +val transp_values : unit -> bool +val set_transp_values : bool -> unit +val swap_global_transp : unit -> unit +(* le code machine *) +type tcode + +(* Les valeurs ***********) + +type accumulator +type vprod +type vfun +type vfix +type vfix_app +type vcofix +type vcofix_app +type vblock +type vswitch +type arguments + +type zipper = + | Zapp of arguments + | Zfix of vfix_app + | Zswitch of vswitch + +type stack = zipper list + + +type atom = + | Aid of id_key + | Aiddef of id_key * values + | Aind of inductive + | Afix_app of accumulator * vfix_app + | Aswitch of accumulator * vswitch + +type whd = + | Vsort of sorts + | Vprod of vprod + | Vfun of vfun + | Vfix of vfix + | Vfix_app of vfix_app + | Vcofix of vcofix + | Vcofix_app of vcofix_app + | Vconstr_const of int + | Vconstr_block of vblock + | Vatom_stk of atom * stack + +(* Constructors *) +val val_of_str_const : structured_constant -> values + +val val_of_rel : int -> values +val val_of_rel_def : int -> values -> values + +val val_of_named : identifier -> values +val val_of_named_def : identifier -> values -> values + +val val_of_constant : constant -> values +val val_of_constant_def : constant -> values -> values + +(* Destructors *) +val whd_val : values -> whd + +(* Product *) +val dom : vprod -> values +val codom : vprod -> vfun +(* Function *) +val body_of_vfun : int -> vfun -> values +val decompose_vfun2 : int -> vfun -> vfun -> int * values * values +(* Fix *) +val fix : vfix_app -> vfix +val args_of_fix : vfix_app -> arguments +val fix_init : vfix -> int +val fix_ndef : vfix -> int +val rec_args : vfix -> int array +val check_fix : vfix -> vfix -> bool +val bodies_of_fix : int -> vfix -> vfun array +val types_of_fix : vfix -> values array +(* CoFix *) +val cofix : vcofix_app -> vcofix +val args_of_cofix : vcofix_app -> arguments +val cofix_init : vcofix -> int +val cofix_ndef : vcofix -> int +val check_cofix : vcofix -> vcofix -> bool +val bodies_of_cofix : int -> vcofix -> values array +val types_of_cofix : vcofix -> values array +(* Block *) +val btag : vblock -> int +val bsize : vblock -> int +val bfield : vblock -> int -> values +(* Switch *) +val eq_tbl : vswitch -> vswitch -> bool +val case_info : vswitch -> case_info +val type_of_switch : vswitch -> values +val branch_of_switch : int -> vswitch -> (int * values) array +(* Arguments *) +val nargs : arguments -> int +val arg : arguments -> int -> values + +(* Evaluation *) +val whd_stack : values -> stack -> whd + + + diff --git a/lib/options.ml b/lib/options.ml index 3459279bb..2e8c53517 100644 --- a/lib/options.ml +++ b/lib/options.ml @@ -107,3 +107,4 @@ let dump_it () = end let _ = at_exit dump_it + diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml index 66b1bb072..597431840 100644 --- a/library/decl_kinds.ml +++ b/library/decl_kinds.ml @@ -23,7 +23,7 @@ type theorem_kind = | Remark type definition_object_kind = - | Definition + | Definition of bool | Coercion | SubClass | CanonicalStructure diff --git a/library/declare.ml b/library/declare.ml index 93a90380c..ea986e3fb 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -184,7 +184,8 @@ let hcons_constant_declaration = function DefinitionEntry { const_entry_body = hcons1_constr ce.const_entry_body; const_entry_type = option_app hcons1_constr ce.const_entry_type; - const_entry_opaque = ce.const_entry_opaque } + const_entry_opaque = ce.const_entry_opaque; + const_entry_boxed = ce.const_entry_boxed } | cd -> cd let declare_constant_common id discharged_hyps (cd,kind) = diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 7c4fa0d5b..5ba7d591e 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -165,6 +165,7 @@ GEXTEND Gram | IDENT "Cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) | IDENT "Lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) | IDENT "Compute" -> Cbv (make_red_flag [FBeta;FIota;FDeltaBut [];FZeta]) + | IDENT "Vm_compute" -> CbvVm | IDENT "Unfold"; ul = LIST1 unfold_occ -> Unfold ul | IDENT "Fold"; cl = LIST1 constr -> Fold cl | IDENT "Pattern"; pl = LIST1 pattern_occ -> Pattern pl ] ] @@ -180,6 +181,7 @@ GEXTEND Gram | IDENT "Unfold"; ul = LIST1 unfold_occ -> Unfold ul | IDENT "Fold"; cl = LIST1 constr -> Fold cl | IDENT "Pattern"; pl = LIST1 pattern_occ -> Pattern pl + | IDENT "Vm_compute" -> CbvVm | s = IDENT; c = constr -> ExtraRedExpr (s,c) ] ] ; hypident: @@ -250,7 +252,8 @@ GEXTEND Gram | IDENT "Assumption" -> TacAssumption | IDENT "Exact"; c = constr -> TacExact c - + | IDENT "Exact_no_check"; c = constr -> TacExactNoCheck c + | IDENT "Apply"; cl = constr_with_bindings -> TacApply cl | IDENT "Elim"; cl = constr_with_bindings; el = OPT eliminator -> TacElim (cl,el) diff --git a/parsing/g_tacticnew.ml4 b/parsing/g_tacticnew.ml4 index 4a6263139..8930c8dca 100644 --- a/parsing/g_tacticnew.ml4 +++ b/parsing/g_tacticnew.ml4 @@ -197,6 +197,7 @@ GEXTEND Gram | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) | IDENT "compute" -> compute + | IDENT "vm_compute" -> CbvVm | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul | IDENT "fold"; cl = LIST1 constr -> Fold cl | IDENT "pattern"; pl = LIST1 pattern_occ SEP","-> Pattern pl ] ] @@ -209,6 +210,7 @@ GEXTEND Gram | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s) | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s) | IDENT "compute" -> compute + | IDENT "vm_compute" -> CbvVm | IDENT "unfold"; ul = LIST1 unfold_occ -> Unfold ul | IDENT "fold"; cl = LIST1 constr -> Fold cl | IDENT "pattern"; pl = LIST1 pattern_occ -> Pattern pl @@ -278,6 +280,7 @@ GEXTEND Gram | IDENT "assumption" -> TacAssumption | IDENT "exact"; c = constr -> TacExact c + | IDENT "exact_no_check"; c = constr -> TacExactNoCheck c | IDENT "apply"; cl = constr_with_bindings -> TacApply cl | IDENT "elim"; cl = constr_with_bindings; el = OPT eliminator -> diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index fbfd35863..43e6b81cc 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -109,8 +109,10 @@ GEXTEND Gram | IDENT "Remark" -> Remark ] ] ; def_token: - [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition) - | IDENT "Local" -> (fun _ _ -> ()), (Local, Definition) + [ [ IDENT "Boxed";"Definition" -> + (fun _ _ -> ()), (Global, Definition true) + | "Definition" -> (fun _ _ -> ()), (Global, Definition false) + | IDENT "Local" -> (fun _ _ -> ()), (Local, Definition true) | IDENT "SubClass" -> Class.add_subclass_hook, (Global, SubClass) | IDENT "Local"; IDENT "SubClass" -> Class.add_subclass_hook, (Local, SubClass) ] ] @@ -315,8 +317,12 @@ GEXTEND Gram VernacInductive (f,indl) | f = finite_token; indl = LIST1 oneind SEP "with" -> VernacInductive (f,indl) - | "Fixpoint"; recs = specifrec -> VernacFixpoint recs - | "CoFixpoint"; corecs = specifcorec -> VernacCoFixpoint corecs + | IDENT "Boxed"; "Fixpoint"; recs = specifrec -> + VernacFixpoint (recs,true) + | "Fixpoint"; recs = specifrec -> VernacFixpoint (recs,false) + | IDENT "Boxed"; "CoFixpoint"; corecs = specifcorec -> + VernacCoFixpoint (corecs,true) + | "CoFixpoint"; corecs = specifcorec -> VernacCoFixpoint (corecs,false) | IDENT "Scheme"; l = schemes -> VernacScheme l | f = finite_token; s = csort; id = identref; indpar = simple_binders_list; ":="; lc = constructor_list -> diff --git a/parsing/g_vernacnew.ml4 b/parsing/g_vernacnew.ml4 index def78d92a..9cf0d3a21 100644 --- a/parsing/g_vernacnew.ml4 +++ b/parsing/g_vernacnew.ml4 @@ -96,21 +96,28 @@ GEXTEND Gram [ [ thm = thm_token; id = identref; bl = LIST0 binder_let; ":"; c = lconstr -> VernacStartTheoremProof (thm, id, (bl, c), false, (fun _ _ -> ())) - | (f,d) = def_token; id = identref; b = def_body -> - VernacDefinition (d, id, b, f) | stre = assumption_token; bl = assum_list -> VernacAssumption (stre, bl) | stre = assumptions_token; bl = assum_list -> test_plurial_form bl; VernacAssumption (stre, bl) + | IDENT "Boxed";"Definition";id = identref; b = def_body -> + VernacDefinition ((Global,Definition true), id, b, (fun _ _ -> ())) + | (f,d) = def_token; id = identref; b = def_body -> + VernacDefinition (d, id, b, f) (* Gallina inductive declarations *) | f = finite_token; indl = LIST1 inductive_definition SEP "with" -> VernacInductive (f,indl) + | IDENT "Boxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" -> + VernacFixpoint (recs,true) | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint recs + VernacFixpoint (recs,false) + | IDENT "Boxed"; "CoFixpoint"; + corecs = LIST1 corec_definition SEP "with" -> + VernacCoFixpoint (corecs,true) | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint corecs + VernacCoFixpoint (corecs,false) | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l ] ] ; gallina_ext: @@ -133,8 +140,8 @@ GEXTEND Gram | IDENT "Remark" -> Remark ] ] ; def_token: - [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition) - | IDENT "Let" -> (fun _ _ -> ()), (Local, Definition) + [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition false) + | IDENT "Let" -> (fun _ _ -> ()), (Local, Definition false) | IDENT "SubClass" -> Class.add_subclass_hook, (Global, SubClass) | IDENT "Local"; IDENT "SubClass" -> Class.add_subclass_hook, (Local, SubClass) ] ] diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index 3a02e5f25..3bfd26d72 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -372,6 +372,8 @@ let pr_red_expr (pr_constr,pr_ref) = function | Red true -> error "Shouldn't be accessible from user" | ExtraRedExpr (s,c) -> hov 1 (str s ++ pr_arg pr_constr c) + | CbvVm -> str "vm_compute" + let rec pr_may_eval pr pr2 = function | ConstrEval (r,c) -> diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index 8c78e4fc7..3057e41a4 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -456,6 +456,7 @@ and pr_atom1 = function (str "Intro" ++ pr_opt pr_id ido1 ++ spc () ++ str "after " ++ pr_id id2) | TacAssumption as t -> pr_atom0 t | TacExact c -> hov 1 (str "Exact" ++ pr_arg pr_constr c) + | TacExactNoCheck c -> hov 1 (str "Exact_no_check" ++ pr_arg pr_constr c) | TacApply cb -> hov 1 (str "Apply" ++ spc () ++ pr_with_bindings cb) | TacElim (cb,cbo) -> hov 1 (str "Elim" ++ pr_arg pr_with_bindings cb ++ diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index 3ed0256ff..ec1e6410e 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -248,6 +248,7 @@ let mlexpr_of_red_expr = function | Rawterm.Pattern l -> let f = mlexpr_of_list mlexpr_of_occ_constr in <:expr< Rawterm.Pattern $f l$ >> + | Rawterm.CbvVm -> <:expr< Rawterm.CbvVm >> | Rawterm.ExtraRedExpr (s,c) -> let l = mlexpr_of_constr c in <:expr< Rawterm.ExtraRedExpr $mlexpr_of_string s$ $l$ >> @@ -350,6 +351,8 @@ let rec mlexpr_of_atomic_tactic = function <:expr< Tacexpr.TacAssumption >> | Tacexpr.TacExact c -> <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >> + | Tacexpr.TacExactNoCheck c -> + <:expr< Tacexpr.TacExactNoCheck $mlexpr_of_constr c$ >> | Tacexpr.TacApply cb -> <:expr< Tacexpr.TacApply $mlexpr_of_constr_with_binding cb$ >> | Tacexpr.TacElim (cb,cbo) -> diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index ceb23cc78..33a9272d0 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -15,6 +15,7 @@ open Names open Environ open Univ open Evd +open Conv_oracle open Closure open Esubst @@ -91,7 +92,7 @@ let contract_cofixp env (i,(_,_,bds as bodies)) = subst_bodies_from_i 0 env, bds.(i) let make_constr_ref n = function - | FarRelKey p -> mkRel (n+p) + | RelKey p -> mkRel (n+p) | VarKey id -> mkVar id | ConstKey cst -> mkConst cst @@ -127,7 +128,7 @@ let stack_app appl stack = open RedFlags let red_set_ref flags = function - | FarRelKey _ -> red_set flags fDELTA + | RelKey _ -> red_set flags fDELTA | VarKey id -> red_set flags (fVAR id) | ConstKey sp -> red_set flags (fCONST sp) @@ -195,7 +196,7 @@ let rec norm_head info env t stack = | Inl (0,v) -> strip_appl v stack | Inl (n,v) -> strip_appl (shift_value n v) stack | Inr (n,None) -> (VAL(0, mkRel n), stack) - | Inr (n,Some p) -> norm_head_ref (n-p) info env stack (FarRelKey p)) + | Inr (n,Some p) -> norm_head_ref (n-p) info env stack (RelKey p)) | Var id -> norm_head_ref 0 info env stack (VarKey id) diff --git a/pretyping/clenv.ml b/pretyping/clenv.ml index 121466334..981692ebd 100644 --- a/pretyping/clenv.ml +++ b/pretyping/clenv.ml @@ -17,6 +17,7 @@ open Termops open Sign open Environ open Evd +open Reduction open Reductionops open Rawterm open Pattern diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 2ed26c92c..93d9ba906 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -11,6 +11,7 @@ open Util open Names open Term +open Reduction open Reductionops open Closure open Environ diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 52a899714..c199eb008 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -458,7 +458,7 @@ let solve_refl conv_algo env isevars ev argsv1 argsv2 = let (isevars',_,rsign) = array_fold_left2 (fun (isevars,sgn,rsgn) a1 a2 -> - let (isevars',b) = conv_algo env isevars CONV a1 a2 in + let (isevars',b) = conv_algo env isevars Reduction.CONV a1 a2 in if b then (isevars',List.tl sgn, add_named_decl (List.hd sgn) rsgn) else diff --git a/pretyping/evd.ml b/pretyping/evd.ml index e9c60e18e..5c0f42852 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -198,10 +198,7 @@ type hole_kind = | InternalHole | TomatchTypeParameter of inductive * int -type conv_pb = - | CONV - | CUMUL - +type conv_pb = Reduction.conv_pb type evar_constraint = conv_pb * constr * constr type evar_defs = { evars : evar_map; diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 4487c9220..9f10d2dfe 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -129,9 +129,7 @@ val evar_define : evar -> constr -> evar_defs -> evar_defs val evar_source : existential_key -> evar_defs -> loc * hole_kind (* Unification constraints *) -type conv_pb = - | CONV - | CUMUL +type conv_pb = Reduction.conv_pb type evar_constraint = conv_pb * constr * constr val add_conv_pb : evar_constraint -> evar_defs -> evar_defs val get_conv_pbs : evar_defs -> (evar_constraint -> bool) -> diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml index 0a9722b87..d93a583c4 100644 --- a/pretyping/rawterm.ml +++ b/pretyping/rawterm.ml @@ -350,6 +350,7 @@ type ('a,'b) red_expr_gen = | Fold of 'a list | Pattern of 'a occurrences list | ExtraRedExpr of string * 'a + | CbvVm type ('a,'b) may_eval = | ConstrTerm of 'a diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli index ff1f86c58..7e8b8b894 100644 --- a/pretyping/rawterm.mli +++ b/pretyping/rawterm.mli @@ -123,6 +123,7 @@ type ('a,'b) red_expr_gen = | Fold of 'a list | Pattern of 'a occurrences list | ExtraRedExpr of string * 'a + | CbvVm type ('a,'b) may_eval = | ConstrTerm of 'a diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index a48881bd7..9ec71866b 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -285,6 +285,17 @@ let reference_eval sigma env = function end) | ref -> compute_consteval sigma env ref +let rev_firstn_liftn fn ln = + let rec rfprec p res l = + if p = 0 then + res + else + match l with + | [] -> invalid_arg "Reduction.rev_firstn_liftn" + | a::rest -> rfprec (p-1) ((lift ln a)::res) rest + in + rfprec fn [] + (* If f is bound to EliminationFix (n',infos), then n' is the minimal number of args for starting the reduction and infos is (nbfix,[(yi1,Ti1);...;(yip,Tip)],n) indicating that f converts @@ -292,7 +303,6 @@ let reference_eval sigma env = function yij = Rel(n+1-j) f is applied to largs and we need for recursive calls to build the function - g := [xp:Tip',...,x1:Ti1'](f a1 ... an) s.t. (g u1 ... up) reduces to (Fix(..) u1 ... up) @@ -790,6 +800,11 @@ let cbv_betadeltaiota env sigma = cbv_norm_flags betadeltaiota env sigma let compute = cbv_betadeltaiota +(* call by value reduction functions using virtual machine *) +let cbv_vm env _ c = + let ctyp = (fst (Typeops.infer env c)).uj_type in + Vconv.cbv_vm env c ctyp + (* Pattern *) (* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only @@ -860,6 +875,7 @@ let reduction_of_redexp = function | ExtraRedExpr (s,c) -> (try Stringmap.find s !red_expr_tab with Not_found -> error("unknown user-defined reduction \""^s^"\"")) + | CbvVm -> cbv_vm (* Used in several tactics. *) exception NotStepReducible diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 2ac908ad4..0c093694c 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -51,6 +51,9 @@ val cbv_norm_flags : Closure.RedFlags.reds -> reduction_function val cbv_betadeltaiota : reduction_function val compute : reduction_function (* = [cbv_betadeltaiota] *) +(* Call by value strategy (uses virtual machine) *) +val cbv_vm : reduction_function + (* [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 314e361c3..b5e175dd8 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -17,6 +17,7 @@ open Termops open Sign open Environ open Evd +open Reduction open Reductionops open Rawterm open Pattern diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 07c3aca83..e653345da 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -22,6 +22,7 @@ open Proof_type open Refiner open Proof_trees open Logic +open Reduction open Reductionops open Tacmach open Evar_refiner diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 2e6946f72..671fbd34c 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -192,7 +192,8 @@ let cook_proof () = (ident, ({ const_entry_body = pfterm; const_entry_type = Some concl; - const_entry_opaque = true }, + const_entry_opaque = true; + const_entry_boxed = false}, strength, ts.top_hook)) let current_proof_statement () = diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml index 3e925d460..12fa2b950 100644 --- a/proofs/tacexpr.ml +++ b/proofs/tacexpr.ml @@ -113,6 +113,7 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr = | TacIntroMove of identifier option * identifier located option | TacAssumption | TacExact of 'constr + | TacExactNoCheck of 'constr | TacApply of 'constr with_bindings | TacElim of 'constr with_bindings * 'constr with_bindings option | TacElimType of 'constr diff --git a/scripts/coqc.ml b/scripts/coqc.ml index ee7cf9da1..6959aad2d 100644 --- a/scripts/coqc.ml +++ b/scripts/coqc.ml @@ -148,9 +148,12 @@ let parse_args () = | [] -> usage () end | "-R" as o :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem - | ("-notactics"|"-debug"|"-nolib"|"-batch"|"-nois" + + | ("-notactics"|"-debug"|"-db"|"-debugger"|"-nolib" + | "-debugVM"|"-alltransp"|"-VMno" + |"-batch"|"-nois" |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet" - |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-translate"|"-strict-implicit" + |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-translate" |"-strict-implicit" |"-dont-load-proofs"|"-impredicative-set" as o) :: rem -> parse (cfiles,o::args) rem | ("-v"|"--version") :: _ -> diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml index 8a661d47c..632c3ebd6 100644 --- a/scripts/coqmktop.ml +++ b/scripts/coqmktop.ml @@ -66,8 +66,10 @@ let native_suffix f = (Filename.chop_suffix f ".cmo") ^ ".cmx" else if Filename.check_suffix f ".cma" then (Filename.chop_suffix f ".cma") ^ ".cmxa" - else - failwith ("File "^f^" has not extension .cmo or .cma") + else + if Filename.check_suffix f ".a" then f + else + failwith ("File "^f^" has not extension .cmo, .cma or .a") (* Transforms a file name in the corresponding Caml module name. *) let rem_ext_regexpr = Str.regexp "\\(.*\\)\\.\\(cm..?\\|ml\\)" diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml index 0f61d3b0e..a33d648ed 100644 --- a/tactics/hiddentac.ml +++ b/tactics/hiddentac.ml @@ -28,6 +28,7 @@ let h_intro x = h_intro_move (Some x) None let h_intros_until x = abstract_tactic (TacIntrosUntil x) (intros_until x) let h_assumption = abstract_tactic TacAssumption assumption let h_exact c = abstract_tactic (TacExact c) (exact_check c) +let h_exact_no_check c = abstract_tactic (TacExactNoCheck c) (exact_no_check c) let h_apply cb = abstract_tactic (TacApply cb) (apply_with_bindings cb) let h_elim cb cbo = abstract_tactic (TacElim (cb,cbo)) (elim cb cbo) let h_elim_type c = abstract_tactic (TacElimType c) (elim_type c) diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli index 711e71d91..ddfb9bd12 100644 --- a/tactics/hiddentac.mli +++ b/tactics/hiddentac.mli @@ -29,6 +29,7 @@ val h_intros_until : quantified_hypothesis -> tactic val h_assumption : tactic val h_exact : constr -> tactic +val h_exact_no_check : constr -> tactic val h_apply : constr with_bindings -> tactic diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 9fd54ee69..77d9233d1 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -246,8 +246,9 @@ let add_inversion_lemma name env sigma t sort dep inv_op = let _ = declare_constant name (DefinitionEntry { const_entry_body = invProof; - const_entry_type = None; - const_entry_opaque = false }, + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = true}, IsProof Lemma) in () diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml index cf0388543..a1873770b 100644 --- a/tactics/setoid_replace.ml +++ b/tactics/setoid_replace.ml @@ -690,7 +690,8 @@ let add_morphism lemma_infos mor_name (m,quantifiers_rev,args,output) = [| argsconstr; outputconstr; apply_to_rels m quantifiers_rev ; apply_to_rels mext quantifiers_rev |])); const_entry_type = None; - const_entry_opaque = false}, + const_entry_opaque = false; + const_entry_boxed = false}, IsDefinition)) ; mext in @@ -993,7 +994,8 @@ let int_add_relation id a aeq refl sym trans = Name (id_of_string "X"),None,mkType (Termops.new_univ ())] @ a_quantifiers_rev); const_entry_type = None; - const_entry_opaque = false}, + const_entry_opaque = false; + const_entry_boxed = false}, IsDefinition) in let id_precise = id_of_string (string_of_id id ^ "_precise_relation_class") in let xreflexive_relation_class = @@ -1009,7 +1011,8 @@ let int_add_relation id a aeq refl sym trans = {const_entry_body = Sign.it_mkLambda_or_LetIn xreflexive_relation_class a_quantifiers_rev; const_entry_type = None; - const_entry_opaque = false}, + const_entry_opaque = false; + const_entry_boxed = false }, IsDefinition) in let aeq_rel = { aeq_rel with @@ -1068,7 +1071,8 @@ let int_add_relation id a aeq refl sym trans = (DefinitionEntry {const_entry_body = Sign.it_mkLambda_or_LetIn lemma a_quantifiers_rev; const_entry_type = None; - const_entry_opaque = false}, + const_entry_opaque = false; + const_entry_boxed = false}, IsDefinition) in let a_quantifiers_rev = diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 6f459b15c..00dc19332 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -552,7 +552,7 @@ let intern_redexp ist = function | Lazy f -> Lazy (intern_flag ist f) | Pattern l -> Pattern (List.map (intern_constr_occurrence ist) l) | Simpl o -> Simpl (option_app (intern_constr_occurrence ist) o) - | (Red _ | Hnf as r) -> r + | (Red _ | Hnf | CbvVm as r ) -> r | ExtraRedExpr (s,c) -> ExtraRedExpr (s, intern_constr ist c) let intern_inversion_strength lf ist = function @@ -637,6 +637,7 @@ let rec intern_atomic lf ist x = option_app (intern_hyp ist) ido') | TacAssumption -> TacAssumption | TacExact c -> TacExact (intern_constr ist c) + | TacExactNoCheck c -> TacExactNoCheck (intern_constr ist c) | TacApply cb -> TacApply (intern_constr_with_bindings ist cb) | TacElim (cb,cbo) -> TacElim (intern_constr_with_bindings ist cb, @@ -1233,7 +1234,7 @@ let redexp_interp ist sigma env = function | Lazy f -> Lazy (interp_flag ist env f) | Pattern l -> Pattern (List.map (interp_pattern ist sigma env) l) | Simpl o -> Simpl (option_app (interp_pattern ist sigma env) o) - | (Red _ | Hnf as r) -> r + | (Red _ | Hnf | CbvVm as r) -> r | ExtraRedExpr (s,c) -> ExtraRedExpr (s,interp_constr ist sigma env c) let pf_redexp_interp ist gl = redexp_interp ist (project gl) (pf_env gl) @@ -1653,6 +1654,7 @@ and interp_atomic ist gl = function (option_app (interp_hyp ist gl) ido') | TacAssumption -> h_assumption | TacExact c -> h_exact (pf_interp_casted_constr ist gl c) + | TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c) | TacApply cb -> h_apply (interp_constr_with_bindings ist gl cb) | TacElim (cb,cbo) -> h_elim (interp_constr_with_bindings ist gl cb) @@ -1894,7 +1896,7 @@ let subst_redexp subst = function | Lazy f -> Lazy (subst_flag subst f) | Pattern l -> Pattern (List.map (subst_constr_occurrence subst) l) | Simpl o -> Simpl (option_app (subst_constr_occurrence subst) o) - | (Red _ | Hnf as r) -> r + | (Red _ | Hnf | CbvVm as r) -> r | ExtraRedExpr (s,c) -> ExtraRedExpr (s, subst_rawconstr subst c) let subst_raw_may_eval subst = function @@ -1918,6 +1920,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacIntroPattern _ | TacIntrosUntil _ | TacIntroMove _ as x -> x | TacAssumption as x -> x | TacExact c -> TacExact (subst_rawconstr subst c) + | TacExactNoCheck c -> TacExactNoCheck (subst_rawconstr subst c) | TacApply cb -> TacApply (subst_raw_with_bindings subst cb) | TacElim (cb,cbo) -> TacElim (subst_raw_with_bindings subst cb, diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 3d91877d0..0a0589e96 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -369,7 +369,7 @@ let general_elim_then_using match predicate with | None -> elimclause' | Some p -> - clenv_unify true Evd.CONV (mkMeta pmv) p elimclause' + clenv_unify true Reduction.CONV (mkMeta pmv) p elimclause' in elim_res_pf_THEN_i elimclause' branchtacs gl diff --git a/tactics/tactics.ml b/tactics/tactics.ml index ad17f5248..11f2e38fe 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -184,10 +184,12 @@ let change_and_check cv_pb t env sigma c = (* Use cumulutavity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb t = function | None -> change_and_check cv_pb t - | Some occl -> contextually false occl (change_and_check CONV t) + | Some occl -> contextually false occl (change_and_check Reduction.CONV t) -let change_in_concl occl t = reduct_in_concl (change_on_subterm CUMUL t occl) -let change_in_hyp occl t = reduct_in_hyp (change_on_subterm CONV t occl) +let change_in_concl occl t = + reduct_in_concl (change_on_subterm Reduction.CUMUL t occl) +let change_in_hyp occl t = + reduct_in_hyp (change_on_subterm Reduction.CONV t occl) let change_option occl t = function Some id -> change_in_hyp occl t id @@ -1662,7 +1664,8 @@ let elim_scheme_type elim t gl = | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) - clenv_unify true CUMUL t (clenv_meta_type clause mv) clause in + clenv_unify true Reduction.CUMUL t + (clenv_meta_type clause mv) clause in res_pf clause' ~allow_K:true gl | _ -> anomaly "elim_scheme_type" diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v index 93b191c02..9f7de8503 100644 --- a/theories/Arith/Factorial.v +++ b/theories/Arith/Factorial.v @@ -15,7 +15,7 @@ Open Local Scope nat_scope. (** Factorial *) -Fixpoint fact (n:nat) : nat := +Boxed Fixpoint fact (n:nat) : nat := match n with | O => 1 | S n => S n * fact n @@ -47,4 +47,4 @@ assumption. simpl (1 * fact n) in H0. rewrite <- plus_n_O in H0. assumption. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v index 6acc72ce7..85a3102a0 100644 --- a/theories/Reals/Binomial.v +++ b/theories/Reals/Binomial.v @@ -13,7 +13,7 @@ Require Import Rfunctions. Require Import PartSum. Open Local Scope R_scope. -Definition C (n p:nat) : R := +Boxed Definition C (n p:nat) : R := INR (fact n) / (INR (fact p) * INR (fact (n - p))). Lemma pascal_step1 : forall n i:nat, (i <= n)%nat -> C n i = C n (n - i). @@ -201,4 +201,4 @@ replace (p - p)%nat with 0%nat; [ idtac | apply minus_n_n ]. replace (INR (fact 0)) with 1; [ idtac | reflexivity ]. rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym; [ reflexivity | apply INR_fact_neq_0 ]. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v index 85a405900..ba108e95e 100644 --- a/theories/Reals/Cos_rel.v +++ b/theories/Reals/Cos_rel.v @@ -417,4 +417,4 @@ unfold sin_in in s. assert (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s). rewrite H1; reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index 61200764e..c8fa2b0cf 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -1008,4 +1008,4 @@ rewrite Rmult_minus_distr_l. rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rmult_assoc; rewrite Rmult_minus_distr_l. rewrite Rmult_1_r; rewrite exp_plus; reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v index 92a958b16..d20b896a5 100644 --- a/theories/Reals/PartSum.v +++ b/theories/Reals/PartSum.v @@ -600,4 +600,4 @@ apply Rle_trans with (sum_f_R0 An n0 + Rabs (fn (S n0) x)). do 2 rewrite <- (Rplus_comm (Rabs (fn (S n0) x))). apply Rplus_le_compat_l; apply Hrecn0. apply Rplus_le_compat_l; apply H1. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index b588d96c7..2f2a52d08 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -13,7 +13,7 @@ Require Import Rfunctions. Require Import Rsqrt_def. Open Local Scope R_scope. (* Here is a continuous extension of Rsqrt on R *) -Definition sqrt (x:R) : R := +Boxed Definition sqrt (x:R) : R := match Rcase_abs x with | left _ => 0 | right a => Rsqrt (mknonnegreal x (Rge_le _ _ a)) @@ -396,4 +396,4 @@ unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse. rewrite Ropp_minus_distr. reflexivity. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 1fdf145e9..1acd611d5 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -107,7 +107,7 @@ Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real. (**********************************************************) (**********) -Fixpoint INR (n:nat) : R := +Boxed Fixpoint INR (n:nat) : R := match n with | O => 0 | S O => 1 @@ -121,7 +121,7 @@ Arguments Scope INR [nat_scope]. (**********************************************************) (**********) -Definition IZR (z:Z) : R := +Boxed Definition IZR (z:Z) : R := match z with | Z0 => 0 | Zpos n => INR (nat_of_P n) diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index 324ebb98f..3e1a9262d 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -63,7 +63,7 @@ Qed. (* Power *) (*******************************) (*********) -Fixpoint pow (r:R) (n:nat) {struct n} : R := +Boxed Fixpoint pow (r:R) (n:nat) {struct n} : R := match n with | O => 1 | S n => r * pow r n @@ -527,7 +527,7 @@ Qed. Ltac case_eq name := generalize (refl_equal name); pattern name at -1 in |- *; case name. -Definition powerRZ (x:R) (n:Z) := +Boxed Definition powerRZ (x:R) (n:Z) := match n with | Z0 => 1 | Zpos p => x ^ nat_of_P p @@ -670,7 +670,7 @@ Definition decimal_exp (r:R) (z:Z) : R := (r * 10 ^Z z). (** Sum of n first naturals *) (*******************************) (*********) -Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) {struct n} : nat := +Boxed Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) {struct n} : nat := match n with | O => f 0%nat | S n' => (sum_nat_f_O f n' + f (S n'))%nat @@ -690,7 +690,7 @@ Definition sum_nat (s n:nat) : nat := sum_nat_f s n (fun x:nat => x). (** Sum *) (*******************************) (*********) -Fixpoint sum_f_R0 (f:nat -> R) (N:nat) {struct N} : R := +Boxed Fixpoint sum_f_R0 (f:nat -> R) (N:nat) {struct N} : R := match N with | O => f 0%nat | S i => sum_f_R0 f i + f (S i) diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index fe0ed965e..7f86f3f42 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -461,7 +461,7 @@ assert (H5 := IZN _ H4); elim H5; clear H5; intros N H5; elim (Rlt_irrefl _ H7) ] ]. Qed. -Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) {struct N} : Rlist := +Boxed Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) {struct N} : Rlist := match N with | O => cons y nil | S p => cons x (SubEquiN p (x + del) y del) diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index 4dcdebdd1..d35672404 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -142,12 +142,12 @@ Record StepFun (a b:R) : Type := mkStepFun Definition subdivision (a b:R) (f:StepFun a b) : Rlist := projT1 (pre f). -Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist := +Boxed Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist := match projT2 (pre f) with | existT a b => a end. -Fixpoint Int_SF (l k:Rlist) {struct l} : R := +Boxed Fixpoint Int_SF (l k:Rlist) {struct l} : R := match l with | nil => 0 | cons a l' => @@ -159,7 +159,7 @@ Fixpoint Int_SF (l k:Rlist) {struct l} : R := end. (* Integral of step functions *) -Definition RiemannInt_SF (a b:R) (f:StepFun a b) : R := +Boxed Definition RiemannInt_SF (a b:R) (f:StepFun a b) : R := match Rle_dec a b with | left _ => Int_SF (subdivision_val f) (subdivision f) | right _ => - Int_SF (subdivision_val f) (subdivision f) diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index 7ef2ed69a..30dfa6274 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -195,13 +195,13 @@ apply Rinv_neq_0_compat; red in |- *; intro; rewrite H3 in H; Qed. (* Definition of log R+* -> R *) -Definition Rln (y:posreal) : R := +Boxed Definition Rln (y:posreal) : R := match ln_exists (pos y) (cond_pos y) with | existT a b => a end. (* Extension on R *) -Definition ln (x:R) : R := +Boxed Definition ln (x:R) : R := match Rlt_dec 0 x with | left a => Rln (mkposreal x a) | right a => 0 @@ -377,7 +377,7 @@ Qed. (* Definition of Rpower *) (******************************************************************) -Definition Rpower (x y:R) := exp (y * ln x). +Boxed Definition Rpower (x y:R) := exp (y * ln x). Infix Local "^R" := Rpower (at level 30, right associativity) : R_scope. @@ -658,4 +658,4 @@ apply derivable_pt_lim_const with (a := y). apply derivable_pt_lim_id. ring. apply derivable_pt_lim_exp. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v index 160d9be4c..b29fb6a98 100644 --- a/theories/Reals/Rprod.v +++ b/theories/Reals/Rprod.v @@ -17,7 +17,7 @@ Require Import Binomial. Open Local Scope R_scope. (* TT Ak; 1<=k<=N *) -Fixpoint prod_f_SO (An:nat -> R) (N:nat) {struct N} : R := +Boxed Fixpoint prod_f_SO (An:nat -> R) (N:nat) {struct N} : R := match N with | O => 1 | S p => prod_f_SO An p * An (S p) @@ -188,4 +188,4 @@ rewrite mult_INR; apply prod_neq_R0; apply INR_fact_neq_0. apply prod_neq_R0; apply INR_fact_neq_0. apply INR_eq; rewrite minus_INR; [ rewrite mult_INR; do 2 rewrite S_INR; ring | apply le_n_2n ]. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index 9bab638af..6d3457229 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -28,7 +28,7 @@ Section sequence. Variable Un : nat -> R. (*********) -Fixpoint Rmax_N (N:nat) : R := +Boxed Fixpoint Rmax_N (N:nat) : R := match N with | O => Un 0 | S n => Rmax (Un (S n)) (Rmax_N n) diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v index 7794e1598..df750b9c6 100644 --- a/theories/Reals/Rsqrt_def.v +++ b/theories/Reals/Rsqrt_def.v @@ -15,7 +15,7 @@ Require Import SeqSeries. Require Import Ranalysis1. Open Local Scope R_scope. -Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R := +Boxed Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R := match N with | O => x | S n => @@ -759,4 +759,4 @@ apply Rsqr_inj. assumption. assumption. rewrite <- H0; rewrite <- H2; reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v index 335728b2b..f8db0463f 100644 --- a/theories/Reals/Rtrigo.v +++ b/theories/Reals/Rtrigo.v @@ -1704,4 +1704,4 @@ Lemma cos_eq_0_2PI_1 : intros x H1 H2 H3; elim H3; intro H4; [ rewrite H4; rewrite cos_PI2; reflexivity | rewrite H4; rewrite cos_3PI2; reflexivity ]. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index 01bdfd2fa..7a4921628 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -423,4 +423,4 @@ intros; unfold cos_approx in |- *; apply sum_eq; intros; unfold cos_term in |- *; do 2 rewrite pow_Rsqr; rewrite Rsqr_neg; unfold Rdiv in |- *; reflexivity. apply Ropp_0_gt_lt_contravar; assumption. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index 170431ecd..3d848a948 100644 --- a/theories/Reals/Rtrigo_def.v +++ b/theories/Reals/Rtrigo_def.v @@ -35,7 +35,7 @@ unfold Pser, exp_in in |- *. trivial. Defined. -Definition exp (x:R) : R := projT1 (exist_exp x). +Boxed Definition exp (x:R) : R := projT1 (exist_exp x). Lemma pow_i : forall i:nat, (0 < i)%nat -> 0 ^ i = 0. intros; apply pow_ne_zero. @@ -235,7 +235,7 @@ Qed. (* Definition of cosinus *) (*************************) -Definition cos (x:R) : R := +Boxed Definition cos (x:R) : R := match exist_cos (Rsqr x) with | existT a b => a end. @@ -356,7 +356,7 @@ Qed. (***********************) (* Definition of sinus *) -Definition sin (x:R) : R := +Boxed Definition sin (x:R) : R := match exist_sin (Rsqr x) with | existT a b => x * a end. @@ -409,4 +409,4 @@ apply H. exact (projT2 exist_cos0). assert (H := projT2 (exist_cos (Rsqr 0))); unfold cos in |- *; pattern 0 at 1 in |- *; replace 0 with (Rsqr 0); [ exact H | apply Rsqr_0 ]. -Qed.
\ No newline at end of file +Qed. diff --git a/toplevel/class.ml b/toplevel/class.ml index fa29cac59..e0339768e 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -269,7 +269,8 @@ let build_id_coercion idf_opt source = DefinitionEntry { const_entry_body = mkCast (val_f, typ_f); const_entry_type = Some typ_f; - const_entry_opaque = false } in + const_entry_opaque = false; + const_entry_boxed = false} in let (_,kn) = declare_constant idf (constr_entry,Decl_kinds.IsDefinition) in ConstRef kn diff --git a/toplevel/command.ml b/toplevel/command.ml index f2642fcd1..a0cf3c40e 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -84,7 +84,7 @@ let rec adjust_conclusion a cs = function let definition_message id = if_verbose message ((string_of_id id) ^ " is defined") -let constant_entry_of_com (bl,com,comtypopt,opacity) = +let constant_entry_of_com (bl,com,comtypopt,opacity,boxed) = let sigma = Evd.empty in let env = Global.env() in match comtypopt with @@ -93,7 +93,8 @@ let constant_entry_of_com (bl,com,comtypopt,opacity) = let j = judgment_of_rawconstr sigma env b in { const_entry_body = j.uj_val; const_entry_type = Some (refresh_universes j.uj_type); - const_entry_opaque = opacity } + const_entry_opaque = opacity; + const_entry_boxed = boxed } | Some comtyp -> (* We use a cast to avoid troubles with evars in comtyp *) (* that can only be resolved knowing com *) @@ -101,7 +102,8 @@ let constant_entry_of_com (bl,com,comtypopt,opacity) = let (body,typ) = destSubCast (interp_constr sigma env b) in { const_entry_body = body; const_entry_type = Some typ; - const_entry_opaque = opacity } + const_entry_opaque = opacity; + const_entry_boxed = boxed } let red_constant_entry ce = function | None -> ce @@ -117,8 +119,14 @@ let declare_global_definition ident ce local = definition_message ident; ConstRef kn -let declare_definition ident (local,_) bl red_option c typopt hook = - let ce = constant_entry_of_com (bl,c,typopt,false) in +let is_boxed_def dok = + match dok with + | Definition b -> b + | _ -> false + +let declare_definition ident (local,dok) bl red_option c typopt hook = + let boxed = is_boxed_def dok in + let ce = constant_entry_of_com (bl,c,typopt,false,boxed) in if bl<>[] && red_option <> None then error "Evaluation under a local context not supported"; let ce' = red_constant_entry ce red_option in @@ -189,7 +197,8 @@ let declare_one_elimination ind = (DefinitionEntry { const_entry_body = c; const_entry_type = t; - const_entry_opaque = false }, + const_entry_opaque = false; + const_entry_boxed = true }, Decl_kinds.IsDefinition) in definition_message id; kn @@ -451,7 +460,8 @@ let collect_non_rec env = in searchrec [] -let build_recursive (lnameargsardef:(fixpoint_expr *decl_notation) list) = +let build_recursive (lnameargsardef:(fixpoint_expr *decl_notation) list) + boxed = let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef and sigma = Evd.empty and env0 = Global.env() @@ -502,7 +512,8 @@ let build_recursive (lnameargsardef:(fixpoint_expr *decl_notation) list) = let ce = { const_entry_body = mkFix ((nvrec,i),recdecls); const_entry_type = Some arrec.(i); - const_entry_opaque = false } in + const_entry_opaque = false; + const_entry_boxed = boxed} in let (_,kn) = declare_constant fi (DefinitionEntry ce, IsDefinition) in (ConstRef kn) in @@ -516,7 +527,8 @@ let build_recursive (lnameargsardef:(fixpoint_expr *decl_notation) list) = (fun subst (f,def,t) -> let ce = { const_entry_body = replace_vars subst def; const_entry_type = Some t; - const_entry_opaque = false } in + const_entry_opaque = false; + const_entry_boxed = boxed } in let _ = declare_constant f (DefinitionEntry ce, IsDefinition) in warning ((string_of_id f)^" is non-recursively defined"); (var_subst f) :: subst) @@ -526,7 +538,7 @@ let build_recursive (lnameargsardef:(fixpoint_expr *decl_notation) list) = List.iter (fun (df,c,scope) -> Metasyntax.add_notation_interpretation df [] c scope) notations -let build_corecursive lnameardef = +let build_corecursive lnameardef boxed = let lrecnames = List.map (fun (f,_,_,_) -> f) lnameardef and sigma = Evd.empty and env0 = Global.env() in @@ -566,7 +578,8 @@ let build_corecursive lnameardef = let ce = { const_entry_body = mkCoFix (i, recdecls); const_entry_type = Some (arrec.(i)); - const_entry_opaque = false } + const_entry_opaque = false; + const_entry_boxed = boxed } in let _,kn = declare_constant fi (DefinitionEntry ce, IsDefinition) in (ConstRef kn) @@ -579,7 +592,8 @@ let build_corecursive lnameardef = (fun subst (f,def,t) -> let ce = { const_entry_body = replace_vars subst def; const_entry_type = Some t; - const_entry_opaque = false } in + const_entry_opaque = false; + const_entry_boxed = boxed } in let _ = declare_constant f (DefinitionEntry ce,IsDefinition) in warning ((string_of_id f)^" is non-recursively defined"); (var_subst f) :: subst) @@ -605,7 +619,8 @@ let build_scheme lnamedepindsort = let decltype = refresh_universes decltype in let ce = { const_entry_body = decl; const_entry_type = Some decltype; - const_entry_opaque = false } in + const_entry_opaque = false; + const_entry_boxed = true } in let _,kn = declare_constant fi (DefinitionEntry ce, IsDefinition) in ConstRef kn :: lrecref in diff --git a/toplevel/command.mli b/toplevel/command.mli index 7fba7bb75..cd97ec5f8 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -43,9 +43,9 @@ val build_mutual : inductive_expr list -> bool -> unit val declare_mutual_with_eliminations : bool -> Entries.mutual_inductive_entry -> mutual_inductive -val build_recursive : (fixpoint_expr * decl_notation) list -> unit +val build_recursive : (fixpoint_expr * decl_notation) list -> bool -> unit -val build_corecursive : cofixpoint_expr list -> unit +val build_corecursive : cofixpoint_expr list -> bool -> unit val build_scheme : (identifier located * bool * reference * rawsort) list -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 248f68796..1a90139b4 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -227,7 +227,8 @@ let parse_args is_ide = | "-unsafe" :: [] -> usage () | "-debug" :: rem -> set_debug (); parse rem - + | "-unboxed-values" :: rem -> Vm.set_transp_values true; parse rem + | "-no-vm" :: rem -> Reduction.use_vm := false;parse rem | "-emacs" :: rem -> Options.print_emacs := true; parse rem | "-where" :: _ -> print_endline Coq_config.coqlib; exit 0 diff --git a/toplevel/record.ml b/toplevel/record.ml index da24a7dd2..91f5b4ad8 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -181,7 +181,8 @@ let declare_projections indsp coers fields = let cie = { const_entry_body = proj; const_entry_type = Some projtyp; - const_entry_opaque = false } in + const_entry_opaque = false; + const_entry_boxed = false } in let k = (DefinitionEntry cie,IsDefinition) in let sp = declare_internal_constant fid k in Options.if_verbose message (string_of_id fid ^" is defined"); diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index e8c8516bf..c4e15b68b 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -751,6 +751,22 @@ let _ = optwrite = (fun b -> Options.raw_print := b) } let _ = + declare_bool_option + { optsync = false; + optname = "use of virtual machine inside the kernel"; + optkey = (SecondaryTable ("Virtual","Machine")); + optread = (fun () -> !Reduction.use_vm); + optwrite = (fun b -> Reduction.use_vm := b) } + +let _ = + declare_bool_option + { optsync = false; + optname = "transparent values for virtual machine"; + optkey = (SecondaryTable ("Boxed","Values")); + optread = Vm.transp_values; + optwrite = (fun b -> Vm.set_transp_values b) } + +let _ = declare_int_option { optsync=false; optkey=PrimaryTable("Undo"); @@ -1154,8 +1170,8 @@ let interp c = match c with | VernacExactProof c -> vernac_exact_proof c | VernacAssumption (stre,l) -> vernac_assumption stre l | VernacInductive (finite,l) -> vernac_inductive finite l - | VernacFixpoint l -> vernac_fixpoint l - | VernacCoFixpoint l -> vernac_cofixpoint l + | VernacFixpoint (l,b) -> vernac_fixpoint l b + | VernacCoFixpoint (l,b) -> vernac_cofixpoint l b | VernacScheme l -> vernac_scheme l (* Modules *) diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index 892b5935e..854d18152 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -196,8 +196,8 @@ type vernac_expr = | VernacExactProof of constr_expr | VernacAssumption of assumption_kind * simple_binder with_coercion list | VernacInductive of inductive_flag * inductive_expr list - | VernacFixpoint of (fixpoint_expr * decl_notation) list - | VernacCoFixpoint of cofixpoint_expr list + | VernacFixpoint of (fixpoint_expr * decl_notation) list * bool + | VernacCoFixpoint of cofixpoint_expr list * bool | VernacScheme of (lident * bool * lreference * sort_expr) list (* Gallina extensions *) diff --git a/translate/ppconstrnew.ml b/translate/ppconstrnew.ml index 35cd2ea2c..3e08fae30 100644 --- a/translate/ppconstrnew.ml +++ b/translate/ppconstrnew.ml @@ -773,6 +773,7 @@ let pr_red_expr (pr_constr,pr_lconstr,pr_ref) = function | Red true -> error "Shouldn't be accessible from user" | ExtraRedExpr (s,c) -> hov 1 (str s ++ pr_arg pr_constr c) + | CbvVm -> str "vm_compute" let rec pr_may_eval test prc prlc pr2 = function | ConstrEval (r,c) -> diff --git a/translate/pptacticnew.ml b/translate/pptacticnew.ml index 7596dc2c3..0dbf05aac 100644 --- a/translate/pptacticnew.ml +++ b/translate/pptacticnew.ml @@ -487,6 +487,7 @@ and pr_atom1 env = function pr_lident id2) | TacAssumption as t -> pr_atom0 env t | TacExact c -> hov 1 (str "exact" ++ pr_constrarg env c) + | TacExactNoCheck c -> hov 1 (str "exact_no_check" ++ pr_constrarg env c) | TacApply cb -> hov 1 (str "apply" ++ spc () ++ pr_with_bindings env cb) | TacElim (cb,cbo) -> hov 1 (str "elim" ++ pr_arg (pr_with_bindings env) cb ++ diff --git a/translate/ppvernacnew.ml b/translate/ppvernacnew.ml index 085dcccb1..ecf7b76a1 100644 --- a/translate/ppvernacnew.ml +++ b/translate/ppvernacnew.ml @@ -578,8 +578,10 @@ let rec pr_vernac = function let pr_def_token = function | Local, Coercion -> str"Coercion Local" | Global, Coercion -> str"Coercion" - | Local, Definition -> str"Let" - | Global, Definition -> str"Definition" + | Local, Definition _ -> str"Let" + | Global, Definition b -> + if b then str"Boxed Definition" + else str"Definition" | Local, SubClass -> str"Local SubClass" | Global, SubClass -> str"SubClass" | Global, CanonicalStructure -> str"Canonical Structure" @@ -726,7 +728,7 @@ let rec pr_vernac = function (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) - | VernacFixpoint recs -> + | VernacFixpoint (recs,b) -> (* Copie simplifiée de command.ml pour recalculer les implicites *) (* les notations, et le contexte d'evaluation *) @@ -792,10 +794,11 @@ let rec pr_vernac = function ++ str" :=" ++ brk(1,1) ++ ppc ++ pr_decl_notation pr_constr ntn in - hov 1 (str"Fixpoint" ++ spc() ++ + let start = if b then "Boxed Fixpoint" else "Fixpoint" in + hov 1 (str start ++ spc() ++ prlist_with_sep (fun _ -> fnl() ++ fnl() ++ str"with ") pr_onerec recs) - | VernacCoFixpoint corecs -> + | VernacCoFixpoint (corecs,b) -> let pr_onecorec (id,bl,c,def) = let (bl',def,c) = if Options.do_translate() then extract_def_binders def c @@ -804,7 +807,8 @@ let rec pr_vernac = function pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ spc() ++ pr_type c ++ str" :=" ++ brk(1,1) ++ pr_lconstr def in - hov 1 (str"CoFixpoint" ++ spc() ++ + let start = if b then "Boxed CoFixpoint" else "CoFixpoint" in + hov 1 (str start ++ spc() ++ prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs) | VernacScheme l -> hov 2 (str"Scheme" ++ spc() ++ |