2014-07-14 19:32:44 +00:00
|
|
|
(*
|
2020-03-09 06:18:30 +00:00
|
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
2014-07-14 19:32:44 +00:00
|
|
|
*
|
2020-03-09 06:18:30 +00:00
|
|
|
* SPDX-License-Identifier: BSD-2-Clause
|
2014-07-14 19:32:44 +00:00
|
|
|
*)
|
|
|
|
|
|
|
|
signature ISAR_INSTALL =
|
|
|
|
sig
|
|
|
|
|
|
|
|
type additional_options
|
|
|
|
val GhostState : string -> additional_options
|
|
|
|
val get_Csyntax : theory -> string -> Absyn.ext_decl list
|
|
|
|
val gen_umm_types_file : string -> string -> theory -> theory
|
2015-04-10 04:48:07 +00:00
|
|
|
val do_cpp : {error_detail : int, cpp_path : string option} ->
|
2019-06-19 02:49:39 +00:00
|
|
|
{includes : string list, filename : string} -> string * bool
|
2014-07-14 19:32:44 +00:00
|
|
|
val install_C_file : (((bool option * bool option) * bool option) * string) *
|
|
|
|
additional_options list option ->
|
|
|
|
theory -> theory
|
|
|
|
val interactive_install : string -> theory -> theory
|
|
|
|
val mk_thy_relative : theory -> string -> string
|
|
|
|
|
2017-05-18 04:03:17 +00:00
|
|
|
val extra_trace_filename : string Config.T
|
2019-05-25 07:54:28 +00:00
|
|
|
val cpp_path : string Config.T
|
2017-05-18 04:03:17 +00:00
|
|
|
|
2016-07-12 03:44:16 +00:00
|
|
|
val installed_C_files : theory
|
|
|
|
-> {c_filename : string, locale_names : string list,
|
|
|
|
options: (bool * bool * bool),
|
|
|
|
additional_options: additional_options list} list
|
2014-07-14 19:32:44 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
structure IsarInstall : ISAR_INSTALL =
|
|
|
|
struct
|
|
|
|
|
|
|
|
type 'a wrap = 'a Region.Wrap.t
|
|
|
|
|
2017-05-18 04:03:17 +00:00
|
|
|
fun setup_feedback extra_output_filename = let
|
|
|
|
val trace_extra = case extra_output_filename of
|
|
|
|
NONE => K ()
|
|
|
|
| SOME f => let
|
|
|
|
val out = TextIO.openOut f
|
|
|
|
in fn s => (TextIO.output (out, s); TextIO.flushOut out) end
|
|
|
|
val add_extra = case extra_output_filename of
|
2019-05-22 10:30:32 +00:00
|
|
|
NONE => (fn _ => fn f => f)
|
2017-05-18 04:03:17 +00:00
|
|
|
| SOME _ => (fn pfx => fn f => fn s => (trace_extra (pfx ^ s); f s))
|
|
|
|
in
|
|
|
|
Feedback.errorf := add_extra "ERROR: " (ignore o error);
|
|
|
|
Feedback.warnf := add_extra "" warning;
|
|
|
|
Feedback.informf := add_extra "" (Output.tracing o Feedback.timestamp)
|
|
|
|
end
|
|
|
|
|
|
|
|
val extra_trace_filename = let
|
|
|
|
val (config, setup) =
|
|
|
|
Attrib.config_string @{binding "CParser_extra_trace_file"} (K "")
|
|
|
|
in
|
|
|
|
Context.>>(Context.map_theory setup);
|
|
|
|
config
|
|
|
|
end
|
|
|
|
|
|
|
|
fun setup_feedback_thy thy = let
|
|
|
|
val str = Config.get_global thy extra_trace_filename
|
|
|
|
in setup_feedback (if str = "" then NONE else SOME str) end
|
2014-07-14 19:32:44 +00:00
|
|
|
|
2017-05-18 04:03:17 +00:00
|
|
|
val _ = setup_feedback NONE
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
structure C_Includes = Theory_Data
|
|
|
|
(struct
|
|
|
|
type T = string list
|
|
|
|
val empty = []
|
|
|
|
val merge = Library.merge (op =)
|
|
|
|
end);
|
|
|
|
|
|
|
|
datatype additional_options = MachineState of string | GhostState of string | CRoots of string list
|
|
|
|
|
2016-07-12 03:44:16 +00:00
|
|
|
type install_data = {c_filename : string, locale_names : string list,
|
|
|
|
options: (bool * bool * bool),
|
|
|
|
additional_options: additional_options list}
|
|
|
|
structure C_Installs = Theory_Data
|
|
|
|
(struct
|
|
|
|
type T = install_data list
|
|
|
|
val empty = []
|
|
|
|
val merge = Library.merge (op =)
|
|
|
|
end);
|
|
|
|
val installed_C_files = C_Installs.get
|
|
|
|
|
2014-07-14 19:32:44 +00:00
|
|
|
structure IsaPath = Path
|
|
|
|
|
2014-08-08 07:29:54 +00:00
|
|
|
val get_Cdir = Resources.master_directory
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
fun mk_thy_relative thy s =
|
|
|
|
if OS.Path.isRelative s then OS.Path.concat(Path.implode (get_Cdir thy), s)
|
|
|
|
else s
|
|
|
|
|
2015-01-22 03:02:29 +00:00
|
|
|
val cpp_path = let
|
|
|
|
val (cpp_path_config, cpp_path_setup) =
|
|
|
|
Attrib.config_string (Binding.name "cpp_path") (K "/usr/bin/cpp")
|
|
|
|
in
|
|
|
|
Context.>>(Context.map_theory cpp_path_setup);
|
|
|
|
cpp_path_config
|
|
|
|
end
|
|
|
|
|
2016-02-15 05:13:08 +00:00
|
|
|
val munge_info_fname = let
|
2017-07-12 05:13:51 +00:00
|
|
|
val (mifname_config, mifname_setup) =
|
2016-02-15 05:13:08 +00:00
|
|
|
Attrib.config_string (Binding.name "munge_info_fname") (K "")
|
|
|
|
in
|
|
|
|
Context.>>(Context.map_theory mifname_setup);
|
|
|
|
mifname_config
|
|
|
|
end
|
|
|
|
|
2015-04-10 04:48:07 +00:00
|
|
|
val report_cpp_errors = let
|
|
|
|
val (report_cpp_errors_config, report_cpp_errors_setup) =
|
|
|
|
Attrib.config_int (Binding.name "report_cpp_errors") (K 10)
|
|
|
|
in
|
|
|
|
Context.>>(Context.map_theory report_cpp_errors_setup);
|
|
|
|
report_cpp_errors_config
|
|
|
|
end
|
|
|
|
|
|
|
|
fun do_cpp {error_detail, cpp_path} {includes, filename} =
|
|
|
|
case cpp_path of
|
2019-06-19 02:49:39 +00:00
|
|
|
NONE => (File.standard_path (Path.explode filename), false)
|
2015-04-10 04:48:07 +00:00
|
|
|
| SOME p =>
|
|
|
|
let
|
|
|
|
open OS.FileSys OS.Process
|
|
|
|
val tmpname = tmpName()
|
|
|
|
val err_tmpname = tmpName()
|
|
|
|
val includes_string = String.concat (map (fn s => "-I\""^s^"\" ") includes)
|
|
|
|
fun plural 1 = "" | plural _ = "s"
|
|
|
|
val cmdline =
|
|
|
|
p ^ " " ^ includes_string ^ " -CC \"" ^ filename ^ "\" > " ^ tmpname ^ " 2> " ^ err_tmpname
|
|
|
|
in
|
2019-06-19 02:49:39 +00:00
|
|
|
if isSuccess (system cmdline)
|
|
|
|
then (OS.FileSys.remove err_tmpname; (tmpname, true))
|
2015-04-10 04:48:07 +00:00
|
|
|
else let val _ = OS.FileSys.remove tmpname
|
|
|
|
val (msg, rest) = File.read_lines (Path.explode err_tmpname) |> chop error_detail
|
|
|
|
val _ = OS.FileSys.remove err_tmpname
|
|
|
|
val _ = warning ("cpp failed on " ^ filename ^ "\nCommand: " ^ cmdline ^
|
|
|
|
"\n\nOutput:\n" ^
|
|
|
|
cat_lines (msg @ (if null rest then [] else
|
|
|
|
["(... " ^ string_of_int (length rest) ^
|
|
|
|
" more line" ^ plural (length rest) ^ ")"])))
|
|
|
|
in raise Feedback.WantToExit ("cpp failed on " ^ filename) end
|
|
|
|
end
|
|
|
|
|
2014-07-14 19:32:44 +00:00
|
|
|
fun get_Csyntax thy s = let
|
2017-05-18 04:03:17 +00:00
|
|
|
val _ = setup_feedback_thy thy
|
2015-01-22 03:02:29 +00:00
|
|
|
val cpp_option =
|
|
|
|
case Config.get_global thy cpp_path of
|
|
|
|
"" => NONE
|
|
|
|
| s => SOME s
|
2015-04-10 04:48:07 +00:00
|
|
|
val cpp_error_count = Config.get_global thy report_cpp_errors
|
2014-07-14 19:32:44 +00:00
|
|
|
val (ast0, _) =
|
2015-04-10 04:48:07 +00:00
|
|
|
StrictCParser.parse
|
|
|
|
(do_cpp {error_detail = cpp_error_count, cpp_path = cpp_option})
|
|
|
|
15
|
|
|
|
(C_Includes.get thy)
|
|
|
|
(mk_thy_relative thy s)
|
2014-07-14 19:32:44 +00:00
|
|
|
handle IO.Io {name, ...} => error ("I/O error on "^name)
|
|
|
|
in
|
2015-02-09 03:12:00 +00:00
|
|
|
ast0 |> SyntaxTransforms.remove_anonstructs |> SyntaxTransforms.remove_typedefs
|
2014-07-14 19:32:44 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
fun define_naming_scheme [] _ = I
|
|
|
|
| define_naming_scheme fninfo nmdefs = let
|
|
|
|
fun name_term fni = SOME (HOLogic.mk_string (#fname fni))
|
|
|
|
fun name_name fni = #fname fni ^ "_name"
|
|
|
|
|
2014-09-23 04:40:31 +00:00
|
|
|
in StaticFun.define_tree_and_thms_with_defs
|
|
|
|
(Binding.name NameGeneration.naming_scheme_name)
|
|
|
|
(map name_name fninfo) nmdefs
|
|
|
|
(map name_term fninfo) @{term "id :: int => int"}
|
|
|
|
#> snd end
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
fun define_function_names fninfo thy = let
|
|
|
|
open Feedback
|
|
|
|
fun decl1 (fni, (n, defs, lthy)) = let
|
|
|
|
open TermsTypes
|
|
|
|
val cname = suffix HoarePackage.proc_deco (#fname fni)
|
|
|
|
val _ = informStr (4, "Adding ("^cname^" :: int) = "^Int.toString n)
|
|
|
|
val b = Binding.name cname
|
|
|
|
val ((_, (_, th)), lthy) =
|
2019-05-22 10:30:32 +00:00
|
|
|
lthy
|
2021-01-20 05:04:40 +00:00
|
|
|
|> Local_Theory.begin_nested |> snd
|
2019-05-22 10:30:32 +00:00
|
|
|
|>Local_Theory.define ((b, NoSyn),
|
|
|
|
((Thm.def_binding b, []), mk_int_numeral n))
|
2021-01-20 05:04:40 +00:00
|
|
|
val lthy' = Local_Theory.end_nested lthy
|
2014-07-14 19:32:44 +00:00
|
|
|
val morph = Proof_Context.export_morphism lthy lthy'
|
|
|
|
val th' = Morphism.thm morph th
|
|
|
|
|
|
|
|
in
|
|
|
|
(n + 1, th' :: defs, lthy')
|
|
|
|
end
|
|
|
|
val (_, defs, lthy) =
|
|
|
|
List.foldl decl1 (1, [], Named_Target.theory_init thy) fninfo
|
|
|
|
val lthy' = define_naming_scheme fninfo (List.rev defs) lthy
|
|
|
|
in
|
2014-08-09 08:04:48 +00:00
|
|
|
(defs, Local_Theory.exit_global lthy')
|
2014-07-14 19:32:44 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
|
|
|
|
fun print_addressed_vars cse = let
|
|
|
|
open ProgramAnalysis Feedback
|
|
|
|
val globs = get_globals cse
|
|
|
|
val _ = informStr (0, "There are "^Int.toString (length globs)^" globals: "^
|
|
|
|
commas_quote (map srcname globs))
|
|
|
|
val addressed = get_addressed cse
|
2015-04-09 02:23:22 +00:00
|
|
|
val addr_vars = map MString.dest (MSymTab.keys addressed)
|
2014-07-14 19:32:44 +00:00
|
|
|
val _ = informStr (0, "There are "^Int.toString (length addr_vars)^
|
|
|
|
" addressed variables: "^ commas_quote addr_vars)
|
|
|
|
in
|
|
|
|
()
|
|
|
|
end
|
|
|
|
|
|
|
|
fun define_global_initializers globloc msgpfx name_munger mungedb cse globs thy = let
|
|
|
|
open ProgramAnalysis Absyn
|
2021-01-20 05:04:40 +00:00
|
|
|
val lthy = Named_Target.init [] globloc thy
|
2014-07-14 19:32:44 +00:00
|
|
|
val globinits = let
|
|
|
|
val inittab = get_globinits cse
|
2015-04-09 02:23:22 +00:00
|
|
|
fun foldthis (gnm : MString.t, gty) defs = let
|
|
|
|
val rhs_opt = MSymTab.lookup inittab gnm
|
2014-07-14 19:32:44 +00:00
|
|
|
val rhs_t =
|
|
|
|
case rhs_opt of
|
|
|
|
NONE => ExpressionTranslation.zero_term thy (get_senv cse) gty
|
|
|
|
| SOME rhs => let
|
|
|
|
open ExpressionTranslation
|
|
|
|
fun error _ = (Feedback.errorStr'(eleft rhs, eright rhs,
|
|
|
|
"Illegal form in initialisor for\
|
|
|
|
\ global");
|
|
|
|
raise Fail "Bad global initialisation")
|
|
|
|
val fakeTB = TermsTypes.TB {var_updator = error, var_accessor = error,
|
|
|
|
rcd_updator = error, rcd_accessor = error}
|
|
|
|
fun varinfo s = stmt_translation.state_varlookup "" s mungedb
|
|
|
|
val ei = expr_term lthy cse fakeTB varinfo rhs
|
|
|
|
val ei = case gty of
|
|
|
|
Array _ => ei
|
|
|
|
| _ => typecast(thy,gty,ei)
|
|
|
|
in
|
|
|
|
rval_of ei (Free("x", TermsTypes.bool))
|
|
|
|
(* the Free("x",bool) is arbitrary as the constant
|
|
|
|
expression should be ignoring the state argument *)
|
|
|
|
end
|
|
|
|
in
|
|
|
|
(gnm, gty, rhs_t) :: defs
|
|
|
|
end
|
|
|
|
in
|
2015-04-09 02:23:22 +00:00
|
|
|
MSymTab.fold foldthis globs []
|
2014-07-14 19:32:44 +00:00
|
|
|
end
|
|
|
|
fun define1 ((nm, ty, value), lthy) = let
|
|
|
|
open Feedback
|
|
|
|
val _ = informStr(2,
|
2015-04-09 02:23:22 +00:00
|
|
|
msgpfx ^ MString.dest nm ^ " (of C type "^
|
2014-07-14 19:32:44 +00:00
|
|
|
Absyn.tyname ty ^") to have value "^
|
|
|
|
Syntax.string_of_term lthy value)
|
2015-04-09 02:23:22 +00:00
|
|
|
val b = Binding.name (MString.dest (name_munger nm))
|
2014-07-14 19:32:44 +00:00
|
|
|
val (_, lthy) =
|
|
|
|
Local_Theory.define
|
|
|
|
((b, NoSyn), ((Thm.def_binding b, []), value))
|
|
|
|
lthy
|
|
|
|
in
|
|
|
|
lthy
|
|
|
|
end
|
|
|
|
in
|
|
|
|
List.foldl define1 lthy globinits
|
2014-08-09 08:04:48 +00:00
|
|
|
|> Local_Theory.exit_global
|
2014-07-14 19:32:44 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
val use_anon_vars = let
|
|
|
|
val (uavconfig, uavsetup) = Attrib.config_bool (Binding.name "use_anonymous_local_variables") (K false)
|
|
|
|
in
|
|
|
|
Context.>>(Context.map_theory uavsetup);
|
|
|
|
uavconfig
|
|
|
|
end
|
|
|
|
|
|
|
|
val allow_underscore_idents = let
|
|
|
|
val (auiconfig, auisetup) = Attrib.config_bool (Binding.name "allow_underscore_idents") (K false)
|
|
|
|
in
|
|
|
|
Context.>>(Context.map_theory auisetup);
|
|
|
|
auiconfig
|
|
|
|
end
|
|
|
|
|
|
|
|
fun get_callees cse slist = let
|
|
|
|
val {callgraph = cg,...} = ProgramAnalysis.compute_callgraphs cse
|
|
|
|
fun recurse acc worklist =
|
|
|
|
case worklist of
|
|
|
|
[] => acc
|
|
|
|
| fnname :: rest =>
|
|
|
|
if Binaryset.member(acc, fnname) then recurse acc rest
|
|
|
|
else
|
|
|
|
case Symtab.lookup cg fnname of
|
|
|
|
NONE => recurse (Binaryset.add(acc, fnname)) rest
|
|
|
|
| SOME set => recurse (Binaryset.add(acc, fnname))
|
|
|
|
(Binaryset.listItems set @ rest)
|
|
|
|
in
|
|
|
|
recurse (Binaryset.empty String.compare) slist
|
|
|
|
end
|
|
|
|
|
|
|
|
fun install_C_file0 (((((memsafe),ctyps),cdefs),s),statetylist_opt) thy = let
|
2017-05-18 04:03:17 +00:00
|
|
|
val _ = setup_feedback_thy thy
|
2014-11-14 03:49:00 +00:00
|
|
|
val {base = localename,...} = OS.Path.splitBaseExt (OS.Path.file s)
|
|
|
|
val _ = not (Long_Name.is_qualified localename) orelse
|
|
|
|
raise Fail ("Base of filename looks like qualified Isabelle ID: "^
|
|
|
|
localename)
|
2015-01-22 03:02:29 +00:00
|
|
|
val _ = localename <> "" orelse
|
|
|
|
raise Fail ("Filename (>'" ^ s ^
|
|
|
|
"'<) gives \"\" as locale name, which is illegal")
|
2014-07-14 19:32:44 +00:00
|
|
|
val statetylist = case statetylist_opt of NONE => [] | SOME l => List.rev l
|
|
|
|
val mstate_ty =
|
|
|
|
case get_first (fn (MachineState s) => SOME s | _ => NONE) statetylist of
|
|
|
|
NONE => TermsTypes.nat
|
|
|
|
| SOME s => Syntax.read_typ_global thy s
|
|
|
|
val roots_opt =
|
|
|
|
get_first (fn CRoots slist => SOME slist | _ => NONE) statetylist
|
|
|
|
val gstate_ty =
|
|
|
|
case get_first (fn (GhostState s) => SOME s | _ => NONE) statetylist of
|
|
|
|
NONE => TermsTypes.unit
|
|
|
|
| SOME s => Syntax.read_typ_global thy s
|
|
|
|
val thy = Config.put_global CalculateState.current_C_filename s thy
|
|
|
|
val thy = CalculateState.store_ghostty (s, gstate_ty) thy
|
|
|
|
val anon_vars = Config.get_global thy use_anon_vars
|
|
|
|
val uscore_idents = Config.get_global thy allow_underscore_idents
|
|
|
|
|
|
|
|
val o2b = isSome
|
|
|
|
val install_typs = not (o2b cdefs) orelse (o2b ctyps)
|
|
|
|
val install_defs = not (o2b ctyps) orelse (o2b cdefs)
|
|
|
|
val ms = o2b memsafe
|
|
|
|
val ast = get_Csyntax thy s
|
|
|
|
open ProgramAnalysis CalculateState Feedback
|
|
|
|
val owners =
|
|
|
|
(* non-null if there are any globals that have owned_by annotations *)
|
|
|
|
let
|
|
|
|
open StmtDecl RegionExtras
|
|
|
|
fun getowner d =
|
|
|
|
case d of
|
|
|
|
Decl d =>
|
|
|
|
(case node d of
|
|
|
|
VarDecl (_, _, _, _, attrs) => get_owned_by attrs
|
|
|
|
| _ => NONE)
|
|
|
|
| _ => NONE
|
|
|
|
in
|
|
|
|
List.mapPartial getowner ast
|
|
|
|
end
|
2016-02-15 05:13:08 +00:00
|
|
|
val mifname = case Config.get_global thy munge_info_fname of
|
|
|
|
"" => NONE
|
|
|
|
| s => SOME s
|
2017-07-12 05:13:51 +00:00
|
|
|
|
2014-07-14 19:32:44 +00:00
|
|
|
val ((ast, _ (* init_stmts *)), cse) =
|
|
|
|
process_decls {anon_vars=anon_vars,owners = owners,
|
2016-02-15 05:13:08 +00:00
|
|
|
allow_underscore_idents = uscore_idents,
|
|
|
|
munge_info_fname = mifname}
|
2014-07-14 19:32:44 +00:00
|
|
|
ast
|
2016-02-15 05:13:08 +00:00
|
|
|
val () = export_mungedb cse
|
2014-07-14 19:32:44 +00:00
|
|
|
val thy = store_csenv (s, cse) thy
|
|
|
|
|
|
|
|
val _ = print_addressed_vars cse
|
|
|
|
val ecenv = cse2ecenv cse
|
|
|
|
val thy = define_enum_consts ecenv thy
|
|
|
|
val state = create_state cse
|
|
|
|
val (thy, rcdinfo) = mk_thy_types cse install_typs thy
|
|
|
|
val ast = SyntaxTransforms.remove_embedded_fncalls cse ast
|
|
|
|
in
|
|
|
|
if install_defs then let
|
|
|
|
val (thy, vdecls, globs) =
|
|
|
|
mk_thy_decls
|
|
|
|
state {owners=owners,gstate_ty=gstate_ty,mstate_ty=mstate_ty} thy
|
|
|
|
val loc_b = Binding.name (suffix HPInter.globalsN localename)
|
|
|
|
val (globloc, ctxt) =
|
2021-01-20 05:04:40 +00:00
|
|
|
Expression.add_locale loc_b loc_b [] ([], []) globs thy
|
2014-07-17 16:22:50 +00:00
|
|
|
val thy = Local_Theory.exit_global ctxt
|
2015-05-02 19:37:33 +00:00
|
|
|
val _ = Output.state ("Created locale for globals (" ^ Binding.print loc_b ^
|
2014-07-14 19:32:44 +00:00
|
|
|
")- with " ^ Int.toString (length globs) ^
|
|
|
|
" globals elements")
|
2015-05-02 19:37:33 +00:00
|
|
|
val _ = app (fn e => Output.state ("-- " ^ HPInter.asm_to_string (Syntax.string_of_term ctxt) e))
|
2014-07-14 19:32:44 +00:00
|
|
|
globs
|
|
|
|
val mungedb = mk_mungedb vdecls
|
|
|
|
val thy = CalculateState.store_mungedb (s, mungedb) thy
|
|
|
|
val thy =
|
|
|
|
define_global_initializers globloc "Defining untouched global constant "
|
|
|
|
NameGeneration.untouched_global_name
|
|
|
|
mungedb
|
|
|
|
cse
|
|
|
|
(calc_untouched_globals cse)
|
|
|
|
thy
|
|
|
|
val thy =
|
|
|
|
if Config.get_global thy CalculateState.record_globinits then let
|
|
|
|
val globs0 = get_globals cse
|
2015-04-09 02:23:22 +00:00
|
|
|
val globs_types = map (fn vi => (get_mname vi, get_vi_type vi)) globs0
|
|
|
|
val glob_table = MSymTab.make globs_types
|
2014-07-14 19:32:44 +00:00
|
|
|
in
|
|
|
|
define_global_initializers
|
|
|
|
globloc "Defining initializers for all globals "
|
|
|
|
NameGeneration.global_initializer_name
|
|
|
|
mungedb
|
|
|
|
cse
|
|
|
|
glob_table
|
|
|
|
thy
|
|
|
|
end
|
2017-05-18 04:03:17 +00:00
|
|
|
else (Feedback.informStr (0,
|
|
|
|
"Ignoring initialisations of modified globals (if any)");
|
2014-07-14 19:32:44 +00:00
|
|
|
thy)
|
|
|
|
open TermsTypes
|
|
|
|
val (globty, styargs) = let
|
|
|
|
val globty0 = Type(Sign.intern_type thy
|
|
|
|
NameGeneration.global_rcd_name, [])
|
2015-05-02 19:37:33 +00:00
|
|
|
val globty = expand_tyabbrevs (thy2ctxt thy) globty0
|
2014-07-14 19:32:44 +00:00
|
|
|
val statetype0 =
|
|
|
|
Type(Sign.intern_type thy NameGeneration.local_rcd_name, [globty])
|
2015-05-02 19:37:33 +00:00
|
|
|
val statetype = expand_tyabbrevs (thy2ctxt thy) statetype0
|
2014-07-14 19:32:44 +00:00
|
|
|
(* only happens if no local variables, = no functions declared,
|
|
|
|
= pretty bogus
|
|
|
|
(decl_only and bigstruct test cases are like this though) *)
|
|
|
|
handle TYPE _ => alpha
|
|
|
|
in
|
|
|
|
(globty, [statetype, int, StrictC_errortype_ty])
|
|
|
|
end
|
|
|
|
val toTranslate = Option.map (get_callees cse) roots_opt
|
|
|
|
val toTranslate_s =
|
|
|
|
case toTranslate of
|
|
|
|
NONE => "all functions"
|
|
|
|
| SOME set => "functions " ^
|
|
|
|
String.concatWith ", " (Binaryset.listItems set) ^
|
|
|
|
" (derived from "^
|
|
|
|
String.concatWith ", " (valOf roots_opt) ^ ")"
|
|
|
|
val _ =
|
2017-05-18 04:03:17 +00:00
|
|
|
Feedback.informStr (0, "Beginning function translation for " ^
|
2015-05-02 19:37:33 +00:00
|
|
|
toTranslate_s)
|
2014-07-14 19:32:44 +00:00
|
|
|
val toTranslateP =
|
|
|
|
case toTranslate of
|
|
|
|
NONE => (fn _ => true)
|
|
|
|
| SOME set => (fn s => Binaryset.member(set,s))
|
|
|
|
val fninfo : HPInter.fninfo list = HPInter.mk_fninfo thy cse toTranslateP ast
|
|
|
|
val (nmdefs, thy) = define_function_names fninfo thy
|
|
|
|
val compile_bodies =
|
|
|
|
stmt_translation.define_functions (globty, styargs)
|
|
|
|
mungedb
|
|
|
|
cse
|
|
|
|
fninfo
|
|
|
|
rcdinfo
|
|
|
|
ms
|
2016-07-12 03:44:16 +00:00
|
|
|
val (loc2, thy) =
|
2014-07-14 19:32:44 +00:00
|
|
|
HPInter.make_function_definitions localename
|
|
|
|
cse
|
|
|
|
styargs
|
|
|
|
(List.rev nmdefs)
|
|
|
|
fninfo
|
|
|
|
compile_bodies
|
|
|
|
globloc
|
|
|
|
globs
|
|
|
|
thy
|
|
|
|
val thy =
|
|
|
|
if not (Symtab.is_empty (get_defined_functions cse)) then
|
2016-07-12 03:44:16 +00:00
|
|
|
Modifies_Proofs.prove_all_modifies_goals thy cse toTranslateP styargs loc2
|
2014-07-14 19:32:44 +00:00
|
|
|
else thy (* like this is ever going to happen *)
|
|
|
|
in
|
2016-07-12 03:44:16 +00:00
|
|
|
C_Installs.map (fn ss =>
|
|
|
|
{c_filename = s, locale_names = [globloc, loc2],
|
|
|
|
options = (ms, install_typs, install_defs),
|
|
|
|
additional_options = statetylist} :: ss) thy
|
2014-07-14 19:32:44 +00:00
|
|
|
end
|
|
|
|
else
|
2016-07-12 03:44:16 +00:00
|
|
|
C_Installs.map (fn ss =>
|
|
|
|
{c_filename = s, locale_names = [],
|
|
|
|
options = (ms, install_typs, install_defs),
|
|
|
|
additional_options = statetylist} :: ss) thy
|
2014-07-14 19:32:44 +00:00
|
|
|
end handle e as TYPE (s,tys,tms) =>
|
2017-05-18 04:03:17 +00:00
|
|
|
(Feedback.informStr (0, s ^ "\n" ^
|
2014-07-14 19:32:44 +00:00
|
|
|
Int.toString (length tms) ^ " term(s): " ^
|
|
|
|
String.concatWith
|
|
|
|
", "
|
|
|
|
(map (Syntax.string_of_term @{context}) tms) ^ "\n" ^
|
|
|
|
Int.toString (length tys) ^ " type(s): "^
|
|
|
|
String.concatWith
|
|
|
|
", "
|
|
|
|
(map (Syntax.string_of_typ @{context}) tys));
|
|
|
|
raise e)
|
|
|
|
|
|
|
|
fun install_C_file args thy =
|
|
|
|
thy |> install_C_file0 args
|
|
|
|
|> Config.put_global CalculateState.current_C_filename ""
|
|
|
|
|
|
|
|
(* for interactive debugging/testing *)
|
|
|
|
fun interactive_install s thy =
|
|
|
|
install_C_file ((((NONE, NONE), NONE), s), NONE) thy
|
|
|
|
handle TYPE (s,tys,tms) =>
|
2017-05-18 04:03:17 +00:00
|
|
|
(Feedback.informStr (0, s ^ "\n" ^
|
2014-07-14 19:32:44 +00:00
|
|
|
Int.toString (length tms) ^ " term(s): " ^
|
|
|
|
String.concatWith
|
|
|
|
", "
|
|
|
|
(map (Syntax.string_of_term @{context}) tms) ^ "\n" ^
|
|
|
|
Int.toString (length tys) ^ " type(s): "^
|
|
|
|
String.concatWith
|
|
|
|
", "
|
|
|
|
(map (Syntax.string_of_typ @{context}) tys));
|
|
|
|
thy);
|
|
|
|
|
|
|
|
|
|
|
|
fun install_C_types s thy = let
|
|
|
|
open CalculateState ProgramAnalysis
|
|
|
|
val ast = get_Csyntax thy s
|
|
|
|
val (_, cse) =
|
|
|
|
process_decls {
|
|
|
|
anon_vars = Config.get_global thy use_anon_vars,
|
|
|
|
allow_underscore_idents = Config.get_global thy allow_underscore_idents,
|
2016-02-15 05:13:08 +00:00
|
|
|
munge_info_fname = NONE,
|
2014-07-14 19:32:44 +00:00
|
|
|
owners = []} ast
|
|
|
|
val (thy, _) = mk_thy_types cse true thy
|
|
|
|
in
|
|
|
|
thy
|
|
|
|
end
|
|
|
|
|
|
|
|
fun gen_umm_types_file inputfile outputfile thy = let
|
|
|
|
open ProgramAnalysis
|
|
|
|
val ast = get_Csyntax thy inputfile
|
|
|
|
val (_, cse) =
|
|
|
|
process_decls {
|
|
|
|
anon_vars = Config.get_global thy use_anon_vars,
|
|
|
|
allow_underscore_idents = Config.get_global thy allow_underscore_idents,
|
2016-02-15 05:13:08 +00:00
|
|
|
munge_info_fname = NONE,
|
2014-07-14 19:32:44 +00:00
|
|
|
owners = []} ast
|
|
|
|
val _ = CalculateState.gen_umm_types_file cse outputfile
|
|
|
|
in
|
|
|
|
thy
|
|
|
|
end
|
|
|
|
|
|
|
|
val memsafeN = "memsafe"
|
|
|
|
val typesN = "c_types"
|
|
|
|
val defsN = "c_defs"
|
|
|
|
val mtypN = "machinety"
|
|
|
|
val ghosttypN = "ghostty"
|
|
|
|
val rootsN = "roots"
|
|
|
|
|
|
|
|
local
|
|
|
|
structure P = Parse
|
|
|
|
structure K = Keyword
|
|
|
|
in
|
|
|
|
fun new_include s thy = C_Includes.map (fn sl => mk_thy_relative thy s::sl) thy
|
|
|
|
|
2015-04-18 20:51:26 +00:00
|
|
|
val _ = Outer_Syntax.command @{command_keyword "new_C_include_dir"}
|
2014-07-14 19:32:44 +00:00
|
|
|
"add a directory to the include path"
|
2022-11-01 11:34:30 +00:00
|
|
|
(P.embedded >> (Toplevel.theory o new_include))
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
val file_inclusion = let
|
|
|
|
val typoptions =
|
2022-11-01 11:34:30 +00:00
|
|
|
P.reserved mtypN |-- (P.$$$ "=" |-- P.embedded >> MachineState) ||
|
|
|
|
P.reserved ghosttypN |-- (P.$$$ "=" |-- P.embedded >> GhostState) ||
|
|
|
|
P.reserved rootsN |-- (P.$$$ "=" |-- (P.$$$ "[" |-- P.enum1 "," P.embedded --| P.$$$ "]") >> CRoots)
|
2014-07-14 19:32:44 +00:00
|
|
|
in
|
|
|
|
((Scan.option (P.$$$ memsafeN)) --
|
|
|
|
(Scan.option (P.$$$ typesN)) --
|
2022-11-01 11:34:30 +00:00
|
|
|
(Scan.option (P.$$$ defsN)) -- P.embedded --
|
2014-07-14 19:32:44 +00:00
|
|
|
(Scan.option
|
|
|
|
(P.$$$ "[" |-- P.enum1 "," typoptions --| P.$$$ "]"))) >>
|
|
|
|
(Toplevel.theory o install_C_file)
|
|
|
|
end
|
|
|
|
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command
|
2015-04-18 20:51:26 +00:00
|
|
|
@{command_keyword "install_C_file"}
|
2014-07-14 19:32:44 +00:00
|
|
|
"import a C file"
|
|
|
|
file_inclusion
|
|
|
|
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command
|
2015-04-18 20:51:26 +00:00
|
|
|
@{command_keyword "install_C_types"}
|
2014-07-14 19:32:44 +00:00
|
|
|
"install types from a C file"
|
2022-11-01 11:34:30 +00:00
|
|
|
(P.embedded >> (Toplevel.theory o install_C_types))
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
end
|
|
|
|
|
|
|
|
end; (* struct *)
|