From 7cfc4e5146be5666419451bdd516f1f3f264d24a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 25 Jan 2015 14:42:51 +0100 Subject: Imported Upstream version 8.5~beta1+dfsg --- checker/check.ml | 224 ++++++--- checker/check.mllib | 39 +- checker/check_stat.ml | 13 +- checker/check_stat.mli | 2 +- checker/checker.ml | 154 +++--- checker/cic.mli | 444 ++++++++++++++++ checker/closure.ml | 329 ++++++------ checker/closure.mli | 33 +- checker/declarations.ml | 582 ++++++--------------- checker/declarations.mli | 213 +------- checker/environ.ml | 97 ++-- checker/environ.mli | 52 +- checker/include | 26 +- checker/indtypes.ml | 126 ++--- checker/indtypes.mli | 15 +- checker/inductive.ml | 666 +++++++++++++++++------- checker/inductive.mli | 25 +- checker/mod_checking.ml | 427 ++++------------ checker/mod_checking.mli | 4 +- checker/modops.ml | 159 +++--- checker/modops.mli | 29 +- checker/print.ml | 144 ++++++ checker/reduction.ml | 190 +++++-- checker/reduction.mli | 5 +- checker/safe_typing.ml | 156 +----- checker/safe_typing.mli | 30 +- checker/subtyping.ml | 217 ++++---- checker/subtyping.mli | 6 +- checker/term.ml | 254 ++++------ checker/term.mli | 66 +-- checker/type_errors.ml | 11 +- checker/type_errors.mli | 11 +- checker/typeops.ml | 184 +++---- checker/typeops.mli | 9 +- checker/univ.ml | 1253 ++++++++++++++++++++++++++++++++++++++++++++++ checker/univ.mli | 224 +++++++++ checker/validate.ml | 188 +++---- checker/values.ml | 350 +++++++++++++ checker/votour.ml | 189 +++++++ 39 files changed, 4629 insertions(+), 2517 deletions(-) create mode 100644 checker/cic.mli create mode 100644 checker/print.ml create mode 100644 checker/univ.ml create mode 100644 checker/univ.mli create mode 100644 checker/values.ml create mode 100644 checker/votour.ml (limited to 'checker') diff --git a/checker/check.ml b/checker/check.ml index 85ee28db..9a750858 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -1,31 +1,32 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* failwith "path_of_dirpath" | l::dir -> - {dirpath=List.map string_of_id dir;basename=string_of_id l} + {dirpath=List.map Id.to_string dir;basename=Id.to_string l} let pr_dirlist dp = prlist_with_sep (fun _ -> str".") str (List.rev dp) let pr_path sp = @@ -33,37 +34,26 @@ let pr_path sp = [] -> str sp.basename | sl -> pr_dirlist sl ++ str"." ++ str sp.basename -type library_objects - -type compilation_unit_name = dir_path - -type library_disk = { - md_name : compilation_unit_name; - md_compiled : Safe_typing.LightenLibrary.lightened_compiled_library; - md_objects : library_objects; - md_deps : (compilation_unit_name * Digest.t) list; - md_imports : compilation_unit_name list } - (************************************************************************) -(*s Modules on disk contain the following informations (after the magic - number, and before the digest). *) (*s Modules loaded in memory contain the following informations. They are kept in the global table [libraries_table]. *) type library_t = { - library_name : compilation_unit_name; - library_filename : System.physical_path; - library_compiled : Safe_typing.compiled_library; - library_deps : (compilation_unit_name * Digest.t) list; - library_digest : Digest.t } + library_name : Cic.compilation_unit_name; + library_filename : CUnix.physical_path; + library_compiled : Cic.compiled_library; + library_opaques : Cic.opaque_table; + library_deps : Cic.library_deps; + library_digest : Cic.vodigest; + library_extra_univs : Univ.constraints } module LibraryOrdered = struct - type t = dir_path + type t = DirPath.t let compare d1 d2 = Pervasives.compare - (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2)) + (List.rev (DirPath.repr d1)) (List.rev (DirPath.repr d2)) end module LibrarySet = Set.Make(LibraryOrdered) @@ -80,7 +70,7 @@ let find_library dir = let try_find_library dir = try find_library dir with Not_found -> - error ("Unknown library " ^ (string_of_dirpath dir)) + error ("Unknown library " ^ (DirPath.to_string dir)) let library_full_filename dir = (find_library dir).library_filename @@ -90,6 +80,29 @@ let library_full_filename dir = (find_library dir).library_filename let register_loaded_library m = libraries_table := LibraryMap.add m.library_name m !libraries_table +(* Map from library names to table of opaque terms *) +let opaque_tables = ref LibraryMap.empty +let opaque_univ_tables = ref LibraryMap.empty + +let access_opaque_table dp i = + let t = + try LibraryMap.find dp !opaque_tables + with Not_found -> assert false + in + assert (i < Array.length t); + Future.force t.(i) + +let access_opaque_univ_table dp i = + try + let t = LibraryMap.find dp !opaque_univ_tables in + assert (i < Array.length t); + Future.force t.(i) + with Not_found -> Univ.empty_constraint + + +let _ = Declarations.indirect_opaque_access := access_opaque_table +let _ = Declarations.indirect_opaque_univ_access := access_opaque_univ_table + let check_one_lib admit (dir,m) = let file = m.library_filename in let md = m.library_compiled in @@ -98,22 +111,23 @@ let check_one_lib admit (dir,m) = also check if it carries a validation certificate (yet to be implemented). *) if LibrarySet.mem dir admit then - (Flags.if_verbose msgnl + (Flags.if_verbose ppnl (str "Admitting library: " ++ pr_dirpath dir); - Safe_typing.unsafe_import file md dig) + Safe_typing.unsafe_import file md m.library_extra_univs dig) else - (Flags.if_verbose msgnl + (Flags.if_verbose ppnl (str "Checking library: " ++ pr_dirpath dir); - Safe_typing.import file md dig); - Flags.if_verbose msg(fnl()); + Safe_typing.import file md m.library_extra_univs dig); + Flags.if_verbose pp (fnl()); + pp_flush (); register_loaded_library m (*************************************************************************) (*s Load path. Mapping from physical to logical paths etc.*) -type logical_path = dir_path +type logical_path = DirPath.t -let load_paths = ref ([],[] : System.physical_path list * logical_path list) +let load_paths = ref ([],[] : CUnix.physical_path list * logical_path list) let get_load_paths () = fst !load_paths @@ -147,20 +161,23 @@ let canonical_path_name p = let find_logical_path phys_dir = let phys_dir = canonical_path_name phys_dir in - match list_filter2 (fun p d -> p = phys_dir) !load_paths with + let physical, logical = !load_paths in + match List.filter2 (fun p d -> p = phys_dir) physical logical with | _,[dir] -> dir | _,[] -> default_root_prefix - | _,l -> anomaly ("Two logical paths are associated to "^phys_dir) + | _,l -> anomaly (Pp.str ("Two logical paths are associated to "^phys_dir)) let remove_load_path dir = - load_paths := list_filter2 (fun p d -> p <> dir) !load_paths + let physical, logical = !load_paths in + load_paths := List.filter2 (fun p d -> p <> dir) physical logical let add_load_path (phys_path,coq_path) = if !Flags.debug then - msgnl (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++ + ppnl (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++ str phys_path); let phys_path = canonical_path_name phys_path in - match list_filter2 (fun p d -> p = phys_path) !load_paths with + let physical, logical = !load_paths in + match List.filter2 (fun p d -> p = phys_path) physical logical with | _,[dir] -> if coq_path <> dir (* If this is not the default -I . to coqtop *) @@ -171,7 +188,7 @@ let add_load_path (phys_path,coq_path) = begin (* Assume the user is concerned by library naming *) if dir <> default_root_prefix then - Flags.if_warn msg_warning + msg_warning (str phys_path ++ strbrk " was previously bound to " ++ pr_dirpath dir ++ strbrk "; it is remapped to " ++ pr_dirpath coq_path); @@ -180,10 +197,11 @@ let add_load_path (phys_path,coq_path) = end | _,[] -> load_paths := (phys_path :: fst !load_paths, coq_path :: snd !load_paths) - | _ -> anomaly ("Two logical paths are associated to "^phys_path) + | _ -> anomaly (Pp.str ("Two logical paths are associated to "^phys_path)) let load_paths_of_dir_path dir = - fst (list_filter2 (fun p d -> d = dir) !load_paths) + let physical, logical = !load_paths in + fst (List.filter2 (fun p d -> d = dir) physical logical) (************************************************************************) (*s Locate absolute or partially qualified library names in the path *) @@ -197,7 +215,7 @@ let locate_absolute_library dir = let loadpath = load_paths_of_dir_path pref in if loadpath = [] then raise LibUnmappedDir; try - let name = string_of_id base^".vo" in + let name = Id.to_string base^".vo" in let _, file = System.where_in_path ~warn:false loadpath name in (dir, file) with Not_found -> @@ -220,7 +238,7 @@ let locate_qualified_library qid = let name = qid.basename^".vo" in let path, file = System.where_in_path loadpath name in let dir = - extend_dirpath (find_logical_path path) (id_of_string qid.basename) in + extend_dirpath (find_logical_path path) (Id.of_string qid.basename) in (* Look if loaded *) try (dir, library_full_filename dir) @@ -228,28 +246,29 @@ let locate_qualified_library qid = (dir, file) with Not_found -> raise LibNotFound -let explain_locate_library_error qid = function - | LibUnmappedDir -> - let prefix = qid.dirpath in - errorlabstrm "load_absolute_library_from" - (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++ - str "no physical path bound to" ++ spc () ++ pr_dirlist prefix ++ fnl ()) - | LibNotFound -> - errorlabstrm "load_absolute_library_from" - (str"Cannot find library " ++ pr_path qid ++ str" in loadpath") - | e -> raise e +let error_unmapped_dir qid = + let prefix = qid.dirpath in + errorlabstrm "load_absolute_library_from" + (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++ + str "no physical path bound to" ++ spc () ++ pr_dirlist prefix ++ fnl ()) + +let error_lib_not_found qid = + errorlabstrm "load_absolute_library_from" + (str"Cannot find library " ++ pr_path qid ++ str" in loadpath") let try_locate_absolute_library dir = try locate_absolute_library dir - with e -> - explain_locate_library_error (path_of_dirpath dir) e + with + | LibUnmappedDir -> error_unmapped_dir (path_of_dirpath dir) + | LibNotFound -> error_lib_not_found (path_of_dirpath dir) let try_locate_qualified_library qid = try locate_qualified_library qid - with e -> - explain_locate_library_error qid e + with + | LibUnmappedDir -> error_unmapped_dir qid + | LibNotFound -> error_lib_not_found qid (************************************************************************) (*s Low-level interning/externing of libraries to files *) @@ -257,7 +276,7 @@ let try_locate_qualified_library qid = (*s Loading from disk to cache (preparation phase) *) let raw_intern_library = - snd (System.raw_extern_intern Coq_config.vo_magic_number ".vo") + snd (System.raw_extern_intern Coq_config.vo_magic_number) let with_magic_number_check f a = try f a @@ -270,12 +289,16 @@ let with_magic_number_check f a = (************************************************************************) (* Internalise libraries *) -let mk_library md f table digest = { +open Cic + +let mk_library md f table digest cst = { library_name = md.md_name; library_filename = f; - library_compiled = Safe_typing.LightenLibrary.load table md.md_compiled; + library_compiled = md.md_compiled; + library_opaques = table; library_deps = md.md_deps; - library_digest = digest } + library_digest = digest; + library_extra_univs = cst } let name_clash_message dir mdir f = str ("The file " ^ f ^ " contains library") ++ spc () ++ @@ -286,22 +309,56 @@ let name_clash_message dir mdir f = let depgraph = ref LibraryMap.empty let intern_from_file (dir, f) = - Flags.if_verbose msg (str"[intern "++str f++str" ..."); - let (md,table,digest) = + Flags.if_verbose pp (str"[intern "++str f++str" ..."); pp_flush (); + let (md,table,opaque_csts,digest) = try let ch = with_magic_number_check raw_intern_library f in - let (md:library_disk) = System.marshal_in f ch in - let digest = System.marshal_in f ch in - let table = (System.marshal_in f ch : Safe_typing.LightenLibrary.table) in - close_in ch; + let (md:Cic.library_disk), _, digest = System.marshal_in_segment f ch in + let (opaque_csts:'a option), _, udg = System.marshal_in_segment f ch in + let (discharging:'a option), _, _ = System.marshal_in_segment f ch in + let (tasks:'a option), _, _ = System.marshal_in_segment f ch in + let (table:Cic.opaque_table), pos, checksum = + System.marshal_in_segment f ch in + (* Verification of the final checksum *) + let () = close_in ch in + let ch = open_in f in + if not (String.equal (Digest.channel ch pos) checksum) then + errorlabstrm "intern_from_file" (str "Checksum mismatch"); + let () = close_in ch in if dir <> md.md_name then - errorlabstrm "load_physical_library" + errorlabstrm "intern_from_file" (name_clash_message dir md.md_name f); - Flags.if_verbose msgnl(str" done]"); - md,table,digest - with e -> Flags.if_verbose msgnl(str" failed!]"); raise e in + if tasks <> None || discharging <> None then + errorlabstrm "intern_from_file" + (str "The file "++str f++str " contains unfinished tasks"); + if opaque_csts <> None then begin + pp (str " (was a vio file) "); + Option.iter (fun (_,_,b) -> if not b then + errorlabstrm "intern_from_file" + (str "The file "++str f++str " is still a .vio")) + opaque_csts; + Validate.validate !Flags.debug Values.v_univopaques opaque_csts; + end; + (* Verification of the unmarshalled values *) + Validate.validate !Flags.debug Values.v_lib md; + Validate.validate !Flags.debug Values.v_opaques table; + Flags.if_verbose ppnl (str" done]"); pp_flush (); + let digest = + if opaque_csts <> None then Cic.Dviovo (digest,udg) + else (Cic.Dvo digest) in + md,table,opaque_csts,digest + with e -> Flags.if_verbose ppnl (str" failed!]"); raise e in depgraph := LibraryMap.add md.md_name md.md_deps !depgraph; - mk_library md f table digest + opaque_tables := LibraryMap.add md.md_name table !opaque_tables; + Option.iter (fun (opaque_csts,_,_) -> + opaque_univ_tables := + LibraryMap.add md.md_name opaque_csts !opaque_univ_tables) + opaque_csts; + let extra_cst = + Option.default Univ.empty_constraint + (Option.map (fun (_,cs,_) -> + Univ.ContextSet.constraints cs) opaque_csts) in + mk_library md f table digest extra_cst let get_deps (dir, f) = try LibraryMap.find dir !depgraph @@ -317,14 +374,15 @@ let rec intern_library seen (dir, f) needed = try let _ = find_library dir in needed with Not_found -> (* Look if already listed and consequently its dependencies too *) - if List.mem_assoc dir needed then needed + if List.mem_assoc_f DirPath.equal dir needed then needed else (* [dir] is an absolute name which matches [f] which must be in loadpath *) let m = intern_from_file (dir,f) in let seen' = LibrarySet.add dir seen in let deps = - List.map (fun (d,_) -> try_locate_absolute_library d) m.library_deps in - (dir,m) :: List.fold_right (intern_library seen') deps needed + Array.map (fun (d,_) -> try_locate_absolute_library d) m.library_deps + in + (dir,m) :: Array.fold_right (intern_library seen') deps needed (* Compute the reflexive transitive dependency closure *) let rec fold_deps seen ff (dir,f) (s,acc) = @@ -332,9 +390,9 @@ let rec fold_deps seen ff (dir,f) (s,acc) = if LibrarySet.mem dir s then (s,acc) else let deps = get_deps (dir,f) in - let deps = List.map (fun (d,_) -> try_locate_absolute_library d) deps in + let deps = Array.map (fun (d,_) -> try_locate_absolute_library d) deps in let seen' = LibrarySet.add dir seen in - let (s',acc') = List.fold_right (fold_deps seen' ff) deps (s,acc) in + let (s',acc') = Array.fold_right (fold_deps seen' ff) deps (s,acc) in (LibrarySet.add dir s', ff dir acc') and fold_deps_list seen ff modl needed = @@ -358,14 +416,14 @@ let recheck_library ~norec ~admit ~check = let nochk = List.fold_right LibrarySet.remove (List.map fst (nrl@ml)) nochk in (* *) - Flags.if_verbose msgnl (fnl()++hv 2 (str "Ordered list:" ++ fnl() ++ + Flags.if_verbose ppnl (fnl()++hv 2 (str "Ordered list:" ++ fnl() ++ prlist (fun (dir,_) -> pr_dirpath dir ++ fnl()) needed)); List.iter (check_one_lib nochk) needed; - Flags.if_verbose msgnl(str"Modules were successfully checked") + Flags.if_verbose ppnl (str"Modules were successfully checked") open Printf let mem s = let m = try_find_library s in - h 0 (str (sprintf "%dk" (size_kb m))) + h 0 (str (sprintf "%dk" (CObj.size_kb m))) diff --git a/checker/check.mllib b/checker/check.mllib index 08dd78bc..22df3756 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -1,22 +1,49 @@ Coq_config + +Hook +Canary +Hashset +Hashcons +CSet +CMap +Int +HMap +Option +Store +Exninfo +Backtrace +Flags +Control Pp_control +Loc +Serialize +Stateid +Feedback Pp -Compat -Flags Segmenttree Unicodetable +Unicode +Errors +CObj +CList +CString +CArray +CStack Util -Option -Hashcons +Ephemeron +Future +CUnix System +Profile +RemoteCounter Envars Predicate Rtree Names Univ Esubst -Validate Term +Print Declarations Environ Closure @@ -29,6 +56,8 @@ Indtypes Subtyping Mod_checking Safe_typing +Values +Validate Check Check_stat Checker diff --git a/checker/check_stat.ml b/checker/check_stat.ml index 145c191c..05a2a1b9 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -1,17 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Check.default_root_prefix - | dir -> make_dirpath (List.map id_of_string dir) + | dir -> DirPath.make (List.map Id.of_string dir) let path_of_string s = match parse_dir s with [] -> invalid_arg "path_of_string" | l::dir -> {dirpath=dir; basename=l} -let (/) = Filename.concat +let ( / ) = Filename.concat let get_version_date () = try - let coqlib = Envars.coqlib () in - let ch = open_in (Filename.concat coqlib "revision") in + let ch = open_in (Envars.coqlib () / "revision") in let ver = input_line ch in let rev = input_line ch in - (ver,rev) + let () = close_in ch in + (ver,rev) with _ -> (Coq_config.version,Coq_config.date) let print_header () = let (ver,rev) = (get_version_date ()) in - Printf.printf "Welcome to Chicken %s (%s)\n" ver rev; - flush stdout + Printf.printf "Welcome to Chicken %s (%s)\n" ver rev; + flush stdout (* Adding files to Coq loadpath *) @@ -65,20 +70,23 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = msg_warning (str ("Cannot open " ^ dir)) let convert_string d = - try id_of_string d - with _ -> - if_verbose warning - ("Directory "^d^" cannot be used as a Coq identifier (skipped)"); - flush_all (); - failwith "caught" + try Id.of_string d + with Errors.UserError _ -> + if_verbose msg_warning + (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)")); + raise Exit let add_rec_path ~unix_path ~coq_root = if exists_dir unix_path then let dirs = all_subdirs ~unix_path in - let prefix = repr_dirpath coq_root in - let convert_dirs (lp,cp) = - (lp,make_dirpath (List.map convert_string (List.rev cp)@prefix)) in - let dirs = map_succeed convert_dirs dirs in + let prefix = DirPath.repr coq_root in + let convert_dirs (lp, cp) = + try + let path = List.rev_map convert_string cp @ prefix in + Some (lp, Names.DirPath.make path) + with Exit -> None + in + let dirs = List.map_filter convert_dirs dirs in List.iter Check.add_load_path dirs; Check.add_load_path (unix_path, coq_root) else @@ -107,14 +115,15 @@ let init_load_path () = let plugins = coqlib/"plugins" in (* NOTE: These directories are searched from last to first *) (* first standard library *) - add_rec_path ~unix_path:(coqlib/"theories") ~coq_root:(Names.make_dirpath[coq_root]); + add_rec_path ~unix_path:(coqlib/"theories") ~coq_root:(Names.DirPath.make[coq_root]); (* then plugins *) - add_rec_path ~unix_path:plugins ~coq_root:(Names.make_dirpath [coq_root]); + add_rec_path ~unix_path:plugins ~coq_root:(Names.DirPath.make [coq_root]); (* then user-contrib *) if Sys.file_exists user_contrib then add_rec_path ~unix_path:user_contrib ~coq_root:Check.default_root_prefix; (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *) - List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) xdg_dirs; + List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) + (xdg_dirs ~warn:(fun x -> msg_warning (str x))); (* then directories in COQPATH *) List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) coqpath; (* then current directory *) @@ -208,10 +217,10 @@ let anomaly_string () = str "Anomaly: " let report () = (str "." ++ spc () ++ str "Please report.") let print_loc loc = - if loc = dummy_loc then + if loc = Loc.ghost then (str"") else - let loc = unloc loc in + let loc = Loc.unloc loc in (int (fst loc) ++ str"-" ++ int (snd loc)) let guill s = "\""^s^"\"" @@ -223,8 +232,6 @@ let rec explain_exn = function hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.") | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt) - | Token.Error txt -> - hov 0 (str "Syntax error: " ++ str txt) | Sys_error msg -> hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report() ) | UserError(s,pps) -> @@ -233,8 +240,6 @@ let rec explain_exn = function hov 0 (str "Out of memory") | Stack_overflow -> hov 0 (str "Stack overflow") - | Anomaly (s,pps) -> - hov 1 (anomaly_string () ++ where s ++ pps ++ report ()) | Match_failure(filename,pos1,pos2) -> hov 1 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ str " at line " ++ int pos1 ++ @@ -250,26 +255,57 @@ let rec explain_exn = function | Univ.UniverseInconsistency (o,u,v) -> let msg = if !Flags.debug (*!Constrextern.print_universes*) then - spc() ++ str "(cannot enforce" ++ spc() ++ (*Univ.pr_uni u ++*) spc() ++ + spc() ++ str "(cannot enforce" ++ spc() ++ Univ.pr_uni u ++ spc() ++ str (match o with Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=") - ++ spc() ++ (*Univ.pr_uni v ++*) str")" + ++ spc() ++ Univ.pr_uni v ++ str")" else mt() in hov 0 (str "Error: Universe inconsistency" ++ msg ++ str ".") | TypeError(ctx,te) -> -(* hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx *) - (* te)*) - hov 0 (str "Type error") + hov 0 (str "Type error: " ++ + (match te with + | UnboundRel i -> str"UnboundRel " ++ int i + | UnboundVar v -> str"UnboundVar" ++ str(Names.Id.to_string v) + | NotAType _ -> str"NotAType" + | BadAssumption _ -> str"BadAssumption" + | ReferenceVariables _ -> str"ReferenceVariables" + | ElimArity _ -> str"ElimArity" + | CaseNotInductive _ -> str"CaseNotInductive" + | WrongCaseInfo _ -> str"WrongCaseInfo" + | NumberBranches _ -> str"NumberBranches" + | IllFormedBranch _ -> str"IllFormedBranch" + | Generalization _ -> str"Generalization" + | ActualType _ -> str"ActualType" + | CantApplyBadType ((n,a,b),(hd,hdty),args) -> + Format.printf "====== ill-typed term ====@\n"; + Format.printf "@[application head=@ "; + Print.print_pure_constr hd; + Format.printf "@]@\n@[head type=@ "; + Print.print_pure_constr hdty; + Format.printf "@]@\narguments:@\n@["; + Array.iteri (fun i (t,ty) -> + Format.printf "@[arg %d=@ " (i+1); + Print.print_pure_constr t; + Format.printf "@ type=@ "; + Print.print_pure_constr ty) args; + Format.printf "@]@\n====== type error ====@\n"; + Print.print_pure_constr b; + Format.printf "@\nis not convertible with@\n"; + Print.print_pure_constr a; + Format.printf "@\n====== universes ====@\n"; + Pp.pp (Univ.pr_universes + (ctx.Environ.env_stratification.Environ.env_universes)); + str("\nCantApplyBadType at argument " ^ string_of_int n) + | CantApplyNonFunctional _ -> str"CantApplyNonFunctional" + | IllFormedRecBody _ -> str"IllFormedRecBody" + | IllTypedRecBody _ -> str"IllTypedRecBody" + | UnsatisfiedConstraints _ -> str"UnsatisfiedConstraints")) | Indtypes.InductiveError e -> hov 0 (str "Error related to inductive types") (* let ctx = Check.get_env() in hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error ctx e)*) - | Loc.Exc_located (loc,exc) -> - hov 0 ((if loc = dummy_loc then (mt ()) - else (str"At location " ++ print_loc loc ++ str":" ++ fnl ())) - ++ explain_exn exc) | Assert_failure (s,b,e) -> hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++ (if s = "" then mt () @@ -278,19 +314,17 @@ let rec explain_exn = function str ", characters " ++ int e ++ str "-" ++ int (e+6) ++ str ")")) ++ report ()) - | reraise -> - hov 0 (anomaly_string () ++ str "Uncaught exception " ++ - str (Printexc.to_string reraise)++report()) + | e -> Errors.print e (* for anomalies and other uncaught exceptions *) let parse_args argv = let rec parse = function | [] -> () | "-impredicative-set" :: rem -> - set_engagement Declarations.ImpredicativeSet; parse rem + set_engagement Cic.ImpredicativeSet; parse rem | "-coqlib" :: s :: rem -> if not (exists_dir s) then - (msgnl (str ("Directory '"^s^"' does not exist")); exit 1); + fatal_error (str ("Directory '"^s^"' does not exist")) false; Flags.coqlib := s; Flags.coqlib_spec := true; parse rem @@ -308,7 +342,9 @@ let parse_args argv = | "-debug" :: rem -> set_debug (); parse rem | "-where" :: _ -> - print_endline (Envars.coqlib ()); exit 0 + Envars.set_coqlib ~fail:Errors.error; + print_endline (Envars.coqlib ()); + exit 0 | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () @@ -318,8 +354,6 @@ let parse_args argv = | ("-o" | "--output-context") :: rem -> Check_stat.output_context := true; parse rem - | "-no-hash-consing" :: rem -> Flags.hash_cons_proofs := false; parse rem - | "-admit" :: s :: rem -> add_admit s; parse rem | "-admit" :: [] -> usage () @@ -330,19 +364,10 @@ let parse_args argv = Flags.make_silent true; parse rem | s :: _ when s<>"" && s.[0]='-' -> - msgnl (str "Unknown option " ++ str s); exit 1 + fatal_error (str "Unknown option " ++ str s) false | s :: rem -> add_compile s; parse rem in - try - parse (List.tl (Array.to_list argv)) - with - | UserError(_,s) as e -> begin - try - Stream.empty s; exit 1 - with Stream.Failure -> - msgnl (explain_exn e); exit 1 - end - | e -> begin msgnl (explain_exn e); exit 1 end + parse (List.tl (Array.to_list argv)) (* To prevent from doing the initialization twice *) @@ -354,14 +379,13 @@ let init_with_argv argv = Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) try parse_args argv; + if !Flags.debug then Printexc.record_backtrace true; + Envars.set_coqlib ~fail:Errors.error; if_verbose print_header (); init_load_path (); engage (); with e -> - flush_all(); - message "Error during initialization :"; - msgnl (explain_exn e); - exit 1 + fatal_error (str "Error during initialization :" ++ (explain_exn e)) (is_anomaly e) end let init() = init_with_argv Sys.argv @@ -371,9 +395,7 @@ let run () = compile_files (); flush_all() with e -> - (flush_all(); - Pp.ppnl(explain_exn e); - flush_all(); - exit 1) + if !Flags.debug then Printexc.print_backtrace stderr; + fatal_error (explain_exn e) (is_anomaly e) let start () = init(); run(); Check_stat.stats(); exit 0 diff --git a/checker/cic.mli b/checker/cic.mli new file mode 100644 index 00000000..a793fefa --- /dev/null +++ b/checker/cic.mli @@ -0,0 +1,444 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* red_kind - val fVAR : identifier -> red_kind + val fVAR : Id.t -> red_kind val no_red : reds val red_add : reds -> red_kind -> reds val mkflags : red_kind list -> reds @@ -85,7 +86,7 @@ module RedFlags = (struct r_iota : bool } type red_kind = BETA | DELTA | IOTA | ZETA - | CONST of constant | VAR of identifier + | CONST of constant | VAR of Id.t let fBETA = BETA let fDELTA = DELTA let fIOTA = IOTA @@ -110,7 +111,7 @@ module RedFlags = (struct | ZETA -> { red with r_zeta = true } | VAR id -> let (l1,l2) = red.r_const in - { red with r_const = Idpred.add id l1, l2 } + { red with r_const = Id.Pred.add id l1, l2 } let mkflags = List.fold_left red_add no_red @@ -122,7 +123,7 @@ module RedFlags = (struct incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) let (l,_) = red.r_const in - let c = Idpred.mem id l in + let c = Id.Pred.mem id l in incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | IOTA -> incr_cnt red.r_iota iota @@ -150,7 +151,6 @@ let betaiotazeta = mkflags [fBETA;fIOTA;fZETA] * is stored in the table. * * i_rels = (4,[(1,c);(3,d)]) means there are 4 free rel variables * and only those with index 1 and 3 have bodies which are c and d resp. - * * i_vars is the list of _defined_ named variables. * * ref_value_cache searchs in the tab, otherwise uses i_repr to * compute the result and store it in the table. If the constant can't @@ -160,49 +160,60 @@ let betaiotazeta = mkflags [fBETA;fIOTA;fZETA] * instantiations (cbv or lazy) are. *) -type table_key = - | ConstKey of constant - | VarKey of identifier +type 'a tableKey = + | ConstKey of 'a + | VarKey of Id.t | RelKey of int +type table_key = constant puniverses tableKey + +module KeyHash = +struct + type t = table_key + let equal k1 k2 = match k1, k2 with + | ConstKey (c1,u1), ConstKey (c2,u2) -> Constant.UserOrd.equal c1 c2 + && Univ.Instance.equal u1 u2 + | VarKey id1, VarKey id2 -> Id.equal id1 id2 + | RelKey i1, RelKey i2 -> Int.equal i1 i2 + | (ConstKey _ | VarKey _ | RelKey _), _ -> false + + open Hashset.Combine + + let hash = function + | ConstKey (c,u) -> combinesmall 1 (Constant.UserOrd.hash c) + | VarKey id -> combinesmall 2 (Id.hash id) + | RelKey i -> combinesmall 3 (Int.hash i) +end + +module KeyTable = Hashtbl.Make(KeyHash) + type 'a infos = { i_flags : reds; i_repr : 'a infos -> constr -> 'a; i_env : env; i_rels : int * (int * constr) list; - i_vars : (identifier * constr) list; - i_tab : (table_key, 'a) Hashtbl.t } + i_tab : 'a KeyTable.t } let ref_value_cache info ref = try - Some (Hashtbl.find info.i_tab ref) + Some (KeyTable.find info.i_tab ref) with Not_found -> try let body = match ref with | RelKey n -> - let (s,l) = info.i_rels in lift n (List.assoc (s-n) l) - | VarKey id -> List.assoc id info.i_vars + let (s,l) = info.i_rels in lift n (Int.List.assoc (s-n) l) + | VarKey id -> raise Not_found | ConstKey cst -> constant_value info.i_env cst in let v = info.i_repr info body in - Hashtbl.add info.i_tab ref v; + KeyTable.add info.i_tab ref v; Some v with | Not_found (* List.assoc *) | NotEvaluableConst _ (* Const *) -> None -let defined_vars flags env = -(* if red_local_const (snd flags) then*) - fold_named_context - (fun (id,b,_) e -> - match b with - | None -> e - | Some body -> (id, body)::e) - (named_context env) ~init:[] -(* else []*) - let defined_rels flags env = (* if red_local_const (snd flags) then*) fold_rel_context @@ -215,18 +226,14 @@ let defined_rels flags env = let mind_equiv_infos info = mind_equiv info.i_env -let eq_table_key k1 k2 = - match k1,k2 with - | ConstKey con1 ,ConstKey con2 -> eq_con_chk con1 con2 - | _,_ -> k1=k2 +let eq_table_key = KeyHash.equal let create mk_cl flgs env = { i_flags = flgs; i_repr = mk_cl; i_env = env; i_rels = defined_rels flgs env; - i_vars = defined_vars flgs env; - i_tab = Hashtbl.create 17 } + i_tab = KeyTable.create 17 } (**********************************************************************) @@ -266,16 +273,18 @@ and fterm = | FAtom of constr (* Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key - | FInd of inductive - | FConstruct of constructor + | FInd of pinductive + | FConstruct of pconstructor | FApp of fconstr * fconstr array + | FProj of constant * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCases of case_info * fconstr * fconstr * fconstr array + | FCase of case_info * fconstr * fconstr * fconstr array + | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (name * constr) list * constr * fconstr subs | FProd of name * fconstr * fconstr | FLetIn of name * fconstr * fconstr * constr * fconstr subs - | FEvar of existential_key * fconstr array + | FEvar of existential_key * fconstr array (* why diff from kernel/closure? *) | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED @@ -298,6 +307,8 @@ let update v1 (no,t) = type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array + | ZcaseT of case_info * constr * constr array * fconstr subs + | Zproj of int * int * constant | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -357,81 +368,14 @@ let compact_stack head stk = (* Put an update mark in the stack, only if needed *) let zupdate m s = - if !share & m.norm = Red + if !share && m.norm = Red then let s' = compact_stack m s in let _ = m.term <- FLOCKED in Zupdate(m)::s' else s -(* Closure optimization: *) -let rec compact_constr (lg, subs as s) c k = - match c with - Rel i -> - if i < k then c,s else - (try Rel (k + lg - list_index (i-k+1) subs), (lg,subs) - with Not_found -> Rel (k+lg), (lg+1, (i-k+1)::subs)) - | (Sort _|Var _|Meta _|Ind _|Const _|Construct _) -> c,s - | Evar(ev,v) -> - let (v',s) = compact_vect s v k in - if v==v' then c,s else Evar(ev,v'),s - | Cast(a,ck,b) -> - let (a',s) = compact_constr s a k in - let (b',s) = compact_constr s b k in - if a==a' && b==b' then c,s else Cast(a', ck, b'), s - | App(f,v) -> - let (f',s) = compact_constr s f k in - let (v',s) = compact_vect s v k in - if f==f' && v==v' then c,s else App(f',v'), s - | Lambda(n,a,b) -> - let (a',s) = compact_constr s a k in - let (b',s) = compact_constr s b (k+1) in - if a==a' && b==b' then c,s else Lambda(n,a',b'), s - | Prod(n,a,b) -> - let (a',s) = compact_constr s a k in - let (b',s) = compact_constr s b (k+1) in - if a==a' && b==b' then c,s else Prod(n,a',b'), s - | LetIn(n,a,ty,b) -> - let (a',s) = compact_constr s a k in - let (ty',s) = compact_constr s ty k in - let (b',s) = compact_constr s b (k+1) in - if a==a' && ty==ty' && b==b' then c,s else LetIn(n,a',ty',b'), s - | Fix(fi,(na,ty,bd)) -> - let (ty',s) = compact_vect s ty k in - let (bd',s) = compact_vect s bd (k+Array.length ty) in - if ty==ty' && bd==bd' then c,s else Fix(fi,(na,ty',bd')), s - | CoFix(i,(na,ty,bd)) -> - let (ty',s) = compact_vect s ty k in - let (bd',s) = compact_vect s bd (k+Array.length ty) in - if ty==ty' && bd==bd' then c,s else CoFix(i,(na,ty',bd')), s - | Case(ci,p,a,br) -> - let (p',s) = compact_constr s p k in - let (a',s) = compact_constr s a k in - let (br',s) = compact_vect s br k in - if p==p' && a==a' && br==br' then c,s else Case(ci,p',a',br'),s -and compact_vect s v k = compact_v [] s v k (Array.length v - 1) -and compact_v acc s v k i = - if i < 0 then - let v' = Array.of_list acc in - if array_for_all2 (==) v v' then v,s else v',s - else - let (a',s') = compact_constr s v.(i) k in - compact_v (a'::acc) s' v k (i-1) - -(* Computes the minimal environment of a closure. - Idea: if the subs is not identity, the term will have to be - reallocated entirely (to propagate the substitution). So, - computing the set of free variables does not change the - complexity. *) -let optimise_closure env c = - if is_subs_id env then (env,c) else - let (c',(_,s)) = compact_constr (0,[]) c 1 in - let env' = - Array.map (fun i -> clos_rel env i) (Array.of_list s) in - (subs_cons (env', subs_id 0),c') - let mk_lambda env t = - let (env,t) = optimise_closure env t in let (rvars,t') = decompose_lam t in FLambda(List.length rvars, List.rev rvars, t', env) @@ -452,7 +396,7 @@ let mk_clos e t = | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } | Ind kn -> { norm = Norm; term = FInd kn } | Construct kn -> { norm = Cstr; term = FConstruct kn } - | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _) -> + | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) -> {norm = Red; term = FCLOS(t,e)} let mk_clos_vect env v = Array.map (mk_clos env) v @@ -471,10 +415,11 @@ let mk_clos_deep clos_fun env t = | App (f,v) -> { norm = Red; term = FApp (clos_fun env f, Array.map (clos_fun env) v) } + | Proj (p,c) -> + { norm = Red; + term = FProj (p, clos_fun env c) } | Case (ci,p,c,v) -> - { norm = Red; - term = FCases (ci, clos_fun env p, clos_fun env c, - Array.map (clos_fun env) v) } + { norm = Red; term = FCaseT (ci, p, clos_fun env c, v, env) } | Fix fx -> { norm = Cstr; term = FFix (fx, env) } | CoFix cfx -> @@ -505,10 +450,13 @@ let rec to_constr constr_fun lfts v = | FFlex (ConstKey op) -> Const op | FInd op -> Ind op | FConstruct op -> Construct op - | FCases (ci,p,c,ve) -> + | FCase (ci,p,c,ve) -> Case (ci, constr_fun lfts p, constr_fun lfts c, Array.map (constr_fun lfts) ve) + | FCaseT (ci,p,c,ve,e) -> (* TODO: enable sharing, cf FCLOS below ? *) + to_constr constr_fun lfts + {norm=Red;term=FCase(ci,mk_clos2 e p,c,mk_clos_vect e ve)} | FFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in let ftys = Array.map (mk_clos e) tys in @@ -526,6 +474,8 @@ let rec to_constr constr_fun lfts v = | FApp (f,ve) -> App (constr_fun lfts f, Array.map (constr_fun lfts) ve) + | FProj (p,c) -> + Proj (p,constr_fun lfts c) | FLambda _ -> let (na,ty,bd) = destFLambda mk_clos2 v in Lambda (na, constr_fun lfts ty, @@ -544,7 +494,7 @@ let rec to_constr constr_fun lfts v = let fr = mk_clos2 env t in let unfv = update v (fr.norm,fr.term) in to_constr constr_fun lfts unfv - | FLOCKED -> assert false (*mkVar(id_of_string"_LOCK_")*) + | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) (* This function defines the correspondance between constr and fconstr. When we find a closure whose substitution is the identity, @@ -553,11 +503,13 @@ let rec to_constr constr_fun lfts v = let term_of_fconstr = let rec term_of_fconstr_lift lfts v = match v.term with - | FCLOS(t,env) when is_subs_id env & is_lift_id lfts -> t - | FLambda(_,tys,f,e) when is_subs_id e & is_lift_id lfts -> + | FCLOS(t,env) when is_subs_id env && is_lift_id lfts -> t + | FLambda(_,tys,f,e) when is_subs_id e && is_lift_id lfts -> compose_lam (List.rev tys) f - | FFix(fx,e) when is_subs_id e & is_lift_id lfts -> Fix fx - | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> CoFix cfx + | FCaseT(ci,p,c,b,env) when is_subs_id env && is_lift_id lfts -> + Case(ci,p,term_of_fconstr_lift lfts c,b) + | FFix(fx,e) when is_subs_id e && is_lift_id lfts -> Fix fx + | FCoFix(cfx,e) when is_subs_id e && is_lift_id lfts -> CoFix cfx | _ -> to_constr term_of_fconstr_lift lfts v in term_of_fconstr_lift el_id @@ -575,8 +527,13 @@ let rec zip m stk = | [] -> m | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s | Zcase(ci,p,br)::s -> - let t = FCases(ci, p, m, br) in + let t = FCase(ci, p, m, br) in + zip {norm=neutr m.norm; term=t} s + | ZcaseT(ci,p,br,e)::s -> + let t = FCaseT(ci, p, m, br, e) in zip {norm=neutr m.norm; term=t} s + | Zproj (i,j,cst) :: s -> + zip {norm=neutr m.norm; term=FProj (cst,m)} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> @@ -647,13 +604,14 @@ let rec get_args n tys f e stk = let eargs = Array.sub l n (na-n) in (Inl (subs_cons(args,e)), Zapp eargs :: s) else (* more lambdas *) - let etys = list_skipn na tys in + let etys = List.skipn na tys in get_args (n-na) etys f (subs_cons(l,e)) s | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function - | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s -> + | (Zapp _ | Zfix _ | Zcase _ | ZcaseT _ | Zproj _ + | Zshift _ | Zupdate _ as e) :: s -> e :: eta_expand_stack s | [] -> [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] @@ -670,18 +628,69 @@ let rec reloc_rargs_rec depth stk = let reloc_rargs depth stk = if depth = 0 then stk else reloc_rargs_rec depth stk -let rec drop_parameters depth n stk = - match stk with +let rec try_drop_parameters depth n argstk = + match argstk with Zapp args::s -> let q = Array.length args in - if n > q then drop_parameters depth (n-q) s - else if n = q then reloc_rargs depth s + if n > q then try_drop_parameters depth (n-q) s + else if Int.equal n q then reloc_rargs depth s else let aft = Array.sub args n (q-n) in reloc_rargs depth (append_stack aft s) - | Zshift(k)::s -> drop_parameters (depth-k) n s - | [] -> assert (n=0); [] - | _ -> assert false (* we know that n < stack_args_size(stk) *) + | Zshift(k)::s -> try_drop_parameters (depth-k) n s + | [] -> + if Int.equal n 0 then [] + else raise Not_found + | _ -> assert false + (* strip_update_shift_app only produces Zapp and Zshift items *) + +let drop_parameters depth n argstk = + try try_drop_parameters depth n argstk + with Not_found -> assert false + (* we know that n < stack_args_size(argstk) (if well-typed term) *) + +(** Projections and eta expansion *) + +let rec get_parameters depth n argstk = + match argstk with + Zapp args::s -> + let q = Array.length args in + if n > q then Array.append args (get_parameters depth (n-q) s) + else if Int.equal n q then [||] + else Array.sub args 0 n + | Zshift(k)::s -> + get_parameters (depth-k) n s + | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *) + if Int.equal n 0 then [||] + else raise Not_found (* Trying to eta-expand a partial application..., should do + eta expansion first? *) + | _ -> assert false + (* strip_update_shift_app only produces Zapp and Zshift items *) + +let eta_expand_ind_stack env ind m s (f, s') = + let mib = lookup_mind (fst ind) env in + match mib.mind_record with + | Some (Some (_,projs,pbs)) when mib.mind_finite <> CoFinite -> + (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> + arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) + let pars = mib.mind_nparams in + let right = fapp_stack (f, s') in + let (depth, args, s) = strip_update_shift_app m s in + (** Try to drop the params, might fail on partially applied constructors. *) + let argss = try_drop_parameters depth pars args in + let hstack = Array.map (fun p -> { norm = Red; (* right can't be a constructor though *) + term = FProj (p, right) }) projs in + argss, [Zapp hstack] + | _ -> raise Not_found (* disallow eta-exp for non-primitive records *) + +let rec project_nth_arg n argstk = + match argstk with + | Zapp args :: s -> + let q = Array.length args in + if n >= q then project_nth_arg (n - q) s + else (* n < q *) args.(n) + | _ -> assert false + (* After drop_parameters we have a purely applicative stack *) (* Iota reduction: expansion of a fixpoint. @@ -714,33 +723,42 @@ let contract_fix_vect fix = atom or a subterm that may produce a redex (abstraction, constructor, cofix, letin, constant), or a neutral term (product, inductive) *) -let rec knh m stk = +let rec knh info m stk = match m.term with - | FLIFT(k,a) -> knh a (zshift k stk) - | FCLOS(t,e) -> knht e t (zupdate m stk) + | FLIFT(k,a) -> knh info a (zshift k stk) + | FCLOS(t,e) -> knht info e t (zupdate m stk) | FLOCKED -> assert false - | FApp(a,b) -> knh a (append_stack b (zupdate m stk)) - | FCases(ci,p,t,br) -> knh t (Zcase(ci,p,br)::zupdate m stk) + | FApp(a,b) -> knh info a (append_stack b (zupdate m stk)) + | FCase(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk) + | FCaseT(ci,p,t,br,env) -> knh info t (ZcaseT(ci,p,br,env)::zupdate m stk) | FFix(((ri,n),(_,_,_)),_) -> (match get_nth_arg m ri.(n) stk with - (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk') + (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) - | FCast(t,_,_) -> knh t stk + | FCast(t,_,_) -> knh info t stk + + | FProj (p,c) -> + if red_set info.i_flags (fCONST p) then + (let pb = lookup_projection p (info.i_env) in + knh info c (Zproj (pb.proj_npars, pb.proj_arg, p) + :: zupdate m stk)) + else (m,stk) + (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> (m, stk) (* The same for pure terms *) -and knht e t stk = +and knht info e t stk = match t with | App(a,b) -> - knht e a (append_stack (mk_clos_vect e b) stk) - | Case(ci,p,t,br) -> - knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) - | Fix _ -> knh (mk_clos2 e t) stk - | Cast(a,_,_) -> knht e a stk - | Rel n -> knh (clos_rel e n) stk + knht info e a (append_stack (mk_clos_vect e b) stk) + | Case(ci,p,t,br) -> knht info e t (ZcaseT(ci, p, br, e)::stk) + | Fix _ -> knh info (mk_clos2 e t) stk (* laziness *) + | Cast(a,_,_) -> knht info e a stk + | Rel n -> knh info (clos_rel e n) stk + | Proj (p,c) -> knh info (mk_clos2 e t) stk (* laziness *) | (Lambda _|Prod _|Construct _|CoFix _|Ind _| LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> (mk_clos2 e t, stk) @@ -755,7 +773,7 @@ let rec knr info m stk = (match get_args n tys f e stk with Inl e', s -> knit info e' f s | Inr lam, s -> (lam,s)) - | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) -> + | FFlex(ConstKey kn) when red_set info.i_flags (fCONST (fst kn)) -> (match ref_value_cache info (ConstKey kn) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) @@ -767,21 +785,29 @@ let rec knr info m stk = (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 -> + | FConstruct((ind,c),u) when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with (depth, args, Zcase(ci,_,br)::s) -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in kni info br.(c-1) (rargs@s) - | (_, cargs, Zfix(fx,par)::s) -> + | (depth, args, ZcaseT(ci,_,br,env)::s) -> + assert (ci.ci_npar>=0); + let rargs = drop_parameters depth ci.ci_npar args in + knit info env br.(c-1) (rargs@s) + | (_, cargs, Zfix(fx,par)::s) -> let rarg = fapp_stack(m,cargs) in let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info fxe fxbd stk' - | (_,args,s) -> (m,args@s)) + | (depth, args, Zproj (n, m, cst)::s) -> + let rargs = drop_parameters depth n args in + let rarg = project_nth_arg m rargs in + kni info rarg s + | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with - (_, args, ((Zcase _::_) as stk')) -> + (_, args, (((Zcase _|ZcaseT _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info fxe fxbd (args@stk') | (_,args,s) -> (m,args@s)) @@ -791,10 +817,10 @@ let rec knr info m stk = (* Computes the weak head normal form of a term *) and kni info m stk = - let (hm,s) = knh m stk in + let (hm,s) = knh info m stk in knr info hm s and knit info e t stk = - let (ht,s) = knht e t stk in + let (ht,s) = knht info e t stk in knr info ht s let kh info v stk = fapp_stack(kni info v stk) @@ -816,6 +842,9 @@ let whd_stack infos m stk = (* cache of constants: the body is computed only when needed. *) type clos_infos = fconstr infos +let infos_env x = x.i_env +let infos_flags x = x.i_flags + let create_clos_infos flgs env = create (fun _ -> inject) flgs env diff --git a/checker/closure.mli b/checker/closure.mli index e072a106..e6b39250 100644 --- a/checker/closure.mli +++ b/checker/closure.mli @@ -1,15 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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 * Cpred.t +type transparent_state = Id.Pred.t * Cpred.t val all_opaque : transparent_state val all_transparent : transparent_state @@ -44,7 +43,7 @@ module type RedFlagsSig = sig val fIOTA : red_kind val fZETA : red_kind val fCONST : constant -> red_kind - val fVAR : identifier -> red_kind + val fVAR : Id.t -> red_kind (* No reduction at all *) val no_red : reds @@ -67,11 +66,13 @@ val betaiotazeta : reds val betadeltaiotanolet : reds (***********************************************************************) -type table_key = - | ConstKey of constant - | VarKey of identifier +type 'a tableKey = + | ConstKey of 'a + | VarKey of Id.t | RelKey of int +type table_key = constant puniverses tableKey + type 'a infos val ref_value_cache: 'a infos -> table_key -> 'a option val create: ('a infos -> constr -> 'a) -> reds -> env -> 'a infos @@ -91,12 +92,14 @@ type fterm = | FAtom of constr (* Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key - | FInd of inductive - | FConstruct of constructor + | FInd of pinductive + | FConstruct of pconstructor | FApp of fconstr * fconstr array + | FProj of constant * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCases of case_info * fconstr * fconstr * fconstr array + | FCase of case_info * fconstr * fconstr * fconstr array + | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (name * constr) list * constr * fconstr subs | FProd of name * fconstr * fconstr | FLetIn of name * fconstr * fconstr * constr * fconstr subs @@ -113,6 +116,8 @@ type fterm = type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array + | ZcaseT of case_info * constr * constr array * fconstr subs + | Zproj of int * int * constant | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -121,6 +126,9 @@ and stack = stack_member list val append_stack : fconstr array -> stack -> stack val eta_expand_stack : stack -> stack + +val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> + (fconstr * stack) -> stack * stack (* To lazy reduce a constr, create a [clos_infos] with [create_clos_infos], inject the term to reduce with [inject]; then use @@ -136,6 +144,8 @@ val destFLambda : (* Global and local constant cache *) type clos_infos val create_clos_infos : reds -> env -> clos_infos +val infos_env : clos_infos -> env +val infos_flags : clos_infos -> reds (* Reduction function *) @@ -172,6 +182,5 @@ val kni: clos_infos -> fconstr -> stack -> fconstr * stack val knr: clos_infos -> fconstr -> stack -> fconstr * stack val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr -val optimise_closure : fconstr subs -> constr -> fconstr subs * constr (* End of cbn debug section i*) diff --git a/checker/declarations.ml b/checker/declarations.ml index 890996d1..c6709a78 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -1,44 +1,14 @@ open Util open Names +open Cic open Term -open Validate - -(* Bytecode *) -type values -type reloc_table -type to_patch_substituted -(*Retroknowledge *) -type action -type retroknowledge - -type engagement = ImpredicativeSet -let val_eng = val_enum "eng" 1 - - -type polymorphic_arity = { - poly_param_levels : Univ.universe option list; - poly_level : Univ.universe; -} -let val_pol_arity = - val_tuple ~name:"polyorphic_arity"[|val_list(val_opt val_univ);val_univ|] - -type constant_type = - | NonPolymorphicType of constr - | PolymorphicArity of rel_context * polymorphic_arity - -let val_cst_type = - val_sum "constant_type" 0 [|[|val_constr|];[|val_rctxt;val_pol_arity|]|] (** Substitutions, code imported from kernel/mod_subst *) -type delta_hint = - | Inline of int * constr option - | Equiv of kernel_name - - module Deltamap = struct - type t = module_path MPmap.t * delta_hint KNmap.t + type t = delta_resolver let empty = MPmap.empty, KNmap.empty + let is_empty (mm, km) = MPmap.is_empty mm && KNmap.is_empty km let add_kn kn hint (mm,km) = (mm,KNmap.add kn hint km) let add_mp mp mp' (mm,km) = (MPmap.add mp mp' mm, km) let remove_mp mp (mm,km) = (MPmap.remove mp mm, km) @@ -52,18 +22,10 @@ module Deltamap = struct let join map1 map2 = fold add_mp add_kn map1 map2 end -type delta_resolver = Deltamap.t - let empty_delta_resolver = Deltamap.empty -module MBImap = Map.Make - (struct - type t = mod_bound_id - let compare = Pervasives.compare - end) - module Umap = struct - type 'a t = 'a MPmap.t * 'a MBImap.t + type 'a t = 'a umap_t let empty = MPmap.empty, MBImap.empty let is_empty (m1,m2) = MPmap.is_empty m1 && MBImap.is_empty m2 let add_mbi mbi x (m1,m2) = (m1,MBImap.add mbi x m2) @@ -78,29 +40,12 @@ module Umap = struct let join map1 map2 = fold add_mp add_mbi map1 map2 end -type substitution = (module_path * delta_resolver) Umap.t type 'a subst_fun = substitution -> 'a -> 'a let empty_subst = Umap.empty let is_empty_subst = Umap.is_empty -let val_delta_hint = - val_sum "delta_hint" 0 - [|[|val_int; val_opt val_constr|];[|val_kn|]|] - -let val_res = - val_tuple ~name:"delta_resolver" - [|val_map ~name:"delta_resolver" val_mp val_mp; - val_map ~name:"delta_resolver" val_kn val_delta_hint|] - -let val_mp_res = val_tuple [|val_mp;val_res|] - -let val_subst = - val_tuple ~name:"substitution" - [|val_map ~name:"substitution" val_mp val_mp_res; - val_map ~name:"substitution" val_uid val_mp_res|] - let add_mbid mbid mp = Umap.add_mbi mbid (mp,empty_delta_resolver) let add_mp mp1 mp2 = Umap.add_mp mp1 (mp2,empty_delta_resolver) @@ -110,7 +55,7 @@ let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst let mp_in_delta mp = Deltamap.mem_mp mp -let rec find_prefix resolve mp = +let find_prefix resolve mp = let rec sub_mp = function | MPdot(mp,l) as mp_sup -> (try Deltamap.find_mp mp_sup resolve @@ -136,10 +81,8 @@ let solve_delta_kn resolve kn = make_kn new_mp dir l let gen_of_delta resolve x kn fix_can = - try - let new_kn = solve_delta_kn resolve kn in - if kn == new_kn then x else fix_can new_kn - with _ -> x + let new_kn = solve_delta_kn resolve kn in + if kn == new_kn then x else fix_can new_kn let constant_of_delta resolve con = let kn = user_con con in @@ -221,6 +164,11 @@ let gen_subst_mp f sub mp1 mp2 = | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2 +let make_mind_equiv mpu mpc dir l = + let knu = make_kn mpu dir l in + if mpu == mpc then mind_of_kn knu + else mind_of_kn_equiv knu (make_kn mpc dir l) + let subst_ind sub mind = let kn1,kn2 = user_mind mind, canonical_mind mind in let mp1,dir,l = repr_kn kn1 in @@ -233,12 +181,17 @@ let subst_ind sub mind = | Canonical -> mind_of_delta2 resolve mind' with No_subst -> mind -let subst_con0 sub con = +let make_con_equiv mpu mpc dir l = + let knu = make_kn mpu dir l in + if mpu == mpc then constant_of_kn knu + else constant_of_kn_equiv knu (make_kn mpc dir l) + +let subst_con0 sub con u = let kn1,kn2 = user_con con,canonical_con con in let mp1,dir,l = repr_kn kn1 in let mp2,_,_ = repr_kn kn2 in let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in - let dup con = con, Const con in + let dup con = con, Const (con, u) in let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in match constant_of_delta_with_inline resolve con' with | Some t -> con', t @@ -252,13 +205,21 @@ let subst_con0 sub con = let rec map_kn f f' c = let func = map_kn f f' in match c with - | Const kn -> (try snd (f' kn) with No_subst -> c) - | Ind (kn,i) -> + | Const (kn, u) -> (try snd (f' kn u) with No_subst -> c) + | Proj (kn,t) -> + let kn' = + try fst (f' kn Univ.Instance.empty) + with No_subst -> kn + in + let t' = func t in + if kn' == kn && t' == t then c + else Proj (kn', t') + | Ind ((kn,i),u) -> let kn' = f kn in - if kn'==kn then c else Ind (kn',i) - | Construct ((kn,i),j) -> + if kn'==kn then c else Ind ((kn',i),u) + | Construct (((kn,i),j),u) -> let kn' = f kn in - if kn'==kn then c else Construct ((kn',i),j) + if kn'==kn then c else Construct (((kn',i),j),u) | Case (ci,p,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in @@ -267,7 +228,7 @@ let rec map_kn f f' c = in let p' = func p in let ct' = func ct in - let l' = array_smartmap func l in + let l' = Array.smartmap func l in if (ci.ci_ind==ci_ind && p'==p && l'==l && ct'==ct)then c else @@ -296,21 +257,21 @@ let rec map_kn f f' c = else LetIn (na, b', t', ct') | App (ct,l) -> let ct' = func ct in - let l' = array_smartmap func l in + let l' = Array.smartmap func l in if (ct'== ct && l'==l) then c else App (ct',l') | Evar (e,l) -> - let l' = array_smartmap func l in + let l' = Array.smartmap func l in if (l'==l) then c else Evar (e,l') | Fix (ln,(lna,tl,bl)) -> - let tl' = array_smartmap func tl in - let bl' = array_smartmap func bl in + let tl' = Array.smartmap func tl in + let bl' = Array.smartmap func bl in if (bl == bl'&& tl == tl') then c else Fix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let tl' = array_smartmap func tl in - let bl' = array_smartmap func bl in + let tl' = Array.smartmap func tl in + let bl' = Array.smartmap func bl in if (bl == bl'&& tl == tl') then c else CoFix (ln,(lna,tl',bl')) | _ -> c @@ -318,24 +279,10 @@ let rec map_kn f f' c = let subst_mps sub c = if is_empty_subst sub then c else map_kn (subst_ind sub) (subst_con0 sub) c - - -type 'a lazy_subst = - | LSval of 'a - | LSlazy of substitution list * 'a - -type 'a substituted = 'a lazy_subst ref - -let val_substituted val_a = - val_ref - (val_sum "constr_substituted" 0 - [|[|val_a|];[|val_list val_subst;val_a|]|]) - -let from_val a = ref (LSval a) let rec replace_mp_in_mp mpfrom mpto mp = match mp with - | _ when mp = mpfrom -> mpto + | _ when ModPath.equal mp mpfrom -> mpto | MPdot (mp1,l) -> let mp1' = replace_mp_in_mp mpfrom mpto mp1 in if mp1==mp1' then mp @@ -344,7 +291,7 @@ let rec replace_mp_in_mp mpfrom mpto mp = let rec mp_in_mp mp mp1 = match mp1 with - | _ when mp1 = mp -> true + | _ when ModPath.equal mp1 mp -> true | MPdot (mp2,l) -> mp_in_mp mp mp2 | _ -> false @@ -417,14 +364,14 @@ let update_delta_resolver resolver1 resolver2 = let add_delta_resolver resolver1 resolver2 = if resolver1 == resolver2 then resolver2 - else if resolver2 = empty_delta_resolver then + else if Deltamap.is_empty resolver2 then resolver1 else Deltamap.join (update_delta_resolver resolver1 resolver2) resolver2 let substition_prefixed_by k mp subst = let mp_prefixmp kmp (mp_to,reso) sub = - if mp_in_mp mp kmp && mp <> kmp then + if mp_in_mp mp kmp && not (ModPath.equal mp kmp) then let new_key = replace_mp_in_mp mp k kmp in Umap.add_mp new_key (mp_to,reso) sub else sub @@ -455,75 +402,51 @@ let join subst1 subst2 = let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in Umap.join subst2 subst -let force fsubst r = - match !r with - | LSval a -> a - | LSlazy(s,a) -> - let subst = List.fold_left join empty_subst (List.rev s) in - let a' = fsubst subst a in - r := LSval a'; - a' - -let subst_substituted s r = - match !r with - | LSval a -> ref (LSlazy([s],a)) - | LSlazy(s',a) -> - ref (LSlazy(s::s',a)) +let from_val x = { subst_value = x; subst_subst = []; } -let force_constr = force subst_mps +let force fsubst r = match r.subst_subst with +| [] -> r.subst_value +| s -> + let subst = List.fold_left join empty_subst (List.rev s) in + let x = fsubst subst r.subst_value in + let () = r.subst_subst <- [] in + let () = r.subst_value <- x in + x -type constr_substituted = constr substituted +let subst_substituted s r = { r with subst_subst = s :: r.subst_subst; } -let val_cstr_subst = val_substituted val_constr +let force_constr = force subst_mps let subst_constr_subst = subst_substituted -(** Beware! In .vo files, lazy_constr are stored as integers - used as indexes for a separate table. The actual lazy_constr is restored - later, by [Safe_typing.LightenLibrary.load]. This allows us - to use here a different definition of lazy_constr than coqtop: - since the checker will inspect all proofs parts, even opaque - ones, no need to use Lazy.t here *) - -type lazy_constr = constr_substituted -let subst_lazy_constr = subst_substituted -let force_lazy_constr = force_constr -let lazy_constr_from_val c = c -let val_lazy_constr = val_cstr_subst - -(** Inlining level of parameters at functor applications. - This is ignored by the checker. *) - -type inline = int option +let subst_lazy_constr sub = function + | Indirect (l,dp,i) -> Indirect (sub::l,dp,i) -(** A constant can have no body (axiom/parameter), or a - transparent body, or an opaque one *) +let indirect_opaque_access = + ref ((fun dp i -> assert false) : DirPath.t -> int -> constr) +let indirect_opaque_univ_access = + ref ((fun dp i -> assert false) : DirPath.t -> int -> Univ.constraints) -type constant_def = - | Undef of inline - | Def of constr_substituted - | OpaqueDef of lazy_constr +let force_lazy_constr = function + | Indirect (l,dp,i) -> + let c = !indirect_opaque_access dp i in + force_constr (List.fold_right subst_constr_subst l (from_val c)) -let val_cst_def = - val_sum "constant_def" 0 - [|[|val_opt val_int|]; [|val_cstr_subst|]; [|val_lazy_constr|]|] +let force_lazy_constr_univs = function + | OpaqueDef (Indirect (l,dp,i)) -> !indirect_opaque_univ_access dp i + | _ -> Univ.empty_constraint let subst_constant_def sub = function | Undef inl -> Undef inl | Def c -> Def (subst_constr_subst sub c) | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc) -type constant_body = { - const_hyps : section_context; (* New: younger hyp at top *) - const_body : constant_def; - const_type : constant_type; - const_body_code : to_patch_substituted; - const_constraints : Univ.constraints } +(** Local variables and graph *) let body_of_constant cb = match cb.const_body with | Undef _ -> None - | Def c -> Some c - | OpaqueDef c -> Some c + | Def c -> Some (force_constr c) + | OpaqueDef c -> Some (force_lazy_constr c) let constant_has_body cb = match cb.const_body with | Undef _ -> false @@ -533,40 +456,18 @@ let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true | Def _ | Undef _ -> false -let val_cb = val_tuple ~name:"constant_body" - [|val_nctxt; - val_cst_def; - val_cst_type; - no_val; - val_cstrs|] - let subst_rel_declaration sub (id,copt,t as x) = let copt' = Option.smartmap (subst_mps sub) copt in let t' = subst_mps sub t in - if copt == copt' & t == t' then x else (id,copt',t') - -let subst_rel_context sub = list_smartmap (subst_rel_declaration sub) + if copt == copt' && t == t' then x else (id,copt',t') -type recarg = - | Norec - | Mrec of inductive - | Imbr of inductive -let val_recarg = val_sum "recarg" 1 (* Norec *) - [|[|val_ind|] (* Mrec *);[|val_ind|] (* Imbr *)|] +let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) let subst_recarg sub r = match r with | Norec -> r | (Mrec(kn,i)|Imbr (kn,i)) -> let kn' = subst_ind sub kn in if kn==kn' then r else Imbr (kn',i) -type wf_paths = recarg Rtree.t -let val_wfp = val_rec_sum "wf_paths" 0 - (fun val_wfp -> - [|[|val_int;val_int|]; (* Rtree.Param *) - [|val_recarg;val_array val_wfp|]; (* Rtree.Node *) - [|val_int;val_array val_wfp|] (* Rtree.Rec *) - |]) - let mk_norec = Rtree.mk_node Norec [||] let mk_paths r recargs = @@ -581,6 +482,14 @@ let dest_subterms p = let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p +let eq_recarg r1 r2 = match r1, r2 with + | Norec, Norec -> true + | Mrec i1, Mrec i2 -> Names.eq_ind i1 i2 + | Imbr i1, Imbr i2 -> Names.eq_ind i1 i2 + | _ -> false + +let eq_wf_paths = Rtree.equal eq_recarg + (**********************************************************************) (* Representation of mutual inductive types in the kernel *) (* @@ -589,142 +498,66 @@ let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p with In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn *) -type monomorphic_inductive_arity = { - mind_user_arity : constr; - mind_sort : sorts; -} -let val_mono_ind_arity = - val_tuple ~name:"monomorphic_inductive_arity"[|val_constr;val_sort|] - -type inductive_arity = -| Monomorphic of monomorphic_inductive_arity -| Polymorphic of polymorphic_arity -let val_ind_arity = val_sum "inductive_arity" 0 - [|[|val_mono_ind_arity|];[|val_pol_arity|]|] - -type one_inductive_body = { - -(* Primitive datas *) - - (* Name of the type: [Ii] *) - mind_typename : identifier; - (* Arity context of [Ii] with parameters: [forall params, Ui] *) - mind_arity_ctxt : rel_context; +let subst_decl_arity f g sub ar = + match ar with + | RegularArity x -> + let x' = f sub x in + if x' == x then ar + else RegularArity x' + | TemplateArity x -> + let x' = g sub x in + if x' == x then ar + else TemplateArity x' - (* Arity sort, original user arity, and allowed elim sorts, if monomorphic *) - mind_arity : inductive_arity; +let map_decl_arity f g = function + | RegularArity a -> RegularArity (f a) + | TemplateArity a -> TemplateArity (g a) - (* Names of the constructors: [cij] *) - mind_consnames : identifier array; - (* Types of the constructors with parameters: [forall params, Tij], - where the Ik are replaced by de Bruijn index in the context - I1:forall params, U1 .. In:forall params, Un *) - mind_user_lc : constr array; - -(* Derived datas *) - - (* Number of expected real arguments of the type (no let, no params) *) - mind_nrealargs : int; - - (* Length of realargs context (with let, no params) *) - mind_nrealargs_ctxt : int; - - (* List of allowed elimination sorts *) - mind_kelim : sorts_family list; - - (* Head normalized constructor types so that their conclusion is atomic *) - mind_nf_lc : constr array; - - (* Length of the signature of the constructors (with let, w/o params) *) - mind_consnrealdecls : int array; - - (* Signature of recursive arguments in the constructors *) - mind_recargs : wf_paths; - -(* Datas for bytecode compilation *) - - (* number of constant constructor *) - mind_nb_constant : int; - - (* number of no constant constructor *) - mind_nb_args : int; - - mind_reloc_tbl : reloc_table; - } - -let val_one_ind = val_tuple ~name:"one_inductive_body" - [|val_id;val_rctxt;val_ind_arity;val_array val_id;val_array val_constr; - val_int;val_int;val_list val_sortfam;val_array val_constr;val_array val_int; - val_wfp;val_int;val_int;no_val|] - - -type mutual_inductive_body = { - - (* The component of the mutual inductive block *) - mind_packets : one_inductive_body array; - - (* Whether the inductive type has been declared as a record *) - mind_record : bool; - - (* Whether the type is inductive or coinductive *) - mind_finite : bool; - - (* Number of types in the block *) - mind_ntypes : int; - - (* Section hypotheses on which the block depends *) - mind_hyps : section_context; +let subst_rel_declaration sub (id,copt,t as x) = + let copt' = Option.smartmap (subst_mps sub) copt in + let t' = subst_mps sub t in + if copt == copt' && t == t' then x else (id,copt',t') - (* Number of expected parameters *) - mind_nparams : int; +let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) - (* Number of recursively uniform (i.e. ordinary) parameters *) - mind_nparams_rec : int; +let subst_template_cst_arity sub (ctx,s as arity) = + let ctx' = subst_rel_context sub ctx in + if ctx==ctx' then arity else (ctx',s) - (* The context of parameters (includes let-in declaration) *) - mind_params_ctxt : rel_context; +let subst_arity sub s = subst_decl_arity subst_mps subst_template_cst_arity sub s - (* Universes constraints enforced by the inductive declaration *) - mind_constraints : Univ.constraints; +(* TODO: should be changed to non-coping after Term.subst_mps *) +(* NB: we leave bytecode and native code fields untouched *) +let subst_const_body sub cb = + { cb with + const_body = subst_constant_def sub cb.const_body; + const_type = subst_arity sub cb.const_type } - } -let val_ind_pack = val_tuple ~name:"mutual_inductive_body" - [|val_array val_one_ind;val_bool;val_bool;val_int;val_nctxt; - val_int; val_int; val_rctxt;val_cstrs|] +let subst_regular_ind_arity sub s = + let uar' = subst_mps sub s.mind_user_arity in + if uar' == s.mind_user_arity then s + else { mind_user_arity = uar'; mind_sort = s.mind_sort } -let subst_arity sub = function -| NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s) -| PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s) +let subst_template_ind_arity sub s = s -(* TODO: should be changed to non-coping after Term.subst_mps *) -let subst_const_body sub cb = { - const_hyps = (assert (cb.const_hyps=[]); []); - const_body = subst_constant_def sub cb.const_body; - const_type = subst_arity sub cb.const_type; - const_body_code = (*Cemitcodes.subst_to_patch_subst sub*) cb.const_body_code; - const_constraints = cb.const_constraints} - -let subst_arity sub = function -| Monomorphic s -> - Monomorphic { - mind_user_arity = subst_mps sub s.mind_user_arity; - mind_sort = s.mind_sort; - } -| Polymorphic s as x -> x +(* FIXME records *) +let subst_ind_arity = + subst_decl_arity subst_regular_ind_arity subst_template_ind_arity let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; mind_consnrealdecls = mbp.mind_consnrealdecls; + mind_consnrealargs = mbp.mind_consnrealargs; mind_typename = mbp.mind_typename; - mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc; + mind_nf_lc = Array.smartmap (subst_mps sub) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; - mind_arity = subst_arity sub mbp.mind_arity; - mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc; + mind_arity = subst_ind_arity sub mbp.mind_arity; + mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc; mind_nrealargs = mbp.mind_nrealargs; - mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt; + mind_nrealdecls = mbp.mind_nrealdecls; mind_kelim = mbp.mind_kelim; mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); mind_nb_constant = mbp.mind_nb_constant; @@ -733,146 +566,49 @@ let subst_mind_packet sub mbp = let subst_mind sub mib = - { mind_record = mib.mind_record ; - mind_finite = mib.mind_finite ; - mind_ntypes = mib.mind_ntypes ; - mind_hyps = (assert (mib.mind_hyps=[]); []) ; - mind_nparams = mib.mind_nparams; - mind_nparams_rec = mib.mind_nparams_rec; - mind_params_ctxt = - map_rel_context (subst_mps sub) mib.mind_params_ctxt; - mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; - mind_constraints = mib.mind_constraints } + { mib with + mind_params_ctxt = map_rel_context (subst_mps sub) mib.mind_params_ctxt; + mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets } (* Modules *) -(* Whenever you change these types, please do update the validation - functions below *) -type structure_field_body = - | SFBconst of constant_body - | SFBmind of mutual_inductive_body - | SFBmodule of module_body - | SFBmodtype of module_type_body - -and structure_body = (label * structure_field_body) list - -and struct_expr_body = - | SEBident of module_path - | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body - | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints - | SEBstruct of structure_body - | SEBwith of struct_expr_body * with_declaration_body - -and with_declaration_body = - With_module_body of identifier list * module_path - | With_definition_body of identifier list * constant_body - -and module_body = - { mod_mp : module_path; - mod_expr : struct_expr_body option; - mod_type : struct_expr_body; - mod_type_alg : struct_expr_body option; - mod_constraints : Univ.constraints; - mod_delta : delta_resolver; - mod_retroknowledge : action list} - -and module_type_body = - { typ_mp : module_path; - typ_expr : struct_expr_body; - typ_expr_alg : struct_expr_body option ; - typ_constraints : Univ.constraints; - typ_delta :delta_resolver} - -(* the validation functions: *) -let rec val_sfb o = val_sum "struct_field_body" 0 - [|[|val_cb|]; (* SFBconst *) - [|val_ind_pack|]; (* SFBmind *) - [|val_module|]; (* SFBmodule *) - [|val_modtype|] (* SFBmodtype *) - |] o -and val_sb o = val_list (val_tuple ~name:"label*sfb"[|val_id;val_sfb|]) o -and val_seb o = val_sum "struct_expr_body" 0 - [|[|val_mp|]; (* SEBident *) - [|val_uid;val_modtype;val_seb|]; (* SEBfunctor *) - [|val_seb;val_seb;val_cstrs|]; (* SEBapply *) - [|val_sb|]; (* SEBstruct *) - [|val_seb;val_with|] (* SEBwith *) - |] o -and val_with o = val_sum "with_declaration_body" 0 - [|[|val_list val_id;val_mp|]; - [|val_list val_id;val_cb|]|] o -and val_module o = val_tuple ~name:"module_body" - [|val_mp;val_opt val_seb;val_seb; - val_opt val_seb;val_cstrs;val_res;no_val|] o -and val_modtype o = val_tuple ~name:"module_type_body" - [|val_mp;val_seb;val_opt val_seb;val_cstrs;val_res|] o - - -let rec subst_with_body sub = function - | With_module_body(id,mp) -> - With_module_body(id,subst_mp sub mp) - | With_definition_body(id,cb) -> - With_definition_body( id,subst_const_body sub cb) - -and subst_modtype sub mtb= - let typ_expr' = subst_struct_expr sub mtb.typ_expr in - let typ_alg' = - Option.smartmap - (subst_struct_expr sub) mtb.typ_expr_alg in - let mp = subst_mp sub mtb.typ_mp - in - if typ_expr'==mtb.typ_expr && - typ_alg'==mtb.typ_expr_alg && mp==mtb.typ_mp then - mtb - else - {mtb with - typ_mp = mp; - typ_expr = typ_expr'; - typ_expr_alg = typ_alg'} +let rec functor_map fty f0 = function + | NoFunctor a -> NoFunctor (f0 a) + | MoreFunctor (mbid,ty,e) -> MoreFunctor(mbid,fty ty,functor_map fty f0 e) -and subst_structure sub sign = - let subst_body = function - SFBconst cb -> - SFBconst (subst_const_body sub cb) - | SFBmind mib -> - SFBmind (subst_mind sub mib) - | SFBmodule mb -> - SFBmodule (subst_module sub mb) - | SFBmodtype mtb -> - SFBmodtype (subst_modtype sub mtb) - in - List.map (fun (l,b) -> (l,subst_body b)) sign +let implem_map fs fa = function + | Struct s -> Struct (fs s) + | Algebraic a -> Algebraic (fa a) + | impl -> impl +let subst_with_body sub = function + | WithMod(id,mp) -> WithMod(id,subst_mp sub mp) + | WithDef(id,c) -> WithDef(id,subst_mps sub c) -and subst_module sub mb = - let mtb' = subst_struct_expr sub mb.mod_type in - let typ_alg' = Option.smartmap - (subst_struct_expr sub ) mb.mod_type_alg in - let me' = Option.smartmap - (subst_struct_expr sub) mb.mod_expr in - let mp = subst_mp sub mb.mod_mp in - if mtb'==mb.mod_type && mb.mod_expr == me' - && mp == mb.mod_mp - then mb else - { mb with - mod_mp = mp; - mod_expr = me'; - mod_type_alg = typ_alg'; - mod_type=mtb'} - -and subst_struct_expr sub = function - | SEBident mp -> SEBident (subst_mp sub mp) - | SEBfunctor (mbid, mtb, meb') -> - SEBfunctor(mbid,subst_modtype sub mtb - ,subst_struct_expr sub meb') - | SEBstruct (str)-> - SEBstruct( subst_structure sub str) - | SEBapply (meb1,meb2,cst)-> - SEBapply(subst_struct_expr sub meb1, - subst_struct_expr sub meb2, - cst) - | SEBwith (meb,wdb)-> - SEBwith(subst_struct_expr sub meb, - subst_with_body sub wdb) +let rec subst_expr sub = function + | MEident mp -> MEident (subst_mp sub mp) + | MEapply (me1,mp2)-> MEapply (subst_expr sub me1, subst_mp sub mp2) + | MEwith (me,wd)-> MEwith (subst_expr sub me, subst_with_body sub wd) + +let rec subst_expression sub me = + functor_map (subst_module sub) (subst_expr sub) me +and subst_signature sub sign = + functor_map (subst_module sub) (subst_structure sub) sign +and subst_structure sub struc = + let subst_body = function + | SFBconst cb -> SFBconst (subst_const_body sub cb) + | SFBmind mib -> SFBmind (subst_mind sub mib) + | SFBmodule mb -> SFBmodule (subst_module sub mb) + | SFBmodtype mtb -> SFBmodtype (subst_module sub mtb) + in + List.map (fun (l,b) -> (l,subst_body b)) struc + +and subst_module sub mb = + { mb with + mod_mp = subst_mp sub mb.mod_mp; + mod_expr = + implem_map (subst_signature sub) (subst_expression sub) mb.mod_expr; + mod_type = subst_signature sub mb.mod_type; + mod_type_alg = Option.smartmap (subst_expression sub) mb.mod_type_alg } diff --git a/checker/declarations.mli b/checker/declarations.mli index 90beb326..3c6db6ab 100644 --- a/checker/declarations.mli +++ b/checker/declarations.mli @@ -1,238 +1,47 @@ -open Util open Names -open Term +open Cic -(* Bytecode *) -type values -type reloc_table -type to_patch_substituted -(*Retroknowledge *) -type action -type retroknowledge - -(* Engagements *) - -type engagement = ImpredicativeSet - -(* Constants *) - -type polymorphic_arity = { - poly_param_levels : Univ.universe option list; - poly_level : Univ.universe; -} - -type constant_type = - | NonPolymorphicType of constr - | PolymorphicArity of rel_context * polymorphic_arity - -type constr_substituted val force_constr : constr_substituted -> constr +val force_lazy_constr_univs : Cic.constant_def -> Univ.constraints val from_val : constr -> constr_substituted -(** Beware! In .vo files, lazy_constr are stored as integers - used as indexes for a separate table. The actual lazy_constr is restored - later, by [Safe_typing.LightenLibrary.load]. This allows us - to use here a different definition of lazy_constr than coqtop: - since the checker will inspect all proofs parts, even opaque - ones, no need to use Lazy.t here *) - -type lazy_constr -val force_lazy_constr : lazy_constr -> constr -val lazy_constr_from_val : constr_substituted -> lazy_constr +val indirect_opaque_access : (DirPath.t -> int -> constr) ref +val indirect_opaque_univ_access : (DirPath.t -> int -> Univ.constraints) ref -(** Inlining level of parameters at functor applications. - This is ignored by the checker. *) +(** Constant_body *) -type inline = int option - -(** A constant can have no body (axiom/parameter), or a - transparent body, or an opaque one *) - -type constant_def = - | Undef of inline - | Def of constr_substituted - | OpaqueDef of lazy_constr - -type constant_body = { - const_hyps : section_context; (* New: younger hyp at top *) - const_body : constant_def; - const_type : constant_type; - const_body_code : to_patch_substituted; - const_constraints : Univ.constraints } - -val body_of_constant : constant_body -> constr_substituted option +val body_of_constant : constant_body -> constr option val constant_has_body : constant_body -> bool val is_opaque : constant_body -> bool (* Mutual inductives *) -type recarg = - | Norec - | Mrec of inductive - | Imbr of inductive - -type wf_paths = recarg Rtree.t - val mk_norec : wf_paths val mk_paths : recarg -> wf_paths list array -> wf_paths val dest_recarg : wf_paths -> recarg val dest_subterms : wf_paths -> wf_paths list array - -type monomorphic_inductive_arity = { - mind_user_arity : constr; - mind_sort : sorts; -} - -type inductive_arity = -| Monomorphic of monomorphic_inductive_arity -| Polymorphic of polymorphic_arity - -type one_inductive_body = { - -(* Primitive datas *) - - (* Name of the type: [Ii] *) - mind_typename : identifier; - - (* Arity context of [Ii] with parameters: [forall params, Ui] *) - mind_arity_ctxt : rel_context; - - (* Arity sort, original user arity, and allowed elim sorts, if monomorphic *) - mind_arity : inductive_arity; - - (* Names of the constructors: [cij] *) - mind_consnames : identifier array; - - (* Types of the constructors with parameters: [forall params, Tij], - where the Ik are replaced by de Bruijn index in the context - I1:forall params, U1 .. In:forall params, Un *) - mind_user_lc : constr array; - -(* Derived datas *) - - (* Number of expected real arguments of the type (no let, no params) *) - mind_nrealargs : int; - - (* Length of realargs context (with let, no params) *) - mind_nrealargs_ctxt : int; - - (* List of allowed elimination sorts *) - mind_kelim : sorts_family list; - - (* Head normalized constructor types so that their conclusion is atomic *) - mind_nf_lc : constr array; - - (* Length of the signature of the constructors (with let, w/o params) *) - mind_consnrealdecls : int array; - - (* Signature of recursive arguments in the constructors *) - mind_recargs : wf_paths; - -(* Datas for bytecode compilation *) - - (* number of constant constructor *) - mind_nb_constant : int; - - (* number of no constant constructor *) - mind_nb_args : int; - - mind_reloc_tbl : reloc_table; - } - -type mutual_inductive_body = { - - (* The component of the mutual inductive block *) - mind_packets : one_inductive_body array; - - (* Whether the inductive type has been declared as a record *) - mind_record : bool; - - (* Whether the type is inductive or coinductive *) - mind_finite : bool; - - (* Number of types in the block *) - mind_ntypes : int; - - (* Section hypotheses on which the block depends *) - mind_hyps : section_context; - - (* Number of expected parameters *) - mind_nparams : int; - - (* Number of recursively uniform (i.e. ordinary) parameters *) - mind_nparams_rec : int; - - (* The context of parameters (includes let-in declaration) *) - mind_params_ctxt : rel_context; - - (* Universes constraints enforced by the inductive declaration *) - mind_constraints : Univ.constraints; - - } +val eq_recarg : recarg -> recarg -> bool +val eq_wf_paths : wf_paths -> wf_paths -> bool (* Modules *) -type substitution -type delta_resolver val empty_delta_resolver : delta_resolver -type structure_field_body = - | SFBconst of constant_body - | SFBmind of mutual_inductive_body - | SFBmodule of module_body - | SFBmodtype of module_type_body - -and structure_body = (label * structure_field_body) list - -and struct_expr_body = - | SEBident of module_path - | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body - | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints - | SEBstruct of structure_body - | SEBwith of struct_expr_body * with_declaration_body - -and with_declaration_body = - With_module_body of identifier list * module_path - | With_definition_body of identifier list * constant_body - -and module_body = - { mod_mp : module_path; - mod_expr : struct_expr_body option; - mod_type : struct_expr_body; - mod_type_alg : struct_expr_body option; - mod_constraints : Univ.constraints; - mod_delta : delta_resolver; - mod_retroknowledge : action list} - -and module_type_body = - { typ_mp : module_path; - typ_expr : struct_expr_body; - typ_expr_alg : struct_expr_body option ; - typ_constraints : Univ.constraints; - typ_delta :delta_resolver} - (* Substitutions *) type 'a subst_fun = substitution -> 'a -> 'a val empty_subst : substitution -val add_mbid : mod_bound_id -> module_path -> substitution -> substitution +val add_mbid : MBId.t -> module_path -> substitution -> substitution val add_mp : module_path -> module_path -> substitution -> substitution -val map_mbid : mod_bound_id -> module_path -> substitution +val map_mbid : MBId.t -> module_path -> substitution val map_mp : module_path -> module_path -> substitution val mp_in_delta : module_path -> delta_resolver -> bool val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive val subst_const_body : constant_body subst_fun val subst_mind : mutual_inductive_body subst_fun -val subst_modtype : substitution -> module_type_body -> module_type_body -val subst_struct_expr : substitution -> struct_expr_body -> struct_expr_body -val subst_structure : substitution -> structure_body -> structure_body +val subst_signature : substitution -> module_signature -> module_signature val subst_module : substitution -> module_body -> module_body val join : substitution -> substitution -> substitution - -(* Validation *) -val val_eng : Validate.func -val val_module : Validate.func -val val_modtype : Validate.func diff --git a/checker/environ.ml b/checker/environ.ml index 99b36457..710ebc71 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -1,6 +1,7 @@ +open Errors open Util open Names -open Univ +open Cic open Term open Declarations @@ -12,16 +13,15 @@ type globals = { env_modtypes : module_type_body MPmap.t} type stratification = { - env_universes : universes; + env_universes : Univ.universes; env_engagement : engagement option } type env = { env_globals : globals; - env_named_context : named_context; env_rel_context : rel_context; env_stratification : stratification; - env_imports : Digest.t MPmap.t } + env_imports : Cic.vodigest MPmap.t } let empty_env = { env_globals = @@ -30,7 +30,6 @@ let empty_env = { env_inductives_eq = KNmap.empty; env_modules = MPmap.empty; env_modtypes = MPmap.empty}; - env_named_context = []; env_rel_context = []; env_stratification = { env_universes = Univ.initial_universes; @@ -39,7 +38,6 @@ let empty_env = { let engagement env = env.env_stratification.env_engagement let universes env = env.env_stratification.env_universes -let named_context env = env.env_named_context let rel_context env = env.env_rel_context let set_engagement c env = @@ -73,46 +71,31 @@ let push_rel d env = let push_rel_context ctxt x = 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, lift i t)) lna typarray in + let ctxt = Array.map2_i (fun i na t -> (na, None, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt -(* Named context *) - -let push_named d env = -(* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); - assert (env.env_rel_context = []); *) - { env with - env_named_context = d :: env.env_named_context } - -let lookup_named id env = - let rec lookup_named id = function - | (id',_,_ as decl) :: _ when id=id' -> decl - | _ :: sign -> lookup_named id sign - | [] -> raise Not_found in - lookup_named id env.env_named_context - -(* A local const is evaluable if it is defined *) - -let named_type id env = - let (_,_,t) = lookup_named id env in t - (* Universe constraints *) let add_constraints c env = - if c == empty_constraint then + if c == Univ.Constraint.empty then env else let s = env.env_stratification in { env with env_stratification = - { s with env_universes = merge_constraints c s.env_universes } } + { s with env_universes = Univ.merge_constraints c s.env_universes } } + +let check_constraints cst env = + Univ.check_constraints cst env.env_stratification.env_universes (* Global constants *) let lookup_constant kn env = Cmap_env.find kn env.env_globals.env_constants +let anomaly s = anomaly (Pp.str s) + let add_constant kn cs env = if Cmap_env.mem kn env.env_globals.env_constants then - Printf.ksprintf anomaly "Constant %s is already defined" + Printf.ksprintf anomaly ("Constant %s is already defined") (string_of_con kn); let new_constants = Cmap_env.add kn cs env.env_globals.env_constants in @@ -123,20 +106,52 @@ let add_constant kn cs env = type const_evaluation_result = NoBody | Opaque +(* Constant types *) + +let constraints_of cb u = + let univs = cb.const_universes in + Univ.subst_instance_constraints u (Univ.UContext.constraints univs) + +let map_regular_arity f = function + | RegularArity a as ar -> + let a' = f a in + if a' == a then ar else RegularArity a' + | TemplateArity _ -> assert false + +(* constant_type gives the type of a constant *) +let constant_type env (kn,u) = + let cb = lookup_constant kn env in + if cb.const_polymorphic then + let csts = constraints_of cb u in + (map_regular_arity (subst_instance_constr u) cb.const_type, csts) + else cb.const_type, Univ.Constraint.empty + exception NotEvaluableConst of const_evaluation_result -let constant_value env kn = +let constant_value env (kn,u) = let cb = lookup_constant kn env in - match cb.const_body with - | Def l_body -> force_constr l_body + match cb.const_body with + | Def l_body -> + let b = force_constr l_body in + if cb.const_polymorphic then + subst_instance_constr u (force_constr l_body) + else b | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) (* A global const is evaluable if it is defined and not opaque *) let evaluable_constant cst env = - try let _ = constant_value env cst in true + try let _ = constant_value env (cst, Univ.Instance.empty) in true with Not_found | NotEvaluableConst _ -> false +let is_projection cst env = + not (Option.is_empty (lookup_constant cst env).const_proj) + +let lookup_projection cst env = + match (lookup_constant cst env).const_proj with + | Some pb -> pb + | None -> anomaly ("lookup_projection: constant is not a projection") + (* Mutual Inductives *) let scrape_mind env kn= try @@ -145,8 +160,8 @@ let scrape_mind env kn= Not_found -> kn let mind_equiv env (kn1,i1) (kn2,i2) = - i1 = i2 && - scrape_mind env (user_mind kn1) = scrape_mind env (user_mind kn2) + Int.equal i1 i2 && + KerName.equal (scrape_mind env (user_mind kn1)) (scrape_mind env (user_mind kn2)) let lookup_mind kn env = @@ -154,11 +169,11 @@ let lookup_mind kn env = let add_mind kn mib env = if Mindmap_env.mem kn env.env_globals.env_inductives then - Printf.ksprintf anomaly "Inductive %s is already defined" + Printf.ksprintf anomaly ("Inductive %s is already defined") (string_of_mind kn); let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in let kn1,kn2 = user_mind kn,canonical_mind kn in - let new_inds_eq = if kn1=kn2 then + let new_inds_eq = if KerName.equal kn1 kn2 then env.env_globals.env_inductives_eq else KNmap.add kn1 kn2 env.env_globals.env_inductives_eq in @@ -173,7 +188,7 @@ let add_mind kn mib env = let add_modtype ln mtb env = if MPmap.mem ln env.env_globals.env_modtypes then - Printf.ksprintf anomaly "Module type %s is already defined" + Printf.ksprintf anomaly ("Module type %s is already defined") (string_of_mp ln); let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in let new_globals = @@ -183,7 +198,7 @@ let add_modtype ln mtb env = let shallow_add_module mp mb env = if MPmap.mem mp env.env_globals.env_modules then - Printf.ksprintf anomaly "Module %s is already defined" + Printf.ksprintf anomaly ("Module %s is already defined") (string_of_mp mp); let new_mods = MPmap.add mp mb env.env_globals.env_modules in let new_globals = @@ -193,7 +208,7 @@ let shallow_add_module mp mb env = let shallow_remove_module mp env = if not (MPmap.mem mp env.env_globals.env_modules) then - Printf.ksprintf anomaly "Module %s is unknown" + Printf.ksprintf anomaly ("Module %s is unknown") (string_of_mp mp); let new_mods = MPmap.remove mp env.env_globals.env_modules in let new_globals = diff --git a/checker/environ.mli b/checker/environ.mli index 628febbb..d3448b12 100644 --- a/checker/environ.mli +++ b/checker/environ.mli @@ -1,34 +1,33 @@ open Names -open Term +open Cic (* Environments *) type globals = { - env_constants : Declarations.constant_body Cmap_env.t; - env_inductives : Declarations.mutual_inductive_body Mindmap_env.t; + env_constants : constant_body Cmap_env.t; + env_inductives : mutual_inductive_body Mindmap_env.t; env_inductives_eq : kernel_name KNmap.t; - env_modules : Declarations.module_body MPmap.t; - env_modtypes : Declarations.module_type_body MPmap.t} + env_modules : module_body MPmap.t; + env_modtypes : module_type_body MPmap.t} type stratification = { env_universes : Univ.universes; - env_engagement : Declarations.engagement option; + env_engagement : engagement option; } type env = { env_globals : globals; - env_named_context : named_context; env_rel_context : rel_context; env_stratification : stratification; - env_imports : Digest.t MPmap.t; + env_imports : Cic.vodigest MPmap.t; } val empty_env : env (* Engagement *) -val engagement : env -> Declarations.engagement option -val set_engagement : Declarations.engagement -> env -> env +val engagement : env -> Cic.engagement option +val set_engagement : Cic.engagement -> env -> env (* Digests *) -val add_digest : env -> dir_path -> Digest.t -> env -val lookup_digest : env -> dir_path -> Digest.t +val add_digest : env -> DirPath.t -> Cic.vodigest -> env +val lookup_digest : env -> DirPath.t -> Cic.vodigest (* de Bruijn variables *) val rel_context : env -> rel_context @@ -37,38 +36,37 @@ val push_rel : rel_declaration -> env -> env val push_rel_context : rel_context -> env -> env val push_rec_types : name array * constr array * 'a -> env -> env -(* Named variables *) -val named_context : env -> named_context -val push_named : named_declaration -> env -> env -val lookup_named : identifier -> env -> named_declaration -val named_type : identifier -> env -> constr - (* Universes *) val universes : env -> Univ.universes val add_constraints : Univ.constraints -> env -> env +val check_constraints : Univ.constraints -> env -> bool (* Constants *) -val lookup_constant : constant -> env -> Declarations.constant_body -val add_constant : constant -> Declarations.constant_body -> env -> env +val lookup_constant : constant -> env -> Cic.constant_body +val add_constant : constant -> Cic.constant_body -> env -> env +val constant_type : env -> constant puniverses -> constant_type Univ.constrained type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result -val constant_value : env -> constant -> constr +val constant_value : env -> constant puniverses -> constr val evaluable_constant : constant -> env -> bool +val is_projection : constant -> env -> bool +val lookup_projection : constant -> env -> projection_body + (* Inductives *) val mind_equiv : env -> inductive -> inductive -> bool val lookup_mind : - mutual_inductive -> env -> Declarations.mutual_inductive_body + mutual_inductive -> env -> Cic.mutual_inductive_body val add_mind : - mutual_inductive -> Declarations.mutual_inductive_body -> env -> env + mutual_inductive -> Cic.mutual_inductive_body -> env -> env (* Modules *) val add_modtype : - module_path -> Declarations.module_type_body -> env -> env + module_path -> Cic.module_type_body -> env -> env val shallow_add_module : - module_path -> Declarations.module_body -> env -> env + module_path -> Cic.module_body -> env -> env val shallow_remove_module : module_path -> env -> env -val lookup_module : module_path -> env -> Declarations.module_body -val lookup_modtype : module_path -> env -> Declarations.module_type_body +val lookup_module : module_path -> env -> Cic.module_body +val lookup_modtype : module_path -> env -> Cic.module_type_body diff --git a/checker/include b/checker/include index b7d46d4b..f5bd2984 100644 --- a/checker/include +++ b/checker/include @@ -12,10 +12,12 @@ #directory "lib";; #directory "kernel";; #directory "checker";; +#directory "+threads";; #directory "+camlp4";; #directory "+camlp5";; #load "unix.cma";; +#load"threads.cma";; #load "str.cma";; #load "gramlib.cma";; (*#load "toplevellib.cma";; @@ -29,12 +31,14 @@ open Typeops;; open Check;; open Pp;; +open Errors;; open Util;; open Names;; open Term;; open Environ;; open Declarations;; open Mod_checking;; +open Cic;; let pr_id id = str(string_of_id id) let pr_na = function Name id -> pr_id id | _ -> str"_";; @@ -111,23 +115,33 @@ let prsub s = (*#install_printer prenvu;; #install_printer prsub;;*) -Checker.init_with_argv [|""|];; +Checker.init_with_argv [|"";"-coqlib";"."|];; Flags.make_silent false;; Flags.debug := true;; Sys.catch_break true;; let module_of_file f = let (_,mb,_,_) = Obj.magic ((intern_from_file f).library_compiled) in - (mb:module_body) + (mb:Cic.module_body) ;; +let deref_mod md s = + let l = match md.mod_expr with + Struct(NoFunctor l) -> l + | FullStruct -> + (match md.mod_type with + NoFunctor l -> l) + in + List.assoc (label_of_id(id_of_string s)) l +;; +(* let mod_access m fld = match m.mod_expr with Some(SEBstruct l) -> List.assoc fld l | _ -> failwith "bad structure type" ;; - +*) let parse_dp s = - make_dirpath(List.map id_of_string (List.rev (Str.split(Str.regexp"\\.") s))) + make_dirpath(List.rev_map id_of_string (Str.split(Str.regexp"\\.") s)) ;; let parse_sp s = let l = List.rev (Str.split(Str.regexp"\\.") s) in @@ -160,10 +174,6 @@ let read_mod s f = (dir_path * Digest.t) list * engagement option);; -let deref_mod md s = - let (Some (SEBstruct l)) = md.mod_expr in - List.assoc (label_of_id(id_of_string s)) l -;; let expln f x = try f x diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 1207a325..2ce9f038 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -1,14 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* string_of_dirpath sl - | MPbound uid -> "bound("^string_of_mbid uid^")" - | MPdot (mp,l) -> debug_string_of_mp mp ^ "." ^ string_of_label l + | MPfile sl -> DirPath.to_string sl + | MPbound uid -> "bound("^MBId.to_string uid^")" + | MPdot (mp,l) -> debug_string_of_mp mp ^ "." ^ Label.to_string l let rec string_of_mp = function - | MPfile sl -> string_of_dirpath sl - | MPbound uid -> string_of_mbid uid - | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l + | MPfile sl -> DirPath.to_string sl + | MPbound uid -> MBId.to_string uid + | MPdot (mp,l) -> string_of_mp mp ^ "." ^ Label.to_string l let string_of_mp mp = if !Flags.debug then debug_string_of_mp mp else string_of_mp mp let prkn kn = let (mp,_,l) = repr_kn kn in - str(string_of_mp mp ^ "." ^ string_of_label l) + str(string_of_mp mp ^ "." ^ Label.to_string l) let prcon c = let ck = canonical_con c in let uk = user_con c in - if ck=uk then prkn uk else (prkn uk ++str"(="++prkn ck++str")") + if KerName.equal ck uk then prkn uk else (prkn uk ++str"(="++prkn ck++str")") (* Same as noccur_between but may perform reductions. Could be refined more... *) @@ -75,10 +76,10 @@ type inductive_error = | NotEnoughArgs of env * constr * constr | NotConstructor of env * constr * constr | NonPar of env * constr * int * constr * constr - | SameNamesTypes of identifier - | SameNamesConstructors of identifier - | SameNamesOverlap of identifier list - | NotAnArity of identifier + | SameNamesTypes of Id.t + | SameNamesConstructors of Id.t + | SameNamesOverlap of Id.t list + | NotAnArity of Id.t | BadEntry exception InductiveError of inductive_error @@ -99,7 +100,7 @@ let rec sorts_of_constr_args env t = let env1 = push_rel (name,Some def,ty) env in sorts_of_constr_args env1 c | _ when is_constructor_head t -> [] - | _ -> anomaly "infos_and_sort: not a positive constructor" + | _ -> anomaly ~label:"infos_and_sort" (Pp.str "not a positive constructor") (* Prop and Set are small *) @@ -107,7 +108,9 @@ let is_small_sort = function | Prop _ -> true | _ -> false -let is_logic_sort s = (s = Prop Null) +let is_logic_sort = function +| Prop Null -> true +| _ -> false (* [infos] is a sequence of pair [islogic,issmall] for each type in the product of a constructor or arity *) @@ -126,7 +129,7 @@ let is_unit constrsinfos = | _ -> false let small_unit constrsinfos = - let issmall = array_for_all is_small_constr constrsinfos + let issmall = Array.for_all is_small_constr constrsinfos and isunit = is_unit constrsinfos in issmall, isunit @@ -135,14 +138,15 @@ let typecheck_arity env params inds = let nparamargs = rel_context_nhyps params in let nparamdecls = rel_context_length params in let check_arity arctxt = function - Monomorphic mar -> + | RegularArity mar -> let ar = mar.mind_user_arity in let _ = infer_type env ar in conv env (it_mkProd_or_LetIn (Sort mar.mind_sort) arctxt) ar; ar - | Polymorphic par -> - check_polymorphic_arity env params par; - it_mkProd_or_LetIn (Sort(Type par.poly_level)) arctxt in + | TemplateArity par -> + check_polymorphic_arity env params par; + it_mkProd_or_LetIn (Sort(Type par.template_level)) arctxt + in let env_arities = Array.fold_left (fun env_ar ind -> @@ -156,7 +160,7 @@ let typecheck_arity env params inds = if ind.mind_nrealargs <> nrealargs then failwith "bad number of real inductive arguments"; let nrealargs_ctxt = rel_context_length ar_ctxt - nparamdecls in - if ind.mind_nrealargs_ctxt <> nrealargs_ctxt then + if ind.mind_nrealdecls <> nrealargs_ctxt then failwith "bad length of real inductive arguments signature"; (* We do not need to generate the universe of full_arity; if later, after the validation of the inductive definition, @@ -174,11 +178,11 @@ let typecheck_arity env params inds = let check_predicativity env s small level = match s, engagement env with Type u, _ -> - let u' = fresh_local_univ () in - let cst = - merge_constraints (enforce_geq u' u empty_constraint) - (universes env) in - if not (check_geq cst u' level) then + (* let u' = fresh_local_univ () in *) + (* let cst = *) + (* merge_constraints (enforce_leq u u' empty_constraint) *) + (* (universes env) in *) + if not (Univ.check_leq (universes env) level u) then failwith "impredicative Type inductive type" | Prop Pos, Some ImpredicativeSet -> () | Prop Pos, _ -> @@ -187,8 +191,8 @@ let check_predicativity env s small level = let sort_of_ind = function - Monomorphic mar -> mar.mind_sort - | Polymorphic par -> Type par.poly_level + | RegularArity mar -> mar.mind_sort + | TemplateArity par -> Type par.template_level let all_sorts = [InProp;InSet;InType] let small_sorts = [InProp;InSet] @@ -207,7 +211,7 @@ let allowed_sorts issmall isunit s = (* Unitary/empty Prop: elimination to all sorts are realizable *) (* unless the type is large. If it is large, forbids large elimination *) - (* which otherwise allows to simulate the inconsistent system Type:Type *) + (* which otherwise allows simulating the inconsistent system Type:Type *) | InProp when isunit -> if issmall then all_sorts else small_sorts (* Other propositions: elimination only to Prop *) @@ -242,17 +246,18 @@ let typecheck_one_inductive env params mib mip = let _ = Array.map (infer_type env) mip.mind_user_lc in (* mind_nf_lc *) let _ = Array.map (infer_type env) mip.mind_nf_lc in - array_iter2 (conv env) mip.mind_nf_lc mip.mind_user_lc; + Array.iter2 (conv env) mip.mind_nf_lc mip.mind_user_lc; (* mind_consnrealdecls *) let check_cons_args c n = let ctx,_ = decompose_prod_assum c in if n <> rel_context_length ctx - rel_context_length params then failwith "bad number of real constructor arguments" in - array_iter2 check_cons_args mip.mind_nf_lc mip.mind_consnrealdecls; + Array.iter2 check_cons_args mip.mind_nf_lc mip.mind_consnrealdecls; (* mind_kelim: checked by positivity criterion ? *) let sorts = compute_elim_sorts env params mib mip.mind_arity mip.mind_nf_lc in - if List.exists (fun s -> not (List.mem s sorts)) mip.mind_kelim then + let reject_sort s = not (List.mem_f family_equal s sorts) in + if List.exists reject_sort mip.mind_kelim then failwith "elimination not allowed"; (* mind_recargs: checked by positivity criterion *) () @@ -298,11 +303,11 @@ let failwith_non_pos n ntypes c = let failwith_non_pos_vect n ntypes v = Array.iter (failwith_non_pos n ntypes) v; - anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur" + anomaly ~label:"failwith_non_pos_vect" (Pp.str "some k in [n;n+ntypes-1] should occur") let failwith_non_pos_list n ntypes l = List.iter (failwith_non_pos n ntypes) l; - anomaly "failwith_non_pos_list: some k in [n;n+ntypes-1] should occur" + anomaly ~label:"failwith_non_pos_list" (Pp.str "some k in [n;n+ntypes-1] should occur") (* Conclusion of constructors: check the inductive type is called with the expected parameters *) @@ -311,7 +316,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = let largs = Array.of_list largs in if Array.length largs < nparams then raise (IllFormedInd (LocalNotEnoughArgs l)); - let (lpar,largs') = array_chop nparams largs in + let (lpar,largs') = Array.chop nparams largs in let nhyps = List.length hyps in let rec check k index = function | [] -> () @@ -321,7 +326,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = | Rel w when w = index -> check (k-1) (index+1) hyps | _ -> raise (IllFormedInd (LocalNonPar (k+1,l))) in check (nparams-1) (n-nhyps) hyps; - if not (array_for_all (noccur_between n ntypes) largs') then + if not (Array.for_all (noccur_between n ntypes) largs') then failwith_non_pos_vect n ntypes largs' (* Arguments of constructor: check the number of recursive parameters nrecp. @@ -330,7 +335,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = recursive parameters *) let check_rec_par (env,n,_,_) hyps nrecp largs = - let (lpar,_) = list_chop nrecp largs in + let (lpar,_) = List.chop nrecp largs in let rec find index = function | ([],_) -> () @@ -354,8 +359,8 @@ let abstract_mind_lc env ntyps npars lc = lc else let make_abs = - list_tabulate - (function i -> lambda_implicit_lift npars (Rel (i+1))) ntyps + List.init ntyps + (function i -> lambda_implicit_lift npars (Rel (i+1))) in Array.map (substl make_abs) lc @@ -368,12 +373,12 @@ let abstract_mind_lc env ntyps npars lc = let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) -let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = +let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) = let auxntyp = 1 in let specif = lookup_mind_specif env mi in let env' = push_rel (Anonymous,None, - hnf_prod_applist env (type_of_inductive env specif) lpar) env in + hnf_prod_applist env (type_of_inductive env (specif,u)) lpar) env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in @@ -399,7 +404,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc let x,largs = decompose_app (whd_betadeltaiota env c) in match x with | Prod (na,b,d) -> - assert (largs = []); + assert (List.is_empty largs); (match weaker_noccur_between env n ntypes b with None -> failwith_non_pos_list n ntypes [b] | Some b -> @@ -426,12 +431,12 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc else failwith_non_pos_list n ntypes (x::largs) (* accesses to the environment are not factorised, but is it worth it? *) - and check_positive_imbr (env,n,ntypes,ra_env as ienv) (mi, largs) = + and check_positive_imbr (env,n,ntypes,ra_env as ienv) ((mi,u), largs) = let (mib,mip) = lookup_mind_specif env mi in let auxnpar = mib.mind_nparams_rec in let nonrecpar = mib.mind_nparams - auxnpar in let (lpar,auxlargs) = - try list_chop auxnpar largs + try List.chop auxnpar largs with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in (* If the inductive appears in the args (non params) then the definition is not positive. *) @@ -444,7 +449,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in (* Extends the environment with a variable corresponding to the inductive def *) - let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in + let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in let irecargs = @@ -468,16 +473,17 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc let x,largs = decompose_app (whd_betadeltaiota env c) in match x with | Prod (na,b,d) -> - assert (largs = []); + assert (List.is_empty largs); let recarg = check_pos ienv b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' (recarg::lrec) d | hd -> if check_head then - if hd = Rel (n+ntypes-i-1) then + match hd with + | Rel j when j = (n + ntypes - i - 1) -> check_correct_par ienv hyps (ntypes-i) largs - else + | _ -> raise (IllFormedInd LocalNotConstructor) else if not (List.for_all (noccur_between n ntypes) largs) @@ -496,13 +502,10 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc indlc in mk_paths (Mrec ind) irecargs -let check_subtree (t1:'a) (t2:'a) = - if not (Rtree.compare_rtree (fun t1 t2 -> - let l1 = fst(Rtree.dest_node t1) in - let l2 = fst(Rtree.dest_node t2) in - if l1 = Norec || l1 = l2 then 0 else -1) - t1 t2) then - failwith "bad recursive trees" +let check_subtree t1 t2 = + let cmp_labels l1 l2 = l1 == Norec || eq_recarg l1 l2 in + if not (Rtree.equiv eq_recarg cmp_labels t1 t2) + then failwith "bad recursive trees" (* if t1=t2 then () else msg_warning (str"TODO: check recursive positions")*) let check_positivity env_ar mind params nrecp inds = @@ -513,29 +516,26 @@ let check_positivity env_ar mind params nrecp inds = let lparams = rel_context_length params in let check_one i mip = let ra_env = - list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in + List.init lparams (fun _ -> (Norec,mk_norec)) @ lra_ind in let ienv = (env_ar, 1+lparams, ntypes, ra_env) in check_positivity_one ienv params nrecp (mind,i) mip.mind_nf_lc in let irecargs = Array.mapi check_one inds in let wfp = Rtree.mk_rec irecargs in - array_iter2 (fun ind wfpi -> check_subtree ind.mind_recargs wfpi) inds wfp + Array.iter2 (fun ind wfpi -> check_subtree ind.mind_recargs wfpi) inds wfp (************************************************************************) (************************************************************************) let check_inductive env kn mib = - Flags.if_verbose msgnl (str " checking ind: " ++ pr_mind kn); + Flags.if_verbose ppnl (str " checking ind: " ++ pr_mind kn); pp_flush (); (* check mind_constraints: should be consistent with env *) - let env = add_constraints mib.mind_constraints env in + let env = add_constraints (Univ.UContext.constraints mib.mind_universes) env in (* check mind_record : TODO ? check #constructor = 1 ? *) (* check mind_finite : always OK *) (* check mind_ntypes *) if Array.length mib.mind_packets <> mib.mind_ntypes then error "not the right number of packets"; - (* check mind_hyps: should be empty *) - if mib.mind_hyps <> empty_named_context then - error "section context not empty"; (* check mind_params_ctxt *) let params = mib.mind_params_ctxt in let _ = check_ctxt env params in diff --git a/checker/indtypes.mli b/checker/indtypes.mli index 6093752d..5188f80d 100644 --- a/checker/indtypes.mli +++ b/checker/indtypes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (ind, l) + | Ind (ind,_) + when (fst (lookup_mind_specif env ind)).mind_finite != CoFinite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match t with - | Ind ind - when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) + | Ind (ind,_) + when (fst (lookup_mind_specif env ind)).mind_finite == CoFinite -> (ind, l) | _ -> raise Not_found let inductive_params (mib,_) = mib.mind_nparams +(** Polymorphic inductives *) + +let inductive_instance mib = + if mib.mind_polymorphic then + UContext.instance mib.mind_universes + else Instance.empty + +let inductive_context mib = + if mib.mind_polymorphic then + instantiate_univ_context mib.mind_universes + else UContext.empty + +let instantiate_inductive_constraints mib u = + if mib.mind_polymorphic then + subst_instance_constraints u (UContext.constraints mib.mind_universes) + else Constraint.empty + (************************************************************************) (* Build the substitution that replaces Rels by the appropriate *) (* inductives *) -let ind_subst mind mib = +let ind_subst mind mib u = let ntypes = mib.mind_ntypes in - let make_Ik k = Ind (mind,ntypes-k-1) in - list_tabulate make_Ik ntypes + let make_Ik k = Ind ((mind,ntypes-k-1),u) in + List.init ntypes make_Ik (* Instantiate inductives in constructor type *) -let constructor_instantiate mind mib c = - let s = ind_subst mind mib in - substl s c +let constructor_instantiate mind u mib c = + let s = ind_subst mind mib u in + substl s (subst_instance_constr u c) -let instantiate_params full t args sign = +let instantiate_params full t u args sign = let fail () = - anomaly "instantiate_params: type, ctxt and args mismatch" in + anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in let (rem_args, subs, ty) = fold_rel_context (fun (_,copt,_) (largs,subs,ty) -> match (copt, largs, ty) with | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t) - | (Some b,_,LetIn(_,_,_,t)) -> (largs, (substl subs b)::subs, t) + | (Some b,_,LetIn(_,_,_,t)) -> + (largs, (substl subs (subst_instance_constr u b))::subs, t) | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) sign @@ -81,15 +101,15 @@ let instantiate_params full t args sign = if rem_args <> [] then fail(); substl subs ty -let full_inductive_instantiate mib params sign = +let full_inductive_instantiate mib u params sign = let dummy = Prop Null in let t = mkArity (sign,dummy) in - fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) + fst (destArity (instantiate_params true t u params mib.mind_params_ctxt)) -let full_constructor_instantiate ((mind,_),(mib,_),params) = - let inst_ind = constructor_instantiate mind mib in +let full_constructor_instantiate ((mind,_),u,(mib,_),params) = + let inst_ind = constructor_instantiate mind u mib in (fun t -> - instantiate_params true (inst_ind t) params mib.mind_params_ctxt) + instantiate_params true (inst_ind t) u params mib.mind_params_ctxt) (************************************************************************) (************************************************************************) @@ -119,12 +139,11 @@ Remark: Set (predicative) is encoded as Type(0) let sort_as_univ = function | Type u -> u -| Prop Null -> type0m_univ -| Prop Pos -> type0_univ +| Prop Null -> Univ.type0m_univ +| Prop Pos -> Univ.type0_univ let cons_subst u su subst = - try (u, sup su (List.assoc u subst)) :: List.remove_assoc u subst - with Not_found -> (u, su) :: subst + Univ.LMap.add u su subst let actualize_decl_level env lev t = let sign,s = dest_arity env t in @@ -157,65 +176,112 @@ let rec make_subst env = function (* (actualize_decl_level), then to the conclusion of the arity (via *) (* the substitution) *) let ctx,subst = make_subst env (sign, exp, []) in - if polymorphism_on_non_applied_parameters then - let s = fresh_local_univ () in - let t = actualize_decl_level env (Type s) t in - (na,None,t)::ctx, cons_subst u s subst - else d::ctx, subst | sign, [], _ -> (* Uniform parameters are exhausted *) - sign,[] + sign,Univ.LMap.empty | [], _, _ -> assert false + +exception SingletonInductiveBecomesProp of Id.t + let instantiate_universes env ctx ar argsorts = let args = Array.to_list argsorts in - let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in - let level = subst_large_constraints subst ar.poly_level in - ctx, - if is_type0m_univ level then Prop Null - else if is_type0_univ level then Prop Pos - else Type level - -let type_of_inductive_knowing_parameters env mip paramtyps = + let ctx,subst = make_subst env (ctx,ar.template_param_levels,args) in + let level = Univ.subst_univs_universe (Univ.make_subst subst) ar.template_level in + let ty = + (* Singleton type not containing types are interpretable in Prop *) + if Univ.is_type0m_univ level then Prop Null + (* Non singleton type not containing types are interpretable in Set *) + else if Univ.is_type0_univ level then Prop Pos + (* This is a Type with constraints *) + else Type level + in + (ctx, ty) + +(* Type of an inductive type *) + +let is_prop_sort = function + | Prop Null -> true + | _ -> false + +let type_of_inductive_gen ?(polyprop=true) env ((mib,mip),u) paramtyps = match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let ctx = List.rev mip.mind_arity_ctxt in - let ctx,s = instantiate_universes env ctx ar paramtyps in + | RegularArity a -> + if not mib.mind_polymorphic then a.mind_user_arity + else subst_instance_constr u a.mind_user_arity + | TemplateArity ar -> + let ctx = List.rev mip.mind_arity_ctxt in + let ctx,s = instantiate_universes env ctx ar paramtyps in + (* The Ocaml extraction cannot handle (yet?) "Prop-polymorphism", i.e. + the situation where a non-Prop singleton inductive becomes Prop + when applied to Prop params *) + if not polyprop && not (Univ.is_type0m_univ ar.template_level) && is_prop_sort s + then raise (SingletonInductiveBecomesProp mip.mind_typename); mkArity (List.rev ctx,s) +let type_of_inductive env pind = + type_of_inductive_gen env pind [||] + +let constrained_type_of_inductive env ((mib,mip),u as pind) = + let ty = type_of_inductive_gen env pind [||] in + let cst = instantiate_inductive_constraints mib u in + (ty, cst) + +let constrained_type_of_inductive_knowing_parameters env ((mib,mip),u as pind) args = + let ty = type_of_inductive_gen env pind args in + let cst = instantiate_inductive_constraints mib u in + (ty, cst) + +let type_of_inductive_knowing_parameters env mip args = + type_of_inductive_gen env mip args + (* Type of a (non applied) inductive type *) -let type_of_inductive env (_,mip) = +let type_of_inductive env mip = type_of_inductive_knowing_parameters env mip [||] (* The max of an array of universes *) let cumulate_constructor_univ u = function | Prop Null -> u - | Prop Pos -> sup type0_univ u - | Type u' -> sup u u' + | Prop Pos -> Univ.sup Univ.type0_univ u + | Type u' -> Univ.sup u u' let max_inductive_sort = - Array.fold_left cumulate_constructor_univ type0m_univ + Array.fold_left cumulate_constructor_univ Univ.type0m_univ (************************************************************************) (* Type of a constructor *) -let type_of_constructor cstr (mib,mip) = +let type_of_constructor_subst cstr u (mib,mip) = let ind = inductive_of_constructor cstr in let specif = mip.mind_user_lc in let i = index_of_constructor cstr in let nconstr = Array.length mip.mind_consnames in - if i > nconstr then error "Not enough constructors in the type"; - constructor_instantiate (fst ind) mib specif.(i-1) + if i > nconstr then error "Not enough constructors in the type."; + constructor_instantiate (fst ind) u mib specif.(i-1) -let arities_of_specif kn (mib,mip) = +let type_of_constructor_gen (cstr,u) (mib,mip as mspec) = + type_of_constructor_subst cstr u mspec + +let type_of_constructor cstru mspec = + type_of_constructor_gen cstru mspec + +let type_of_constructor_in_ctx cstr (mib,mip as mspec) = + let u = Univ.UContext.instance mib.mind_universes in + let c = type_of_constructor_gen (cstr, u) mspec in + (c, mib.mind_universes) + +let constrained_type_of_constructor (cstr,u as cstru) (mib,mip as ind) = + let ty = type_of_constructor_gen cstru ind in + let cst = instantiate_inductive_constraints mib u in + (ty, cst) + +let arities_of_specif (kn,u) (mib,mip) = let specif = mip.mind_nf_lc in - Array.map (constructor_instantiate kn mib) specif + Array.map (constructor_instantiate kn u mib) specif @@ -233,15 +299,15 @@ let error_elim_expln kp ki = let inductive_sort_family mip = match mip.mind_arity with - | Monomorphic s -> family_of_sort s.mind_sort - | Polymorphic _ -> InType + | RegularArity s -> family_of_sort s.mind_sort + | TemplateArity _ -> InType let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip -let get_instantiated_arity (mib,mip) params = +let get_instantiated_arity (ind,u) (mib,mip) params = let sign, s = mind_arity mip in - full_inductive_instantiate mib params sign, s + full_inductive_instantiate mib u params sign, s let elim_sorts (_,mip) = mip.mind_kelim @@ -254,10 +320,10 @@ let extended_rel_list n hyps = reln [] 1 hyps let build_dependent_inductive ind (_,mip) params = - let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in applist (Ind ind, - List.map (lift mip.mind_nrealargs_ctxt) params + List.map (lift mip.mind_nrealdecls) params @ extended_rel_list 0 realargs) (* This exception is local *) @@ -269,7 +335,7 @@ let check_allowed_sort ksort specif = raise (LocalArity (Some(ksort,s,error_elim_expln ksort s))) let is_correct_arity env c (p,pj) ind specif params = - let arsign,_ = get_instantiated_arity specif params in + let arsign,_ = get_instantiated_arity ind specif params in let rec srec env pt ar = let pt' = whd_betadeltaiota env pt in match pt', ar with @@ -305,18 +371,18 @@ let is_correct_arity env c (p,pj) ind specif params = (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) -let build_branches_type ind (_,mip as specif) params dep p = +let build_branches_type (ind,u) (_,mip as specif) params dep p = let build_one_branch i cty = - let typi = full_constructor_instantiate (ind,specif,params) cty in + let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (args,ccl) = decompose_prod_assum typi in let nargs = rel_context_length args in let (_,allargs) = decompose_app ccl in - let (lparams,vargs) = list_chop (inductive_params specif) allargs in + let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = if dep then let cstr = ith_constructor_of_inductive ind (i+1) in let dep_cstr = - applist (Construct cstr,lparams@extended_rel_list 0 args) in + applist (Construct (cstr,u),lparams@extended_rel_list 0 args) in vargs @ [dep_cstr] else vargs in @@ -330,12 +396,12 @@ let build_case_type dep p c realargs = let args = if dep then realargs@[c] else realargs in beta_appvect p (Array.of_list args) -let type_case_branches env (ind,largs) (p,pj) c = - let specif = lookup_mind_specif env ind in +let type_case_branches env (pind,largs) (p,pj) c = + let specif = lookup_mind_specif env (fst pind) in let nparams = inductive_params specif in - let (params,realargs) = list_chop nparams largs in - let dep = is_correct_arity env c (p,pj) ind specif params in - let lc = build_branches_type ind specif params dep p in + let (params,realargs) = List.chop nparams largs in + let dep = is_correct_arity env c (p,pj) pind specif params in + let lc = build_branches_type pind specif params dep p in let ty = build_case_type dep p c realargs in (lc, ty) @@ -346,9 +412,10 @@ let type_case_branches env (ind,largs) (p,pj) c = let check_case_info env indsp ci = let (mib,mip) = lookup_mind_specif env indsp in if - not (eq_ind indsp ci.ci_ind) or - (mib.mind_nparams <> ci.ci_npar) or - (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls) + not (eq_ind indsp ci.ci_ind) || + (mib.mind_nparams <> ci.ci_npar) || + (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls) || + (mip.mind_consnrealargs <> ci.ci_cstr_nargs) then raise (TypeError(env,WrongCaseInfo(indsp,ci))) (************************************************************************) @@ -399,54 +466,70 @@ type subterm_spec = | Dead_code | Not_subterm -let spec_of_tree t = lazy - (if Rtree.eq_rtree (=) (Lazy.force t) mk_norec - then Not_subterm - else Subterm(Strict,Lazy.force t)) +let eq_recarg r1 r2 = match r1, r2 with +| Norec, Norec -> true +| Mrec i1, Mrec i2 -> Names.eq_ind i1 i2 +| Imbr i1, Imbr i2 -> Names.eq_ind i1 i2 +| _ -> false + +let eq_wf_paths = Rtree.equal eq_recarg + +let pp_recarg = function + | Norec -> Pp.str "Norec" + | Mrec i -> Pp.str ("Mrec "^MutInd.to_string (fst i)) + | Imbr i -> Pp.str ("Imbr "^MutInd.to_string (fst i)) + +let pp_wf_paths = Rtree.pp_tree pp_recarg + +let inter_recarg r1 r2 = match r1, r2 with +| Norec, Norec -> Some r1 +| Mrec i1, Mrec i2 +| Imbr i1, Imbr i2 +| Mrec i1, Imbr i2 -> if Names.eq_ind i1 i2 then Some r1 else None +| Imbr i1, Mrec i2 -> if Names.eq_ind i1 i2 then Some r2 else None +| _ -> None + +let inter_wf_paths = Rtree.inter eq_recarg inter_recarg Norec + +let incl_wf_paths = Rtree.incl eq_recarg inter_recarg Norec + +let spec_of_tree t = + if eq_wf_paths t mk_norec + then Not_subterm + else Subterm (Strict, t) + +let inter_spec s1 s2 = + match s1, s2 with + | _, Dead_code -> s1 + | Dead_code, _ -> s2 + | Not_subterm, _ -> s1 + | _, Not_subterm -> s2 + | Subterm (a1,t1), Subterm (a2,t2) -> + Subterm (size_glb a1 a2, inter_wf_paths t1 t2) let subterm_spec_glb = - let glb2 s1 s2 = - match s1,s2 with - _, Dead_code -> s1 - | Dead_code, _ -> s2 - | Not_subterm, _ -> Not_subterm - | _, Not_subterm -> Not_subterm - | Subterm (a1,t1), Subterm (a2,t2) -> - if Rtree.eq_rtree (=) t1 t2 then Subterm (size_glb a1 a2, t1) - (* branches do not return objects with same spec *) - else Not_subterm in - Array.fold_left glb2 Dead_code + Array.fold_left inter_spec Dead_code type guard_env = { env : env; (* dB of last fixpoint *) rel_min : int; - (* inductive of recarg of each fixpoint *) - inds : inductive array; - (* the recarg information of inductive family *) - recvec : wf_paths array; (* dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } -let make_renv env minds recarg (kn,tyi) = - let mib = lookup_mind kn env in - let mind_recvec = - Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in +let make_renv env recarg tree = { env = env; - rel_min = recarg+2; - inds = minds; - recvec = mind_recvec; - genv = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] } + rel_min = recarg+2; (* recarg = 0 ==> Rel 1 -> recarg; Rel 2 -> fix *) + genv = [Lazy.lazy_from_val(Subterm(Large,tree))] } let push_var renv (x,ty,spec) = - { renv with - env = push_rel (x,None,ty) renv.env; + { env = push_rel (x,None,ty) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } let assign_var_spec renv (i,spec) = - { renv with genv = list_assign renv.genv (i-1) spec } + { renv with genv = List.assign renv.genv (i-1) spec } let push_var_renv renv (x,ty) = push_var renv (x,ty,Lazy.lazy_from_val Not_subterm) @@ -458,15 +541,13 @@ let subterm_var p renv = let push_ctxt_renv renv ctxt = let n = rel_context_length ctxt in - { renv with - env = push_rel_context ctxt renv.env; + { env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } let push_fix_renv renv (_,v,_ as recdef) = let n = Array.length v in - { renv with - env = push_rec_types recdef renv.env; + { env = push_rec_types recdef renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } @@ -524,14 +605,171 @@ let branches_specif renv c_spec ci = Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) -> let vra = Array.of_list (dest_subterms t).(i) in assert (nca = Array.length vra); - Array.map - (fun t -> Lazy.force (spec_of_tree (lazy t))) - vra - | Dead_code -> Array.create nca Dead_code - | _ -> Array.create nca Not_subterm) in - list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca) + Array.map spec_of_tree vra + | Dead_code -> Array.make nca Dead_code + | _ -> Array.make nca Not_subterm) in + List.init nca (fun j -> lazy (Lazy.force lvra).(j))) car +let check_inductive_codomain env p = + let absctx, ar = dest_lam_assum env p in + let env = push_rel_context absctx env in + let arctx, s = dest_prod_assum env ar in + let env = push_rel_context arctx env in + let i,l' = decompose_app (whd_betadeltaiota env s) in + match i with Ind _ -> true | _ -> false + +(* The following functions are almost duplicated from indtypes.ml, except +that they carry here a poorer environment (containing less information). *) +let ienv_push_var (env, lra) (x,a,ra) = +(push_rel (x,None,a) env, (Norec,ra)::lra) + +let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = + let mib = Environ.lookup_mind mind env in + let ntypes = mib.mind_ntypes in + let push_ind specif env = + push_rel (Anonymous,None, + hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) env + in + let env = Array.fold_right push_ind mib.mind_packets env in + let rc = Array.mapi (fun j t -> (Imbr (mind,j),t)) (Rtree.mk_rec_calls ntypes) in + let lra_ind = Array.rev_to_list rc in + let ra_env = List.map (fun (r,t) -> (r,Rtree.lift ntypes t)) ra_env in + (env, lra_ind @ ra_env) + +let rec ienv_decompose_prod (env,_ as ienv) n c = + if Int.equal n 0 then (ienv,c) else + let c' = whd_betadeltaiota env c in + match c' with + Prod(na,a,b) -> + let ienv' = ienv_push_var ienv (na,a,mk_norec) in + ienv_decompose_prod ienv' (n-1) b + | _ -> assert false + +let lambda_implicit_lift n a = + let level = Level.make (DirPath.make [Id.of_string "implicit"]) 0 in + let implicit_sort = Sort (Type (Universe.make level)) in + let lambda_implicit a = Lambda (Anonymous, implicit_sort, a) in + iterate lambda_implicit n (lift n a) + +let abstract_mind_lc ntyps npars lc = + if Int.equal npars 0 then + lc + else + let make_abs = + List.init ntyps + (function i -> lambda_implicit_lift npars (Rel (i+1))) + in + Array.map (substl make_abs) lc + +(* [get_recargs_approx env tree ind args] builds an approximation of the recargs +tree for ind, knowing args. The argument tree is used to know when candidate +nested types should be traversed, pruning the tree otherwise. This code is very +close to check_positive in indtypes.ml, but does no positivy check and does not +compute the number of recursive arguments. *) +let get_recargs_approx env tree ind args = + let rec build_recargs (env, ra_env as ienv) tree c = + let x,largs = decompose_app (whd_betadeltaiota env c) in + match x with + | Prod (na,b,d) -> + assert (List.is_empty largs); + build_recargs (ienv_push_var ienv (na, b, mk_norec)) tree d + | Rel k -> + (* Free variables are allowed and assigned Norec *) + (try snd (List.nth ra_env (k-1)) + with Failure _ | Invalid_argument _ -> mk_norec) + | Ind ind_kn -> + (* When the inferred tree allows it, we consider that we have a potential + nested inductive type *) + begin match dest_recarg tree with + | Imbr kn' | Mrec kn' when eq_ind (fst ind_kn) kn' -> + build_recargs_nested ienv tree (ind_kn, largs) + | _ -> mk_norec + end + | err -> + mk_norec + + and build_recargs_nested (env,ra_env as ienv) tree (((mind,i),u), largs) = + (* If the infered tree already disallows recursion, no need to go further *) + if eq_wf_paths tree mk_norec then tree + else + let mib = Environ.lookup_mind mind env in + let auxnpar = mib.mind_nparams_rec in + let nonrecpar = mib.mind_nparams - auxnpar in + let (lpar,_) = List.chop auxnpar largs in + let auxntyp = mib.mind_ntypes in + (* Extends the environment with a variable corresponding to + the inductive def *) + let (env',_ as ienv') = ienv_push_inductive ienv ((mind,u),lpar) in + (* Parameters expressed in env' *) + let lpar' = List.map (lift auxntyp) lpar in + (* In case of mutual inductive types, we use the recargs tree which was + computed statically. This is fine because nested inductive types with + mutually recursive containers are not supported. *) + let trees = + if Int.equal auxntyp 1 then [|dest_subterms tree|] + else Array.map (fun mip -> dest_subterms mip.mind_recargs) mib.mind_packets + in + let mk_irecargs j specif = + (* The nested inductive type with parameters removed *) + let auxlcvect = abstract_mind_lc auxntyp auxnpar specif.mind_nf_lc in + let paths = Array.mapi + (fun k c -> + let c' = hnf_prod_applist env' c lpar' in + (* skip non-recursive parameters *) + let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in + build_recargs_constructors ienv' trees.(j).(k) c') + auxlcvect + in + mk_paths (Imbr (mind,j)) paths + in + let irecargs = Array.mapi mk_irecargs mib.mind_packets in + (Rtree.mk_rec irecargs).(i) + + and build_recargs_constructors ienv trees c = + let rec recargs_constr_rec (env,ra_env as ienv) trees lrec c = + let x,largs = decompose_app (whd_betadeltaiota env c) in + match x with + + | Prod (na,b,d) -> + let () = assert (List.is_empty largs) in + let recarg = build_recargs ienv (List.hd trees) b in + let ienv' = ienv_push_var ienv (na,b,mk_norec) in + recargs_constr_rec ienv' (List.tl trees) (recarg::lrec) d + | hd -> + List.rev lrec + in + recargs_constr_rec ienv trees [] c + in + (* starting with ra_env = [] seems safe because any unbounded Rel will be + assigned Norec *) + build_recargs_nested (env,[]) tree (ind, args) + +(* [restrict_spec env spec p] restricts the size information in spec to what is + allowed to flow through a match with predicate p in environment env. *) +let restrict_spec env spec p = + if spec = Not_subterm then spec + else let absctx, ar = dest_lam_assum env p in + (* Optimization: if the predicate is not dependent, no restriction is needed + and we avoid building the recargs tree. *) + if noccur_with_meta 1 (rel_context_length absctx) ar then spec + else + let env = push_rel_context absctx env in + let arctx, s = dest_prod_assum env ar in + let env = push_rel_context arctx env in + let i,args = decompose_app (whd_betadeltaiota env s) in + match i with + | Ind i -> + begin match spec with + | Dead_code -> spec + | Subterm(st,tree) -> + let recargs = get_recargs_approx env tree i args in + let recargs = inter_wf_paths tree recargs in + Subterm(st,recargs) + | _ -> assert false + end + | _ -> Not_subterm + (* [subterm_specif renv t] computes the recursive structure of [t] and compare its size with the size of the initial recursive argument of the fixpoint we are checking. [renv] collects such information @@ -545,36 +783,40 @@ let rec subterm_specif renv stack t = match f with | Rel k -> subterm_var k renv - | Case (ci,_,c,lbr) -> - let stack' = push_stack_closures renv l stack in - let cases_spec = branches_specif renv - (lazy_subterm_specif renv [] c) ci in - let stl = - Array.mapi (fun i br' -> - let stack_br = push_stack_args (cases_spec.(i)) stack' in - subterm_specif renv stack_br br') - lbr in - subterm_spec_glb stl - - | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> - (* when proving that the fixpoint f(x)=e is less than n, it is enough - to prove that e is less than n assuming f is less than n - furthermore when f is applied to a term which is strictly less than - n, one may assume that x itself is strictly less than n - *) - let (ctxt,clfix) = dest_prod renv.env typarray.(i) in - let oind = - let env' = push_rel_context ctxt renv.env in - try Some(fst(find_inductive env' clfix)) - with Not_found -> None in - (match oind with - None -> Not_subterm (* happens if fix is polymorphic *) - | Some ind -> - let nbfix = Array.length typarray in - let recargs = lookup_subterms renv.env ind in - (* pushing the fixpoints *) - let renv' = push_fix_renv renv recdef in - let renv' = + | Case (ci,p,c,lbr) -> + let stack' = push_stack_closures renv l stack in + let cases_spec = + branches_specif renv (lazy_subterm_specif renv [] c) ci + in + let stl = + Array.mapi (fun i br' -> + let stack_br = push_stack_args (cases_spec.(i)) stack' in + subterm_specif renv stack_br br') + lbr in + let spec = subterm_spec_glb stl in + restrict_spec renv.env spec p + + | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> + (* when proving that the fixpoint f(x)=e is less than n, it is enough + to prove that e is less than n assuming f is less than n + furthermore when f is applied to a term which is strictly less than + n, one may assume that x itself is strictly less than n + *) + if not (check_inductive_codomain renv.env typarray.(i)) then Not_subterm + else + let (ctxt,clfix) = dest_prod renv.env typarray.(i) in + let oind = + let env' = push_rel_context ctxt renv.env in + try Some(fst(find_inductive env' clfix)) + with Not_found -> None in + (match oind with + None -> Not_subterm (* happens if fix is polymorphic *) + | Some ind -> + let nbfix = Array.length typarray in + let recargs = lookup_subterms renv.env ind in + (* pushing the fixpoints *) + let renv' = push_fix_renv renv recdef in + let renv' = (* Why Strict here ? To be general, it could also be Large... *) assign_var_spec renv' @@ -618,9 +860,10 @@ and extract_stack renv a = function (* Check size x is a correct size for recursive calls. *) -let check_is_subterm x = +let check_is_subterm x tree = match Lazy.force x with - Subterm (Strict,_) | Dead_code -> true + | Subterm (Strict,tree') -> incl_wf_paths tree tree' + | Dead_code -> true | _ -> false (************************************************************************) @@ -643,10 +886,38 @@ let error_illegal_rec_call renv fx (arg_renv,arg) = let error_partial_apply renv fx = raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx)) +let filter_stack_domain env ci p stack = + let absctx, ar = dest_lam_assum env p in + (* Optimization: if the predicate is not dependent, no restriction is needed + and we avoid building the recargs tree. *) + if noccur_with_meta 1 (rel_context_length absctx) ar then stack + else let env = push_rel_context absctx env in + let rec filter_stack env ar stack = + let t = whd_betadeltaiota env ar in + match stack, t with + | elt :: stack', Prod (n,a,c0) -> + let d = (n,None,a) in + let ty, args = decompose_app (whd_betadeltaiota env a) in + let elt = match ty with + | Ind ind -> + let spec' = stack_element_specif elt in + (match (Lazy.force spec') with + | Not_subterm | Dead_code -> elt + | Subterm(s,path) -> + let recargs = get_recargs_approx env path ind args in + let path = inter_wf_paths path recargs in + SArg (lazy (Subterm(s,path)))) + | _ -> (SArg (lazy Not_subterm)) + in + elt :: filter_stack (push_rel d env) c0 stack' + | _,_ -> List.fold_right (fun _ l -> SArg (lazy Not_subterm) :: l) stack [] + in + filter_stack env ar stack + (* Check if [def] is a guarded fixpoint body with decreasing arg. given [recpos], the decreasing arguments of each mutually defined fixpoint. *) -let check_one_fix renv recpos def = +let check_one_fix renv recpos trees def = let nfi = Array.length recpos in (* Checks if [t] only make valid recursive calls *) @@ -658,7 +929,7 @@ let check_one_fix renv recpos def = match f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) - if renv.rel_min <= p & p < renv.rel_min+nfi then + if renv.rel_min <= p && p < renv.rel_min+nfi then begin List.iter (check_rec_call renv []) l; (* the position of the invoked fixpoint: *) @@ -668,9 +939,10 @@ let check_one_fix renv recpos def = let stack' = push_stack_closures renv l stack in if List.length stack' <= np then error_partial_apply renv glob else + (* Retrieve the expected tree for the argument *) (* Check the decreasing arg is smaller *) let z = List.nth stack' np in - if not (check_is_subterm (stack_element_specif z)) then + if not (check_is_subterm (stack_element_specif z) trees.(glob)) then begin match z with |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') |SArg _ -> error_partial_apply renv glob @@ -694,6 +966,7 @@ let check_one_fix renv recpos def = let case_spec = branches_specif renv (lazy_subterm_specif renv [] c_0) ci in let stack' = push_stack_closures renv l stack in + let stack' = filter_stack_domain renv.env ci p stack' in Array.iteri (fun k br' -> let stack_br = push_stack_args case_spec.(k) stack' in check_rec_call renv stack_br br') lrest @@ -725,11 +998,11 @@ let check_one_fix renv recpos def = else check_rec_call renv' [] body) bodies - | Const kn -> + | Const (kn,u) -> if evaluable_constant kn renv.env then try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> - let value = (applist(constant_value renv.env kn, l)) in + let value = (applist(constant_value renv.env (kn,u), l)) in check_rec_call renv stack value else List.iter (check_rec_call renv []) l @@ -753,16 +1026,7 @@ let check_one_fix renv recpos def = | (Ind _ | Construct _) -> List.iter (check_rec_call renv []) l - | Var id -> - begin - match pi2 (lookup_named id renv.env) with - | None -> - List.iter (check_rec_call renv []) l - | Some c -> - try List.iter (check_rec_call renv []) l - with (FixGuardError _) -> - check_rec_call renv stack (applist(c,l)) - end + | Var _ -> anomaly (Pp.str "Section variable in Coqchk !") | Sort _ -> assert (l = []) @@ -771,6 +1035,8 @@ let check_one_fix renv recpos def = | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *) + | Proj (p, c) -> check_rec_call renv [] c + and check_nested_fix_body renv decr recArgsDecrArg body = if decr = 0 then check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body @@ -780,7 +1046,7 @@ let check_one_fix renv recpos def = check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in check_nested_fix_body renv' (decr-1) recArgsDecrArg b - | _ -> anomaly "Not enough abstractions in fix body" + | _ -> anomaly (Pp.str "Not enough abstractions in fix body") in check_rec_call renv [] def @@ -789,12 +1055,12 @@ let check_one_fix renv recpos def = let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = let nbfix = Array.length bodies in if nbfix = 0 - or Array.length nvect <> nbfix - or Array.length types <> nbfix - or Array.length names <> nbfix - or bodynum < 0 - or bodynum >= nbfix - then anomaly "Ill-formed fix term"; + || Array.length nvect <> nbfix + || Array.length types <> nbfix + || Array.length names <> nbfix + || bodynum < 0 + || bodynum >= nbfix + then anomaly (Pp.str "Ill-formed fix term"); let fixenv = push_rec_types recdef env in let raise_err env i err = error_ill_formed_rec_body env err names i in @@ -815,20 +1081,25 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = raise_err env i (RecursionNotOnInductiveType a) in (mind, (env', b)) else check_occur env' (n+1) b - else anomaly "check_one_fix: Bad occurrence of recursive call" + else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call") | _ -> raise_err env i NotEnoughAbstractionInFixBody in check_occur fixenv 1 def in (* Do it on every fixpoint *) - let rv = array_map2_i find_ind nvect bodies in + let rv = Array.map2_i find_ind nvect bodies in (Array.map fst rv, Array.map snd rv) let check_fix env ((nvect,_),(names,_,bodies as _recdef) as fix) = let (minds, rdef) = inductive_of_mutfix env fix in + let get_tree (kn,i) = + let mib = Environ.lookup_mind kn env in + mib.mind_packets.(i).mind_recargs + in + let trees = Array.map get_tree minds in for i = 0 to Array.length bodies - 1 do let (fenv,body) = rdef.(i) in - let renv = make_renv fenv minds nvect.(i) minds.(i) in - try check_one_fix renv nvect body + let renv = make_renv fenv nvect.(i) trees.(i) in + try check_one_fix renv nvect trees body with FixGuardError (fixenv,err) -> error_ill_formed_rec_body fixenv err names i done @@ -844,7 +1115,7 @@ let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; exception CoFixGuardError of env * guard_error let anomaly_ill_typed () = - anomaly "check_one_cofix: too many arguments applied to constructor" + anomaly ~label:"check_one_cofix" (Pp.str "too many arguments applied to constructor") let rec codomain_is_coind env c = let b = whd_betadeltaiota env c in @@ -857,7 +1128,7 @@ let rec codomain_is_coind env c = raise (CoFixGuardError (env, CodomainNotInductiveType b))) let check_one_cofix env nbfix def deftype = - let rec check_rec_call env alreadygrd n vlra t = + let rec check_rec_call env alreadygrd n tree vlra t = if not (noccur_with_meta n nbfix t) then let c,args = decompose_app (whd_betadeltaiota env t) in match c with @@ -868,12 +1139,11 @@ let check_one_cofix env nbfix def deftype = raise (CoFixGuardError (env,UnguardedRecursiveCall t)) else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) - - | Construct (_,i as cstr_kn) -> + | Construct ((_,i as cstr_kn),u) -> let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in - let realargs = list_skipn mib.mind_nparams args in + let realargs = List.skipn mib.mind_nparams args in let rec process_args_of_constr = function | (t::lr), (rar::lrar) -> if rar = mk_norec then @@ -881,10 +1151,10 @@ let check_one_cofix env nbfix def deftype = then process_args_of_constr (lr, lrar) else raise (CoFixGuardError (env,RecCallInNonRecArgOfConstructor t)) - else - let spec = dest_subterms rar in - check_rec_call env true n spec t; - process_args_of_constr (lr, lrar) + else begin + check_rec_call env true n rar (dest_subterms rar) t; + process_args_of_constr (lr, lrar) + end | [],_ -> () | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) @@ -893,44 +1163,52 @@ let check_one_cofix env nbfix def deftype = assert (args = []); if noccur_with_meta n nbfix a then let env' = push_rel (x, None, a) env in - check_rec_call env' alreadygrd (n+1) vlra b + check_rec_call env' alreadygrd (n+1) tree vlra b else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) | CoFix (j,(_,varit,vdefs as recdef)) -> if List.for_all (noccur_with_meta n nbfix) args then - if array_for_all (noccur_with_meta n nbfix) varit then + if Array.for_all (noccur_with_meta n nbfix) varit then let nbfix = Array.length vdefs in let env' = push_rec_types recdef env in - (Array.iter (check_rec_call env' alreadygrd (n+nbfix) vlra) vdefs; - List.iter (check_rec_call env alreadygrd n vlra) args) + (Array.iter (check_rec_call env' alreadygrd (n+nbfix) tree vlra) vdefs; + List.iter (check_rec_call env alreadygrd n tree vlra) args) else raise (CoFixGuardError (env,RecCallInTypeOfDef c)) else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) | Case (_,p,tm,vrest) -> - if (noccur_with_meta n nbfix p) then - if (noccur_with_meta n nbfix tm) then - if (List.for_all (noccur_with_meta n nbfix) args) then - Array.iter (check_rec_call env alreadygrd n vlra) vrest - else - raise (CoFixGuardError (env,RecCallInCaseFun c)) - else - raise (CoFixGuardError (env,RecCallInCaseArg c)) - else - raise (CoFixGuardError (env,RecCallInCasePred c)) + begin + let tree = match restrict_spec env (Subterm (Strict, tree)) p with + | Dead_code -> assert false + | Subterm (_, tree') -> tree' + | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) + in + if (noccur_with_meta n nbfix p) then + if (noccur_with_meta n nbfix tm) then + if (List.for_all (noccur_with_meta n nbfix) args) then + let vlra = dest_subterms tree in + Array.iter (check_rec_call env alreadygrd n tree vlra) vrest + else + raise (CoFixGuardError (env,RecCallInCaseFun c)) + else + raise (CoFixGuardError (env,RecCallInCaseArg c)) + else + raise (CoFixGuardError (env,RecCallInCasePred c)) + end | Meta _ -> () | Evar _ -> - List.iter (check_rec_call env alreadygrd n vlra) args + List.iter (check_rec_call env alreadygrd n tree vlra) args | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let (mind, _) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in - check_rec_call env false 1 (dest_subterms vlra) def + check_rec_call env false 1 vlra (dest_subterms vlra) def (* The function which checks that the whole block of definitions satisfies the guarded condition *) diff --git a/checker/inductive.mli b/checker/inductive.mli index 0c1117f5..78fb0bdd 100644 --- a/checker/inductive.mli +++ b/checker/inductive.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr -> inductive * constr list +val find_rectype : env -> constr -> pinductive * constr list type mind_specif = mutual_inductive_body * one_inductive_body @@ -23,12 +22,14 @@ type mind_specif = mutual_inductive_body * one_inductive_body Raises [Not_found] if the inductive type is not found. *) val lookup_mind_specif : env -> inductive -> mind_specif -val type_of_inductive : env -> mind_specif -> constr +val inductive_instance : mutual_inductive_body -> Univ.universe_instance + +val type_of_inductive : env -> mind_specif puniverses -> constr (* Return type as quoted by the user *) -val type_of_constructor : constructor -> mind_specif -> constr +val type_of_constructor : pconstructor -> mind_specif -> constr -val arities_of_specif : mutual_inductive -> mind_specif -> constr array +val arities_of_specif : mutual_inductive puniverses -> mind_specif -> constr array (* [type_case_branches env (I,args) (p:A) c] computes useful types about the following Cases expression: @@ -37,7 +38,7 @@ val arities_of_specif : mutual_inductive -> mind_specif -> constr array introduced by products) and the type for the whole expression. *) val type_case_branches : - env -> inductive * constr list -> constr * constr -> constr + env -> pinductive * constr list -> constr * constr -> constr -> constr array * constr (* Check a [case_info] actually correspond to a Case expression on the @@ -51,12 +52,12 @@ val check_cofix : env -> cofixpoint -> unit (*s Support for sort-polymorphic inductive types *) val type_of_inductive_knowing_parameters : - env -> one_inductive_body -> constr array -> constr + env -> mind_specif puniverses -> constr array -> constr val max_inductive_sort : sorts array -> Univ.universe val instantiate_universes : env -> rel_context -> - polymorphic_arity -> constr array -> rel_context * sorts + template_arity -> constr array -> rel_context * sorts (***************************************************************) (* Debug *) @@ -70,10 +71,6 @@ type guard_env = { env : env; (* dB of last fixpoint *) rel_min : int; - (* inductive of recarg of each fixpoint *) - inds : inductive array; - (* the recarg information of inductive family *) - recvec : wf_paths array; (* dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index dc3ed452..998e23c6 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -2,8 +2,8 @@ open Pp open Util open Names +open Cic open Term -open Inductive open Reduction open Typeops open Indtypes @@ -12,371 +12,132 @@ open Subtyping open Declarations open Environ -(************************************************************************) -(* Checking constants *) +(** {6 Checking constants } *) let refresh_arity ar = let ctxt, hd = decompose_prod_assum ar in match hd with Sort (Type u) when not (Univ.is_univ_variable u) -> - let u' = Univ.fresh_local_univ() in - mkArity (ctxt,Type u'), - Univ.enforce_geq u' u Univ.empty_constraint + let u' = Univ.Universe.make (Univ.Level.make empty_dirpath 1) in + mkArity (ctxt,Prop Null), + Univ.enforce_leq u u' Univ.empty_constraint | _ -> ar, Univ.empty_constraint let check_constant_declaration env kn cb = - Flags.if_verbose msgnl (str " checking cst: " ++ prcon kn); -(* let env = add_constraints cb.const_constraints env in*) - let env' = check_named_ctxt env cb.const_hyps in - (match cb.const_type with - NonPolymorphicType ty -> - let ty, cu = refresh_arity ty in + Flags.if_verbose ppnl (str " checking cst: " ++ prcon kn); pp_flush (); + let env' = add_constraints (Univ.UContext.constraints cb.const_universes) env in + let envty, ty = + match cb.const_type with + RegularArity ty -> + let ty', cu = refresh_arity ty in let envty = add_constraints cu env' in - let _ = infer_type envty ty in - (match body_of_constant cb with - | Some bd -> - let j = infer env' (force_constr bd) in - conv_leq envty j ty - | None -> ()) - | PolymorphicArity(ctxt,par) -> - let _ = check_ctxt env ctxt in - check_polymorphic_arity env ctxt par); - add_constant kn cb env - -(************************************************************************) -(* Checking modules *) - - -exception Not_path - -let path_of_mexpr = function - | SEBident mp -> mp - | _ -> raise Not_path - -let is_modular = function - | SFBmodule _ | SFBmodtype _ -> true - | SFBconst _ | SFBmind _ -> false - -let rec list_split_assoc ((k,m) as km) rev_before = function - | [] -> raise Not_found - | (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after - | h::tail -> list_split_assoc km (h::rev_before) tail - -let check_definition_sub env cb1 cb2 = - let check_type env t1 t2 = - - (* If the type of a constant is generated, it may mention - non-variable algebraic universes that the general conversion - algorithm is not ready to handle. Anyway, generated types of - constants are functions of the body of the constant. If the - bodies are the same in environments that are subtypes one of - the other, the types are subtypes too (i.e. if Gamma <= Gamma', - Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T'). - Hence they don't have to be checked again *) - - let t1,t2 = - if isArity t2 then - let (ctx2,s2) = destArity t2 in - match s2 with - | Type v when not (Univ.is_univ_variable v) -> - (* The type in the interface is inferred and is made of algebraic - universes *) - begin try - let (ctx1,s1) = dest_arity env t1 in - match s1 with - | Type u when not (Univ.is_univ_variable u) -> - (* Both types are inferred, no need to recheck them. We - cheat and collapse the types to Prop *) - mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null) - | Prop _ -> - (* The type in the interface is inferred, it may be the case - that the type in the implementation is smaller because - the body is more reduced. We safely collapse the upper - type to Prop *) - mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null) - | Type _ -> - (* The type in the interface is inferred and the type in the - implementation is not inferred or is inferred but from a - more reduced body so that it is just a variable. Since - constraints of the form "univ <= max(...)" are not - expressible in the system of algebraic universes: we fail - (the user has to use an explicit type in the interface *) - raise Reduction.NotConvertible - with UserError _ (* "not an arity" *) -> - raise Reduction.NotConvertible end - | _ -> t1,t2 - else - (t1,t2) in - Reduction.conv_leq env t1 t2 + let _ = infer_type envty ty' in envty, ty + | TemplateArity(ctxt,par) -> + let _ = check_ctxt env' ctxt in + check_polymorphic_arity env' ctxt par; + env', it_mkProd_or_LetIn (Sort(Type par.template_level)) ctxt + in + let () = + match body_of_constant cb with + | Some bd -> + (match cb.const_proj with + | None -> let j = infer envty bd in + conv_leq envty j ty + | Some pb -> + let env' = add_constant kn cb env' in + let j = infer env' bd in + conv_leq envty j ty) + | None -> () in - assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; - (*Start by checking types*) - let typ1 = Typeops.type_of_constant_type env cb1.const_type in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in - check_type env typ1 typ2; - (* In the spirit of subtyping.check_constant, we accept - any implementations of parameters and opaques terms, - as long as they have the right type *) - (match cb2.const_body with - | Undef _ | OpaqueDef _ -> () - | Def lc2 -> - (match cb1.const_body with - | Def lc1 -> - let c1 = force_constr lc1 in - let c2 = force_constr lc2 in - Reduction.conv env c1 c2 - (* Coq only places transparent cb in With_definition_body *) - | _ -> assert false)) + if cb.const_polymorphic then add_constant kn cb env + else add_constant kn cb env' -let lookup_modtype mp env = - try Environ.lookup_modtype mp env - with Not_found -> - failwith ("Unknown module type: "^string_of_mp mp) +(** {6 Checking modules } *) + +(** We currently ignore the [mod_type_alg] and [typ_expr_alg] fields. + The only delicate part is when [mod_expr] is an algebraic expression : + we need to expand it before checking it is indeed a subtype of [mod_type]. + Fortunately, [mod_expr] cannot contain any [MEwith]. *) let lookup_module mp env = try Environ.lookup_module mp env with Not_found -> failwith ("Unknown module: "^string_of_mp mp) -let rec check_with env mtb with_decl mp= - match with_decl with - | With_definition_body (idl,c) -> - check_with_def env mtb (idl,c) mp; - mtb - | With_module_body (idl,mp1) -> - check_with_mod env mtb (idl,mp1) mp; - mtb - -and check_with_def env mtb (idl,c) mp = - let sig_b = match mtb with - | SEBstruct(sig_b) -> - sig_b - | _ -> error_signature_expected mtb - in - let id,idl = match idl with - | [] -> assert false - | id::idl -> id,idl +let mk_mtb mp sign delta = + { mod_mp = mp; + mod_expr = Abstract; + mod_type = sign; + mod_type_alg = None; + mod_constraints = Univ.Constraint.empty; + mod_delta = delta; + mod_retroknowledge = []; } + +let rec check_module env mp mb = + let (_:module_signature) = + check_signature env mb.mod_type mb.mod_mp mb.mod_delta in - let l = label_of_id id in - try - let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in - let before = List.rev rev_before in - let env' = Modops.add_signature mp before empty_delta_resolver env in - if idl = [] then - let cb = match spec with - SFBconst cb -> cb - | _ -> error_not_a_constant l - in - check_definition_sub env' c cb - else - let old = match spec with - SFBmodule msb -> msb - | _ -> error_not_a_module l - in - begin - match old.mod_expr with - | None -> - check_with_def env' old.mod_type (idl,c) (MPdot(mp,l)) - | Some msb -> - error_a_generative_module_expected l - end - with - Not_found -> error_no_such_label l - | Reduction.NotConvertible -> error_with_incorrect l - -and check_with_mod env mtb (idl,mp1) mp = - let sig_b = - match mtb with - | SEBstruct(sig_b) -> - sig_b - | _ -> error_signature_expected mtb in - let id,idl = match idl with - | [] -> assert false - | id::idl -> id,idl + let optsign = match mb.mod_expr with + |Struct sign -> Some (check_signature env sign mb.mod_mp mb.mod_delta) + |Algebraic me -> Some (check_mexpression env me mb.mod_mp mb.mod_delta) + |Abstract|FullStruct -> None in - let l = label_of_id id in - try - let rev_before,spec,after = list_split_assoc (l,false) [] sig_b in - let before = List.rev rev_before in - let env' = Modops.add_signature mp before empty_delta_resolver env in - if idl = [] then - let _ = match spec with - SFBmodule msb -> msb - | _ -> error_not_a_module l - in - let (_:module_body) = (Environ.lookup_module mp1 env) in () - else - let old = match spec with - SFBmodule msb -> msb - | _ -> error_not_a_module l - in - begin - match old.mod_expr with - None -> - check_with_mod env' - old.mod_type (idl,mp1) (MPdot(mp,l)) - | Some msb -> - error_a_generative_module_expected l - end - with - Not_found -> error_no_such_label l - | Reduction.NotConvertible -> error_with_incorrect l + match optsign with + |None -> () + |Some sign -> + let mtb1 = mk_mtb mp sign mb.mod_delta + and mtb2 = mk_mtb mp mb.mod_type mb.mod_delta in + let env = add_module_type mp mtb1 env in + Subtyping.check_subtypes env mtb1 mtb2 and check_module_type env mty = - let (_:struct_expr_body) = - check_modtype env mty.typ_expr mty.typ_mp mty.typ_delta in + let (_:module_signature) = + check_signature env mty.mod_type mty.mod_mp mty.mod_delta in () - -and check_module env mp mb = - match mb.mod_expr, mb.mod_type with - | None,mtb -> - let (_:struct_expr_body) = - check_modtype env mtb mb.mod_mp mb.mod_delta in () - | Some mexpr, mtb when mtb==mexpr -> - let (_:struct_expr_body) = - check_modtype env mtb mb.mod_mp mb.mod_delta in () - | Some mexpr, _ -> - let sign = check_modexpr env mexpr mb.mod_mp mb.mod_delta in - let (_:struct_expr_body) = - check_modtype env mb.mod_type mb.mod_mp mb.mod_delta in - let mtb1 = - {typ_mp=mp; - typ_expr=sign; - typ_expr_alg=None; - typ_constraints=Univ.empty_constraint; - typ_delta = mb.mod_delta;} - and mtb2 = - {typ_mp=mp; - typ_expr=mb.mod_type; - typ_expr_alg=None; - typ_constraints=Univ.empty_constraint; - typ_delta = mb.mod_delta;} - in - let env = add_module (module_body_of_type mp mtb1) env in - check_subtypes env mtb1 mtb2 - and check_structure_field env mp lab res = function | SFBconst cb -> - let c = make_con mp empty_dirpath lab in - check_constant_declaration env c cb + let c = Constant.make2 mp lab in + check_constant_declaration env c cb | SFBmind mib -> - let kn = make_mind mp empty_dirpath lab in + let kn = MutInd.make2 mp lab in let kn = mind_of_delta res kn in - Indtypes.check_inductive env kn mib + Indtypes.check_inductive env kn mib | SFBmodule msb -> - let (_:unit) = check_module env (MPdot(mp,lab)) msb in - Modops.add_module msb env + let () = check_module env (MPdot(mp,lab)) msb in + Modops.add_module msb env | SFBmodtype mty -> check_module_type env mty; add_modtype (MPdot(mp,lab)) mty env - -and check_modexpr env mse mp_mse res = match mse with - | SEBident mp -> + +and check_mexpr env mse mp_mse res = match mse with + | MEident mp -> let mb = lookup_module mp env in (subst_and_strengthen mb mp_mse).mod_type - | SEBfunctor (arg_id, mtb, body) -> - check_module_type env mtb ; - let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in - let sign = check_modexpr env' body mp_mse res in - SEBfunctor (arg_id, mtb, sign) - | SEBapply (f,m,cst) -> - let sign = check_modexpr env f mp_mse res in - let farg_id, farg_b, fbody_b = destr_functor env sign in - let mp = - try (path_of_mexpr m) - with Not_path -> error_application_to_not_path m - (* place for nondep_supertype *) in + | MEapply (f,mp) -> + let sign = check_mexpr env f mp_mse res in + let farg_id, farg_b, fbody_b = destr_functor sign in let mtb = module_type_of_module (Some mp) (lookup_module mp env) in - check_subtypes env mtb farg_b; - (subst_struct_expr (map_mbid farg_id mp) fbody_b) - | SEBwith(mte, with_decl) -> - let sign = check_modexpr env mte mp_mse res in - let sign = check_with env sign with_decl mp_mse in - sign - | SEBstruct(msb) -> - let (_:env) = List.fold_left (fun env (lab,mb) -> - check_structure_field env mp_mse lab res mb) env msb in - SEBstruct(msb) - -and check_modtype env mse mp_mse res = match mse with - | SEBident mp -> - let mtb = lookup_modtype mp env in - mtb.typ_expr - | SEBfunctor (arg_id, mtb, body) -> - check_module_type env mtb; - let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in - let body = check_modtype env' body mp_mse res in - SEBfunctor(arg_id,mtb,body) - | SEBapply (f,m,cst) -> - let sign = check_modtype env f mp_mse res in - let farg_id, farg_b, fbody_b = destr_functor env sign in - let mp = - try (path_of_mexpr m) - with Not_path -> error_application_to_not_path m - (* place for nondep_supertype *) in - let mtb = module_type_of_module (Some mp) (lookup_module mp env) in - check_subtypes env mtb farg_b; - subst_struct_expr (map_mbid farg_id mp) fbody_b - | SEBwith(mte, with_decl) -> - let sign = check_modtype env mte mp_mse res in - let sign = check_with env sign with_decl mp_mse in - sign - | SEBstruct(msb) -> - let (_:env) = List.fold_left (fun env (lab,mb) -> - check_structure_field env mp_mse lab res mb) env msb in - SEBstruct(msb) - -(* - let rec add_struct_expr_constraints env = function - | SEBident _ -> env - - | SEBfunctor (_,mtb,meb) -> - add_struct_expr_constraints - (add_modtype_constraints env mtb) meb - - | SEBstruct (_,structure_body) -> - List.fold_left - (fun env (l,item) -> add_struct_elem_constraints env item) - env - structure_body + check_subtypes env mtb farg_b; + subst_signature (map_mbid farg_id mp) fbody_b + | MEwith _ -> error_with_module () - | SEBapply (meb1,meb2,cst) -> -(* let g = Univ.merge_constraints cst Univ.initial_universes in -msgnl(str"ADDING FUNCTOR APPLICATION CONSTRAINTS:"++fnl()++ - Univ.pr_universes g++str"============="++fnl()); -*) - Environ.add_constraints cst - (add_struct_expr_constraints - (add_struct_expr_constraints env meb1) - meb2) - | SEBwith(meb,With_definition_body(_,cb))-> - Environ.add_constraints cb.const_constraints - (add_struct_expr_constraints env meb) - | SEBwith(meb,With_module_body(_,_,cst))-> - Environ.add_constraints cst - (add_struct_expr_constraints env meb) - -and add_struct_elem_constraints env = function - | SFBconst cb -> Environ.add_constraints cb.const_constraints env - | SFBmind mib -> Environ.add_constraints mib.mind_constraints env - | SFBmodule mb -> add_module_constraints env mb - | SFBalias (mp,Some cst) -> Environ.add_constraints cst env - | SFBalias (mp,None) -> env - | SFBmodtype mtb -> add_modtype_constraints env mtb - -and add_module_constraints env mb = - let env = match mb.mod_expr with - | None -> env - | Some meb -> add_struct_expr_constraints env meb - in - let env = match mb.mod_type with - | None -> env - | Some mtb -> - add_struct_expr_constraints env mtb - in - Environ.add_constraints mb.mod_constraints env +and check_mexpression env sign mp_mse res = match sign with + | MoreFunctor (arg_id, mtb, body) -> + check_module_type env mtb; + let env' = add_module_type (MPbound arg_id) mtb env in + let body = check_mexpression env' body mp_mse res in + MoreFunctor(arg_id,mtb,body) + | NoFunctor me -> check_mexpr env me mp_mse res -and add_modtype_constraints env mtb = - add_struct_expr_constraints env mtb.typ_expr -*) +and check_signature env sign mp_mse res = match sign with + | MoreFunctor (arg_id, mtb, body) -> + check_module_type env mtb; + let env' = add_module_type (MPbound arg_id) mtb env in + let body = check_signature env' body mp_mse res in + MoreFunctor(arg_id,mtb,body) + | NoFunctor struc -> + let (_:env) = List.fold_left (fun env (lab,mb) -> + check_structure_field env mp_mse lab res mb) env struc + in + NoFunctor struc diff --git a/checker/mod_checking.mli b/checker/mod_checking.mli index e2f63b77..ae28caed 100644 --- a/checker/mod_checking.mli +++ b/checker/mod_checking.mli @@ -1,9 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Names.module_path -> Declarations.module_body -> unit +val check_module : Environ.env -> Names.module_path -> Cic.module_body -> unit diff --git a/checker/modops.ml b/checker/modops.ml index 11793af9..8ccf118d 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -1,126 +1,111 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* true + | NoFunctor _ -> false -let error_signature_expected mtb = - error "Signature expected" +let destr_functor = function + | MoreFunctor (arg_id,arg_t,body_t) -> (arg_id,arg_t,body_t) + | NoFunctor _ -> error_not_a_functor () -let error_application_to_not_path _ = error "Application to not path" +let module_body_of_type mp mtb = + { mtb with mod_mp = mp; mod_expr = Abstract } -let destr_functor env mtb = - match mtb with - | SEBfunctor (arg_id,arg_t,body_t) -> - (arg_id,arg_t,body_t) - | _ -> error_not_a_functor mtb - -let module_body_of_type mp mtb = - { mod_mp = mp; - mod_type = mtb.typ_expr; - mod_type_alg = mtb.typ_expr_alg; - mod_expr = None; - mod_constraints = mtb.typ_constraints; - mod_delta = mtb.typ_delta; - mod_retroknowledge = []} - -let rec add_signature mp sign resolver env = +let rec add_structure mp sign resolver env = let add_one env (l,elem) = - let kn = make_kn mp empty_dirpath l in - let con = constant_of_kn kn in - let mind = mind_of_delta resolver (mind_of_kn kn) in + let kn = KerName.make2 mp l in + let con = Constant.make1 kn in + let mind = mind_of_delta resolver (MutInd.make1 kn) in match elem with - | SFBconst cb -> + | SFBconst cb -> (* let con = constant_of_delta resolver con in*) Environ.add_constant con cb env - | SFBmind mib -> + | SFBmind mib -> (* let mind = mind_of_delta resolver mind in*) Environ.add_mind mind mib env | SFBmodule mb -> add_module mb env (* adds components as well *) - | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env + | SFBmodtype mtb -> Environ.add_modtype mtb.mod_mp mtb env in - List.fold_left add_one env sign + List.fold_left add_one env sign -and add_module mb env = +and add_module mb env = let mp = mb.mod_mp in let env = Environ.shallow_add_module mp mb env in - match mb.mod_type with - | SEBstruct (sign) -> - add_signature mp sign mb.mod_delta env - | SEBfunctor _ -> env - | _ -> anomaly "Modops:the evaluation of the structure failed " + match mb.mod_type with + | NoFunctor struc -> add_structure mp struc mb.mod_delta env + | MoreFunctor _ -> env +let add_module_type mp mtb env = add_module (module_body_of_type mp mtb) env let strengthen_const mp_from l cb resolver = match cb.const_body with | Def _ -> cb | _ -> - let con = make_con mp_from empty_dirpath l in + let con = Constant.make2 mp_from l in (* let con = constant_of_delta resolver con in*) - { cb with const_body = Def (Declarations.from_val (Const con)) } + let u = + if cb.const_polymorphic then Univ.UContext.instance cb.const_universes + else Univ.Instance.empty + in + { cb with const_body = Def (Declarations.from_val (Const (con,u))) } let rec strengthen_mod mp_from mp_to mb = - if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then - mb - else - match mb.mod_type with - | SEBstruct (sign) -> - let resolve_out,sign_out = - strengthen_sig mp_from sign mp_to mb.mod_delta in - { mb with - mod_expr = Some (SEBident mp_to); - mod_type = SEBstruct(sign_out); - mod_type_alg = mb.mod_type_alg; - mod_constraints = mb.mod_constraints; - mod_delta = resolve_out(*add_mp_delta_resolver mp_from mp_to - (add_delta_resolver mb.mod_delta resolve_out)*); - mod_retroknowledge = mb.mod_retroknowledge} - | SEBfunctor _ -> mb - | _ -> anomaly "Modops:the evaluation of the structure failed " - + if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then mb + else strengthen_body true mp_from mp_to mb + +and strengthen_body is_mod mp_from mp_to mb = + match mb.mod_type with + | MoreFunctor _ -> mb + | NoFunctor sign -> + let resolve_out,sign_out = strengthen_sig mp_from sign mp_to mb.mod_delta + in + { mb with + mod_expr = + (if is_mod then Algebraic (NoFunctor (MEident mp_to)) else Abstract); + mod_type = NoFunctor sign_out; + mod_delta = resolve_out } + and strengthen_sig mp_from sign mp_to resolver = match sign with | [] -> empty_delta_resolver,[] @@ -139,39 +124,23 @@ and strengthen_sig mp_from sign mp_to resolver = let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out (*add_delta_resolver resolve_out mb.mod_delta*), item':: rest' - | (l,SFBmodtype mty as item) :: rest -> + | (l,SFBmodtype mty as item) :: rest -> let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out,item::rest' let strengthen mtb mp = - match mtb.typ_expr with - | SEBstruct (sign) -> - let resolve_out,sign_out = - strengthen_sig mtb.typ_mp sign mp mtb.typ_delta in - {mtb with - typ_expr = SEBstruct(sign_out); - typ_delta = resolve_out(*add_delta_resolver mtb.typ_delta - (add_mp_delta_resolver mtb.typ_mp mp resolve_out)*)} - | SEBfunctor _ -> mtb - | _ -> anomaly "Modops:the evaluation of the structure failed " + strengthen_body false mtb.mod_mp mp mtb let subst_and_strengthen mb mp = strengthen_mod mb.mod_mp mp (subst_module (map_mp mb.mod_mp mp) mb) - let module_type_of_module mp mb = + let mtb = + { mb with + mod_expr = Abstract; + mod_type_alg = None; + mod_retroknowledge = [] } + in match mp with - Some mp -> - strengthen { - typ_mp = mp; - typ_expr = mb.mod_type; - typ_expr_alg = None; - typ_constraints = mb.mod_constraints; - typ_delta = mb.mod_delta} mp - - | None -> - {typ_mp = mb.mod_mp; - typ_expr = mb.mod_type; - typ_expr_alg = None; - typ_constraints = mb.mod_constraints; - typ_delta = mb.mod_delta} + | Some mp -> strengthen {mtb with mod_mp = mp} mp + | None -> mtb diff --git a/checker/modops.mli b/checker/modops.mli index 61b2c80f..e22c2656 100644 --- a/checker/modops.mli +++ b/checker/modops.mli @@ -1,36 +1,31 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* module_type_body -> module_body +val module_type_of_module : + module_path option -> module_body -> module_type_body -val module_type_of_module : module_path option -> module_body -> - module_type_body +val is_functor : ('ty,'a) functorize -> bool -val destr_functor : - env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body - -val add_signature : module_path -> structure_body -> delta_resolver -> env -> env +val destr_functor : ('ty,'a) functorize -> MBId.t * 'ty * ('ty,'a) functorize (* adds a module and its components, but not the constraints *) val add_module : module_body -> env -> env +val add_module_type : module_path -> module_type_body -> env -> env + val strengthen : module_type_body -> module_path -> module_type_body val subst_and_strengthen : module_body -> module_path -> module_body @@ -40,19 +35,13 @@ val error_incompatible_modtypes : val error_not_match : label -> structure_field_body -> 'a -val error_with_incorrect : label -> 'a +val error_with_module : unit -> 'a val error_no_such_label : label -> 'a val error_no_such_label_sub : label -> module_path -> 'a -val error_signature_expected : struct_expr_body -> 'a - val error_not_a_constant : label -> 'a val error_not_a_module : label -> 'a - -val error_a_generative_module_expected : label -> 'a - -val error_application_to_not_path : struct_expr_body -> 'a diff --git a/checker/print.ml b/checker/print.ml new file mode 100644 index 00000000..1cc48ff7 --- /dev/null +++ b/checker/print.ml @@ -0,0 +1,144 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* print_string "#"; print_int n + | Meta n -> print_string "Meta("; print_int n; print_string ")" + | Var id -> print_string (Id.to_string id) + | Sort s -> sort_display s + | Cast (c,_, t) -> open_hovbox 1; + print_string "("; (term_display c); print_cut(); + print_string "::"; (term_display t); print_string ")"; close_box() + | Prod (Name(id),t,c) -> + open_hovbox 1; + print_string"("; print_string (Id.to_string id); + print_string ":"; box_display t; + print_string ")"; print_cut(); + box_display c; close_box() + | Prod (Anonymous,t,c) -> + print_string"("; box_display t; print_cut(); print_string "->"; + box_display c; print_string ")"; + | Lambda (na,t,c) -> + print_string "["; name_display na; + print_string ":"; box_display t; print_string "]"; + print_cut(); box_display c; + | LetIn (na,b,t,c) -> + print_string "["; name_display na; print_string "="; + box_display b; print_cut(); + print_string ":"; box_display t; print_string "]"; + print_cut(); box_display c; + | App (c,l) -> + print_string "("; + box_display c; + Array.iter (fun x -> print_space (); box_display x) l; + print_string ")" + | Evar _ -> print_string "Evar#" + | Const (c,u) -> print_string "Cons("; + sp_con_display c; + print_string ","; print_instance u; + print_string ")" + | Ind ((sp,i),u) -> + print_string "Ind("; + sp_display sp; + print_string ","; print_int i; + print_string ","; print_instance u; + print_string ")" + | Construct (((sp,i),j),u) -> + print_string "Constr("; + sp_display sp; + print_string ","; + print_int i; print_string ","; print_int j; + print_string ","; print_instance u; print_string ")" + | Case (ci,p,c,bl) -> + open_vbox 0; + print_string "<"; box_display p; print_string ">"; + print_cut(); print_string "Case"; + print_space(); box_display c; print_space (); print_string "of"; + open_vbox 0; + Array.iter (fun x -> print_cut(); box_display x) bl; + close_box(); + print_cut(); + print_string "end"; + close_box() + | Fix ((t,i),(lna,tl,bl)) -> + print_string "Fix("; print_int i; print_string ")"; + print_cut(); + open_vbox 0; + let print_fix () = + for k = 0 to (Array.length tl) - 1 do + open_vbox 0; + name_display lna.(k); print_string "/"; + print_int t.(k); print_cut(); print_string ":"; + box_display tl.(k) ; print_cut(); print_string ":="; + box_display bl.(k); close_box (); + print_cut() + done + in print_string"{"; print_fix(); print_string"}" + | CoFix(i,(lna,tl,bl)) -> + print_string "CoFix("; print_int i; print_string ")"; + print_cut(); + open_vbox 0; + let print_fix () = + for k = 0 to (Array.length tl) - 1 do + open_vbox 1; + name_display lna.(k); print_cut(); print_string ":"; + box_display tl.(k) ; print_cut(); print_string ":="; + box_display bl.(k); close_box (); + print_cut(); + done + in print_string"{"; print_fix (); print_string"}" + | Proj (p, c) -> + print_string "Proj("; sp_con_display p; print_string ","; + box_display c; print_string ")" + + and box_display c = open_hovbox 1; term_display c; close_box() + + and sort_display = function + | Prop(Pos) -> print_string "Set" + | Prop(Null) -> print_string "Prop" + | Type u -> print_string "Type("; Pp.pp (Univ.pr_uni u); print_string ")" + + and name_display = function + | Name id -> print_string (Id.to_string id) + | Anonymous -> print_string "_" +(* Remove the top names for library and Scratch to avoid long names *) + and sp_display sp = +(* let dir,l = decode_kn sp in + let ls = + match List.rev_map Id.to_string (DirPath.repr dir) with + ("Top"::l)-> l + | ("Coq"::_::l) -> l + | l -> l + in List.iter (fun x -> print_string x; print_string ".") ls;*) + print_string (debug_string_of_mind sp) + and sp_con_display sp = +(* let dir,l = decode_kn sp in + let ls = + match List.rev_map Id.to_string (DirPath.repr dir) with + ("Top"::l)-> l + | ("Coq"::_::l) -> l + | l -> l + in List.iter (fun x -> print_string x; print_string ".") ls;*) + print_string (debug_string_of_con sp) + + in + try + box_display csr; print_flush() + with e -> + print_string (Printexc.to_string e);print_flush (); + raise e + + + diff --git a/checker/reduction.ml b/checker/reduction.ml index 91b59a08..185c6edf 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -1,15 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 - | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) -> + | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> + Int.equal bal 0 && compare_rec 0 s1 s2 + | ((Zcase(c1,_,_)|ZcaseT(c1,_,_,_))::s1, + (Zcase(c2,_,_)|ZcaseT(c2,_,_,_))::s2) -> bal=0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> bal=0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 @@ -49,6 +52,7 @@ let compare_stack_shape stk1 stk2 = type lft_constr_stack_elt = Zlapp of (lift * fconstr) array + | Zlproj of Names.constant * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list @@ -67,9 +71,13 @@ let pure_stack lfts stk = | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (Array.map (fun t -> (l,t)) a) pstk) + | (Zproj (n,m,c), (l,pstk)) -> + (l, Zlproj (c,l)::pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) + | (ZcaseT(ci,p,br,env),(l,pstk)) -> + (l,Zlcase(ci,l,mk_clos env p,mk_clos_vect env br)::pstk) | (Zcase(ci,p,br),(l,pstk)) -> (l,Zlcase(ci,l,p,br)::pstk)) in snd (pure_rec lfts stk) @@ -115,20 +123,27 @@ type 'a conversion_function = env -> 'a -> 'a -> unit exception NotConvertible exception NotConvertibleVect of int +let convert_universes univ u u' = + if Univ.Instance.check_eq univ u u' then () + else raise NotConvertible + let compare_stacks f fmind lft1 stk1 lft2 stk2 = let rec cmp_rec pstk1 pstk2 = match (pstk1,pstk2) with | (z1::s1, z2::s2) -> cmp_rec s1 s2; (match (z1,z2) with - | (Zlapp a1,Zlapp a2) -> array_iter2 f a1 a2 + | (Zlapp a1,Zlapp a2) -> Array.iter2 f a1 a2 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> f fx1 fx2; cmp_rec a1 a2 + | (Zlproj (c1,l1),Zlproj (c2,l2)) -> + if not (Names.eq_con_chk c1 c2) then + raise NotConvertible | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) -> if not (fmind ci1.ci_ind ci2.ci_ind) then raise NotConvertible; f (l1,p1) (l2,p2); - array_iter2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 + Array.iter2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 | _ -> assert false) | _ -> () in if compare_stack_shape stk1 stk2 then @@ -143,7 +158,7 @@ type conv_pb = let sort_cmp univ pb s0 s1 = match (s0,s1) with - | (Prop c1, Prop c2) when pb = CUMUL -> if c1 = Pos & c2 = Null then raise NotConvertible + | (Prop c1, Prop c2) when pb = CUMUL -> if c1 = Pos && c2 = Null then raise NotConvertible | (Prop c1, Prop c2) -> if c1 <> c2 then raise NotConvertible | (Prop c1, Type u) -> (match pb with @@ -152,8 +167,8 @@ let sort_cmp univ pb s0 s1 = | (Type u1, Type u2) -> if not (match pb with - | CONV -> check_eq univ u1 u2 - | CUMUL -> check_geq univ u2 u1) + | CONV -> Univ.check_eq univ u1 u2 + | CUMUL -> Univ.check_leq univ u1 u2) then raise NotConvertible | (_, _) -> raise NotConvertible @@ -162,7 +177,9 @@ let rec no_arg_available = function | Zupdate _ :: stk -> no_arg_available stk | Zshift _ :: stk -> no_arg_available stk | Zapp v :: stk -> Array.length v = 0 && no_arg_available stk + | Zproj _ :: _ -> true | Zcase _ :: _ -> true + | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true let rec no_nth_arg_available n = function @@ -173,7 +190,9 @@ let rec no_nth_arg_available n = function let k = Array.length v in if n >= k then no_nth_arg_available (n-k) stk else false + | Zproj _ :: _ -> true | Zcase _ :: _ -> true + | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true let rec no_case_available = function @@ -181,17 +200,19 @@ let rec no_case_available = function | Zupdate _ :: stk -> no_case_available stk | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk + | Zproj (_,_,_) :: _ -> false | Zcase _ :: _ -> false + | ZcaseT _ :: _ -> false | Zfix _ :: _ -> true let in_whnf (t,stk) = match fterm_of t with - | (FLetIn _ | FCases _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false + | (FLetIn _ | FCase _ | FCaseT _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false | FLambda _ -> no_arg_available stk | FConstruct _ -> no_case_available stk | FCoFix _ -> no_case_available stk | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk - | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _) -> true + | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _ | FProj _) -> true | FLOCKED -> assert false let oracle_order fl1 fl2 = @@ -200,13 +221,18 @@ let oracle_order fl1 fl2 = | _, ConstKey _ -> true | _ -> false +let unfold_projection infos p c = + let pb = lookup_projection p (infos_env infos) in + let s = Zproj (pb.proj_npars, pb.proj_arg, p) in + (c, s) + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 = eqappr univ cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = - Util.check_for_interrupt (); + Control.check_for_interrupt (); (* First head reduce both terms *) let rec whd_both (t1,stk1) (t2,stk2) = let st1' = whd_stack infos t1 stk1 in @@ -246,7 +272,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try (* try first intensional equality *) - if eq_table_key fl1 fl2 + if eq_table_key fl1 fl2 then convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible with NotConvertible -> @@ -254,19 +280,27 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = let (app1,app2) = if oracle_order fl1 fl2 then match unfold_reference infos fl1 with - | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2) - | None -> - (match unfold_reference infos fl2 with - | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2)) - | None -> raise NotConvertible) + | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2) + | None -> + (match unfold_reference infos fl2 with + | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2)) + | None -> raise NotConvertible) else match unfold_reference infos fl2 with - | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2)) - | None -> - (match unfold_reference infos fl1 with - | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2) - | None -> raise NotConvertible) in - eqappr univ cv_pb infos app1 app2) + | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2)) + | None -> + (match unfold_reference infos fl1 with + | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2) + | None -> raise NotConvertible) in + eqappr univ cv_pb infos app1 app2) + + | (FProj (p1,c1), _) -> + let (def1, s1) = unfold_projection infos p1 c1 in + eqappr univ cv_pb infos (lft1, whd_stack infos def1 (s1 :: v1)) appr2 + + | (_, FProj (p2,c2)) -> + let (def2, s2) = unfold_projection infos p2 c2 in + eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 (s2 :: v2)) (* other constructors *) | (FLambda _, FLambda _) -> @@ -287,43 +321,76 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = (* Eta-expansion on the fly *) | (FLambda _, _) -> if v1 <> [] then - anomaly "conversion was given unreduced term (FLambda)"; + anomaly (Pp.str "conversion was given unreduced term (FLambda)"); let (_,_ty1,bd1) = destFLambda mk_clos hd1 in eqappr univ CONV infos (el_lift lft1,(bd1,[])) (el_lift lft2,(hd2,eta_expand_stack v2)) | (_, FLambda _) -> if v2 <> [] then - anomaly "conversion was given unreduced term (FLambda)"; + anomaly (Pp.str "conversion was given unreduced term (FLambda)"); let (_,_ty2,bd2) = destFLambda mk_clos hd2 in eqappr univ CONV infos (el_lift lft1,(hd1,eta_expand_stack v1)) (el_lift lft2,(bd2,[])) (* only one constant, defined var or defined rel *) - | (FFlex fl1, _) -> + | (FFlex fl1, c2) -> (match unfold_reference infos fl1 with | Some def1 -> eqappr univ cv_pb infos (lft1, whd_stack infos def1 v1) appr2 - | None -> raise NotConvertible) - | (_, FFlex fl2) -> + | None -> + match c2 with + | FConstruct ((ind2,j2),u2) -> + (try + let v2, v1 = + eta_expand_ind_stack (infos_env infos) ind2 hd2 v2 (snd appr1) + in convert_stacks univ infos lft1 lft2 v1 v2 + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible) + + | (c1, FFlex fl2) -> (match unfold_reference infos fl2 with | Some def2 -> eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 v2) - | None -> raise NotConvertible) + | None -> + match c1 with + | FConstruct ((ind1,j1),u1) -> + (try let v1, v2 = + eta_expand_ind_stack (infos_env infos) ind1 hd1 v1 (snd appr2) + in convert_stacks univ infos lft1 lft2 v1 v2 + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible) (* Inductive types: MutInd MutConstruct Fix Cofix *) - | (FInd ind1, FInd ind2) -> - if mind_equiv_infos infos ind1 ind2 - then - convert_stacks univ infos lft1 lft2 v1 v2 - else raise NotConvertible + | (FInd (ind1,u1), FInd (ind2,u2)) -> + if mind_equiv_infos infos ind1 ind2 + then + (let () = convert_universes univ u1 u2 in + convert_stacks univ infos lft1 lft2 v1 v2) + else raise NotConvertible - | (FConstruct (ind1,j1), FConstruct (ind2,j2)) -> - if j1 = j2 && mind_equiv_infos infos ind1 ind2 + | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> + if Int.equal j1 j2 && mind_equiv_infos infos ind1 ind2 then - convert_stacks univ infos lft1 lft2 v1 v2 + (let () = convert_universes univ u1 u2 in + convert_stacks univ infos lft1 lft2 v1 v2) else raise NotConvertible + (* Eta expansion of records *) + | (FConstruct ((ind1,j1),u1), _) -> + (try + let v1, v2 = + eta_expand_ind_stack (infos_env infos) ind1 hd1 v1 (snd appr2) + in convert_stacks univ infos lft1 lft2 v1 v2 + with Not_found -> raise NotConvertible) + + | (_, FConstruct ((ind2,j2),u2)) -> + (try + let v2, v1 = + eta_expand_ind_stack (infos_env infos) ind2 hd2 v2 (snd appr1) + in convert_stacks univ infos lft1 lft2 v1 v2 + with Not_found -> raise NotConvertible) + | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) -> if op1 = op2 then @@ -353,8 +420,8 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) - | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) - | (_, FLetIn _) | (_,FCases _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) + | ( (FLetIn _, _) | (FCase _,_) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) + | (_, FLetIn _) | (_,FCase _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false (* In all other cases, terms are not convertible *) @@ -367,23 +434,25 @@ and convert_stacks univ infos lft1 lft2 stk1 stk2 = lft1 stk1 lft2 stk2 and convert_vect univ infos lft1 lft2 v1 v2 = - array_iter2 (fun t1 t2 -> ccnv univ CONV infos lft1 lft2 t1 t2) v1 v2 + Array.iter2 (fun t1 t2 -> ccnv univ CONV infos lft1 lft2 t1 t2) v1 v2 -let clos_fconv cv_pb env t1 t2 = - let infos = create_clos_infos betaiotazeta env in +let clos_fconv cv_pb eager_delta env t1 t2 = + let infos = + create_clos_infos + (if eager_delta then betadeltaiota else betaiotazeta) env in let univ = universes env in ccnv univ cv_pb infos el_id el_id (inject t1) (inject t2) -let fconv cv_pb env t1 t2 = +let fconv cv_pb eager_delta env t1 t2 = if eq_constr t1 t2 then () - else clos_fconv cv_pb env t1 t2 + else clos_fconv cv_pb eager_delta env t1 t2 -let conv = fconv CONV -let conv_leq = fconv CUMUL +let conv = fconv CONV false +let conv_leq = fconv CUMUL false (* option for conversion : no compilation for the checker *) -let vm_conv = fconv +let vm_conv cv_pb = fconv cv_pb true (********************************************************************) (* Special-Purpose Reduction *) @@ -398,7 +467,7 @@ let vm_conv = fconv let hnf_prod_app env t n = match whd_betadeltaiota env t with | Prod (_,_,b) -> subst1 n b - | _ -> anomaly "hnf_prod_app: Need a product" + | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product") let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl @@ -416,7 +485,7 @@ let dest_prod env = in decrec env empty_rel_context -(* The same but preserving lets *) +(* The same but preserving lets in the context, not internal ones. *) let dest_prod_assum env = let rec prodec_rec env l ty = let rty = whd_betadeltaiota_nolet env ty in @@ -428,10 +497,29 @@ let dest_prod_assum env = let d = (x,Some b,t) in prodec_rec (push_rel d env) (d::l) c | Cast (c,_,_) -> prodec_rec env l c - | _ -> l,rty + | _ -> + let rty' = whd_betadeltaiota env rty in + if Term.eq_constr rty' rty then l, rty + else prodec_rec env l rty' in prodec_rec env empty_rel_context +let dest_lam_assum env = + let rec lamec_rec env l ty = + let rty = whd_betadeltaiota_nolet env ty in + match rty with + | Lambda (x,t,c) -> + let d = (x,None,t) in + lamec_rec (push_rel d env) (d::l) c + | LetIn (x,b,t,c) -> + let d = (x,Some b,t) in + lamec_rec (push_rel d env) (d::l) c + | Cast (c,_,_) -> lamec_rec env l c + | _ -> l,rty + in + lamec_rec env empty_rel_context + + let dest_arity env c = let l, c = dest_prod_assum env c in match c with diff --git a/checker/reduction.mli b/checker/reduction.mli index 67cd599c..2e873469 100644 --- a/checker/reduction.mli +++ b/checker/reduction.mli @@ -1,12 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr -> constr list -> constr val dest_prod : env -> constr -> rel_context * constr val dest_prod_assum : env -> constr -> rel_context * constr +val dest_lam_assum : env -> constr -> rel_context * constr + val dest_arity : env -> constr -> arity diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index f7abd4dc..35f7f14b 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -1,15 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* actual_stamp then report_clash f caller dp with Not_found -> - error ("Reference to unknown module " ^ (string_of_dirpath dp)) + error ("Reference to unknown module " ^ (DirPath.to_string dp)) in - List.iter check needed - - -type compiled_library = - dir_path * - module_body * - (dir_path * Digest.t) list * - engagement option - - (* Store the body of modules' opaque constants inside a table. - - This module is used during the serialization and deserialization - of vo files. - - By adding an indirection to the opaque constant definitions, we - gain the ability not to load them. As these constant definitions - are usually big terms, we save a deserialization time as well as - some memory space. *) -module LightenLibrary : sig - type table - type lightened_compiled_library - val load : table -> lightened_compiled_library -> compiled_library -end = struct - - (* The table is implemented as an array of [constr_substituted]. - Keys are hence integers. To avoid changing the [compiled_library] - type, we brutally encode integers into [lazy_constr]. This isn't - pretty, but shouldn't be dangerous since the produced structure - [lightened_compiled_library] is abstract and only meant for writing - to .vo via Marshal (which doesn't care about types). - *) - type table = constr_substituted array - let key_of_lazy_constr (c:lazy_constr) = (Obj.magic c : int) - - (* To avoid any future misuse of the lightened library that could - interpret encoded keys as real [constr_substituted], we hide - these kind of values behind an abstract datatype. *) - type lightened_compiled_library = compiled_library - - (* Map a [compiled_library] to another one by just updating - the opaque term [t] to [on_opaque_const_body t]. *) - let traverse_library on_opaque_const_body = - let rec traverse_module mb = - match mb.mod_expr with - None -> - { mb with - mod_expr = None; - mod_type = traverse_modexpr mb.mod_type; - } - | Some impl when impl == mb.mod_type-> - let mtb = traverse_modexpr mb.mod_type in - { mb with - mod_expr = Some mtb; - mod_type = mtb; - } - | Some impl -> - { mb with - mod_expr = Option.map traverse_modexpr mb.mod_expr; - mod_type = traverse_modexpr mb.mod_type; - } - and traverse_struct struc = - let traverse_body (l,body) = (l,match body with - | (SFBconst cb) when is_opaque cb -> - SFBconst {cb with const_body = on_opaque_const_body cb.const_body} - | (SFBconst _ | SFBmind _ ) as x -> - x - | SFBmodule m -> - SFBmodule (traverse_module m) - | SFBmodtype m -> - SFBmodtype ({m with typ_expr = traverse_modexpr m.typ_expr})) - in - List.map traverse_body struc - - and traverse_modexpr = function - | SEBfunctor (mbid,mty,mexpr) -> - SEBfunctor (mbid, - ({mty with - typ_expr = traverse_modexpr mty.typ_expr}), - traverse_modexpr mexpr) - | SEBident mp as x -> x - | SEBstruct (struc) -> - SEBstruct (traverse_struct struc) - | SEBapply (mexpr,marg,u) -> - SEBapply (traverse_modexpr mexpr,traverse_modexpr marg,u) - | SEBwith (seb,wdcl) -> - SEBwith (traverse_modexpr seb,wdcl) - in - fun (dp,mb,depends,s) -> (dp,traverse_module mb,depends,s) - - (* Loading is also a traversing that decodes the embedded keys that - are inside the [lightened_library]. If the [load_proof] flag is - set, we lookup inside the table to graft the - [constr_substituted]. Otherwise, we set the [const_body] field - to [None]. - *) - let load table lightened_library = - let decode_key = function - | Undef _ | Def _ -> assert false - | OpaqueDef k -> - let k = key_of_lazy_constr k in - let body = - try table.(k) - with _ -> error "Error while retrieving an opaque body" - in - OpaqueDef (lazy_constr_from_val body) - in - traverse_library decode_key lightened_library - -end - -open Validate -let val_deps = val_list (val_tuple ~name:"dep"[|val_dp;no_val|]) -let val_vo = val_tuple ~name:"vo" [|val_dp;val_module;val_deps;val_opt val_eng|] + Array.iter check needed (* This function should append a certificate to the .vo file. The digest must be part of the certicate to rule out attackers @@ -179,24 +69,20 @@ let stamp_library file digest = () (* When the module is checked, digests do not need to match, but a warning is issued in case of mismatch *) -let import file (dp,mb,depends,engmt as vo) digest = - Validate.apply !Flags.debug val_vo vo; - Flags.if_verbose msgnl (str "*** vo structure validated ***"); +let import file clib univs digest = let env = !genv in - check_imports msg_warning dp env depends; - check_engagement env engmt; - Mod_checking.check_module (add_constraints mb.mod_constraints env) mb.mod_mp mb; + check_imports msg_warning clib.comp_name env clib.comp_deps; + check_engagement env clib.comp_enga; + let mb = clib.comp_mod in + Mod_checking.check_module + (add_constraints univs + (add_constraints mb.mod_constraints env)) mb.mod_mp mb; stamp_library file digest; - (* We drop proofs once checked *) -(* let mb = lighten_module mb in*) - full_add_module dp mb digest + full_add_module clib.comp_name mb univs digest (* When the module is admitted, digests *must* match *) -let unsafe_import file (dp,mb,depends,engmt as vo) digest = - if !Flags.debug then ignore vo; (*Validate.apply !Flags.debug val_vo vo;*) +let unsafe_import file clib univs digest = let env = !genv in - check_imports (errorlabstrm"unsafe_import") dp env depends; - check_engagement env engmt; - (* We drop proofs once checked *) -(* let mb = lighten_module mb in*) - full_add_module dp mb digest + check_imports (errorlabstrm"unsafe_import") clib.comp_name env clib.comp_deps; + check_engagement env clib.comp_enga; + full_add_module clib.comp_name clib.comp_mod univs digest diff --git a/checker/safe_typing.mli b/checker/safe_typing.mli index c34d3508..e16e64e6 100644 --- a/checker/safe_typing.mli +++ b/checker/safe_typing.mli @@ -1,40 +1,20 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* env -(* exporting and importing modules *) -type compiled_library - -val set_engagement : Declarations.engagement -> unit +val set_engagement : engagement -> unit val import : - System.physical_path -> compiled_library -> Digest.t -> unit + CUnix.physical_path -> compiled_library -> Univ.constraints -> Cic.vodigest -> unit val unsafe_import : - System.physical_path -> compiled_library -> Digest.t -> unit - -(** Store the body of modules' opaque constants inside a table. - - This module is used during the serialization and deserialization - of vo files. -*) -module LightenLibrary : -sig - type table - type lightened_compiled_library - - (** [load table lcl] builds a compiled library from a - lightened library [lcl] by remplacing every index by its related - opaque terms inside [table]. *) - val load : table -> lightened_compiled_library -> compiled_library -end + CUnix.physical_path -> compiled_library -> Univ.constraints -> Cic.vodigest -> unit diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 02821c29..372c3142 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -1,15 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map) + Label.Map.add (Label.of_id id) (IndConstr((ip,i+1), mib)) map) oib.mind_consnames map in - Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map + Label.Map.add (Label.of_id oib.mind_typename) (IndType (ip, mib)) map in - array_fold_right_i add_mip_nameobjects mib.mind_packets map + Array.fold_right_i add_mip_nameobjects mib.mind_packets map (* creates (namedobject/namedmodule) map for the whole signature *) -type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t } +type labmap = { objs : namedobject Label.Map.t; mods : namedmodule Label.Map.t } -let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty } +let empty_labmap = { objs = Label.Map.empty; mods = Label.Map.empty } let get_obj mp map l = - try Labmap.find l map.objs + try Label.Map.find l map.objs with Not_found -> error_no_such_label_sub l mp let get_mod mp map l = - try Labmap.find l map.mods + try Label.Map.find l map.mods with Not_found -> error_no_such_label_sub l mp let make_labmap mp list = let add_one (l,e) map = match e with - | SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs } + | SFBconst cb -> { map with objs = Label.Map.add l (Constant cb) map.objs } | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs } - | SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods } - | SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods } + | SFBmodule mb -> { map with mods = Label.Map.add l (Module mb) map.mods } + | SFBmodtype mtb -> { map with mods = Label.Map.add l (Modtype mtb) map.mods } in List.fold_right add_one list empty_labmap @@ -85,7 +83,7 @@ let check_conv_error error f env a1 a2 = (* for now we do not allow reorderings *) let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= - let kn = make_mind mp1 empty_dirpath l in + let kn = MutInd.make2 mp1 l in let error () = error_not_match l spec2 in let check_conv f = check_conv_error error f in let mib1 = @@ -93,7 +91,26 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= | IndType ((_,0), mib) -> mib | _ -> error () in - let mib2 = subst_mind subst2 mib2 in + let mib2 = subst_mind subst2 mib2 in + let check eq f = if not (eq (f mib1) (f mib2)) then error () in + let bool_equal (x : bool) (y : bool) = x = y in + let u = + check bool_equal (fun x -> x.mind_polymorphic); + if mib1.mind_polymorphic then ( + check Univ.Instance.equal (fun x -> Univ.UContext.instance x.mind_universes); + Univ.UContext.instance mib1.mind_universes) + else Univ.Instance.empty + in + let eq_projection_body p1 p2 = + let check eq f = if not (eq (f p1) (f p2)) then error () in + check eq_mind (fun x -> x.proj_ind); + check (==) (fun x -> x.proj_npars); + check (==) (fun x -> x.proj_arg); + check (eq_constr) (fun x -> x.proj_type); + check (eq_constr) (fun x -> fst x.proj_eta); + check (eq_constr) (fun x -> snd x.proj_eta); + check (eq_constr) (fun x -> x.proj_body); true + in let check_inductive_type env t1 t2 = (* Due to sort-polymorphism in inductive types, the conclusions of @@ -130,14 +147,16 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= in let check_packet p1 p2 = - let check f = if f p1 <> f p2 then error () in - check (fun p -> p.mind_consnames); - check (fun p -> p.mind_typename); + let check eq f = if not (eq (f p1) (f p2)) then error () in + check + (fun a1 a2 -> Array.equal Id.equal a1 a2) + (fun p -> p.mind_consnames); + check Id.equal (fun p -> p.mind_typename); (* nf_lc later *) (* nf_arity later *) (* user_lc ignored *) (* user_arity ignored *) - check (fun p -> p.mind_nrealargs); + check Int.equal (fun p -> p.mind_nrealargs); (* kelim ignored *) (* listrec ignored *) (* finite done *) @@ -145,17 +164,15 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= (* params_ctxt done because part of the inductive types *) (* Don't check the sort of the type if polymorphic *) check_inductive_type env - (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2)) + (type_of_inductive env ((mib1,p1),u)) (type_of_inductive env ((mib2,p2),u)) in let check_cons_types i p1 p2 = - array_iter2 (check_conv conv env) - (arities_of_specif kn (mib1,p1)) - (arities_of_specif kn (mib2,p2)) + Array.iter2 (check_conv conv env) + (arities_of_specif (kn,u) (mib1,p1)) + (arities_of_specif (kn,u) (mib2,p2)) in - let check f = if f mib1 <> f mib2 then error () in - check (fun mib -> mib.mind_finite); - check (fun mib -> mib.mind_ntypes); - assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]); + check (==) (fun mib -> mib.mind_finite); + check Int.equal (fun mib -> mib.mind_ntypes); assert (Array.length mib1.mind_packets >= 1 && Array.length mib2.mind_packets >= 1); @@ -164,7 +181,7 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= (* at the time of checking the inductive arities in check_packet. *) (* Notice that we don't expect the local definitions to match: only *) (* the inductive types and constructors types have to be convertible *) - check (fun mib -> mib.mind_nparams); + check Int.equal (fun mib -> mib.mind_nparams); (*begin match mib2.mind_equiv with @@ -178,8 +195,18 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= if kn1 <> kn2 then error () end;*) (* we check that records and their field names are preserved. *) - check (fun mib -> mib.mind_record); - if mib1.mind_record then begin + let record_equal x y = + match x, y with + | None, None -> true + | Some None, Some None -> true + | Some (Some (id1,p1,pb1)), Some (Some (id2,p2,pb2)) -> + Id.equal id1 id2 && + Array.for_all2 eq_con_chk p1 p2 && + Array.for_all2 eq_projection_body pb1 pb2 + | _, _ -> false + in + check record_equal (fun mib -> mib.mind_record); + if mib1.mind_record != None then begin let rec names_prod_letin t = match t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) @@ -190,12 +217,14 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= assert (Array.length mib2.mind_packets = 1); assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); - check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0)); + check + (fun l1 l2 -> List.equal Name.equal l1 l2) + (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0)); end; (* we first check simple things *) - array_iter2 check_packet mib1.mind_packets mib2.mind_packets; + Array.iter2 check_packet mib1.mind_packets mib2.mind_packets; (* and constructor types in the end *) - let _ = array_map2_i check_cons_types mib1.mind_packets mib2.mind_packets + let _ = Array.map2_i check_cons_types mib1.mind_packets mib2.mind_packets in () let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = @@ -216,13 +245,13 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = if isArity t2 then let (ctx2,s2) = destArity t2 in match s2 with - | Type v when not (is_univ_variable v) -> + | Type v when not (Univ.is_univ_variable v) -> (* The type in the interface is inferred and is made of algebraic universes *) begin try let (ctx1,s1) = dest_arity env t1 in match s1 with - | Type u when not (is_univ_variable u) -> + | Type u when not (Univ.is_univ_variable u) -> (* Both types are inferred, no need to recheck them. We cheat and collapse the types to Prop *) mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null) @@ -249,7 +278,6 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = in match info1 with | Constant cb1 -> - assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; let cb1 = subst_const_body subst1 cb1 in let cb2 = subst_const_body subst2 cb2 in (*Start by checking types*) @@ -274,25 +302,25 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = let c2 = force_constr lc2 in check_conv conv env c1 c2)) | IndType ((kn,i),mind1) -> - ignore (Util.error ( + ignore (Errors.error ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by an inductive type. Hint: you can rename the " ^ "inductive type and give a definition to map the old name to the new " ^ "name.")); - assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ; if constant_has_body cb2 then error () ; - let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in + let u = inductive_instance mind1 in + let arity1 = type_of_inductive env ((mind1,mind1.mind_packets.(i)),u) in let typ2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> - ignore (Util.error ( + ignore (Errors.error ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by a constructor. Hint: you can rename the " ^ "constructor and give a definition to map the old name to the new " ^ "name.")); - assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ; if constant_has_body cb2 then error () ; - let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in + let u1 = inductive_instance mind1 in + let ty1 = type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv env ty1 ty2 @@ -325,56 +353,53 @@ and check_signatures env mp1 sig1 sig2 subst1 subst2 = | Modtype mtb -> mtb | _ -> error_not_match l spec2 in - let env = add_module (module_body_of_type mtb2.typ_mp mtb2) - (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in - check_modtypes env mtb1 mtb2 subst1 subst2 true + let env = + add_module_type mtb2.mod_mp mtb2 + (add_module_type mtb1.mod_mp mtb1 env) + in + check_modtypes env mtb1 mtb2 subst1 subst2 true in - List.iter check_one_body sig2 - -and check_modtypes env mtb1 mtb2 subst1 subst2 equiv = - if mtb1==mtb2 then () else - let mtb1',mtb2'=mtb1.typ_expr,mtb2.typ_expr in - let rec check_structure env str1 str2 equiv subst1 subst2 = - match str1,str2 with - | SEBstruct (list1), - SEBstruct (list2) -> - check_signatures env - mtb1.typ_mp list1 list2 subst1 subst2; - if equiv then - check_signatures env - mtb2.typ_mp list2 list1 subst1 subst2 - else - () - | SEBfunctor (arg_id1,arg_t1,body_t1), - SEBfunctor (arg_id2,arg_t2,body_t2) -> - check_modtypes env - arg_t2 arg_t1 - (map_mp arg_t1.typ_mp arg_t2.typ_mp) subst2 - equiv ; - (* contravariant *) - let env = add_module - (module_body_of_type (MPbound arg_id2) arg_t2) env - in - let env = match body_t1 with - SEBstruct str -> - let env = shallow_remove_module mtb1.typ_mp env in - add_module {mod_mp = mtb1.typ_mp; - mod_expr = None; - mod_type = body_t1; - mod_type_alg= None; - mod_constraints=mtb1.typ_constraints; - mod_retroknowledge = []; - mod_delta = mtb1.typ_delta} env - | _ -> env - in - check_structure env body_t1 body_t2 equiv - (join (map_mbid arg_id1 (MPbound arg_id2)) subst1) - subst2 - | _ , _ -> error_incompatible_modtypes mtb1 mtb2 - in - if mtb1'== mtb2' then () - else check_structure env mtb1' mtb2' equiv subst1 subst2 + List.iter check_one_body sig2 + +and check_modtypes env mtb1 mtb2 subst1 subst2 equiv = + if mtb1==mtb2 || mtb1.mod_type == mtb2.mod_type then () + else + let rec check_structure env str1 str2 equiv subst1 subst2 = + match str1,str2 with + | NoFunctor (list1), + NoFunctor (list2) -> + check_signatures env mtb1.mod_mp list1 list2 subst1 subst2; + if equiv then + check_signatures env mtb2.mod_mp list2 list1 subst1 subst2 + else + () + | MoreFunctor (arg_id1,arg_t1,body_t1), + MoreFunctor (arg_id2,arg_t2,body_t2) -> + check_modtypes env + arg_t2 arg_t1 + (map_mp arg_t1.mod_mp arg_t2.mod_mp) subst2 + equiv; + (* contravariant *) + let env = add_module_type (MPbound arg_id2) arg_t2 env in + let env = + if is_functor body_t1 then env + else + let env = shallow_remove_module mtb1.mod_mp env in + add_module {mod_mp = mtb1.mod_mp; + mod_expr = Abstract; + mod_type = body_t1; + mod_type_alg = None; + mod_constraints = mtb1.mod_constraints; + mod_retroknowledge = []; + mod_delta = mtb1.mod_delta} env + in + check_structure env body_t1 body_t2 equiv + (join (map_mbid arg_id1 (MPbound arg_id2)) subst1) + subst2 + | _ , _ -> error_incompatible_modtypes mtb1 mtb2 + in + check_structure env mtb1.mod_type mtb2.mod_type equiv subst1 subst2 let check_subtypes env sup super = - check_modtypes env (strengthen sup sup.typ_mp) super empty_subst - (map_mp super.typ_mp sup.typ_mp) false + check_modtypes env (strengthen sup sup.mod_mp) super empty_subst + (map_mp super.mod_mp sup.mod_mp) false diff --git a/checker/subtyping.mli b/checker/subtyping.mli index bef5a6b1..03242cbc 100644 --- a/checker/subtyping.mli +++ b/checker/subtyping.mli @@ -1,15 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* InProp | Prop Pos -> InSet | Type _ -> InType -let val_sort = val_sum "sort" 0 [|[|val_enum "cnt" 2|];[|val_univ|]|] -let val_sortfam = val_enum "sorts_family" 3 +let family_equal = (==) + +let sort_of_univ u = + if Univ.is_type0m_univ u then Prop Null + else if Univ.is_type0_univ u then Prop Pos + else Type u (********************************************************************) (* Constructions as implemented *) (********************************************************************) -(* [constr array] is an instance matching definitional [named_context] in - the same order (i.e. last argument first) *) -type 'constr pexistential = existential_key * 'constr array -type 'constr prec_declaration = - name array * 'constr array * 'constr array -type 'constr pfixpoint = - (int array * int) * 'constr prec_declaration -type 'constr pcofixpoint = - int * 'constr prec_declaration - -let val_evar f = val_tuple ~name:"pexistential" [|val_int;val_array f|] -let val_prec f = - val_tuple ~name:"prec_declaration" - [|val_array val_name; val_array f; val_array f|] -let val_fix f = - val_tuple ~name:"pfixpoint" - [|val_tuple~name:"fix2"[|val_array val_int;val_int|];val_prec f|] -let val_cofix f = val_tuple ~name:"pcofixpoint"[|val_int;val_prec f|] - -type cast_kind = VMcast | DEFAULTcast -let val_cast = val_enum "cast_kind" 2 - -(*s*******************************************************************) -(* The type of constructions *) - -type constr = - | Rel of int - | Var of identifier - | Meta of metavariable - | Evar of constr pexistential - | Sort of sorts - | Cast of constr * cast_kind * constr - | Prod of name * constr * constr - | Lambda of name * constr * constr - | LetIn of name * constr * constr * constr - | App of constr * constr array - | Const of constant - | Ind of inductive - | Construct of constructor - | Case of case_info * constr * constr * constr array - | Fix of constr pfixpoint - | CoFix of constr pcofixpoint - -let val_constr = val_rec_sum "constr" 0 (fun val_constr -> [| - [|val_int|]; (* Rel *) - [|val_id|]; (* Var *) - [|val_int|]; (* Meta *) - [|val_evar val_constr|]; (* Evar *) - [|val_sort|]; (* Sort *) - [|val_constr;val_cast;val_constr|]; (* Cast *) - [|val_name;val_constr;val_constr|]; (* Prod *) - [|val_name;val_constr;val_constr|]; (* Lambda *) - [|val_name;val_constr;val_constr;val_constr|]; (* LetIn *) - [|val_constr;val_array val_constr|]; (* App *) - [|val_con|]; (* Const *) - [|val_ind|]; (* Ind *) - [|val_cstr|]; (* Construct *) - [|val_ci;val_constr;val_constr;val_array val_constr|]; (* Case *) - [|val_fix val_constr|]; (* Fix *) - [|val_cofix val_constr|] (* CoFix *) -|]) - -type existential = constr pexistential -type rec_declaration = constr prec_declaration -type fixpoint = constr pfixpoint -type cofixpoint = constr pcofixpoint - - let rec strip_outer_cast c = match c with | Cast (c,_,_) -> strip_outer_cast c | _ -> c -let rec collapse_appl c = match c with +let collapse_appl c = match c with | App (f,cl) -> let rec collapse_rec f cl2 = match (strip_outer_cast f) with @@ -176,6 +80,7 @@ let iter_constr_with_binders g f n c = match c with | CoFix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl + | Proj (p, c) -> f n c exception LocalOccur @@ -197,7 +102,7 @@ let closed0 = closedn 0 let noccurn n term = let rec occur_rec n c = match c with - | Rel m -> if m = n then raise LocalOccur + | Rel m -> if Int.equal m n then raise LocalOccur | _ -> iter_constr_with_binders succ occur_rec n c in try occur_rec n term; true with LocalOccur -> false @@ -221,7 +126,7 @@ let noccur_between n m term = let noccur_with_meta n m term = let rec occur_rec n c = match c with - | Rel p -> if n<=p & p if n<=p && p (match f with | (Cast (Meta _,_,_)| Meta _) -> () @@ -252,6 +157,7 @@ let map_constr_with_binders g f l c = match c with | CoFix(ln,(lna,tl,bl)) -> let l' = iterate g (Array.length tl) l in CoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) + | Proj (p, c) -> Proj (p, f l c) (* The generic lifting function *) let rec exliftn el c = match c with @@ -291,7 +197,7 @@ let make_substituend c = { sinfo=Unknown; sit=c } let substn_many lamv n c = let lv = Array.length lamv in - if lv = 0 then c + if Int.equal lv 0 then c else let rec substrec depth c = match c with | Rel k -> @@ -311,23 +217,6 @@ let subst1 lam = substl [lam] (* Type of assumptions and contexts *) (***************************************************************************) -let val_ndecl = - val_tuple ~name:"named_declaration"[|val_id;val_opt val_constr;val_constr|] -let val_rdecl = - val_tuple ~name:"rel_declaration"[|val_name;val_opt val_constr;val_constr|] -let val_nctxt = val_list val_ndecl -let val_rctxt = val_list val_rdecl - -type named_declaration = identifier * constr option * constr -type rel_declaration = name * constr option * constr - -type named_context = named_declaration list -let empty_named_context = [] -let fold_named_context f l ~init = List.fold_right f l init - -type section_context = named_context - -type rel_context = rel_declaration list let empty_rel_context = [] let rel_context_length = List.length let rel_context_nhyps hyps = @@ -338,16 +227,14 @@ let rel_context_nhyps hyps = nhyps 0 hyps let fold_rel_context f l ~init = List.fold_right f l init -let map_context f l = +let map_rel_context f l = let map_decl (n, body_o, typ as decl) = let body_o' = Option.smartmap f body_o in let typ' = f typ in if body_o' == body_o && typ' == typ then decl else (n, body_o', typ') in - list_smartmap map_decl l - -let map_rel_context = map_context + List.smartmap map_decl l let extended_rel_list n hyps = let rec reln l p = function @@ -383,7 +270,7 @@ let decompose_lam_n_assum n = if n < 0 then error "decompose_lam_n_assum: integer parameter must be positive"; let rec lamdec_rec l n c = - if n=0 then l,c + if Int.equal n 0 then l,c else match c with | Lambda (x,t,c) -> lamdec_rec ((x,None,t) :: l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec ((x,Some b,t) :: l) n c @@ -416,7 +303,7 @@ let decompose_prod_n_assum n = if n < 0 then error "decompose_prod_n_assum: integer parameter must be positive"; let rec prodec_rec l n c = - if n=0 then l,c + if Int.equal n 0 then l,c else match c with | Prod (x,t,c) -> prodec_rec ((x,None,t) :: l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) (n-1) c @@ -441,7 +328,7 @@ let destArity = | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s - | _ -> anomaly "destArity: not an arity" + | _ -> anomaly ~label:"destArity" (Pp.str "not an arity") in prodec_rec [] @@ -459,40 +346,99 @@ let rec isArity c = (* alpha conversion : ignore print names and casts *) +let compare_sorts s1 s2 = match s1, s2 with +| Prop c1, Prop c2 -> + begin match c1, c2 with + | Pos, Pos | Null, Null -> true + | Pos, Null -> false + | Null, Pos -> false + end +| Type u1, Type u2 -> Univ.Universe.equal u1 u2 +| Prop _, Type _ -> false +| Type _, Prop _ -> false + +let eq_puniverses f (c1,u1) (c2,u2) = + Univ.Instance.equal u1 u2 && f c1 c2 + let compare_constr f t1 t2 = match t1, t2 with - | Rel n1, Rel n2 -> n1 = n2 - | Meta m1, Meta m2 -> m1 = m2 - | Var id1, Var id2 -> id1 = id2 - | Sort s1, Sort s2 -> s1 = s2 + | Rel n1, Rel n2 -> Int.equal n1 n2 + | Meta m1, Meta m2 -> Int.equal m1 m2 + | Var id1, Var id2 -> Id.equal id1 id2 + | Sort s1, Sort s2 -> compare_sorts s1 s2 | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 - | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2 - | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2 - | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2 + | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 && f c1 c2 + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 && f c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 && f t1 t2 && f c1 c2 | App (c1,l1), App (c2,l2) -> - if Array.length l1 = Array.length l2 then - f c1 c2 & array_for_all2 f l1 l2 + if Int.equal (Array.length l1) (Array.length l2) then + f c1 c2 && Array.for_all2 f l1 l2 else let (h1,l1) = decompose_app t1 in let (h2,l2) = decompose_app t2 in - if List.length l1 = List.length l2 then - f h1 h2 & List.for_all2 f l1 l2 + if Int.equal (List.length l1) (List.length l2) then + f h1 h2 && List.for_all2 f l1 l2 else false - | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2 - | Const c1, Const c2 -> eq_con_chk c1 c2 - | Ind c1, Ind c2 -> eq_ind_chk c1 c2 - | Construct (c1,i1), Construct (c2,i2) -> i1=i2 && eq_ind_chk c1 c2 + | Evar (e1,l1), Evar (e2,l2) -> Int.equal e1 e2 && Array.equal f l1 l2 + | Const c1, Const c2 -> eq_puniverses eq_con_chk c1 c2 + | Ind c1, Ind c2 -> eq_puniverses eq_ind_chk c1 c2 + | Construct ((c1,i1),u1), Construct ((c2,i2),u2) -> Int.equal i1 i2 && eq_ind_chk c1 c2 + && Univ.Instance.equal u1 u2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> - f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2 - | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> - ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 + f p1 p2 && f c1 c2 && Array.equal f bl1 bl2 + | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> + Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 && + Array.equal f tl1 tl2 && Array.equal f bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> - ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 + Int.equal ln1 ln2 && Array.equal f tl1 tl2 && Array.equal f bl1 bl2 + | Proj (p1,c1), Proj(p2,c2) -> eq_con_chk p1 p2 && f c1 c2 | _ -> false let rec eq_constr m n = - (m==n) or + (m == n) || compare_constr eq_constr m n let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *) + +(* Universe substitutions *) + +let map_constr f c = map_constr_with_binders (fun x -> x) (fun _ c -> f c) 0 c + +let subst_instance_constr subst c = + if Univ.Instance.is_empty subst then c + else + let f u = Univ.subst_instance_instance subst u in + let changed = ref false in + let rec aux t = + match t with + | Const (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; Const (c, u')) + | Ind (i, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; Ind (i, u')) + | Construct (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; Construct (c, u')) + | Sort (Type u) -> + let u' = Univ.subst_instance_universe subst u in + if u' == u then t else + (changed := true; Sort (sort_of_univ u')) + | _ -> map_constr aux t + in + let c' = aux c in + if !changed then c' else c + +let subst_instance_context s ctx = + if Univ.Instance.is_empty s then ctx + else map_rel_context (fun x -> subst_instance_constr s x) ctx diff --git a/checker/term.mli b/checker/term.mli index 0340c79b..ab488b2b 100644 --- a/checker/term.mli +++ b/checker/term.mli @@ -1,50 +1,9 @@ open Names +open Cic -type existential_key = int -type metavariable = int -type case_style = - LetStyle - | IfStyle - | LetPatternStyle - | MatchStyle - | RegularStyle -type case_printing = { ind_nargs : int; style : case_style; } -type case_info = { - ci_ind : inductive; - ci_npar : int; - ci_cstr_ndecls : int array; - ci_pp_info : case_printing; -} -type contents = Pos | Null -type sorts = Prop of contents | Type of Univ.universe -type sorts_family = InProp | InSet | InType val family_of_sort : sorts -> sorts_family -type 'a pexistential = existential_key * 'a array -type 'a prec_declaration = name array * 'a array * 'a array -type 'a pfixpoint = (int array * int) * 'a prec_declaration -type 'a pcofixpoint = int * 'a prec_declaration -type cast_kind = VMcast | DEFAULTcast -type constr = - Rel of int - | Var of identifier - | Meta of metavariable - | Evar of constr pexistential - | Sort of sorts - | Cast of constr * cast_kind * constr - | Prod of name * constr * constr - | Lambda of name * constr * constr - | LetIn of name * constr * constr * constr - | App of constr * constr array - | Const of constant - | Ind of inductive - | Construct of constructor - | Case of case_info * constr * constr * constr array - | Fix of constr pfixpoint - | CoFix of constr pcofixpoint -type existential = constr pexistential -type rec_declaration = constr prec_declaration -type fixpoint = constr pfixpoint -type cofixpoint = constr pcofixpoint +val family_equal : sorts_family -> sorts_family -> bool + val strip_outer_cast : constr -> constr val collapse_appl : constr -> constr val decompose_app : constr -> constr * constr list @@ -71,20 +30,11 @@ val substnl : constr list -> int -> constr -> constr val substl : constr list -> constr -> constr val subst1 : constr -> constr -> constr -type named_declaration = identifier * constr option * constr -type rel_declaration = name * constr option * constr -type named_context = named_declaration list -val empty_named_context : named_context -val fold_named_context : - (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a -type section_context = named_context -type rel_context = rel_declaration list val empty_rel_context : rel_context val rel_context_length : rel_context -> int val rel_context_nhyps : rel_context -> int val fold_rel_context : (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a -val map_context : (constr -> constr) -> named_context -> named_context val map_rel_context : (constr -> constr) -> rel_context -> rel_context val extended_rel_list : int -> rel_context -> constr list val compose_lam : (name * constr) list -> constr -> constr @@ -96,15 +46,13 @@ val decompose_prod_assum : constr -> rel_context * constr val decompose_prod_n_assum : int -> constr -> rel_context * constr type arity = rel_context * sorts + val mkArity : arity -> constr val destArity : constr -> arity val isArity : constr -> bool val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool val eq_constr : constr -> constr -> bool -(* Validation *) -val val_sortfam : Validate.func -val val_sort : Validate.func -val val_constr : Validate.func -val val_rctxt : Validate.func -val val_nctxt : Validate.func +(** Instance substitution for polymorphism. *) +val subst_instance_constr : Univ.universe_instance -> constr -> constr +val subst_instance_context : Univ.universe_instance -> rel_context -> rel_context diff --git a/checker/type_errors.ml b/checker/type_errors.ml index e25f7d18..c4c65286 100644 --- a/checker/type_errors.ml +++ b/checker/type_errors.ml @@ -1,13 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unsafe_judgment -> 'a val error_reference_variables : env -> constr -> 'a val error_elim_arity : - env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> + env -> pinductive -> sorts_family list -> constr -> unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a @@ -99,3 +101,4 @@ val error_ill_formed_rec_body : val error_ill_typed_rec_body : env -> int -> name array -> unsafe_judgment array -> constr array -> 'a +val error_unsatisfied_constraints : env -> Univ.constraints -> 'a diff --git a/checker/typeops.ml b/checker/typeops.ml index 6b0c6eaf..9bc4b269 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -1,25 +1,25 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (try conv_leq env t1 t2 with NotConvertible -> raise (NotConvertibleVect i)); ()) @@ -27,6 +27,10 @@ let conv_leq_vecti env v1 v2 = v1 v2 +let check_constraints cst env = + if Environ.check_constraints cst env then () + else error_unsatisfied_constraints env cst + (* This should be a type (a priori without intension to be an assumption) *) let type_judgment env (c,ty as j) = match whd_betadeltaiota env ty with @@ -48,11 +52,11 @@ let assumption_of_judgment env j = (* Prop and Set *) -let judge_of_prop = Sort (Type type1_univ) +let judge_of_prop = Sort (Type Univ.type1_univ) (* Type of Type(i). *) -let judge_of_type u = Sort (Type (super u)) +let judge_of_type u = Sort (Type (Univ.super u)) (*s Type of a de Bruijn index. *) @@ -63,53 +67,36 @@ let judge_of_relative env n = with Not_found -> error_unbound_rel env n -(* Type of variables *) -let judge_of_variable env id = - try named_type id env - with Not_found -> - error_unbound_var env id - -(* Management of context of variables. *) - -(* Checks if a context of variable can be instantiated by the - variables of the current env *) -(* TODO: check order? *) -let rec check_hyps_inclusion env sign = - fold_named_context - (fun (id,_,ty1) () -> - let ty2 = named_type id env in - if not (eq_constr ty2 ty1) then - error "types do not match") - sign - ~init:() - - -let check_args env c hyps = - try check_hyps_inclusion env hyps - with UserError _ | Not_found -> - error_reference_variables env c - (* Type of constants *) -let type_of_constant_knowing_parameters env t paramtyps = + +let type_of_constant_type_knowing_parameters env t paramtyps = match t with - | NonPolymorphicType t -> t - | PolymorphicArity (sign,ar) -> + | RegularArity t -> t + | TemplateArity (sign,ar) -> let ctx = List.rev sign in let ctx,s = instantiate_universes env ctx ar paramtyps in mkArity (List.rev ctx,s) +let type_of_constant_knowing_parameters env cst paramtyps = + let ty, cu = constant_type env cst in + type_of_constant_type_knowing_parameters env ty paramtyps, cu + let type_of_constant_type env t = - type_of_constant_knowing_parameters env t [||] + type_of_constant_type_knowing_parameters env t [||] -let judge_of_constant_knowing_parameters env cst paramstyp = - let c = Const cst in - let cb = - try lookup_constant cst env +let type_of_constant env cst = + type_of_constant_knowing_parameters env cst [||] + +let judge_of_constant_knowing_parameters env (kn,u as cst) paramstyp = + let _cb = + try lookup_constant kn env with Not_found -> - failwith ("Cannot find constant: "^string_of_con cst) in - let _ = check_args env c cb.const_hyps in - type_of_constant_knowing_parameters env cb.const_type paramstyp + failwith ("Cannot find constant: "^string_of_con kn) + in + let ty, cu = type_of_constant_knowing_parameters env cst paramstyp in + let () = check_constraints cu env in + ty let judge_of_constant env cst = judge_of_constant_knowing_parameters env cst [||] @@ -146,13 +133,13 @@ let sort_of_product env domsort rangsort = rangsort else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) - Type (sup u1 type0_univ) + Type (Univ.sup u1 Univ.type0_univ) (* Product rule (Prop,Type_i,Type_i) *) - | (Prop Pos, Type u2) -> Type (sup type0_univ u2) + | (Prop Pos, Type u2) -> Type (Univ.sup Univ.type0_univ u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) - | (Type u1, Type u2) -> Type (sup u1 u2) + | (Type u1, Type u2) -> Type (Univ.sup u1 u2) (* Type of a type cast *) @@ -166,7 +153,7 @@ let sort_of_product env domsort rangsort = let judge_of_cast env (c,cj) k tj = let conversion = match k with - | VMcast -> vm_conv CUMUL + | VMcast | NATIVEcast -> vm_conv CUMUL | DEFAULTcast -> conv_leq in try conversion env cj tj @@ -187,31 +174,27 @@ let judge_of_cast env (c,cj) k tj = the App case of execute; from this constraints, the expected dynamic constraints of the form u<=v are enforced *) -let judge_of_inductive_knowing_parameters env ind (paramstyp:constr array) = - let c = Ind ind in - let (mib,mip) = +let judge_of_inductive_knowing_parameters env (ind,u) (paramstyp:constr array) = + let specif = try lookup_mind_specif env ind with Not_found -> - failwith ("Cannot find inductive: "^string_of_mind (fst ind)) in - check_args env c mib.mind_hyps; - type_of_inductive_knowing_parameters env mip paramstyp + failwith ("Cannot find inductive: "^string_of_mind (fst ind)) + in + type_of_inductive_knowing_parameters env (specif,u) paramstyp let judge_of_inductive env ind = judge_of_inductive_knowing_parameters env ind [||] (* Constructors. *) -let judge_of_constructor env c = - let constr = Construct c in - let _ = - let ((kn,_),_) = c in - let mib = - try lookup_mind kn env - with Not_found -> - failwith ("Cannot find inductive: "^string_of_mind (fst (fst c))) in - check_args env constr mib.mind_hyps in - let specif = lookup_mind_specif env (inductive_of_constructor c) in - type_of_constructor c specif +let judge_of_constructor env (c,u) = + let ind = inductive_of_constructor c in + let specif = + try lookup_mind_specif env ind + with Not_found -> + failwith ("Cannot find inductive: "^string_of_mind (fst ind)) + in + type_of_constructor (c,u) specif (* Case. *) @@ -227,11 +210,23 @@ let judge_of_case env ci pj (c,cj) lfj = let indspec = try find_rectype env cj with Not_found -> error_case_not_inductive env (c,cj) in - let _ = check_case_info env (fst indspec) ci in + let _ = check_case_info env (fst (fst indspec)) ci in let (bty,rslty) = type_case_branches env indspec pj c in check_branch_types env (c,cj) (lfj,bty); rslty +(* Projection. *) + +let judge_of_projection env p c ct = + let pb = lookup_projection p env in + let (ind,u), args = + try find_rectype env ct + with Not_found -> error_case_not_inductive env (c, ct) + in + assert(eq_mind pb.proj_ind (fst ind)); + let ty = subst_instance_constr u pb.proj_type in + substl (c :: List.rev args) ty + (* Fixpoints. *) (* Checks the type of a general (co)fixpoint, i.e. without checking *) @@ -243,21 +238,21 @@ let type_fixpoint env lna lar lbody vdefj = try conv_leq_vecti env vdefj (Array.map (fun ty -> lift lt ty) lar) with NotConvertibleVect i -> - let vdefj = array_map2 (fun b ty -> b,ty) lbody vdefj in + let vdefj = Array.map2 (fun b ty -> b,ty) lbody vdefj in error_ill_typed_rec_body env i lna vdefj lar (************************************************************************) (************************************************************************) -let refresh_arity env ar = - let ctxt, hd = decompose_prod_assum ar in - match hd with - Sort (Type u) when not (is_univ_variable u) -> - let u' = fresh_local_univ() in - let env' = add_constraints (enforce_geq u' u empty_constraint) env in - env', mkArity (ctxt,Type u') - | _ -> env, ar +(* let refresh_arity env ar = *) +(* let ctxt, hd = decompose_prod_assum ar in *) +(* match hd with *) +(* Sort (Type u) when not (is_univ_variable u) -> *) +(* let u' = fresh_local_univ() in *) +(* let env' = add_constraints (enforce_leq u u' empty_constraint) env in *) +(* env', mkArity (ctxt,Type u') *) +(* | _ -> env, ar *) (* The typing machine. *) @@ -270,7 +265,7 @@ let rec execute env cstr = | Rel n -> judge_of_relative env n - | Var id -> judge_of_variable env id + | Var _ -> anomaly (Pp.str "Section variable in Coqchk !") | Const c -> judge_of_constant env c @@ -292,9 +287,13 @@ let rec execute env cstr = (* No sort-polymorphism *) execute env f in - let jl = array_map2 (fun c ty -> c,ty) args jl in + let jl = Array.map2 (fun c ty -> c,ty) args jl in judge_of_apply env (f,j) jl + | Proj (p, c) -> + let ct = execute env c in + judge_of_projection env p c ct + | Lambda (name,c1,c2) -> let _ = execute_type env c1 in let env1 = push_rel (name,None,c1) env in @@ -312,7 +311,7 @@ let rec execute env cstr = (* /!\ c2 can be an inferred type => refresh (but the pushed type is still c2) *) let _ = - let env',c2' = refresh_arity env c2 in + let env',c2' = (* refresh_arity env *) env, c2 in let _ = execute_type env' c2' in judge_of_cast env' (c1,j1) DEFAULTcast c2' in let env1 = push_rel (name,Some c1,c2) env in @@ -350,10 +349,10 @@ let rec execute env cstr = (* Partial proofs: unsupported by the kernel *) | Meta _ -> - anomaly "the kernel does not support metavariables" + anomaly (Pp.str "the kernel does not support metavariables") | Evar _ -> - anomaly "the kernel does not support existential variables" + anomaly (Pp.str "the kernel does not support existential variables") and execute_type env constr = let j = execute env constr in @@ -361,7 +360,7 @@ and execute_type env constr = and execute_recdef env (names,lar,vdef) i = let larj = execute_array env lar in - let larj = array_map2 (fun c ty -> c,ty) lar larj in + let larj = Array.map2 (fun c ty -> c,ty) lar larj in let lara = Array.map (assumption_of_judgment env) larj in let env1 = push_rec_types (names,lara,vdef) env in let vdefj = execute_array env1 vdef in @@ -389,32 +388,15 @@ let check_ctxt env rels = push_rel d env) rels ~init:env -let check_named_ctxt env ctxt = - fold_named_context (fun (id,_,_ as d) env -> - let _ = - try - let _ = lookup_named id env in - failwith ("variable "^string_of_id id^" defined twice") - with Not_found -> () in - match d with - (_,None,ty) -> - let _ = infer_type env ty in - push_named d env - | (_,Some bd,ty) -> - let j1 = infer env bd in - let _ = infer env ty in - conv_leq env j1 ty; - push_named d env) - ctxt ~init:env - (* Polymorphic arities utils *) let check_kind env ar u = - if snd (dest_prod env ar) = Sort(Type u) then () - else failwith "not the correct sort" + match (snd (dest_prod env ar)) with + | Sort (Type u') when Univ.Universe.equal u' (Univ.Universe.make u) -> () + | _ -> failwith "not the correct sort" let check_polymorphic_arity env params par = - let pl = par.poly_param_levels in + let pl = par.template_param_levels in let rec check_p env pl params = match pl, params with Some u::pl, (na,None,ty)::params -> diff --git a/checker/typeops.mli b/checker/typeops.mli index bd7249f1..39d66041 100644 --- a/checker/typeops.mli +++ b/checker/typeops.mli @@ -1,15 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr -> constr val infer_type : env -> constr -> sorts val check_ctxt : env -> rel_context -> env -val check_named_ctxt : env -> named_context -> env val check_polymorphic_arity : - env -> rel_context -> polymorphic_arity -> unit + env -> rel_context -> template_arity -> unit val type_of_constant_type : env -> constant_type -> constr diff --git a/checker/univ.ml b/checker/univ.ml new file mode 100644 index 00000000..5fed6dcd --- /dev/null +++ b/checker/univ.ml @@ -0,0 +1,1253 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int + val equal : t -> t -> bool + val hcons : t -> t +end + +module HashedList (M : Hashconsed) : +sig + type t = private Nil | Cons of M.t * int * t + val nil : t + val cons : M.t -> t -> t +end = +struct + type t = Nil | Cons of M.t * int * t + module Self = + struct + type _t = t + type t = _t + type u = (M.t -> M.t) + let hash = function Nil -> 0 | Cons (_, h, _) -> h + let equal l1 l2 = match l1, l2 with + | Nil, Nil -> true + | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 + | _ -> false + let hashcons hc = function + | Nil -> Nil + | Cons (x, h, l) -> Cons (hc x, h, l) + end + module Hcons = Hashcons.Make(Self) + let hcons = Hashcons.simple_hcons Hcons.generate Hcons.hcons M.hcons + (** No recursive call: the interface guarantees that all HLists from this + program are already hashconsed. If we get some external HList, we can + still reconstruct it by traversing it entirely. *) + let nil = Nil + let cons x l = + let h = M.hash x in + let hl = match l with Nil -> 0 | Cons (_, h, _) -> h in + let h = Hashset.Combine.combine h hl in + hcons (Cons (x, h, l)) +end + +module HList = struct + + module type S = sig + type elt + type t = private Nil | Cons of elt * int * t + val hash : t -> int + val nil : t + val cons : elt -> t -> t + val tip : elt -> t + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val map : (elt -> elt) -> t -> t + val smartmap : (elt -> elt) -> t -> t + val exists : (elt -> bool) -> t -> bool + val for_all : (elt -> bool) -> t -> bool + val for_all2 : (elt -> elt -> bool) -> t -> t -> bool + val remove : elt -> t -> t + val to_list : t -> elt list + end + + module Make (H : Hashconsed) : S with type elt = H.t = + struct + type elt = H.t + include HashedList(H) + + let hash = function Nil -> 0 | Cons (_, h, _) -> h + + let tip e = cons e nil + + let rec fold f l accu = match l with + | Nil -> accu + | Cons (x, _, l) -> fold f l (f x accu) + + let rec map f = function + | Nil -> nil + | Cons (x, _, l) -> cons (f x) (map f l) + + let smartmap = map + (** Apriori hashconsing ensures that the map is equal to its argument *) + + let rec exists f = function + | Nil -> false + | Cons (x, _, l) -> f x || exists f l + + let rec for_all f = function + | Nil -> true + | Cons (x, _, l) -> f x && for_all f l + + let rec for_all2 f l1 l2 = match l1, l2 with + | Nil, Nil -> true + | Cons (x1, _, l1), Cons (x2, _, l2) -> f x1 x2 && for_all2 f l1 l2 + | _ -> false + + let rec to_list = function + | Nil -> [] + | Cons (x, _, l) -> x :: to_list l + + let rec remove x = function + | Nil -> nil + | Cons (y, _, l) -> + if H.equal x y then l + else cons y (remove x l) + + end +end + +module RawLevel = +struct + open Names + type t = + | Prop + | Set + | Level of int * DirPath.t + | Var of int + + (* Hash-consing *) + + let equal x y = + x == y || + match x, y with + | Prop, Prop -> true + | Set, Set -> true + | Level (n,d), Level (n',d') -> + Int.equal n n' && DirPath.equal d d' + | Var n, Var n' -> Int.equal n n' + | _ -> false + + let compare u v = + match u, v with + | Prop,Prop -> 0 + | Prop, _ -> -1 + | _, Prop -> 1 + | Set, Set -> 0 + | Set, _ -> -1 + | _, Set -> 1 + | Level (i1, dp1), Level (i2, dp2) -> + if i1 < i2 then -1 + else if i1 > i2 then 1 + else DirPath.compare dp1 dp2 + | Level _, _ -> -1 + | _, Level _ -> 1 + | Var n, Var m -> Int.compare n m + + let hcons = function + | Prop as x -> x + | Set as x -> x + | Level (n,d) as x -> + let d' = Names.DirPath.hcons d in + if d' == d then x else Level (n,d') + | Var n as x -> x + + open Hashset.Combine + + let hash = function + | Prop -> combinesmall 1 0 + | Set -> combinesmall 1 1 + | Var n -> combinesmall 2 n + | Level (n, d) -> combinesmall 3 (combine n (Names.DirPath.hash d)) +end + +module Level = struct + + open Names + + type raw_level = RawLevel.t = + | Prop + | Set + | Level of int * DirPath.t + | Var of int + + (** Embed levels with their hash value *) + type t = { + hash : int; + data : RawLevel.t } + + let equal x y = + x == y || Int.equal x.hash y.hash && RawLevel.equal x.data y.data + + let hash x = x.hash + + let hcons x = + let data' = RawLevel.hcons x.data in + if data' == x.data then x + else { x with data = data' } + + let data x = x.data + + (** Hashcons on levels + their hash *) + + let make = + let module Self = struct + type _t = t + type t = _t + let equal = equal + let hash = hash + end in + let module WH = Weak.Make(Self) in + let pool = WH.create 4910 in fun x -> + let x = { hash = RawLevel.hash x; data = x } in + try WH.find pool x + with Not_found -> WH.add pool x; x + + let set = make Set + let prop = make Prop + + let is_small x = + match data x with + | Level _ -> false + | _ -> true + + let is_prop x = + match data x with + | Prop -> true + | _ -> false + + let is_set x = + match data x with + | Set -> true + | _ -> false + + let compare u v = + if u == v then 0 + else + let c = Int.compare (hash u) (hash v) in + if c == 0 then RawLevel.compare (data u) (data v) + else c + + let to_string x = + match data x with + | Prop -> "Prop" + | Set -> "Set" + | Level (n,d) -> Names.DirPath.to_string d^"."^string_of_int n + | Var i -> "Var("^string_of_int i^")" + + let pr u = str (to_string u) + + let make m n = make (Level (n, Names.DirPath.hcons m)) + +end + +(** Level sets and maps *) +module LSet = Set.Make (Level) +module LMap = Map.Make (Level) + +type 'a universe_map = 'a LMap.t + +type universe_level = Level.t + +type universe_level_subst_fn = universe_level -> universe_level + +(* An algebraic universe [universe] is either a universe variable + [Level.t] or a formal universe known to be greater than some + universe variables and strictly greater than some (other) universe + variables + + Universes variables denote universes initially present in the term + to type-check and non variable algebraic universes denote the + universes inferred while type-checking: it is either the successor + of a universe present in the initial term to type-check or the + maximum of two algebraic universes +*) + +module Universe = +struct + (* Invariants: non empty, sorted and without duplicates *) + + module Expr = + struct + type t = Level.t * int + type _t = t + + (* Hashing of expressions *) + module ExprHash = + struct + type t = _t + type u = Level.t -> Level.t + let hashcons hdir (b,n as x) = + let b' = hdir b in + if b' == b then x else (b',n) + let equal l1 l2 = + l1 == l2 || + match l1,l2 with + | (b,n), (b',n') -> b == b' && n == n' + + let hash (x, n) = n + Level.hash x + + end + + module HExpr = + struct + + module H = Hashcons.Make(ExprHash) + + type t = ExprHash.t + + let hcons = + Hashcons.simple_hcons H.generate H.hcons Level.hcons + let hash = ExprHash.hash + let equal x y = x == y || + (let (u,n) = x and (v,n') = y in + Int.equal n n' && Level.equal u v) + + end + + let hcons = HExpr.hcons + + let make l = hcons (l, 0) + + let prop = make Level.prop + let set = make Level.set + let type1 = hcons (Level.set, 1) + + let is_prop = function + | (l,0) -> Level.is_prop l + | _ -> false + + let equal x y = x == y || + (let (u,n) = x and (v,n') = y in + Int.equal n n' && Level.equal u v) + + let leq (u,n) (v,n') = + let cmp = Level.compare u v in + if Int.equal cmp 0 then n <= n' + else if n <= n' then + (Level.is_prop u && Level.is_small v) + else false + + let successor (u,n) = + if Level.is_prop u then type1 + else hcons (u, n + 1) + + let addn k (u,n as x) = + if k = 0 then x + else if Level.is_prop u then + hcons (Level.set,n+k) + else hcons (u,n+k) + + let super (u,n as x) (v,n' as y) = + let cmp = Level.compare u v in + if Int.equal cmp 0 then + if n < n' then Inl true + else Inl false + else if is_prop x then Inl true + else if is_prop y then Inl false + else Inr cmp + + let to_string (v, n) = + if Int.equal n 0 then Level.to_string v + else Level.to_string v ^ "+" ^ string_of_int n + + let pr x = str(to_string x) + + let level = function + | (v,0) -> Some v + | _ -> None + + let map f (v, n as x) = + let v' = f v in + if v' == v then x + else if Level.is_prop v' && n != 0 then + hcons (Level.set, n) + else hcons (v', n) + + end + + module Huniv = HList.Make(Expr.HExpr) + type t = Huniv.t + open Huniv + + let equal x y = x == y || + (Huniv.hash x == Huniv.hash y && + Huniv.for_all2 Expr.equal x y) + + let make l = Huniv.tip (Expr.make l) + let tip x = Huniv.tip x + + let pr l = match l with + | Cons (u, _, Nil) -> Expr.pr u + | _ -> + str "max(" ++ hov 0 + (prlist_with_sep pr_comma Expr.pr (to_list l)) ++ + str ")" + + let level l = match l with + | Cons (l, _, Nil) -> Expr.level l + | _ -> None + + (* The lower predicative level of the hierarchy that contains (impredicative) + Prop and singleton inductive types *) + let type0m = tip Expr.prop + + (* The level of sets *) + let type0 = tip Expr.set + + (* When typing [Prop] and [Set], there is no constraint on the level, + hence the definition of [type1_univ], the type of [Prop] *) + let type1 = tip (Expr.successor Expr.set) + + let is_type0m x = equal type0m x + let is_type0 x = equal type0 x + + (* Returns the formal universe that lies juste above the universe variable u. + Used to type the sort u. *) + let super l = + Huniv.map (fun x -> Expr.successor x) l + + let addn n l = + Huniv.map (fun x -> Expr.addn n x) l + + let rec merge_univs l1 l2 = + match l1, l2 with + | Nil, _ -> l2 + | _, Nil -> l1 + | Cons (h1, _, t1), Cons (h2, _, t2) -> + (match Expr.super h1 h2 with + | Inl true (* h1 < h2 *) -> merge_univs t1 l2 + | Inl false -> merge_univs l1 t2 + | Inr c -> + if c <= 0 (* h1 < h2 is name order *) + then cons h1 (merge_univs t1 l2) + else cons h2 (merge_univs l1 t2)) + + let sort u = + let rec aux a l = + match l with + | Cons (b, _, l') -> + (match Expr.super a b with + | Inl false -> aux a l' + | Inl true -> l + | Inr c -> + if c <= 0 then cons a l + else cons b (aux a l')) + | Nil -> cons a l + in + fold (fun a acc -> aux a acc) u nil + + (* Returns the formal universe that is greater than the universes u and v. + Used to type the products. *) + let sup x y = merge_univs x y + + let empty = nil + + let exists = Huniv.exists + + let for_all = Huniv.for_all + + let smartmap = Huniv.smartmap + +end + +type universe = Universe.t + +(* The level of predicative Set *) +let type0m_univ = Universe.type0m +let type0_univ = Universe.type0 +let type1_univ = Universe.type1 +let is_type0m_univ = Universe.is_type0m +let is_type0_univ = Universe.is_type0 +let is_univ_variable l = Universe.level l != None +let pr_uni = Universe.pr + +let sup = Universe.sup +let super = Universe.super + +open Universe + +(* Comparison on this type is pointer equality *) +type canonical_arc = + { univ: Level.t; + lt: Level.t list; + le: Level.t list; + rank : int; + predicative : bool} + +let terminal u = {univ=u; lt=[]; le=[]; rank=0; predicative=false} + +module UMap : +sig + type key = Level.t + type +'a t + val empty : 'a t + val add : key -> 'a -> 'a t -> 'a t + val find : key -> 'a t -> 'a + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b +end = HMap.Make(Level) + +(* A Level.t is either an alias for another one, or a canonical one, + for which we know the universes that are above *) + +type univ_entry = + Canonical of canonical_arc + | Equiv of Level.t + +type universes = univ_entry UMap.t + +let enter_equiv_arc u v g = + UMap.add u (Equiv v) g + +let enter_arc ca g = + UMap.add ca.univ (Canonical ca) g + +(* Every Level.t has a unique canonical arc representative *) + +(* repr : universes -> Level.t -> canonical_arc *) +(* canonical representative : we follow the Equiv links *) + +let repr g u = + let rec repr_rec u = + let a = + try UMap.find u g + with Not_found -> anomaly ~label:"Univ.repr" + (str"Universe " ++ Level.pr u ++ str" undefined") + in + match a with + | Equiv v -> repr_rec v + | Canonical arc -> arc + in + repr_rec u + +(* [safe_repr] also search for the canonical representative, but + if the graph doesn't contain the searched universe, we add it. *) + +let safe_repr g u = + let rec safe_repr_rec u = + match UMap.find u g with + | Equiv v -> safe_repr_rec v + | Canonical arc -> arc + in + try g, safe_repr_rec u + with Not_found -> + let can = terminal u in + enter_arc can g, can + +(* reprleq : canonical_arc -> canonical_arc list *) +(* All canonical arcv such that arcu<=arcv with arcv#arcu *) +let reprleq g arcu = + let rec searchrec w = function + | [] -> w + | v :: vl -> + let arcv = repr g v in + if List.memq arcv w || arcu==arcv then + searchrec w vl + else + searchrec (arcv :: w) vl + in + searchrec [] arcu.le + + +(* between : Level.t -> canonical_arc -> canonical_arc list *) +(* between u v = { w | u<=w<=v, w canonical } *) +(* between is the most costly operation *) + +let between g arcu arcv = + (* good are all w | u <= w <= v *) + (* bad are all w | u <= w ~<= v *) + (* find good and bad nodes in {w | u <= w} *) + (* explore b u = (b or "u is good") *) + let rec explore ((good, bad, b) as input) arcu = + if List.memq arcu good then + (good, bad, true) (* b or true *) + else if List.memq arcu bad then + input (* (good, bad, b or false) *) + else + let leq = reprleq g arcu in + (* is some universe >= u good ? *) + let good, bad, b_leq = + List.fold_left explore (good, bad, false) leq + in + if b_leq then + arcu::good, bad, true (* b or true *) + else + good, arcu::bad, b (* b or false *) + in + let good,_,_ = explore ([arcv],[],false) arcu in + good + +(* We assume compare(u,v) = LE with v canonical (see compare below). + In this case List.hd(between g u v) = repr u + Otherwise, between g u v = [] + *) + +type constraint_type = Lt | Le | Eq + +let constraint_type_ord c1 c2 = match c1, c2 with +| Lt, Lt -> 0 +| Lt, _ -> -1 +| Le, Lt -> 1 +| Le, Le -> 0 +| Le, Eq -> -1 +| Eq, Eq -> 0 +| Eq, _ -> 1 + +(** [compare_neq] : is [arcv] in the transitive upward closure of [arcu] ? + + In [strict] mode, we fully distinguish between LE and LT, while in + non-strict mode, we simply answer LE for both situations. + + If [arcv] is encountered in a LT part, we could directly answer + without visiting unneeded parts of this transitive closure. + In [strict] mode, if [arcv] is encountered in a LE part, we could only + change the default answer (1st arg [c]) from NLE to LE, since a strict + constraint may appear later. During the recursive traversal, + [lt_done] and [le_done] are universes we have already visited, + they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)], + two lists of universes not yet considered, known to be above [arcu], + strictly or not. + + We use depth-first search, but the presence of [arcv] in [new_lt] + is checked as soon as possible : this seems to be slightly faster + on a test. +*) + +type fast_order = FastEQ | FastLT | FastLE | FastNLE + +let fast_compare_neq strict g arcu arcv = + (* [c] characterizes whether arcv has already been related + to arcu among the lt_done,le_done universe *) + let rec cmp c lt_done le_done lt_todo le_todo = match lt_todo, le_todo with + | [],[] -> c + | arc::lt_todo, le_todo -> + if List.memq arc lt_done then + cmp c lt_done le_done lt_todo le_todo + else + let rec find lt_todo lt le = match le with + | [] -> + begin match lt with + | [] -> cmp c (arc :: lt_done) le_done lt_todo le_todo + | u :: lt -> + let arc = repr g u in + if arc == arcv then + if strict then FastLT else FastLE + else find (arc :: lt_todo) lt le + end + | u :: le -> + let arc = repr g u in + if arc == arcv then + if strict then FastLT else FastLE + else find (arc :: lt_todo) lt le + in + find lt_todo arc.lt arc.le + | [], arc::le_todo -> + if arc == arcv then + (* No need to continue inspecting universes above arc: + if arcv is strictly above arc, then we would have a cycle. + But we cannot answer LE yet, a stronger constraint may + come later from [le_todo]. *) + if strict then cmp FastLE lt_done le_done [] le_todo else FastLE + else + if (List.memq arc lt_done) || (List.memq arc le_done) then + cmp c lt_done le_done [] le_todo + else + let rec find lt_todo lt = match lt with + | [] -> + let fold accu u = + let node = repr g u in + node :: accu + in + let le_new = List.fold_left fold le_todo arc.le in + cmp c lt_done (arc :: le_done) lt_todo le_new + | u :: lt -> + let arc = repr g u in + if arc == arcv then + if strict then FastLT else FastLE + else find (arc :: lt_todo) lt + in + find [] arc.lt + in + cmp FastNLE [] [] [] [arcu] + +let fast_compare g arcu arcv = + if arcu == arcv then FastEQ else fast_compare_neq true g arcu arcv + +let is_leq g arcu arcv = + arcu == arcv || + (match fast_compare_neq false g arcu arcv with + | FastNLE -> false + | (FastEQ|FastLE|FastLT) -> true) + +let is_lt g arcu arcv = + if arcu == arcv then false + else + match fast_compare_neq true g arcu arcv with + | FastLT -> true + | (FastEQ|FastLE|FastNLE) -> false + +(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ + compare(u,v) = LT or LE => compare(v,u) = NLE + compare(u,v) = NLE => compare(v,u) = NLE or LE or LT + + Adding u>=v is consistent iff compare(v,u) # LT + and then it is redundant iff compare(u,v) # NLE + Adding u>v is consistent iff compare(v,u) = NLE + and then it is redundant iff compare(u,v) = LT *) + +(** * Universe checks [check_eq] and [check_leq], used in coqchk *) + +(** First, checks on universe levels *) + +let check_equal g u v = + let g, arcu = safe_repr g u in + let _, arcv = safe_repr g v in + arcu == arcv + +let check_eq_level g u v = u == v || check_equal g u v + +let is_set_arc u = Level.is_set u.univ +let is_prop_arc u = Level.is_prop u.univ + +let check_smaller g strict u v = + let g, arcu = safe_repr g u in + let g, arcv = safe_repr g v in + if strict then + is_lt g arcu arcv + else + is_prop_arc arcu + || (is_set_arc arcu && arcv.predicative) + || is_leq g arcu arcv + +(** Then, checks on universes *) + +type 'a check_function = universes -> 'a -> 'a -> bool + +let check_equal_expr g x y = + x == y || (let (u, n) = x and (v, m) = y in + Int.equal n m && check_equal g u v) + +let check_eq_univs g l1 l2 = + let f x1 x2 = check_equal_expr g x1 x2 in + let exists x1 l = Huniv.exists (fun x2 -> f x1 x2) l in + Huniv.for_all (fun x1 -> exists x1 l2) l1 + && Huniv.for_all (fun x2 -> exists x2 l1) l2 + +let check_eq g u v = + Universe.equal u v || check_eq_univs g u v + +let check_smaller_expr g (u,n) (v,m) = + let diff = n - m in + match diff with + | 0 -> check_smaller g false u v + | 1 -> check_smaller g true u v + | x when x < 0 -> check_smaller g false u v + | _ -> false + +let exists_bigger g ul l = + Huniv.exists (fun ul' -> + check_smaller_expr g ul ul') l + +let real_check_leq g u v = + Huniv.for_all (fun ul -> exists_bigger g ul v) u + +let check_leq g u v = + Universe.equal u v || + Universe.is_type0m u || + check_eq_univs g u v || real_check_leq g u v + +(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) + +(** To speed up tests of Set Level.t -> reason -> unit *) +(* forces u > v *) +(* this is normally an update of u in g rather than a creation. *) +let setlt g arcu arcv = + let arcu' = {arcu with lt=arcv.univ::arcu.lt} in + let g = + if is_set_arc arcu then set_predicative g arcv + else g + in + enter_arc arcu' g, arcu' + +(* checks that non-redundant *) +let setlt_if (g,arcu) v = + let arcv = repr g v in + if is_lt g arcu arcv then g, arcu + else setlt g arcu arcv + +(* setleq : Level.t -> Level.t -> unit *) +(* forces u >= v *) +(* this is normally an update of u in g rather than a creation. *) +let setleq g arcu arcv = + let arcu' = {arcu with le=arcv.univ::arcu.le} in + let g = + if is_set_arc arcu' then + set_predicative g arcv + else g + in + enter_arc arcu' g, arcu' + +(* checks that non-redundant *) +let setleq_if (g,arcu) v = + let arcv = repr g v in + if is_leq g arcu arcv then g, arcu + else setleq g arcu arcv + +(* merge : Level.t -> Level.t -> unit *) +(* we assume compare(u,v) = LE *) +(* merge u v forces u ~ v with repr u as canonical repr *) +let merge g arcu arcv = + (* we find the arc with the biggest rank, and we redirect all others to it *) + let arcu, g, v = + let best_ranked (max_rank, old_max_rank, best_arc, rest) arc = + if Level.is_small arc.univ || arc.rank >= max_rank + then (arc.rank, max_rank, arc, best_arc::rest) + else (max_rank, old_max_rank, best_arc, arc::rest) + in + match between g arcu arcv with + | [] -> anomaly (str "Univ.between") + | arc::rest -> + let (max_rank, old_max_rank, best_arc, rest) = + List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in + if max_rank > old_max_rank then best_arc, g, rest + else begin + (* one redirected node also has max_rank *) + let arcu = {best_arc with rank = max_rank + 1} in + arcu, enter_arc arcu g, rest + end + in + let redirect (g,w,w') arcv = + let g' = enter_equiv_arc arcv.univ arcu.univ g in + (g',List.unionq arcv.lt w,arcv.le@w') + in + let (g',w,w') = List.fold_left redirect (g,[],[]) v in + let g_arcu = (g',arcu) in + let g_arcu = List.fold_left setlt_if g_arcu w in + let g_arcu = List.fold_left setleq_if g_arcu w' in + fst g_arcu + +(* merge_disc : Level.t -> Level.t -> unit *) +(* we assume compare(u,v) = compare(v,u) = NLE *) +(* merge_disc u v forces u ~ v with repr u as canonical repr *) +let merge_disc g arc1 arc2 = + let arcu, arcv = if arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in + let arcu, g = + if not (Int.equal arc1.rank arc2.rank) then arcu, g + else + let arcu = {arcu with rank = succ arcu.rank} in + arcu, enter_arc arcu g + in + let g' = enter_equiv_arc arcv.univ arcu.univ g in + let g_arcu = (g',arcu) in + let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in + let g_arcu = List.fold_left setleq_if g_arcu arcv.le in + fst g_arcu + +(* Universe inconsistency: error raised when trying to enforce a relation + that would create a cycle in the graph of universes. *) + +type univ_inconsistency = constraint_type * universe * universe + +exception UniverseInconsistency of univ_inconsistency + +let error_inconsistency o u v = + raise (UniverseInconsistency (o,make u,make v)) + +(* enforc_univ_eq : Level.t -> Level.t -> unit *) +(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) + +let enforce_univ_eq u v g = + let g,arcu = safe_repr g u in + let g,arcv = safe_repr g v in + match fast_compare g arcu arcv with + | FastEQ -> g + | FastLT -> error_inconsistency Eq v u + | FastLE -> merge g arcu arcv + | FastNLE -> + (match fast_compare g arcv arcu with + | FastLT -> error_inconsistency Eq u v + | FastLE -> merge g arcv arcu + | FastNLE -> merge_disc g arcu arcv + | FastEQ -> anomaly (Pp.str "Univ.compare")) + +(* enforce_univ_leq : Level.t -> Level.t -> unit *) +(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) +let enforce_univ_leq u v g = + let g,arcu = safe_repr g u in + let g,arcv = safe_repr g v in + if is_leq g arcu arcv then g + else + match fast_compare g arcv arcu with + | FastLT -> error_inconsistency Le u v + | FastLE -> merge g arcv arcu + | FastNLE -> fst (setleq g arcu arcv) + | FastEQ -> anomaly (Pp.str "Univ.compare") + +(* enforce_univ_lt u v will force u g + | FastLE -> fst (setlt g arcu arcv) + | FastEQ -> error_inconsistency Lt u v + | FastNLE -> + match fast_compare_neq false g arcv arcu with + FastNLE -> fst (setlt g arcu arcv) + | FastEQ -> anomaly (Pp.str "Univ.compare") + | FastLE | FastLT -> error_inconsistency Lt u v + +(* Prop = Set is forbidden here. *) +let initial_universes = enforce_univ_lt Level.prop Level.set UMap.empty + +(* Constraints and sets of constraints. *) + +type univ_constraint = Level.t * constraint_type * Level.t + +let enforce_constraint cst g = + match cst with + | (u,Lt,v) -> enforce_univ_lt u v g + | (u,Le,v) -> enforce_univ_leq u v g + | (u,Eq,v) -> enforce_univ_eq u v g + +module UConstraintOrd = +struct + type t = univ_constraint + let compare (u,c,v) (u',c',v') = + let i = constraint_type_ord c c' in + if not (Int.equal i 0) then i + else + let i' = Level.compare u u' in + if not (Int.equal i' 0) then i' + else Level.compare v v' +end + +module Constraint = Set.Make(UConstraintOrd) + +let empty_constraint = Constraint.empty +let merge_constraints c g = + Constraint.fold enforce_constraint c g + +type constraints = Constraint.t + +(** A value with universe constraints. *) +type 'a constrained = 'a * constraints + +(** Constraint functions. *) + +type 'a constraint_function = 'a -> 'a -> constraints -> constraints + +let constraint_add_leq v u c = + (* We just discard trivial constraints like u<=u *) + if Expr.equal v u then c + else + match v, u with + | (x,n), (y,m) -> + let j = m - n in + if j = -1 (* n = m+1, v+1 <= u <-> v < u *) then + Constraint.add (x,Lt,y) c + else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then + if Level.equal x y then (* u+(k+1) <= u *) + raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u)) + else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints") + else if j = 0 then + Constraint.add (x,Le,y) c + else (* j >= 1 *) (* m = n + k, u <= v+k *) + if Level.equal x y then c (* u <= u+k, trivial *) + else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) + else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints") + +let check_univ_leq_one u v = Universe.exists (Expr.leq u) v + +let check_univ_leq u v = + Universe.for_all (fun u -> check_univ_leq_one u v) u + +let enforce_leq u v c = + match v with + | Universe.Huniv.Cons (v, _, Universe.Huniv.Nil) -> + Universe.Huniv.fold (fun u -> constraint_add_leq u v) u c + | _ -> anomaly (Pp.str"A universe bound can only be a variable") + +let enforce_leq u v c = + if check_univ_leq u v then c + else enforce_leq u v c + +let check_constraint g (l,d,r) = + match d with + | Eq -> check_equal g l r + | Le -> check_smaller g false l r + | Lt -> check_smaller g true l r + +let check_constraints c g = + Constraint.for_all (check_constraint g) c + +(**********************************************************************) +(** Universe polymorphism *) +(**********************************************************************) + +(** A universe level substitution, note that no algebraic universes are + involved *) + +type universe_level_subst = universe_level universe_map + +(** A full substitution might involve algebraic universes *) +type universe_subst = universe universe_map + +let level_subst_of f = + fun l -> + try let u = f l in + match Universe.level u with + | None -> l + | Some l -> l + with Not_found -> l + +module Instance : sig + type t = Level.t array + + val empty : t + val is_empty : t -> bool + val equal : t -> t -> bool + val subst_fn : universe_level_subst_fn -> t -> t + val subst : universe_level_subst -> t -> t + val pr : t -> Pp.std_ppcmds + val check_eq : t check_function +end = +struct + type t = Level.t array + + let empty : t = [||] + + module HInstancestruct = + struct + type _t = t + type t = _t + type u = Level.t -> Level.t + + let hashcons huniv a = + let len = Array.length a in + if Int.equal len 0 then empty + else begin + for i = 0 to len - 1 do + let x = Array.unsafe_get a i in + let x' = huniv x in + if x == x' then () + else Array.unsafe_set a i x' + done; + a + end + + let equal t1 t2 = + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) + in aux 0) + + let hash a = + let accu = ref 0 in + for i = 0 to Array.length a - 1 do + let l = Array.unsafe_get a i in + let h = Level.hash l in + accu := Hashset.Combine.combine !accu h; + done; + (* [h] must be positive. *) + let h = !accu land 0x3FFFFFFF in + h + end + + module HInstance = Hashcons.Make(HInstancestruct) + + let hcons = Hashcons.simple_hcons HInstance.generate HInstance.hcons Level.hcons + + let empty = hcons [||] + + let is_empty x = Int.equal (Array.length x) 0 + + let subst_fn fn t = + let t' = CArray.smartmap fn t in + if t' == t then t else hcons t' + + let subst s t = + let t' = + CArray.smartmap (fun x -> try LMap.find x s with Not_found -> x) t + in if t' == t then t else hcons t' + + let pr = + prvect_with_sep spc Level.pr + + let equal t u = + t == u || + (Array.is_empty t && Array.is_empty u) || + (CArray.for_all2 Level.equal t u + (* Necessary as universe instances might come from different modules and + unmarshalling doesn't preserve sharing *)) + + let check_eq g t1 t2 = + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) + in aux 0) + +end + +type universe_instance = Instance.t + +type 'a puniverses = 'a * Instance.t +(** A context of universe levels with universe constraints, + representiong local universe variables and constraints *) + +module UContext = +struct + type t = Instance.t constrained + + (** Universe contexts (variables as a list) *) + let empty = (Instance.empty, Constraint.empty) + + let instance (univs, cst) = univs + let constraints (univs, cst) = cst +end + +type universe_context = UContext.t + +module ContextSet = +struct + type t = LSet.t constrained + let empty = LSet.empty, Constraint.empty + let constraints (_, cst) = cst +end +type universe_context_set = ContextSet.t + +(** Substitutions. *) + +let is_empty_subst = LMap.is_empty +let empty_level_subst = LMap.empty +let is_empty_level_subst = LMap.is_empty + +(** Substitution functions *) + +(** With level to level substitutions. *) +let subst_univs_level_level subst l = + try LMap.find l subst + with Not_found -> l + +let subst_univs_level_universe subst u = + let f x = Universe.Expr.map (fun u -> subst_univs_level_level subst u) x in + let u' = Universe.smartmap f u in + if u == u' then u + else Universe.sort u' + +(** Substitute instance inst for ctx in csts *) + +let subst_instance_level s l = + match l.Level.data with + | Level.Var n -> s.(n) + | _ -> l + +let subst_instance_instance s i = + Array.smartmap (fun l -> subst_instance_level s l) i + +let subst_instance_universe s u = + let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in + let u' = Universe.smartmap f u in + if u == u' then u + else Universe.sort u' + +let subst_instance_constraint s (u,d,v as c) = + let u' = subst_instance_level s u in + let v' = subst_instance_level s v in + if u' == u && v' == v then c + else (u',d,v') + +let subst_instance_constraints s csts = + Constraint.fold + (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) + csts Constraint.empty + +(** Substitute instance inst for ctx in csts *) +let instantiate_univ_context (ctx, csts) = + (ctx, subst_instance_constraints ctx csts) + +let instantiate_univ_constraints u (_, csts) = + subst_instance_constraints u csts + +(** With level to universe substitutions. *) +type universe_subst_fn = universe_level -> universe + +let make_subst subst = fun l -> LMap.find l subst + +let subst_univs_expr_opt fn (l,n) = + Universe.addn n (fn l) + +let subst_univs_universe fn ul = + let subst, nosubst = + Universe.Huniv.fold (fun u (subst,nosubst) -> + try let a' = subst_univs_expr_opt fn u in + (a' :: subst, nosubst) + with Not_found -> (subst, u :: nosubst)) + ul ([], []) + in + if CList.is_empty subst then ul + else + let substs = + List.fold_left Universe.merge_univs Universe.empty subst + in + List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) + substs nosubst + +(** Pretty-printing *) + +let pr_arc = function + | _, Canonical {univ=u; lt=[]; le=[]} -> + mt () + | _, Canonical {univ=u; lt=lt; le=le} -> + let opt_sep = match lt, le with + | [], _ | _, [] -> mt () + | _ -> spc () + in + Level.pr u ++ str " " ++ + v 0 + (pr_sequence (fun v -> str "< " ++ Level.pr v) lt ++ + opt_sep ++ + pr_sequence (fun v -> str "<= " ++ Level.pr v) le) ++ + fnl () + | u, Equiv v -> + Level.pr u ++ str " = " ++ Level.pr v ++ fnl () + +let pr_universes g = + let graph = UMap.fold (fun u a l -> (u,a)::l) g [] in + prlist pr_arc graph diff --git a/checker/univ.mli b/checker/univ.mli new file mode 100644 index 00000000..742ef91a --- /dev/null +++ b/checker/univ.mli @@ -0,0 +1,224 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int -> t + (** Create a new universe level from a unique identifier and an associated + module path. *) + + val equal : t -> t -> bool +end + +type universe_level = Level.t +(** Alias name. *) + +module Universe : +sig + type t + (** Type of universes. A universe is defined as a set of level expressions. + A level expression is built from levels and successors of level expressions, i.e.: + le ::= l + n, n \in N. + + A universe is said atomic if it consists of a single level expression with + no increment, and algebraic otherwise (think the least upper bound of a set of + level expressions). + *) + + val equal : t -> t -> bool + (** Equality function on formal universes *) + + val make : Level.t -> t + (** Create a universe representing the given level. *) + +end + +type universe = Universe.t + +(** Alias name. *) + +val pr_uni : universe -> Pp.std_ppcmds + +(** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... + Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *) +val type0m_univ : universe +val type0_univ : universe +val type1_univ : universe + +val is_type0_univ : universe -> bool +val is_type0m_univ : universe -> bool +val is_univ_variable : universe -> bool + +val sup : universe -> universe -> universe +val super : universe -> universe + +(** {6 Graphs of universes. } *) + +type universes + +type 'a check_function = universes -> 'a -> 'a -> bool +val check_leq : universe check_function +val check_eq : universe check_function + +(** The initial graph of universes: Prop < Set *) +val initial_universes : universes + +(** {6 Constraints. } *) + +type constraint_type = Lt | Le | Eq +type univ_constraint = universe_level * constraint_type * universe_level + +module Constraint : Set.S with type elt = univ_constraint + +type constraints = Constraint.t + +val empty_constraint : constraints + +(** A value with universe constraints. *) +type 'a constrained = 'a * constraints + +(** Enforcing constraints. *) + +type 'a constraint_function = 'a -> 'a -> constraints -> constraints + +val enforce_leq : universe constraint_function + +(** {6 ... } *) +(** Merge of constraints in a universes graph. + The function [merge_constraints] merges a set of constraints in a given + universes graph. It raises the exception [UniverseInconsistency] if the + constraints are not satisfiable. *) + +(** Type explanation is used to decorate error messages to provide + useful explanation why a given constraint is rejected. It is composed + of a path of universes and relation kinds [(r1,u1);..;(rn,un)] means + .. <(r1) u1 <(r2) ... <(rn) un (where <(ri) is the relation symbol + denoted by ri, currently only < and <=). The lowest end of the chain + is supposed known (see UniverseInconsistency exn). The upper end may + differ from the second univ of UniverseInconsistency because all + universes in the path are canonical. Note that each step does not + necessarily correspond to an actual constraint, but reflect how the + system stores the graph and may result from combination of several + constraints... +*) +type univ_inconsistency = constraint_type * universe * universe + +exception UniverseInconsistency of univ_inconsistency + +val merge_constraints : constraints -> universes -> universes + +val check_constraints : constraints -> universes -> bool + +(** {6 Support for universe polymorphism } *) + +(** Polymorphic maps from universe levels to 'a *) +module LMap : Map.S with type key = universe_level + +type 'a universe_map = 'a LMap.t + +(** {6 Substitution} *) + +type universe_subst_fn = universe_level -> universe +type universe_level_subst_fn = universe_level -> universe_level + +(** A full substitution, might involve algebraic universes *) +type universe_subst = universe universe_map +type universe_level_subst = universe_level universe_map + +val level_subst_of : universe_subst_fn -> universe_level_subst_fn + +(** {6 Universe instances} *) + +module Instance : +sig + type t + (** A universe instance represents a vector of argument universes + to a polymorphic definition (constant, inductive or constructor). *) + + val empty : t + val is_empty : t -> bool + + val equal : t -> t -> bool + (** Equality (note: instances are hash-consed, this is O(1)) *) + + val subst_fn : universe_level_subst_fn -> t -> t + (** Substitution by a level-to-level function. *) + + val subst : universe_level_subst -> t -> t + (** Substitution by a level-to-level function. *) + + val pr : t -> Pp.std_ppcmds + (** Pretty-printing, no comments *) + + val check_eq : t check_function + (** Check equality of instances w.r.t. a universe graph *) +end + +type universe_instance = Instance.t + +type 'a puniverses = 'a * universe_instance + +(** A vector of universe levels with universe constraints, + representiong local universe variables and associated constraints *) + +module UContext : +sig + type t + + val empty : t + + val instance : t -> Instance.t + val constraints : t -> constraints + +end + +module ContextSet : + sig + type t + val empty : t + val constraints : t -> constraints + end + +type universe_context = UContext.t +type universe_context_set = ContextSet.t + +val empty_level_subst : universe_level_subst +val is_empty_level_subst : universe_level_subst -> bool + +(** Substitution of universes. *) +val subst_univs_level_level : universe_level_subst -> universe_level -> universe_level +val subst_univs_level_universe : universe_level_subst -> universe -> universe + +(** Level to universe substitutions. *) + +val is_empty_subst : universe_subst -> bool +val make_subst : universe_subst -> universe_subst_fn + +val subst_univs_universe : universe_subst_fn -> universe -> universe + +(** Substitution of instances *) +val subst_instance_instance : universe_instance -> universe_instance -> universe_instance +val subst_instance_universe : universe_instance -> universe -> universe +val subst_instance_constraints : universe_instance -> constraints -> constraints + +(* val make_instance_subst : universe_instance -> universe_level_subst *) +(* val make_inverse_instance_subst : universe_instance -> universe_level_subst *) + +(** Get the instantiated graph. *) +val instantiate_univ_context : universe_context -> universe_context +val instantiate_univ_constraints : universe_instance -> universe_context -> constraints + +(** {6 Pretty-printing of universes. } *) + +val pr_universes : universes -> Pp.std_ppcmds diff --git a/checker/validate.ml b/checker/validate.ml index 67baff73..63180f05 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* f ctx) -let ext s f (ctx:error_context) = f (ctx/s) - exception ValidObjError of string * error_context * Obj.t let fail ctx o s = raise (ValidObjError(s,ctx,o)) type func = error_context -> Obj.t -> unit -let apply debug f x = - let o = Obj.repr x in - try f mt_ec o - with ValidObjError(msg,ctx,obj) -> - if debug then begin - print_endline ("Validation failed: "^msg); - print_endline ("Context: "^String.concat"/"(List.rev ctx)); - pr_obj obj - end; - failwith "vo structure validation failed" - -(* data not validated *) -let no_val (c:error_context) (o:Obj.t) = () - (* Check that object o is a block with tag t *) let val_tag t ctx o = if Obj.is_block o && Obj.tag o = t then () @@ -73,36 +62,61 @@ let val_block ctx o = fail ctx o "block: found no scan tag") else fail ctx o "expected block obj" -(* Check that an object is a tuple (or a record). v is an array of - validation functions for each field. Its size corresponds to the +let val_dyn ctx o = + let fail () = fail ctx o "expected a Dyn.t" in + if not (Obj.is_block o) then fail () + else if not (Obj.size o = 2) then fail () + else if not (Obj.tag (Obj.field o 0) = Obj.int_tag) then fail () + else () + +open Values + +let rec val_gen v ctx o = match v with + | Tuple (name,vs) -> val_tuple ~name vs ctx o + | Sum (name,cc,vv) -> val_sum name cc vv ctx o + | Array v -> val_array v ctx o + | List v0 -> val_sum "list" 1 [|[|Annot ("elem",v0);v|]|] ctx o + | Opt v -> val_sum "option" 1 [|[|v|]|] ctx o + | Int -> if not (Obj.is_int o) then fail ctx o "expected an int" + | String -> + (try val_tag Obj.string_tag ctx o + with Failure _ -> fail ctx o "expected a string") + | Any -> () + | Fail s -> fail ctx o ("unexpected object " ^ s) + | Annot (s,v) -> val_gen v (ctx/CtxAnnot s) o + | Dyn -> val_dyn ctx o + +(* Check that an object is a tuple (or a record). vs is an array of + value representation for each field. Its size corresponds to the expected size of the object. *) -let val_tuple ?name v ctx o = +and val_tuple ?name vs ctx o = let ctx = match name with - Some n -> ctx/n - | _ -> ctx in - let n = Array.length v in - let val_fld i f = - f (ctx/("fld="^string_of_int i)) (Obj.field o i) in + | Some n -> ctx/CtxType n + | _ -> ctx + in + let n = Array.length vs in + let val_fld i v = + val_gen v (ctx/(CtxField i)) (Obj.field o i) in val_block ctx o; - if Obj.size o = n then Array.iteri val_fld v + if Obj.size o = n then Array.iteri val_fld vs else fail ctx o ("tuple size: found "^string_of_int (Obj.size o)^ - ", expected "^string_of_int n) + ", expected "^string_of_int n) (* Check that the object is either a constant constructor of tag < cc, or a constructed variant. each element of vv is an array of - validation functions to be applied to the constructor arguments. + value representations of the constructor arguments. The size of vv corresponds to the number of non-constant constructors, and the size of vv.(i) is the expected arity of the i-th non-constant constructor. *) -let val_sum name cc vv ctx o = - let ctx = ctx/name in +and val_sum name cc vv ctx o = + let ctx = ctx/CtxType name in if Obj.is_block o then - (val_block (ctx/name) o; + (val_block ctx o; let n = Array.length vv in let i = Obj.tag o in - let ctx' = if n=1 then ctx else ctx/("tag="^string_of_int i) in + let ctx' = if n=1 then ctx else ctx/CtxTag i in if i < n then val_tuple vv.(i) ctx' o else fail ctx' o ("sum: unexpected tag")) else if Obj.is_int o then @@ -111,95 +125,27 @@ let val_sum name cc vv ctx o = fail ctx o ("bad constant constructor "^string_of_int n)) else fail ctx o "not a sum" -let val_enum s n = val_sum s n [||] - -(* Recursive types: avoid looping by eta-expansion *) -let rec val_rec_sum name cc f ctx o = - val_sum name cc (f (overr (ctx/name) (val_rec_sum name cc f))) ctx o - -(**************************************************************************) -(* Builtin types *) - (* Check the o is an array of values satisfying f. *) -let val_array ?(pos=false) f ctx o = - let upd_ctx = - if pos then (fun i -> ctx/string_of_int i) else (fun _ -> ctx) in - val_block (ctx/"array") o; +and val_array v ctx o = + val_block (ctx/CtxType "array") o; for i = 0 to Obj.size o - 1 do - (f (upd_ctx i) (Obj.field o i):unit) + val_gen v ctx (Obj.field o i) done -(* Integer validator *) -let val_int ctx o = - if not (Obj.is_int o) then fail ctx o "expected an int" - -(* String validator *) -let val_str ctx o = - try val_tag Obj.string_tag ctx o - with Failure _ -> fail ctx o "expected a string" - -(* Booleans *) -let val_bool = val_enum "bool" 2 - -(* Option type *) -let val_opt ?(name="option") f = - val_sum name 1 [|[|f|]|] - -(* Lists *) -let val_list ?(name="list") f ctx = - val_rec_sum name 1 (fun vlist -> [|[|ext "elem" f;vlist|]|]) - ctx - -(* Reference *) -let val_ref ?(name="ref") f ctx = - val_tuple [|f|] (ctx/name) - -(**************************************************************************) -(* Standard library types *) - -(* Sets *) -let val_set ?(name="Set.t") f = - val_rec_sum name 1 - (fun vset -> [|[|vset;ext "elem" f; - vset;ext "bal" val_int|]|]) - -(* Maps *) -let rec val_map ?(name="Map.t") fk fv = - val_rec_sum name 1 - (fun vmap -> - [|[|vmap; ext "key" fk; ext "value" fv; - vmap; ext "bal" val_int|]|]) - -(**************************************************************************) -(* Coq types *) - -(* names *) -let val_id = val_str - -let val_dp = val_list ~name:"dirpath" val_id - -let val_name = val_sum "name" 1 [|[|val_id|]|] - -let val_uid = val_tuple ~name:"uniq_ident" [|val_int;val_str;val_dp|] - -let val_mp = - val_rec_sum "module_path" 0 - (fun vmp -> [|[|val_dp|];[|val_uid|];[|vmp;val_id|]|]) - -let val_kn = val_tuple ~name:"kernel_name" [|val_mp;val_dp;val_id|] +let print_frame = function +| CtxType t -> t +| CtxAnnot t -> t +| CtxField i -> Printf.sprintf "fld=%i" i +| CtxTag i -> Printf.sprintf "tag=%i" i -let val_con = - val_tuple ~name:"constant/mutind" [|val_kn;val_kn|] - -let val_ind = val_tuple ~name:"inductive"[|val_con;val_int|] -let val_cstr = val_tuple ~name:"constructor"[|val_ind;val_int|] - -(* univ *) -let val_level = val_sum "level" 1 [|[|val_dp;val_int|]|] -let val_univ = val_sum "univ" 0 - [|[|val_level|];[|val_list val_level;val_list val_level|]|] - -let val_cstrs = - val_set ~name:"Univ.constraints" - (val_tuple ~name:"univ_constraint" - [|val_level;val_enum "order_request" 3;val_level|]) +let validate debug v x = + let o = Obj.repr x in + try val_gen v mt_ec o + with ValidObjError(msg,ctx,obj) -> + if debug then begin + let ctx = List.rev_map print_frame ctx in + print_endline ("Validation failed: "^msg); + print_endline ("Context: "^String.concat"/"ctx); + pr_obj obj + end; + failwith "vo structure validation failed" diff --git a/checker/values.ml b/checker/values.ml new file mode 100644 index 00000000..3ca44b7d --- /dev/null +++ b/checker/values.ml @@ -0,0 +1,350 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Any diff --git a/checker/votour.ml b/checker/votour.ml new file mode 100644 index 00000000..29593cb7 --- /dev/null +++ b/checker/votour.ml @@ -0,0 +1,189 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "?" + |Fail s -> "Invalid node: "^s + |Tuple (name,_) -> name + |Sum (name,_,_) -> name + |Array v -> "array"^(if extra then "/"^get_name ~extra v else "") + |List v -> "list"^(if extra then "/"^get_name ~extra v else "") + |Opt v -> "option"^(if extra then "/"^get_name ~extra v else "") + |Int -> "int" + |String -> "string" + |Annot (s,v) -> s^"/"^get_name ~extra v + |Dyn -> "" + +(** For tuples, its quite handy to display the inner 1st string (if any). + Cf. [structure_body] for instance *) + +let get_string_in_tuple v o = + try + for i = 0 to Array.length v - 1 do + if v.(i) = String then + failwith (" [.."^(Obj.magic (Obj.field o i) : string)^"..]"); + done; + "" + with Failure s -> s + +(** Some details : tags, integer value for non-block, etc etc *) + +let rec get_details v o = match v with + |String | Any when (Obj.is_block o && Obj.tag o = Obj.string_tag) -> + " [" ^ String.escaped (Obj.magic o : string) ^"]" + |Tuple (_,v) -> get_string_in_tuple v o + |(Sum _|Any) when Obj.is_block o -> + " [tag=" ^ string_of_int (Obj.tag o) ^"]" + |(Sum _|Any) -> + " [imm=" ^ string_of_int (Obj.magic o : int) ^"]" + |Int -> " [" ^ string_of_int (Obj.magic o : int) ^"]" + |Annot (s,v) -> get_details v o + |_ -> "" + +let node_info (v,o,p) = + get_name ~extra:true v ^ get_details v o ^ + " (size "^ string_of_int (CObj.shared_size_of_pos p)^"w)" + +(** Children of a block : type, object, position. + For lists, we collect all elements of the list at once *) + +let access_children vs o pos = + Array.mapi (fun i v -> v, Obj.field o i, i::pos) vs + +let rec get_children v o pos = match v with + |Tuple (_,v) -> access_children v o pos + |Sum (_,_,vv) -> + if Obj.is_block o then access_children vv.(Obj.tag o) o pos + else [||] + |Array v -> access_children (Array.make (Obj.size o) v) o pos + |List v -> + let rec loop pos = function + | [] -> [] + | o :: ol -> (v,o,0::pos) :: loop (1::pos) ol + in + Array.of_list (loop pos (Obj.magic o : Obj.t list)) + |Opt v -> + if Obj.is_block o then [|v,Obj.field o 0,0::pos|] else [||] + |String | Int -> [||] + |Annot (s,v) -> get_children v o pos + |Any -> + if Obj.is_block o && Obj.tag o < Obj.no_scan_tag then + Array.init (Obj.size o) (fun i -> (Any,Obj.field o i,i::pos)) + else [||] + |Dyn -> + let t = to_dyn o in + let tpe = find_dyn t.dyn_tag in + [|(String, Obj.repr t.dyn_tag, 0 :: pos); (tpe, t.dyn_obj, 1 :: pos)|] + |Fail s -> failwith "forbidden" + +type info = { + nam : string; + typ : value; + obj : Obj.t; + pos : int list +} + +let stk = ref ([] : info list) + +let init () = stk := [] + +let push name v o p = stk := { nam = name; typ = v; obj = o; pos = p } :: !stk + +let pop () = match !stk with + | i::s -> stk := s; i + | _ -> failwith "empty stack" + +let rec visit v o pos = + Printf.printf "\nDepth %d Pos %s Context %s\n" + (List.length !stk) + (String.concat "." (List.rev_map string_of_int pos)) + (String.concat "/" (List.rev_map (fun i -> i.nam) !stk)); + Printf.printf "-------------\n"; + let children = get_children v o pos in + let nchild = Array.length children in + Printf.printf "Here: %s, %d child%s\n" + (node_info (v,o,pos)) nchild (if nchild = 0 then "" else "ren:"); + Array.iteri + (fun i vop -> Printf.printf " %d: %s\n" i (node_info vop)) + children; + Printf.printf "-------------\n"; + Printf.printf ("# %!"); + let l = read_line () in + try + if l = "u" then let info = pop () in visit info.typ info.obj info.pos + else if l = "x" then (Printf.printf "\nGoodbye!\n\n";exit 0) + else + let v',o',pos' = children.(int_of_string l) in + push (get_name v) v o pos; + visit v' o' pos' + with + | Failure "empty stack" -> () + | Failure "forbidden" -> let info = pop () in visit info.typ info.obj info.pos + | Failure _ | Invalid_argument _ -> visit v o pos + +(** Loading the vo *) + +type segment = { + name : string; + mutable pos : int; + typ : Values.value; +} + +let visit_vo f = + Printf.printf "\nWelcome to votour !\n"; + Printf.printf "Enjoy your guided tour of a Coq .vo or .vi file\n"; + Printf.printf "Object sizes are in words (%d bits)\n" Sys.word_size; + Printf.printf + "At prompt, enters the -th child, u goes up 1 level, x exits\n\n%!"; + let segments = [| + {name="library"; pos=0; typ=Values.v_lib}; + {name="univ constraints of opaque proofs"; pos=0;typ=Values.v_univopaques}; + {name="discharging info"; pos=0; typ=Opt Any}; + {name="STM tasks"; pos=0; typ=Opt Any}; + {name="opaque proofs"; pos=0; typ=Values.v_opaques}; + |] in + while true do + let ch = open_in_bin f in + let magic = input_binary_int ch in + Printf.printf "File format: %d\n%!" magic; + for i=0 to Array.length segments - 1 do + let pos = input_binary_int ch in + segments.(i).pos <- pos_in ch; + seek_in ch pos; + ignore(Digest.input ch); + done; + Printf.printf "The file has %d segments, choose the one to visit:\n" + (Array.length segments); + Array.iteri (fun i { name; pos } -> + Printf.printf " %d: %s, starting at byte %d\n" i name pos) + segments; + Printf.printf "# %!"; + let l = read_line () in + let seg = int_of_string l in + seek_in ch segments.(seg).pos; + let o = (input_value ch : Obj.t) in + let () = CObj.register_shared_size o in + let () = init () in + visit segments.(seg).typ o [] + done + +let main = + if not !Sys.interactive then + Arg.parse [] visit_vo + ("votour: guided tour of a Coq .vo or .vi file\n"^ + "Usage: votour file.v[oi]") -- cgit v1.2.3