diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index da9782151..4e17e20b1 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -70,6 +70,6 @@ jobs: run: | opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-ci.sh + cd tests; USE_OPAM='' ./run-ci.sh --both-callconvs ./diff-prog.py cerberus bytes/elab.json ./diff-prog.py cerberus bytes/exec.json diff --git a/.gitignore b/.gitignore index bcceb1ddc..f747f2178 100644 --- a/.gitignore +++ b/.gitignore @@ -23,7 +23,6 @@ generated_tex/ /public/node_modules/ /cerberus-webserver /webcerb.concrete -/webcerb.symbolic /webcerb.vip /public/dist/main.bundle.js /public/dist/main.bundle.js.map diff --git a/Makefile b/Makefile index b8f2a0ad8..c3414b5db 100644 --- a/Makefile +++ b/Makefile @@ -115,9 +115,8 @@ web: cerberus-web cerberus-web: prelude-src web-deployment @echo "[DUNE] web" $(Q)dune build $(DUNEFLAGS) cerberus-lib.install cerberus-web.install - $(Q) rm -f webcerb.concrete webcerb.symbolic webcerb.vip cerberus-webserver + $(Q) rm -f webcerb.concrete webcerb.vip cerberus-webserver $(Q)cp -L _build/default/backend/web/instance.exe webcerb.concrete - $(Q)cp -L _build/default/backend/web/instance_symbolic.exe webcerb.symbolic $(Q)cp -L _build/default/backend/web/instance_vip.exe webcerb.vip $(Q)cp -L _build/default/backend/web/web.exe cerberus-webserver @@ -149,8 +148,7 @@ LEM_CORE_TO_CORE = core_sequentialise.lem core_indet.lem core_rewrite.lem \ core_unstruct.lem LEM_CORE_DYNAMICS = core_run_aux.lem core_eval.lem core_run.lem core_reduction.lem core_reduction_aux.lem driver.lem LEM_ELABORATION = translation_effect.lem translation_aux.lem translation.lem -LEM_DEFACTO = mem_common.lem defacto_memory_types.lem \ - defacto_memory_aux.lem defacto_memory.lem mem.lem \ +LEM_DEFACTO = mem_common.lem mem.lem \ mem_aux.lem LEM_CONC_INTERF = cmm_aux.lem LEM_CONC = cmm_csem.lem cmm_op.lem linux.lem @@ -276,7 +274,7 @@ clean-sibylfs-src: .PHONY: clean-web distclean-web clean-web: - $(Q)rm -f webcerb.concrete webcerb.symbolic webcerb.vip cerberus-webserver + $(Q)rm -f webcerb.concrete webcerb.vip cerberus-webserver distclean-web: $(Q)rm -f public/dist/main.bundle.js public/dist/main.bundle.js.map $(Q)rm -f public/dist/style.bundle.css public/dist/style.bundle.css.map diff --git a/backend/bmc/bmc_common.ml b/backend/bmc/bmc_common.ml index 4c0899b72..99a6f9d08 100644 --- a/backend/bmc/bmc_common.ml +++ b/backend/bmc/bmc_common.ml @@ -135,13 +135,13 @@ let integer_value_to_z3 (ival: Impl_mem.integer_value) : Expr.expr = | None -> assert false | Some i -> big_num_to_z3 i -let object_value_to_z3 (oval: object_value) : Expr.expr = +let object_value_to_z3 ~tagDefs (oval: object_value) : Expr.expr = match oval with | OVinteger ival -> integer_value_to_z3 ival | OVfloating _ -> failwith "Floats are not supported." | OVpointer pv -> - assert (is_null pv); + assert (is_null ~tagDefs pv); PointerSort.mk_null | OVarray _ | OVstruct _ @@ -163,7 +163,7 @@ let value_to_z3 (value: value) (file: unit typed_file) : Expr.expr = | Vlist _ -> assert false | Vtuple _ -> assert false | Vctype cty -> CtypeSort.mk_expr cty - | Vobject oval -> object_value_to_z3 oval + | Vobject oval -> object_value_to_z3 ~tagDefs:file.tagDefs oval | Vloaded (LVspecified oval) -> begin match oval with | OVinteger ival -> diff --git a/backend/bmc/bmc_utils.ml b/backend/bmc/bmc_utils.ml index 98c1ef123..40c5c50b8 100644 --- a/backend/bmc/bmc_utils.ml +++ b/backend/bmc/bmc_utils.ml @@ -191,10 +191,10 @@ let ident_cmp = fun ident1 ident2 -> (* ========== Core memory functions ============= *) -let is_null (ptr: Impl_mem.pointer_value) : bool = +let is_null ~tagDefs (ptr: Impl_mem.pointer_value) : bool = let (Nondeterminism.ND f) = Impl_mem.eq_ptrval Cerb_location.unknown ptr (Impl_mem.null_ptrval Ctype.void) in - match f (Impl_mem.initial_mem_state) with + match f (Impl_mem.initial_mem_state tagDefs) with | (Nondeterminism.NDactive b,_) -> b | _ -> assert false diff --git a/backend/bmc/main.ml b/backend/bmc/main.ml index 8b8fafc16..95974b546 100644 --- a/backend/bmc/main.ml +++ b/backend/bmc/main.ml @@ -11,13 +11,13 @@ let io, get_progress = let open Pipeline in default_io_helpers, get_progress -let frontend (conf, io) ~is_lib filename core_std = +let frontend elab_conf (conf, io) ~is_lib filename core_std = if not (Sys.file_exists filename) then error ("The file `" ^ filename ^ "' doesn't exist."); if Filename.check_suffix filename ".co" || Filename.check_suffix filename ".o" then read_core_object (conf, io) ~is_lib core_std filename else if Filename.check_suffix filename ".c" then - c_frontend_and_elaboration (conf, io) core_std ~filename >>= fun (_, _, core_file) -> + c_frontend_and_elaboration elab_conf (conf, io) core_std ~filename >>= fun (_, _, core_file) -> core_passes (conf, io) ~filename core_file else if Filename.check_suffix filename ".core" then core_frontend (conf, io) core_std ~filename @@ -106,16 +106,18 @@ let cerberus debug_level progress core_obj let prelude = (* Looking for and parsing the core standard library *) Switches.set switches; + (* TODO: merge this with conf *) + let elab_conf = mk_elab_config () in load_core_stdlib () >>= fun core_stdlib -> io.pass_message "Core standard library loaded." >> (* Looking for and parsing the implementation file *) load_core_impl core_stdlib impl_name >>= fun core_impl -> io.pass_message "Implementation file loaded." >> - return (core_stdlib, core_impl) + return ((core_stdlib, core_impl), elab_conf) in - let main core_std = + let main core_std elab_conf = Exception.except_foldlM (fun core_files (is_lib, file) -> - frontend (conf, io) ~is_lib file core_std >>= fun core_file -> + frontend elab_conf (conf, io) ~is_lib file core_std >>= fun core_file -> return (core_file::core_files) ) [] (core_libraries (not nolibc && not core_obj) link_lib_path link_core_obj @ (List.map (fun z -> (false, z)) files)) in @@ -187,7 +189,8 @@ let cerberus debug_level progress core_obj else Pp_errors.fatal "no input file" | [file] when core_obj -> - prelude >>= frontend (conf, io) ~is_lib:false file >>= fun core_file -> + prelude >>= fun (core_std, elab_conf) -> + frontend elab_conf (conf, io) ~is_lib:false file core_std >>= fun core_file -> begin match output_name with | Some output_file -> write_core_object core_file output_file @@ -204,8 +207,8 @@ let cerberus debug_level progress core_obj else if bmc then begin match files with | [filename] -> - prelude >>= fun core_std -> - c_frontend_and_elaboration (conf, io) core_std ~filename >>= fun (_, ail_opt, core) -> + prelude >>= fun (core_std, elab_conf) -> + c_frontend_and_elaboration elab_conf (conf, io) core_std ~filename >>= fun (_, ail_opt, core) -> core_passes (conf, io) ~filename core >>= fun core -> ignore @@ Bmc.bmc core (Option.map snd ail_opt); return success @@ -236,9 +239,9 @@ let cerberus debug_level progress core_obj return success (* Dump a core object (-c) *) else if core_obj then - prelude >>= fun core_std -> + prelude >>= fun (core_std, elab_conf) -> Exception.except_foldlM (fun () file -> - frontend (conf, io) ~is_lib:false file core_std >>= fun core_file -> + frontend elab_conf (conf, io) ~is_lib:false file core_std >>= fun core_file -> let output_file = Filename.remove_extension file ^ ".co" in write_core_object core_file output_file; return () @@ -246,7 +249,8 @@ let cerberus debug_level progress core_obj return success (* Link and execute *) else - prelude >>= main >>= begin function + prelude >>= fun (core_std, elab_conf) -> + main core_std elab_conf >>= begin function | [] -> assert false | f::fs -> (*if cfg then Cfg.mk_dot ~sequentialise:sequentialise_core f;*) @@ -254,8 +258,7 @@ let cerberus debug_level progress core_obj end >>= fun core_file -> if exec then let open Driver_ocaml in - let () = Tags.set_tagDefs core_file.tagDefs in - let driver_conf = {concurrency; exec_mode; fs_dump; trace} in + let driver_conf = {exec_mode; do_stepping= false; concurrency; fs_dump; trace} in interp_backend io core_file ~args ~batch ~fs ~driver_conf else match output_name with diff --git a/backend/common/driver_ocaml.ml b/backend/common/driver_ocaml.ml index 7a47a4085..148fb1bb8 100644 --- a/backend/common/driver_ocaml.ml +++ b/backend/common/driver_ocaml.ml @@ -11,6 +11,8 @@ let isActive = function type driver_conf = { (* TODO: bring back ==> [`Interactive | `Exhaustive | `Random] -> *) exec_mode: execution_mode; + do_stepping: bool; (* Stepping should only be enabled when really used (e.g. for Web instances) + * because it impacts execution time *) concurrency: bool; fs_dump: bool; trace: bool; @@ -66,87 +68,103 @@ let string_of_batch_output ?(json=false) ?(is_charon=false) i_opt (z3_strs, exec end else "" in - let has_multiple = - match i_opt with - | Some i -> - Printf.bprintf buf "EXECUTION %d" i; - true - | None -> - Buffer.add_string buf constrs_str; - false in - begin match exec with - | Defined { exit; stdout; stderr; blocked } -> - let exit_str = Cerb_colour.without_colour string_of_batch_exit exit in - if is_charon then begin - if has_multiple then begin - Printf.bprintf buf " (exit = %s):\n" exit_str; - Buffer.add_string buf constrs_str - end; - Buffer.add_string buf stdout; - prerr_string stderr - end else if json then begin - Yojson.to_buffer buf begin - `Assoc [ "status", `String "Defined" - ; "details", `Assoc [ "value", `String exit_str - ; "stdout", `String (String.escaped stdout) - ; "stderr", `String (String.escaped stderr) ] ] - end - end else begin - begin if has_multiple then - Buffer.add_string buf ":\n" - end; - Buffer.add_string buf constrs_str; - Printf.bprintf buf "Defined {value: \"%s\", stdout: \"%s\", stderr: \"%s\", blocked: \"%s\"}" - exit_str - (String.escaped stdout) (String.escaped stderr) - (if blocked then "true" else "false") - end - | Undefined { ub; stderr; loc } -> - begin if has_multiple then - Buffer.add_string buf ":\n" - end; - Buffer.add_string buf constrs_str; - if is_charon then begin - prerr_string stderr; - Printf.bprintf buf "Undefined {ub: \"%s\", loc: \"%s\"}%s" - (Undefined.stringFromUndefined_behaviour ub) - (Cerb_location.simple_location loc) - (if is_charon then "\n" else "") - end else if json then begin - Yojson.to_buffer buf begin - `Assoc [ "status", `String "Undefined" - ; "details", `Assoc [ "ub", `String (Undefined.stringFromUndefined_behaviour ub) - ; "stderr", `String (String.escaped stderr) - ; "loc", (Cerb_location.to_json loc :> Yojson.t) ] ] - end - end else - Printf.bprintf buf "Undefined {ub: \"%s\", stderr: \"%s\", loc: \"%s\"}%s" - (Undefined.stringFromUndefined_behaviour ub) - (String.escaped stderr) - (Cerb_location.simple_location loc) - (if is_charon then "\n" else "") - | Error { msg; stderr } -> - if is_charon then - prerr_string stderr - else if json then begin - Yojson.to_buffer buf begin - `Assoc [ "status", `String "Error" - ; "details", `Assoc [ "msg", `String msg - ; "stderr", `String (String.escaped stderr) ] ] + if json then begin + let execution_fields = + match i_opt with + | Some i -> [ ("execution", `Int i) ] + | None -> [] in + let constraints_fields = + if !Cerb_debug.debug_level > 0 then + [ ("constraints", `List (List.map (fun z -> `String z) z3_strs)) ] + else + [] in + let (status, details) = + match exec with + | Defined { exit; stdout; stderr; blocked } -> + ( "Defined" + , [ ("value", `String (Cerb_colour.without_colour string_of_batch_exit exit)) + ; ("stdout", `String stdout) + ; ("stderr", `String stderr) + ; ("blocked", `Bool blocked) ] ) + | Undefined { ub; stderr; loc } -> + ( "Undefined" + , [ ("ub", `String (Undefined.stringFromUndefined_behaviour ub)) + ; ("stderr", `String stderr) + ; ("loc", (Cerb_location.to_json loc :> Yojson.t)) ] ) + | Error { msg; stderr } -> + ( "Error" + , [ ("msg", `String msg) + ; ("stderr", `String stderr) ] ) in + Yojson.to_buffer buf begin + `Assoc (execution_fields @ [ ("status", `String status); ("details", `Assoc details) ] + @ constraints_fields) + end; + Buffer.add_string buf "\n"; + flush_all (); + Buffer.contents buf + end else begin + let has_multiple = + match i_opt with + | Some i -> + Printf.bprintf buf "EXECUTION %d" i; + true + | None -> + Buffer.add_string buf constrs_str; + false in + begin match exec with + | Defined { exit; stdout; stderr; blocked } -> + let exit_str = Cerb_colour.without_colour string_of_batch_exit exit in + if is_charon then begin + if has_multiple then begin + Printf.bprintf buf " (exit = %s):\n" exit_str; + Buffer.add_string buf constrs_str + end; + Buffer.add_string buf stdout; + prerr_string stderr + end else begin + begin if has_multiple then + Buffer.add_string buf ":\n" + end; + Buffer.add_string buf constrs_str; + Printf.bprintf buf "Defined {value: \"%s\", stdout: \"%s\", stderr: \"%s\", blocked: \"%s\"}" + exit_str + (String.escaped stdout) (String.escaped stderr) + (if blocked then "true" else "false") end - end else begin + | Undefined { ub; stderr; loc } -> begin if has_multiple then Buffer.add_string buf ":\n" end; Buffer.add_string buf constrs_str; - Printf.bprintf buf "Error {msg: \"%s\"}%s" - msg + if is_charon then begin + prerr_string stderr; + Printf.bprintf buf "Undefined {ub: \"%s\", loc: \"%s\"}%s" + (Undefined.stringFromUndefined_behaviour ub) + (Cerb_location.simple_location loc) (if is_charon then "\n" else "") - end - end; - (if not is_charon then Buffer.add_string buf "\n" else ()); - flush_all (); - Buffer.contents buf + end else + Printf.bprintf buf "Undefined {ub: \"%s\", stderr: \"%s\", loc: \"%s\"}%s" + (Undefined.stringFromUndefined_behaviour ub) + (String.escaped stderr) + (Cerb_location.simple_location loc) + (if is_charon then "\n" else "") + | Error { msg; stderr } -> + if is_charon then + prerr_string stderr + else begin + begin if has_multiple then + Buffer.add_string buf ":\n" + end; + Buffer.add_string buf constrs_str; + Printf.bprintf buf "Error {msg: \"%s\"}%s" + msg + (if is_charon then "\n" else "") + end + end; + (if not is_charon then Buffer.add_string buf "\n" else ()); + flush_all (); + Buffer.contents buf + end (* TODO: make the output match the json format from charon2 (or at least add a option for that) *) let batch_drive (file: 'a Core.file) args fs_state conf = @@ -154,7 +172,7 @@ let batch_drive (file: 'a Core.file) args fs_state conf = (* changing the annotations type from unit to core_run_annotation *) let file = Core_run_aux.convert_file file in (* computing the value (or values if exhaustive) *) - let initial_dr_st = Driver.initial_driver_state file fs_state in + let initial_dr_st = Driver.initial_driver_state file fs_state conf.do_stepping in let values = Smt2.runND conf.exec_mode Impl_mem.cs_module (Driver.drive conf.concurrency file args) initial_dr_st in List.mapi (fun i (res, z3_strs, nd_st) -> let result = begin match res with @@ -191,7 +209,7 @@ let drive file args fs_state conf : execution_result = (* changing the annotations type from unit to core_run_annotation *) let file = Core_run_aux.convert_file file in (* computing the value (or values if exhaustive) *) - let initial_dr_st = Driver.initial_driver_state file fs_state in + let initial_dr_st = Driver.initial_driver_state file fs_state conf.do_stepping in let values = Smt2.runND conf.exec_mode Impl_mem.cs_module (Driver.drive conf.concurrency file args) initial_dr_st in let n_actives = List.length (List.filter isActive values) in diff --git a/backend/common/driver_ocaml.mli b/backend/common/driver_ocaml.mli index 78ba7be38..9043d7d3f 100644 --- a/backend/common/driver_ocaml.mli +++ b/backend/common/driver_ocaml.mli @@ -3,6 +3,8 @@ open Cerb_frontend type driver_conf = { (* TODO: bring back ==> [`Interactive | `Exhaustive | `Random] -> *) exec_mode: Cerb_global.execution_mode; + do_stepping: bool; (* Stepping should only be enabled when really used (e.g. for Web instances) + * because it impacts execution time *) concurrency: bool; fs_dump: bool; trace: bool; diff --git a/backend/common/pipeline.ml b/backend/common/pipeline.ml index 5d1afaa27..ea549b101 100644 --- a/backend/common/pipeline.ml +++ b/backend/common/pipeline.ml @@ -177,7 +177,9 @@ let cpp (conf, io) ~filename = return txt end () -let c_frontend ?(cn_init_scope=Cn_desugaring.empty_init) (conf, io) (core_stdlib, core_impl) ~filename = +let c_frontend ?(cn_init_scope=Cn_desugaring.empty_init) + desug_conf (conf, io) (core_stdlib, core_impl) ~filename += Cerb_fresh.set_digest filename; let parse filename file_content = C_parser_driver.parse_from_string ~filename file_content >>= fun cabs_tunit -> @@ -199,7 +201,7 @@ let c_frontend ?(cn_init_scope=Cn_desugaring.empty_init) (conf, io) (core_stdlib ret in let desugar cabs_tunit = let (ailnames, core_stdlib_fun_map) = core_stdlib in - Cabs_to_ail.desugar (ailnames, core_stdlib_fun_map, core_impl) cn_init_scope + Cabs_to_ail.desugar desug_conf (ailnames, core_stdlib_fun_map, core_impl) cn_init_scope "main" cabs_tunit >>= fun (markers_env, ail_prog) -> io.set_progress "DESUG" >|> io.pass_message "Cabs -> Ail completed!" @@ -245,15 +247,10 @@ let c_frontend ?(cn_init_scope=Cn_desugaring.empty_init) (conf, io) (core_stdlib ail_typechecking ail_prog >>= fun ailtau_prog -> return (cabs_tunit, (markers_env, ailtau_prog)) -let c_frontend_and_elaboration ?(cn_init_scope=Cn_desugaring.empty_init) (conf, io) (core_stdlib, core_impl) ~filename = - c_frontend ~cn_init_scope (conf, io) (core_stdlib, core_impl) ~filename >>= fun (cabs_tunit, (markers_env, ailtau_prog)) -> - (* NOTE: the elaboration sets the struct/union tag definitions, so to allow the frontend to be - used more than once, we need to do reset here *) - (* TODO(someday): find a better way *) - Tags.reset_tagDefs (); - let calling_convention = - Core.(if Switches.has_switch SW_inner_arg_temps then Inner_arg_callconv else Normal_callconv) in - let core_file = Translation.translate core_stdlib calling_convention core_impl ailtau_prog in +let c_frontend_and_elaboration ?(cn_init_scope=Cn_desugaring.empty_init) elab_conf (conf, io) (core_stdlib, core_impl) ~filename = + let desug_conf = Cabs_to_ail_effect.{ elab_conf } in + c_frontend ~cn_init_scope desug_conf (conf, io) (core_stdlib, core_impl) ~filename >>= fun (cabs_tunit, (markers_env, ailtau_prog)) -> + let core_file = Translation.translate core_stdlib elab_conf core_impl ailtau_prog in io.set_progress "ELABO" >>= fun () -> io.pass_message "Translation to Core completed!" >>= fun () -> return (Some cabs_tunit, Some (markers_env, ailtau_prog), core_file) @@ -701,4 +698,16 @@ let ocaml_backend (conf, io) ~filename ~ocaml_corestd core_file = >>= Codegen_ocaml.gen filename ocaml_corestd *) +let mk_elab_config () = + Translation_effect.{ + calling_convention0= + Core.(if Switches.has_switch SW_inner_arg_temps then Inner_arg_callconv else Normal_callconv); + is_PNVI= Switches.is_PNVI (); + is_CHERI= Switches.is_CHERI (); + is_CN= String.equal Cerb_global.(backend_name ()) "Cn"; + strict_pointer_arith= Switches.has_strict_pointer_arith (); + branching_on_unspec= Translation_effect.( + if Switches.(has_switch SW_branching_on_unspec_is_nd) + then Elab_ND else Elab_UB) + } diff --git a/backend/common/pipeline.mli b/backend/common/pipeline.mli index b0f34efd2..489b24782 100644 --- a/backend/common/pipeline.mli +++ b/backend/common/pipeline.mli @@ -47,6 +47,7 @@ val cpp: (configuration * io_helpers) -> filename:string -> (string, Cerb_locati val c_frontend: ?cn_init_scope: Cn_desugaring.init_scope -> + Cabs_to_ail_effect.desug_config -> (configuration * io_helpers) -> (((string, Symbol.sym) Pmap.map * (unit, unit) Core.generic_fun_map) * unit Core.generic_impl) -> filename:string -> @@ -56,6 +57,7 @@ val c_frontend: val c_frontend_and_elaboration: ?cn_init_scope: Cn_desugaring.init_scope -> + Translation_effect.elab_config -> (configuration * io_helpers) -> (((string, Symbol.sym) Pmap.map * (unit, unit) Core.generic_fun_map) * unit Core.generic_impl) -> filename:string -> @@ -103,3 +105,5 @@ val write_core_object: unit Core.file -> string -> unit val untype_file: 'a Core.typed_file -> 'a Core.file + +val mk_elab_config: unit -> Translation_effect.elab_config \ No newline at end of file diff --git a/backend/driver/dune b/backend/driver/dune index 8245c4ff6..7ea527f57 100644 --- a/backend/driver/dune +++ b/backend/driver/dune @@ -5,18 +5,6 @@ (modules main) (libraries result cmdliner str unix mem_concrete cerberus-lib.backend_common)) -;(executable -; (name main_symbolic) -; (public_name cerberus-symbolic) -; (package cerberus) -; (modules main_symbolic) -; (libraries result cmdliner str unix mem_symbolic cerberus-lib.backend_common)) - -(rule - (target main_symbolic.ml) - (deps main.ml) - (action (copy main.ml main_symbolic.ml))) - (executable (name main_vip) (public_name cerberus-vip) diff --git a/backend/driver/main.ml b/backend/driver/main.ml index 134c59351..21ae2ede8 100644 --- a/backend/driver/main.ml +++ b/backend/driver/main.ml @@ -20,13 +20,13 @@ let is_cheri_memory () = | Invalid_argument _ -> false in starts_with ~prefix:"cheri" Impl_mem.name -let frontend (conf, io) ~is_lib filename core_std = +let frontend elab_conf (conf, io) ~is_lib filename core_std = if not (Sys.file_exists filename) then error ("The file `" ^ filename ^ "' doesn't exist."); if Filename.check_suffix filename ".co" || Filename.check_suffix filename ".o" then read_core_object (conf, io) ~is_lib core_std filename else if Filename.check_suffix filename ".c" then - c_frontend_and_elaboration (conf, io) core_std ~filename >>= fun (_, _, core_file) -> + c_frontend_and_elaboration elab_conf (conf, io) core_std ~filename >>= fun (_, _, core_file) -> core_passes (conf, io) ~filename core_file else if Filename.check_suffix filename ".core" then core_frontend (conf, io) core_std ~filename @@ -141,17 +141,19 @@ let cerberus debug_level progress core_obj end else Switches.set switches end; + (* TODO: merge this with conf *) + let elab_conf = mk_elab_config () in io.pass_message (Printf.sprintf "Using '%s'" Impl_mem.name) >> load_core_stdlib () >>= fun core_stdlib -> io.pass_message "Core standard library loaded." >> (* Looking for and parsing the implementation file *) load_core_impl core_stdlib impl_name >>= fun core_impl -> io.pass_message "Implementation file loaded." >> - return (core_stdlib, core_impl) + return ((core_stdlib, core_impl), elab_conf) in - let main core_std = + let main elab_conf core_std = Exception.except_foldlM (fun core_files (is_lib, file) -> - frontend ~is_lib (conf, io) file core_std >>= fun core_file -> + frontend ~is_lib elab_conf (conf, io) file core_std >>= fun core_file -> return (core_file::core_files) ) [] (core_libraries (not nolibc && not core_obj) link_lib_path link_core_obj @ (List.map (fun z -> (false, z)) files)) in @@ -162,6 +164,18 @@ let cerberus debug_level progress core_obj else n in let success = Either.Right 0 in + (* --json-batch: the errors issued before any execution are reported on + * stdout as a JSON object of the same shape as the executions *) + let print_json_error ?(loc=Cerb_location.unknown) kind msg text = + print_string begin + Yojson.to_string begin + `Assoc [ ("status", `String "Error") + ; ("details", `Assoc [ ("kind", `String kind) + ; ("msg", `String msg) + ; ("loc", (Cerb_location.to_json loc :> Yojson.t)) + ; ("text", `String text) ]) ] + end ^ "\n" + end in let runM = function | Exception.Exception (loc, Errors.(DESUGAR (Desugar_UndefinedBehaviour ub))) when (batch = `Batch || batch = `CharonBatch || batch = `JsonBatch) -> let open Driver_ocaml in @@ -177,6 +191,11 @@ let cerberus debug_level progress core_obj ([], Undefined { ub; stderr= ""; loc }) end; epilogue 1 + | Exception.Exception (loc, err) when batch = `JsonBatch -> + print_json_error ~loc (Pp_errors.string_of_cause_kind err) + (Cerb_colour.without_colour Pp_errors.short_message err) + (Cerb_colour.without_colour Pp_errors.to_string (loc, err)); + epilogue 1 | Exception.Exception err -> prerr_endline (Pp_errors.to_string err); epilogue 1 @@ -217,11 +236,17 @@ let cerberus debug_level progress core_obj | Exception.Result (Either.Right n) -> epilogue n in + let run () = runM @@ match files with | [] -> - Pp_errors.fatal "no input file" + if batch = `JsonBatch then begin + print_json_error "fatal" "no input file" "no input file"; + exit 1 + end else + Pp_errors.fatal "no input file" | [file] when core_obj -> - prelude >>= frontend (conf, io) ~is_lib:false file >>= fun core_file -> + prelude >>= fun (core_std, elab_conf) -> + frontend elab_conf (conf, io) ~is_lib:false file core_std >>= fun core_file -> begin match output_name with | Some output_file -> write_core_object core_file output_file @@ -241,9 +266,9 @@ let cerberus debug_level progress core_obj return success (* Dump a core object (-c) *) else if core_obj then - prelude >>= fun core_std -> + prelude >>= fun (core_std, elab_conf) -> Exception.except_foldlM (fun () file -> - frontend (conf, io) ~is_lib:false file core_std >>= fun core_file -> + frontend elab_conf (conf, io) ~is_lib:false file core_std >>= fun core_file -> let output_file = Filename.remove_extension file ^ ".co" in write_core_object core_file output_file; return () @@ -251,9 +276,9 @@ let cerberus debug_level progress core_obj return success (* Parsing, Ail typing and stopping there *) else if syntax_only && List.for_all (fun z -> Filename.check_suffix z ".c") files then - prelude >>= fun core_std -> + prelude >>= fun (core_std, elab_conf) -> Exception.except_mapM (fun filename -> - c_frontend (conf, io) core_std ~filename + c_frontend Cabs_to_ail_effect.{ elab_conf } (conf, io) core_std ~filename ) files >>= fun _ -> return success (* Link and execute *) @@ -263,16 +288,17 @@ let cerberus debug_level progress core_obj else return () end >>= fun () -> - prelude >>= main >>= begin function + prelude >>= fun (core_std, elab_conf) -> + main elab_conf core_std >>= begin function | [] -> assert false | f::fs -> Core_linking.link (f::fs) end >>= fun core_file -> if exec then let open Driver_ocaml in - let () = Tags.reset_tagDefs () in (* TODO: check this *) - let () = Tags.set_tagDefs core_file.tagDefs in - let driver_conf = {concurrency; exec_mode; fs_dump; trace} in + (* Stepping is only enabled for Web instance because they impact execution time *) + let do_stepping = false in + let driver_conf = {exec_mode; do_stepping; concurrency; fs_dump; trace} in interp_backend io core_file ~args ~batch ~fs ~driver_conf else match output_name with @@ -285,6 +311,16 @@ let cerberus debug_level progress core_obj (write_core_object core_file (out ^ ".co"); create_executable out); return success end + in + if batch = `JsonBatch then + (* the OCaml exceptions escaping the pipeline (likely crashes) are reported + * as JSON too, and re-raised *) + try run () with + | e -> + print_json_error "uncaught_exception" (Printexc.to_string e) ""; + raise e + else + run () (* CLI stuff *) open Cmdliner @@ -464,7 +500,7 @@ let batch = let doc = "makes the execution driver produce batch friendly output" in Arg.(value & vflag `NotBatch & [(`Batch, info["batch"] ~doc); (`CharonBatch, info["charon-batch"] ~doc:(doc^" (for Charon)")); - (`JsonBatch, info["json-batch"] ~doc:"outputs the executions in json") ]) + (`JsonBatch, info["json-batch"] ~doc:"like --batch, but prints one JSON object per line on stdout (for each execution, or for the reported error)") ]) let typecheck_core = let doc = "typecheck the elaborated Core program" in diff --git a/backend/web/dune b/backend/web/dune index ff624546a..9c6e6ab49 100644 --- a/backend/web/dune +++ b/backend/web/dune @@ -23,15 +23,6 @@ (libraries str lwt cohttp-lwt-unix ezgzip fpath cerb_frontend cerb_backend mem_vip cerb_util instance_api)) -(executable - (name instance_symbolic) - (public_name instance-symbolic) - (package cerberus-web) - (flags (:standard -w -27)) - (modules instance_symbolic) - (libraries str lwt cohttp-lwt-unix ezgzip fpath - cerb_frontend cerb_backend mem_symbolic cerb_util instance_api)) - (executable (name web) (public_name cerberus-webserver) @@ -41,11 +32,6 @@ (libraries str lwt cohttp-lwt-unix ezgzip fpath cerb_frontend cerb_backend mem_concrete cerb_util instance_api)) -(rule - (target instance_symbolic.ml) - (deps instance.ml) - (action (copy instance.ml instance_symbolic.ml))) - (rule (target instance_vip.ml) (deps instance.ml) diff --git a/backend/web/instance.ml b/backend/web/instance.ml index 83e45fac8..15c7384a6 100644 --- a/backend/web/instance.ml +++ b/backend/web/instance.ml @@ -98,7 +98,9 @@ let elaborate ~is_bmc ~conf ~filename = try load_core_stdlib () >>= fun core_stdlib -> load_core_impl core_stdlib conf.instance.core_impl >>= fun core_impl -> - c_frontend_and_elaboration (conf.pipeline, conf.io) (core_stdlib, core_impl) ~filename + (* TODO: merge this with conf *) + let elab_conf = mk_elab_config () in + c_frontend_and_elaboration elab_conf (conf.pipeline, conf.io) (core_stdlib, core_impl) ~filename >>= function | (Some cabs, Some (_, ail), core) -> core_passes (conf.pipeline, conf.io) ~filename core @@ -173,7 +175,6 @@ let bmc ~filename ~name ~conf ~bmc_model:bmc_model ~filename () = try elaborate ~is_bmc:true ~conf ~filename >>= fun (core_std, core_lib, cabs, ail, core) -> - Tags.set_tagDefs core.tagDefs; let (cat_file_opt, mem_model) = match bmc_model with | `C11 -> @@ -221,9 +222,8 @@ let execute ~conf ~filename (mode: Cerb_global.execution_mode) = else return core end >>= fun core -> - Tags.set_tagDefs core.tagDefs; let open Driver_ocaml in - let driver_conf = {concurrency=false; exec_mode=mode; fs_dump=false; trace=false; } in + let driver_conf = {exec_mode=mode; do_stepping= true; concurrency=false; fs_dump=false; trace=false; } in interp_backend dummy_io core ~args:[] ~batch:`Batch ~fs:None ~driver_conf >>= function | Either.Left (_, execs) -> @@ -390,7 +390,7 @@ let json_of_step_kind step = | SK_done -> `Assoc [("kind", `String "done")] | SK_misc strs -> - `Assoc [("kind", `String "action request"); + `Assoc [("kind", `String "misc"); ("debug", `List (List.map (fun str -> `String str) strs))] let create_node node_info st next_state = @@ -630,9 +630,8 @@ let step ~conf ~filename (active_node_opt: Instance_api.active_node option) = else return core end >>= fun core -> - Tags.set_tagDefs core.tagDefs; let core' = Core_run_aux.convert_file core in - let st0 = Driver.initial_driver_state core' Sibylfs.fs_initial_state (* TODO *) in + let st0 = Driver.initial_driver_state core' Sibylfs.fs_initial_state true(*do_stepping*) in let (m, st) = (Driver.drive false core' [], st0) in last_node_id := 0; let node_info= `Init in @@ -640,11 +639,8 @@ let step ~conf ~filename (active_node_opt: Instance_api.active_node option) = let (c_loc, core_uid, arena, env, stdout, stderr) = get_state_details st in let next_state = Some (encode (m, st)) in let n = { node_id= 0; node_info; memory; c_loc; core_uid; arena; env; next_state; stdout; stderr } in - let tagDefs = encode @@ Tags.tagDefs () in - return @@ Interactive (tagDefs, ranges, ([n], [])) + return @@ Interactive (ranges, ([n], [])) | Some n -> - let tagsMap : (Symbol.sym, Cerb_location.t * Ctype.tag_definition) Pmap.map = decode n.tagDefs in - Tags.set_tagDefs tagsMap; hack ~conf Random; Switches.set conf.instance.switches; last_node_id := n.last_id; diff --git a/backend/web/instance_api.ml b/backend/web/instance_api.ml index cceb80ccd..9b3afed22 100644 --- a/backend/web/instance_api.ml +++ b/backend/web/instance_api.ml @@ -14,7 +14,6 @@ type conf = core_impl: string; (* core implementation file *) cerb_debug_level: int; (* Cerberus debug level (not include server) *) timeout: int; (* instance execution timeout *) - tagDefs: string; (* marshalled tag defs *) switches: string list; n1570: Yojson.Basic.t; } @@ -23,7 +22,6 @@ type active_node = { last_id: int; (* used to feed node id generation in the current instance *) marshalled_state: string; active_id: int; - tagDefs: string; } type filename = string @@ -100,7 +98,7 @@ type elaboration_result = type result = | Elaboration of elaboration_result | Execution of string (* cerberus result *) - | Interactive of string * (string * PPrint.range) list * exec_tree (* tagDefs * range list * execution tree *) + | Interactive of (string * PPrint.range) list * exec_tree (* range list * execution tree *) | Step of string option * int * exec_tree (* maybe result * active node id * execution tree *) | BMC of [ `Satisfiable of (string * string list) | `Unsatisfiable of (string * string list) | `Unknown of string ] | Shorten of string diff --git a/backend/web/web.ml b/backend/web/web.ml index d29975fbf..df275066d 100644 --- a/backend/web/web.ml +++ b/backend/web/web.ml @@ -146,7 +146,6 @@ let create_conf w = { rewrite_core = false; sequentialise_core = false; link_libc = false; - tagDefs = ""; switches = []; cpp_cmd = cpp_cmd (); core_impl = w.core_impl; @@ -188,12 +187,10 @@ type action = (* implementation of the memory interface *) type model = [ `Concrete - | `Symbolic | `VIP ] let string_of_model = function | `Concrete -> "concrete" - | `Symbolic -> "symbolic" | `VIP -> "vip" let string_of_action = function @@ -232,7 +229,6 @@ let parse_incoming_msg content = } in let empty_node_id = { last_id= 0; - tagDefs= ""; marshalled_state= ""; active_id= 0; } @@ -263,7 +259,6 @@ let parse_incoming_msg content = in let parse_model = function | "concrete" -> `Concrete - | "symbolic" -> `Symbolic | "vip" -> `VIP | str -> Debug.warn ("Unknown model: '" ^ str ^ "' (defaulting to 'concrete')"); @@ -294,9 +289,6 @@ let parse_incoming_msg content = | ("interactive[active]", [v]) -> { msg with interactive= Some { (get msg.interactive) with active_id = int_of_string v } } - | ("interactive[tagDefs]", [v]) -> - { msg with interactive= - Some { (get msg.interactive) with tagDefs = Base64.decode_exn v } } | (k, _) -> Debug.warn ("unknown value " ^ k ^ " when parsing incoming message"); msg (* ignore unknown key *) @@ -400,14 +392,13 @@ let json_of_result = function ("console", `String ""); ("result", `String str); ] - | Interactive (tags, ranges, t) -> + | Interactive (ranges, t) -> `Assoc [ ("steps", json_of_exec_tree t); ("status", `String "interactive"); ("result", `String ""); ("ranges", `Assoc (List.map (fun (uid, range) -> (uid, json_of_range range)) ranges)); - ("tagDefs", `String (Base64.encode_string tags)); ] | Step (res, activeId, t) -> `Assoc [ @@ -655,7 +646,6 @@ let cerberus ~rheader ~conf ~flow content = prevent the possibility of exploits since the string comes from the client *) "./webcerb." ^ begin match msg.model with | `Concrete -> "concrete" - | `Symbolic -> "symbolic" | `VIP -> "vip" end in let cmd = (instance, [| instance; "-d" ^ string_of_int !Debug.level|]) in diff --git a/coq/CheriMemory/CheriMorelloMemory.v b/coq/CheriMemory/CheriMorelloMemory.v index 9df78359a..6a7f03c2d 100644 --- a/coq/CheriMemory/CheriMorelloMemory.v +++ b/coq/CheriMemory/CheriMorelloMemory.v @@ -17,7 +17,7 @@ From CheriCaps.Common Require Import Capabilities. From Common Require Import SimpleError Utils ZMap AMap. From Morello Require Import CapabilitiesGS MorelloCapsGS. -Require Import Memory_model CoqMem_common ErrorWithState CoqUndefined ErrorWithState CoqLocation CoqSymbol CoqImplementation CoqTags CoqSwitches CerbSwitches CoqAilTypesAux. +Require Import Memory_model CoqMem_common ErrorWithState CoqUndefined ErrorWithState CoqLocation CoqSymbol CoqImplementation CoqSwitches CerbSwitches CoqAilTypesAux. Local Open Scope string_scope. Local Open Scope type_scope. @@ -71,7 +71,6 @@ Module Type CheriMemoryImpl (Bounds) (Permissions) Capability_GS) - (TD: TagDefs) (SW: CerbSwitchesDefs) <: Memory(AddressValue)(Bounds)(MC). @@ -302,6 +301,7 @@ Module Type CheriMemoryImpl next_varargs_id : Z; bytemap : AMap.M.t (option ascii); capmeta : AMap.M.t (bool* CapGhostState); + tagDefs: SymMap.t CoqCtype.tag_definition; }. (* @@ -316,44 +316,46 @@ Module Type CheriMemoryImpl next_varargs_id := st.(next_varargs_id); bytemap := st.(bytemap); capmeta := st.(capmeta); + tagDefs := st.(tagDefs); |} *) Definition mem_state := mem_state_r. Definition mem_state_with_last_address last_address (r : mem_state) := - Build_mem_state_r r.(next_alloc_id) last_address r.(allocations) r.(funptrmap) r.(varargs) r.(next_varargs_id) r.(bytemap) r.(capmeta). + Build_mem_state_r r.(next_alloc_id) last_address r.(allocations) r.(funptrmap) r.(varargs) r.(next_varargs_id) r.(bytemap) r.(capmeta) r.(tagDefs). Definition mem_state_with_bytemap bytemap (r : mem_state) := - Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) r.(funptrmap) r.(varargs) r.(next_varargs_id) bytemap r.(capmeta). + Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) r.(funptrmap) r.(varargs) r.(next_varargs_id) bytemap r.(capmeta) r.(tagDefs). Definition mem_state_with_allocations allocations (r : mem_state) := - Build_mem_state_r r.(next_alloc_id) r.(last_address) allocations r.(funptrmap) r.(varargs) r.(next_varargs_id) r.(bytemap) r.(capmeta). + Build_mem_state_r r.(next_alloc_id) r.(last_address) allocations r.(funptrmap) r.(varargs) r.(next_varargs_id) r.(bytemap) r.(capmeta) r.(tagDefs). Definition mem_state_with_next_alloc_id next_alloc_id (r : mem_state) := - Build_mem_state_r next_alloc_id r.(last_address) r.(allocations) r.(funptrmap) r.(varargs) r.(next_varargs_id) r.(bytemap) r.(capmeta). + Build_mem_state_r next_alloc_id r.(last_address) r.(allocations) r.(funptrmap) r.(varargs) r.(next_varargs_id) r.(bytemap) r.(capmeta) r.(tagDefs). Definition mem_state_with_capmeta capmeta (r : mem_state) := - Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) r.(funptrmap) r.(varargs) r.(next_varargs_id) r.(bytemap) capmeta. + Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) r.(funptrmap) r.(varargs) r.(next_varargs_id) r.(bytemap) capmeta r.(tagDefs). Definition mem_state_with_funptrmap funptrmap (r : mem_state) := - Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) funptrmap r.(varargs) r.(next_varargs_id) r.(bytemap) r.(capmeta). + Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) funptrmap r.(varargs) r.(next_varargs_id) r.(bytemap) r.(capmeta) r.(tagDefs). Definition mem_state_with_varargs_next_varargs_id varargs next_varargs_id (r : mem_state) := - Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) r.(funptrmap) varargs next_varargs_id r.(bytemap) r.(capmeta). + Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) r.(funptrmap) varargs next_varargs_id r.(bytemap) r.(capmeta) r.(tagDefs). Definition mem_state_with_bytemap_capmeta bytemap capmeta (r : mem_state) := - Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) r.(funptrmap) r.(varargs) r.(next_varargs_id) bytemap capmeta. + Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) r.(funptrmap) r.(varargs) r.(next_varargs_id) bytemap capmeta r.(tagDefs). Definition mem_state_with_funptrmap_bytemap_capmeta funptrmap bytemap capmeta (r : mem_state) := - Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) funptrmap r.(varargs) r.(next_varargs_id) bytemap capmeta. + Build_mem_state_r r.(next_alloc_id) r.(last_address) r.(allocations) funptrmap r.(varargs) r.(next_varargs_id) bytemap capmeta r.(tagDefs). Definition initial_address := AddressValue.of_Z (HexString.to_Z "0xFFFFFFFFFFFF"). Definition DEFAULT_FUEL:nat := 1000%nat. (* TODO maybe needs to be abstracted *) Definition MAX_STRFCAP_FORMAT_LEN := 4096%nat. - Definition initial_mem_state : mem_state := + Definition initial_mem_state (tagDefs: SymMap.t CoqCtype.tag_definition) + : mem_state := {| next_alloc_id := Z0; last_address := initial_address; @@ -363,6 +365,7 @@ Module Type CheriMemoryImpl next_varargs_id := Z0; bytemap := AMap.M.empty _; capmeta := AMap.M.empty _; + tagDefs := tagDefs; |}. Definition memM := errS mem_state memMError. @@ -545,6 +548,7 @@ Module Type CheriMemoryImpl next_varargs_id := st.(next_varargs_id); bytemap := st.(bytemap); capmeta := (init_ghost_tags (AddressValue.of_Z addr) size st.(capmeta)); + tagDefs := st.(tagDefs); |}) ;; (* mprint_msg ("Alloc: " ++ String.hex_str addr ++ " (" ++ String.dec_str size ++ ")" ) ;; *) @@ -552,14 +556,9 @@ Module Type CheriMemoryImpl Fixpoint alignof (fuel: nat) - (maybe_tagDefs : option (SymMap.t CoqCtype.tag_definition)) + (tagDefs : SymMap.t CoqCtype.tag_definition) (ty: CoqCtype.ctype): serr nat := - let tagDefs := - match maybe_tagDefs with - | Some x => x - | None => TD.tagDefs tt - end in let fix alignof_ (fuel: nat) ty := match fuel with | O => raise "alignof out of fuel" @@ -594,9 +593,9 @@ Module Type CheriMemoryImpl monadic_fold_left (fun acc '(_, (_, align_opt, _, ty)) => al <- match align_opt with - | None => alignof fuel (Some tagDefs) ty + | None => alignof fuel tagDefs ty | Some (CoqCtype.AlignInteger al_n) => ret (Z.to_nat al_n) - | Some (CoqCtype.AlignType al_ty) => alignof fuel (Some tagDefs) al_ty + | Some (CoqCtype.AlignType al_ty) => alignof fuel tagDefs al_ty end ;; ret (Nat.max al acc) ) @@ -612,9 +611,9 @@ Module Type CheriMemoryImpl monadic_fold_left (fun acc '(_, (_, align_opt, _, ty)) => al <- match align_opt with - | None => alignof fuel (Some tagDefs) ty + | None => alignof fuel tagDefs ty | Some (CoqCtype.AlignInteger al_n) => ret (Z.to_nat al_n) - | Some (CoqCtype.AlignType al_ty) => alignof fuel (Some tagDefs) al_ty + | Some (CoqCtype.AlignType al_ty) => alignof fuel tagDefs al_ty end ;; ret (Nat.max al acc) ) @@ -647,12 +646,12 @@ Module Type CheriMemoryImpl '(xs, maxoffset) <- monadic_fold_left (fun '(xs, last_offset) '(membr, (_, align_opt, _, ty)) => - size <- sizeof fuel (Some tagDefs) ty ;; + size <- sizeof fuel tagDefs ty ;; align <- match align_opt with - | None => alignof fuel (Some tagDefs) ty + | None => alignof fuel tagDefs ty | Some (CoqCtype.AlignInteger al_n) => ret (Z.to_nat al_n) - | Some (CoqCtype.AlignType al_ty) => alignof fuel (Some tagDefs) al_ty + | Some (CoqCtype.AlignType al_ty) => alignof fuel tagDefs al_ty end ;; let x_value := Nat.modulo last_offset align in let pad := @@ -667,17 +666,12 @@ Module Type CheriMemoryImpl end with sizeof (fuel: nat) - (maybe_tagDefs : option (SymMap.t CoqCtype.tag_definition)) + (tagDefs : SymMap.t CoqCtype.tag_definition) : CoqCtype.ctype -> serr nat := match fuel with | O => fun _ => raise "sizeof out of fuel" | S fuel => - let tagDefs := - match maybe_tagDefs with - | Some x => x - | None => TD.tagDefs tt - end in fun (function_parameter : CoqCtype.ctype) => let '(CoqCtype.Ctype _ ty) as cty := function_parameter in match ty with @@ -691,15 +685,15 @@ Module Type CheriMemoryImpl option2serr "sizeof_fty not defined in Implementation" (IMP.get.(sizeof_fty) fty) | CoqCtype.Array elem_ty (Some asize) => sassert (Nat.ltb 0 asize) "Zero array size encountered" ;; - sz <- sizeof fuel (Some tagDefs) elem_ty ;; + sz <- sizeof fuel tagDefs elem_ty ;; ret (asize * sz)%nat | CoqCtype.Pointer _ _ => ret (IMP.get.(sizeof_pointer)) | CoqCtype.Atomic atom_ty => - sizeof fuel (Some tagDefs) atom_ty + sizeof fuel tagDefs atom_ty | CoqCtype.Struct tag_sym => '(_, max_offset) <- offsetsof_struct fuel tagDefs tag_sym ;; - align <- alignof fuel (Some tagDefs) cty ;; + align <- alignof fuel tagDefs cty ;; let x_value := Nat.modulo max_offset align in ret (if Nat.eqb x_value 0%nat then max_offset @@ -713,11 +707,11 @@ Module Type CheriMemoryImpl '(max_size, max_align) <- monadic_fold_left (fun '(acc_size, acc_align) '(_, (_, align_opt, _, ty)) => - sz <- sizeof fuel (Some tagDefs) ty ;; + sz <- sizeof fuel tagDefs ty ;; al <- match align_opt with - | None => alignof fuel (Some tagDefs) ty + | None => alignof fuel tagDefs ty | Some (CoqCtype.AlignInteger al_n) => ret (Z.to_nat al_n) - | Some (CoqCtype.AlignType al_ty) => alignof fuel (Some tagDefs) al_ty + | Some (CoqCtype.AlignType al_ty) => alignof fuel tagDefs al_ty end ;; ret (Nat.max acc_size sz, Nat.max acc_align al) ) @@ -878,6 +872,7 @@ Module Type CheriMemoryImpl Fixpoint repr (fuel: nat) + (tagDefs: SymMap.t CoqCtype.tag_definition) (addr : AddressValue.t) (mval : mem_value) (s: mem_state) @@ -888,7 +883,7 @@ Module Type CheriMemoryImpl | S fuel => match mval with | MVunspecified ty => - sz <- sizeof DEFAULT_FUEL None ty ;; + sz <- sizeof DEFAULT_FUEL tagDefs ty ;; sassert ((AddressValue.to_Z addr + (Z.of_nat sz)) <=? AddressValue.ADDR_LIMIT) "The object does not fit in the address space" ;; let bs := List.repeat None sz in ret (mem_state_with_bytemap_capmeta @@ -899,7 +894,7 @@ Module Type CheriMemoryImpl AddressValue.with_offset addr (Z.of_nat sz)) | MVinteger ity (IV ivalue) => iss <- option2serr "Could not get int signedness of a type in repr" (is_signed_ity DEFAULT_FUEL ity) ;; - sz <- sizeof DEFAULT_FUEL None (CoqCtype.Ctype [] (CoqCtype.Basic (CoqCtype.Integer ity))) ;; + sz <- sizeof DEFAULT_FUEL tagDefs (CoqCtype.Ctype [] (CoqCtype.Basic (CoqCtype.Integer ity))) ;; bs' <- bytes_of_Z iss sz ivalue ;; let bs := List.map (Some) bs' in sassert (AddressValue.to_Z addr + (Z.of_nat (length bs)) <=? AddressValue.ADDR_LIMIT) "The object does not fit in the address space" ;; @@ -934,7 +929,7 @@ Module Type CheriMemoryImpl raise "invalid integer value (capability for non-(u)intptr_t" end | MVfloating fty fval => - sz <- sizeof DEFAULT_FUEL None (CoqCtype.Ctype [] (CoqCtype.Basic (CoqCtype.Floating fty))) ;; + sz <- sizeof DEFAULT_FUEL tagDefs (CoqCtype.Ctype [] (CoqCtype.Basic (CoqCtype.Floating fty))) ;; sassert (AddressValue.to_Z addr + (Z.of_nat sz) <=? AddressValue.ADDR_LIMIT) "The object does not fit in the address space" ;; bs' <- bytes_of_Z true sz (bits_of_float fval) ;; let bs := List.map (Some) bs' in @@ -981,21 +976,21 @@ Module Type CheriMemoryImpl end | MVarray mvals => monadic_fold_left - (fun '(s', addr') (mval': mem_value) => repr fuel addr' mval' s') + (fun '(s', addr') (mval': mem_value) => repr fuel tagDefs addr' mval' s') mvals (s, addr) | MVunion tag_sym _ mval => - sz <- sizeof DEFAULT_FUEL None (CoqCtype.Ctype [] (CoqCtype.Union tag_sym)) ;; + sz <- sizeof DEFAULT_FUEL tagDefs (CoqCtype.Ctype [] (CoqCtype.Union tag_sym)) ;; sassert (AddressValue.to_Z addr + (Z.of_nat sz) <=? AddressValue.ADDR_LIMIT) "The object does not fit in the address space" ;; - '(s', pad_addr) <- repr fuel addr mval s ;; + '(s', pad_addr) <- repr fuel tagDefs addr mval s ;; let obj_sz := Z.to_nat (AddressValue.to_Z pad_addr - AddressValue.to_Z addr) in sassert (obj_sz <=? sz)%nat "Union member is larger that the union" ;; let pad_size := Nat.sub sz obj_sz in let s'' := do_pad pad_addr pad_size s' in ret (s'', AddressValue.with_offset pad_addr (Z.of_nat pad_size)) | MVstruct tag_sym xs => - struct_typecheck tag_sym (TD.tagDefs tt) xs ;; - sz <- sizeof DEFAULT_FUEL None (CoqCtype.Ctype [] (CoqCtype.Struct tag_sym)) ;; - '(offs, final_off) <- offsetsof_struct DEFAULT_FUEL (TD.tagDefs tt) tag_sym ;; + struct_typecheck tag_sym tagDefs xs ;; + sz <- sizeof DEFAULT_FUEL tagDefs (CoqCtype.Ctype [] (CoqCtype.Struct tag_sym)) ;; + '(offs, final_off) <- offsetsof_struct DEFAULT_FUEL tagDefs tag_sym ;; '(s', final_pad_addr) <- monadic_fold_left2 (fun '(s0, addr0) '(ident, ty, off) '(_, _, mval) => @@ -1005,7 +1000,7 @@ Module Type CheriMemoryImpl sassert ((AddressValue.to_Z addr0 + pad_size) <=? AddressValue.ADDR_LIMIT) "struct member padding does not fit in the address space" ;; let s1 := do_pad addr0 (Z.to_nat pad_size) s0 in (* write the value *) - '(s2, end_addr) <- repr fuel value_a mval s1 ;; + '(s2, end_addr) <- repr fuel tagDefs value_a mval s1 ;; ret (s2, end_addr)) (s, addr) offs xs ;; @@ -1053,7 +1048,8 @@ Module Type CheriMemoryImpl if align_n <=? 0 then raise (InternalErr "non-positive aligment passed to allocate_object") else - size_n <- serr2InternalErr (sizeof DEFAULT_FUEL None ty) ;; + st <- get ;; + size_n <- serr2InternalErr (sizeof DEFAULT_FUEL st.(tagDefs) ty) ;; let size_z := Z.of_nat size_n in let mask := C.representable_alignment_mask size_z in let size_z' := C.representable_length size_z in @@ -1133,6 +1129,7 @@ Module Type CheriMemoryImpl next_varargs_id := st.(next_varargs_id); bytemap := st.(bytemap); capmeta := st.(capmeta); + tagDefs := st.(tagDefs); |}). Definition get_allocation_opt (alloc_id : Z) : memM (option allocation) := @@ -1163,6 +1160,7 @@ Module Type CheriMemoryImpl Fixpoint abst (fuel: nat) + (tagDefs: SymMap.t CoqCtype.tag_definition) (funptrmap : ZMap.M.t (digest * string * C.t)) (tag_query_f : AddressValue.t -> (bool* CapGhostState)) (addr : AddressValue.t) @@ -1174,8 +1172,8 @@ Module Type CheriMemoryImpl | O => raise "abst out of fuel" | S fuel => let '(CoqCtype.Ctype _ ty) := cty in - let self f := abst f funptrmap tag_query_f in - sz <- sizeof DEFAULT_FUEL None cty ;; + let self f := abst f tagDefs funptrmap tag_query_f in + sz <- sizeof DEFAULT_FUEL tagDefs cty ;; sassert (negb (Nat.ltb (List.length bs) sz)) "abst, |bs| < sizeof(ty)" ;; match ty with | (CoqCtype.Void | CoqCtype.Array _ None | @@ -1185,7 +1183,7 @@ Module Type CheriMemoryImpl | (CoqCtype.Basic (CoqCtype.Integer ((CoqIntegerType.Signed CoqIntegerType.Intptr_t) as ity)) | CoqCtype.Basic (CoqCtype.Integer ((CoqIntegerType.Unsigned CoqIntegerType.Intptr_t) as ity))) => - sz <- sizeof DEFAULT_FUEL None cty ;; + sz <- sizeof DEFAULT_FUEL tagDefs cty ;; let '(bs1, bs2) := split_at sz bs in iss <- option2serr "Could not get signedness of a type" (is_signed_ity DEFAULT_FUEL ity) ;; let _:bool := iss in (* hack to hint type checker *) @@ -1208,7 +1206,7 @@ Module Type CheriMemoryImpl | None => ret (MVEunspecified cty, bs) end | CoqCtype.Basic (CoqCtype.Floating fty) => - sz <- sizeof DEFAULT_FUEL None cty ;; + sz <- sizeof DEFAULT_FUEL tagDefs cty ;; let '(bs1, bs2) := split_at sz bs in match extract_unspec bs1 with | Some cs => @@ -1217,7 +1215,7 @@ Module Type CheriMemoryImpl | None => ret (MVEunspecified cty, bs2) end | CoqCtype.Basic (CoqCtype.Integer ity) => - sz <- sizeof DEFAULT_FUEL None cty ;; + sz <- sizeof DEFAULT_FUEL tagDefs cty ;; let '(bs1, bs2) := split_at sz bs in iss <- option2serr "Could not get signedness of a type" (is_signed_ity DEFAULT_FUEL ity) ;; match extract_unspec bs1 with @@ -1234,7 +1232,7 @@ Module Type CheriMemoryImpl match n_value with | O => ret ((MVEarray (List.rev mval_acc)), cs) | S n_value => - sz <- sizeof DEFAULT_FUEL None elem_ty ;; + sz <- sizeof DEFAULT_FUEL tagDefs elem_ty ;; let el_addr := AddressValue.with_offset addr (Z.of_nat (n_value * sz)%nat) in '(mval, cs') <- self fuel el_addr elem_ty cs ;; aux n_value (mval::mval_acc) cs' @@ -1242,7 +1240,7 @@ Module Type CheriMemoryImpl in aux n_value [] bs | CoqCtype.Pointer _ ref_ty => - sz <- sizeof DEFAULT_FUEL None cty ;; + sz <- sizeof DEFAULT_FUEL tagDefs cty ;; let '(bs1, bs2) := split_at sz bs in match extract_unspec bs1 with | Some cs => @@ -1280,8 +1278,8 @@ Module Type CheriMemoryImpl | CoqCtype.Atomic atom_ty => self fuel addr atom_ty bs | CoqCtype.Struct tag_sym => - sz <- sizeof DEFAULT_FUEL None cty ;; - '(offsets,_) <- offsetsof DEFAULT_FUEL (TD.tagDefs tt) tag_sym ;; + sz <- sizeof DEFAULT_FUEL tagDefs cty ;; + '(offsets,_) <- offsetsof DEFAULT_FUEL tagDefs tag_sym ;; let '(bs1, bs2) := split_at sz bs in '(rev_xs, _, bs') <- monadic_fold_left @@ -1290,7 +1288,7 @@ Module Type CheriMemoryImpl let memb_addr := AddressValue.with_offset addr (Z.of_nat memb_offset) in '(mval, acc_bs') <- self fuel memb_addr memb_ty (List.skipn pad acc_bs) ;; - sz <- sizeof DEFAULT_FUEL None memb_ty ;; + sz <- sizeof DEFAULT_FUEL tagDefs memb_ty ;; ret ((memb_ident, memb_ty, mval)::acc_xs, (memb_offset + sz)%nat, acc_bs')) offsets @@ -1544,11 +1542,12 @@ Module Type CheriMemoryImpl (MerrCHERI CheriMerrInvalidCap). Definition is_within_bound + (tagDefs: SymMap.t CoqCtype.tag_definition) (alloc_id : Z.t) (lvalue_ty : CoqCtype.ctype) (addr : Z) : memM bool := - szn <- serr2InternalErr (sizeof DEFAULT_FUEL None lvalue_ty) ;; + szn <- serr2InternalErr (sizeof DEFAULT_FUEL tagDefs lvalue_ty) ;; let sz := Z.of_nat szn in get_allocation alloc_id >>= (fun (alloc : allocation) => @@ -1558,12 +1557,13 @@ Module Type CheriMemoryImpl AddressValue.to_Z alloc.(base) + Z.of_nat alloc.(size)))). Definition is_atomic_member_access + (tagDefs: SymMap.t CoqCtype.tag_definition) (alloc_id : Z.t) (lvalue_ty : CoqCtype.ctype) (addr : Z.t) : memM bool := - szn <- serr2InternalErr (sizeof DEFAULT_FUEL None lvalue_ty) ;; + szn <- serr2InternalErr (sizeof DEFAULT_FUEL tagDefs lvalue_ty) ;; let sz := Z.of_nat szn in get_allocation alloc_id >>= (fun (alloc : allocation) => @@ -1619,10 +1619,10 @@ Module Type CheriMemoryImpl bounds_unspecified := false |}) in '(mval, bs') <- - serr2InternalErr (abst DEFAULT_FUEL st.(funptrmap) tag_query addr ty bs) + serr2InternalErr (abst DEFAULT_FUEL st.(tagDefs) st.(funptrmap) tag_query addr ty bs) ;; mval <- mem_value_strip_err loc mval ;; - szn <- serr2InternalErr (sizeof DEFAULT_FUEL None ty) ;; + szn <- serr2InternalErr (sizeof DEFAULT_FUEL st.(tagDefs) ty) ;; let fp := FP Read addr szn in match bs' with | [] => @@ -1657,13 +1657,14 @@ Module Type CheriMemoryImpl then fail loc (MerrAccess LoadAccess DeadPtr) else ret tt) ;; - inbounds <- is_within_bound alloc_id ty (cap_to_Z c) ;; + st <- get ;; + inbounds <- is_within_bound st.(tagDefs) alloc_id ty (cap_to_Z c) ;; if inbounds then - atomic <- is_atomic_member_access alloc_id ty (cap_to_Z c) ;; + atomic <- is_atomic_member_access st.(tagDefs) alloc_id ty (cap_to_Z c) ;; if atomic then fail loc (MerrAccess LoadAccess AtomicMemberof) else - (sz <- serr2InternalErr (sizeof DEFAULT_FUEL None ty) ;; + (sz <- serr2InternalErr (sizeof DEFAULT_FUEL st.(tagDefs) ty) ;; do_load_cap (Some alloc_id) c sz) else fail loc (MerrAccess LoadAccess OutOfBoundPtr) @@ -1707,13 +1708,13 @@ Module Type CheriMemoryImpl (c_value : C.t) : memM footprint := - szn <- serr2InternalErr (sizeof DEFAULT_FUEL None cty) ;; + s <- get ;; + szn <- serr2InternalErr (sizeof DEFAULT_FUEL s.(tagDefs) cty) ;; let sz := Z.of_nat szn in cap_check loc c_value 0 WriteIntent szn ;; let addr := C.cap_get_value c_value in - s <- get ;; - '(s',_) <- serr2InternalErr (repr DEFAULT_FUEL addr mval s) ;; + '(s',_) <- serr2InternalErr (repr DEFAULT_FUEL s.(tagDefs) addr mval s) ;; put s' ;; ret (FP Write addr szn) in @@ -1722,14 +1723,15 @@ Module Type CheriMemoryImpl if cap_is_null c then fail loc (MerrAccess StoreAccess NullPtr) else - inbounds <- is_within_bound alloc_id cty (cap_to_Z c) ;; + st <- get ;; + inbounds <- is_within_bound st.(tagDefs) alloc_id cty (cap_to_Z c) ;; if inbounds then (alloc <- get_allocation alloc_id ;; match alloc.(is_readonly) with | IsReadOnly ro_kind => fail loc (MerrWriteOnReadOnly ro_kind) | IsWritable => - atomic <- is_atomic_member_access alloc_id cty (cap_to_Z c) ;; + atomic <- is_atomic_member_access st.(tagDefs) alloc_id cty (cap_to_Z c) ;; if atomic then fail loc (MerrAccess LoadAccess AtomicMemberof) else @@ -1965,7 +1967,8 @@ Module Type CheriMemoryImpl | CoqCtype.Ctype _ (CoqCtype.Array elem_ty _) => elem_ty | _ => diff_ty end in - sz <- serr2InternalErr (sizeof DEFAULT_FUEL None diff_ty') ;; + st <- get ;; + sz <- serr2InternalErr (sizeof DEFAULT_FUEL st.(tagDefs) diff_ty') ;; ret (IV (Z.div (addr1 - addr2) (Z.of_nat sz))) in @@ -2032,7 +2035,7 @@ Module Type CheriMemoryImpl ret (Some (CoqSymbol.string_of_prefix alloc.(prefix) ++ " + " ++ String.dec_str offset)) | Some (CoqCtype.Ctype _ (CoqCtype.Struct tag_sym)) => (* TODO: nested structs *) let offset := Z.sub addr alloc.(base) in - '(offs, _) <- serr2InternalErr (offsetsof DEFAULT_FUEL (TD.tagDefs tt) tag_sym) ;; + '(offs, _) <- serr2InternalErr (offsetsof DEFAULT_FUEL tagDefs tag_sym) ;; let fix find y := match y with | [] => None @@ -2046,7 +2049,7 @@ Module Type CheriMemoryImpl | Some (CoqCtype.Ctype _ (CoqCtype.Array ty _)) => let offset := Z.sub addr alloc.(base) in if offset - sz <- serr2InternalErr (alignof DEFAULT_FUEL None ref_ty) ;; + st <- get ;; + sz <- serr2InternalErr (alignof DEFAULT_FUEL st.(tagDefs) ref_ty) ;; ret ((cap_to_Z addr) mod (Z.of_nat sz) =? 0) end end. @@ -2393,13 +2397,13 @@ Module Type CheriMemoryImpl Definition null_cap (is_signed : bool) : integer_value := IC is_signed (C.cap_c0 tt). - Definition array_shift_ptrval: pointer_value -> CoqCtype.ctype -> integer_value -> + Definition array_shift_ptrval: SymMap.t CoqCtype.tag_definition -> location_ocaml -> pointer_value -> CoqCtype.ctype -> integer_value -> serr pointer_value - := fun _ _ _ => raise "pure array_shift_ptrval not used in CHERI". + := fun _ _ _ _ _ => raise "pure array_shift_ptrval not used in CHERI". - Definition member_shift_ptrval: pointer_value -> CoqSymbol.sym -> + Definition member_shift_ptrval: SymMap.t CoqCtype.tag_definition -> pointer_value -> CoqSymbol.sym -> CoqSymbol.identifier -> serr pointer_value - := fun _ _ _ => raise "members_shift_ptrval (pure) is not supported in CHERI". + := fun _ _ _ _ => raise "members_shift_ptrval (pure) is not supported in CHERI". Definition eff_array_shift_ptrval (loc : location_ocaml) @@ -2408,8 +2412,9 @@ Module Type CheriMemoryImpl (ival_int : integer_value) : memM pointer_value := + st <- get ;; let ival := num_of_int ival_int in - szn <- serr2InternalErr (sizeof DEFAULT_FUEL None ty) ;; + szn <- serr2InternalErr (sizeof DEFAULT_FUEL st.(tagDefs) ty) ;; let sz := Z.of_nat szn in let offset := Z.mul sz ival in @@ -2460,7 +2465,8 @@ Module Type CheriMemoryImpl (tag_sym: CoqSymbol.sym) (memb_ident: CoqSymbol.identifier): memM pointer_value := - ioff <- serr2InternalErr (offsetof_ival (TD.tagDefs tt) tag_sym memb_ident) ;; + st <- get ;; + ioff <- serr2InternalErr (offsetof_ival st.(tagDefs) tag_sym memb_ident) ;; offset <- match ioff with | IV offset => ret (offset) @@ -2692,6 +2698,7 @@ Module Type CheriMemoryImpl ret dst_p. Definition memcmp + (loc : location_ocaml) (ptrval1 ptrval2 : pointer_value) (size_int : integer_value) : memM integer_value @@ -2898,16 +2905,6 @@ Module Type CheriMemoryImpl | IntExp => int_bin Z.pow v1 v2 end. - Definition sizeof_ival (ty : CoqCtype.ctype): serr integer_value - := - sz <- sizeof DEFAULT_FUEL None ty ;; - ret (IV (Z.of_nat sz)). - - Definition alignof_ival (ty: CoqCtype.ctype): serr integer_value - := - a <- alignof DEFAULT_FUEL None ty ;; - ret (IV (Z.of_nat a)). - Definition bitwise_complement_ival (ty : CoqIntegerType.integerType) (v : integer_value) : integer_value @@ -3253,7 +3250,8 @@ Module Type CheriMemoryImpl | MVinteger (CoqIntegerType.Size_t as ity) (IV z_value) => iss <- option2memM "is_signed_ity failed" (is_signed_ity DEFAULT_FUEL ity) ;; - sz <- serr2InternalErr (sizeof DEFAULT_FUEL None (CoqCtype.Ctype [](CoqCtype.Basic (CoqCtype.Integer ity)))) ;; + st <- get ;; + sz <- serr2InternalErr (sizeof DEFAULT_FUEL st.(tagDefs) (CoqCtype.Ctype [](CoqCtype.Basic (CoqCtype.Integer ity)))) ;; bytes_value <- serr2InternalErr (bytes_of_Z iss sz z_value) ;; let bits := List.rev (bool_bits_of_bytes bytes_value) in let bits := list.take (BinNat.N.to_nat Permissions.len) bits in @@ -3759,10 +3757,9 @@ Module CheriMemoryExe (Bounds) (Permissions) Capability_GS) - (TD: TagDefs) (SW: CerbSwitchesDefs) -<: CheriMemoryImpl(MC)(C)(IMP)(TD)(SW). +<: CheriMemoryImpl(MC)(C)(IMP)(SW). - Include CheriMemoryImpl(MC)(C)(IMP)(TD)(SW). + Include CheriMemoryImpl(MC)(C)(IMP)(SW). End CheriMemoryExe. diff --git a/coq/CheriMemory/CoqSwitches.v b/coq/CheriMemory/CoqSwitches.v index 2f329e005..1504ed9b6 100644 --- a/coq/CheriMemory/CoqSwitches.v +++ b/coq/CheriMemory/CoqSwitches.v @@ -24,7 +24,9 @@ Inductive cerb_switch : Set := | SW_zero_initialised : cerb_switch | SW_revocation: SW_revocation_values -> cerb_switch | SW_at_magic_comments : cerb_switch -| SW_magic_comment_char_dollar: cerb_switch. +| SW_magic_comment_char_dollar: cerb_switch +| SW_copy_prop: cerb_switch +| SW_branching_on_unspec_is_nd: cerb_switch. Lemma SW_pointer_arith_values_dec: forall x y:SW_pointer_arith_values, {x = y} + {x <> y}. Proof. decide equality. Qed. diff --git a/coq/CheriMemory/Memory_model.v b/coq/CheriMemory/Memory_model.v index 2d5bda363..356bbbaf4 100644 --- a/coq/CheriMemory/Memory_model.v +++ b/coq/CheriMemory/Memory_model.v @@ -39,7 +39,7 @@ Module Type Memory (A:PTRADDR) (B:PTRADDR_INTERVAL A) (MC:Mem_common(A)(B)). Parameter footprint : Set. Parameter overlapping : footprint -> footprint -> bool. Parameter mem_state : Type. - Parameter initial_mem_state : mem_state. + Parameter initial_mem_state : SymMap.t CoqCtype.tag_definition -> mem_state. Parameter memM: Type -> Type. #[local] Declare Instance memM_monad: Monad memM. @@ -114,10 +114,12 @@ Module Type Memory (A:PTRADDR) (B:PTRADDR_INTERVAL A) (MC:Mem_common(A)(B)). Parameter null_cap : bool -> integer_value. Parameter array_shift_ptrval : - pointer_value -> CoqCtype.ctype -> integer_value -> + SymMap.t CoqCtype.tag_definition -> + location_ocaml -> pointer_value -> CoqCtype.ctype -> integer_value -> serr pointer_value. Parameter member_shift_ptrval : + SymMap.t CoqCtype.tag_definition -> pointer_value -> CoqSymbol.sym -> CoqSymbol.identifier -> serr pointer_value. @@ -133,7 +135,7 @@ Module Type Memory (A:PTRADDR) (B:PTRADDR_INTERVAL A) (MC:Mem_common(A)(B)). location_ocaml -> pointer_value -> pointer_value -> integer_value -> memM pointer_value. Parameter memcmp : - pointer_value -> pointer_value -> integer_value -> memM integer_value. + location_ocaml -> pointer_value -> pointer_value -> integer_value -> memM integer_value. Parameter realloc : location_ocaml -> @@ -166,8 +168,6 @@ Module Type Memory (A:PTRADDR) (B:PTRADDR_INTERVAL A) (MC:Mem_common(A)(B)). CoqSymbol.sym -> CoqSymbol.identifier -> serr integer_value. - Parameter sizeof_ival : CoqCtype.ctype -> serr integer_value. - Parameter alignof_ival : CoqCtype.ctype -> serr integer_value. Parameter bitwise_complement_ival : CoqIntegerType.integerType -> integer_value -> integer_value. Parameter bitwise_and_ival : diff --git a/coq/CheriMemory/dune b/coq/CheriMemory/dune index c9295a918..e5c2c9ad6 100644 --- a/coq/CheriMemory/dune +++ b/coq/CheriMemory/dune @@ -2,6 +2,6 @@ (mode vo) (name CheriMemory) (package cerberus-cheri) - (modules CoqLocation CoqIntegerType CoqAnnot CoqCtype CoqSwitches CoqImplementation CoqAilSyntax CoqAilTypesAux ErrorWithState CoqMem_common Memory_model CoqSymbol CoqUndefined CoqTags CheriMorelloMemory CerbSwitches) + (modules CoqLocation CoqIntegerType CoqAnnot CoqCtype CoqSwitches CoqImplementation CoqAilSyntax CoqAilTypesAux ErrorWithState CoqMem_common Memory_model CoqSymbol CoqUndefined CheriMorelloMemory CerbSwitches) (theories Common Morello) ) diff --git a/coq/Proofs/Revocation.v b/coq/Proofs/Revocation.v index c8e0f2133..81347906f 100644 --- a/coq/Proofs/Revocation.v +++ b/coq/Proofs/Revocation.v @@ -36,7 +36,7 @@ From CheriCaps.Common Require Import Capabilities. From Common Require Import SimpleError Utils ZMap AMap FMapExt. From Morello Require Import CapabilitiesGS MorelloCapsGS. -From CheriMemory Require Import CheriMorelloMemory Memory_model CoqMem_common ErrorWithState CoqUndefined ErrorWithState CoqLocation CoqSymbol CoqImplementation CoqTags CoqSwitches CerbSwitches CoqAilTypesAux. +From CheriMemory Require Import CheriMorelloMemory Memory_model CoqMem_common ErrorWithState CoqUndefined ErrorWithState CoqLocation CoqSymbol CoqImplementation CoqSwitches CerbSwitches CoqAilTypesAux. Require Import Tactics. @@ -60,10 +60,6 @@ Require Import ListSet. Module ZMapProofs:= FMapExtProofs(Z_as_ExtOT)(ZMap). Module AMapProofs:= FMapExtProofs(AddressValue_as_ExtOT)(AMap). -Module AbstTagDefs: TagDefs. - Definition tagDefs := abst_tagDefs. -End AbstTagDefs. - (* Morello-specific *) Fact ADDR_LIMIT_to_Z: AddressValue.to_Z (AddressValue.of_Z AddressValue.ADDR_LIMIT) = 0. @@ -233,8 +229,8 @@ End CHERISwitchesExe. Module CheriMemoryImplWithProofs <: - CheriMemoryImpl(MemCommonExe)(Capability_GS)(MorelloImpl)(AbstTagDefs)(CHERISwitchesExe). - Include CheriMemoryExe(MemCommonExe)(Capability_GS)(MorelloImpl)(AbstTagDefs)(CHERISwitchesExe). + CheriMemoryImpl(MemCommonExe)(Capability_GS)(MorelloImpl)(CHERISwitchesExe). + Include CheriMemoryExe(MemCommonExe)(Capability_GS)(MorelloImpl)(CHERISwitchesExe). (* --- Equality predicates for types used in Memory Models --- *) @@ -2739,8 +2735,9 @@ Module CheriMemoryImplWithProofs ). Lemma initial_mem_state_invariant: - mem_invariant initial_mem_state. + forall tagDefs, mem_invariant (initial_mem_state tagDefs). Proof. + intro tagDefs. unfold initial_mem_state, mem_invariant. repeat split; cbn in *. - @@ -3775,17 +3772,17 @@ Module CheriMemoryImplWithProofs Qed. Instance is_within_bound_SameState: - forall x0 x1 x2, SameState (is_within_bound x0 x1 x2). + forall tagDefs x0 x1 x2, SameState (is_within_bound tagDefs x0 x1 x2). Proof. - intros x0 x1 x2. + intros tagDefs x0 x1 x2. unfold is_within_bound. same_state_steps. Qed. Instance is_atomic_member_access_SameState: - forall x0 x1 x2, SameState (is_atomic_member_access x0 x1 x2). + forall tagDefs x0 x1 x2, SameState (is_atomic_member_access tagDefs x0 x1 x2). Proof. - intros x0 x1 x2. + intros tagDefs x0 x1 x2. unfold is_atomic_member_access. same_state_steps. Qed. @@ -4244,6 +4241,7 @@ Module CheriMemoryImplWithProofs break_if;[preserves_step|]. preserves_step. preserves_step. + preserves_step. break_match_goal;[preserves_step|]. preserves_step. apply allocator_PreservesInvariant. @@ -4547,9 +4545,9 @@ Module CheriMemoryImplWithProofs unfold store in H. state_inv_steps. - rewrite MorelloImpl.uchar_size in H6, H11. + rewrite MorelloImpl.uchar_size in H6, H12. invc H6. - invc H11. + invc H12. cbn. apply AMap.M.add_1. reflexivity. @@ -4843,8 +4841,8 @@ Module CheriMemoryImplWithProofs Qed. Lemma sizeof_pos: - forall fuel szn maybe_tagDefs ty, - sizeof fuel maybe_tagDefs ty = inr szn -> (0 < szn)%nat + forall fuel szn tagDefs ty, + sizeof fuel tagDefs ty = inr szn -> (0 < szn)%nat with offsetof_struct_max_offset_pos: @@ -4855,11 +4853,11 @@ Module CheriMemoryImplWithProofs clear sizeof_pos. induction fuel as [| fuel' IHfuel] using nat_ind. + (* Base case: fuel = 0 *) - intros szn maybe_tagDefs ty H. + intros szn tagDefs ty H. simpl in H. discriminate. + - intros szn maybe_tagDefs ty H. + intros szn tagDefs ty H. simpl in H. destruct ty as [a cty]. @@ -4896,10 +4894,7 @@ Module CheriMemoryImplWithProofs assumption. * (* struct *) - generalize dependent (match maybe_tagDefs with - | Some x => x - | None => AbstTagDefs.tagDefs tt - end); intros. + generalize dependent tagDefs; intros. clear H1. @@ -4913,10 +4908,7 @@ Module CheriMemoryImplWithProofs state_inv_steps;bool_to_prop_hyp; try congruence;lia. * (* Union *) - generalize dependent (match maybe_tagDefs with - | Some x => x - | None => AbstTagDefs.tagDefs tt - end); intros. + generalize dependent tagDefs; intros. clear H1. break_match_hyp;[|inv H]. @@ -4937,7 +4929,7 @@ Module CheriMemoryImplWithProofs clear H3. (* proof by induction on [l] *) - revert t0 Heqt1. + revert t Heqt0. induction l;intros. ++ invc H. @@ -4946,12 +4938,12 @@ Module CheriMemoryImplWithProofs clear H. repeat break_let. remember (fun '(acc_size, acc_align) '(_, (_, align_opt, _, ty)) => - sz <- sizeof fuel' (Some t) ty;; + sz <- sizeof fuel' tagDefs0 ty;; al <- match align_opt with | Some (CoqCtype.AlignInteger al_n) => ret (Z.to_nat al_n) - | Some (CoqCtype.AlignType al_ty) => alignof fuel' (Some t) al_ty - | None => alignof fuel' (Some t) ty + | Some (CoqCtype.AlignType al_ty) => alignof fuel' tagDefs0 al_ty + | None => alignof fuel' tagDefs0 ty end;; ret (Nat.max acc_size sz, Nat.max acc_align al)) as f. assert (f_mon : forall sz sz' al al' a, @@ -5747,14 +5739,15 @@ Module CheriMemoryImplWithProofs (fun mval : mem_value_indt => forall s s' : mem_state_r, mem_invariant s -> - forall (addr addr' : AddressValue.t) (fuel : nat), - repr fuel addr mval s = inr (s', addr') -> mem_invariant s') l) + forall (addr addr' : AddressValue.t) (fuel : nat) (tagDefs: SymMap.t CoqCtype.tag_definition), + repr fuel tagDefs addr mval s = inr (s', addr') -> mem_invariant s') l) (s s' : mem_state_r) (M: mem_invariant s) (addr addr': AddressValue.t) - (fuel: nat): - repr fuel addr (MVarray l) s = inr (s', addr') -> mem_invariant s'. + (fuel: nat) + (tagDefs: SymMap.t CoqCtype.tag_definition): + repr fuel tagDefs addr (MVarray l) s = inr (s', addr') -> mem_invariant s'. Proof. intros R. destruct fuel;[apply raise_either_inr_inv in R;tauto|]. @@ -5794,9 +5787,10 @@ Module CheriMemoryImplWithProofs (offs : list (identifier * CoqCtype.ctype * nat)) (sym: CoqSymbol.sym) (fuel max_offset: nat) + (tagDefs: SymMap.t CoqCtype.tag_definition) : - struct_typecheck sym (AbstTagDefs.tagDefs tt) values = inr tt -> - offsetsof_struct fuel (AbstTagDefs.tagDefs tt) sym = inr (offs, max_offset) -> + struct_typecheck sym tagDefs values = inr tt -> + offsetsof_struct fuel tagDefs sym = inr (offs, max_offset) -> Datatypes.length offs = Datatypes.length values. Proof. intros HT HO. @@ -5910,13 +5904,14 @@ Module CheriMemoryImplWithProofs (fun '(_, _, b) => forall s s' : mem_state_r, mem_invariant s -> - forall (addr addr' : AddressValue.t) (fuel : nat), - repr fuel addr b s = inr (s', addr') -> mem_invariant s') l) + forall (addr addr' : AddressValue.t) (fuel : nat) (tagDefs: SymMap.t CoqCtype.tag_definition), + repr fuel tagDefs addr b s = inr (s', addr') -> mem_invariant s') l) (s s' : mem_state_r) (M: mem_invariant s) (addr addr': AddressValue.t) - (fuel: nat): - repr fuel addr (MVstruct sym l) s = inr (s', addr') -> mem_invariant s'. + (fuel: nat) + (tagDefs: SymMap.t CoqCtype.tag_definition): + repr fuel tagDefs addr (MVstruct sym l) s = inr (s', addr') -> mem_invariant s'. Proof. intros R. destruct fuel;[apply raise_either_inr_inv in R;tauto|]. @@ -5926,7 +5921,7 @@ Module CheriMemoryImplWithProofs destruct x. rename l0 into offs, l into values. - apply (offsetsof_struct_length _ _ _ _ _ R2) in R3. + apply (offsetsof_struct_length _ _ _ _ _ _ R2) in R3. clear R2. rename R3 into L. apply do_pad_preserves. @@ -5989,18 +5984,19 @@ Module CheriMemoryImplWithProofs Lemma repr_preserves (fuel : nat) + (tagDefs: SymMap.t CoqCtype.tag_definition) (mval: mem_value) (s s': mem_state_r) (M: mem_invariant s) (addr addr': AddressValue.t): - repr fuel addr mval s = inr (s', addr') + repr fuel tagDefs addr mval s = inr (s', addr') -> mem_invariant s'. Proof. Opaque sizeof. - revert fuel. - dependent induction mval;intros fuel R. + revert fuel tagDefs. + dependent induction mval;intros fuel tagDefs R. - (* MVunspecified *) destruct fuel;[apply raise_either_inr_inv in R;tauto|]. unfold repr in R. @@ -6125,6 +6121,7 @@ Module CheriMemoryImplWithProofs break_let. break_if;[preserves_step|]. preserves_step. + preserves_step. apply SameStatePreserves, is_within_bound_SameState. break_if;[|preserves_step]. preserves_step. @@ -6135,9 +6132,13 @@ Module CheriMemoryImplWithProofs break_if;[preserves_step|]. preserves_step. - - preserves_step;[preserves_step|]. - preserves_step;[apply SameStatePreserves, cap_check_SameState|]. preserves_step. + apply bind_PreservesInvariant_same_state. + typeclasses eauto. + intros szn. + apply bind_PreservesInvariant_same_state. + typeclasses eauto. + intros u. apply bind_PreservesInvariant_value_SameState. typeclasses eauto. intros H x6 H0. @@ -6145,8 +6146,6 @@ Module CheriMemoryImplWithProofs preserves_step;[|preserves_step]. preserves_step. apply serr2InternalErr_inv in H0. - destruct x5. - subst. apply repr_preserves in H0;eauto. - (* handling `is_locking` *) diff --git a/coq/dune b/coq/dune index 9e8cfb0d4..dbe5fd48f 100644 --- a/coq/dune +++ b/coq/dune @@ -126,7 +126,6 @@ (copy_files extracted/Sumbool.{ml,mli}) (copy_files extracted/CoqSwitches.{ml,mli}) (copy_files extracted/CoqSymbol.{ml,mli}) -(copy_files extracted/CoqTags.{ml,mli}) (copy_files extracted/TypeCasts.{ml,mli}) (copy_files extracted/Traversable.{ml,mli}) (copy_files extracted/CoqUndefined.{ml,mli}) diff --git a/coq/extracted/dune b/coq/extracted/dune index e6fd2e89b..08bd2e2e3 100644 --- a/coq/extracted/dune +++ b/coq/extracted/dune @@ -1,6 +1,6 @@ (coq.extraction (mode vo) (prelude Extract) - (extracted_modules Addr BinaryString Capabilities Capabilities0 CapabilitiesGS CoqAilSyntax CoqAnnot Applicative Ascii BinInt BinList BinNat BinNatDef BinNums BinPos BinPosDef bitvector Compare_dec Qcanon Relation_Definitions Bool0 Byte CapFns CapFnsTypes CarryType CheriMorelloMemory ClassicalDedekindReals CMorphisms ConstructiveCauchyAbs ConstructiveCauchyReals ConstructiveCauchyRealsMult ConstructiveEpsilon ConstructiveExtra ConstructiveRcomplete ConstructiveReals CRelationClasses CoqIntegerType CoqCtype Datatypes DecidableClass DecidableType Decimal EitherMonad Eqdep_dec Equalities EquivDec ErrorWithState Fin FloatClass FMapAVL0 FMapFacts0 FMapList FMapInterface Functor Hexadecimal HexString CoqImplementation Init Injection Instr_kinds Int0 List0 List1 ListSet CoqLocation Logic Monad0 MonadExc MonadFix MonadPlus MonadReader MonadState MonadTrans MonadWriter MonadZero Monoid MorelloCapsGS Nat0 Number Operators_mwords OrderedType0 Orders OrdersTac PeanoNat PrimFloat PrimInt63 Prompt Prompt_monad Qabs QArith_base QExtra Qreduction Qround Rdefinitions RelDec Ring_polynom Ring_theory SimpleError FMapExt AMap ZMap Specif OrderedType0 String0 String1 Sumbool CoqSwitches CoqSymbol CoqTags CerbSwitches Traversable CoqUndefined Undefined Utils Utils0 OptionMonad TypeCasts MachineWord Values Vector0 vector1 VectorDef Wf ZArith_dec Zbool Bvector Zdigits Zeven base0 Basics countable decidable fin0 list2 numbers0 option0 finite list_numbers) + (extracted_modules Addr BinaryString Capabilities Capabilities0 CapabilitiesGS CoqAilSyntax CoqAnnot Applicative Ascii BinInt BinList BinNat BinNatDef BinNums BinPos BinPosDef bitvector Compare_dec Qcanon Relation_Definitions Bool0 Byte CapFns CapFnsTypes CarryType CheriMorelloMemory ClassicalDedekindReals CMorphisms ConstructiveCauchyAbs ConstructiveCauchyReals ConstructiveCauchyRealsMult ConstructiveEpsilon ConstructiveExtra ConstructiveRcomplete ConstructiveReals CRelationClasses CoqIntegerType CoqCtype Datatypes DecidableClass DecidableType Decimal EitherMonad Eqdep_dec Equalities EquivDec ErrorWithState Fin FloatClass FMapAVL0 FMapFacts0 FMapList FMapInterface Functor Hexadecimal HexString CoqImplementation Init Injection Instr_kinds Int0 List0 List1 ListSet CoqLocation Logic Monad0 MonadExc MonadFix MonadPlus MonadReader MonadState MonadTrans MonadWriter MonadZero Monoid MorelloCapsGS Nat0 Number Operators_mwords OrderedType0 Orders OrdersTac PeanoNat PrimFloat PrimInt63 Prompt Prompt_monad Qabs QArith_base QExtra Qreduction Qround Rdefinitions RelDec Ring_polynom Ring_theory SimpleError FMapExt AMap ZMap Specif OrderedType0 String0 String1 Sumbool CoqSwitches CoqSymbol CerbSwitches Traversable CoqUndefined Undefined Utils Utils0 OptionMonad TypeCasts MachineWord Values Vector0 vector1 VectorDef Wf ZArith_dec Zbool Bvector Zdigits Zeven base0 Basics countable decidable fin0 list2 numbers0 option0 finite list_numbers) (theories CheriMemory Common Morello ExtLib stdpp SailStdpp StructTact CheriCaps) ) diff --git a/frontend/model/README.md b/frontend/model/README.md index 59b3933d9..85d20833c 100644 --- a/frontend/model/README.md +++ b/frontend/model/README.md @@ -25,7 +25,6 @@ Classification of the files in model/ * state_exception_undefined.lem * std.lem * symbol.lem -* symbolic.lem * uniqueId.lem * utils.lem diff --git a/frontend/model/cabs_to_ail.lem b/frontend/model/cabs_to_ail.lem index 223650ce7..7ffd74417 100644 --- a/frontend/model/cabs_to_ail.lem +++ b/frontend/model/cabs_to_ail.lem @@ -579,9 +579,12 @@ let constructValue tagDefs elems ty = (* BEGIN predicates on Ail syntax *) (* see §6.6#6 *) -(* TODO: make the function pure, when complete *) -val is_integer_constant_expression: expression unit -> E.desugM bool -let rec is_integer_constant_expression (AnnotatedExpression () _ loc expr_ as expr) = +(* The is_constraint boolean informs whether the expression is specified to be an integer constant + * expression by a Constraint section in standard. If not, "shall" failures from §6.6#6 are to be + * reported as undefined behaviour *) +val is_integer_constant_expression: bool -> expression unit -> E.desugM bool +let rec is_integer_constant_expression is_constraint (AnnotatedExpression () _ loc expr_ as expr) = + let is_integer_constant_expression = is_integer_constant_expression is_constraint in STD_ "§6.6#6" match expr_ with | AilEunary uop e -> match uop with @@ -600,8 +603,33 @@ let rec is_integer_constant_expression (AnnotatedExpression () _ loc expr_ as ex | PostfixDecr -> E.return false end - | AilEcast _ _ _ -> - E.fail loc (Errors.Desugar_NotYetSupported "cast operator in `integer constant expressions'") + | AilEcast _ cast_ty e -> + let do_failure = + if is_constraint then + E.return false + else + E.undef loc Undefined.UB055_invalid_integer_constant_expression in + if not (AilTypesAux.is_integer cast_ty) then + do_failure + else if Global.isAgnostic () then + E.fail loc (Errors.Desugar_agnosticFailure "cast in an integer constant expression") + else + E.get_sigma_sofar >>= fun sigm -> + E.get_gamma_sofar >>= fun gamm -> + match Mini_pipeline.typecheckAil sigm gamm e with + | Left (loc, tcause) -> E.fail_ailtyping loc tcause + | Right ty -> + if not (AilTypesAux.is_arithmetic ty) then + do_failure + else match e with + | AnnotatedExpression () _ _ (AilEconst (ConstantFloating _)) -> + (* STD §6.6#6: "floating constants that are the immediate + * operands of casts" *) + E.return true + | _ -> + is_integer_constant_expression e + end + end | AilEassert _ -> E.return false | AilEoffsetof _ _ -> @@ -919,7 +947,7 @@ let is_address_constant a_expr = | true -> E.return true | false -> - is_integer_constant_expression expr + is_integer_constant_expression false(*not Constraint *) expr end | _ -> E.return false @@ -933,6 +961,7 @@ let is_address_constant a_expr = (* TODO: "or evaluate to" *) val is_initializer_constant_expression_or_string_literal: expression unit -> E.desugM bool let is_initializer_constant_expression_or_string_literal (AnnotatedExpression () _ loc expr as a_expr) = + let is_integer_constant_expression = is_integer_constant_expression false(*not Constraint *) in is_arithmetic_constant_expression false (* TODO check *) a_expr >>= fun b1 -> is_address_constant a_expr >>= fun b2 -> (* STD §6.6#7, bullets 1 - 3 *) @@ -984,8 +1013,12 @@ type fundef = | NotFunDef +(* Builders use an exception monad rather than the desugaring monad. This allows reporting + * constraint violations (currently for invalid element types of arrays) while guaranteeing that + * they never change the desugaring state. This is important to keep dummy instantiations like the + * the one in desugar_and_register_function_definition harmless. *) type qs_ctype_builder = - Ctype.qualifiers -> Ctype.ctype -> (Ctype.qualifiers * Ctype.ctype) + Ctype.qualifiers -> Ctype.ctype -> Exception.exceptM (Ctype.qualifiers * Ctype.ctype) Errors.error val desugar_struct_declaration: @@ -1124,13 +1157,34 @@ let translate_character_constant (pref_opt, str) = -val evaluate_integer_constant_expression: Loc.t -> maybe Ctype.ctype -> expression unit -> E.desugM integer -let evaluate_integer_constant_expression loc ty_opt expr = +val evaluate_integer_constant_expression_aux: Mini_pipeline.eval_mode -> expression unit -> E.desugM integer +let evaluate_integer_constant_expression_aux mode d_expr = E.get_core_eval_stuff >>= fun core_env -> E.get_sigma_sofar >>= fun sigm -> + E.read_config >>= fun conf -> E.liftException - (Mini_pipeline.evalIntegerConstantExpression loc core_env sigm ty_opt expr) - + (Mini_pipeline.evalIntegerConstantExpression conf.E.elab_conf core_env sigm mode d_expr) + +(* If ty_opt is [Just ty], this checks that the value is representable in [ty] *) +val evaluate_integer_constant_expression: maybe Ctype.ctype -> expression unit -> E.desugM integer +let evaluate_integer_constant_expression ty_opt d_expr = + evaluate_integer_constant_expression_aux + match ty_opt with + | Just ty -> Mini_pipeline.Check_representable_in ty + | Nothing -> Mini_pipeline.Own_type + end + d_expr + +(* (STD §6.8.4.2#5, sentence 2) the expression of a case statement is converted to the promoted type + * of the switch's controlling expression. (see the desugaring of CabsSswitch) *) +val evaluate_case_constant_expression: Ctype.ctype -> expression unit -> E.desugM integer +let evaluate_case_constant_expression promoted_ctrl_ty d_expr = + is_integer_constant_expression true(*Constraint requirement *) d_expr >>= function + | false -> + E.constraint_violation (Loc.locOf d_expr) CaseNotIntegerConstantExpression + | true -> + evaluate_integer_constant_expression_aux (Mini_pipeline.Convert_to promoted_ctrl_ty) d_expr + end @@ -1450,13 +1504,13 @@ type under_array = val desugar_array_declarator: - under_array -> array_declarator -> E.desugM (Ctype.qualifiers -> Ctype.ctype -> (Ctype.qualifiers * Ctype.ctype)) + under_array -> array_declarator -> E.desugM qs_ctype_builder val desugar_pointer_declarator: - pointer_declarator -> E.desugM (Ctype.qualifiers -> Ctype.ctype -> (Ctype.qualifiers * Ctype.ctype)) + pointer_declarator -> E.desugM qs_ctype_builder val desugar_abstract_declarator: - under_array -> abstract_declarator -> E.desugM (Ctype.qualifiers -> Ctype.ctype -> (Ctype.qualifiers * Ctype.ctype)) + under_array -> abstract_declarator -> E.desugM qs_ctype_builder val desugar_direct_abstract_declarator: - under_array -> direct_abstract_declarator -> E.desugM (Ctype.qualifiers -> Ctype.ctype -> (Ctype.qualifiers * Ctype.ctype)) + under_array -> direct_abstract_declarator -> E.desugM qs_ctype_builder @@ -1879,18 +1933,28 @@ STD_ "§6.7.6.2#1, sentence 5, not function parameter" $ a size expression *) (* STD §6.7.6.2#4, sentence 3 *) desugar_expression e >>= fun d_e -> - is_integer_constant_expression d_e >>= function + is_integer_constant_expression true(* failure should in term lead to VLA *) d_e >>= function | false -> E.fail loc (Errors.Desugar_NotYetSupported "variable length array type 2") | true -> (* STD §6.7.6.2#1, sentence 2 *) (* NOTE: the preceding STD clause is performed by a typecheck done by [Mini_pipeline.evalIntegerConstantExpression] *) - evaluate_integer_constant_expression loc Nothing d_e >>= fun n -> + evaluate_integer_constant_expression Nothing d_e >>= fun n -> if n <= 0 then E.constraint_violation loc ArrayDeclarationNegativeSize else - E.return (fun qs ty -> perform_adjust qs (Ctype.Ctype [Annot.Aloc loc] (Ctype.Array ty (Just n)))) + E.return (fun qs ty -> + if AilTypesAux.is_function ty then + (* STD §6.7.6.2#1, sentence 4 (only the function check for now (TODO)) *) + Exception.throw + ( loc + , Errors.DESUGAR (Errors.Desugar_ConstraintViolation + ArrayDeclarationFunctionType) ) + else + Exception.except_return + (perform_adjust qs (Ctype.Ctype [Annot.Aloc loc] (Ctype.Array ty (Just n)))) + ) end | Just ADeclSize_asterisk -> @@ -1904,11 +1968,20 @@ STD_ "§6.7.6.2#1, sentence 5, not function parameter" $ | Nothing -> (* here the array declarator: has no size expression *) - E.return (fun qs ty -> perform_adjust qs (Ctype.Ctype [Annot.Aloc loc] (Ctype.Array ty Nothing))) + E.return (fun qs ty -> + if AilTypesAux.is_function ty then + (* STD §6.7.6.2#1, sentence 4 (only the function check for now (TODO)) *) + Exception.throw + ( loc + , Errors.DESUGAR (Errors.Desugar_ConstraintViolation ArrayDeclarationFunctionType) ) + else + Exception.except_return + (perform_adjust qs (Ctype.Ctype [Annot.Aloc loc] (Ctype.Array ty Nothing))) + ) end -(* TYPE: pointer_declarator -> E.desugM (Ctype.qualifiers -> Ctype.ctype -> (Ctype.qualifiers * Ctype.ctype)) *) +(* TYPE: pointer_declarator -> E.desugM qs_ctype_builder *) and desugar_pointer_declarator (PDecl ptr_loc tquals ptr_decltor_opt) = (* if ptr_decltor_opt = Nothing, these qualifiers are of the current pointer type we are building; otherwise, they are of the referenced type of the @@ -1934,7 +2007,7 @@ and desugar_pointer_declarator (PDecl ptr_loc tquals ptr_decltor_opt) = (* in this case [tquals_qs] are the qualifiers of the pointer type we are currently building *) E.return ( - fun base_qs base_ty -> (tquals_qs, mk_pointer_ctype base_qs base_ty) + fun base_qs base_ty -> Exception.except_return (tquals_qs, mk_pointer_ctype base_qs base_ty) ) end @@ -1943,13 +2016,13 @@ and desugar_abstract_declarator under_array = function | AbsDecl_pointer ptr_decltor -> desugar_pointer_declarator ptr_decltor | AbsDecl_direct ptr_decltor_opt dabs_decltor -> - maybe (E.return (fun qs ty -> (qs, ty))) desugar_pointer_declarator + maybe (E.return (fun qs ty -> Exception.except_return (qs, ty))) desugar_pointer_declarator ptr_decltor_opt >>= fun mk_pointer_qs_ctype -> desugar_direct_abstract_declarator under_array dabs_decltor >>= fun mk_qs_ctype -> E.return ( fun base_qs base_ty -> - let (ptr_qs, ptr_ty) = mk_pointer_qs_ctype base_qs base_ty in - mk_qs_ctype ptr_qs ptr_ty + Exception.except_bind (mk_pointer_qs_ctype base_qs base_ty) + (fun (ptr_qs, ptr_ty) -> mk_qs_ctype ptr_qs ptr_ty) ) end @@ -1959,17 +2032,17 @@ and desugar_direct_abstract_declarator under_array = function desugar_abstract_declarator under_array abs_decltor | DAbs_array dabs_decltor_opt a_decltor -> (* NOTE: the recursive call is "under an array" declaration *) - maybe (E.return (fun qs ty -> (qs, ty))) + maybe (E.return (fun qs ty -> Exception.except_return (qs, ty))) (desugar_direct_abstract_declarator IsUnderArray) dabs_decltor_opt >>= fun mk_outer_qs_ctype -> desugar_array_declarator under_array a_decltor >>= fun mk_array_qs_ctype -> E.return ( fun base_qs base_ty -> - let (array_qs, array_ty) = mk_array_qs_ctype base_qs base_ty in - mk_outer_qs_ctype array_qs array_ty + Exception.except_bind (mk_array_qs_ctype base_qs base_ty) + (fun (array_qs, array_ty) -> mk_outer_qs_ctype array_qs array_ty) ) | DAbs_function dabs_decltor_opt param_tys -> (* TODO: documentation (the code the same as for desugar_direct_declarator, DDecl_function *) - maybe (E.return (fun qs ty -> (qs, ty))) + maybe (E.return (fun qs ty -> Exception.except_return (qs, ty))) (desugar_direct_abstract_declarator under_array) dabs_decltor_opt >>= fun mk_qs_ctype -> E.fresh_prototype_scope >>= fun proto_scope -> E.under_scope proto_scope @@ -2015,10 +2088,10 @@ and desugar_direct_abstract_declarator under_array = function ) end -(* TYPE: E.desugM (Symbol.identifier * (Ctype.qualifiers -> Ctype.ctype -> (Ctype.qualifiers * Ctype.ctype))) *) +(* TYPE: E.desugM (Symbol.identifier * qs_ctype_builder) *) and desugar_direct_declarator fundef under_array = function | DDecl_identifier attrs ident -> - E.return ((attrs, ident), fun base_qs base_ty -> (base_qs, base_ty)) + E.return ((attrs, ident), fun base_qs base_ty -> Exception.except_return (base_qs, base_ty)) | DDecl_declarator decltor -> desugar_declarator fundef decltor @@ -2029,8 +2102,8 @@ and desugar_direct_declarator fundef under_array = function desugar_array_declarator under_array a_decltor >>= fun mk_array_qs_ctype -> E.return ( attrs_ident , fun base_qs base_ty -> - let (array_qs, array_ty) = mk_array_qs_ctype base_qs base_ty in - mk_outer_qs_ctype array_qs array_ty ) + Exception.except_bind (mk_array_qs_ctype base_qs base_ty) + (fun (array_qs, array_ty) -> mk_outer_qs_ctype array_qs array_ty) ) | DDecl_function ddecltor param_tys -> let fundef' = @@ -2123,9 +2196,8 @@ and desugar_parameter_declaration is_first fundef param_decl = desugar_declarator NotFunDef decltor >>= fun ((_, ident), mk_qs_ctype) -> let (isAtomic, tquals_qs) = translate_type_qualifiers specifs.type_qualifiers in (* STD §6.9.1#7, sentence 4 *) - let (_qs, _ty) = - mk_qs_ctype (Ctype.combine_qualifiers specs_qs tquals_qs) base_ty in - + E.liftException (mk_qs_ctype (Ctype.combine_qualifiers specs_qs tquals_qs) base_ty) + >>= fun (_qs, _ty) -> if AilTypesAux.is_void _ty then match fundef with | IsFunDef -> @@ -2178,12 +2250,12 @@ and desugar_parameter_declaration is_first fundef param_decl = else (* NOTE: specs_qs <> no_qualifiers when the specifiers had a type-name or _Atomic *) desugar_type_specifiers specifs.type_specifiers >>= fun (specs_qs, base_ty) -> - maybe (E.return (fun qs ty -> (qs, ty))) + maybe (E.return (fun qs ty -> Exception.except_return (qs, ty))) (desugar_abstract_declarator NotUnderArray) abs_decltor_opt >>= fun mk_qs_ctype -> let (isAtomic, tquals_qs) = translate_type_qualifiers specifs.type_qualifiers in (* STD §6.9.1#7, sentence 4 *) - let (_qs, _ty) = - mk_qs_ctype (Ctype.combine_qualifiers specs_qs tquals_qs) base_ty in + E.liftException (mk_qs_ctype (Ctype.combine_qualifiers specs_qs tquals_qs) base_ty) + >>= fun (_qs, _ty) -> let (qs, ty) = AilTypesAux.adjust _qs _ty in let ret = (Nothing, ( qs , if isAtomic then Ctype.mk_ctype_atomic ty else ty @@ -2207,16 +2279,17 @@ and desugar_parameter_declaration is_first fundef param_decl = -(* TYPE: E.desugM (Symbol.identifier * (AilTypes.qualifiers -> AilTypes.ctype -> (AilTypes.qualifiers * AilTypes.ctype))) *) +(* TYPE: E.desugM (Symbol.identifier * qs_ctype_builder) *) and desugar_declarator fundef (Declarator ptr_decltor_opt ddecltor) = - maybe (E.return (fun qs ty -> (qs, ty))) desugar_pointer_declarator + maybe (E.return (fun qs ty -> Exception.except_return (qs, ty))) desugar_pointer_declarator ptr_decltor_opt >>= fun mk_pointer_qs_ctype -> desugar_direct_declarator fundef NotUnderArray ddecltor >>= fun (attrs_ident, mk_qs_ctype) -> (* TODO: check, but seems correct *) - E.return ( attrs_ident - , fun base_qs base_ty -> - let (ptr_qs, ptr_ty) = mk_pointer_qs_ctype base_qs base_ty in - mk_qs_ctype ptr_qs ptr_ty ) + E.return + ( attrs_ident + , fun base_qs base_ty -> + Exception.except_bind (mk_pointer_qs_ctype base_qs base_ty) + (fun (ptr_qs, ptr_ty) -> mk_qs_ctype ptr_qs ptr_ty) ) @@ -2357,7 +2430,14 @@ STD_ "§6.5.2.1#2, sentence 2" $ | CabsEcompound tyname inits -> AnnotatedExpression () [] loc <$> (desugar_type_name tyname >>= fun (qs, ty) -> - E.is_inside_function >>= fun inside_func -> + (* STD §6.5.2.5#1 + * we perform the check of the type BEFORE we desugar the initializer *) + E.is_complete_object ty >>= fun is_complete_object -> + if not ( AilTypesAux.is_array_unknown_size ty + || (is_complete_object && not (AilTypesAux.is_vla ty)) ) then + E.constraint_violation loc InvalidTypeCompoundLiteral + else + E.is_inside_function >>= fun inside_func -> (* NOTE: there is no need to do the check for STD §6.7.9#3 here, because of the ail typing *) wip_desugar_initializer_ loc (if inside_func then Automatic else Static) ty (Init_list loc inits) >>= fun (ty', d_e) -> E.return (AilEcompound qs ty' d_e)) @@ -2522,12 +2602,12 @@ STD_ "§6.5.2.1#2, sentence 2" $ | CabsEbuiltinGNU (GNUbuiltin_choose_expr const_e e1 e2) -> AnnotatedExpression () [] loc <$> (* TODO: add extension warning *) - (desugar_expression const_e >>= fun d_e -> - is_integer_constant_expression d_e >>= function + (desugar_expression const_e >>= fun d_e -> + is_integer_constant_expression true(*Constraint requirement *) d_e >>= function | false -> E.constraint_violation (Loc.locOf const_e) GNUBuiltinChooseExprNotIntegerConstant | true -> - evaluate_integer_constant_expression loc Nothing d_e >>= fun n -> + evaluate_integer_constant_expression Nothing d_e >>= fun n -> if n <> 0 then desugar_expression e1 else @@ -2587,7 +2667,7 @@ and desugar_init_declarator_BROKEN base_qs base_ty (scs: list storage_class_spec match idecltor with | InitDecl _ decltor Nothing -> desugar_declarator NotFunDef decltor >>= fun ((_, ident), mk_qs_ctype) -> - let (qs, ty) = mk_qs_ctype base_qs base_ty in + E.liftException (mk_qs_ctype base_qs base_ty) >>= fun (qs, ty) -> let mk_desug_init = fun () -> E.return Nothing in (* STD §6.9.2#2, sentence 1 *) @@ -2601,8 +2681,7 @@ and desugar_init_declarator_BROKEN base_qs base_ty (scs: list storage_class_spec | InitDecl loc decltor (Just init) -> desugar_declarator NotFunDef decltor >>= fun ((_, ident), mk_qs_ctype) -> - let (qs, ty) = mk_qs_ctype base_qs base_ty in - + E.liftException (mk_qs_ctype base_qs base_ty) >>= fun (qs, ty) -> (* TODO: check that we really never have parameter objects here *) let kind = if AilTypesAux.is_function ty then E.OK_function else E.OK_object false in (* TODO: I don't like the fact that we are using this function directly here *) @@ -2632,7 +2711,7 @@ and desugar_init_declarator attrs isAtomic has_alignment base_qs base_ty (scs: l match idecltor with | InitDecl loc decltor Nothing -> desugar_declarator NotFunDef decltor >>= fun ((ident_attrs, ident), mk_qs_ctype) -> - let (qs, _ty) = mk_qs_ctype base_qs base_ty in + E.liftException (mk_qs_ctype base_qs base_ty) >>= fun (qs, _ty) -> let ty = if isAtomic then wrap_atomic _ty else _ty in let mk_desug_init = fun () -> E.return Nothing in @@ -2664,7 +2743,7 @@ and desugar_init_declarator attrs isAtomic has_alignment base_qs base_ty (scs: l E.fail loc (Errors.Desugar_MiscViolation Errors.TypedefInitializer) else desugar_declarator NotFunDef decltor >>= fun ((ident_attrs, ident), mk_qs_ctype) -> - let (qs, _ty) = mk_qs_ctype base_qs base_ty in + E.liftException (mk_qs_ctype base_qs base_ty) >>= fun (qs, _ty) -> let ty = if isAtomic then wrap_atomic _ty else _ty in (* TODO: check that we really never have parameter objects here *) let kind = if AilTypesAux.is_function ty then E.OK_function else E.OK_object false in @@ -2714,8 +2793,8 @@ and desugar_struct_declaration struct_decl = desugar_struct_declarator (align_specs <> []) sdecltor >>= fun ((attrs, ident), mk_qs_ctype) -> (* NOTE: the checks for §6.7.2.1#3 are done by desugar_type_specifiers because we need to special case the last member. *) - let (qs, ty) = - mk_qs_ctype (Ctype.combine_qualifiers tquals_qs specs_qs) base_ty in + E.liftException (mk_qs_ctype (Ctype.combine_qualifiers tquals_qs specs_qs) base_ty) + >>= fun (qs, ty) -> desugar_alignment_specifiers (Loc.locOf ident) ty align_specs >>= fun align_opt -> E.return (ident, (Annot.combine_attributes outer_attrs attrs, align_opt, qs, if isAtomic then wrap_atomic ty else ty)) ) sdecltors @@ -2752,13 +2831,13 @@ and desugar_enumerator (ident, e_opt) = let loc = Loc.locOf e in desugar_expression e >>= fun d_e -> (* STD §6.7.2.2#2 *) - is_integer_constant_expression d_e >>= function + is_integer_constant_expression true(*Constraint requirement *) d_e >>= function | false -> E.constraint_violation loc WrongTypeEnumConstant | true -> (* TODO: the type provided to the evaluator should be the integer type compatible with the enum? *) - evaluate_integer_constant_expression loc (Just Ctype.signed_int) d_e >>= fun n -> + evaluate_integer_constant_expression (Just Ctype.signed_int) d_e >>= fun n -> E.return (ident, Just (loc, n)) end end @@ -2773,13 +2852,13 @@ and desugar_alignment_specifier loc align_spec = let loc = Loc.locOf e in desugar_expression e >>= fun d_e -> (* STD §6.7.2.2#2 *) - is_integer_constant_expression d_e >>= function + is_integer_constant_expression true(*Constraint requirement *) d_e >>= function | false -> E.constraint_violation loc AlignasNotIntegerConstant | true -> (* TODO: the type provided to the evaluator should be the integer type compatible with the enum? *) - evaluate_integer_constant_expression loc Nothing d_e >>= fun n -> + evaluate_integer_constant_expression Nothing d_e >>= fun n -> if n = 0 then (* STD (§6.7.5#6, second sentence) *) E.return Nothing @@ -2894,13 +2973,12 @@ and desugar_alignment_specifiers loc decl_ty xs = and desugar_type_name (Type_name specs tquals align_specs abs_decltor_opt) = (* TODO: align_specs is ignored here *) desugar_type_specifiers specs >>= fun (specs_qs, base_ty) -> - maybe (E.return (fun qs ty -> (qs, ty))) + maybe (E.return (fun qs ty -> Exception.except_return (qs, ty))) (desugar_abstract_declarator NotUnderArray) abs_decltor_opt >>= fun mk_qs_ctype -> let (isAtomic, tquals_qs) = translate_type_qualifiers tquals in - let (qs, ty) = - mk_qs_ctype (Ctype.combine_qualifiers specs_qs tquals_qs) base_ty in - E.return (qs, (if isAtomic then wrap_atomic ty else ty)) + E.liftException (mk_qs_ctype (Ctype.combine_qualifiers specs_qs tquals_qs) base_ty) + >>= fun (qs, ty) -> E.return (qs, (if isAtomic then wrap_atomic ty else ty)) @@ -3028,11 +3106,11 @@ and pathFromDesigs_aux acc = function E.return (List.reverse acc) | Desig_array e :: xs -> desugar_expression e >>= fun d_e -> - is_integer_constant_expression d_e >>= function + is_integer_constant_expression true(*Constraint requirement *) d_e >>= function | false -> E.constraint_violation (Loc.locOf e) IllegalTypeArrayDesignator | true -> - evaluate_integer_constant_expression (Loc.locOf e) Nothing d_e >>= fun n -> + evaluate_integer_constant_expression Nothing d_e >>= fun n -> if n < 0 then E.constraint_violation (Loc.locOf e) IllegalSizeArrayDesignator else @@ -3168,8 +3246,7 @@ and foo_aux E.get_sigma_sofar >>= fun sigm -> E.get_gamma_sofar >>= fun gamm -> match Mini_pipeline.typecheckAil sigm gamm d_e with - | Left (loc, _) -> - error ("WIP: foo_aux, Init_expr Ail type error ==> " ^ Loc.stringFromLocation loc) + | Left (loc, tcause) -> E.fail_ailtyping loc tcause | Right ty -> if AilTypesAux.is_struct ty then if ty = outer_ty then @@ -3379,7 +3456,7 @@ and wip_desugar_initializer_ loc dur current_ty init = because the setting the suffix to Nothing regardless of the value of n is wrong. *) E.return (current_ty, d_e) (* - evaluate_integer_constant_expression loc (Just current_ty) d_e >>= fun n -> + evaluate_integer_constant_expression (Just current_ty) d_e >>= fun n -> E.return begin (current_ty, AnnotatedExpression () [] loc (AilEconst (ConstantInteger (IConstant n Decimal Nothing)))) end @@ -3510,11 +3587,11 @@ and desugar_and_register_static_assert_declaration sa_decl = match sa_decl with | Static_assert (CabsExpression loc _ as e) lit -> desugar_expression e >>= fun d_e -> - is_integer_constant_expression d_e >>= function + is_integer_constant_expression false(* not Constraint requirement *) d_e >>= function | false -> E.undef loc Undefined.UB204_illtyped_Static_assert | true -> - evaluate_integer_constant_expression loc Nothing d_e >>= fun n -> + evaluate_integer_constant_expression Nothing d_e >>= fun n -> if n = 0 then E.constraint_violation loc (StaticAssertFailed (string_of_string_literal lit)) else @@ -3708,12 +3785,17 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = <*> E.return Nothing | CabsScase e s -> - if Global.isAgnostic () then - E.fail loc (Errors.Desugar_agnosticFailure "case statements are not supported in the agnostic mode") - else - desugar_expression e >>= evaluate_integer_constant_expression (Loc.locOf e) Nothing >>= fun n -> - E.register_case (Loc.locOf e) (E.CaseSelectConst n) >>= fun () -> - AilScase n <$> self s + E.get_switch_promoted_type >>= function + | Just promoted_ctrl_ty -> + desugar_expression e >>= evaluate_case_constant_expression promoted_ctrl_ty + >>= fun n -> + E.register_case (Loc.locOf e) (E.CaseSelectConst n) >>= fun () -> + (* NOTE: when running in agnostic mode, the desugaring of the switch will + * have failed already *) + AilScase n <$> self s + | Nothing -> + E.constraint_violation loc LabelStatementOutsideSwitch + end | CabsSdefault s -> E.register_default loc >>= fun () -> @@ -3761,14 +3843,33 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = end | CabsSswitch e s -> - (* STD §6.8.4#3 both the switch-statement and its sub statement are distinct blocks *) - (* NOTE: see the note in CabsSif *) - E.fresh_block_scope >>= fun switch_scope -> - E.fresh_block_scope >>= fun s_scope -> - E.under_scope switch_scope begin - AilSswitch <$> desugar_expression e - <*> E.under_scope s_scope (E.as_switch_body (self s)) - end + if Global.isAgnostic () then + (* We fail because we need to typecheck the controlling expression *) + E.fail loc (Errors.Desugar_agnosticFailure "switch statements are not supported in the agnostic mode") + else + (* STD §6.8.4#3 both the switch-statement and its sub statement are distinct blocks *) + (* NOTE: see the note in CabsSif *) + E.fresh_block_scope >>= fun switch_scope -> + E.fresh_block_scope >>= fun s_scope -> + E.under_scope switch_scope begin + desugar_expression e >>= fun d_e -> + E.get_sigma_sofar >>= fun sigm -> + E.get_gamma_sofar >>= fun gamm -> + (* TODO: this will move to a read-only config in the monad *) + let impl = Implementation.integerImpl () in + (* The expression in any enclosed case statement must be converted to the promoted + * type of the switch's controlling expression (STD §6.8.4.2#5). So we perform the + * Ail typechecking and promotion here and save it for when we reach a case statement. + *) + match Mini_pipeline.typecheckAil_promoted impl sigm gamm d_e with + | Left (loc, tcause) -> E.fail_ailtyping loc tcause + | Right Nothing -> + E.constraint_violation loc SwitchStatementControllingExpressionNotInteger + | Right (Just promoted_ty) -> + E.under_scope s_scope (E.as_switch_body promoted_ty (self s)) >>= fun d_s -> + E.return (AilSswitch d_e d_s) + end + end | CabsSwhile e s -> (* TODO: when supporting VLAs ==> §6.8.4.2#2 *) @@ -4028,10 +4129,10 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = end | CabsSbreak -> - E.is_in_switch >>= function - | true -> + E.get_switch_promoted_type >>= function + | Just _ -> E.return AilSbreak - | false -> + | Nothing -> match ctx.cont_ident_opt with | Just _ -> E.return AilSbreak @@ -4063,26 +4164,33 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = E.return AilSskip | CabsScaseGNU e1 e2 s -> - let desugar_case_constant e = - desugar_expression e >>= - evaluate_integer_constant_expression (Loc.locOf e) Nothing in - if Global.isAgnostic () then - E.fail loc (Errors.Desugar_agnosticFailure "case statements are not supported in the agnostic mode") - else - E.is_in_switch >>= function - | true -> - (* TODOO *) - desugar_case_constant e1 >>= fun n1 -> - desugar_case_constant e2 >>= fun n2 -> - E.register_case (Loc.bbox_location [Loc.locOf e1; Loc.locOf e2]) (E.CaseSelectRange n1 n2) >>= fun () -> - if n1 <= n2 then - AilScase_rangeGNU n1 n2 <$> self s - else - E.warnM (fun () -> "empty case range [" ^ Loc.stringFromLocation loc ^ "] discarded by the desugaring") >>= fun () -> - E.return AilSskip - | false -> - E.constraint_violation loc LabelStatementOutsideSwitch - end + E.get_switch_promoted_type >>= function + | Just promoted_ctrl_ty -> + desugar_expression e1 >>= + evaluate_case_constant_expression promoted_ctrl_ty >>= fun n1 -> + desugar_expression e2 >>= + evaluate_case_constant_expression promoted_ctrl_ty >>= fun n2 -> + (* NOTE: when running in agnostic mode, the desugaring of the switch will + * have failed already *) + let range_loc = Loc.bbox_location [Loc.locOf e1; Loc.locOf e2] in + if n1 < n2 then + E.register_case range_loc (E.CaseSelectRange n1 n2) >>= fun () -> + AilScase_rangeGNU n1 n2 <$> self s + else if n1 = n2 then + (* using a standard case statement for a singleton range *) + E.register_case range_loc (E.CaseSelectConst n1) >>= fun () -> + AilScase n1 <$> self s + else + (* an empty range can never be selected, so the case statement is dropped and not + * registered, but we kept its body because it can still be reached when + * control-flow falls through from a previous case *) + E.warnM (fun () -> + "empty case range [" ^ Loc.stringFromLocation loc ^ + "] discarded by the desugaring") >>= fun () -> + (fun d_s -> AilSblock [] [d_s]) <$> self s + | Nothing -> + E.constraint_violation loc LabelStatementOutsideSwitch + end | CabsSmarker s -> E.record_marker () >>= fun id -> AilSmarker id <$> self s @@ -4660,7 +4768,8 @@ let desugar_and_register_function_definition (FunDef fundef_loc fundef_attrs spe (* NOTE: as per §6.9.1#2, we perform a dummy instantiation of the type **specified by the declarator portion of the function definition**, which here means `ddecltor' without `specifs' *) - match mk_qs_ctype Ctype.no_qualifiers (Ctype.Ctype [] Ctype.Void) with + E.liftException (mk_qs_ctype Ctype.no_qualifiers (Ctype.Ctype [] Ctype.Void)) >>= + function | (_, Ctype.Ctype _ (Ctype.Function _ _ _)) -> E.return () | (_, Ctype.Ctype _ (Ctype.FunctionNoParams _)) -> @@ -4686,7 +4795,7 @@ let desugar_and_register_function_definition (FunDef fundef_loc fundef_attrs spe let base_ty = if isAtomic then Ctype.mk_ctype_atomic specs_ty else specs_ty in let base_qs = Ctype.combine_qualifiers specs_qs tquals_qs in - let (qs, ty) = mk_qs_ctype base_qs base_ty in + E.liftException (mk_qs_ctype base_qs base_ty) >>= fun (qs, ty) -> let process (return_qs, return_ty) params_opt isVariadic = (* NOTE: the constraint in §6.9.1#3 is enforced later in the Ail typechecker *) @@ -4945,9 +5054,12 @@ let register_additional_cn_var id = E.register_cn_ident CN_vars id import Core -val desugar: (map string Symbol.sym) * Core.fun_map unit * Core.impl -> Cn_desugaring.init_scope -> string -> translation_unit -> +val desugar: + E.desug_config -> + (map string Symbol.sym) * Core.fun_map unit * Core.impl -> Cn_desugaring.init_scope -> string -> + translation_unit -> Exception.exceptM (E.fin_markers_env * ail_program unit) Errors.error -let desugar core_eval_stuff cn_eval_stuff startup_str (TUnit edecls) = +let desugar desug_conf core_eval_stuff cn_eval_stuff startup_str (TUnit edecls) = (* E.eval sym_counter core_eval_stuff cn_eval_stuff ( E.under_scope E.Scope_file ( @@ -5022,7 +5134,7 @@ let desugar core_eval_stuff cn_eval_stuff startup_str (TUnit edecls) = ) ) *) - E.eval core_eval_stuff cn_eval_stuff ( + E.eval desug_conf core_eval_stuff cn_eval_stuff ( E.under_scope E.Scope_file ( register_cn_predicate_names edecls >>= fun () -> register_cn_function_names edecls >>= fun () -> diff --git a/frontend/model/cabs_to_ail_effect.lem b/frontend/model/cabs_to_ail_effect.lem index a461ef0c9..39ce06089 100644 --- a/frontend/model/cabs_to_ail_effect.lem +++ b/frontend/model/cabs_to_ail_effect.lem @@ -216,6 +216,13 @@ type case_selector = type switch_info = <| cases_info: list (Loc.t * case_selector); default_info: maybe Loc.t; + promoted_ty: Ctype.ctype; (* the promoted type of the controlling expression *) +|> + + +import Translation_effect +type desug_config = <| + elab_conf: Translation_effect.elab_config; |> type state = <| @@ -278,6 +285,9 @@ type state = <| (* TODO TODO TODO *) core_eval_stuff: (map string Symbol.sym) * Core.fun_map unit * Core.impl; + + (* READ-ONLY, this will be moved to the `desug_config` type when the monad is updated *) + desug_conf: desug_config; |> type markers_env = @@ -373,6 +383,9 @@ let modify_inner f = ) +let read_config = + read_inner (fun st -> st.desug_conf) + val void: forall 'a. desugM 'a -> desugM unit let cabs_to_ail_effect_void m = fmap (const ()) m @@ -547,13 +560,15 @@ let hack_inject_idents_map idents_map = ) -let empty_switch_info = - <| cases_info= []; default_info= Nothing |> +let init_switch_info promoted_ty = + <| cases_info= []; default_info= Nothing; promoted_ty= promoted_ty |> (* ========================================================================== *) -val initial_state: (map string Symbol.sym) * Core.fun_map unit * Core.impl -> Cn_desugaring.init_scope -> state_with_markers -let initial_state core_eval_stuff cn_eval_stuff = <| +val initial_state: + desug_config -> (map string Symbol.sym) * Core.fun_map unit * Core.impl -> + Cn_desugaring.init_scope -> state_with_markers +let initial_state desug_conf core_eval_stuff cn_eval_stuff = <| inner= <| aux_supply= 0; scope_id_supply= 0; @@ -583,6 +598,7 @@ let initial_state core_eval_stuff cn_eval_stuff = <| cn_state= Cn_desugaring.initial_cn_desugaring_state cn_eval_stuff; core_eval_stuff= core_eval_stuff; + desug_conf = desug_conf; |>; markers_env= Map.empty; |> @@ -619,13 +635,16 @@ let fin_markers_env () = State_exception.return (id, st.markers_env) -val eval: forall 'a. (map string Symbol.sym) * Core.fun_map unit * Core.impl -> Cn_desugaring.init_scope -> desugM 'a -> Exception.exceptM (fin_markers_env * 'a) Errors.error -let cabs_to_ail_effect_eval core_eval_stuff cn_eval_stuff m = +val eval: + forall 'a. + desug_config -> (map string Symbol.sym) * Core.fun_map unit * Core.impl -> + Cn_desugaring.init_scope -> desugM 'a -> Exception.exceptM (fin_markers_env * 'a) Errors.error +let cabs_to_ail_effect_eval desug_conf core_eval_stuff cn_eval_stuff m = State_exception.eval begin m >>= fun res -> fin_markers_env () >>= fun markers -> State_exception.return (markers, res) - end (initial_state core_eval_stuff cn_eval_stuff) + end (initial_state desug_conf core_eval_stuff cn_eval_stuff) let inline eval = cabs_to_ail_effect_eval @@ -917,19 +936,21 @@ end let check_case_overlaps xs = check_case_overlaps_aux [] xs -val is_in_switch : desugM bool -let is_in_switch = +(* Use this to check whether inside a switch, and to get the (promoted) type of + * the controlling expression. *) +val get_switch_promoted_type : desugM (maybe Ctype.ctype) +let get_switch_promoted_type = read_inner (fun st -> match st.switch_context with - | [] -> false - | _ :: _ -> true + | [] -> Nothing + | ctx :: _ -> Just (ctx.promoted_ty) end ) -val as_switch_body: forall 'a. desugM 'a -> desugM 'a -let as_switch_body m = +val as_switch_body: forall 'a. Ctype.ctype -> desugM 'a -> desugM 'a +let as_switch_body promoted_ty m = update_inner (fun st -> - <| st with switch_context= empty_switch_info :: st.switch_context |> + <| st with switch_context= init_switch_info promoted_ty :: st.switch_context |> ) >>= fun () -> m >>= fun ret -> get_inner >>= fun st -> diff --git a/frontend/model/constraint.lem b/frontend/model/constraint.lem index a14505e8c..841368fa3 100644 --- a/frontend/model/constraint.lem +++ b/frontend/model/constraint.lem @@ -1,5 +1,5 @@ -open import Pervasives Symbol GenTypes Ctype -import Loc +open import Pervasives GenTypes Ctype +import Loc Symbol type simple_assignment_violation = | IncompatibleType @@ -62,13 +62,13 @@ type violation = (* 6.5.2.3 Structure and union members *) | MemberofReferenceBaseTypeLvalue of qualifiers * ctype (* §6.5.2.3#1 *) | MemberofReferenceBaseTypeRvalue of genType (* §6.5.2.3#1 *) - | MemberofNoMemberLvalue of identifier * qualifiers * ctype (* §6.5.2.3#1 *) - | MemberofNoMemberRvalue of identifier * genType (* §6.5.2.3#1 *) + | MemberofNoMemberLvalue of Symbol.identifier * qualifiers * ctype (* §6.5.2.3#1 *) + | MemberofNoMemberRvalue of Symbol.identifier * genType (* §6.5.2.3#1 *) | MemberofIncompleteLvalue of qualifiers * ctype (* §6.5.2.3#1 (indirect consequence of the need for a member to exist) *) | MemberofIncompleteRvalue of genType (* §6.5.2.3#1 (indirect consequence of the need for a member to exist) *) | MemberofptrReferenceBaseType of qualifiers * ctype (* §6.5.2.3#2 *) | MemberofptrReferenceTypeNotPointer of genType (* §6.5.2.3#2 *) - | MemberofptrNoMember of identifier * qualifiers * ctype (* §6.5.2.3#2 *) + | MemberofptrNoMember of Symbol.identifier * qualifiers * ctype (* §6.5.2.3#2 *) | MemberofptrIncomplete of qualifiers * ctype (* §6.5.2.3#1 (indirect consequence of the need for a member to exist) *) (* 6.5.2.5 Compound literals *) | InvalidTypeCompoundLiteral (* §6.5.2.5#1 *) @@ -112,7 +112,7 @@ type violation = (* 6.6 Constant expressions *) | IntegerConstantOutRange (* §6.6#4 *) (* 6.7 Declarations *) - | NoLinkageMultipleDeclaration of identifier (* §6.7#3 *) + | NoLinkageMultipleDeclaration of Symbol.identifier (* §6.7#3 *) | TypedefRedefinition (* §6.7#3, 1st bullet *) | TypedefRedefinitionVariablyModifiedType (* §6.7#3, 1st bullet, sentence 2 *) | SameScopeIncompatibleDeclarations (* §6.7#4 *) @@ -127,15 +127,15 @@ type violation = (* 6.7.2.1 Struct and union specifiers *) | StructDeclarationLacksDeclaratorList (* §6.7.2.1#2 *) | StructMemberIncompleteType of qualifiers * ctype (* §6.7.2.1#3, sentence 1 *) - | StructMemberFunctionType of identifier (* §6.7.2.1#3, sentence 1 *) + | StructMemberFunctionType of Symbol.identifier (* §6.7.2.1#3, sentence 1 *) | StructMemberFlexibleArray (* §6.7.2.1#3, sentence 2 *) | StructMemberFlexibleArrayInArray (* §6.7.2.1#3, sentence 2, "element of array" *) - | IllegalFlexibleArrayMember of identifier (* §6.7.2.1#18 *) + | IllegalFlexibleArrayMember of Symbol.identifier (* §6.7.2.1#18 *) (* 6.7.2.1 Enum specifiers *) | WrongTypeEnumConstant (* §6.7.2.2#2 *) (* 6.7.2.3 Tags *) - | TagRedefinition of sym (* §6.7.2.3#1 *) - | TagRedeclaration of sym (* §6.7.2.3#2 *) + | TagRedefinition of Symbol.sym (* §6.7.2.3#1 *) + | TagRedeclaration of Symbol.sym (* §6.7.2.3#2 *) | EnumTagIncomplete (* §6.7.2.3#3 *) (* 6.7.2.4 Atomic type specifiers *) | AtomicTypeConstraint (* §6.7.2.4#3 *) @@ -172,18 +172,19 @@ type violation = (* 6.8 Statements and blocks *) (* 6.8.1 Labeled statements *) | LabelStatementOutsideSwitch (* §6.8.1#2 *) - | LabelRedefinition of identifier (* §6.8.1#3 *) + | LabelRedefinition of Symbol.identifier (* §6.8.1#3 *) (* 6.8.4.1 The if statement *) | IfStatementControllingExpressionNotScalar (* §6.8.4.1#1 *) (* 6.8.4.2 The switch statement *) | SwitchStatementControllingExpressionNotInteger (* §6.8.4.2#1 *) + | CaseNotIntegerConstantExpression (* §6.8.4.2#3, sentence 1 *) | CaseStatementOverlap of Loc.t | MutipleDefaultStatement of Loc.t (* 6.8.5 Iteration statements *) | IterationStatementControllingExpressionNotScalar (* §6.8.5#2 *) | IllegalStorageClassIterationStatement(* §6.8.5#3 *) (* 6.8.5 Jump statements *) - | UndeclaredLabel of identifier (* §6.8.6.1#1, sentence 1 *) + | UndeclaredLabel of Symbol.identifier (* §6.8.6.1#1, sentence 1 *) | ContinueOutsideLoop (* §6.8.6.2#1 *) | BreakOutsideSwitchOrLoop (* §6.8.6.3#1 *) (* 6.8.5.4 The return statement *) @@ -192,7 +193,7 @@ type violation = | ReturnAsSimpleAssignment of simple_assignment_violation * ctype * genType (* §6.8.6.4#3, sentence 2 *) (* 6.9 External definitions *) | IllegalStorageClassFileScoped (* §6.9#2 *) - | ExternalRedefinition of sym (* §6.9#3 *) + | ExternalRedefinition of Symbol.sym (* §6.9#3 *) (* 6.9.1 Function definitions *) | WrongTypeFunctionIdentifier (* §6.9.1#2 *) | IllegalStorageClassFunctionDefinition (* §6.9.1#4 *) @@ -452,6 +453,8 @@ let std_of_violation = function ["§6.8.4.1#1"] | SwitchStatementControllingExpressionNotInteger -> ["§6.8.4.2#1"] + | CaseNotIntegerConstantExpression -> + ["§6.8.4.2#3, sentence 1"] | CaseStatementOverlap _ -> ["§6.8.4.2#3, sentence 1"] | MutipleDefaultStatement _ -> diff --git a/frontend/model/core.lem b/frontend/model/core.lem index 952184883..d708e3072 100644 --- a/frontend/model/core.lem +++ b/frontend/model/core.lem @@ -398,9 +398,6 @@ type generic_globs 'a 'bty = type generic_globs_map 'a 'bty = map Symbol.sym (generic_globs 'a 'bty) -type core_tag_definitions = - map Symbol.sym (Loc.t * Ctype.tag_definition) - type visible_objects_env = map nat (list (Symbol.sym * Ctype.ctype)) type calling_convention = @@ -416,7 +413,7 @@ end type generic_file 'bty 'a = <| main: maybe Symbol.sym; calling_convention: calling_convention; - tagDefs: core_tag_definitions; + tagDefs: Ctype.tag_definitions; stdlib: generic_fun_map 'bty 'a; impl: generic_impl 'bty; globs: list (Symbol.sym * generic_globs 'a 'bty); diff --git a/frontend/model/core_aux.lem b/frontend/model/core_aux.lem index ef0660770..28aaddd46 100644 --- a/frontend/model/core_aux.lem +++ b/frontend/model/core_aux.lem @@ -134,8 +134,8 @@ let valueFromMemValue mem_val = (fun sym xs -> (OTy_struct sym, Vloaded (LVspecified (OVstruct sym xs)))) (fun sym ident mem_val -> (OTy_union sym, Vloaded (LVspecified (OVunion sym ident mem_val)))) -val memValueFromValue: ctype -> value -> maybe Mem.mem_value -let rec memValueFromValue ty cval = +val memValueFromValue: Ctype.tag_definitions -> ctype -> value -> maybe Mem.mem_value +let rec memValueFromValue tagDefs ty cval = let (Ctype annots ty_) = unatomic ty in match (ty_, cval) with | (_, Vunit) -> @@ -172,7 +172,7 @@ let rec memValueFromValue ty cval = (* TODO: check that the sizes match? *) maybe Nothing (fun z -> Just (Mem.array_mval z)) $ List.foldr (fun lval acc_opt -> - match (memValueFromValue elem_ty (Vloaded lval), acc_opt) with + match (memValueFromValue tagDefs elem_ty (Vloaded lval), acc_opt) with | (Just mem_val, Just acc) -> Just (mem_val :: acc) | _ -> @@ -181,7 +181,7 @@ let rec memValueFromValue ty cval = ) (Just []) lvals | (Struct tag_sym1, Vloaded (LVspecified (OVstruct tag_sym2 xs))) -> let () = Debug.print_debug 2 [] (fun () -> "Comparing struct tag symbols: " ^ Symbol.show_raw tag_sym1 ^ " = " ^ Symbol.show_raw tag_sym2) in - if Ctype_aux.are_compatible + if Ctype_aux.are_compatible tagDefs (no_qualifiers, Ctype [] (Struct tag_sym1)) (no_qualifiers, Ctype [] (Struct tag_sym2)) then @@ -598,7 +598,7 @@ let rec zeros_aux tagDefs (Ctype _ ty) = error "Core_aux.zeros should only be called on complete types" end -val zeros: core_tag_definitions -> ctype -> pexpr +val zeros: Ctype.tag_definitions -> ctype -> pexpr let zeros tagDefs ty = (* TODO: yucky *) Pexpr [] () diff --git a/frontend/model/core_eval.lem b/frontend/model/core_eval.lem index 7107ad8a0..0bf708a8e 100644 --- a/frontend/model/core_eval.lem +++ b/frontend/model/core_eval.lem @@ -751,7 +751,8 @@ let rec step_eval_pexpr n loc parent_call_loc_opt core_extern env mem_st_opt fil self pe2 >>= fun pe2' -> match (Caux.valueFromPexpr pe1', Caux.valueFromPexpr pe2') with | (Just (Vobject (OVpointer ptr_val)), Just (Vobject (OVinteger ival))) -> - EU.return $ PEval (Vobject (OVpointer (Mem.array_shift_ptrval ptr_val ty ival))) + Exception.return (Mem.array_shift_ptrval file.tagDefs loc ptr_val ty ival) >>= fun ptrval' -> + EU.return (PEval (Vobject (OVpointer ptrval'))) | (Just _, Just _) -> EU.fail $ Illformed_program ("PEarray_shift: type error ==> " ^ Pp.stringFromCore_pexpr (Pexpr [] () (PEarray_shift pe1' ty pe2'))) @@ -762,7 +763,7 @@ let rec step_eval_pexpr n loc parent_call_loc_opt core_extern env mem_st_opt fil self pe >>= fun pe' -> match Caux.valueFromPexpr pe' with | Just (Vobject (OVpointer ptr_val)) -> - EU.return $ PEval (Vobject (OVpointer (Mem.member_shift_ptrval ptr_val tag_sym member_ident))) + EU.return $ PEval (Vobject (OVpointer (Mem.member_shift_ptrval file.tagDefs ptr_val tag_sym member_ident))) | Just _ -> EU.fail $ Illformed_program "PEmember_shift" | _ -> @@ -870,7 +871,7 @@ let rec step_eval_pexpr n loc parent_call_loc_opt core_extern env mem_st_opt fil error "Core_eval, PEstruct => found a flexible array member" end in *) let (_, _, _, memb_ty) = fromJust "Core_eval, PEstruct 1" (List.lookup memb_ident membrs) in - let mval = fromJust "Core_Eval, PEstruct 2" (Caux.memValueFromValue memb_ty cval) in + let mval = fromJust "Core_Eval, PEstruct 2" (Caux.memValueFromValue file.tagDefs memb_ty cval) in (memb_ident, memb_ty, mval) | Ctype.UnionDef _ -> error "Core_eval.step_eval_pexpr, PEstruct found a UnionDef" @@ -890,7 +891,7 @@ KKK: EU.return (PEval (Vloaded (LVspecified (OVstruct tag_sym xs))) match snd $ fromJust "Core_eval, PEunion 1,1" (Map.lookup tag_sym file.tagDefs) with | Ctype.UnionDef membrs -> let (_, _, _, memb_ty) = fromJust "Core_eval, PEunion 1" (List.lookup memb_ident membrs) in - let mval = fromJust "Core_Eval, PEunion 2" (Caux.memValueFromValue memb_ty cval) in + let mval = fromJust "Core_Eval, PEunion 2" (Caux.memValueFromValue file.tagDefs memb_ty cval) in EU.return (PEval (Vobject (OVunion tag_sym memb_ident mval))) | Ctype.StructDef _ _ -> error "Core_eval.step_eval_pexpr, PEunion found a StructDef" diff --git a/frontend/model/core_linking.lem b/frontend/model/core_linking.lem index c7960397e..9a6f32c1a 100644 --- a/frontend/model/core_linking.lem +++ b/frontend/model/core_linking.lem @@ -1,5 +1,6 @@ open import Pervasives Utils Show Map Map_extra -open import Loc Cabs Symbol Core Exception Errors +open import Loc Cabs Core Exception Errors +import Symbol let inline (>>=) = except_bind val link_fail: forall 'a. Loc.t -> core_linking_cause -> exceptM 'a (Loc.t * cause) @@ -8,9 +9,9 @@ let link_fail loc cause = (* NOTE: the function returns an assoc list of redundant tentative to global definitions *) val link_extern: forall 'a. SetType 'a => - map identifier (list 'a * linking_kind) -> - map identifier (list 'a * linking_kind) -> - exceptM ((map identifier (list 'a * linking_kind)) * list (sym * sym)) (Loc.t * cause) + map Symbol.identifier (list 'a * linking_kind) -> + map Symbol.identifier (list 'a * linking_kind) -> + exceptM ((map Symbol.identifier (list 'a * linking_kind)) * list (Symbol.sym * Symbol.sym)) (Loc.t * cause) let link_extern ext acc = Map_extra.fold (fun k (ds, lk_def) m_acc -> let () = Debug.print_debug 3 [] (fun _ -> "linking " ^ show k) in @@ -45,7 +46,7 @@ let link_extern ext acc = end) ext (return (acc, [])) -val link_main: maybe sym -> maybe sym -> exceptM (maybe sym) (Loc.t * cause) +val link_main: maybe Symbol.sym -> maybe Symbol.sym -> exceptM (maybe Symbol.sym) (Loc.t * cause) let link_main opt_m1 opt_m2 = match (opt_m1, opt_m2) with | (Just _, Just _) -> link_fail Loc.unknown DuplicateMain @@ -230,7 +231,7 @@ let free acc = function | GlobalDecl _ -> acc end -val empty_dep: list (sym * set sym) -> set sym +val empty_dep: list (Symbol.sym * set Symbol.sym) -> set Symbol.sym let empty_dep map = Set.fromList (List.map fst (List.filter (fun (_, edges) -> Set.null edges) map)) diff --git a/frontend/model/core_reduction.lem b/frontend/model/core_reduction.lem index 054e99acd..27beb0cf8 100644 --- a/frontend/model/core_reduction.lem +++ b/frontend/model/core_reduction.lem @@ -619,9 +619,10 @@ type action_step = | ACTION_ILLTYPED of string val step_action: - list Annot.annot -> - (Core.pexpr -> core_runM Core.value) -> maybe nat -> Core.action core_run_annotation -> action_step -let step_action e_annots full_eval_pexpr is_excluded (Action loc act_annots act) = + Ctype.tag_definitions -> + list Annot.annot -> + (Core.pexpr -> core_runM Core.value) -> maybe nat -> Core.action core_run_annotation -> action_step +let step_action tagDefs e_annots full_eval_pexpr is_excluded (Action loc act_annots act) = let wrap z = Action loc act_annots z in match act with @@ -648,7 +649,7 @@ let step_action e_annots full_eval_pexpr is_excluded (Action loc act_annots act) | CreateReadOnly pe1 pe2 pe3 pref -> match (act_valueFromPexpr pe1, act_valueFromPexpr pe2, act_valueFromPexpr pe3) with | (Just (Vobject (OVinteger ival)), Just (Vctype ty), Just cval3) -> - match memValueFromValue (Ctype.Ctype [] (Ctype.unatomic_ ty)) cval3 with + match memValueFromValue tagDefs (Ctype.Ctype [] (Ctype.unatomic_ ty)) cval3 with | Just mval -> ACTION_REQUEST "CreateRequest" @@ -680,7 +681,7 @@ let step_action e_annots full_eval_pexpr is_excluded (Action loc act_annots act) | Store is_locking pe1 pe2 pe3 mo -> match (act_valueFromPexpr pe1, act_valueFromPexpr pe2, act_valueFromPexpr pe3) with | (Just (Vctype ty), Just (Vobject (OVpointer ptrval)), Just cval) -> - match memValueFromValue (Ctype.Ctype [] (Ctype.unatomic_ ty)) cval with + match memValueFromValue tagDefs (Ctype.Ctype [] (Ctype.unatomic_ ty)) cval with | Just mval -> ACTION_REQUEST "StoreRequest" @@ -1105,7 +1106,7 @@ let step_ctx mem_st file core_extern current_tid (parent_tid_opt, th_st) = | Just psym -> match Map.lookup psym file.funinfo with | Just (_, _, ret_ty, _, _, _) -> - Core_run.TSK_Return psym (Core_aux.memValueFromValue ret_ty cval) + Core_run.TSK_Return psym (Core_aux.memValueFromValue file.tagDefs ret_ty cval) | Nothing -> Core_run.TSK_Misc end @@ -1150,7 +1151,7 @@ let step_ctx mem_st file core_extern current_tid (parent_tid_opt, th_st) = end in let wrap_expr z = <| th_st with arena= apply_ctx ctx z |> in let process_action is_excluded wrap_act z = - match step_action e_annots full_eval_pexpr' is_excluded z with + match step_action file.tagDefs e_annots full_eval_pexpr' is_excluded z with | ACTION_REQUEST debug_str loc _request -> let loc' = if Loc.is_library_location loc then @@ -1232,7 +1233,7 @@ let step_ctx mem_st file core_extern current_tid (parent_tid_opt, th_st) = Map.insert sym (snd (Caux.valueFromMemValue mval)) x :: xs end |> in full_eval_pexpr th_st_tmp core_extern mem_st file pe3 >>= fun cval3 -> - match memValueFromValue (Ctype.Ctype [] (Ctype.unatomic_ ty)) cval3 with + match memValueFromValue file.tagDefs (Ctype.Ctype [] (Ctype.unatomic_ ty)) cval3 with | Just mval' -> E.return mval' | Nothing -> diff --git a/frontend/model/core_run.lem b/frontend/model/core_run.lem index 0c628d237..064a6e80b 100644 --- a/frontend/model/core_run.lem +++ b/frontend/model/core_run.lem @@ -379,7 +379,7 @@ let core_action_step arena_annots core_extern mem_st file current_tid (parent_ti | Just cval3 -> match (cval1, cval2) with | (Vobject (OVinteger ival), Vctype ty) -> - match memValueFromValue (Ctype.Ctype [] (Ctype.unatomic_ ty)) cval3 with + match memValueFromValue file.tagDefs (Ctype.Ctype [] (Ctype.unatomic_ ty)) cval3 with | Just mem_val -> Step_action_request "CreateRequest" ( E.fresh_action_id >>= fun create_aid -> @@ -524,7 +524,7 @@ KKK ) *) | _ -> - match memValueFromValue (Ctype.Ctype [] (Ctype.unatomic_ ty)) cval with + match memValueFromValue file.tagDefs (Ctype.Ctype [] (Ctype.unatomic_ ty)) cval with | Just mem_val -> Step_action_request "StoreRequest" ( E.fresh_action_id >>= fun store_aid -> @@ -615,7 +615,7 @@ KKK | RMW pe1 pe2 pe3 pe4 mo1 mo2 -> match (valueFromPexpr pe1, valueFromPexpr pe2, valueFromPexpr pe3, valueFromPexpr pe4) with | (Just (Vctype ty), Just (Vobject (OVpointer ptr_val)), Just cval_expected, Just cval_desired) -> - match (memValueFromValue ty cval_expected, memValueFromValue ty cval_desired) with + match (memValueFromValue file.tagDefs ty cval_expected, memValueFromValue file.tagDefs ty cval_desired) with | (Just mval_expected, Just mval_desired) -> Step_action_request "RMWRequest" ( E.fresh_action_id >>= fun rmw_aid -> @@ -948,7 +948,7 @@ BEFORE EVAL_PEXPR2 ty else Ctype.Ctype [] (Ctype.Pointer Ctype.no_qualifiers ty) in - match Core_aux.memValueFromValue arg_ty cval with + match Core_aux.memValueFromValue file.tagDefs arg_ty cval with | Just mval -> mval | Nothing -> error "Eccall memvalue" end) $ List.zip (List.map snd param_tys) cvals @@ -1577,7 +1577,7 @@ BEFORE EVAL_PEXPR2 | Just psym -> match Map.lookup psym file.funinfo with | Just (_, _, ret_ty, _, _, _) -> - TSK_Return psym $ Core_aux.memValueFromValue ret_ty cval + TSK_Return psym $ Core_aux.memValueFromValue file.tagDefs ret_ty cval | Nothing -> TSK_Misc end diff --git a/frontend/model/core_typing.lem b/frontend/model/core_typing.lem index 39e6780a1..e630cf7f3 100644 --- a/frontend/model/core_typing.lem +++ b/frontend/model/core_typing.lem @@ -392,7 +392,7 @@ let rec typeof_value loc env cval = end -(*val infer_pexpr: foral 'bty. core_tag_definitions -> typing_env -> generic_pexpr 'bty Symbol.sym -> E.eff inferred_pexpr *) +(*val infer_pexpr: foral 'bty. Ctype.tag_definitions -> typing_env -> generic_pexpr 'bty Symbol.sym -> E.eff inferred_pexpr *) let rec infer_pexpr tagDefs env ((Pexpr annot _ pexpr_ as pexpr) : generic_pexpr 'bty Symbol.sym) = let loc = Annot.get_loc_ annot in match pexpr_ with @@ -1205,12 +1205,12 @@ and typecheck_pexpr tagDefs (env: typing_env) (bTy: core_base_type) (Pexpr annot end -(*val typecheck_export_pexpr: forall 'bty. core_tag_definitions -> typing_env -> core_base_type -> Core.generic_pexpr 'bty Symbol.sym -> E.eff typed_pexpr *) +(*val typecheck_export_pexpr: forall 'bty. Ctype.tag_definitions -> typing_env -> core_base_type -> Core.generic_pexpr 'bty Symbol.sym -> E.eff typed_pexpr *) let typecheck_export_pexpr tagDefs env bTy pe = typecheck_pexpr tagDefs env bTy pe >>= export_pexpr -(*val infer_action: foral 'a 'bty. core_tag_definitions -> typing_env -> generic_action 'a 'bty -> E.eff (core_base_type * typed_action 'a) *) +(*val infer_action: foral 'a 'bty. Ctype.tag_definitions -> typing_env -> generic_action 'a 'bty -> E.eff (core_base_type * typed_action 'a) *) let infer_action tagDefs env (Action loc annot act_) = match act_ with | Create pe1 pe2 pref -> @@ -1362,7 +1362,7 @@ let infer_action tagDefs env (Action loc annot act_) = val typecheck_action: - forall 'a 'bty. core_tag_definitions -> typing_env -> core_base_type -> generic_action 'a 'bty Symbol.sym -> E.eff (typed_action 'a) + forall 'a 'bty. Ctype.tag_definitions -> typing_env -> core_base_type -> generic_action 'a 'bty Symbol.sym -> E.eff (typed_action 'a) let typecheck_action tagDefs env bTy (Action loc annot act_) = Action loc annot <$> match act_ with | Create pe1 pe2 pref -> @@ -1827,6 +1827,9 @@ and typecheck_expr callconv tagDefs (env: typing_env) expected_bTy (Expr annot e match Map.lookup sym env.labs with | Just (bTy, bTys) -> (* guard_match loc "run" expected_bTy bTy >> *) (* TODO check *) + if List.length pes <> List.length bTys then + E.fail loc (ArityMismatchRun (List.length bTys) (List.length pes)) + else begin Erun annot sym <$> E.mapM (fun (bTy, pe) -> typecheck_pexpr tagDefs env bTy pe diff --git a/frontend/model/core_unstruct.lem b/frontend/model/core_unstruct.lem index 3fbf8fbe0..758110403 100644 --- a/frontend/model/core_unstruct.lem +++ b/frontend/model/core_unstruct.lem @@ -15,8 +15,11 @@ let insupported str = error ("Core_unstruct: unsupported ==> " ^ str) -val extract_ctype_pe: typed_pexpr -> maybe (either ctype (Symbol.sym * list (Symbol.identifier * (Annot.attributes * maybe alignment * qualifiers * ctype)))) -let extract_ctype_pe (Pexpr _ _ pexpr_) = +val extract_ctype_pe: + Ctype.tag_definitions -> + typed_pexpr -> + maybe (either ctype (Symbol.sym * list (Symbol.identifier * (Annot.attributes * maybe alignment * qualifiers * ctype)))) +let extract_ctype_pe tagDefs (Pexpr _ _ pexpr_) = match pexpr_ with | PEval (Vctype (Ctype _ ty as cty)) -> Just match ty with @@ -26,7 +29,7 @@ let extract_ctype_pe (Pexpr _ _ pexpr_) = insupported "atomic union" | Struct tag_sym -> (* TODO(check) ignoring flexible array members *) - Right (tag_sym, fst (get_structDef tag_sym)) + Right (tag_sym, fst (get_structDef tagDefs tag_sym)) | Union tag_sym -> (*let xs = get_unionDef tag_sym in*) insupported "(non atomic) union" @@ -47,9 +50,8 @@ let extract_alignement_type (Pexpr _ _ pexpr_) = end -val type_pexpr: pexpr -> typed_pexpr -let type_pexpr pexpr = - let tagDefs = Ctype_aux.tagDefs () in +val type_pexpr: Ctype.tag_definitions -> pexpr -> typed_pexpr +let type_pexpr tagDefs pexpr = let m = Core_typing_effect.bind (Core_typing.infer_pexpr tagDefs Core_typing_aux.empty_env pexpr) @@ -103,12 +105,12 @@ let explode_ptr_pexpr env (Pexpr annot bTy pexpr_) = (*val explode_paction: explode_env -> typed_paction unit -> list (typed_expr_ unit) *) -let explode_paction env (Paction pol (Action loc a act_)) = +let explode_paction tagDefs env (Paction pol (Action loc a act_)) = let wrap z = Eaction (Paction pol (Action loc a z)) in match act_ with | Create al_pe1 ty_pe2 pref -> - match (extract_alignement_type al_pe1, extract_ctype_pe ty_pe2) with + match (extract_alignement_type al_pe1, extract_ctype_pe tagDefs ty_pe2) with | (_, Just (Left _)) -> (* this is not allocating a struct, so no need to explode *) Nothing @@ -128,7 +130,7 @@ let explode_paction env (Paction pol (Action loc a act_)) = | Nothing -> Caux.mk_alignof_pe ty_pe end in - (ident, wrap (Create (type_pexpr align_pe) (type_pexpr ty_pe) pref)) + (ident, wrap (Create (type_pexpr tagDefs align_pe) (type_pexpr tagDefs ty_pe) pref)) ) xs end | (_, _) -> @@ -231,8 +233,9 @@ let mk_ptr_sym_pe sym = Pexpr [] (BTy_object OTy_pointer) (PEsym sym) -val explode_expr: explode_env -> typed_expr unit -> typed_expr unit -let rec explode_expr env (Expr annot expr_ as expr) = +val explode_expr: Ctype.tag_definitions -> explode_env -> typed_expr unit -> typed_expr unit +let rec explode_expr tagDefs env (Expr annot expr_ as expr) = + let explode_expr = explode_expr tagDefs in let self e = explode_expr env e in let wrap z = Expr annot z in match expr_ with @@ -251,7 +254,7 @@ let rec explode_expr env (Expr annot expr_ as expr) = end | Esseq (Pattern pat_annot (CaseBase (Just sym, BTy_object OTy_pointer)) as pat) (Expr annot1 (Eaction pact) as e1) e2 -> - match explode_paction env pact with + match explode_paction tagDefs env pact with | Nothing -> wrap (Esseq pat e1 (explode_expr env e2)) | Just xs -> @@ -343,11 +346,11 @@ let rec explode_expr env (Expr annot expr_ as expr) = -val explode_fun_map: typed_fun_map unit -> typed_fun_map unit -let explode_fun_map funs = +val explode_fun_map: Ctype.tag_definitions -> typed_fun_map unit -> typed_fun_map unit +let explode_fun_map tagDefs funs = Map.map (function | Proc loc mrk bTy xs e -> - Proc loc mrk bTy xs (explode_expr Map.empty e) + Proc loc mrk bTy xs (explode_expr tagDefs Map.empty e) | z -> z end) funs @@ -356,4 +359,4 @@ let explode_fun_map funs = val explode_file: typed_file unit -> typed_file unit let explode_file file = <| file with - funs= explode_fun_map file.funs |> + funs= explode_fun_map file.tagDefs file.funs |> diff --git a/frontend/model/ctype.lem b/frontend/model/ctype.lem index 5afc79e37..032489abb 100644 --- a/frontend/model/ctype.lem +++ b/frontend/model/ctype.lem @@ -3,8 +3,8 @@ * Victor Gomes *) -open import Pervasives Utils Loc Show Symbol -import Annot IntegerType +open import Pervasives Utils Loc Show +import Symbol Annot IntegerType include IntegerType (* STD §6.2.5#10, sentence 1 *) @@ -84,6 +84,10 @@ type tag_definition = | StructDef of list (Symbol.identifier * (Annot.attributes * maybe alignment * qualifiers * ctype)) * maybe flexible_array_member | UnionDef of list (Symbol.identifier * (Annot.attributes * maybe alignment * qualifiers * ctype)) +type tag_definitions = + map Symbol.sym (Loc.t * tag_definition) + + (** Type class instances *) instance (Eq realFloatingType) diff --git a/frontend/model/ctype_aux.lem b/frontend/model/ctype_aux.lem index af1ec8777..0341b6df6 100644 --- a/frontend/model/ctype_aux.lem +++ b/frontend/model/ctype_aux.lem @@ -4,29 +4,16 @@ import Symbol AilTypesAux open import Utils Ctype import Map_extra -(* SEE src/tags.mli for the documentation *) -val tagDefs: unit -> map Symbol.sym (Loc.t * tag_definition) -val set_tagDefs: map Symbol.sym (Loc.t * tag_definition) -> unit -val with_tagDefs: forall 'a. map Symbol.sym (Loc.t * tag_definition) -> (unit -> 'a) -> 'a - -declare ocaml target_rep function tagDefs = `Tags.tagDefs` -declare ocaml target_rep function set_tagDefs = `Tags.set_tagDefs` -declare ocaml target_rep function with_tagDefs = `Tags.with_tagDefs` - -declare hol target_rep function tagDefs = `tagDefs` -declare hol target_rep function set_tagDefs = `set_tagDefs` -declare hol target_rep function with_tagDefs = `with_tagDefs` - -val get_membersDefs: Symbol.sym -> tag_definition -let get_membersDefs tag_sym = - snd $ fromJust "Ctype_aux.get_membersDefs" (Map.lookup tag_sym (tagDefs ())) - -val get_membersDefs_with_tagDefs: map Symbol.sym tag_definition -> Symbol.sym -> tag_definition -let get_membersDefs_with_tagDefs tagDefs tag_sym = - fromJust ("Ctype_aux._with_tagDefs[" ^ show tag_sym ^ "]") (Map.lookup tag_sym tagDefs) - -val get_structDef_with_tagDefs: map Symbol.sym (Loc.t * tag_definition) -> Symbol.sym -> list (Symbol.identifier * (Annot.attributes * maybe alignment * qualifiers * ctype)) * maybe Ctype.flexible_array_member -let get_structDef_with_tagDefs tagDefs tag_sym = +val get_membersDefs: Ctype.tag_definitions -> Symbol.sym -> tag_definition +let get_membersDefs tagDefs tag_sym = + snd (fromJust ("Ctype_aux.get_membersDefs[" ^ show tag_sym ^ "]") (Map.lookup tag_sym tagDefs)) + +val get_structDef: + Ctype.tag_definitions -> + Symbol.sym -> + list (Symbol.identifier * (Annot.attributes * maybe alignment * qualifiers * ctype)) * + maybe Ctype.flexible_array_member +let get_structDef tagDefs tag_sym = match Map.lookup tag_sym tagDefs with | Just (_, StructDef xs flexible_opt) -> (xs, flexible_opt) @@ -38,14 +25,13 @@ let get_structDef_with_tagDefs tagDefs tag_sym = "): couldn't find a struct/union definition") end -val get_structDef: Symbol.sym -> list (Symbol.identifier * (Annot.attributes * maybe alignment * qualifiers * ctype)) * maybe Ctype.flexible_array_member -let get_structDef tag_sym = - get_structDef_with_tagDefs (tagDefs ()) tag_sym - - -val get_unionDef: Symbol.sym -> (Symbol.identifier * (Annot.attributes * maybe alignment * qualifiers * ctype)) * list (Symbol.identifier * (Annot.attributes * maybe alignment * qualifiers * ctype)) -let get_unionDef tag_sym = - match Map.lookup tag_sym (tagDefs ()) with +val get_unionDef: + Ctype.tag_definitions -> + Symbol.sym -> + (Symbol.identifier * (Annot.attributes * maybe alignment * qualifiers * ctype)) * + list (Symbol.identifier * (Annot.attributes * maybe alignment * qualifiers * ctype)) +let get_unionDef tagDefs tag_sym = + match Map.lookup tag_sym tagDefs with | Just (_, UnionDef []) -> error ("Core_type.aux.get_unionDef (" ^ show tag_sym ^ "): found an empty union definition") @@ -59,9 +45,6 @@ let get_unionDef tag_sym = "): couldn't find a struct/union definition") end -val reset_tagDefs: unit -> unit -declare ocaml target_rep function reset_tagDefs = `Tags.reset_tagDefs` - @@ -191,7 +174,7 @@ and are_compatible_params env params1 params2 = are_compatible_params_aux env true (params1, params2) -let are_compatible qs_ty1 qs_ty2 = +let are_compatible tagDefs qs_ty1 qs_ty2 = (* let tagDefs = Map_extra.fold (fun k v acc -> match k with | Symbol.Symbol _ _ (Symbol.SD_Id str) -> @@ -200,7 +183,6 @@ let are_compatible qs_ty1 qs_ty2 = error "Ctype_aux.are_compatible" end ) (tagDefs ()) Map.empty in *) - let tagDefs = tagDefs () in are_compatible_aux (tagDefs, tagDefs) qs_ty1 qs_ty2 (* diff --git a/frontend/model/defacto_memory.lem b/frontend/model/defacto_memory.lem deleted file mode 100644 index 555b75b1b..000000000 --- a/frontend/model/defacto_memory.lem +++ /dev/null @@ -1,2600 +0,0 @@ -(* De-facto C11 memory model *) -open import Pervasives -import Num_extra Set_helpers (* fold *) Map_extra - -open import Utils Enum - -import Cabs Dlist Loc - -open import Mem_common Defacto_memory_aux Defacto_memory_types Ctype -import Ctype_aux - -module F = Float - - -import State - - -val stringFromCtype: ctype -> string -declare ocaml target_rep function stringFromCtype = `String_core_ctype.string_of_ctype` - -(* TODO: HOL hack *) -declare hol target_rep function stringFromCtype c = "" - -(* Semantic switches *) -type mode = - | Mode_ISO - (* the bools are: "-no-strict-aliasing", multiple-provenance, - pointer-lifetime-zap *) - | Mode_Defacto of bool * bool * bool - - -(* Basic representation: - assuming 8-bit bytes and two's complement arithmetic. - *) - - - -type write_event = - WriteEvent of Loc.t * ctype * impl_pointer_value * impl_mem_value - - -type storage = - | Storage_static of Symbol.prefix * ctype * maybe impl_mem_value - | Storage_dynamic of Symbol.prefix * integer_value_base * list write_event - - -type impl_mem_state = <| - (* this is read-only *) - flags: list memory_flag; - - (* machinery stuff *) - allocation_id_suppl: allocation_id; - - (* the semantic stuff starts here *) -(* - old_allocations: map allocation_id (allocation * maybe impl_mem_value); -*) - - allocations: map allocation_id storage; - dead_allocations: set allocation_id; - - device_memory: list write_event; - - (* For the detection of races, need to be flushed at every sequence point *) - access_log: list allocation_id; -|> - -let impl_initial_mem_state = <| - flags= [Allow_disjoint_alloc_tests]; - allocation_id_suppl= 0; - - allocations= Map.empty; - dead_allocations= Set.empty; - - device_memory= []; - - access_log= []; -|> - - -(* BEGIN effect ================================================================================= *) -open import Nondeterminism -type impl_memM 'a = - ndM 'a string mem_error (mem_constraint impl_integer_value) impl_mem_state - -let impl_return = return -let inline impl_bind = bind - -let inline (>>=) = impl_bind -let inline (>>) m1 m2 = impl_bind m1 (fun _ -> m2) - -let inline (<$>) f m = - m >>= return -| f - - -(* TODO: debug *) -val wip: forall 'a. string -> impl_memM 'a (* DEBUG *) -let wip str = - kill (Other (MerrWIP str)) - - -val defacto_fail: forall 'a. Loc.t -> mem_error -> impl_memM 'a -let defacto_fail loc err = - match undefinedFromMem_error err with - | Just ub -> - kill (Undef loc [ub]) - | Nothing -> - kill (Other err) - end -let inline fail = defacto_fail - -val print_debugM: nat -> (unit -> string) -> impl_memM unit -let print_debugM n msg = - return (Debug.print_debug n [Debug.DB_memory] msg) -(* END effect ================================================================================= *) - - -val fresh_allocation_id: impl_memM allocation_id -let fresh_allocation_id = - get >>= fun mem_st -> - let id = mem_st.allocation_id_suppl in - put <| mem_st with allocation_id_suppl= id+1 |> >> - return id - - -val register_allocation: allocation_id -> storage -> impl_memM unit -let register_allocation alloc_id stor = - get >>= fun mem_st -> - put <| mem_st with allocations= - Map.insert alloc_id stor mem_st.allocations - |> - -val resolve_allocation: allocation_id -> impl_memM storage -let resolve_allocation alloc_id = - get >>= fun mem_st -> - maybe (fail Loc.unknown (MerrInternal ("failed to resolve allocation: " ^ show alloc_id))) return - (Map.lookup alloc_id mem_st.allocations) - - -val allocation_is_dead: allocation_id -> impl_memM bool -let allocation_is_dead alloc_id = - get >>= fun mem_st -> - return (alloc_id IN mem_st.dead_allocations) - - - - - - - -(* DEBUG, fixing impl: gcc-5 (Homebrew gcc 5.2.0) 5.2.0 *) -val defacto_integer_range: integerType -> integer * integer -let defacto_integer_range = function - | Char -> - (0-128, 127) - | Bool -> - error "WIP: Mem.integer_range, Bool" - | Signed Ichar -> - (0-128, 127) - | Signed Short -> - (0-32768, 32767) - | Signed Int_ -> - (0-2147483648, 2147483647) - | Signed Long -> - (0-2**63, 2**63-1) - | Signed LongLong -> - (0-2**63, 2**63-1) - | Signed (IntN_t n) -> - (0-(2**(n-1)), 2**(n-1) - 1) - | Signed (Int_leastN_t n) -> - (0-(2**(n-1)), 2**(n-1) - 1) - | Signed (Int_fastN_t n) -> - (0-(2**(n-1)), 2**(n-1) - 1) - | Signed Intmax_t -> - (0-(2**63), 2**63 - 1) - | Signed Intptr_t -> - (0-(2**63), 2**63 - 1) - | Unsigned Ichar -> - (0, 255) - | Unsigned Short -> - (0, 65535) - | Unsigned Int_ -> - (0, 4294967295) - | Unsigned Long -> - (0, 2**64-1) - | Unsigned LongLong -> - (0, 2**64-1) - | Unsigned (IntN_t n) -> - (0, 2**n - 1) - | Unsigned (Int_leastN_t n) -> - (0, 2**n - 1) - | Unsigned (Int_fastN_t n) -> - (0, 2**n - 1) - | Unsigned Intmax_t -> - (0, 2**64 - 1) - | Unsigned Intptr_t -> - (0, 2**64 - 1) - | Enum sym -> - error "WIP: Mem.integer_range, Enum" - | Size_t -> - (0, 2**64-1) - | Wchar_t -> - (0, 2**64-1) - | Wint_t -> - (0-2147483648, 2147483647) - | Ptrdiff_t -> - (0-2**63, 2**63-1) - | Ptraddr_t -> - (0, 2**64 - 1) -end -let inline integer_range = defacto_integer_range - - -(* ============================================================================================== *) -val ifFlag: forall 'a. memory_flag -> impl_memM 'a -> impl_memM 'a -> impl_memM 'a -let ifFlag flag mThen mElse = - get >>= fun st -> - if List.elem flag st.flags then - mThen - else - mElse - - -val condM: string -> mem_constraint impl_integer_value -> impl_memM bool -let condM debug_str cs = - ifM debug_str cs (return true) (return false) - - -(* ============================================================================================== *) -(* | empty ID ID' wildcard - ---------+------------------------------------- - empty | empty ID ID' wildcard - ID | ID ID empty wildcard - ID' | ID' empty ID' wildcard - wildcard | wildcard wildcard wildcard wildcard *) -val combine_prov: provenance -> provenance -> provenance -let combine_prov prov1 prov2 = - match (prov1, prov2) with - | (Prov_none, Prov_none) -> - Prov_none - | (Prov_none, Prov_some id) -> - Prov_some id - | (Prov_none, Prov_wildcard) -> - Prov_wildcard - | (Prov_none, Prov_device) -> - Prov_device - - | (Prov_some id, Prov_none) -> - Prov_some id - | (Prov_some id1, Prov_some id2) -> - if id1 = id2 then - Prov_some id1 - else - Prov_none - | (Prov_some _, Prov_wildcard) -> - Prov_wildcard - | (Prov_some _, Prov_device) -> - Prov_device - - | (Prov_device, Prov_none) -> - Prov_device - | (Prov_device, Prov_some _) -> - Prov_device - | (Prov_device, Prov_device) -> - Prov_device - | (Prov_device, Prov_wildcard) -> - Prov_wildcard - - | (Prov_wildcard, _) -> - Prov_wildcard - end - - -(* Wellformedness predicates (following the comments in the definitions of the related types). *) -val wf_pointer_value: impl_pointer_value -> bool -let wf_pointer_value = function - | PV Prov_none (PVnull _) _ -> - true - | PV _ (PVnull _) _ -> - false - | _ -> - true (* TODO !!!! error "WIP: wf_pointer_value" *) -end - - -(* Returns whether a given allocation has reached the end of its lifetime *) -val is_dead: allocation_id -> impl_memM bool -let is_dead alloc_id = - get >>= fun mem_st -> - return (Set.member alloc_id mem_st.dead_allocations) - - -(* TODO: why is that effectfull? *) -val explicitAllocationIdFromPointer_value_aux: pointer_value_base -> impl_memM (maybe (allocation_id * Symbol.prefix)) -let rec explicitAllocationIdFromPointer_value_aux ptr_val_ = - match ptr_val_ with - | PVunspecified _ -> - return Nothing - | PVnull _ -> - return Nothing - | PVfunction _ -> - return Nothing - | PVbase alloc_id pref -> - return (Just (alloc_id, pref)) - | PVfromint ival_ -> - explicitAllocationIdFromInteger_value_aux ival_ - end - -and explicitAllocationIdFromInteger_value_aux ival_ = - match ival_ with - | IVunspecified -> - return Nothing - | IVconcurRead _ _ -> - return Nothing - | IVconcrete _ -> - return Nothing - | IVaddress _ _ -> - return Nothing - | IVfromptr _ ity ptr_val_ _ -> - explicitAllocationIdFromPointer_value_aux ptr_val_ - | IVop _ _ -> - return Nothing - | IVmin _ -> - return Nothing - | IVmax _-> - return Nothing - | IVsizeof _-> - return Nothing - | IValignof _-> - return Nothing - | IVoffsetof _ _ -> - return Nothing - | IVpadding _ _-> - return Nothing - | IVptrdiff _ _ _-> - return Nothing - | IVbyteof _ _-> - return Nothing - | IVcomposite _ -> - return Nothing - | IVbitwise _ _ -> - return Nothing - end - - -(* Making an indirection here, so that future crazy optimisations won't be duplicated all over. *) -let mk_op_ival_ iop ival_1 ival_2 = - lifted_simplify_integer_value_base (IVop iop [ival_1; ival_2]) - - -let mk_offsetof_ival_ acc tag_sym memb_ident = - match Ctype_aux.get_membersDefs tag_sym with - | StructDef _ (Just _) -> - error "TODO: Defacto_memory.mk_offsetof_ival_ ==> for struct with flexible array member" - | StructDef xs Nothing -> - (* we take the prefix the members before the one we want to offset to *) - let prefix_xs = - List.takeWhile (fun (ident, _) -> memb_ident <> ident) xs in - (* then we sum their sizeof and trailing paddings *) - List.foldl (fun acc' (ident, (_, _(* TODO: alignment*), _, ty)) -> - if ident = memb_ident then - (* TODO: this should be dead code since we fold on the prefix *) - acc' - else - mk_op_ival_ IntAdd (IVsizeof ty) - (mk_op_ival_ IntAdd (IVpadding tag_sym ident) acc') - ) acc (List.reverse prefix_xs) - | UnionDef _ -> - (* TODO: check, but if we have a struct this should be no offset to do *) - acc - end - - - - -val get_allocation_id: pointer_value_base -> maybe allocation_id -let rec get_allocation_id ptr_val_ = - match ptr_val_ with - | PVnull ty -> - Nothing - | PVbase alloc_id _ -> - Just alloc_id - | PVfromint (IVfromptr _ _ ptr_val_' _) -> - get_allocation_id ptr_val_' - | _ -> - error "TODO: get_allocation_id, wildcard" - end - - - - -val integer_value_baseFromShift_path: shift_path -> integer_value_base -let integer_value_baseFromShift_path sh = - List.foldl (fun acc spe -> - let spe_ival_ = match spe with - | SPE_array ty ival_ -> - mk_op_ival_ IntMul (IVsizeof ty) ival_ - | SPE_member tag_sym memb_ident -> - mk_offsetof_ival_ acc tag_sym memb_ident - end in - mk_op_ival_ IntAdd spe_ival_ acc - ) (IVconcrete 0) sh - - - - -val mkUnspec: ctype -> impl_mem_value -let rec mkUnspec (Ctype _ ty) = - match ty with - | Void -> - error "Defacto_memory.mkUnspec: called on Void" - | Basic (Integer ity) -> - MVinteger ity (IV Prov_none IVunspecified) - | Basic (Floating fty) -> - MVfloating fty FVunspecified - | Array _ Nothing -> - error "Defacto_memory.mkUnspec: called on Array _ Nothing" - | Array ty (Just n) -> - MVarray $ replicate (natFromInteger n) (mkUnspec ty) - | Function _ _ _ -> - error "Defacto_memory.mkUnspec: called on Function _ _ _" - | FunctionNoParams _ -> - error "Defacto_memory.mkUnspec: called on FunctionNoParams _" - | (Pointer _ ty') -> - MVpointer ty' (PV Prov_none (PVunspecified ty') []) - | Atomic _ -> - error ("TODO: Defacto_memory.mkUnspec ==> " ^ stringFromCtype (Ctype [] ty)) - | Struct tag_sym -> - (* TODO(check) ignoring potential flexible array member, because we are dealing with a struct as value *) - let (xs, _) = Ctype_aux.get_structDef tag_sym in - MVstruct tag_sym ( - List.map (fun (ident, (_, _, _, ty)) -> (ident, ty, mkUnspec ty)) xs - ) - | (Union tag_sym) -> - let ((memb_ident, (_, _, _, ty)), _) = Ctype_aux.get_unionDef tag_sym in - MVunion tag_sym memb_ident (mkUnspec ty) - | Byte -> - MVinteger (Unsigned Ichar) (IV Prov_none IVunspecified) - end - - - - - - - - - - - - - - - -(* BEGIN API IMPLEMENTATION ===================================================================== *) -val impl_eval_integer_value: impl_integer_value -> maybe integer -let impl_eval_integer_value (IV _ ival_) = - eval_integer_value_base ival_ - - -let impl_offsetof_ival tagDefs tag_sym memb_ident = -(* IV Prov_none (lifted_simplify_integer_value_base (IVoffsetof tag_sym membr_ident)) *) - IV Prov_none (mk_offsetof_ival_ (IVconcrete 0) tag_sym memb_ident) - - -val addToLog: allocation_id -> impl_memM unit -let addToLog alloc_id = - print_debugM 1 (fun () -> "addToLog: " ^ show alloc_id) >> - get >>= fun mem_st -> - if List.elem alloc_id mem_st.access_log then - fail Loc.unknown (MerrOther ("unsequenced race: " ^ show alloc_id)) - else - put <| mem_st with access_log= alloc_id :: mem_st.access_log |> - - -val impl_sequencePoint: impl_memM unit -let impl_sequencePoint = - get >>= fun mem_st -> - put <| mem_st with access_log= [] |> - - - - - - - -val register_address_constraints: Symbol.prefix -> allocation_id -> integer_value_base -> integer_value_base -> impl_memM unit -let register_address_constraints pref alloc_id size_ival_ align_ival_ = - get >>= fun st -> - (* list of previous allocations that must not clash with - the new allocations *) - let allocs = - List.filter (fun (z, _) -> - not (Set.member z st.dead_allocations) - ) (Map_extra.toList st.allocations) in - let distinctness_constrs = - (* forall z_id: allocations, *) - List.map (fun (z_id, z_stor) -> - let (z_pref, z_size_ival_) = match z_stor with - | Storage_static pref ty _ -> - (pref, IVsizeof ty) - | Storage_dynamic pref ival_ _ -> - (pref, ival_) - end in - (* @z_id + sizeof(int) <= @alloc_id \/ @alloc_id + sizeof(int) <= @z_id *) - MC_or (mk_iv_constr MC_le (IVop IntAdd [IVaddress z_id z_pref; z_size_ival_]) (IVaddress alloc_id pref)) - (mk_iv_constr MC_le (IVop IntAdd [IVaddress alloc_id pref; size_ival_ ]) (IVaddress z_id z_pref)) - ) allocs in - (* @alloc_id mod align_ival = 0 *) - let align_constr = - mk_iv_constr MC_eq (IVop IntRem_f [IVaddress alloc_id pref; align_ival_]) (IVconcrete 0) in - addConstraints "address constraint" - ((*simplify_constraint $ *) MC_conj (align_constr :: distinctness_constrs)) >> - - (* TODO: hack simplifying intptr_t/uintptr_t (cast to uintptr_t is the identity for Z3) *) - addConstraints "address constraint hack" - (MC_conj [ mk_iv_constr MC_le (IVmin (Unsigned Intptr_t)) (IVaddress alloc_id pref) - ; mk_iv_constr MC_le (IVaddress alloc_id pref) (IVmax (Unsigned Intptr_t)) ]) - - - - - -(* TODO: readonly case *) -let impl_allocate_object tid pref (IV _ align_ival_) ty _ init_opt = - fresh_allocation_id >>= fun alloc_id -> - register_address_constraints pref alloc_id (IVsizeof ty) (align_ival_) >> - register_allocation alloc_id (Storage_static pref ty Nothing) >> - let ptr_val = PV (Prov_some (alloc_id, pref)) (PVbase alloc_id pref) [] in - print_debugM 1 (fun () -> - "Allocating (static) with type [" ^ stringFromCtype ty ^ "] alloc_id= " ^ - show alloc_id ^ ": " ^ stringFromPointer_value ptr_val - ) >> (* DEBUG *) - return ptr_val - -(* - (* the allocated object is given a new address (distinct from all other - existing addresses) *) - fresh_address pref >>= fun addr -> - register_distinctness_constraints addr (IVsizeof ty) >> - - fresh_allocation_id >>= fun alloc_id -> - register_allocation alloc_id (Alloc_static ty addr, Nothing (* mkUnspec ty *)) >> - - let ptr_val = PV (Prov_some alloc_id) (PVbase alloc_id pref) [] in - print_debugM 4 (fun () -> "Allocating (static) with type [" ^ stringFromCtype ty ^ "]: " ^ stringFromPointer_value ptr_val) >> (* DEBUG *) - - return ptr_val -*) - - -let impl_allocate_region tid pref (IV _ align_ival_) ((IV _ size_ival_) as size_ival) = - fresh_allocation_id >>= fun alloc_id -> - register_address_constraints pref alloc_id size_ival_ (align_ival_) >> - register_allocation alloc_id (Storage_dynamic pref size_ival_ []) >> - let ptr_val = PV (Prov_some (alloc_id, pref)) (PVbase alloc_id pref) [] in - print_debugM 1 (fun () -> - "Allocating (dynamic) with size [" ^ stringFromInteger_value size_ival ^ "] alloc_id= " ^ - show alloc_id ^ ": " ^ stringFromPointer_value ptr_val - ) >> (* DEBUG *) - return ptr_val - -(* - (* TODO *) - fresh_address pref >>= fun addr -> - register_distinctness_constraints addr size_ival_ >> - - fresh_allocation_id >>= fun alloc_id -> - let unsigned_char = Basic (Integer (Signed Ichar)) in - register_allocation alloc_id (Alloc_dynamic size_ival_, Nothing (* mkUnspec (Array unsigned_char (Just 42 (* TODO !!! *))) *)) >> - - return ( - PV (Prov_some alloc_id) (PVbase alloc_id pref) [] - ) -*) - - -(* TODO: wip *) -let real_address_expression_of_pointer (PV _ ptrval sh) = - let ival_ = match ptrval with - | PVunspecified ty -> - error "real_address_expression_of_pointer, PVunspecified" - | PVnull ty -> - error "real_address_expression_of_pointer, PVnull" - | PVfunction sym -> - error "real_address_expression_of_pointer, PVfunction" - | PVbase alloc_id pref -> - IVaddress alloc_id pref - | PVfromint ival_ -> - ival_ - end in - IVop IntAdd [ival_; integer_value_baseFromShift_path sh] - - -(* TODO: (for statics) this is not doing the right thing *) -(* TODO: by calling real_address_expression_of_pointer, this is now correct *) -val address_expression_of_pointer: impl_pointer_value -> impl_memM integer_value_base -let address_expression_of_pointer ptr_val = - return (real_address_expression_of_pointer ptr_val) - - -let impl_kill loc is_dynamic (PV _ ptr_val_ sh as ptr_val) = - (* TODO: UB if this is a dynamic kill and the pointer wasn't dynamically allocated *) - print_debugM 5 (fun () -> "KILL with pointer value: " ^ stringFromPointer_value ptr_val) >> (* DEBUG *) - explicitAllocationIdFromPointer_value_aux ptr_val_ >>= function - | Just (alloc_id, pref) -> - address_expression_of_pointer ptr_val >>= fun ptr_ival -> - ifM "kill" - (mk_iv_constr MC_eq ptr_ival (IVaddress alloc_id pref)) - begin - (* TODO: turn the live pointers to this alloc_id into unspec values *) - get >>= fun mem_st -> - put <| mem_st with dead_allocations= Set.insert alloc_id mem_st.dead_allocations |> - end - (fail loc (MerrOther "trying to kill with an non-initial pointer")) - | Nothing -> - fail loc (MerrOther "trying to kill with an invalid pointer") - end - - -(* -(* TODO: temporary *) -let structural_equality_provenance prov1 prov2 = - match (prov1, prov2) with - | (Prov_wildcard, Prov_wildcard) -> - true - | (Prov_none, Prov_none) -> - true - | (Prov_device, Prov_device) -> - true - | (Prov_some id1, Prov_some id2) -> - id1 = id2 - | _ -> - false - end - -let rec structural_equality_pointer_value (PV prov1 ptr_val_1 sh1) (PV prov2 ptr_val_2 sh2) = - structural_equality_provenance prov1 prov2 - && structural_equality_pointer_value_base ptr_val_1 ptr_val_2 - && listEqualBy structural_equality_shift_path_element sh1 sh2 - -and structural_equality_pointer_value_base ptr_val_1 ptr_val_2 = - match (ptr_val_1, ptr_val_2) with - | (PVnull ty1, PVnull ty2) -> - ty1 = ty2 - | (PVfunction sym1, PVfunction sym2) -> - sym1 = sym2 - | (PVbase alloc_id1 _, PVbase alloc_id2 _) -> - alloc_id1 = alloc_id2 - | (PVfromint ival_1, PVfromint ival_2) -> - structural_equality_integer_value_base ival_1 ival_2 - | _ -> - false - end - -and structural_equality_shift_path_element spe1 spe2 = - match (spe1, spe2) with - | (SPE_array ty1 ival_1, SPE_array ty2 ival_2) -> - ty1 = ty2 && structural_equality_integer_value_base ival_1 ival_2 - | (SPE_member tag_sym1 memb_ident1, SPE_member tag_sym2 memb_ident2) -> - tag_sym1 = tag_sym2 && memb_ident1 = memb_ident2 - | _ -> - false - end - -and structural_equality_shift_path sh1 sh2 = - List.all (uncurry structural_equality_shift_path_element) (zip sh1 sh2) - -and structural_equality_integer_value_base _ _ = - error "structural_equality_integer_value_base" -*) - - - -val is_affecting: write_event -> ctype -> impl_pointer_value -> impl_memM bool -let is_affection (WriteEvent loc w_ty w_ptr_val mval) r_ty r_ptr_val = -(* - get_allocation_id r_ptr_val >>= fun r_alloc_id_opt -> - get_allocation_id w_ptr_val >>= fun w_alloc_id_opt -> - match (r_alloc_id_opt, w_alloc_id_opt) with - | (Just r_alloc_id, Just w_alloc_id) -> - if r_alloc_id = w_alloc_id then - condM (MC_conj (MC_le_ival_ (offset_ival_ w_ptr_val) (offset_ival_ r_ptr_val)) - (MC_le_ival_ () ()) - else - wip "is_affecting 1" - condM (offset_ival - end -*) - error "is_affecting" - - - - - - - - - - - - - - - - - - - - - - - - - -val fetch_first_write_event: (write_event -> bool) -> impl_memM (maybe write_event) -let rec fetch_first_write_event_aux pred = function - | [] -> - Nothing - | x :: xs -> - if pred x then Just x else fetch_first_write_event_aux pred xs -end -let fetch_first_write_event pred = - wip "fetch_frist_write_event" -(* - get >>= fun st -> - return (fetch_first_write_event_aux pred st.writes) -*) - - - - - - -val apply_shift_path_element: ctype -> shift_path_element -> impl_mem_value -> impl_memM impl_mem_value -let apply_shift_path_element lvalue_ty spe mval = -(* TODO: use lvalue_ty *) - match (spe, mval) with - | (SPE_array elem_ty ival_, MVarray mvals) -> - match eval_integer_value_base ival_ with - | Just n -> - let n = natFromInteger n in - if n < 0 || List.length mvals <= n then - error "Mem.apply_shift_path_element: out of bound array" - else - return (fromJust "Defacto_memory.apply_shift_path_element, SPE_array vs MVarray" $ List.index mvals n) - | Nothing -> - error ("Mem.apply_shift_path_element: symbolic array index ==> " ^ - stringFromInteger_value (IV Prov_none ival_)) - end - | (SPE_array elem_ty ival_, MVpointer _ _) -> -(* - if lvalue_ty <> Basic (Integer (Unsigned Ichar)) then - error ("WIP ==> result_ty <> not unsigned char, SPE_array, MVpointer ===> result_ty = " ^ stringFromCtype result_ty) - else -*) - match lvalue_ty with - | Ctype _ (Basic (Integer lvalue_ity)) -> - return (MVinteger lvalue_ity (IV Prov_none (IVbyteof (mk_op_ival_ IntMul ival_ (IVsizeof elem_ty)) mval))) - | _ -> - error ("WIP ==> lvalue_ty <> not an integer value, SPE_array, MVpointer ===> lvalue_ty = " ^ stringFromCtype lvalue_ty) - end - - | (SPE_member tag_sym memb_ident, MVstruct tag_sym_ xs) -> - if tag_sym <> tag_sym_ then - fail Loc.unknown (MerrOther ("tried to read member of type '" ^ - stringFromCore_ctype (Ctype [] (Struct tag_sym)) ^ - "', but a value of type '" ^ - stringFromCore_ctype (Ctype [] (Struct tag_sym_)) ^ - "' was found.")) - else - return (fromJust "Defacto_memory.apply_shift_path_element, SPE_member vs MVstruct" (List.lookup memb_ident - (List.map (fun (a,_,b) -> (a,b)) xs))) - - | (SPE_member tag_sym memb_ident, MVunion tag_sym_ memb_ident_ mval') -> - if tag_sym <> tag_sym_ then - fail Loc.unknown (MerrOther ("tried to read member of type '" ^ - stringFromCore_ctype (Ctype [] (Union tag_sym)) ^ - "', but a value of type '" ^ - stringFromCore_ctype (Ctype [] (Union tag_sym_)) ^ - "' was found.")) - else -(* - let UnionDef xs = Ctype_aux.get_membersDefs tag_sym in -*) - if memb_ident = memb_ident_ then - return mval' - else - error "TODO: union punning" - - | (SPE_array elem_ty ival_1, MVinteger ity ival_2) -> - error ("lvalue_ty: " ^ stringFromCtype lvalue_ty ^ - ", spe: " ^ stringFromShift_path [spe] ^ - ", ity: " ^ stringFromCtype (Ctype [] (Basic (Integer ity)))) - - | (SPE_array elem_ty offset_ival_, MVdelayed xs under_mval) -> - match xs with - | [(sh, new_mval)] -> - ifM "apply_shift_path_element" - (mk_iv_constr MC_eq (integer_value_baseFromShift_path [SPE_array elem_ty offset_ival_]) - (integer_value_baseFromShift_path sh)) - (return new_mval) - - (* TODO: hack *) - (wip ("Mem.apply_shift_path_element, todo MVdelayed ==> didn't match ==> sh: " ^ - stringFromShift_path [spe] ^ " -- mval: "^ stringFromMem_value mval)) - (* (return (MVinteger (Unsigned Ichar) (IV Prov_none (IVconcrete 142)))) *) - | _ -> - error "Mem.apply_shift_path_element, HELLO KKK" - end - - - | (SPE_array _ _, _) -> - error ("Mem.apply_shift_path_element, SPE_array ==> mval: " ^ - stringFromMem_value mval ^ ", lvalue_ty: " ^ stringFromCtype lvalue_ty) - | (SPE_member _ _, _) -> - error ("Mem.apply_shift_path_element, SPE_member ==> " ^ stringFromMem_value mval) - end - - -(* -let mk_byteof ival_ = function - | MVinteger _ (IV _ IVunspecified) -> - IV - | MVfloating of floatingType * impl_floating_value - | MVpointer of ctype * impl_pointer_value (* the first parameter is the referenced type of the pointer value *) - | MVarray of list impl_mem_value (* INVARIANT: all of the same mem_value constructor and type *) - | MVstruct of Symbol.sym (*struct/union tag*) * list (Cabs.identifier (*member*) * impl_mem_value) - | MVunion of Symbol.sym (*struct/union tag*) * Cabs.identifier (*member*) * impl_mem_value - - | MVdelayed of list (shift_path * impl_mem_value) * impl_mem_value -end -*) - -let project_to_lvalue_type (Ctype _ lvalue_ty) mval = - match (lvalue_ty, mval) with - | (Basic (Integer (Unsigned Ichar)), MVinteger (Unsigned Ichar) _) -> - return mval - - | (Basic (Integer ((Unsigned Ichar) as uchar_ity)), _) -> - let mval_prov = match mval with - | MVinteger _ (IV prov _) -> - prov - | MVpointer _ (PV prov _ _) -> - prov - | _ -> - Prov_none - end in - return (MVinteger uchar_ity (IV mval_prov (IVbyteof (IVconcrete 0) mval))) - - | (Basic (Integer lvalue_ity), MVinteger mval_ity ival) -> - if lvalue_ity = mval_ity then - return mval - - (* TODO: check that we really allow arbitrary bytes accesses like this *) - else match Implementation.sizeof_ity lvalue_ity with - | Nothing -> - error "WIP: project_to_lvalue_type" - | Just size -> - let ival_' = IVcomposite ( - List.map (fun i -> - IVbyteof (IVconcrete (integerFromNat i)) mval - ) (enumFromTo 0 (size-1)) - ) in - return (MVinteger lvalue_ity (IV Prov_none(*TODO*) ival_')) - end - - | (Basic (Floating lvalue_fty), MVfloating mval_fty fval) -> - error "WIP: project_to_lvalue_type floating" - - | (Pointer _ lvalue_ref_ty, MVpointer mval_ref_ty (PV prov _ _)) -> - if lvalue_ref_ty = mval_ref_ty then - return mval - else - error "project_to_lvalue_type: Pointer vs MVpointer, with different referenced types" - - | (_, MVarray mvals) -> - (* TODO: I guess that's not allowed *) - error "WIP: project_to_lvalue_type MVarray" - - | (Struct lvalue_tag_sym, MVstruct mval_tag_sym _) -> - if lvalue_tag_sym = mval_tag_sym then - return mval - else - error "project_to_lvalue_type: Struct vs MVstruct with non-equal tags" - - | (Union lvalue_tag_sym, MVunion mval_tag_sym memb_ident _) -> - if lvalue_tag_sym = mval_tag_sym then - return mval - else - error "project_to_lvalue_type: Union vs MVunion with non-equal tags" - - | (_, MVunion mval_tag memb_ident memb_mval) -> - (* TODO: this implementing that casting a pointer to a union, to - a pointer to one of it's member *) - let (x, xs) = Ctype_aux.get_unionDef mval_tag in - match List.lookup memb_ident (x::xs) with - | Nothing -> - error "project_to_lvalue_type, MVunion was ill-typed (wrong member_ident)" - | Just (_, _, _, Ctype _ memb_ty) -> - if lvalue_ty = memb_ty then - return memb_mval - else - error "TODO: project_to_lvalue_type, union punning" - end - - | _ -> - (* TODO *) - (* return mval *) - let () = Debug.print_debug 1 [] (fun () -> - "lvalue_ty ===> " ^ stringFromCore_ctype (Ctype [] lvalue_ty) ^ - "\nmval ===> " ^ stringFromMem_value mval - ) in - error "TODO: project_to_lvalue_type" - end - - -let apply_shift_path lvalue_ty sh mval = - match sh with - | [] -> - let () = Debug.print_debug 1 [] (fun () -> - "Mem.apply_shift_path, sh == [] ===> " ^ - stringFromMem_value mval - ) in - project_to_lvalue_type lvalue_ty mval - | _ -> - foldlM (fun acc spe -> - apply_shift_path_element lvalue_ty spe acc - ) mval sh (* >>= - project_to_lvalue_type lvalue *) - end - - - - - - - - - - - - - - - - - - - - -let impl_null_ptrval ty = - PV Prov_none (PVnull ty) [] - -let impl_fun_ptrval sym = - PV Prov_none (PVfunction sym) [] - - -(* -val to_shift_path: tag_definitions -> list (ctype * integer_value) -> shift_path -let to_shift_path tagDefs xs = -*) - - -let insert_element_to_path sh spe2 = - match List.dest_init sh with - | Just (sh', spe1) -> - match (spe1, spe2) with - | (SPE_array ty1 ival1, SPE_array ty2 ival2) -> - if ty1 = ty2 then - sh' ++ [SPE_array ty1 (mk_op_ival_ IntAdd ival1 ival2)] - else - List.snoc spe2 sh - | _ -> - List.snoc spe2 sh - end - | Nothing -> - [spe2] - end - -let internal_shift_ptrval ptr_val spe : impl_pointer_value = - match ptr_val with -(* - | PV Prov_none _ -> - Left (MerrOther "attempted to shift a pointer value with no provenance") -*) - | PV prov ptr_val_ sh -> - match get_allocation_id ptr_val_ with - | Just alloc_id -> - (* TODO: there should a be check for when we go out of an object *) - PV prov ptr_val_ (insert_element_to_path sh spe) - | Nothing -> - (* TODO: here we are probably shifting a NULL pointer, so in ISO this is "unclear" *) - (* TODO: add a warning or error in ISO mode *) - PV prov ptr_val_ (insert_element_to_path sh spe) -(* - error ("TODO internal_shift_ptrval: shift 2 ==>" ^ - stringFromPointer_value ptr_val) -*) - end - end - - -let impl_array_shift_ptrval ptr_val ty (IV _ ival_) = - let () = Debug.print_debug 5 [Debug.DB_memory] (fun () -> "Mem.array_shift_ptrval: " ^ stringFromPointer_value ptr_val) in - internal_shift_ptrval ptr_val (SPE_array ty ival_) - -let impl_member_shift_ptrval ptr_val tag_sym memb_ident = - internal_shift_ptrval ptr_val (SPE_member tag_sym memb_ident) - - - - - -let impl_concurRead_ival ity sym = - IV Prov_none (IVconcurRead ity sym) - -let impl_integer_ival n = - IV Prov_none (IVconcrete n) - -let impl_max_ival ity = - IV Prov_none ((*lifted_simplify_integer_value_base*) (IVmax ity)) - -let impl_min_ival ity = - IV Prov_none ((*lifted_simplify_integer_value_base*) (IVmin ity)) - - - - - -let impl_op_ival iop (IV prov1 ival_1) (IV prov2 ival_2) = - IV (combine_prov prov1 prov2) (mk_op_ival_ iop ival_1 ival_2) - -let impl_bitwise_complement_ival ity (IV prov ival_) = - IV prov (IVbitwise ity (BW_complement ival_)) - -let impl_bitwise_and_ival ity (IV prov1 ival_1) (IV prov2 ival_2) = - IV (combine_prov prov1 prov2) (IVbitwise ity (BW_AND ival_1 ival_2)) - -let impl_bitwise_or_ival ity (IV prov1 ival_1) (IV prov2 ival_2) = - IV (combine_prov prov1 prov2) (IVbitwise ity (BW_OR ival_1 ival_2)) - -let impl_bitwise_xor_ival ity (IV prov1 ival_1) (IV prov2 ival_2) = - IV (combine_prov prov1 prov2) (IVbitwise ity (BW_XOR ival_1 ival_2)) - - - -let impl_op_fval fop fval1 fval2 = - match (fval1, fval2) with - | (FVunspecified, _) -> - FVunspecified - | (_, FVunspecified) -> - FVunspecified - | (FVconcrete fval1, FVconcrete fval2) -> - match fop with - | FloatAdd -> FVconcrete (fval1 + fval2) - | FloatSub -> FVconcrete (fval1 - fval2) - | FloatMul -> FVconcrete (fval1 * fval2) - | FloatDiv -> FVconcrete (fval1 / fval2) - end - end - -let impl_eq_fval fval1 fval2 = - match (fval1, fval2) with - | (FVconcrete fval1, FVconcrete fval2) -> - (fval1 = fval2) - | _ -> - error "TODO: Defacto_memory.impl_eq_fval, unspecified" - end - -let impl_lt_fval fval1 fval2 = - match (fval1, fval2) with - | (FVconcrete fval1, FVconcrete fval2) -> - (fval1 < fval2) - | _ -> - error "TODO: Defacto_memory.impl_lt_fval, unspecified" - end - -let impl_le_fval fval1 fval2 = - match (fval1, fval2) with - | (FVconcrete fval1, FVconcrete fval2) -> - (fval1 <= fval2) - | _ -> - error "TODO: Defacto_memory.impl_lt_fval, unspecified" - end - -let impl_fvfromint (IV _ ival_) = - match ival_ with - | IVunspecified -> - FVunspecified - | IVconcrete ival -> - FVconcrete (F.of_integer ival) - | _ -> - error "TODO: Defacto_memory.impl_fvfromint, symbolic integer value" - end - -(* TODO: check type ranges after conversion *) -let impl_ivfromfloat = function - | FVunspecified -> - IV Prov_none IVunspecified - | FVconcrete fval -> - IV Prov_none (IVconcrete (F.to_integer fval)) -end - -let impl_case_integer_value (IV _ ival) fint fother = - match ival with - | IVconcrete n -> - fint n - | _ -> - fother () - end - -let impl_is_specified_ival (IV _ ival) = - match ival with - | IVunspecified -> - false - | _ -> - true -end - -let is_concrete_ival ival = - error "WIP: is_concrete_ival" - - -(* Memory value constructors *) -(* -let symbolic_mval symb = - let () = Debug.print_debug 1 "Mem.symbolic_mval !!!!!" in - MVsymbolic symb -*) - -let impl_unspecified_mval ty = - mkUnspec ty - -let impl_integer_value_mval ity ival = - MVinteger ity ival - -let impl_floating_value_mval fty fval = - MVfloating fty fval - -let impl_pointer_mval ref_ty ptr_val = - MVpointer ref_ty ptr_val - -let impl_array_mval = function - | [] -> - error "Defacto_memory.array_mval, given an empty list" - | mvals -> - MVarray mvals -end - -let impl_struct_mval tag_sym xs = - if List.null xs then - error "Defacto_memory.struct_mval, given an empty list of member values" - else - MVstruct tag_sym xs - -let impl_union_mval tag_sym memb_ident mval = - MVunion tag_sym memb_ident mval - - -(* Memory value destructor *) -let impl_case_mem_value mval funspec (* fsymb *) fconcur fival ffval fptrval farr fstruct funion = - match mval with - | MVinteger ity (IV _ ival_ as ival) -> - match ival_ with - | IVunspecified -> - funspec (Ctype [] (Basic (Integer ity))) - | IVconcurRead ity2 sym -> - (* TODO: check ity1 vs ity2 ? *) - fconcur ity2 sym - | _ -> - fival ity ival - end - | MVfloating fty fval -> - match fval with - | FVunspecified -> - funspec (Ctype [] (Basic (Floating fty))) - | _ -> - ffval fty fval - end - | MVpointer ref_ty (PV _ ptrval_ _ as ptrval) -> - match ptrval_ with - | PVunspecified _ -> - (* TODO: or use the type in PVunspecified? *) - funspec (Ctype [] (Pointer no_qualifiers ref_ty)) - | _ -> - fptrval ref_ty ptrval - end - | MVarray mvals -> - farr mvals - | MVstruct tag_sym xs -> - fstruct tag_sym xs - | MVunion tag_sym memb_ident mval -> - funion tag_sym memb_ident mval - | MVdelayed _ _ -> - error "TODO: Defacto_memory.impl_case_mem_value, MVdelayed" - | MVcomposite _ _ -> - error "TODO: Defacto_memory.impl_case_mem_value, MVcomposite" - end - - -let impl_case_fval fval funspec fconcrete = - match fval with - | FVunspecified -> - funspec () - | FVconcrete str -> - fconcrete str - end - -val impl_zero_fval: impl_floating_value -let impl_zero_fval = - FVconcrete (F.of_int 0) - -val impl_one_fval: impl_floating_value -let impl_one_fval = - FVconcrete (F.of_int 1) - -val impl_str_fval: string -> impl_floating_value -let impl_str_fval str = FVconcrete (F.of_string str) - - -(* -val address_of: allocation -> address -let address_of = function - | Alloc_static _ addr -> - addr - | Alloc_dynamic _ addr -> - addr -end -*) - - -val isEmptyShift: shift_path -> bool -let isEmptyShift = function - | [] -> - true - | _ -> - false -end - -val isBeginningShift: shift_path -> impl_memM bool -let rec isBeginningShift sh = - match sh with - | [] -> - return true - | (SPE_array _ ival_) :: sh' -> - ifM "isBeginningShift" - (mk_iv_constr MC_eq ival_ (IVconcrete 0)) - (isBeginningShift sh') - (return false) - | (SPE_member tag_sym memb_ident) :: sh' -> - let xs = match Ctype_aux.get_membersDefs tag_sym with - | StructDef z Nothing -> z - | StructDef _ (Just _) -> - error "TODO: Defacto_memory.isBeginningShift ==> for struct with flexible array member" - | UnionDef z -> z - end in - match xs with - | [] -> - error "Mem.isBeginningShift, get_membersDefs returning an empty list" - | (memb_ident', _) :: _ -> - return (memb_ident = memb_ident') - end - end - - - - -val is_one_past_pointer: impl_pointer_value -> impl_memM bool -let is_one_past_pointer (PV _ ptr_val_ sh) = - match ptr_val_ with - | PVnull _ -> - return false - | PVfunction _ -> - return false - | _ -> - explicitAllocationIdFromPointer_value_aux ptr_val_ >>= function - | Just (alloc_id, _) -> - resolve_allocation alloc_id >>= fun stor -> - let size_ival_ = match stor with - | Storage_static _ ty _ -> - IVsizeof ty - | Storage_dynamic _ ival_ _ -> - ival_ - end in - (* |sh| = sizeof ty *) - condM "is_one_past_pointer" - (mk_iv_constr MC_eq (integer_value_baseFromShift_path sh) size_ival_) - | Nothing -> - wip "is_one_past_pointer, implicit allocation" - end - end - - -(* -let address_expression_of_pointer (PV _ ptr_val_ sh) = - match ptr_val_ with - | PVnull _ -> - fail (MerrInternal "called [address_expression_of_pointer] on null pointer") - | PVfunction _ -> - fail (MerrInternal "called [address_expression_of_pointer] on function pointer") - | _ -> - explicitAllocationIdFromPointer_value_aux ptr_val_ >>= function - | Just alloc_id -> - resolve_allocation alloc_id >>= function - | Storage_static ty _ -> - return $ mk_op_ival_ IntAdd (IVaddress alloc_id) (IVsizeof ty) - | Storage_dynamic ival_ _ -> - return $ mk_op_ival_ IntAdd (IVaddress alloc_id) ival_ - end - | Nothing -> - wip "address_expression_of_pointer, implicit allocation" - end -end -*) - - - -(* -let rec integerTypes_of_ival ival = - match ival with - | IVconcrete _ -> - Nothing - | IVaddress _ -> - Nothing -(* - | IVfromptr _ _ -> - [Cty.intptr_t; Cty.unintptr_t] -*) - | IVop _ [ival_1; ival_2] -> - - | IVmin ity -> - - | IVmax of integerType - | IVsizeof of ctype - | IValignof of ctype - | IVoffsetof of Symbol.t * Cabs.identifier - | IVptrdiff of pointer_value_base * pointer_value_base - | IVbyteof of integer_value_base * mem_value (* the integer value is the position (indexed from zero) *) - | IVcomposite of list integer_value_base - end -*) - - - - - - -(* WIP *) -let impl_eq_ptrval loc ptr_val1 ptr_val2 = - print_debugM 6 (fun () -> "Mem.eq_ptrval: " ^ stringFromPointer_value ptr_val1 ^ " vs " ^ - stringFromPointer_value ptr_val2) >> - match (ptr_val1, ptr_val2) with - | (PV _ (PVnull _) [], PV _ (PVnull _) []) -> - (* STD §6.5.9#6 *) - return true - | (PV _ (PVnull _) sh1, PV _ (PVnull _) sh2) -> - if false (* ISO mode *) then - (* STD §6.5.9#6 *) - (* TODO: check. I guess not UB here, because the UB should have come when shifting the pointer? *) - return false - else - condM "shifted null pointers equality" - (mk_iv_constr MC_eq (integer_value_baseFromShift_path sh1) - (integer_value_baseFromShift_path sh2)) - | (PV _ (PVfunction sym1) [], PV _ (PVfunction sym2) []) -> - return (sym1 = sym2) - | (PV _ (PVnull _) _, _) -> - (* STD §6.5.9#6 *) - return false - | (_, PV _ (PVnull _) _) -> - (* STD §6.5.9#6 *) - return false - - | (PV prov1 ptr_val1_ sh1, PV prov2 ptr_val2_ sh2) -> - let do_honest_equality = - address_expression_of_pointer ptr_val1 >>= fun addr_ival_1 -> - address_expression_of_pointer ptr_val2 >>= fun addr_ival_2 -> - condM "honest pointer equality" - (mk_iv_constr MC_eq addr_ival_1 addr_ival_2) in - match (prov1, prov2) with - | (Prov_some alloc_id1, Prov_some alloc_id2) -> - ifFlag Allow_disjoint_alloc_tests - (* defacto flag *) - begin - if alloc_id1 = alloc_id2 then - do_honest_equality - else - Nondeterminism.msum "pointer equality" - [ ("using provenance", return false) - ; ("ignoring provenance", do_honest_equality) ] - end - - (* STD case *) - begin - if alloc_id1 = alloc_id2 then - (* this tests that at least one pointer is to a base object and the two - is to either also to that base object or a beginning subobject *) - if isEmptyShift sh1 then isBeginningShift sh2 - else if isEmptyShift sh2 then isBeginningShift sh1 - else - (* the pointers are to a same subobject *) - return (sh1 = sh2) - - else - is_one_past_pointer ptr_val1 >>= function - | true -> - address_expression_of_pointer ptr_val1 >>= fun addr_ival_1 -> - address_expression_of_pointer ptr_val2 >>= fun addr_ival_2 -> - condM "eq_ptrval - left is one past" - (mk_iv_constr MC_eq addr_ival_1 addr_ival_2) - | false -> - is_one_past_pointer ptr_val2 >>= function - | true -> - address_expression_of_pointer ptr_val1 >>= fun addr_ival_1 -> - address_expression_of_pointer ptr_val2 >>= fun addr_ival_2 -> - condM "eq_ptrval - right is one past" - (mk_iv_constr MC_eq addr_ival_1 addr_ival_2) - | false -> - return false - end - end - end - | (Prov_some _, _) -> - do_honest_equality - | (_, Prov_some _) -> - do_honest_equality - | _ -> - error "WIP: Mem.eq_ptrval, not (Just alloc_id1, Just alloc_id2)" - end - end - - -let rec silly_sh_eq sh1 sh2 = - match (sh1, sh2) with - | ([], []) -> - Just true - | (SPE_array ty1 ival_1 :: sh1', SPE_array ty2 ival_2 :: sh2') -> - if ty1 = ty2 then - match (eval_integer_value_base ival_1, eval_integer_value_base ival_2) with - | (Just n1, Just n2) -> - if n1 = n2 then silly_sh_eq sh1' sh2' else Nothing - | _ -> - Nothing - end - else - Nothing - | (SPE_member tag_sym1 membr_ident1 :: sh1', SPE_member tag_sym2 membr_ident2 :: sh2') -> - if tag_sym1 = tag_sym2 && membr_ident1 = membr_ident2 then - silly_sh_eq sh1' sh2' - else - Nothing - | _ -> - Just false - end - -(* TODO: more .... *) -let impl_ne_ptrval loc (PV prov1 ptr_val_1 sh1 as ptrval1) (PV prov2 ptr_val_2 sh2 as ptrval2) = - match (ptr_val_1, ptr_val_2) with - | (PVnull _, PVnull _)-> - return false - | (PVnull _, PVbase _ _) -> - return true - | (PVbase _ _, PVnull _) -> - return true - | (PVbase alloc_id1 _, PVbase alloc_id2 _) -> - if sh1 = [] && sh2 = [] then - return (alloc_id1 <> alloc_id2) - else - match (silly_sh_eq sh1 sh2) with - | Just true -> - return (alloc_id1 <> alloc_id2) - | _ -> - error ("WIP(1): ne_ptrval ==> " ^ stringFromPointer_value ptrval1 ^ " <|> " ^ stringFromPointer_value ptrval2) - end - - - | _ -> - error ("WIP(2): ne_ptrval ==> " ^ stringFromPointer_value ptrval1 ^ " <|> " ^ stringFromPointer_value ptrval2) - end - - - - -let impl_lt_ptrval loc ptrval1 ptrval2 = - let ival_1 = real_address_expression_of_pointer ptrval1 in - let ival_2 = real_address_expression_of_pointer ptrval2 in - condM "lt_ptrval" (mk_iv_constr MC_lt ival_1 ival_2) - -let impl_gt_ptrval loc ptrval1 ptrval2 = - let ival_1 = real_address_expression_of_pointer ptrval1 in - let ival_2 = real_address_expression_of_pointer ptrval2 in - condM "gt_ptrval" (mk_iv_constr MC_lt ival_2 ival_1) - -let impl_le_ptrval loc ptrval1 ptrval2 = - let ival_1 = real_address_expression_of_pointer ptrval1 in - let ival_2 = real_address_expression_of_pointer ptrval2 in - condM "le_ptrval" (mk_iv_constr MC_le ival_1 ival_2) - -let impl_ge_ptrval loc ptrval1 ptrval2 = - let ival_1 = real_address_expression_of_pointer ptrval1 in - let ival_2 = real_address_expression_of_pointer ptrval2 in - condM "ge_ptrval" (mk_iv_constr MC_le ival_2 ival_1) - - - -(* -When two pointers are subtracted, both shall point to elements of the same array object, or one past the last element of the array object; - -If the result is not representable in an object of that type, the behavior is undefined. - -*) - - -(* TODO: check that, std says: -Moreover, if the expression P points either to an element of an array object or -one past the last element of an array object, and the expression Q points to the -last element of the same array object, the expression ((Q)+1)-(P) has the same -value as ((Q)-(P))+1 and as -((P)-((Q)+1)), and has the value zero if the -expression P points one past the last element of the array object, even though -the expression (Q)+1 does not point to an element of the array object. -*) -(* STD §6.5.6#9 *) -let impl_diff_ptrval loc ty ptrval1 ptrval2 : impl_memM impl_integer_value = - match (ptrval1, ptrval2) with - | (PV (Prov_some (alloc_id1, _)) ptr_val_1 sh1, PV (Prov_some (alloc_id2, _)) ptr_val_2 sh2) -> - if alloc_id1 = alloc_id2 then - address_expression_of_pointer ptrval1 >>= fun ival1 -> - address_expression_of_pointer ptrval2 >>= fun ival2 -> - resolve_allocation alloc_id1 >>= function - | Storage_static pref1 ty _ -> - (* STD §6.5.9#9 sentence1 *) - ifM "diff_ptrval_6.5.9#9__sentence_1" - (MC_conj [ mk_iv_constr MC_le (IVaddress alloc_id1 pref1) ival1 - ; mk_iv_constr MC_le ival1 (IVop IntAdd [IVaddress alloc_id1 pref1; IVsizeof ty]) - ; mk_iv_constr MC_le (IVaddress alloc_id1 pref1) ival2 - ; mk_iv_constr MC_le ival2 (IVop IntAdd [IVaddress alloc_id1 pref1; IVsizeof ty]) ]) - (* NOTE: the result of subtraction of two pointer values is an integer value with - empty provenance, irrespective of the operand provenances *) - (return (IV Prov_none (IVptrdiff ty (ptr_val_1, sh1) (ptr_val_2, sh2)))) - (print_debugM 1 (fun () -> "MerrPtrdiff 1") >> fail loc MerrPtrdiff) - | Storage_dynamic _ _ _ -> - error "Mem.impl_diff_ptrval, Storage_dynamic" - end - else - print_debugM 1 (fun () -> "MerrPtrdiff 2 ==> alloc_id1=" ^ show alloc_id1 ^ "; alloc_id2= " ^ show alloc_id2) >> - fail loc MerrPtrdiff - | _ -> - print_debugM 1 (fun () -> "MerrPtrdiff 3") >> fail loc MerrPtrdiff - end - - - - -(* TODO: looks too simple to be true *) -let impl_intcast_ptrval loc ref_ty ity ((PV prov ptr_val_ sh) as ptrval) = - let ival = IV prov (IVfromptr ref_ty ity ptr_val_ sh) in - match ity with - | Signed Intptr_t -> - return ival - | Unsigned Intptr_t -> - return ival - | Unsigned Long -> - (* TODO: check that it's ok to assume intptr_t to caracterise the - size of pointers *) - (* TODO: maybe we should have a flag *) - (*let intptr_t = - Basic (Integer (Signed Intptr_t)) in - let unsigned_long = - Basic (Integer (Unsigned Long)) in *) - - (* TODO: unsure about this *) - let unsigned_long_ity = Unsigned Long in - address_expression_of_pointer ptrval >>= fun ptr_ival_ -> - ifM "intcast_ptrval (unsigned long)" - (MC_conj [ mk_iv_constr MC_le (IVmin unsigned_long_ity) ptr_ival_ - ; mk_iv_constr MC_le ptr_ival_ (IVmax unsigned_long_ity) ]) - (return ival) - (fail loc (MerrWIP "casting a pointer to unsigned long, but the type is too small")) -(* - ifM "intcast_ptrval (unsigned long)" - (mk_iv_constr MC_le (IVsizeof intptr_t) (IVsizeof unsigned_long)) - (return ival) - (fail (MerrWIP "casting a pointer to unsigned long, but the type is too small")) -*) - | _ -> - fail loc (MerrWIP "casting a pointer to an invalid integer type") - end - -let impl_validForDeref_ptrval ref_ty ptr_val = - let () = Debug.warn [] (fun () -> - "Mem.impl_validForDeref_ptrval IS WRONG" - ) in - return true - -let impl_isWellAligned_ptrval ref_ty ptr_val = - error "TODO: Symbolic defacto, isWellAligned_ptrval" - - -(* integer types minimal range (STD Annex E #1) *) -val minimal_range: integerType -> bool * integer * integer -let minimal_range ity = - let (min,max) = integer_range ity in - (true, min, max) - - -let impl_eq_ival (IV prov1 ival_1) (IV prov2 ival_2) = - match (ival_1, ival_2) with - | (IVconcrete n1, IVconcrete n2) -> - Just (n1 = n2) - | _ -> - Nothing - end - - - -let impl_lt_ival (IV prov1 ival_1) (IV prov2 ival_2) = - let ival_1' = lifted_simplify_integer_value_base ival_1 in - let ival_2' = lifted_simplify_integer_value_base ival_2 in - match (ival_1', ival_2') with - | (IVconcrete n1, IVconcrete n2) -> - Just (n1 < n2) - - | (IVfromptr _ ity1 _ _, IVmin ity2) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, not (Ivfromptr(ref_ty, ptrval) < Ivmin(\"intptr_t\"))" - ) in - if ity1 = ity2 then - Just false - else - Nothing - - | (IVmax ity1, IVfromptr _ ity2 _ _) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, Ivmax(\"intptr_t\") < Ivfromptr(ref_ty, ptrval)" - ) in - if ity1 = ity2 then - Just false - else - Nothing -(* - | (IVfromptr _ (Signed Intptr_t) _, IVmin (Signed Intptr_t)) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, not (Ivfromptr(ref_ty, ptrval) < Ivmin(\"intptr_t\"))" - ) in - Just false - - | (IVfromptr _ (Unsigned Intptr_t) _, IVmin (Unsigned Intptr_t)) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, Ivfromptr(ref_ty, ptrval) < Ivmin(\"uintptr_t\")" - ) in - Just false - - | (IVmax (Signed Intptr_t), IVfromptr _ (Signed Intptr_t) _) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, Ivmax(\"intptr_t\") < Ivfromptr(ref_ty, ptrval)" - ) in - Just false - - | (IVmax (Unsigned Intptr_t), IVfromptr _ (Unsigned Intptr_t) _) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, Ivmax(\"uintptr_t\") < Ivfromptr(ref_ty, ptrval)" - ) in - Just false -*) - | (IVbitwise ity1 _, IVmin ity2) -> - if ity1 = ity2 then - Just false - else - Nothing - | (IVmax ity1, IVbitwise ity2 _) -> - if ity1 = ity2 then - Just false - else - Nothing - - | (IVconcrete n, IVsizeof _) -> - if n <= 0 then - Just true - else - Nothing - - | (IVmin _, IVsizeof _) -> - let () = Debug.warn [Debug.DB_memory] (fun () -> "assuming that no integer type has a strictly positive minimal value") in - Just true - | (IVmin _, IValignof _) -> - let () = Debug.warn [Debug.DB_memory] (fun () -> "assuming that no integer type has a strictly positive minimal value") in - Just true - - | (IVconcrete n, IVoffsetof tag_sym membr_ident) -> - error "WIP" -(* - if n <= 0 then - match get_membersDefs tag_sym with - | (ident', _)::_ -> - if membr_ident = ident' then - (* TODO: assuming no prefix padding *) - Just false - else - Just true - | _ -> - error "Mem.lt_ival, get_membersDefs returned an empty list" - end - else - Nothing -*) - - | (IVmin ity, IVconcrete n) -> - let (is_exact, min, _) = minimal_range ity in - if is_exact then - Just (min < n) - else - if min < n then - Just true - else - Nothing - - | (IVconcrete n, IVmax ity) -> - let (is_exact, _, max) = minimal_range ity in - if is_exact then - Just (n < max) - else - if n < max then - Just true - else - Nothing - - | _ -> - let ival_1'' = lifted_simplify_integer_value_base ival_1' in - let ival_2'' = lifted_simplify_integer_value_base ival_2' in - match (ival_1'', ival_2'') with - | (IVconcrete n1, IVconcrete n2) -> - Just (n1 < n2) - | _ -> - (* TODO *) - Nothing - end - end - - -(* TODO: temporary hack for concurrency (need to use a sat solver) *) -let rec has_concurRead ival_ = - match ival_ with - | IVunspecified -> - false - | IVconcurRead _ _ -> - true - | IVconcrete _ -> - false - | IVaddress _ _ -> - false - | IVfromptr _ _ _ _ -> - false - | IVop _ ival_s -> - List.any has_concurRead ival_s - | IVmin _ -> - false - | IVmax _ -> - false - | IVsizeof _ -> - false - | IValignof _ -> - false - | IVoffsetof _ _ -> - false - | IVpadding _ _ -> - false - | IVptrdiff _ _ _ -> - false - | IVbyteof _ _ -> - false - | IVcomposite ival_s -> - List.any has_concurRead ival_s - | IVbitwise _ (BW_complement ival_) -> - has_concurRead ival_ - | IVbitwise _ (BW_AND ival_1 ival_2) -> - has_concurRead ival_1 || has_concurRead ival_2 - | IVbitwise _ (BW_OR ival_1 ival_2) -> - has_concurRead ival_1 || has_concurRead ival_2 - | IVbitwise _ (BW_XOR ival_1 ival_2) -> - has_concurRead ival_1 || has_concurRead ival_2 - end - - -let impl_le_ival (IV _ ival_1 as ival1) (IV _ ival_2 as ival2) = - let () = Debug.print_debug 1 [] (fun () -> - "impl_le_ival ==> " ^ stringFromInteger_value ival1 ^ " -- " ^ - stringFromInteger_value ival2 - ) in - match impl_lt_ival ival1 ival2 with - | Just true -> - Just true - | _ -> - let ival_1' = lifted_simplify_integer_value_base ival_1 in - let ival_2' = lifted_simplify_integer_value_base ival_2 in - match (ival_1', ival_2') with - | (IVconcrete n1, IVconcrete n2) -> - Just (n1 = n2) - - | (IVmin ity1, IVfromptr _ ity2 _ _) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, Ivmin(\"intptr_t\") <= Ivfromptr(ref_ty, ptrval)" - ) in - if ity1 = ity2 then - Just true - else - let () = Debug.print_debug 1 [] (fun () -> - "impl_le_ival (IVmin vs IVfromptr) ==> " ^ stringFromInteger_value ival1 ^ " -- " ^ - stringFromInteger_value ival2 - ) in - Nothing - | (IVfromptr _ ity1 _ _, IVmax ity2) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, Ivfromptr(ref_ty, ptrval) <= Ivmax(\"intptr_t\")" - ) in - if ity1 = ity2 then - Just true - else - Nothing - - -(* - | (IVmin (Signed Intptr_t), IVfromptr _ (Signed Intptr_t) _) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, Ivmin(\"intptr_t\") <= Ivfromptr(ref_ty, ptrval)" - ) in - Just true - - | (IVmin (Unsigned Intptr_t), IVfromptr _ (Unsigned Intptr_t) _) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, Ivmin(\"uintptr_t\") <= Ivfromptr(ref_ty, ptrval)" - ) in - Just true - - | (IVfromptr _ (Signed Intptr_t) _, IVmax (Signed Intptr_t)) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, Ivfromptr(ref_ty, ptrval) <= Ivmax(\"intptr_t\")" - ) in - Just true - - | (IVfromptr _ (Signed Intptr_t) _, IVmax (Unsigned Intptr_t)) -> - let () = Debug.print_debug 3 [Debug.DB_memory] (fun () -> - "using axiom ==> forall ref_ty ptrval, Ivfromptr(ref_ty, ptrval) <= Ivmax(\"uintptr_t\")" - ) in - Just true -*) - | (IVmin ity, IVbitwise ity' _) -> - if ity = ity' then - Just true - else - Nothing - | (IVbitwise ity _, IVmax ity') -> - if ity = ity' then - Just true - else - Nothing - - | (IVmin ity, IVconcurRead ity' _) -> - if ity = ity' then - Just true - else - Nothing - | (IVconcurRead ity' _, IVmax ity) -> - if ity = ity' then - Just true - else - Nothing - - | (IVmin ity, IVconcrete n) -> - let (is_exact, min, _) = minimal_range ity in - if is_exact then - Just (min <= n) - else - if min <= n then - Just true - else - Nothing - - | (IVconcrete n, IVsizeof _) -> - if n <= 0 then - Just true - else - Nothing - | (IVmin _, IVsizeof _) -> - let () = Debug.warn [Debug.DB_memory] (fun () -> "assuming that no integer type has a strictly positive minimal value") in - Just true - | (IVmin _, IValignof _) -> - let () = Debug.warn [Debug.DB_memory] (fun () -> "assuming that no integer type has a strictly positive minimal value") in - Just true - - - | (IVconcrete n, IVmax ity) -> - let (is_exact, _, max) = minimal_range ity in - if is_exact then - Just (n <= max) - else - if n <= max then - Just true - else - Nothing - - | (IVmin (Size_t), IVoffsetof tag_sym membr_ident) -> - let () = Debug.warn [Debug.DB_memory] (fun () -> "we are assuming that struct/union type '" ^ show tag_sym ^ - "' isn't so big the offset to member '" ^ show membr_ident ^ - "' is representable in size_t") in - (* TODO: check that *) - Just true - | (IVoffsetof tag_sym membr_ident, IVmax (Size_t)) -> - let () = Debug.warn [Debug.DB_memory] (fun () -> "we are assuming that struct/union type '" ^ show tag_sym ^ - "' isn't so big the offset to member '" ^ show membr_ident ^ - "' is representable in size_t") in - Just true - - - - | (IVconcrete n, IVoffsetof tag_sym membr_ident) -> - if n <= 0 then - Just true - else - Nothing - - (* a byte always range over uchar *) - | (IVmin (Unsigned Ichar), IVbyteof _ _) -> - Just true - | (IVbyteof _ _, IVmax (Unsigned Ichar)) -> - Just true - - | (IVmin (Signed Int_), IVbyteof _ _) -> - let () = Debug.warn [Debug.DB_memory] (fun () -> "TODO: check + document") in - Just true - | (IVbyteof _ _, IVmax (Signed Int_)) -> - let () = Debug.warn [Debug.DB_memory] (fun () -> "TODO: check + document") in - Just true - - (* sizeof and alignof are always in range of size_t *) -(* - | (IVmin Size_t, IVsizeof _) -> - Just true -*) - | (IVsizeof _, IVmax Size_t) -> - Just true -(* - | (IVmin Size_t, IValignof _) -> - Just true -*) - | (IValignof _, IVmax Size_t) -> - Just true - - | (IVop IntSub [IVoffsetof tag_sym1 membr_ident1; IVoffsetof tag_sym2 membr_ident2], IVmax Size_t) -> - if tag_sym1 = tag_sym2 then - let () = Debug.warn [Debug.DB_memory] (fun () -> "we are assuming that the delta between members '" ^ show membr_ident1 ^ - "' and '" ^ show membr_ident2 ^ "' of struct/union type '" ^ show tag_sym1 ^ - "' is representable in size_t") in - Just true - else - Nothing - | (IVconcrete n, IVop IntSub [IVoffsetof tag_sym1 membr_ident1; IVoffsetof tag_sym2 membr_ident2]) -> - if n <= 0 then - Just true - else - Nothing - - | (IVsizeof (Ctype _ (Pointer _ _)), IVmax _) -> - let () = Debug.warn [Debug.DB_memory] (fun () -> "TODO: document") in - Just true - - - - - - - - - - - - - - - | _ -> - let ival_1'' = lifted_simplify_integer_value_base ival_1' in - let ival_2'' = lifted_simplify_integer_value_base ival_2' in - match (ival_1'', ival_2'') with - | (IVconcrete n1, IVconcrete n2) -> - Just (n1 <= n2) -(* !!!!!! BEGIN HACK FOR CONCURRENCY, WILL FIX LATER *) - | (IVmin _, _) -> - Just true (* if has_concurRead ival_2'' then Just true else Nothing *) - | (_, IVmax _) -> - Just true (* if has_concurRead ival_1'' then Just true else Nothing *) -(* !!!!!! END HACK FOR CONCURRENCY, WILL FIX LATER *) - | _ -> - (* TODO *) - Nothing - end - end - end - - - -(* Converting an integer value into a pointer value *) -(* -let impl_ptrcast_ival int_ty ref_ty (IV prov ival_) = - (* TODO: check the types *) - match ival_ with - | IVfromptr ty ity ptrval_ -> - (* The integer value was made from an pointer value. the provenance is passed on *) - return (PV prov ptrval_ []) - | _ -> - ifM "ptrcast_ival, null pointer" - (mk_iv_constr MC_eq ival_ (IVconcrete 0)) - (* if the integer value is zero, then we make a null pointer (see Q28 in notes30) *) - (return (impl_null_ptrval ref_ty)) - - begin - ifM "ptrcast_ival, device pointer" - (MC_in_device (IV Prov_none ival_)) - (* if the integer value is within the device memory range *) - (return (PV Prov_device (PVfromint ival_) [])) - (* otherwise we produce a runtime error (check with P) *) - (fail (MerrWIP "tried to cast to a pointer type an (non device) integer value non-equal to zero")) - end - end -*) -let impl_ptrcast_ival loc int_ty ref_ty ival = - (* TODO: check the types *) - match ival with - | IV prov (IVfromptr ty ity ptrval_ sh) -> - (* The integer value was made from an pointer value. the provenance is passed on *) - return (PV prov ptrval_ sh) - | IV (Prov_some _ as prov) ival_ -> - return (PV prov (PVfromint ival_) []) - | IV _ ival_ -> - ifM "ptrcast_ival, null pointer" - (mk_iv_constr MC_eq ival_ (IVconcrete 0)) - (* if the integer value is zero, then we make a null pointer (see Q28 in notes30) *) - (return (impl_null_ptrval ref_ty)) - - begin - ifM "ptrcast_ival, device pointer" - (MC_in_device (IV Prov_none ival_)) - (* if the integer value is within the device memory range *) - (return (PV Prov_device (PVfromint ival_) [])) - (* otherwise we produce a runtime error (check with P) *) - (fail loc (MerrWIP "tried to cast to a pointer type an (non device) integer value non-equal to zero")) - end - end - -let impl_bytefromint ival = ival - -let impl_intfrombyte ival = ival - - - - - - - - - -(* ============================================================================================== *) - - - -let get_allocation_size alloc_id = - get >>= fun st -> - match Map.lookup alloc_id st.allocations with - | Just (Storage_static _ ty _) -> - return (IVsizeof ty) - | Just (Storage_dynamic _ ival_ _) -> - return ival_ - | Nothing -> - error "Mem.get_allocation_size: TODO make it an error in the monad" - end - - -(* Decide whether a given pointer value can be use to perform a store *) -val can_store: Loc.t -> impl_pointer_value -> impl_memM (either access_error allocation_id) -let can_store loc (PV prov ptr_val_ sh as ptr_val) = - match ptr_val_ with - (* null and function pointers obviously can't be used for stores. *) - | PVnull _ -> return (Left NullPtr) - | PVfunction _ -> return (Left FunctionPtr) - - (* by WF-invariants, we have a pointer to an object *) - | _ -> - explicitAllocationIdFromPointer_value_aux ptr_val_ >>= function - | Just (alloc_id, pref) -> - is_dead alloc_id >>= function - | true -> - let () = Debug.print_debug 5 [Debug.DB_memory] (fun () -> - "CAN'T STORE : is_dead ==> " ^ stringFromPointer_value ptr_val - ) in - (* can't store with a pointer to an object whose lifetime ended. *) - return (Left DeadPtr) - | false -> - (* add the constraint that the ptr is inside the object *) - get_allocation_size alloc_id >>= fun size_ival_ -> - -let () = Debug.print_debug 1 [] (fun () -> - "CAN STORE size_ival_ ===> " ^ stringFromInteger_value (IV Prov_none size_ival_) - -) in - - let ptr_ival_ = real_address_expression_of_pointer ptr_val in - ifM ("can_store[" ^ Loc.stringFromLocation loc ^ "]") - (MC_conj [ mk_iv_constr MC_le (IVaddress alloc_id pref) ptr_ival_ - ; mk_iv_constr MC_lt ptr_ival_ (IVop IntAdd [IVaddress alloc_id pref; size_ival_]) ]) - (return (Right alloc_id)) - (return (Left OutOfBoundPtr)) - end - - (* we couldn't find an explicit allocation event *) - | Nothing -> - error "WIP: can_store ==> don't know how to deal with the absence of explicit allocation id for now." - end - end - - - - - -let rec find_array_index size i ival_ = - if i >= size then - (fail Loc.unknown (MerrOther "find_array_index failed")) - else - ifM "find_array_index" - (mk_iv_constr MC_eq ival_ (IVconcrete (integerFromNat i))) - (return i) - (find_array_index size (i+1) ival_) - - -(* TODO: bug HOL -- "failure in internal translation to tupled format" *) -(* TODO: with temporary simplification *) -val easy_update_mem_value_aux: - Loc.t -> bool -> ctype -> shift_path -> impl_mem_value -> impl_mem_value -> - impl_memM impl_mem_value -let rec easy_update_mem_value_aux loc is_strong write_ty sh write_mval current_mval = - let () = Debug.print_debug 2 [Debug.DB_memory] (fun () -> - "ENTERING: easy_update_mem_value_aux\n" ^ - "current_mval ==> " ^ stringFromMem_value current_mval ^ "\n" ^ - "sh ==> " ^ stringFromShift_path sh - ) in - let easy_update_mem_value_aux = easy_update_mem_value_aux loc is_strong in - match (current_mval, sh) with - | (_, []) -> - (* SIMPLIFICATION: we assume that the footprint of the new value covers all of the old value *) - return write_mval - | (MVarray mvals, SPE_array elem_ty ival_ :: sh') -> - match Maybe.map natFromInteger (eval_integer_value_base ival_) with - | Just n -> - if 0 <= n && n < List.length mvals then - let () = Debug.print_debug 2 [Debug.DB_memory] (fun () -> - "EXITING: easy_update_mem_value_aux, MVarray" - ) in - match List.index mvals n with - | Just at_n_mval -> - easy_update_mem_value_aux write_ty sh' write_mval at_n_mval >>= fun at_n_mval' -> - return (MVarray (List.update mvals n at_n_mval')) - | Nothing -> - (* NOTE: this is impossible *) - fail loc (MerrInternal "easy_update_mem_value_aux, out of array index") - end - else - (* TODO: if this can actually happen, then the error needs to be in the monad? *) - error "easy_update_mem_value_aux ==> concrete SPE_array was out of bound" - | Nothing -> - find_array_index (List.length mvals) 0 ival_ >>= fun n -> - match List.index mvals n with - | Just at_n_mval -> - easy_update_mem_value_aux write_ty sh' write_mval at_n_mval >>= fun at_n_mval' -> - return (MVarray (List.update mvals n at_n_mval')) - | Nothing -> - (* NOTE: this is impossible *) - fail loc (MerrInternal "easy_update_mem_value_aux, out of array index (symb)") - end - end - | (MVstruct tag_sym xs, SPE_member tag_sym_ memb_ident :: sh') -> - if tag_sym <> tag_sym_ then - error "WIP[easy_update_mem_value_aux]: TODO error message ===> struct value accessed with incompatible SPE" - else - let () = Debug.print_debug 2 [Debug.DB_memory] (fun () -> "EXITING: easy_update_mem_value_aux, MVstruct") in - MVstruct tag_sym <$> - mapM (fun (ident, memb_ty, memb_mval) -> - easy_update_mem_value_aux write_ty sh' write_mval memb_mval >>= fun memb_mval -> - return (ident, memb_ty, memb_mval) - ) xs - - | (MVunion tag_sym old_memb_ident old_memb_mval, SPE_member tag_sym_ new_memb_ident :: sh') -> - if tag_sym <> tag_sym_ then - error "WIP[easy_update_mem_value_aux]: TODO error message ===> union value stored \ - with incompatible SPE_member tag" - else - let (x, xs) = Ctype_aux.get_unionDef tag_sym in - match List.lookup new_memb_ident (x::xs) with - | Nothing -> - error "WIP[easy_update_mem_value_aux]: TODO error message ===> union value stored with \ - incompatible SPE_member memb_ident" - | Just _ -> - easy_update_mem_value_aux write_ty sh' write_mval old_memb_mval >>= fun new_memb_mval -> - return (MVunion tag_sym new_memb_ident new_memb_mval) - end - - | _ -> - if is_strong then - match sh with - | SPE_member tag_sym memb_ident :: sh' -> - (* TODO(check) ignoring potential flexible array member, because we are dealing with a struct as value *) - MVstruct tag_sym <$> - mapM (fun (ident, (_, _, _, ty)) -> - if ident = memb_ident then - easy_update_mem_value_aux write_ty sh' write_mval (mkUnspec ty) >>= fun mval' -> - return (ident, ty, mval') - else - return (ident, ty, mkUnspec ty) - ) (fst (Ctype_aux.get_structDef tag_sym)) - | _ -> - error "WIP: easy_update_mem_value_aux, _, is_strong" - end - else -(* TODO: this might need to be before the test on "is_strong" *) - match sh with - | [SPE_array (Ctype _ (Basic (Integer (Unsigned Ichar)))) byte_ival_] -> - return (MVdelayed [(sh, write_mval)] current_mval) -(* - match write_mval with - | MVinteger _ write_ival -> - MVcomposite [(mk_op_ival_ IntMul byte_ival_ (IVsizeof spe_ty), write_ival)] current_mval - | _ -> - error ("TODO: easy_update_mem_value_aux: object repr access; current_mval = " ^ stringFromMem_value current_mval) - end -*) - - | _ -> - (* *) - - - let () = Debug.print_debug 1 [] (fun () -> - "loc = " ^ Loc.stringFromLocation loc ^ "\n" ^ - "sh = " ^ stringFromShift_path sh ^ "\n" ^ - "current_mval = " ^ stringFromMem_value current_mval - ) in - error "WIP: easy_update_mem_value_aux" - end - end - -(* TODO: bug HOL -- "failure in internal translation to tupled format" *) -declare hol target_rep function easy_update_mem_value_aux = - `tags$easy_update_mem_value_aux` - - -val easy_update_mem_value: bool -> write_event -> impl_mem_value -> impl_memM impl_mem_value -let easy_update_mem_value is_strong (WriteEvent loc write_ty (PV prov ptr_val_ sh as ptr_val) write_mval) current_mval = - (*DEBUG*)let () = Debug.print_debug 2 [Debug.DB_memory] (fun () -> - "easy_update_mem_value: ptrval=" ^ stringFromPointer_value ptr_val ^ ", mval= " ^ stringFromMem_value write_mval - ) in - easy_update_mem_value_aux loc is_strong write_ty sh write_mval current_mval >>= fun ret -> - (*DEBUG*)let () = Debug.print_debug 2 [Debug.DB_memory] (fun () -> - "DONE WITH easy_update_mem_value: ptrval=" ^ stringFromPointer_value ptr_val ^ ", mval= " ^ stringFromMem_value write_mval - ) in - return ret - - - - -(* update the memory state with a write event for a given allocation id *) -val register_write_event: allocation_id -> write_event -> impl_memM unit -let register_write_event alloc_id (WriteEvent loc _ _ mval as w) = - (*DEBUG*)print_debugM 5 (fun () -> "REGISTER_WRITE_EVENT: " ^ stringFromMem_value mval) >> - get >>= fun st -> - match Map.lookup alloc_id st.allocations with - | Just (Storage_static pref obj_ty current) -> - let is_strong = false in - let current_mval = match current with - | Just current_mval -> - current_mval - | Nothing -> - mkUnspec obj_ty - end in - easy_update_mem_value is_strong w current_mval >>= fun new_mval -> - put <| st with allocations= - Map.insert alloc_id (Storage_static pref obj_ty (Just new_mval)) st.allocations - |> - | Just (Storage_dynamic pref size_ival_ ws) -> - (* TODO: check that the write offset is within range? *) - put <| st with allocations= - Map.insert alloc_id (Storage_dynamic pref size_ival_ (w :: ws)) st.allocations - |> - - | Nothing -> - error "Mem.register_write_event, Nothing" - end >> - print_debugM 5 (fun () -> "EXITING register_write_event") - - - - -val perform_access: forall 'a. access_kind -> Loc.t -> ctype -> impl_pointer_value -> - (allocation_id -> impl_memM 'a) -> - impl_memM 'a -> - impl_memM 'a -let perform_access accessKind loc lvalue_ty ptrval do_normal do_device = - match ptrval with - (* null and function pointers obviously can't be used for accesses. *) - | PV _ (PVnull _) _ -> fail loc (MerrAccess accessKind NullPtr) - | PV _ (PVfunction _) _ -> fail loc (MerrAccess accessKind FunctionPtr) - - | PV Prov_none _ _ -> fail loc (MerrAccess accessKind NoProvPtr) - - (* by WF-invariants, we have a pointer to an object *) - | (PV (Prov_some (alloc_id, pref)) _ _ as ptrval) -> - is_dead alloc_id >>= function - | true -> - let () = Debug.print_debug 5 [Debug.DB_memory] (fun () -> - "CAN'T ACCESS : is_dead ==> " ^ stringFromPointer_value ptrval - ) in - (* can't store with a pointer to an object whose lifetime ended. *) - fail loc (MerrAccess accessKind DeadPtr) - | false -> - (* add the constraint that the ptr is inside the object *) - get_allocation_size alloc_id >>= fun size_ival_ -> - address_expression_of_pointer ptrval >>= fun ptr_ival_ -> - (* NOTE: the MC_lt in the second constraint, i.e. we can't - have a "one past" pointer *) - ifM ("perform_access[" ^ Loc.stringFromLocation loc ^ "] provenance check") - (MC_conj [ mk_iv_constr MC_le (IVaddress alloc_id pref) ptr_ival_ - ; mk_iv_constr MC_le (IVop IntAdd [ptr_ival_; IVsizeof lvalue_ty]) - (IVop IntAdd [IVaddress alloc_id pref; size_ival_]) ]) - (do_normal alloc_id) - (fail loc (MerrAccess accessKind OutOfBoundPtr)) - end - - (* device memory *) - | (PV Prov_device _ _) -> - do_device - - | (PV Prov_wildcard _ _) -> - error "TODO perform_access: Prov_wildcard" - end - - - - - - - - - -let stringFromWrite_event (WriteEvent loc ty ptrval mval) = - "WriteEvent[" ^ Loc.stringFromLocation loc ^ "] (" ^ stringFromCore_ctype ty ^ ") ==> ptrval= " ^ - stringFromPointer_value ptrval ^ "; mval= " ^ stringFromMem_value mval - - - -val ival_footprintFromWrite_event: write_event -> impl_memM (integer_value_base * integer_value_base) -let ival_footprintFromWrite_event (WriteEvent loc ty ptrval mval) = - address_expression_of_pointer ptrval >>= fun ptr_ival_ -> - return (ptr_ival_, mk_op_ival_ IntAdd ptr_ival_ (mk_op_ival_ IntSub (IVsizeof ty) (IVconcrete 1))) - - -val isOccludedBy: write_event -> write_event -> impl_memM bool -let isOccludedBy wevent1 wevent2 = - ival_footprintFromWrite_event wevent1 >>= fun (min_ival_1, max_ival_1) -> - ival_footprintFromWrite_event wevent2 >>= fun (min_ival_2, max_ival_2) -> - condM "isOccludedBy" - (MC_conj [ mk_iv_constr MC_le min_ival_2 min_ival_1 - ; mk_iv_constr MC_le max_ival_1 max_ival_2 ]) - -let rec anyM pred = function - | [] -> - return false - | x::xs -> - pred x >>= function - | true -> - return true - | false -> - anyM pred xs - end -end - - -val discardOccluded_write_events: impl_pointer_value -> ctype -> list write_event -> impl_memM (list write_event) -let discardOccluded_write_events view_ptrval view_ty wevents = - address_expression_of_pointer view_ptrval >>= fun view_ptr_ival_ -> - let min_view_ival_ = view_ptr_ival_ in - let max_view_ival_ = mk_op_ival_ IntAdd view_ptr_ival_ (mk_op_ival_ IntSub (IVsizeof view_ty) (IVconcrete 1)) in - foldlM (fun acc wevent -> - ival_footprintFromWrite_event wevent >>= fun (min_wevent_ival_, max_wevent_ival_) -> - ifM "discardOccluded_write_events" - (* if the view is outside the footprint of the write event *) - (MC_or (mk_iv_constr MC_lt max_view_ival_ min_wevent_ival_) - (mk_iv_constr MC_lt max_wevent_ival_ min_view_ival_)) - (return acc) - (anyM (isOccludedBy wevent) acc >>= function - | true -> - return acc - | false -> - return (wevent :: acc) - end) - ) [] wevents - - - - - - - - - -(* BEGIN ACCESS ================================================================================= *) -let impl_load loc lvalue_ty (PV _ ptrval_ sh as ptrval) : impl_memM (impl_footprint * impl_mem_value) = - print_debugM 1 (fun () -> - "LOAD [" ^ stringFromCtype lvalue_ty ^ "]: with pointer value: " ^ stringFromPointer_value ptrval - ) >> - perform_access LoadAccess loc lvalue_ty ptrval - (fun alloc_id -> - (* addToLog alloc_id >> *) - resolve_allocation alloc_id >>= function - | Storage_static stor_pref stor_ty (Just mval) -> - (* found a stored value static memory *) - apply_shift_path lvalue_ty sh mval >>= fun mval' -> - print_debugM 5 (fun () -> - "==> found value (static): " ^ stringFromMem_value mval' - ) >> -(* - if stor_ty = lvalue_ty then - return (FP_alloc alloc_id lvalue_ty, mval') - else - error "WIP: LOAD, lvalue_ty <> stor_ty" -*) - return (FP_alloc alloc_id lvalue_ty, mval') - | Storage_static _ _ Nothing -> - (* loading from uninitialised static memory *) - return (FP_alloc alloc_id lvalue_ty, mkUnspec lvalue_ty) - | Storage_dynamic _ _ ws -> - (* loading from dynamic memory *) - print_debugM 1 (fun () -> - "Loading from dynamic storage, found " ^ show (List.length ws) ^ " write events" - ) >> - discardOccluded_write_events ptrval lvalue_ty ws >>= fun visible_ws -> - print_debugM 1 (fun () -> - "found " ^ show (List.length visible_ws) ^ " visible write events" - ) >> - wip "TODO: loading from dynamic memory" - end - ) - begin - wip ("TODO: load from device memory ==> " ^ stringFromPointer_value ptrval) - end - - -(* -let impl_load_OLD ty (PV _ ptrval_ sh as ptrval) : impl_memM (impl_footprint * impl_mem_value) = - print_debugM 5 (fun () -> - "LOAD [" ^ stringFromCtype ty ^ "]: with pointer value: " ^ stringFromPointer_value ptrval - ) >> - match ptrval_ with - (* null and function pointers obviously can't be used for loads. *) - | PVnull _ -> fail (MerrAccess loc LoadAccess NullPtr) - | PVfunction _ -> fail (MerrAccess loc LoadAccess FunctionPtr) - - | _ -> - explicitAllocationIdFromPointer_value_aux ptrval_ >>= function - | Just alloc_id -> -(* addToLog alloc_id >> *) - get >>= fun mem_st -> - if Set.member alloc_id mem_st.dead_allocations then - fail (MerrAccess loc LoadAccess DeadPtr) - else match Map.lookup alloc_id mem_st.allocations with - | Just (Storage_static _ (Just mval)) -> - apply_shift_path ty sh mval >>= fun mval' -> - print_debugM 5 (fun () -> - "==> found value (static): " ^ stringFromMem_value mval' - ) >> - return (FP_alloc alloc_id ty, mval') - | Just (Storage_static _ Nothing) -> - return (FP_alloc alloc_id ty, mkUnspec ty) - | Just (Storage_dynamic _ ws) -> - print_debugM 0 (fun () -> - "Loading from dynamic storage, found " ^ show (List.length ws) ^ " write events" - ) >> - error "Mem.load, Storage_dynamic: TODO" - | Nothing -> - error "Mem.load, couldn't find some allocation" - end - | Nothing -> - wip ("TODO: load, Nothing ==> " ^ stringFromPointer_value ptrval) - end - end -*) - -(* - (* TODO: this just find the latest store done with exactly the same pointer value *) - fetch_first_write_event (fun (WriteEvent _ ptr_val' _) -> structural_equality_pointer_value ptr_val ptr_val') >>= function - | Just (WriteEvent _ _ mval) -> - print_debugM 4 ("Loading [" ^ stringFromCtype ty ^ "]: "^ stringFromMem_value mval ^ " from: " ^ stringFromPointer_value ptr_val) >> - return mval - | Nothing -> - fail (MerrWIP "load failed") - end -*) - - - - -val impl_store: Loc.t -> ctype -> bool -> impl_pointer_value -> impl_mem_value -> impl_memM impl_footprint -let impl_store loc lvalue_ty is_locking ptrval mval = - (* TODO: is_locking *) - print_debugM 5 (fun () -> - "STORE [" ^ stringFromCtype lvalue_ty ^ "]: with pointer value: " ^ - stringFromPointer_value ptrval ^ " and value: " ^ stringFromMem_value mval - ) >> - let wevent = - WriteEvent loc lvalue_ty ptrval mval in - - perform_access StoreAccess loc lvalue_ty ptrval - (fun alloc_id -> - (* addToLog alloc_id >> *) - register_write_event alloc_id wevent >> - return (FP_alloc alloc_id lvalue_ty) - ) - begin - get >>= fun st -> - put <| st with device_memory= wevent :: st.device_memory |> >> - address_expression_of_pointer ptrval >>= fun ptr_ival_ -> - return (FP_device ptr_ival_ lvalue_ty) - end - - - -let impl_memcpy _ ptr_val1 ptr_val2 size_ival = - error "WIP: Symbolic memcpy" - -(* BEGIN MEMCMP ================================================================================= *) -val memcmp_load_aux: impl_pointer_value -> integer -> integer -> list impl_mem_value -> impl_memM (list impl_mem_value) -let rec memcmp_load_aux ptrval offset max_offset acc = - if offset >= max_offset then - return (List.reverse acc) - else - let ptrval' = impl_array_shift_ptrval ptrval unsigned_char (IV Prov_none (IVconcrete offset)) in - impl_load (Loc.other "memcmp_load_aux") unsigned_char ptrval' >>= fun (fp, mval) -> - memcmp_load_aux ptrval (offset+1) max_offset (mval :: acc) - -let rec memcmp_compare (mval1, mval2) : impl_memM integer = - match (mval1, mval2) with - | (MVinteger ity1 (IV _ (IVbyteof offset_ival1 mval1')), MVinteger ity2 (IV _ (IVbyteof offset_ival2 mval2'))) -> - ifM "memcmp_compare(byte offsets)" - (mk_iv_constr MC_eq offset_ival1 offset_ival2) - (memcmp_compare (mval1', mval2')) - (fail Loc.unknown (MerrWIP "memcmp, two IVbyteof with different offsets")) - | (MVpointer ref_ty1 ptrval1, MVpointer ref_ty2 ptrval2) -> - address_expression_of_pointer ptrval1 >>= fun ival1 -> - address_expression_of_pointer ptrval2 >>= fun ival2 -> - ifM "memcmp_compare(two pointers equals?)" - (mk_iv_constr MC_eq ival1 ival2) - (return 0) - begin - ifM "memcmp_compare(two pointers equals?)" - (mk_iv_constr MC_lt ival1 ival2) - (return (0-1)) - (return 1) - end - | _ -> - error "memcmp_compare" - end - -let rec fold_memcmp_compare mvals1 mvals2 ord_acc = - if ord_acc = 0 then - match (mvals1, mvals2) with - | ([], []) -> - return 0 - | (mval1 :: xs1, mval2 :: xs2) -> - memcmp_compare (mval1, mval2) >>= fun ord -> - fold_memcmp_compare xs1 xs2 ord - | _ -> - error "Impossible: fold_memcmp_compare" - end - else - return ord_acc - - - -let impl_memcmp ptr_val1 ptr_val2 size_ival = - match size_ival with - | IV _ (IVsizeof ty) -> - impl_load (Loc.other "memcmp, 1st pointer") ty ptr_val1 >>= fun (fp1, mval1) -> - impl_load (Loc.other "memcmp, 2nd pointer") ty ptr_val2 >>= fun (fp2, mval2) -> - error "Mem.impl_memcmp" - | IV _ (IVconcrete n) -> - memcmp_load_aux ptr_val1 0 n [] >>= fun mvals1 -> - memcmp_load_aux ptr_val2 0 n [] >>= fun mvals2 -> - fold_memcmp_compare mvals1 mvals2 0 >>= fun ord -> - return (IV Prov_none (IVconcrete ord)) -(* - mapM memcmp_compare (List.zip mvals1 mvals2) >>= fun xs -> - return -*) - | _ -> - error ("Mem.impl_memcmp 3 ==> " ^ stringFromInteger_value size_ival) - end diff --git a/frontend/model/defacto_memory_aux.lem b/frontend/model/defacto_memory_aux.lem deleted file mode 100644 index 34fe89164..000000000 --- a/frontend/model/defacto_memory_aux.lem +++ /dev/null @@ -1,449 +0,0 @@ -open import Pervasives Num_extra Ctype - -open import Utils -open import AilTypesAux - -import Ctype_aux -import Implementation - -open import Mem_common Defacto_memory_types - - - - -(* BEGIN fake stuff to get the concurrency to compile =========================================== *) -let fake_pointer_value_eq (PV _ ptr_val_1 sh1) (PV _ ptr_val_2 sh2) = - match (ptr_val_1, ptr_val_2) with - | (PVbase alloc_id1 _, PVbase alloc_id2 _) -> - alloc_id1 = alloc_id2 - | _ -> - error "DON'T USE Eq for pointer_value" - end -instance (Eq impl_pointer_value) - let (=) = fake_pointer_value_eq - let (<>) ptr_val1 ptr_val2 = not (fake_pointer_value_eq ptr_val1 ptr_val2) -end - -let rec fake_mem_value_eq mval1 mval2 = - match (mval1, mval2) with - | (MVinteger _ (IV _ (IVconcrete n1)), MVinteger _ (IV _ (IVconcrete n2))) -> - n1 = n2 - | (MVarray mvals1, MVarray mvals2) -> - List.all (uncurry fake_mem_value_eq) (zip mvals1 mvals2) - | _ -> - error "DON'T USE Eq for mem_value" -end - -instance (Eq impl_mem_value) - let (=) = fake_mem_value_eq - let (<>) mval1 mval2 = not (fake_mem_value_eq mval1 mval2) -end - -instance (Show impl_mem_value) - let show x = "WIP: show mem_value" -end - -instance (Show impl_pointer_value) - let show x = "WIP: show pointer_value" -end - -(* END fake stuff to get the concurrency to compile ============================================= *) - - -(* BEGIN debug ================================================================================== *) -val stringFromPointer_value: impl_pointer_value -> string -val stringFromMem_value: impl_mem_value -> string -val stringFromInteger_value: impl_integer_value -> string -val stringFromShift_path: shift_path -> string (* DEBUG *) -val stringFromCore_ctype: ctype -> string - -declare ocaml target_rep function stringFromPointer_value = `String_defacto_memory.string_of_pointer_value` -declare ocaml target_rep function stringFromMem_value = `String_defacto_memory.string_of_mem_value` -declare ocaml target_rep function stringFromInteger_value = `String_defacto_memory.string_of_integer_value` -declare ocaml target_rep function stringFromShift_path = `String_defacto_memory.string_of_shift_path` (* DEBUG *) -declare ocaml target_rep function stringFromCore_ctype = `String_core_ctype.string_of_ctype` - -(* TODO: HOL hack *) -declare hol target_rep function stringFromPointer_value p = "??NOT IMPLEMENTED??" -declare hol target_rep function stringFromMem_value p = "??NOT IMPLEMENTED??" -declare hol target_rep function stringFromShift_path p = "??NOT IMPLEMENTED??" -(* END debug ==================================================================================== *) - - -val mk_iv_constr: - (impl_integer_value -> impl_integer_value -> mem_constraint impl_integer_value) -> - integer_value_base -> - integer_value_base -> - mem_constraint impl_integer_value -let mk_iv_constr ctor ival_1 ival_2 = - (*simplify_constraint*) (ctor (IV Prov_none ival_1) (IV Prov_none ival_2)) - - - - - - - - - -type simpl_state = <| -(* - min_eqs: map integerType integer_value_base; - max_eqs: map integerType integer_value_base; -*) - sizeof_eqs: map ctype integer_value_base; - alignof_eqs: map ctype integer_value_base; -|> - - - -let encode (nbits: nat) (n: integer) = - if 0 <= n then - n - else - (2 ** nbits) + n - -let decode (nbits: nat) (n: integer) = - if n <= 2 ** (nbits - 1) - 1 then - n - else - n - (2 ** nbits) - - -val tmp_compl_aux: nat -> integer -> integer -let rec tmp_compl_aux nbits n = - if nbits = 0 then - 0 - else - let n_ = n / 2 in - (1 - (integerRem_f n 2)) + 2 * tmp_compl_aux (nbits - 1) n_ - -val tmp_compl: nat -> integer -> integer -let tmp_compl nbits n = - decode nbits (tmp_compl_aux nbits (encode nbits n)) - - -val tmp_AND_aux: nat -> integer -> integer -> integer -let rec tmp_AND_aux nbits n1 n2 = - if nbits = 0 then - 0 - else - let n1_ = n1 / 2 in - let n2_ = n2 / 2 in - (if (integerRem_f n1 2) = 1 && (integerRem_f n2 2) = 1 then 1 else 0) + 2 * (tmp_AND_aux (nbits-1) n1_ n2_) - - -val tmp_OR_aux: nat -> integer -> integer -> integer -let rec tmp_OR_aux nbits n1 n2 = - if nbits = 0 then - 0 - else - let n1_ = n1 / 2 in - let n2_ = n2 / 2 in - (if (integerRem_f n1 2) = 1 || (integerRem_f n2 2) = 1 then 1 else 0) + 2 * (tmp_OR_aux (nbits-1) n1_ n2_) - - -val tmp_XOR_aux: nat -> integer -> integer -> integer -let rec tmp_XOR_aux nbits n1 n2 = - if nbits = 0 then - 0 - else - let n1_ = n1 / 2 in - let n2_ = n2 / 2 in - (if (integerRem_f n1 2) * (integerRem_f n2 2) = 0 && - not ((integerRem_f n1 2) + (integerRem_f n2 2) = 0) then 1 else 0) + 2 * (tmp_XOR_aux (nbits-1) n1_ n2_) - - -val tmp_AND: nat -> integer -> integer -> integer -val tmp_OR: nat -> integer -> integer -> integer -val tmp_XOR: nat -> integer -> integer -> integer - -let tmp_AND width n1 n2 = - let nbits = 8 * width in - decode nbits (tmp_AND_aux nbits (encode nbits n1) (encode nbits n2)) - -let tmp_OR width n1 n2 = - let nbits = 8 * width in - let n1_ = encode nbits n1 in - let n2_ = encode nbits n2 in - let () = Debug.print_debug 1 [] (fun () -> - "nbits= " ^ show nbits ^ ", n1 = " ^ show n1 ^ " -- n1_= " ^ show n1_ - ) in - let () = Debug.print_debug 1 [] (fun () -> - "nbits= " ^ show nbits ^ ", n2 = " ^ show n2 ^ " -- n2_= " ^ show n2_ - ) in - decode nbits (tmp_OR_aux nbits n1_ n2_) - -let tmp_XOR width n1 n2 = - let nbits = 8 * width in - decode nbits (tmp_XOR_aux nbits (encode nbits n1) (encode nbits n2)) - - -let rec simplify_integer_value_base ival_ = - let lifted_self x = - either (fun n -> IVconcrete n) (fun z -> z) (simplify_integer_value_base x) in - match ival_ with - | IVunspecified -> - Right ival_ - | IVconcurRead _ _ -> - Right ival_ - | IVconcrete n -> - Left n - | IVaddress alloc_id pref -> - Right ival_ - | IVfromptr ty ity ptrval sh -> - (* TODO *) - Right ival_ - | IVop iop [ival_1; ival_2] -> - let num_op = match iop with - | IntAdd -> - (+) - | IntSub -> - (-) - | IntMul -> - ( * ) - | IntDiv -> - fun x y -> if y = 0 then 0 else integerDiv_t x y - | IntRem_t -> - fun x y -> if y = 0 then 0 else integerRem_t x y - | IntRem_f -> - fun x y -> if y = 0 then 0 else integerRem_f x y - | IntExp -> - fun x y -> x ** natFromInteger y - end in - match (simplify_integer_value_base ival_1, simplify_integer_value_base ival_2) with - | (Left n1, Left n2) -> - Left (num_op n1 n2) - | (x, y) -> - let f = either (fun z -> IVconcrete z) (fun z -> z) in - Right (IVop iop [f x; f y]) - end - | IVop _ _ -> - (* Core type error *) - error "Defacto_memory_aux2.simplify_integer_value_base, IVop: Core type error" - | IVmin ity -> - match ity with - | Char -> - if Implementation.is_signed_ity Char then - Left (~ (2 ** (8-1))) - else - Left 0 - | Bool -> - (* this type is unsigned *) - Left 0 - | Size_t -> - (* this type is unsigned *) - Left 0 - | Wchar_t -> - (* TODO: it is implementation defined if signed *) - Left 0 - | Wint_t -> - (* TODO: it is implementation defined if signed *) - Left (~ 2147483648) - | Unsigned _ -> - Left 0 - | Ptrdiff_t -> - (* this type is signed *) - match Implementation.sizeof_ity ity with - | Just n -> - Left (~ (2 ** (8*n-1))) - | Nothing -> - Right ival_ - end - | Ptraddr_t -> - Left 0 - | Signed _ -> - match Implementation.sizeof_ity ity with - | Just n -> - Left (~ (2 ** (8*n-1))) - | Nothing -> - Right ival_ - end - | Enum _ -> - error "IVmin Enum" - end - | IVmax ity -> - match Implementation.sizeof_ity ity with - | Just n -> - let signed_max = (2 ** (8*n-1)) - 1 in - let unsigned_max = (2 ** (8*n)) - 1 in - match ity with - | Char -> - Left (if Implementation.is_signed_ity Char then - signed_max - else - unsigned_max) - | Bool -> - (* TODO: not sure about this (maybe it should be 1 and not 255? *) - Left unsigned_max - | Size_t -> - Left unsigned_max - | Wchar_t -> - (* TODO: it is implementation defined if signed *) - Left unsigned_max - | Wint_t -> - (* TODO: it is implementation defined if signed *) - Left unsigned_max - | Unsigned _ -> - Left unsigned_max - | Ptrdiff_t -> - Left signed_max - | Ptraddr_t -> - Left unsigned_max - | Signed _ -> - Left signed_max - | Enum _ -> - error "IVmax Enum" - end - | Nothing -> - Right ival_ - end - | IVsizeof (Ctype _ ty) -> - match ty with - | Void -> - (* Ail type error *) - error "Defacto_memory_aux2.simplify_integer_value_base, IVsizeof Void" - | Basic (Integer ity) -> - match Nothing (* Implementation.sizeof_ity ity*) with - | Just n -> - Left (integerFromNat n) - | Nothing -> - Right ival_ - end - | Basic (Floating fty) -> - match Implementation.sizeof_fty fty with - | Just n -> - Left (integerFromNat n) - | Nothing -> - Right ival_ - end - | Array elem_ty Nothing -> - (* Ail type error *) - error "Defacto_memory_aux2.simplify_integer_value_base, IVsizeof Array Nothing" - | Array elem_ty (Just n) -> - simplify_integer_value_base (IVop IntMul [IVsizeof elem_ty; IVconcrete n]) - | Function _ _ _ -> - (* Ail type error *) - error "Defacto_memory_aux2.simplify_integer_value_base, IVsizeof Function" - | FunctionNoParams _ -> - (* Ail type error *) - error "Defacto_memory_aux2.simplify_integer_value_base, IVsizeof FunctionNoParams" - | Pointer _ ref_ty -> - Left 8 - | Atomic atom_ty -> - simplify_integer_value_base (IVsizeof atom_ty) - | Struct tag_sym -> - let (tagDef, flexible_opt) = Ctype_aux.get_structDef tag_sym in - if flexible_opt <> Nothing then - error "TODO: Defacto_memmory_aux.simplify_integer_value_base => found flexible array member" - else - simplify_integer_value_base begin - List.foldl (fun acc (ident, (_, _(* TODO: alignment*), _, ty)) -> - IVop IntAdd [ lifted_self (IVsizeof ty); - IVop IntAdd [IVpadding tag_sym ident; acc] ] - ) (IVconcrete 0) tagDef - end - - (* TOOD: move the code from mem_simplify here *) - | Union tag_sym -> - Right ival_ (* error "TODO simplify_integer_value: IVsizeof Union" *) - | Byte -> - Left 1 - end - | IValignof (Ctype _ ty) -> - match ty with - | Void -> - (* Ail type error *) - error "Defacto_memory_aux2.simplify_integer_value_base, IValignof Void" - | Basic (Integer ity) -> - match Implementation.alignof_ity ity with - | Just n -> - Left (integerFromNat n) - | Nothing -> - Right ival_ - end - | Basic (Floating fty) -> - match Implementation.alignof_fty fty with - | Just n -> - Left (integerFromNat n) - | Nothing -> - Right ival_ - end - | Array elem_ty _ -> - simplify_integer_value_base (IValignof elem_ty) - | Function _ _ _ -> - (* Ail type error *) - error "Defacto_memory_aux2.simplify_integer_value_base, IValignof Function" - | FunctionNoParams _ -> - (* Ail type error *) - error "Defacto_memory_aux2.simplify_integer_value_base, IValignof FunctionNoParams" - | Pointer _ ref_ty -> - Left 8 - | Atomic atom_ty -> - simplify_integer_value_base (IValignof atom_ty) - | Struct tag_sym -> - (* TODO *) - Right ival_ - | Union tag_sym -> - error "TODO simplify_integer_value: IValignof Union" - | Byte -> - Left 1 - end - | IVoffsetof _ _ -> - Right ival_ - | IVpadding _ _ -> - Right ival_ - | IVptrdiff ty ptrval1 ptrval2 -> - (* TODO: check *) - Right ival_ - - | IVbyteof _ _ -> - Right ival_ (* error "TODO: Defacto_memory_aux2.simplify_integer_value_base, IVbyteof" *) - | IVcomposite _ -> - error "TODO: Defacto_memory_aux2.simplify_integer_value_base, IVcomposite" - | IVbitwise ity (BW_complement ival_1) -> - match (Implementation.sizeof_ity ity, simplify_integer_value_base ival_1) with - | (Just w, Left n1) -> - Left (tmp_compl w n1) - | (_, Left n1) -> - Right (IVbitwise ity (BW_complement (IVconcrete n1))) - | (_, Right ival_1') -> - Right (IVbitwise ity (BW_complement ival_1')) - end - | IVbitwise ity (BW_AND ival_1 ival_2) -> - match (Implementation.sizeof_ity ity, simplify_integer_value_base ival_1, simplify_integer_value_base ival_2) with - | (Just w, Left n1, Left n2) -> - Left (tmp_AND w n1 n2) - | (_, x, y) -> - let f = either (fun z -> IVconcrete z) (fun z -> z) in - Right (IVbitwise ity (BW_AND (f x) (f y))) - end - | IVbitwise ity (BW_OR ival_1 ival_2) -> - match (Implementation.sizeof_ity ity, simplify_integer_value_base ival_1, simplify_integer_value_base ival_2) with - | (Just w, Left n1, Left n2) -> - Left (tmp_OR w n1 n2) - | (_, x, y) -> - let f = either (fun z -> IVconcrete z) (fun z -> z) in - Right (IVbitwise ity (BW_OR (f x) (f y))) - end - | IVbitwise ity (BW_XOR ival_1 ival_2) -> - match ( Implementation.sizeof_ity ity - , simplify_integer_value_base ival_1 - , simplify_integer_value_base ival_2 ) with - | (Just w, Left n1, Left n2) -> - Left (tmp_XOR w n1 n2) - | (_, x, y) -> - let f = either (fun z -> IVconcrete z) (fun z -> z) in - Right (IVbitwise ity (BW_XOR (f x) (f y))) - end - end - - - -val eval_integer_value_base: integer_value_base -> maybe integer -let eval_integer_value_base ival_ = - either (fun n -> Just n) (fun _ -> Nothing) (simplify_integer_value_base ival_) - -val lifted_simplify_integer_value_base: integer_value_base -> integer_value_base -let lifted_simplify_integer_value_base ival_ = - either (fun n -> IVconcrete n) (fun z -> z) (simplify_integer_value_base ival_) diff --git a/frontend/model/defacto_memory_types.lem b/frontend/model/defacto_memory_types.lem deleted file mode 100644 index eb8c3318c..000000000 --- a/frontend/model/defacto_memory_types.lem +++ /dev/null @@ -1,148 +0,0 @@ -open import Pervasives Utils - -open import Ctype Mem_common Float -import Symbol - - -(* TODO *) -type allocation_id = nat - -type provenance_id = nat - - - - -(* A 'provenance' keeps track of a how a pointer value was constructed *) -type provenance = - (* the associated pointer do reference something but we don't know anything - about the associated allocation (e.g. the pointer was build using scanf()) *) - | Prov_wildcard - - (* the associated pointer do not reference anything (e.g. null pointer, function pointers) *) - | Prov_none - - (* the associated pointer was create using a provenance-less integer value - within the memory range reserved for devices *) - | Prov_device - - (* in this case we know of at least one allocation event *) - | Prov_some of (provenance_id * Symbol.prefix) (* set provenance_id (* INVARIANT: non empty set *) *) - - - -(* a symbolic identifier representing the concrete address of a fresh allocation (the nat) together with the source location *) -type address = - | Address of Symbol.prefix * allocation_id - - -(*** Pointer value ****************************************************************************** *) - -(* Core values of type OTy_pointer will always be of this form *) -type impl_pointer_value = - (* pointer values are annotated with a provenance *) - | PV of provenance * pointer_value_base * (list shift_path_element) - -and pointer_value_base = - | PVunspecified of ctype (* TODO: maybe put this ctor in pointer_value ? *) - (* a null pointer constructed by an expression of the given ctype. *) - - | PVnull of ctype (* INVARIANT: the associated provenance must be Prov_none *) - - | PVfunction of Symbol.sym (* INVARIANT: the associated provenance must be Prov_none *) - - | PVbase of allocation_id * Symbol.prefix (* TODO: not sure about having the prefix here *) - (* the result of a dynamic or automatic/static/thread-local - allocation, generated with Prov_some - with the singleton set of its allocation_id *) - (* the Symbol.prefix is roughly the source location - the "syntactic provenance" :-*) - - | PVfromint of integer_value_base (* INVARIANT: never an IVconcrete(0) or IVfromptr(PVnull), but could be a more complex integer_value_base which (perhaps after constraint solving) will always be zero *) - -(* we don't flatten out nested structs/unions in shift_path's; they just appear as SPE_array with the struct/union type. *) -and shift_path_element = - | SPE_array of ctype * integer_value_base - | SPE_member of Symbol.sym (*struct/union tag*) * Symbol.identifier (*member*) - - -(* Core values of type OTy_integer will always be of this form *) -and impl_integer_value = - | IV of provenance (* * AilTypes.integerType *) * integer_value_base - -and integer_value_base = - | IVunspecified - | IVconcurRead of Ctype.integerType * Symbol.sym (* a fresh symbol from a concurrency-model read *) - (* the concurrency model is at present limited to reads of integer types, so not pointer types *) - | IVconcrete of integer - | IVaddress of allocation_id * Symbol.prefix (* address *) (* NOTE: this should never get out of this module *) - | IVfromptr of ctype * Ctype.integerType * pointer_value_base * shift_path - (* the result of a cast from pointer to integer. The first - parameter is the referenced type of the pointer value, the - second is the integer type *) - | IVop of integer_operator * list integer_value_base - | IVmin of Ctype.integerType - | IVmax of Ctype.integerType - | IVsizeof of ctype - | IValignof of ctype - (* NOTE: this is a number bytes padding trailing a struct/union member *) - | IVoffsetof of Symbol.sym (*struct/union tag*) * Symbol.identifier (*member*) - | IVpadding of Symbol.sym (*struct/union tag*) * Symbol.identifier (*member*) - - | IVptrdiff of ctype * (pointer_value_base * list shift_path_element) * (pointer_value_base * list shift_path_element) - (* TODO: tentative *) - | IVbyteof of integer_value_base * impl_mem_value (* the integer value is the position (indexed from zero) *) - | IVcomposite of list integer_value_base (* a list of byte values reassembled *) - | IVbitwise of Ctype.integerType * bitwise_operation - -and bitwise_operation = - | BW_complement of integer_value_base - | BW_AND of integer_value_base * integer_value_base - | BW_OR of integer_value_base * integer_value_base - | BW_XOR of integer_value_base * integer_value_base - (* shift? *) - - -and impl_floating_value = - | FVunspecified - | FVconcrete of float (* WARN: using Ocaml float representation *) - -(* The mem_value represents what can be stored in memory. *) -(* the types below exist so that when looking at the representations of mem_values one knows what mapping to use *) -and impl_mem_value = - | MVinteger of Ctype.integerType * impl_integer_value - | MVfloating of Ctype.floatingType * impl_floating_value - | MVpointer of ctype * impl_pointer_value (* the first parameter is the referenced type of the pointer value *) - | MVarray of list impl_mem_value (* INVARIANT: all of the same mem_value constructor and type *) - | MVstruct of Symbol.sym (*struct/union tag*) * list (Symbol.identifier (*member*) * ctype * impl_mem_value) - | MVunion of Symbol.sym (*struct/union tag*) * Symbol.identifier (*member*) * impl_mem_value - - | MVdelayed of list (shift_path * impl_mem_value) * impl_mem_value - - | MVcomposite of - list ((* byte offset *) integer_value_base * (* value of the written byte *) impl_integer_value) * - (* value written over *) impl_mem_value - (* INVARIANT: the mem_value should not be a MVcomposite *) - -(* not sure whether these analogues of IVbyteof and IVcomposite should exist (think not) - | MVmodified of list (shift_path * mem_value) * mem_value (* this is for when an object is modified as an - uchar array (or the generalisation to other types of that) *) - | MVbytes of byte_mask * mem_value * mem_value *) - -and shift_path = list shift_path_element - - -(* -type allocation = - | Alloc_static of ctype (* * address *) - | Alloc_dynamic of integer_value_base (* * address *) -*) - - - -(* TODO: simplified for now (only work for scalars) *) -type impl_footprint = - | FP_alloc of allocation_id * ctype - | FP_device of integer_value_base * ctype - -val impl_overlapping: impl_footprint -> impl_footprint -> bool -let impl_overlapping _ _ = - error "impl_overlapping" diff --git a/frontend/model/desugaring_init.lem b/frontend/model/desugaring_init.lem index 470ef3ca0..edbc24667 100644 --- a/frontend/model/desugaring_init.lem +++ b/frontend/model/desugaring_init.lem @@ -280,9 +280,9 @@ import AilSyntax type desugaring_init_funcs = <| desugar_expression: Cabs.cabs_expression -> E.desugM (AilSyntax.expression unit); - is_integer_constant_expression: AilSyntax.expression unit -> E.desugM bool; + is_integer_constant_expression: bool -> AilSyntax.expression unit -> E.desugM bool; is_initializer_constant_expression_or_string_literal: AilSyntax.expression unit -> E.desugM bool; - evaluate_integer_constant_expression: Loc.t -> maybe Ctype.ctype -> AilSyntax.expression unit -> E.desugM integer; + evaluate_integer_constant_expression: maybe Ctype.ctype -> AilSyntax.expression unit -> E.desugM integer; |> let liftM = function @@ -314,12 +314,12 @@ let rec moveTo_aux tagDefs funcs is_top (ty_acc, cursor_acc) desigs = | Cabs.Desig_array e :: desigs' -> let loc = Loc.locOf e in let common e = - funcs.desugar_expression e >>= fun d_e -> - funcs.is_integer_constant_expression d_e >>= function + funcs.desugar_expression e >>= fun d_e -> + funcs.is_integer_constant_expression true d_e >>= function | false -> E.constraint_violation loc Constraint.IllegalTypeArrayDesignator | true -> - funcs.evaluate_integer_constant_expression loc Nothing d_e >>= fun idx -> + funcs.evaluate_integer_constant_expression Nothing d_e >>= fun idx -> if idx < 0 then E.constraint_violation loc Constraint.IllegalSizeArrayDesignator else diff --git a/frontend/model/driver.lem b/frontend/model/driver.lem index be4768b04..03fee7d5c 100644 --- a/frontend/model/driver.lem +++ b/frontend/model/driver.lem @@ -67,6 +67,7 @@ type driver_state = <| blocked: bool; (* concurrency model ended by blocking *) (* DEBUG *) (*trace: list string;*) + do_stepping: bool; dr_step_counter: nat; |> @@ -181,6 +182,8 @@ let liftCore_run m = val drive_fs_step: Mem.thread_id -> Core_run.thread_state -> driver_state -> Core_run.fs_oper -> driverM unit let drive_fs_step tid th_st dr_st fs_oper = + (* NOTE: the Core file (and tagDefs) is read-only *) + let tagDefs = dr_st.core_file.Core.tagDefs in let alignof_ival ty = Mem.integer_ival (Implementation.alignof_ty dr_st.core_file.Core.tagDefs ty) in let th_st_from_int n = let (Core.Expr arena_annots _) = th_st.Core_run.arena in @@ -288,7 +291,7 @@ let drive_fs_step tid th_st dr_st fs_oper = let dirent_cty = Ctype.Ctype [] (Ctype.Struct sym) in let update_mem dir_name = Mem.bind (Mem.allocate_object tid (Symbol.PrefOther "dirent") (alignof_ival dirent_cty) dirent_cty Nothing Nothing) (fun dirent_ptr -> - let d_name_ptr = Mem.member_shift_ptrval dirent_ptr sym (Symbol.Identifier loc "d_name") in + let d_name_ptr = Mem.member_shift_ptrval tagDefs dirent_ptr sym (Symbol.Identifier loc "d_name") in Mem.bind (Formatted.store_chars_in_array true d_name_ptr dir_name) (fun _ -> (Mem.return dirent_ptr))) in @@ -308,7 +311,7 @@ let drive_fs_step tid th_st dr_st fs_oper = let update_mem stat = let loc = Loc.other "store struct stat" in let store iTy memb f = - let ptr = Mem.member_shift_ptrval stat_ptr sym (Symbol.Identifier loc memb) in + let ptr = Mem.member_shift_ptrval tagDefs stat_ptr sym (Symbol.Identifier loc memb) in let mval = Mem.integer_value_mval iTy (Mem.integer_ival (f stat)) in Mem.store loc (Ctype.Ctype [] (Ctype.Basic (Ctype.Integer iTy))) false ptr mval @@ -680,8 +683,9 @@ let action_request_sequential2 loc tid aid = function | Core_reduction.LoadRequest2 mo lvalue_ty ptr_val mk_th_st' -> let () = Debug.print_debug_located 3 [Debug.DB_driver] loc (fun () -> "REQUEST LOAD") in (* DEBUG *) - liftMem (Mem.load loc lvalue_ty ptr_val) >>= fun (fp, mval) -> - liftMem (Mem.prefix_of_pointer ptr_val) >>= fun pref -> + liftMem (Mem.load loc lvalue_ty ptr_val) >>= fun (fp, mval) -> + ND.read (fun dr_st -> dr_st.core_file.Core.tagDefs) >>= fun tagDefs -> + liftMem (Mem.prefix_of_pointer tagDefs ptr_val) >>= fun pref -> ND.update (fun dr_st -> <| dr_st with core_state= Core_run.update_thread_state tid (mk_th_st' aid fp mval) dr_st.core_state; @@ -693,8 +697,9 @@ let action_request_sequential2 loc tid aid = function let () = Debug.print_debug_located 3 [Debug.DB_driver] loc (fun () -> "REQUEST STORE") in (* DEBUG *) (* TODO: need to make memory layout detect unsequenced races (use to make the concurency to the check even in the sequential mode) *) - liftMem (Mem.store loc lvalue_ty is_locking ptr_val mem_val) >>= fun fp -> - liftMem (Mem.prefix_of_pointer ptr_val) >>= fun pref -> + liftMem (Mem.store loc lvalue_ty is_locking ptr_val mem_val) >>= fun fp -> + ND.read (fun dr_st -> dr_st.core_file.Core.tagDefs) >>= fun tagDefs -> + liftMem (Mem.prefix_of_pointer tagDefs ptr_val) >>= fun pref -> ND.update (fun dr_st -> <| dr_st with core_state= Core_run.update_thread_state tid (mk_th_st' aid fp) dr_st.core_state; @@ -706,7 +711,8 @@ let action_request_sequential2 loc tid aid = function liftMem (Mem.load loc lvalue_ty ptr_val) >>= fun (_, mval) -> liftCore_run (mk_mval' mval) >>= fun mval' -> liftMem (Mem.store loc lvalue_ty false ptr_val mval') >>= fun fp -> - liftMem (Mem.prefix_of_pointer ptr_val) >>= fun pref -> + ND.read (fun dr_st -> dr_st.core_file.Core.tagDefs) >>= fun tagDefs -> + liftMem (Mem.prefix_of_pointer tagDefs ptr_val) >>= fun pref -> ND.update (fun dr_st -> <| dr_st with core_state= Core_run.update_thread_state tid (mk_th_st' aid fp mval mval') dr_st.core_state; @@ -809,7 +815,7 @@ let perform_memop_request2 loc memop cvals tid mk_th_st = | (Mem_common.Memcmp, [Core.Vobject (Core.OVpointer ptr_val1); Core.Vobject (Core.OVpointer ptr_val2); Core.Vobject (Core.OVinteger size_ival)]) -> - liftMem (Mem.memcmp ptr_val1 ptr_val2 size_ival) >>= fun res -> + liftMem (Mem.memcmp loc ptr_val1 ptr_val2 size_ival) >>= fun res -> ND.return (mk_th_st (Core.Vobject (Core.OVinteger res))) | (Mem_common.PtrWellAligned, [Core.Vctype ref_ty; Core.Vobject (Core.OVpointer ptrval)]) -> @@ -865,9 +871,10 @@ let perform_memop_request2 loc memop cvals tid mk_th_st = ND.return (mk_th_st (Core.Vobject (Core.OVpointer ptrval'))) | (Mem_common.CHERI_intrinsic str (ret_ty, tys), cvals) -> + ND.read (fun st -> st.core_file.Core.tagDefs) >>= fun tagDefs -> let mvals = Utils.map2 (fun ty cval -> - fromJust "CHERI_intrinsic call" (Caux.memValueFromValue ty cval) + fromJust "CHERI_intrinsic call" (Caux.memValueFromValue tagDefs ty cval) ) tys cvals in liftMem (Mem.call_intrinsic loc str mvals) >>= fun res_opt -> match res_opt with @@ -899,6 +906,46 @@ let perform_memop_request2 loc memop cvals tid mk_th_st = +val step_kind_of_core_step2: Core_reduction.core_step2 -> step_kind +let step_kind_of_core_step2 = function + | Core_reduction.Step_ccall2 _ _ -> + SK_misc ["ccall"] + | Core_reduction.Step_with_runstate2 (Core_reduction.RSK_eval debug_str) _ -> + SK_eval debug_str + | Core_reduction.Step_with_runstate2 (Core_reduction.RSK_tau debug_str _) _ -> + SK_tau debug_str + | Core_reduction.Step_tau2 debug_str _ _ -> + SK_tau debug_str + | Core_reduction.Step_action_request2 debug_str _ _ _ _ -> + SK_action_request debug_str + | Core_reduction.Step_blocked2 -> + SK_misc ["blocked"] + | Core_reduction.Step_error2 debug_str -> + SK_misc ["error"; debug_str] + | Core_reduction.Step_thread_done2 _ _ -> + SK_misc ["thread_done"] + | Core_reduction.Step_done2 _ -> + SK_done + | Core_reduction.Step_memop_request2 _ _ _ _ _ _ -> + SK_memop_request + | Core_reduction.Step_spawn_threads2 _ _ -> + SK_misc ["spawn_threads"] + | Core_reduction.Step_fs2 _ _ _ -> + SK_misc ["fs_step"] + | Core_reduction.Step_nd2 _ -> + SK_misc ["nd"] +end + +(* When enabled, this adds NDstep nodes which is used by the web instance for the interactive + * execution stepping. *) +val as_step: forall 'a. bool -> Core_reduction.core_step2 -> driverM 'a -> driverM 'a +let as_step do_stepping step m = + if do_stepping then + let kind = step_kind_of_core_step2 step in + ND.mk_step kind [(kind, m)] + else + m + let can_advance = function | Core_reduction.Step_ccall2 _ _ -> false @@ -1071,7 +1118,9 @@ let rec drive_nonmemory_steps_aux2 (acc: map Mem.thread_id (list Core_reduction. | Nothing -> drive_nonmemory_steps_aux2 (Map.insert tid steps acc) xs' | Just step -> - advance_step tid step >>= fun wakeups -> + ND.get >>= fun dr_st -> + as_step dr_st.do_stepping step (advance_step tid step) + >>= fun wakeups -> let xs'' = match wakeups with | NOWAKEUP -> @@ -1313,7 +1362,9 @@ let prepare_exit core_st cval = (* performing all action and memop requests until there are no more *) val process_core_step2: bool -> (bool -> driverM unit) -> Core_reduction.core_step2 -> driverM unit -let process_core_step2 with_concurrency driver2 = function +let process_core_step2 with_concurrency driver2 step = + ND.get >>= fun dr_st -> + as_step dr_st.do_stepping step $ match step with | Core_reduction.Step_action_request2 _ loc tid _ m_request -> liftCore_run m_request >>= fun request -> perform_action_request2 with_concurrency loc tid request >>= fun () -> @@ -1501,18 +1552,19 @@ let finalize debug_str dr_st = (* TODO: it is problematic for proofy backend that this function may diverge *) (* TODO: HACK *) -let initial_driver_state file fs_state = +let initial_driver_state file fs_state do_stepping = <| core_file= file; core_extern= Core_linking.create_extern_symmap file; core_state= Core_run.initial_core_state; core_run_state= Core_run.initial_core_run_state (Caux.collect_labeled_continuations_NEW file); - layout_state= Mem.initial_mem_state; + layout_state= Mem.initial_mem_state file.Core.tagDefs; concurrency_state= Cmm_op.symInitialState Cmm_op.symInitialPre; fs_state= fs_state; trace= []; symbolic_assoc= Map.empty; blocked= false; + do_stepping= do_stepping; dr_step_counter= 0; |> diff --git a/frontend/model/errors.lem b/frontend/model/errors.lem index cd55f2365..77ecbc6cd 100644 --- a/frontend/model/errors.lem +++ b/frontend/model/errors.lem @@ -31,6 +31,7 @@ type core_typing_cause = | MismatchIf of core_base_type (* then *) * core_base_type (* else *) | MismatchExpected of string (* syntax info *) * core_base_type (* expected *) * string (* found *) | MismatchFound of string (* syntax info *) * string (* expected *) * maybe core_base_type (* found *) + | ArityMismatchRun of nat(* expected *) * nat(* found *) | UnresolvedSymbol of name | FunctionOrProcedureSymbol of Symbol.sym | CFunctionExpected of name (* symbol *) diff --git a/frontend/model/formatted.lem b/frontend/model/formatted.lem index be7200362..6e27293ff 100644 --- a/frontend/model/formatted.lem +++ b/frontend/model/formatted.lem @@ -346,8 +346,8 @@ declare hol target_rep function stringFromCtype = `pp$stringFromCtype` (* the third argument specify have many characters to load at most *) -val load_character_array_aux: Ctype.ctype -> Mem.pointer_value -> maybe nat -> list char -> Mem.memM (list char) -let rec load_character_array_aux elem_ty ptrval prec_n_opt acc = +val load_character_array_aux: Loc.t -> Ctype.ctype -> Mem.pointer_value -> maybe nat -> list char -> Mem.memM (list char) +let rec load_character_array_aux loc elem_ty ptrval prec_n_opt acc = match prec_n_opt with | Just 0 -> Mem.return (List.reverse acc) @@ -366,13 +366,9 @@ let rec load_character_array_aux elem_ty ptrval prec_n_opt acc = Mem.return (List.reverse acc) else Mem.bind - begin if Global.is_CHERI () then - Mem.eff_array_shift_ptrval (Loc.other "printf()") ptrval elem_ty (Mem.integer_ival 1) - else - Mem.return (Mem.array_shift_ptrval ptrval elem_ty (Mem.integer_ival 1)) - end + (Mem.eff_array_shift_ptrval loc ptrval elem_ty (Mem.integer_ival 1)) (fun ptrval' -> - load_character_array_aux elem_ty ptrval' prec_n_opt' ((Decode.encode_character_constant n) :: acc))) + load_character_array_aux loc elem_ty ptrval' prec_n_opt' ((Decode.encode_character_constant n) :: acc))) (fun () -> error "WIP: Formatted.load_character_array, non constant ival") ) (fun _ _ -> error "Formatted.load_character_array, found a float") @@ -382,15 +378,11 @@ let rec load_character_array_aux elem_ty ptrval prec_n_opt acc = (fun _ _ -> error "Formatted.load_character_array, found a union") ) end -val load_character_array: Ctype.ctype -> Mem.pointer_value -> maybe nat -> Mem.memM (list char) -let load_character_array elem_ty ptrval prec_n_opt = +val load_character_array: Loc.t -> Ctype.ctype -> Mem.pointer_value -> maybe nat -> Mem.memM (list char) +let load_character_array loc elem_ty ptrval prec_n_opt = Mem.bind - begin if Global.is_CHERI () then - Mem.eff_array_shift_ptrval (Loc.other "printf()") ptrval elem_ty (Mem.integer_ival 0) - else - Mem.return (Mem.array_shift_ptrval ptrval elem_ty (Mem.integer_ival 0)) - end - (fun ptrval' -> load_character_array_aux elem_ty ptrval' prec_n_opt []) + (Mem.eff_array_shift_ptrval loc ptrval elem_ty (Mem.integer_ival 0)) + (fun ptrval' -> load_character_array_aux loc elem_ty ptrval' prec_n_opt []) @@ -650,7 +642,7 @@ let convert loc eval_conv prec_opt lm_opt cspec flags args = else match Mem_aux.pointerValueFromMemValue mval with | Just (_, ptrval) -> - load_character_array ref_ty ptrval prec >>= fun chars -> + load_character_array loc ref_ty ptrval prec >>= fun chars -> Mem.return (Right (U.Defined (false, chars, args'))) | Nothing -> error "WIP[error message], Formatted => CS_s, didn't load a pointer" @@ -757,11 +749,13 @@ let rec printf_aux loc eval_conv acc fs ty_ptrvals = val store_chars_in_array: bool -> Mem.pointer_value -> list char -> Mem.memM unit -let rec store_chars_in_array zero_terminated ptrval = function +let rec store_chars_in_array zero_terminated ptrval = + let loc = Loc.other "store_chars_in_array()" in + function | [] -> if zero_terminated then - Mem.store (Loc.other "store_chars_in_array()") Ctype.char false ptrval - (Mem.integer_value_mval Ctype.Char (Mem.integer_ival 0)) >>= fun _ -> + Mem.store loc Ctype.char false ptrval + (Mem.integer_value_mval Ctype.Char (Mem.integer_ival 0)) >>= fun _ -> Mem.return () else Mem.return () @@ -770,14 +764,10 @@ let rec store_chars_in_array zero_terminated ptrval = function Mem.integer_value_mval Ctype.Char (Mem.integer_ival (Decode.decode_character_constant (Decode.escaped_char c))) in (* TODO: maybe needs to be unsigned char *) - Mem.store (Loc.other "store_chars_in_array()") Ctype.char false ptrval c_mval >>= fun _ -> - begin if Global.is_CHERI () then - Mem.eff_array_shift_ptrval (Loc.other "store_chars_in_array()") ptrval Ctype.char (Mem.integer_ival 1) - else - Mem.return (Mem.array_shift_ptrval ptrval Ctype.char (Mem.integer_ival 1)) - end >>= fun ptrval' -> + Mem.store loc Ctype.char false ptrval c_mval >>= fun _ -> + Mem.eff_array_shift_ptrval loc ptrval Ctype.char (Mem.integer_ival 1) >>= fun ptrval' -> store_chars_in_array zero_terminated ptrval' cs -end + end val vsnprintf: Loc.t -> diff --git a/frontend/model/implementation.lem b/frontend/model/implementation.lem index 352279a12..6bfb4b382 100644 --- a/frontend/model/implementation.lem +++ b/frontend/model/implementation.lem @@ -24,8 +24,8 @@ declare ocaml target_rep function register_enum = `(Ocaml_implementation.get()). declare ocaml target_rep function typeof_enum = `(Ocaml_implementation.get()).typeof_enum` declare ocaml target_rep function normalise_integerType = `Ocaml_implementation.normalise_integerType (Ocaml_implementation.get())` -val sizeof_ty: map Symbol.sym (Loc.t * Ctype.tag_definition) -> Ctype.ctype -> integer -val alignof_ty: map Symbol.sym (Loc.t * Ctype.tag_definition) -> Ctype.ctype -> integer +val sizeof_ty: Ctype.tag_definitions -> Ctype.ctype -> integer +val alignof_ty: Ctype.tag_definitions -> Ctype.ctype -> integer declare ocaml target_rep function sizeof_ty = `Ocaml_implementation.sizeof` declare ocaml target_rep function alignof_ty = `Ocaml_implementation.alignof` diff --git a/frontend/model/integerType.lem b/frontend/model/integerType.lem index 2e8e80d5c..9587eb8ab 100644 --- a/frontend/model/integerType.lem +++ b/frontend/model/integerType.lem @@ -3,8 +3,8 @@ * Victor Gomes *) -open import Symbol -open import Pervasives + open import Pervasives + import Symbol type integerBaseType [name = "^\\(\\|\\([a-z A-Z]+_\\)\\)ibty[0-9]*'?$"] = diff --git a/frontend/model/mem.lem b/frontend/model/mem.lem index 8c3232f69..1a756237c 100644 --- a/frontend/model/mem.lem +++ b/frontend/model/mem.lem @@ -32,7 +32,7 @@ declare ocaml target_rep function overlapping = `Impl_mem.overlapping` type mem_state -val initial_mem_state: mem_state +val initial_mem_state: Ctype.tag_definitions -> mem_state declare ocaml target_rep type mem_state = `Impl_mem.mem_state` declare ocaml target_rep function initial_mem_state = `Impl_mem.initial_mem_state` @@ -110,7 +110,7 @@ declare ocaml target_rep function ge_ptrval = `Impl_mem.ge_ptrval` declare ocaml target_rep function diff_ptrval = `Impl_mem.diff_ptrval` val update_prefix: (Symbol.prefix * mem_value) -> memM unit -val prefix_of_pointer: pointer_value -> memM (maybe string) +val prefix_of_pointer: Ctype.tag_definitions -> pointer_value -> memM (maybe string) declare ocaml target_rep function update_prefix = `Impl_mem.update_prefix` declare ocaml target_rep function prefix_of_pointer = `Impl_mem.prefix_of_pointer` @@ -138,8 +138,12 @@ declare ocaml target_rep function null_cap = `Impl_mem.null_cap` declare ocaml target_rep function ptr_t_int_value = `Impl_mem.ptr_t_int_value` (* Pointer shifting constructors *) -val array_shift_ptrval: pointer_value -> Ctype.ctype -> integer_value -> pointer_value -val member_shift_ptrval: pointer_value -> Symbol.sym -> Symbol.identifier -> pointer_value +val array_shift_ptrval: + Ctype.tag_definitions -> + Loc.t -> pointer_value -> Ctype.ctype -> integer_value -> Undefined.t pointer_value +val member_shift_ptrval: + Ctype.tag_definitions -> + pointer_value -> Symbol.sym -> Symbol.identifier -> pointer_value declare ocaml target_rep function array_shift_ptrval = `Impl_mem.array_shift_ptrval` declare ocaml target_rep function member_shift_ptrval = `Impl_mem.member_shift_ptrval` @@ -151,7 +155,7 @@ declare ocaml target_rep function eff_member_shift_ptrval = `Impl_mem.eff_member val memcpy: Loc.t -> pointer_value -> pointer_value -> integer_value -> memM pointer_value -val memcmp: pointer_value -> pointer_value -> integer_value -> memM integer_value +val memcmp: Loc.t -> pointer_value -> pointer_value -> integer_value -> memM integer_value val realloc: Loc.t -> Mem_common.thread_id -> integer_value -> pointer_value -> integer_value -> memM pointer_value declare ocaml target_rep function memcpy = `Impl_mem.memcpy` @@ -186,7 +190,7 @@ val integer_ival: integer -> integer_value val max_ival: Ctype.integerType -> integer_value val min_ival: Ctype.integerType -> integer_value val op_ival: Mem_common.integer_operator -> integer_value -> integer_value -> integer_value -val offsetof_ival: map Symbol.sym (Loc.t * Ctype.tag_definition) -> Symbol.sym -> Symbol.identifier -> integer_value +val offsetof_ival: Ctype.tag_definitions -> Symbol.sym -> Symbol.identifier -> integer_value val bitwise_complement_ival: Ctype.integerType -> integer_value -> integer_value val bitwise_and_ival: Ctype.integerType -> integer_value -> integer_value -> integer_value val bitwise_or_ival: Ctype.integerType -> integer_value -> integer_value -> integer_value diff --git a/frontend/model/mem_aux.lem b/frontend/model/mem_aux.lem index 38c634bc5..011d52705 100644 --- a/frontend/model/mem_aux.lem +++ b/frontend/model/mem_aux.lem @@ -6,15 +6,6 @@ val integerFromIntegerValue: integer_value -> maybe integer let integerFromIntegerValue ival = eval_integer_value ival -(* -val symbolicFromIntegerValue: integer_value -> maybe Symbolic.symbolic -let symbolicFromIntegerValue ival = - case_integer_value ival - (fun _ -> Nothing) - (fun symb -> Just symb) - (fun () -> Nothing) -*) - val integerValueFromMemValue: mem_value -> maybe (Ctype.integerType * integer_value) let integerValueFromMemValue mval = let () = Debug.print_debug 1 [] (fun () -> @@ -49,29 +40,6 @@ let isUnspecifiedMemValue mval = | Nothing -> false end -(* -val symbolicFromMemValue: mem_value -> maybe (Symbolic.symbolic mem_value Mem.pointer_value) -let symbolicFromMemValue mval = - error "symbolicFromMemValue" -*) -(* -let symbolicFromMemValue mval = -(* - maybe Nothing (symbolicFromIntegerValue -| snd) (integerValueFromMemValue mval) -*) - case_mem_value mval - (fun _ -> Nothing) - (fun symb -> Just symb) - (fun _ _ -> Nothing) - (fun _ _ -> Nothing) - (fun _ _ -> Nothing) - (fun _ -> Nothing) - (fun _ _ -> Nothing) - (fun _ _ _ -> Nothing) -*) - - - val pointerValueFromMemValue: mem_value -> maybe (Ctype.ctype * pointer_value) let pointerValueFromMemValue mem_val = let () = Debug.print_debug 1 [] (fun () -> @@ -87,8 +55,6 @@ let pointerValueFromMemValue mem_val = (fun _ _ -> Nothing) (fun _ _ _ -> Nothing) - - val integer_mval: Ctype.integerType -> integer -> mem_value let integer_mval ity n = integer_value_mval ity (integer_ival n) diff --git a/frontend/model/mini_pipeline.lem b/frontend/model/mini_pipeline.lem index c7da2516f..923b6815f 100644 --- a/frontend/model/mini_pipeline.lem +++ b/frontend/model/mini_pipeline.lem @@ -1,5 +1,5 @@ -open import Pervasives Utils Symbol - +open import Pervasives Utils +import Symbol import Pp import Core @@ -13,6 +13,7 @@ import GenTypes GenTypesAux (* Ail typing *) import GenTyping ErrorMonad TypingError +import AilTypesAux Implementation (* Elaboration *) open import Translation Translation_aux @@ -56,39 +57,63 @@ module Eff = Exception let inline (>>=) = Eff.bind -val evalConstantExpressionAux: - Loc.t -> (map string Symbol.sym) * C.fun_map unit * C.impl -> +type eval_mode = + | Own_type + (* only evaluates *) + | Check_representable_in of Ctype.ctype + (* check that the value is representable in the given **integer** type *) + | Convert_to of Ctype.ctype + (* convert the value to the given **integer** type *) + +val evalIntegerConstantExpressionAux: + TranslateEff.elab_config -> (map string Symbol.sym) * C.fun_map unit * C.impl -> A.sigma unit -> (GenTypes.genTypeCategory -> Eff.exceptM unit Errors.error) -> - maybe Ctype.ctype -> A.expression unit -> Eff.exceptM C.value Errors.error + eval_mode -> A.expression unit -> Eff.exceptM C.value Errors.error -let evalConstantExpressionAux loc (*TODO*)(ailnames, stdlib_fun_map, impl) sigm typing_guard ty_opt expr = +let evalIntegerConstantExpressionAux + elab_conf (*TODO*)(ailnames, stdlib_fun_map, impl) sigm typing_guard mode d_expr += let toAilTau: A.expression unit -> ErrorMonad.errorM (A.expression GenTypes.genTypeCategory) = GenTyping.annotate_expression (fun loc -> GenTyping.annotate_block loc Nothing) sigm [] (*TODO: check*)GenTyping.CTXother in let toCore (a_e: A.expression GenTypes.genTypeCategory) : TranslateEff.elabM (Core.expr unit) = (* STD §6.6#4 *) - (* NOTE: this constraint requires the evaluated constant to be within the range of expression's type *) + (* NOTE: this constraint requires the evaluated constant to be within the + * range of expression's type *) let stdlib = Translation_aux.mk_translation_stdlib (ailnames, stdlib_fun_map) in - let ty = match ty_opt with - | Just ty -> - ty - | Nothing -> + (* the type in which the value must be representable is either provided, inferred, + * or guaranteed by conversion *) + let (ty, conv_ty_opt) = match mode with + | Own_type -> (* TODO/NOTE: this should correspond to constants from array sizes and such *) - Translation_aux.ctype_of a_e + (Translation_aux.ctype_of a_e, Nothing) + | Check_representable_in ty -> + (ty, Nothing) + | Convert_to conv_ty -> + (Translation_aux.ctype_of a_e, Just conv_ty) end in let oTy = force_core_object_type_of_ctype ty in - TranslateEff.bind (translate_expression Nothing true ECTX_other ((Nothing: maybe Symbol.sym), (Nothing: maybe Symbol.sym)) stdlib (translate_tag_definitions sigm.A.tag_definitions: C.core_tag_definitions) a_e) (fun core_e -> - TranslateEff.bind (TranslateEff.wrapped_fresh_symbol (C.BTy_loaded oTy)) (fun e_wrp -> - TranslateEff.bind (TranslateEff.wrapped_fresh_symbol (C.BTy_object oTy)) (fun obj_wrp -> - TranslateEff.return begin + TranslateEff.elab_bind (translate_expression Nothing true ECTX_other + ((Nothing: maybe Symbol.sym), (Nothing: maybe Symbol.sym)) stdlib + (translate_tag_definitions sigm.A.tag_definitions: Ctype.tag_definitions) a_e) (fun core_e -> + TranslateEff.elab_bind (TranslateEff.wrapped_fresh_symbol (C.BTy_loaded oTy)) (fun e_wrp -> + TranslateEff.elab_bind (TranslateEff.wrapped_fresh_symbol (C.BTy_object oTy)) (fun obj_wrp -> + TranslateEff.elab_return begin Core_aux.mk_wseq_e e_wrp.TranslateEff.sym_pat core_e begin Core_aux.mk_pure_e begin Core_aux.mk_case_pe e_wrp.TranslateEff.sym_pe [ ( Core_aux.mk_specified_pat obj_wrp.TranslateEff.sym_pat , Core_aux.mk_if_pe (stdlib.mkcall_is_representable obj_wrp.TranslateEff.sym_pe ty) - (Caux.mk_specified_pe obj_wrp.TranslateEff.sym_pe) + (Caux.mk_specified_pe begin + match conv_ty_opt with + | Just conv_ty -> + stdlib.mkcall_conv_int conv_ty obj_wrp.TranslateEff.sym_pe + | Nothing -> + obj_wrp.TranslateEff.sym_pe + end + end) (Core_aux.mk_error_pe "§6.6#4 failed" obj_wrp.TranslateEff.sym_pe) ) ; ( Core_aux.mk_unspecified_pat (Core_aux.mk_empty_pat C.BTy_ctype) (* TODO: this should be dead code? *) @@ -98,36 +123,37 @@ let evalConstantExpressionAux loc (*TODO*)(ailnames, stdlib_fun_map, impl) sigm end))) in (* typechecks the expression *) - match ErrorMonad.runErrorMonad (toAilTau expr) with + match ErrorMonad.runErrorMonad (toAilTau d_expr) with | Left (loc, err) -> Eff.fail (loc, Errors.DESUGAR Errors.Desugar_illtypedIntegerConstant) | Right a_expr -> (* applies the provided typing guard *) typing_guard (GenTypes.genTypeCategoryOf a_expr) >>= fun () -> - - let callconv = - if Global.has_switch Global.SW_inner_arg_temps then Core.Inner_arg_callconv else Core.Normal_callconv in - (* elaborate the typed expression into Core *) - let (core_expr, translate_final_st) = TranslateEff.runStateM (toCore a_expr) (TranslateEff.elab_init callconv) in - + let (core_expr, translate_final_st) = + TranslateEff.runElabM elab_conf (toCore a_expr) TranslateEff.elab_initial_state in + let core_tagDefs = Translation.translate_tag_definitions sigm.A.tag_definitions in let dr_st = (* this just builds the shell of the driver state *) let dummy_core_file = Core_run_aux.convert_file <| C.main= Nothing - ; C.calling_convention= callconv + ; C.calling_convention= elab_conf.TranslateEff.calling_convention ; C.stdlib= stdlib_fun_map ; C.impl= impl ; C.globs= [] ; C.funs= Map.empty - ; C.tagDefs= Map.empty + ; C.tagDefs= core_tagDefs ; C.extern= Map.empty - ; C.funinfo= Map.empty - ; C.loop_attributes= Map.empty + ; C.funinfo= Map.empty + ; C.loop_attributes= Map.empty ; C.visible_objects_env = Map.empty |> in - let init_dr_st = Driver.initial_driver_state dummy_core_file Fs.fs_initial_state in + let init_dr_st = + Driver.initial_driver_state + dummy_core_file + Fs.fs_initial_state + false (* no stepping *) in (* spawning a thread with the Core expression we just generated as it's arena *) let ((tid, core_st), run_st) = State.runStateM ( Core_run.spawn_thread Nothing <| @@ -135,7 +161,7 @@ let evalConstantExpressionAux loc (*TODO*)(ailnames, stdlib_fun_map, impl) sigm Core_run.stack= Core_run.Stack_empty (*Core_run.push_empty_continuation Nothing Core_run.empty_stack*); Core_run.errno= Mem.null_ptrval Ctype.signed_int; Core_run.env= [Map.empty]; - Core_run.current_loc= loc; + Core_run.current_loc= Loc.locOf d_expr; Core_run.exec_loc= Core_run.ELoc_normal []; (* TODO: maybe create a new variant *) Core_run.current_proc_opt= Nothing; |> init_dr_st.Driver.core_state @@ -152,10 +178,7 @@ let evalConstantExpressionAux loc (*TODO*)(ailnames, stdlib_fun_map, impl) sigm ND.return (Driver.finalize "Mini_pipeline" dr_st') ) ) in - let execs = Ctype_aux.with_tagDefs (Translation.translate_tag_definitions sigm.A.tag_definitions) begin - fun () -> runND_proxy driver_action dr_st - end in - match execs with + match runND_proxy driver_action dr_st with | [(ND.Active dres, _, _ )] -> Eff.return dres.Driver.dres_core_value | [(ND.Killed _ (ND.Undef ub_loc [ub]), _, _)] -> @@ -169,25 +192,25 @@ let evalConstantExpressionAux loc (*TODO*)(ailnames, stdlib_fun_map, impl) sigm val evalIntegerConstantExpression: - Loc.t -> (map string Symbol.sym) * C.fun_map unit * C.impl -> A.sigma unit -> - maybe Ctype.ctype -> A.expression unit -> Eff.exceptM integer Errors.error + TranslateEff.elab_config -> (map string Symbol.sym) * C.fun_map unit * C.impl -> A.sigma unit -> + eval_mode -> A.expression unit -> Eff.exceptM integer Errors.error -let evalIntegerConstantExpression loc core_env sigm ty_opt expr = +let evalIntegerConstantExpression elab_conf core_env sigm mode d_expr = let typing_guard gtc = let do_fail = - Eff.fail (loc, Errors.DESUGAR (Errors.Desugar_UndefinedBehaviour Undefined.UB055_invalid_integer_constant_expression)) + Eff.fail (Loc.locOf d_expr, Errors.DESUGAR (Errors.Desugar_UndefinedBehaviour Undefined.UB055_invalid_integer_constant_expression)) in match gtc with | GenTypes.GenLValueType _ _ _ -> do_fail | GenTypes.GenRValueType gty -> - (* TODO: check ty_opt and gty ? *) + (* TODO: check mode and gty ? *) if GenTypesAux.is_integer gty then Eff.return () else do_fail end in - evalConstantExpressionAux loc core_env sigm typing_guard ty_opt expr >>= function + evalIntegerConstantExpressionAux elab_conf core_env sigm typing_guard mode d_expr >>= function | C.Vloaded (C.LVspecified (C.OVinteger ival)) -> match Mem.eval_integer_value ival with | Just n -> @@ -200,19 +223,41 @@ let evalIntegerConstantExpression loc core_env sigm ty_opt expr = "cval: " ^ Pp.stringFromCore_value cval ) in (* given that typing guard has passed the evaluator must evaluate to an integer value *) - error (Loc.stringFromLocation loc ^ ", Mini_pipeline.evalIntegerConstantExpression") + error + ( Loc.stringFromLocation (Loc.locOf d_expr) + ^ ", Mini_pipeline.evalIntegerConstantExpression" ) end -val typecheckAil: A.sigma unit -> A.gamma -> A.expression unit -> either (Loc.t * TypingError.typing_error) Ctype.ctype -let typecheckAil sigm gamm expr = - match ErrorMonad.runErrorMonad (GenTyping.annotate_expression (fun loc -> GenTyping.annotate_block loc Nothing) sigm gamm (*TODO: check*)GenTyping.CTXother expr) with +val typecheckAil: + A.sigma unit -> A.gamma -> A.expression unit -> + either (Loc.t * TypingError.typing_error) Ctype.ctype +let typecheckAil sigm gamm d_expr = + match + ErrorMonad.runErrorMonad (GenTyping.annotate_expression (fun loc -> + GenTyping.annotate_block loc Nothing) sigm gamm (*TODO: check*)GenTyping.CTXother d_expr + ) + with | Left z -> Left z | Right a_expr -> Right (Translation_aux.ctype_of a_expr) end +(* Typechecks the Ail expression and returns its promoted type (as [Right (Just ty)]), + * or [Right Nothing] if it does not have an integer type, or returns the type error if it failed + * to typecheck *) +val typecheckAil_promoted: + IntegerImpl.implementation -> A.sigma unit -> A.gamma -> A.expression unit -> + either (Loc.t * TypingError.typing_error) (maybe Ctype.ctype) +let typecheckAil_promoted impl sigm gamm d_expr = + match typecheckAil sigm gamm d_expr with + | Left z -> + Left z + | Right ty -> + Right (AilTypesAux.promotion impl ty) + end + val in_range_of_signed_int: integer -> maybe bool let in_range_of_signed_int n = match ( Mem.eval_integer_value (Mem.min_ival (Ctype.Signed Ctype.Int_)) diff --git a/frontend/model/nondeterminism.lem b/frontend/model/nondeterminism.lem index 292718b59..76c5341cb 100644 --- a/frontend/model/nondeterminism.lem +++ b/frontend/model/nondeterminism.lem @@ -277,6 +277,15 @@ and liftND get put liftInfo liftErr (ND m) = ) +val lift_undef: forall 'a 'info 'err 'cs 'st. Undefined.t 'a -> ndM 'a 'info 'err 'cs 'st +let lift_undef m = + match m with + | Undefined.Defined a -> return a + | Undefined.Undef loc ubs -> kill (Undef loc ubs) + | Undefined.Error loc str -> kill (Error loc str) + end + + let mk_step info xs = let () = Debug.print_debug 2 [] (fun () -> diff --git a/frontend/model/pp.lem b/frontend/model/pp.lem index 0e7f24b5a..9e060b754 100644 --- a/frontend/model/pp.lem +++ b/frontend/model/pp.lem @@ -84,18 +84,3 @@ declare ocaml target_rep function pretty_stringFromMem_mem_value = `String_mem.s declare hol target_rep function stringFromMem_mem_value = `pp_mem$pp_mem_value` declare hol target_rep function pretty_stringFromMem_mem_value = `pp_mem$pp_mem_value` - - -(* DEBUG *) -val stringFromCmm_op_symState: Cmm_op.symState -> string -declare ocaml target_rep function stringFromCmm_op_symState = `Pp_cmm.string_of_exeState` -declare hol target_rep function stringFromCmm_op_symState = `util$emptyString` - - -(* -val stringFromSequenceGraph: list (nat * nat) -> string -declare ocaml target_rep function stringFromSequenceGraph = `Pp_cmm.stringFromSequenceGraph` -*) - -val stringFromMem_iv_mem_constraint: Mem.mem_iv_constraint -> string -declare ocaml target_rep function stringFromMem_iv_mem_constraint = `String_mem.string_of_iv_memory_constraint` diff --git a/frontend/model/scope_table.lem b/frontend/model/scope_table.lem index edf11f2df..e9a915f78 100644 --- a/frontend/model/scope_table.lem +++ b/frontend/model/scope_table.lem @@ -1,6 +1,6 @@ (* Symbols table with stacked scopes *) -open import Pervasives Utils Symbol -import Map_extra +open import Pervasives Utils +import Map_extra Symbol type t 'a_scope 'b_ident 'c_a = list ('a_scope * map 'b_ident 'c_a) diff --git a/frontend/model/translation.lem b/frontend/model/translation.lem index f9cd680eb..dd1e32a17 100644 --- a/frontend/model/translation.lem +++ b/frontend/model/translation.lem @@ -1,5 +1,4 @@ open import Pervasives Utils Loc String_extra Num -import Global import State Undefined Translation_effect Loc List_extra open import Translation_aux @@ -30,10 +29,10 @@ module Cmm = Cmm_csem module E = Translation_effect module Operators = struct - let inline (>>=) = E.bind - let inline (>>) m f = E.bind m (fun _ -> f) - let inline (<$>) f ma = E.bind ma (fun a -> E.return (f a)) - let inline (<*>) mf m = E.bind mf (fun f -> f <$> m) + let inline (>>=) = E.elab_bind + let inline (>>) m f = E.elab_bind m (fun _ -> f) + let inline (<$>) f ma = E.elab_bind ma (fun a -> E.elab_return (f a)) + let inline (<*>) mf m = E.elab_bind mf (fun f -> f <$> m) end open Operators @@ -269,6 +268,7 @@ val translate_mul_operator: A.expression GenTypes.genTypeCategory -> E.elabM (C.expr unit) let translate_mul_operator loc translate_expr usual_arithmetic_conversion stdlib result_ty e1 e2 = + E.read_config >>= fun conf -> let oTy1 = force_core_object_type_of_ctype (ctype_of e1) in let oTy2 = force_core_object_type_of_ctype (ctype_of e2) in translate_expr e1 >>= fun core_e1 -> @@ -291,7 +291,7 @@ let translate_mul_operator loc translate_expr usual_arithmetic_conversion stdlib (* Both operand are specified *) let core_mul = Caux.mk_std_pe "§6.5.5#4" (Caux.mk_op_pe C.OpMul promoted1_pe promoted2_pe) in Caux.mk_specified_pe begin -if Global.is_CHERI () && Ctype.is_ptr_t result_ty then +if conf.E.is_CHERI && Ctype.is_ptr_t result_ty then Caux.mk_let_pe cap_wrp.E.sym_pat (Caux.mk_memop_pe (Mem_common.DeriveCap (Mem_common.DCbinary (A.Arithmetic A.Mul)) (AilTypesAux.is_signed_integer_type result_ty)) [obj1_wrp.E.sym_pe; obj2_wrp.E.sym_pe]) @@ -335,6 +335,7 @@ val translate_div_mod_operator: A.expression GenTypes.genTypeCategory -> E.elabM (C.expr unit) let translate_div_mod_operator loc translate_expr usual_arithmetic_conversion stdlib result_ty aop e1 e2 = + E.read_config >>= fun conf -> (* STD "§6.5.5" *) let oTy1 = force_core_object_type_of_ctype (ctype_of e1) in let oTy2 = force_core_object_type_of_ctype (ctype_of e2) in @@ -404,7 +405,7 @@ end (Caux.mk_op_pe C.OpDiv conv1_wrp.E.sym_pe conv2_wrp.E.sym_pe) result_ty) begin Caux.mk_specified_pe (Caux.mk_std_pe "§6.5.5#5, sentence 1" begin - if Global.backend_name () = "Cn" then + if conf.E.is_CN then match Cty.match_integer_ctype result_ty with | Cty.MatchedItySigned ity -> Caux.mk_wrapI_pe ity iop conv1_wrp.E.sym_pe conv2_wrp.E.sym_pe @@ -618,6 +619,7 @@ val translate_bitwise_operator: A.expression GenTypes.genTypeCategory -> E.elabM (C.expr unit) let translate_bitwise_operator loc translate_expr usual_arithmetic_conversion stdlib result_ty aop e1 e2 = + E.read_config >>= fun conf -> let (std_id, stdlib_call) = match aop with | A.Band -> ("§6.5.10", (fun ty pe1 pe2 -> C.Pexpr [] () (C.PEctor C.CivAND [Caux.mk_ail_ctype_pe ty; pe1; pe2]))) | A.Bxor -> ("§6.5.11", (fun ty pe1 pe2 -> C.Pexpr [] () (C.PEctor C.CivXOR [Caux.mk_ail_ctype_pe ty; pe1; pe2]))) @@ -643,7 +645,7 @@ let translate_bitwise_operator loc translate_expr usual_arithmetic_conversion st [ ( Caux.mk_tuple_pat [ Caux.mk_specified_pat obj1_wrp.E.sym_pat ; Caux.mk_specified_pat obj2_wrp.E.sym_pat ] , (* Both operand are specified *) Caux.mk_specified_pe (Caux.mk_std_pe (std_id ^ "#4") begin - if Global.is_CHERI () && Ctype.is_ptr_t result_ty then + if conf.E.is_CHERI && Ctype.is_ptr_t result_ty then mk_cheri_derive_and_assign_cap (AilTypesAux.is_signed_integer_type result_ty) (Mem_common.DCbinary (A.Arithmetic aop)) @@ -669,6 +671,7 @@ val translate_postfix: A.expression GenTypes.genTypeCategory -> E.elabM (C.expr unit) let translate_postfix loc translate_expr stdlib result_ty op e = + E.read_config >>= fun conf -> (* TODO: use atomic RMW if the type is atomic *) (* NOTE: if I read N2329 correctly, in C2X this will not be an RMW for the atomic case (but a do while with compare_exchange_weak with seq_cst, seq_cst) *) @@ -705,7 +708,7 @@ match Ctype.unatomic_ ty with (* TODO: check again *) let mk_cheri pe = let is_signed = AilTypesAux.is_signed_integer_type result_ty in - if Global.is_CHERI () && Ctype.is_ptr_t result_ty then + if conf.E.is_CHERI && Ctype.is_ptr_t result_ty then mk_cheri_derive_and_assign_cap is_signed (Mem_common.DCunary op) (obj_wrp.E.sym_pe, Caux.mk_nullcap_pe is_signed) @@ -739,7 +742,7 @@ end end end end in -if Global.is_CHERI () then +if conf.E.is_CHERI then match Ctype.unatomic_ ty with | Ctype.Pointer _ ref_ty -> (* for CHERI we use the effectful array_shift operator *) @@ -858,7 +861,7 @@ let translate_function_call loc annots is_used translate_expr stdlib e es = | Nothing -> false end in - E.get_calling_convention >>= fun callconv -> + E.read_config >>= fun conf -> (* TODO: This is ignoring has_proto, §6.5.2.2#6 is not being considered! *) (* STD §6.5.2.2 *) E.wrapped_fresh_symbol (C.BTy_loaded C.OTy_pointer) >>= fun fun_wrp -> @@ -894,7 +897,34 @@ let translate_function_call loc annots is_used translate_expr stdlib e es = , (ctype_of arg_e, Aaux.is_null_pointer_constant arg_e, arg_wrp.E.sym_pe) :: args_info ) ) (0, [], [], []) es >>= fun (_, rev_arg_sym_pats, rev_core_arg_es, rev_args_info) -> (* create parameters and convert them *) - let (args_info, variadic_args_info) = List.splitAt (List.length expect_params) (List.reverse rev_args_info) in + let (args_info, variadic_args_info) = + List.splitAt (List.length expect_params) (List.reverse rev_args_info) in + (* (STD §6.5.2.2#7, sentence 1) implicit conversion of the argument to the type of the + * corresponding parameter using the assignment rules. + * NOTE: a pointer argument passed to a _Bool parameter has already been converted during its + * elaboration (and has Core type loaded integer), so we do NOT convert it again here. *) + let conv_arg_value expect_param_ty expect_param_ty_pe (arg_ty, arg_is_null, arg_sym_pe) = + if + AilTypesAux.atomic_qualified_unqualified AilTypesAux.is_Bool expect_param_ty + && AilTypesAux.is_pointer arg_ty + then + arg_sym_pe + (* NOTE: since the expected type is compatible with the parameter type, if one is an integer or + floating, the other one must also be an integer or floating (respectively) *) + else if AilTypesAux.is_integer expect_param_ty then + if AilTypesAux.is_integer arg_ty then + stdlib.mkcall_conv_loaded_int_ expect_param_ty_pe arg_sym_pe + else + stdlib.mkcall_loaded_ivfromfloat_ expect_param_ty_pe arg_sym_pe + else if AilTypesAux.is_floating expect_param_ty then + if AilTypesAux.is_integer arg_ty then + stdlib.mkcall_loaded_fvfromint_ expect_param_ty_pe arg_sym_pe + else + arg_sym_pe + else if AilTypesAux.is_pointer expect_param_ty && arg_is_null then + Caux.mk_specified_pe (Caux.mk_nullptr_pe expect_param_ty) + else + arg_sym_pe in (* standard arguments *) E.foldlM (fun (n, rev_core_creates) ((_, expect_param_ty, _), (arg_ty, arg_is_null, arg_sym_pe)) -> E.wrapped_fresh_symbol C.BTy_ctype >>= fun param_ty_wrp -> @@ -908,24 +938,7 @@ let translate_function_call loc annots is_used translate_expr stdlib e es = (Caux.mk_pure_e (Caux.mk_std_undef_pe loc "§6.5.2.2#9" Undefined.UB041_function_not_compatible)) begin let conv_value = - if AilTypesAux.atomic_qualified_unqualified AilTypesAux.is_Bool expect_param_ty && AilTypesAux.is_pointer arg_ty then - arg_sym_pe - (* NOTE: since the expected type is compatible with the parameter type, if one is an integer or - floating, the other one must also be an integer or floating (respectively) *) - else if AilTypesAux.is_integer expect_param_ty then - if AilTypesAux.is_integer arg_ty then - stdlib.mkcall_conv_loaded_int_ expect_param_ty_pe arg_sym_pe - else - stdlib.mkcall_loaded_ivfromfloat_ expect_param_ty_pe arg_sym_pe - else if AilTypesAux.is_floating expect_param_ty then - if AilTypesAux.is_integer arg_ty then - stdlib.mkcall_loaded_fvfromint_ expect_param_ty_pe arg_sym_pe - else - arg_sym_pe - else if AilTypesAux.is_pointer expect_param_ty && arg_is_null then - Caux.mk_specified_pe (Caux.mk_nullptr_pe expect_param_ty) - else - arg_sym_pe in + conv_arg_value expect_param_ty expect_param_ty_pe (arg_ty, arg_is_null, arg_sym_pe) in let mo = if AilTypesAux.is_atomic expect_param_ty then (* STD §6.2.6.1#9 *) @@ -944,7 +957,7 @@ let translate_function_call loc annots is_used translate_expr stdlib e es = end )) :: rev_core_creates ) ) (0,[]) (List.zip expect_params args_info) >>= fun (_, rev_core_creates) -> - match callconv with + match conf.E.calling_convention with | C.Inner_arg_callconv -> (* standard arguments (CN elaboration switch) *) E.foldlM (fun (n, cn_core_args) ((_, expect_param_ty, _), (arg_ty, arg_is_null, arg_sym_pe)) -> @@ -958,22 +971,7 @@ let translate_function_call loc annots is_used translate_expr stdlib e es = (Caux.mk_not_pe (Caux.mk_are_compatible expect_param_ty_pe param_ty_wrp.E.sym_pe)) (Caux.mk_std_undef_pe loc "§6.5.2.2#9" Undefined.UB041_function_not_compatible) begin - (* NOTE: since the expected type is compatible with the parameter type, - if one is an integer or floating, the other one must also be an integer or floating (respectively) *) - if AilTypesAux.is_integer expect_param_ty then - if AilTypesAux.is_integer arg_ty then - stdlib.mkcall_conv_loaded_int_ expect_param_ty_pe arg_sym_pe - else - stdlib.mkcall_loaded_ivfromfloat_ expect_param_ty_pe arg_sym_pe - else if AilTypesAux.is_floating expect_param_ty then - if AilTypesAux.is_integer arg_ty then - stdlib.mkcall_loaded_fvfromint_ expect_param_ty_pe arg_sym_pe - else - arg_sym_pe - else if AilTypesAux.is_pointer expect_param_ty && arg_is_null then - Caux.mk_specified_pe (Caux.mk_nullptr_pe expect_param_ty) - else - arg_sym_pe + conv_arg_value expect_param_ty expect_param_ty_pe (arg_ty, arg_is_null, arg_sym_pe) end )) :: cn_core_args ) ) (0,[]) (List.zip expect_params args_info) @@ -1038,7 +1036,7 @@ begin if expect_is_variadic then (Caux.mk_op_pe C.OpOr (Caux.mk_not_pe is_variadic_wrp.E.sym_pe) (Caux.mk_not_pe (Caux.mk_are_compatible (Caux.mk_ail_ctype_pe expect_ret_ty) ret_wrp.E.sym_pe))) (Caux.mk_pure_e (Caux.mk_std_undef_pe loc "§6.5.2.2#9" Undefined.UB041_function_not_compatible)) -match callconv with +match conf.E.calling_convention with | C.Inner_arg_callconv -> let (_, varg_ptr_sym_pats) = List.splitAt (List.length expect_params) arg_ptr_sym_pats in (Caux.mk_sseqs @@ -1115,7 +1113,7 @@ else (Caux.mk_op_pe C.OpOr is_variadic_wrp.E.sym_pe (Caux.mk_not_pe (Caux.mk_are_compatible (Caux.mk_ail_ctype_pe expect_ret_ty) ret_wrp.E.sym_pe))) (Caux.mk_pure_e (Caux.mk_std_undef_pe loc "§6.5.2.2#9" Undefined.UB041_function_not_compatible)) -match callconv with +match conf.E.calling_convention with | C.Inner_arg_callconv -> (Caux.mk_ccall_e_ annots (Caux.mk_ail_ctype_pe (ctype_of e)) call_wrp.E.sym_pe ((*is_used_pe :: *)List.reverse rev_cn_core_args)) | C.Normal_callconv -> @@ -1390,7 +1388,7 @@ val translate_expression: expr_ctx -> (maybe Symbol.sym * maybe Symbol.sym) -> translation_stdlib -> - Core.core_tag_definitions -> + Ctype.tag_definitions -> A.expression GenTypes.genTypeCategory -> E.elabM (C.expr unit) let rec translate_expression translate_block_opt is_used ctx variadic_env stdlib tagDefs a_expr = @@ -1480,6 +1478,7 @@ let rec translate_expression translate_block_opt is_used ctx variadic_env stdlib let usual_arithmetic_conversion = usual_arithmetic_conversion_aux false in let usual_arithmetic_conversion_TMP_new = usual_arithmetic_conversion_aux true in let result_ty = ctype_of a_expr in + E.read_config >>= fun conf -> if AilTypesAux.is_pointer result_ty && Aaux.is_null_pointer_constant a_expr then (* NOTE: this is a bit tasteless as it makes the case AilEconst, ConstantNull unreachable *) E.return (Caux.mk_pure_e (Caux.mk_specified_pe (Caux.mk_nullptr_pe result_ty))) @@ -1578,7 +1577,7 @@ let rec translate_expression translate_block_opt is_used ctx variadic_env stdlib [ ( Caux.mk_specified_pat obj_wrp.E.sym_pat , (* NOTE: result_ty == promoted type of e *) Caux.mk_specified_pe begin - if Global.is_CHERI () && Ctype.is_ptr_t result_ty then + if conf.E.is_CHERI && Ctype.is_ptr_t result_ty then mk_cheri_derive_and_assign_cap is_signed (Mem_common.DCunary A.Bnot) (obj_wrp.E.sym_pe, Caux.mk_nullcap_pe is_signed) @@ -1716,7 +1715,7 @@ if is_unsigned_shift then Caux.mk_op_pe C.OpRem_t (Caux.mk_op_pe C.OpMul promoted1_wrp.E.sym_pe (Caux.mk_op_pe C.OpExp (Caux.mk_integer_pe 2) promoted2_wrp.E.sym_pe)) (Caux.mk_op_pe C.OpAdd (Caux.mk_ivmax_pe (Caux.mk_ail_ctype_pe result_ty)) (Caux.mk_integer_pe 1)) end in - begin if Global.is_CHERI () && Ctype.is_ptr_t result_ty then + begin if conf.E.is_CHERI && Ctype.is_ptr_t result_ty then Caux.mk_specified_pe begin Caux.mk_memop_pe Mem_common.CapAssignValue [ Caux.mk_memop_pe @@ -1724,7 +1723,7 @@ if is_unsigned_shift then [obj1_wrp.E.sym_pe; obj2_wrp.E.sym_pe] ; core_shl ] end - else if Global.backend_name () = "Cn" then + else if conf.E.is_CN then Caux.mk_specified_pe (Caux.mk_wrapI_pe result_ity C.IOpShl promoted1_wrp.E.sym_pe promoted2_wrp.E.sym_pe) else Caux.mk_specified_pe core_shl @@ -1733,13 +1732,13 @@ else Caux.mk_std_pe "§6.5.7#4, sentence 3" (Caux.mk_if_pe (Caux.mk_op_pe C.OpLt promoted1_wrp.E.sym_pe (Caux.mk_integer_pe 0)) (Caux.mk_std_undef_pe loc "§6.5.7#3, sentence 3" Undefined.UB052a_negative_left_shift) - begin if Global.backend_name () = "Cn" then + begin if conf.E.is_CN then Caux.mk_specified_pe (Caux.mk_catch_exceptional_condition_pe result_ity C.IOpShl promoted1_wrp.E.sym_pe promoted2_wrp.E.sym_pe) else (Caux.mk_let_pe res_wrp.E.sym_pat (Caux.mk_op_pe C.OpMul promoted1_wrp.E.sym_pe (Caux.mk_op_pe C.OpExp (Caux.mk_integer_pe 2) promoted2_wrp.E.sym_pe)) (Caux.mk_if_pe (stdlib.mkcall_is_representable res_wrp.E.sym_pe result_ty) - begin if Global.is_CHERI () && Ctype.is_ptr_t result_ty then + begin if conf.E.is_CHERI && Ctype.is_ptr_t result_ty then Caux.mk_specified_pe begin Caux.mk_memop_pe Mem_common.CapAssignValue [ Caux.mk_memop_pe @@ -1797,7 +1796,7 @@ end begin let expr = Caux.mk_op_pe C.OpDiv promoted1_wrp.E.sym_pe (Caux.mk_op_pe C.OpExp (Caux.mk_integer_pe 2) promoted2_wrp.E.sym_pe) in Caux.mk_specified_pe begin -begin if Global.is_CHERI () && Ctype.is_ptr_t result_ty then +begin if conf.E.is_CHERI && Ctype.is_ptr_t result_ty then fun z -> Caux.mk_memop_pe Mem_common.CapAssignValue [ Caux.mk_memop_pe @@ -1814,7 +1813,7 @@ let result_ity = match result_ty with end in if AilTypesAux.is_unsigned_integer_type result_ty then Caux.mk_std_pe "6.5.7#5, sentence 2" - begin if Global.backend_name () = "Cn" then + begin if conf.E.is_CN then Caux.mk_wrapI_pe result_ity C.IOpShr promoted1_wrp.E.sym_pe promoted2_wrp.E.sym_pe else expr @@ -1822,7 +1821,7 @@ if AilTypesAux.is_unsigned_integer_type result_ty then else Caux.mk_std_pe "6.5.7#5, sentence 3" begin Caux.mk_if_pe (Caux.mk_op_pe C.OpGe promoted1_wrp.E.sym_pe (Caux.mk_integer_pe 0)) - begin if Global.backend_name () = "Cn" then + begin if conf.E.is_CN then Caux.mk_catch_exceptional_condition_pe result_ity C.IOpShr promoted1_wrp.E.sym_pe promoted2_wrp.E.sym_pe else expr @@ -1840,7 +1839,7 @@ end end))) ) ] | A.AilEident sym -> E.cheri_const_alias_map >>= fun alias_map -> let sym_alias_if_CHERI = - if Global.is_CHERI () then + if conf.E.is_CHERI then match Map.lookup sym alias_map with | Just cheri_sym -> cheri_sym | Nothing -> sym @@ -1884,7 +1883,7 @@ else if AilTypesAux.is_pointer cast_ty && Aaux.is_null_pointer_constant e then else if AilTypesAux.is_arithmetic cast_ty && AilTypesAux.is_arithmetic e_ty then if AilTypesAux.is_integer cast_ty then if AilTypesAux.is_integer e_ty then - if Global.is_CHERI () && not (Ctype.is_ptr_t (ctype_of e)) && Ctype.is_ptr_t cast_ty then + if conf.E.is_CHERI && not (Ctype.is_ptr_t (ctype_of e)) && Ctype.is_ptr_t cast_ty then Caux.mk_wseq_e e_wrp.E.sym_pat core_e begin Caux.mk_pure_e begin Caux.mk_case_pe e_wrp.E.sym_pe @@ -1897,7 +1896,7 @@ else if AilTypesAux.is_arithmetic cast_ty && AilTypesAux.is_arithmetic e_ty then , Caux.mk_undef_pe loc (Undefined.DUMMY "integer to [u]intptr_t cast") ) ] end end - else if Global.is_CHERI () && Ctype.is_ptr_t (ctype_of e) && not (Ctype.is_ptr_t cast_ty) then + else if conf.E.is_CHERI && Ctype.is_ptr_t (ctype_of e) && not (Ctype.is_ptr_t cast_ty) then Caux.mk_wseq_e e_wrp.E.sym_pat core_e begin Caux.mk_pure_e begin Caux.mk_case_pe e_wrp.E.sym_pe @@ -2046,7 +2045,7 @@ if AilTypesAux.is_arithmetic (ctype_of e1) && AilTypesAux.is_arithmetic (ctype_o , (* Both operand are specified *) let core_add = Caux.mk_std_pe "§6.5.6#5" (Caux.mk_op_pe C.OpAdd promoted1_pe promoted2_pe) in Caux.mk_specified_pe ( - if Global.is_CHERI () && Ctype.is_ptr_t result_ty then + if conf.E.is_CHERI && Ctype.is_ptr_t result_ty then Caux.mk_let_pe cap_wrp.E.sym_pat (Caux.mk_memop_pe (Mem_common.DeriveCap (Mem_common.DCbinary (A.Arithmetic A.Add)) (AilTypesAux.is_signed_integer_type result_ty)) [obj1_wrp.E.sym_pe; obj2_wrp.E.sym_pe]) @@ -2104,7 +2103,7 @@ else (* Here one of the operands is a pointer *) [ ( Caux.mk_tuple_pat [ Caux.mk_specified_pat ptr_obj_wrp.E.sym_pat ; Caux.mk_specified_pat integer_obj_wrp.E.sym_pat ] , (* Both operand are specified *) -begin if Global.has_strict_pointer_arith () || Global.is_CHERI () || Global.is_PNVI () then +begin if conf.E.strict_pointer_arith || conf.E.is_CHERI || conf.E.is_PNVI then Caux.mk_wseq_e res_wrp.E.sym_pat (Caux.mk_memop_e Mem_common.PtrArrayShift [ptr_obj_wrp.E.sym_pe; Caux.mk_ail_ctype_pe ref_ty; integer_obj_wrp.E.sym_pe]) (Caux.mk_pure_e (Caux.mk_specified_pe res_wrp.E.sym_pe)) @@ -2145,7 +2144,7 @@ if AilTypesAux.is_arithmetic (ctype_of e1) && AilTypesAux.is_arithmetic (ctype_o , (* Both operand are specified *) let core_sub = Caux.mk_std_pe "§6.5.6#6" (Caux.mk_op_pe C.OpSub promoted1_pe promoted2_pe) in Caux.mk_specified_pe $ - if Global.is_CHERI () && Ctype.is_ptr_t result_ty then + if conf.E.is_CHERI && Ctype.is_ptr_t result_ty then Caux.mk_let_pe cap_wrp.E.sym_pat (Caux.mk_memop_pe (Mem_common.DeriveCap (Mem_common.DCbinary (A.Arithmetic A.Sub)) (AilTypesAux.is_signed_integer_type result_ty)) [obj1_wrp.E.sym_pe; obj2_wrp.E.sym_pe]) @@ -2241,7 +2240,7 @@ else [ (Caux.mk_tuple_pat [ Caux.mk_specified_pat (ptr_obj_wrp.E.sym_pat) ; Caux.mk_specified_pat (integer_obj_wrp.E.sym_pat) ], (* Both operand are specified *) -begin if Global.has_strict_pointer_arith () || Global.is_CHERI () || Global.is_PNVI () then +begin if conf.E.strict_pointer_arith || conf.E.is_CHERI || conf.E.is_PNVI then Caux.mk_wseq_e res_wrp.E.sym_pat (C.Expr [] (C.Ememop Mem_common.PtrArrayShift [ptr_obj_wrp.E.sym_pe; Caux.mk_ail_ctype_pe ref_ty; (Caux.mk_neg_pe ity integer_obj_wrp.E.sym_pe)])) (Caux.mk_pure_e (Caux.mk_specified_pe res_wrp.E.sym_pe)) @@ -2410,7 +2409,7 @@ end ) let ty2 = Ctype.unatomic (ctype_of e2) in begin if AilTypesAux.atomic_qualified_unqualified AilTypesAux.is_arithmetic ty1 && AilTypesAux.is_arithmetic ty2 then - begin if Global.is_CHERI () && + begin if conf.E.is_CHERI && (Ctype.is_ptr_t ty1 && not (Ctype.is_ptr_t ty2) || not (Ctype.is_ptr_t ty1) && Ctype.is_ptr_t ty2 ) then self (A.AnnotatedExpression (GenTypes.GenRValueType (GenTypes.inject_type ty1)) [] loc (A.AilEcast Ctype.no_qualifiers ty1 e2)) >>= fun core_e -> @@ -2897,7 +2896,7 @@ end E.return begin C.Expr [Annot.Astd "§6.5.2.3#3, sentence 2"] ( C.Esseq e_wrp.E.sym_pat core_e ( -begin if Global.is_CHERI () then +begin if conf.E.is_CHERI then (Caux.mk_memop_e (Mem_common.PtrMemberShift tag_sym ident) [e_wrp.E.sym_pe]) else Caux.mk_pure_e (Caux.mk_member_shift_pe e_wrp.E.sym_pe tag_sym ident) @@ -2931,10 +2930,10 @@ end [ ( Caux.mk_unspecified_pat (Caux.mk_empty_pat C.BTy_ctype) , Caux.mk_pure_e (Caux.mk_undef_pe loc (Undefined.UB_CERB004_unspecified Undefined.UB_unspec_memberofptr)) ) ; ( Caux.mk_specified_pat obj_wrp.E.sym_pat - , if Global.has_strict_pointer_arith () || Global.is_CHERI () then + , if conf.E.strict_pointer_arith || conf.E.is_CHERI then Caux.mk_wseq_e test_wrp.E.sym_pat (Caux.mk_memop_e Mem_common.PtrValidForDeref [Caux.mk_ail_ctype_pe ref_ty; obj_wrp.E.sym_pe]) - begin if Global.is_CHERI () then + begin if conf.E.is_CHERI then Caux.mk_if_e test_wrp.E.sym_pe begin Caux.mk_wseq_e res_wrp.E.sym_pat @@ -3170,7 +3169,7 @@ else (* is_pointer *) illTypedAil loc "AilEarray_decay, result_ty not a pointer" | Just ref_ty -> C.Expr [Annot.Astd "§6.3.2.1#3"] ( -if Global.has_strict_pointer_arith () || Global.is_CHERI () || Global.is_PNVI () then +if conf.E.strict_pointer_arith || conf.E.is_CHERI || conf.E.is_PNVI then C.Ewseq res_wrp.E.sym_pat (C.Expr [] (C.Ememop Mem_common.PtrArrayShift [e_wrp.E.sym_pe; Caux.mk_ail_ctype_pe ref_ty; Caux.mk_integer_pe 0])) (Caux.mk_pure_e (Caux.mk_specified_pe res_wrp.E.sym_pe)) @@ -3230,33 +3229,56 @@ let inline (>>) m1 m2 = St.bind m1 (fun _ -> m2) let inline (<$>) = State.fmap let inline (<*>) = State.app -type collect_cases_state = <| - found_default: bool; - case_csts: list integer; - case_ranges: list (integer * integer); +type case_selector = + | CaseSelectConstant of integer + | CaseSelectRange of integer * integer + +(* NOTE: the visible objects recorded here are the ones declared inside the switch + body; they are listed innermost first, so that (visible_switch_syms ++ objects visible at + the switch statement) is the list of objects with which the Esave elaborating + AilScase/AilSdefault statements save the label *) +type collect_switch_content_state = <| + visible_switch_syms: list (Symbol.sym * Ctype.ctype); + (* the objects visible at the current point of "collection analysis" *) + found_default: maybe (list (Symbol.sym * Ctype.ctype)); + (* [Just] when a default has been found, holding the objects visible at the default statement *) + found_cases: list (case_selector * list (Symbol.sym * Ctype.ctype)); + (* the cases found so far along with the objects visible at each case label *) |> -val collect_cases_: A.statement GenTypes.genTypeCategory -> St.stateM unit collect_cases_state -let rec collect_cases_ stmt = - let register_case n = - St.update (fun s -> <| s with case_csts= n :: s.case_csts |>) in - let register_case_range n1 n2 = - St.update (fun s -> <| s with case_ranges= (n1, n2) :: s.case_ranges |>) in +val collect_switch_content_aux: + A.statement GenTypes.genTypeCategory -> St.stateM unit collect_switch_content_state +let rec collect_switch_content_aux stmt = + let register_case case_select = + St.update (fun s -> + <| s with found_cases= (case_select, s.visible_switch_syms) :: s.found_cases |> + ) in let register_default = - St.update (fun s -> <| s with found_default= true |>) in + St.update (fun s -> <| s with found_default= Just s.visible_switch_syms |>) in match stmt.A.node with | A.AilSskip -> St.return () | A.AilSexpr _ -> St.return () | A.AilSblock binds ss -> - St.mapM_ collect_cases_ ss + St.get >>= fun st -> + let saved_syms = st.visible_switch_syms in + St.update (fun st -> + <| st with visible_switch_syms= + List.map (fun (sym, (_, _, _, ty)) -> (sym, ty)) binds ++ st.visible_switch_syms + |> + ) >>= fun () -> + St.mapM_ collect_switch_content_aux ss >>= fun () -> + St.update (fun st -> + <| st with visible_switch_syms= saved_syms |> + ) | A.AilSif _ s1 s2 -> - collect_cases_ s1 >> collect_cases_ s2 + collect_switch_content_aux s1 >>= fun () -> + collect_switch_content_aux s2 | A.AilSwhile _ s _ -> - collect_cases_ s + collect_switch_content_aux s | A.AilSdo s _ _ -> - collect_cases_ s + collect_switch_content_aux s | A.AilSbreak -> St.return () | A.AilScontinue -> @@ -3268,30 +3290,35 @@ let rec collect_cases_ stmt = | A.AilSswitch _ _ -> St.return () | A.AilScase n s -> - register_case n >> collect_cases_ s + register_case (CaseSelectConstant n) >>= fun () -> + collect_switch_content_aux s | A.AilScase_rangeGNU n1 n2 s -> if n1 < n2 then - register_case_range n1 n2 >> collect_cases_ s + register_case (CaseSelectRange n1 n2) >>= fun () -> + collect_switch_content_aux s else (* the frontend should catch this *) error "Translation found a GNU case with empty range" | A.AilSdefault s -> - register_default >> collect_cases_ s + register_default >>= fun () -> + collect_switch_content_aux s | A.AilSlabel _ s _ -> - collect_cases_ s + collect_switch_content_aux s | A.AilSgoto _ -> St.return () | A.AilSdeclaration _ -> St.return () | A.AilSpar ss -> - St.mapM_ collect_cases_ ss + St.mapM_ collect_switch_content_aux ss | A.AilSreg_store _ _ -> St.return () | A.AilSmarker _ s -> - collect_cases_ s + collect_switch_content_aux s end -let collect_cases s = - snd (St.runStateM (collect_cases_ s) <| found_default= false; case_csts= []; case_ranges= [] |>) + +let collect_switch_content s = + snd (St.runStateM (collect_switch_content_aux s) + <| visible_switch_syms= []; found_default= Nothing; found_cases= [] |>) type erase_loop_control_state = <| @@ -3492,10 +3519,6 @@ let mk_run_with_lifetime_e loc sym visibles_before visibles_after pes = open Operators -type case_selector = - | CaseSelectConstant of integer - | CaseSelectRange of integer * integer - type translate_stmt_env = <| return_ty: Ctype.ctype; is_Noreturn: bool; @@ -3620,8 +3643,9 @@ let translate_block translate_expr_opt self loc f binds ss = ( Caux.mk_sym_pat sym (C.BTy_object C.OTy_pointer) , Caux.pcreate (Loc.with_cursor_from loc ident_loc) align_ival c_ty (Symbol.PrefSource ident_loc [f; sym]) ) ) decls_with_loc in + E.read_config >>= fun conf -> let cheri_const_intrinsic = - if Global.is_CHERI () then + if conf.E.is_CHERI then List.map (fun (sym, (qs, ty, sym')) -> (* TODO: the partial pattern match in the lets is tasteless (even though the memop() never evaluates to an unspecified value) *) @@ -3650,15 +3674,24 @@ let translate_block translate_expr_opt self loc f binds ss = end ) +let translate_branch_on_unspec conf loc ctx e1 e2 = + match conf.E.branching_on_unspec with + | E.Elab_ND -> + Caux.mk_nd_e [e1; e2] + | E.Elab_UB -> + Caux.mk_pure_e (Caux.mk_undef_pe loc (Undefined.UB_CERB004_unspecified ctx)) + end + val translate_stmt: translation_stdlib -> - C.core_tag_definitions -> + Ctype.tag_definitions -> A.ail_identifier -> translate_stmt_env -> A.statement GenTypes.genTypeCategory -> E.elabM (C.expr unit) let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = + E.read_config >>= fun conf -> let loc = stmt.A.loc in let self = translate_stmt stdlib tagDefs f env in let translate_expression is_used = @@ -3727,7 +3760,7 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = let pats_core_creates : list (C.pattern * C.expr unit) = List.map (fun (sym, ident_loc, (align_opt, qs, ty)) -> let c_ty = Caux.mk_ail_ctype_pe ty in - let align_ival = + let align_ival = match align_opt with | Just (Ctype.AlignInteger n) -> Caux.mk_integer_pe n @@ -3740,7 +3773,7 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = , Caux.pcreate (Loc.with_cursor_from loc ident_loc) align_ival c_ty (Symbol.PrefSource ident_loc [f; sym]) ) ) decls_with_loc in let cheri_const_intrinsic = - if Global.is_CHERI () then + if conf.E.is_CHERI then List.map (fun (sym, (qs, ty, sym')) -> (* TODO: the partial pattern match in the lets is tasteless (even though the memop() never evaluates to an unspecified value) *) @@ -3789,9 +3822,13 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = Caux.mk_if_pe (Caux.mk_not_pe (Caux.mk_op_pe C.OpEq case_wrp.E.sym_pe (Caux.mk_integer_pe 1))) (Caux.mk_boolean_pe true) (Caux.mk_boolean_pe false) end ) - (* non-deterministic branching if the test expression had unspecified value *) + (* if the test expression had unspecified value, UB or non-deterministic + * branching depending on the configuration *) ; ( Caux.mk_unspecified_pat (Caux.mk_empty_pat C.BTy_ctype) - , Caux.mk_nd_e [Caux.mk_pure_e (Caux.mk_boolean_pe true); Caux.mk_pure_e (Caux.mk_boolean_pe false)] ) ] + , translate_branch_on_unspec conf loc + Undefined.UB_unspec_if + (Caux.mk_pure_e (Caux.mk_boolean_pe true)) + (Caux.mk_pure_e (Caux.mk_boolean_pe false)) ) ] end (Caux.mk_if_e do_then_wrp.E.sym_pe core_s1 core_s2) end @@ -3799,7 +3836,7 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = | A.AilSwhile e s loop_id -> (* NOTE: the object type is OTy_integer since we are using mkTestExpression which turns [e] into [e == 0] *) - let sym_loop = Symbol.fresh_pretty_with_id (fun x -> "while_" ^ show x) in + let sym_loop = Symbol.fresh_pretty_with_id (fun x -> "while_" ^ show x) in E.wrapped_fresh_symbol C.BTy_boolean >>= fun do_loop_wrp -> E.wrapped_fresh_symbol (C.BTy_loaded C.OTy_integer) >>= fun test_wrp -> E.wrapped_fresh_symbol (C.BTy_object C.OTy_integer) >>= fun case_wrp -> @@ -3824,9 +3861,13 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = Caux.mk_if_pe (Caux.mk_not_pe (Caux.mk_op_pe C.OpEq case_wrp.E.sym_pe (Caux.mk_integer_pe 1))) (Caux.mk_boolean_pe true) (Caux.mk_boolean_pe false) end ) - (* non-deterministic branching if the test expression had unspecified value *) + (* if the test expression had unspecified value, UB or non-deterministic + * branching depending on the configuration *) ; ( Caux.mk_unspecified_pat (Caux.mk_empty_pat C.BTy_ctype) - , Caux.mk_nd_e [Caux.mk_pure_e (Caux.mk_boolean_pe true); Caux.mk_pure_e (Caux.mk_boolean_pe false)] ) ] + , translate_branch_on_unspec conf loc + Undefined.UB_unspec_while + (Caux.mk_pure_e (Caux.mk_boolean_pe true)) + (Caux.mk_pure_e (Caux.mk_boolean_pe false)) ) ] end (Caux.mk_if_e do_loop_wrp.E.sym_pe core_s_loop Caux.mk_skip_e) end @@ -3834,19 +3875,28 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = end | A.AilSdo s e loop_id -> - (* TODO: make the elab of AilSdo use mkTestExpression *) - let sym_loop = Symbol.fresh_pretty_with_id (fun x -> "do_" ^ show x) in - let sym_case = Symbol.fresh () in - let sym_e = Symbol.fresh () in - translate_expression true e >>= fun core_e -> - self s >>= fun core_s -> - E.get_visible_objects >>= fun visible_syms -> - + (* + * [| do S while (E) |] = + * save l(...) in + * lets () = [| S |] in + * lets test: integer loaded = [| E == 0 |] in + * case test of + * | Specified case => if not (case = 1) then run l(...) else pure(Unit) + * | Unspecified _ => pure(undef("unspecified AilSdo")) + * end + *) + (* NOTE: the object type is OTy_integer since we are using mkTestExpression + * which turns [e] into [e == 0] *) + let sym_loop = Symbol.fresh_pretty_with_id (fun x -> "do_" ^ show x) in + E.wrapped_fresh_symbol (C.BTy_loaded C.OTy_integer) >>= fun test_wrp -> + E.wrapped_fresh_symbol (C.BTy_object C.OTy_integer) >>= fun case_wrp -> + translate_expression true (mkTestExpression TestEq e) >>= fun core_test -> + self s >>= fun core_s -> + E.get_visible_objects >>= fun visible_syms -> let core_loop = Caux.mk_run_e sym_loop [ Caux.mk_sym_pe sym | forall (sym MEM visible_syms) | true ] in - E.mapM (fun sym -> - E.resolve_object_type sym >>= fun (_, ty) -> + E.resolve_object_type sym >>= fun (_, ty) -> E.return (sym, ((C.BTy_object C.OTy_pointer, Just (ty, C.By_pointer)), Caux.mk_sym_pe sym)) ) visible_syms >>= fun args -> E.return begin @@ -3855,15 +3905,14 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = Caux.mk_sseq_e (Caux.mk_empty_pat C.BTy_unit) core_s (* controlling expression *) begin - Caux.mk_sseq_e (Caux.mk_sym_pat sym_e (C.BTy_loaded C.OTy_integer)) core_e ( - Caux.mk_case_e (Caux.mk_sym_pe sym_e) - [ ( Caux.mk_specified_pat (Caux.mk_sym_pat sym_case (C.BTy_object C.OTy_integer)) - , Caux.mk_if_e (Caux.mk_not_pe (Caux.mk_op_pe C.OpEq (Caux.mk_sym_pe sym_case) (Caux.mk_integer_pe 0))) + Caux.mk_sseq_e test_wrp.E.sym_pat core_test ( + Caux.mk_case_e test_wrp.E.sym_pe + [ ( Caux.mk_specified_pat case_wrp.E.sym_pat + , Caux.mk_if_e (Caux.mk_not_pe (Caux.mk_op_pe C.OpEq case_wrp.E.sym_pe (Caux.mk_integer_pe 1))) core_loop Caux.mk_skip_e ) - (* non-deterministic branching if the test expression had unspecified value *) ; ( Caux.mk_unspecified_pat (Caux.mk_empty_pat C.BTy_ctype) - , (* Caux.mk_nd_e [core_loop; Caux.mk_skip_e] *) - Caux.mk_pure_e (Caux.mk_undef_pe loc (Undefined.DUMMY "unspecified AilSdo")) ) ] + , translate_branch_on_unspec conf loc Undefined.UB_unspec_do + core_loop Caux.mk_skip_e ) ] ) end ) @@ -3953,22 +4002,30 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = let promoted_pe = Caux.mk_std_pe "§6.8.4.2#5, sentence 1" ( stdlib.mkcall_conv_int (fromJust "Translation.translate_stmt: switch expr promotion" - (AilTypesAux.promotion (Implementation.integerImpl ()) (ctype_of e))) control_wrp.E.sym_pe + (AilTypesAux.promotion (Implementation.integerImpl ()) (ctype_of e)) + ) control_wrp.E.sym_pe ) in (* Create case symbols and translate cases block *) - let cases = collect_cases s in - let nb_cases = List.length (cases.case_csts) + List.length (cases.case_ranges) in - let case_syms = list_init nb_cases (fun _ -> Symbol.fresh_pretty_with_id (fun x -> "case_" ^ show x)) in - let default_sym = Symbol.fresh_pretty_with_id (fun x -> "default_" ^ show x) in + let switch_content = collect_switch_content s in + let case_infos = + List.map (fun (case_selector, case_visibles) -> + ( case_selector + , Symbol.fresh_pretty_with_id (fun x -> "case_" ^ show x), case_visibles ) + ) switch_content.found_cases in let case_labs = - List.zip - begin - (List.map (fun n -> CaseSelectConstant n) cases.case_csts) ++ - (List.map (fun (n1, n2) -> CaseSelectRange n1 n2) cases.case_ranges) - end case_syms in + List.map (fun (case_selector, case_lab, _) -> (case_selector, case_lab)) case_infos in + let default_sym = Symbol.fresh_pretty_with_id (fun x -> "default_" ^ show x) in translate_cases_block case_labs (Just default_sym) s >>= fun core_s -> - E.get_visible_objects >>= fun visible_syms -> - let visible_pes = List.map (fun sym -> Caux.mk_sym_pe sym) visible_syms in + E.get_visible_objects >>= fun visible_syms_at_switch -> + E.mapM (fun sym -> + E.resolve_object_type sym >>= fun (_, ty) -> + E.return (sym, ty) + ) visible_syms_at_switch >>= fun visibles_here -> + (* Jumping to a case/default label behaves like a goto: objects declared inside the switch + * body that are newly visible at the label are allocated, and ALL objects visible at the + * label are passed to it. *) + let mk_jump lab label_visibles = + mk_run_with_lifetime_e loc lab visibles_here (label_visibles ++ visibles_here) [] in (* Build translated switch *) E.return (* Get control expression *) @@ -3979,35 +4036,43 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = , (* Do integer promotion *) Caux.mk_sseq_e promoted_wrp.E.sym_pat (Caux.mk_pure_e promoted_pe) - (* For every case.... *) - (List.foldl (fun acc (case_select, case_lab) -> + (* For each case: *) + (List.foldl (fun acc (case_select, case_lab, case_visibles) -> let select_test = match case_select with - | CaseSelectConstant case_n -> - Caux.mk_op_pe C.OpEq promoted_wrp.E.sym_pe (Caux.mk_value_pe (C.Vobject (C.OVinteger (Mem.integer_ival case_n)))) - | CaseSelectRange case_n1 case_n2 -> - Caux.mk_op_pe C.OpAnd - (Caux.mk_op_pe C.OpLe (Caux.mk_value_pe (C.Vobject (C.OVinteger (Mem.integer_ival case_n1)))) promoted_wrp.E.sym_pe) - (Caux.mk_op_pe C.OpLe promoted_wrp.E.sym_pe (Caux.mk_value_pe (C.Vobject (C.OVinteger (Mem.integer_ival case_n2))))) + | CaseSelectConstant case_n -> + Caux.mk_op_pe C.OpEq + promoted_wrp.E.sym_pe + (Caux.mk_value_pe (C.Vobject (C.OVinteger (Mem.integer_ival case_n)))) + | CaseSelectRange case_n1 case_n2 -> + Caux.mk_op_pe C.OpAnd + (Caux.mk_op_pe C.OpLe + (Caux.mk_value_pe (C.Vobject (C.OVinteger (Mem.integer_ival case_n1)))) + promoted_wrp.E.sym_pe) + (Caux.mk_op_pe C.OpLe + promoted_wrp.E.sym_pe + (Caux.mk_value_pe (C.Vobject (C.OVinteger (Mem.integer_ival case_n2))))) end in Caux.mk_sseq_e (Caux.mk_empty_pat C.BTy_unit) (* Check if equal to the constant expression *) (Caux.mk_if_e select_test - (* TODO: not sure if the visible afters are the same *) - (Caux.mk_run_e case_lab visible_pes) + (mk_jump case_lab case_visibles) (Caux.mk_skip_e)) acc) (* default branch *) (Caux.mk_sseq_e (Caux.mk_empty_pat C.BTy_unit) - (if cases.found_default then - Caux.mk_run_e default_sym visible_pes - else - Caux.mk_skip_e) + match switch_content.found_default with + | Just default_visibles -> + mk_jump default_sym default_visibles + | Nothing -> + Caux.mk_skip_e + end core_s) - case_labs) ) + case_infos) ) (* UB if unspecified *) ; ( Caux.mk_unspecified_pat (Caux.mk_empty_pat C.BTy_ctype) - , Caux.mk_pure_e (Caux.mk_undef_exceptional_condition loc) ) ])) + , Caux.mk_pure_e (Caux.mk_undef_pe loc + (Undefined.UB_CERB004_unspecified Undefined.UB_unspec_switch)) ) ])) | A.AilScase n s -> self s >>= fun core_s -> @@ -4090,7 +4155,7 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = loc (Caux.mk_ail_ctype_pe ty) ptr_sym_e in match e_opt with | Nothing -> - if Global.backend_name () = "Cn" then + if conf.E.is_CN then (* CN does not support unspecified values *) E.return Caux.mk_skip_e else @@ -4125,7 +4190,7 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = end else (* we are not dealing with a pointer on either sides *) - if Global.is_CHERI () && Ctype.is_ptr_t ty && not (Ctype.is_ptr_t (ctype_of e)) then + if conf.E.is_CHERI && Ctype.is_ptr_t ty && not (Ctype.is_ptr_t (ctype_of e)) then E.wrapped_fresh_symbol (C.BTy_object oTy) >>= fun obj_wrp -> E.return begin Caux.mk_sseq_e e_wrp.E.sym_pat core_e begin @@ -4142,7 +4207,7 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = , Caux.mk_pure_e (Caux.mk_undef_pe loc (Undefined.DUMMY "AilSdeclaration")) ) ] end end - else if Global.is_CHERI () && not (Ctype.is_ptr_t ty) && Ctype.is_ptr_t (ctype_of e) then + else if conf.E.is_CHERI && not (Ctype.is_ptr_t ty) && Ctype.is_ptr_t (ctype_of e) then E.wrapped_fresh_symbol (C.BTy_object oTy) >>= fun obj_wrp -> E.return begin Caux.mk_sseq_e e_wrp.E.sym_pat core_e begin @@ -4200,23 +4265,30 @@ let rec translate_stmt stdlib tagDefs f env stmt : E.elabM (C.expr unit) = val translate_tag_definitions: list (A.ail_identifier * (Loc.t * Annot.attributes * Ctype.tag_definition)) -> - C.core_tag_definitions + Ctype.tag_definitions let translate_tag_definitions ctx = Map.fromList (List.map (fun (x, (loc, _, y)) -> (x, (loc, y))) ctx) import Cerb_attributes +let is_inner_arg_temps conf = + match conf.E.calling_convention with + | C.Inner_arg_callconv -> true + | _ -> false + end + + val translate_program: translation_stdlib -> maybe Symbol.sym * A.sigma GenTypes.genTypeCategory -> - E.elabM ( C.core_tag_definitions + E.elabM ( Ctype.tag_definitions * list (Symbol.sym * (C.generic_globs unit unit)) * C.generic_fun_map unit unit * map Symbol.sym (Loc.t * Annot.attributes * Ctype.ctype * list (maybe Symbol.sym * Ctype.ctype) * bool * bool) ) let translate_program stdlib (startup_sym_opt, sigm) = + E.read_config >>= fun conf -> let core_tagDefs = translate_tag_definitions sigm.A.tag_definitions in - E.foldlM (fun (gacc, facc, finfoacc) (sym, (loc, decl_attrs, decl)) -> (* for each Ail declaration *) match decl with @@ -4297,7 +4369,7 @@ let translate_program stdlib (startup_sym_opt, sigm) = let is_using_inner_arg_temps = (* NOTE: we exclude main because the driver allocates the objects for argc and argvs *) (* with this switch the argument temporary objects are allocated in the function *) - Global.has_switch Global.SW_inner_arg_temps in + is_inner_arg_temps conf in (* elaboration of a function *) let ret_bTy = if AilTypesAux.is_void return_ty then @@ -4332,8 +4404,8 @@ let translate_program stdlib (startup_sym_opt, sigm) = | Just (loc, mrk, _, param_syms, stmt) -> E.mapM (fun (s, bTy) -> - let descr = - if not (Global.has_switch Global.SW_inner_arg_temps) then Symbol.SD_None else + let descr = + if not (is_inner_arg_temps conf) then Symbol.SD_None else match Symbol.symbol_description s with | Symbol.SD_ObjectAddress v -> Symbol.SD_FunArgValue v | _ -> Assert_extra.failwith "function argument does not have SD_ObjectAddress description" @@ -4348,7 +4420,7 @@ let translate_program stdlib (startup_sym_opt, sigm) = ( loc, decl_attrs, return_ty (* TODO: check if we need qualifiers too *) , List.map (fun (sym, (_, ty, _)) -> - if Global.has_switch Global.SW_inner_arg_temps then + if is_inner_arg_temps conf then let descr = match Symbol.symbol_description sym with | Symbol.SD_ObjectAddress v -> Symbol.SD_FunArgValue v | _ -> Assert_extra.failwith "function argument does not have SD_ObjectAddress description" @@ -4463,7 +4535,7 @@ let translate_program stdlib (startup_sym_opt, sigm) = (* adding string literals as Core globals *) E.get_string_literals >>= fun xs -> - E.foldlM begin if Global.is_CHERI () then + E.foldlM begin if conf.E.is_CHERI then (* For CHERI we do not use create_readonly() *) fun acc (loc, sym, ty, e_init) -> let ptr_ty = AilTypesAux.array_coercion ty in @@ -4521,17 +4593,19 @@ let translate_extern_map (_, sigm) = (* This is the entry function (called from main.ml) *) val translate: (map string Symbol.sym) * C.fun_map unit -> - C.calling_convention -> - C.impl -> + E.elab_config -> + C.impl -> A.ail_program GenTypes.genTypeCategory -> C.file unit -let translate (ailnames, stdlib_fun_map) callconv impl prog = +let translate (ailnames, stdlib_fun_map) conf impl prog = let translation_stdlib = mk_translation_stdlib (ailnames, stdlib_fun_map) in let ((core_tagDefs, cglobs, (*cdecls, *) cfuns, funinfo), st) = - E.runStateM_errors (translate_program translation_stdlib prog) (E.elab_init callconv) + E.runElabM_errors conf + (translate_program translation_stdlib prog) + E.elab_initial_state in <| C.main= fst prog; - C.calling_convention= callconv; + C.calling_convention= conf.E.calling_convention; C.tagDefs= core_tagDefs; C.stdlib= stdlib_fun_map; C.impl= impl; @@ -4539,6 +4613,6 @@ let translate (ailnames, stdlib_fun_map) callconv impl prog = C.funs= cfuns; C.extern = translate_extern_map prog; C.funinfo= funinfo; - C.loop_attributes= (snd prog).A.loop_attributes; + C.loop_attributes= (snd prog).A.loop_attributes; C.visible_objects_env= st.E.visible_objects_types_markers_env; |> diff --git a/frontend/model/translation_aux.lem b/frontend/model/translation_aux.lem index c1d7cf3b0..ed8f40a46 100644 --- a/frontend/model/translation_aux.lem +++ b/frontend/model/translation_aux.lem @@ -1,5 +1,5 @@ -open import Pervasives Utils Translation_effect Symbol Show Show_extra Ctype -import Core Core_aux +open import Pervasives Utils Translation_effect Show Show_extra Ctype +import Symbol Core Core_aux Mem import Implementation AilSyntax AilTypesAux GenTypes GenTypesAux import Boot Map_extra @@ -19,7 +19,7 @@ let rec fetch_stdlib_symbol_aux pred xs = val fetch_stdlib_symbol: list Symbol.sym -> string -> Symbol.sym let fetch_stdlib_symbol syms str = - match fetch_stdlib_symbol_aux (function (Symbol.Symbol _ _ (SD_Id z)) -> z = str | _ -> false end) syms with + match fetch_stdlib_symbol_aux (function (Symbol.Symbol _ _ (Symbol.SD_Id z)) -> z = str | _ -> false end) syms with | Just sym -> sym | Nothing -> @@ -39,7 +39,7 @@ let rec mk_stdcall_aux pred xs = val mk_stdcall: forall 'a. Core.fun_map 'a -> string -> (list Core.pexpr -> Core.pexpr) let mk_stdcall stdlib fname = - match mk_stdcall_aux (function ((Symbol _ _ (SD_Id z)), _) -> z = fname | _ -> false end) (Map_extra.toList stdlib) with + match mk_stdcall_aux (function ((Symbol.Symbol _ _ (Symbol.SD_Id z)), _) -> z = fname | _ -> false end) (Map_extra.toList stdlib) with | Just (f, Core.Fun bTy params _) -> fun pes -> Core.Pexpr [] () (Core.PEcall (Core.Sym f) pes) @@ -416,6 +416,8 @@ let warn_atomic_elaboration guard = () in return () +(* IMPORTANT: this must be kept in sync with loaded_ivfromfloat() in std.core + * and std_inner_arg_temps.core *) val conv_arith: translation_stdlib -> Ctype.ctype -> Ctype.ctype -> C.pexpr -> C.pexpr let conv_arith stdlib ty_src ty_dst pe = if AilTypesAux.is_integer ty_src then @@ -427,7 +429,13 @@ let conv_arith stdlib ty_src ty_dst pe = (* NOTE: this case will occurs in particular if ty_dst is an atomic type *) error "Translation_aux.conv_arith, not (is_arithmetic ty_dst)" else if AilTypesAux.is_floating ty_src then - if AilTypesAux.is_integer ty_dst then + if AilTypesAux.is_Bool ty_dst then + (* STD §6.3.1.2#1: 0 if the value compares equal to 0.0, 1 otherwise; the test is on + the floating value, not on its truncation (see loaded_ivfromfloat() in std.core) *) + Caux.mk_if_pe + (Caux.mk_op_pe C.OpEq pe (Caux.mk_floating_value_pe (Mem.zero_fval))) + (Caux.mk_integer_pe 0) (Caux.mk_integer_pe 1) + else if AilTypesAux.is_integer ty_dst then C.Pexpr [] () (C.PEctor C.Civfromfloat [Caux.mk_ail_ctype_pe ty_dst; pe]) else if AilTypesAux.is_floating ty_dst then (* TODO: floating vs floating conversion *) diff --git a/frontend/model/translation_effect.lem b/frontend/model/translation_effect.lem index b07ae0fc4..23afd878c 100644 --- a/frontend/model/translation_effect.lem +++ b/frontend/model/translation_effect.lem @@ -6,8 +6,6 @@ import Core Core_aux Ctype module C = Core module Caux = Core_aux -include State - type wrapped_symbol = <| sym_sym: Symbol.sym; sym_pat: C.pattern; @@ -33,15 +31,37 @@ type elab_state = <| cheri_const_alias: map Symbol.sym Symbol.sym; errors: list string; - - (* readonly *) +|> + +type elab_ub_or_nd = + | Elab_UB + | Elab_ND + +type elab_config = <| calling_convention: C.calling_convention; + + (* TODO: properly classify what the following configure *) + is_PNVI: bool; + is_CHERI: bool; + is_CN: bool; + strict_pointer_arith: bool; + branching_on_unspec: elab_ub_or_nd; +(* +has_switch Global.SW_inner_arg_temps ---> USE calling_convention +*) |> -type elabM 'a = stateM 'a elab_state +let elab_config callconv is_PNVI is_CHERI is_CN strict_pointer_arith branching_on_unspec = <| + calling_convention= callconv; + is_PNVI= is_PNVI; + is_CHERI= is_CHERI; + is_CN= is_CN; + strict_pointer_arith= strict_pointer_arith; + branching_on_unspec= branching_on_unspec; +|> -val elab_init: C.calling_convention -> elab_state -let elab_init callconv = <| +val elab_initial_state: elab_state +let elab_initial_state = <| visible_objects_types= Map.empty; visible_objects= [[]]; string_literals= []; @@ -50,12 +70,55 @@ let elab_init callconv = <| visible_objects_types_markers_env = Map.empty; cheri_const_alias= Map.empty; errors = []; - calling_convention= callconv; |> -val get_calling_convention: elabM C.calling_convention -let get_calling_convention = - fun st -> (st.calling_convention, st) +type elabM 'a = + elab_config -> elab_state -> ('a * elab_state) + +val elab_return: forall 'a. 'a -> elabM 'a +let elab_return x = fun _ st -> (x, st) + +val elab_bind: forall 'a 'b. elabM 'a -> ('a -> elabM 'b) -> elabM 'b +let elab_bind m f = + fun conf st -> + let (a, st') = m conf st in + f a conf st' + +let rec elab_mapM_aux f conf acc st = function + | [] -> (List.reverse acc, st) + | x :: xs -> + let (y, st') = f x conf st in + (* NOTE: this MUST remain in tail position *) + elab_mapM_aux f conf (y :: acc) st' xs +end +val elab_mapM: forall 'a 'b. ('a -> elabM 'b) -> list 'a -> elabM (list 'b) +let elab_mapM f xs = + fun conf st -> elab_mapM_aux f conf [] st xs + +let rec elab_foldlM_aux f conf acc st = function + | [] -> (acc, st) + | x :: xs -> + let (acc', st') = f acc x conf st in + elab_foldlM_aux f conf acc' st' xs +end +val elab_foldlM: forall 'a 'b. ('a -> 'b -> elabM 'a) -> 'a -> list 'b -> elabM 'a +let elab_foldlM f init xs = fun conf st -> elab_foldlM_aux f conf init st xs + + +val elab_update: forall 'a. (elab_state -> elab_state) -> elabM unit +let elab_update f = + fun _ st -> ((), f st) + +let inline return = elab_return +let inline (>>=) = elab_bind +let inline mapM = elab_mapM +let inline foldlM = elab_foldlM + + + +val read_config: elabM elab_config +let read_config = + fun conf st -> (conf, st) (* TODO: this does not need to be in the monad, but it is useful to unsure @@ -71,12 +134,18 @@ let wrapped_fresh_symbol_ descr bTy = return (sym, Caux.mk_sym_pat sym bTy, Caux.mk_sym_pe sym) val cheri_const_alias_map: elabM (map Symbol.sym Symbol.sym) -let cheri_const_alias_map = fun st -> +let cheri_const_alias_map = fun _ st -> (st.cheri_const_alias, st) -val with_block_objects: forall 'a. list (Symbol.sym * (Ctype.qualifiers * Ctype.ctype)) -> elabM 'a -> - elabM (list (Symbol.sym * (Ctype.qualifiers * Ctype.ctype * Symbol.sym)) * list compound_literal_info * 'a) -let with_block_objects binds ma = fun st -> +val with_block_objects: + forall 'a. + list (Symbol.sym * (Ctype.qualifiers * Ctype.ctype)) -> + elabM 'a -> + elabM + ( list (Symbol.sym * (Ctype.qualifiers * Ctype.ctype * Symbol.sym)) + * list compound_literal_info + * 'a ) +let with_block_objects binds ma = fun conf st -> let (new_aliases, cheri_const_alias) = List.foldl (fun (xs_acc, map_acc) (sym, (qs, ty)) -> (* TODO: fail if sym IN acc *) if qs.Ctype.const then @@ -91,66 +160,66 @@ let with_block_objects binds ma = fun st -> compound_literals= []; cheri_const_alias = cheri_const_alias; |> in - let (a, st'') = ma st' in + let (a, st'') = ma conf st' in ((new_aliases, st''.compound_literals, a), <| st'' with visible_objects= match st''.visible_objects with - | _ :: xs -> xs - | _ -> error "[Translation.E.with_block_objects] found an ill-formed scope stack." + | _ :: xs -> xs + | _ -> error "[Translation.E.with_block_objects] found an ill-formed scope stack." end; compound_literals= st.compound_literals |>) val track_temporary_objects: forall 'a. elabM 'a -> elabM (list (wrapped_symbol * Ctype.ctype) * 'a) let track_temporary_objects ma = - fun st -> + fun conf st -> if st.temporary_objects <> [] then error "[Translation.E.track_temporary_objects]" else - let (a, st') = ma st in + let (a, st') = ma conf st in ((st'.temporary_objects, a), <| st' with temporary_objects= [] |>) val register_temporary_object: wrapped_symbol -> Ctype.ctype -> elabM unit let register_temporary_object ptr_wrp ty = - fun st -> ((), <| st with temporary_objects= (ptr_wrp, ty) :: st.temporary_objects |>) + fun _ st -> ((), <| st with temporary_objects= (ptr_wrp, ty) :: st.temporary_objects |>) (* returns the list of all the C objects in scope. *) val get_visible_objects: elabM (list Symbol.sym) -let get_visible_objects = fun st -> +let get_visible_objects = fun _ st -> (foldl (++) [] st.visible_objects, st) val register_string_literal: Loc.t -> Symbol.sym -> Ctype.ctype -> C.pexpr -> elabM unit -let register_string_literal loc sym ty pe = fun st -> +let register_string_literal loc sym ty pe = fun _ st -> ((), <| st with string_literals= (loc, sym, ty, pe) :: st.string_literals |>) val get_string_literals: elabM (list (Loc.t * Symbol.sym * Ctype.ctype * C.pexpr)) -let get_string_literals = fun st -> +let get_string_literals = fun _ st -> (st.string_literals, st) val register_compound_literal: Loc.t -> Symbol.prefix -> Symbol.sym -> bool -> Ctype.ctype -> elabM unit -let register_compound_literal loc prefix sym is_const ty = fun st -> +let register_compound_literal loc prefix sym is_const ty = fun _ st -> ((), <| st with compound_literals= (loc, prefix, sym, is_const, ty) :: st.compound_literals |>) val resolve_object_type: Symbol.sym -> elabM (Ctype.qualifiers * Ctype.ctype) -let resolve_object_type sym = fun st -> +let resolve_object_type sym = fun _ st -> match Map.lookup sym st.visible_objects_types with - | Just qs_ty -> - (qs_ty, st) - | Nothing -> - (* let sym_str = match sym with - * | Symbol.Symbol _ n SD_None -> - * "sym_" ^ show n - * | Symbol.Symbol _ n (SD_Id str) -> - * str ^ "{" ^ show n ^ "}" - * end in *) - error ("Translation_effect.resolve_object_type ===> " ^ show sym) + | Just qs_ty -> + (qs_ty, st) + | Nothing -> + (* let sym_str = match sym with + * | Symbol.Symbol _ n SD_None -> + * "sym_" ^ show n + * | Symbol.Symbol _ n (SD_Id str) -> + * str ^ "{" ^ show n ^ "}" + * end in *) + error ("Translation_effect.resolve_object_type ===> " ^ show sym) end (* similar to Cabs_to_ail_effect.record_marker *) val record_object_types_marker: unit -> elabM nat -let record_object_types_marker () = +let record_object_types_marker () = let marker_id = Symbol.fresh_int () in begin if Global.backend_name () = "Cn" then @@ -159,31 +228,47 @@ let record_object_types_marker () = resolve_object_type sym >>= fun (_, ty) -> return (sym, ty) ) visible_objects >>= fun visible_objects_typed -> - update (fun st -> - <| st with visible_objects_types_markers_env = - Map.insert marker_id visible_objects_typed - st.visible_objects_types_markers_env |> + elab_update (fun st -> + <| st with + visible_objects_types_markers_env = + Map.insert marker_id visible_objects_typed st.visible_objects_types_markers_env + |> ) else return () - end >> + end >>= fun () -> return marker_id -(* record that an (unrecoverable) error occured, but don't abandon +(* record that an (unrecoverable) error occurred, but don't abandon translation yet, so the user gets a full list of such errors *) val record_error: string -> elabM unit let record_error err = let () = Debug.print_unsupported err in - update (fun st -> <| st with errors = err :: st.errors |>) + elab_update (fun st -> <| st with errors = err :: st.errors |>) val record_error_at: Loc.t -> string -> elabM unit let record_error_at loc err = record_error ((Loc.stringFromLocation (Loc.with_cursor loc)) ^ ": " ^ err) -val runStateM_errors: forall 'a. elabM 'a -> elab_state -> 'a * elab_state -let runStateM_errors m st = - let (rv, st) = runStateM m st in + +(* + +val runStateM: forall 'a 'st. stateM 'a 'st -> 'st -> ('a * 'st) +let runStateM m st = + m st + + +*) + +val runElabM: forall 'a. elab_config -> elabM 'a -> elab_state -> ('a * elab_state) +let runElabM conf m st = + m conf st + +val runElabM_errors: + forall 'a. elab_config -> elabM 'a -> elab_state -> 'a * elab_state +let runElabM_errors conf m st = + let (rv, st) = m conf st in match List.reverse st.errors with | [] -> (rv, st) | (err1 :: _) -> error err1 diff --git a/frontend/model/undefined.lem b/frontend/model/undefined.lem index 248550d68..91c454291 100644 --- a/frontend/model/undefined.lem +++ b/frontend/model/undefined.lem @@ -11,7 +11,10 @@ type unspecified_ub_context = | UB_unspec_copy_alloc_id | UB_unspec_rvalue_memberof | UB_unspec_memberofptr + | UB_unspec_if + | UB_unspec_while | UB_unspec_do + | UB_unspec_switch type undefined_by_omission = | UB_OMIT_memcpy_non_object @@ -1079,7 +1082,10 @@ let ub_str_bimap = ; (UB_CERB004_unspecified UB_unspec_copy_alloc_id, "UB_CERB004_unspecified__copy_alloc_id") ; (UB_CERB004_unspecified UB_unspec_rvalue_memberof, "UB_CERB004_unspecified__rvalue_memberof") ; (UB_CERB004_unspecified UB_unspec_memberofptr, "UB_CERB004_unspecified__memberofptr") + ; (UB_CERB004_unspecified UB_unspec_if, "UB_CERB004_unspecified__if") + ; (UB_CERB004_unspecified UB_unspec_while, "UB_CERB004_unspecified__while") ; (UB_CERB004_unspecified UB_unspec_do, "UB_CERB004_unspecified__do") + ; (UB_CERB004_unspecified UB_unspec_switch, "UB_CERB004_unspecified__switch") ; (UB_CERB005_free_nullptr, "UB_CERB005_free_nullptr") ; (UB_CHERI_InvalidCap,"UB_CHERI_InvalidCap") ; (UB_CHERI_InsufficientPermissions,"UB_CHERI_InsufficientPermissions") @@ -1408,8 +1414,14 @@ let pretty_string_of_undefined_behaviour = function "the operand of '.' operator (rvalue case) evaluates to an unspecified value" | UB_unspec_memberofptr -> "the operand of '->' operator evaluates to an unspecified value" + | UB_unspec_if -> + "the controlling expression of an 'if' statement evaluated to an unspecified value" + | UB_unspec_while -> + "the controlling expression of a 'while' statement evaluated to an unspecified value" | UB_unspec_do -> "the controlling expression of a 'do' statement evaluated to an unspecified value" + | UB_unspec_switch -> + "the controlling expression of a 'switch' statement evaluated to an unspecified value" end | UB_CERB005_free_nullptr -> "a call to 'free()' is given a 'NULL' pointer" diff --git a/memory/cheri-coq/impl_mem.ml b/memory/cheri-coq/impl_mem.ml index 472366fbe..d4f9718c5 100644 --- a/memory/cheri-coq/impl_mem.ml +++ b/memory/cheri-coq/impl_mem.ml @@ -33,6 +33,8 @@ module CerbSwitchesProxy = struct | SW_revocation `CORNUCOPIA -> SW_revocation CORNUCOPIA | SW_at_magic_comments -> SW_at_magic_comments | SW_magic_comment_char_dollar -> SW_magic_comment_char_dollar + | SW_copy_prop -> SW_copy_prop + | SW_branching_on_unspec_is_nd -> SW_branching_on_unspec_is_nd let toCoq_switches (cs: cerb_switch list): CoqSwitches.cerb_switches_t = let open ListSet in @@ -241,12 +243,10 @@ module CerbTagDefs = struct let l = Pmap.bindings_list m in let (e:CoqCtype.tag_definition CoqSymbol.SymMap.t) = CoqSymbol.SymMap.empty in List.fold_left (fun m (s,(_, d)) -> CoqSymbol.SymMap.add (toCoq_Symbol_sym s) (toCoq_tag_definition d) m) e l - - let tagDefs _ = toCoq_SymMap (Tags.tagDefs ()) end -module MM = CheriMemoryExe(MemCommonExe)(MorelloCapabilityWithStrfcap)(MorelloImpl)(CerbTagDefs:CoqTags.TagDefs)(CerbSwitchesProxy) +module MM = CheriMemoryExe(MemCommonExe)(MorelloCapabilityWithStrfcap)(MorelloImpl)(CerbSwitchesProxy) module C = MorelloCapabilityWithStrfcap module L = struct @@ -268,7 +268,7 @@ module CHERIMorello : Memory = struct type footprint = MM.footprint type mem_state = MM.mem_state - let initial_mem_state = MM.initial_mem_state + let initial_mem_state tagDefs = MM.initial_mem_state (CerbTagDefs.toCoq_SymMap tagDefs) let overlapping = MM.overlapping let cs_module = (module struct @@ -1159,7 +1159,7 @@ module CHERIMorello : Memory = struct (* There is a sketch of implementation of this function in Coq but it requires some dependencies and fixpoint magic. It OK to have in in OCaml for now *) - let prefix_of_pointer (pv:pointer_value) : string option memM = + let prefix_of_pointer tagDefs (pv:pointer_value) : string option memM = if !Cerb_debug.debug_level >= 2 then Printf.fprintf stderr "MEMOP prefix_of_pointer\n"; let open String_symbol in @@ -1177,7 +1177,7 @@ module CHERIMorello : Memory = struct Some (string_of_prefix (fromCoq_Symbol_prefix alloc.prefix) ^ " + " ^ Z.to_string offset) | Some (Ctype (_, Struct tag_sym)) -> (* TODO: nested structs *) let offset = Z.sub addr alloc.base in - let (offs, _) = lift_coq_serr (MM.offsetsof MM.coq_DEFAULT_FUEL (CerbTagDefs.tagDefs ()) (toCoq_Symbol_sym tag_sym)) in + let (offs, _) = lift_coq_serr (MM.offsetsof MM.coq_DEFAULT_FUEL (toCoq_SymMap tagDefs) (toCoq_Symbol_sym tag_sym)) in let offs = List.map (fun ((id,ty),n) ->(fromCoq_Symbol_identifier id,ty,n)) offs in let rec find = function | [] -> @@ -1190,7 +1190,7 @@ module CHERIMorello : Memory = struct | Some (Ctype (_, Array (ty, _))) -> let offset = Z.sub addr alloc.base in if Z.lt offset alloc.size then - let sz = lift_coq_serr (MM.sizeof MM.coq_DEFAULT_FUEL (Some (CerbTagDefs.tagDefs ())) (toCoq_ctype ty)) in + let sz = lift_coq_serr (MM.sizeof MM.coq_DEFAULT_FUEL (toCoq_SymMap tagDefs) (toCoq_ctype ty)) in let n = Z.div offset sz in Some (string_of_prefix (fromCoq_Symbol_prefix alloc.prefix) ^ "[" ^ Z.to_string n ^ "]") else @@ -1246,9 +1246,9 @@ module CHERIMorello : Memory = struct let null_cap = MM.null_cap (* Pointer shifting constructors *) - let array_shift_ptrval p ty iv = lift_coq_serr @@ MM.array_shift_ptrval p (toCoq_ctype ty) iv - let member_shift_ptrval p tag_sym memb_ident = - lift_coq_serr (MM.member_shift_ptrval p (toCoq_Symbol_sym tag_sym) (toCoq_Symbol_identifier memb_ident)) + let array_shift_ptrval tagDefs loc p ty iv = Undefined.return0 (lift_coq_serr @@ MM.array_shift_ptrval (toCoq_SymMap tagDefs) (toCoq_location loc) p (toCoq_ctype ty) iv) + let member_shift_ptrval tagDefs p tag_sym memb_ident = + lift_coq_serr (MM.member_shift_ptrval (toCoq_SymMap tagDefs) p (toCoq_Symbol_sym tag_sym) (toCoq_Symbol_identifier memb_ident)) let eff_array_shift_ptrval loc ptrval ty iv = lift_coq_memM "eff_array_shift_ptrval" (MM.eff_array_shift_ptrval (toCoq_location loc) ptrval (toCoq_ctype ty) iv) let eff_member_shift_ptrval loc ptrval tag_sym memb_ident = @@ -1257,8 +1257,8 @@ module CHERIMorello : Memory = struct let memcpy loc ptrval1 ptrval2 size_int = lift_coq_memM "memcpy" (MM.memcpy (toCoq_location loc) ptrval1 ptrval2 size_int) - let memcmp ptrval1 ptrval2 size_int = - lift_coq_memM "memcmp" (MM.memcmp ptrval1 ptrval2 size_int) + let memcmp loc ptrval1 ptrval2 size_int = + lift_coq_memM "memcmp" (MM.memcmp (toCoq_location loc) ptrval1 ptrval2 size_int) let realloc loc tid align ptr size = lift_coq_memM "realloc" (MM.realloc (toCoq_location loc) (Z.of_int tid) align ptr size) @@ -1300,9 +1300,6 @@ module CHERIMorello : Memory = struct (toCoq_Symbol_sym tag_sym) (toCoq_Symbol_identifier memb_ident)) - let sizeof_ival ty = lift_coq_serr @@ MM.sizeof_ival (toCoq_ctype ty) - let alignof_ival ty = lift_coq_serr @@ MM.alignof_ival (toCoq_ctype ty) - let bitwise_complement_ival ity a = MM.bitwise_complement_ival (toCoq_integerType ity) a diff --git a/memory/concrete/impl_mem.ml b/memory/concrete/impl_mem.ml index f8c83525a..f401d0a8a 100644 --- a/memory/concrete/impl_mem.ml +++ b/memory/concrete/impl_mem.ml @@ -94,8 +94,8 @@ module IntMap = Map.Make(Z) let offsetsof = Ocaml_implementation.offsetsof (* TODO(state-removal) *) -let sizeof ?(tagDefs= Tags.tagDefs ()) ty = Ocaml_implementation.sizeof tagDefs ty -let alignof ?(tagDefs= Tags.tagDefs ()) ty = Ocaml_implementation.alignof tagDefs ty +let sizeof ~tagDefs ty = Ocaml_implementation.sizeof tagDefs ty +let alignof ~tagDefs ty = Ocaml_implementation.alignof tagDefs ty module Concrete : Memory = struct let name = "concrete" @@ -321,9 +321,12 @@ module Concrete : Memory = struct last_used: storage_instance_id option; requested: (address * Z.t) list; (* the addresses (and object sizes) that were allocated with cerb::with_address() *) + + (* READONLY (TODO: move this to the config part when the monad is changed) *) + tagDefs: Ctype.tag_definitions; } - let initial_mem_state = { + let initial_mem_state tagDefs = { next_alloc_id= Z.zero; next_iota= Z.zero; allocations= IntMap.empty; @@ -340,8 +343,12 @@ module Concrete : Memory = struct dynamic_addrs= []; last_used= None; requested= []; + + tagDefs; } - + + let get_tagDefs = read (fun st -> st.tagDefs) + (* TODO *) type footprint = (* base address, size *) @@ -497,23 +504,23 @@ module Concrete : Memory = struct | None -> fail ~loc (MerrOutsideLifetime ("Concrete.get_allocation, alloc_id=" ^ Z.to_string alloc_id)) - let is_within_bound ~loc alloc_id lvalue_ty addr = + let is_within_bound ~tagDefs ~loc alloc_id lvalue_ty addr = get_allocation ~loc alloc_id >>= fun alloc -> - return (Z.leq alloc.base addr && Z.leq (Z.add addr (sizeof lvalue_ty)) (Z.add alloc.base alloc.size)) + return (Z.leq alloc.base addr && Z.leq (Z.add addr (sizeof ~tagDefs lvalue_ty)) (Z.add alloc.base alloc.size)) - let is_within_device ty addr = + let is_within_device ~tagDefs ty addr = return begin List.exists (fun (min, max) -> - Z.leq min addr && Z.leq (Z.add addr (sizeof ty)) max + Z.leq min addr && Z.leq (Z.add addr (sizeof ~tagDefs ty)) max ) device_ranges end (* NOTE: this will have to change when moving to a subobject semantics *) - let is_atomic_member_access ~loc alloc_id lvalue_ty addr = + let is_atomic_member_access ~tagDefs ~loc alloc_id lvalue_ty addr = get_allocation ~loc alloc_id >>= fun alloc -> match alloc.ty with | Some ty when AilTypesAux.is_atomic ty -> - if addr = alloc.base && Z.equal (sizeof lvalue_ty) alloc.size + if addr = alloc.base && Z.equal (sizeof ~tagDefs lvalue_ty) alloc.size && Ctype.ctypeEqual lvalue_ty ty then (* the types equality check is to deal with the case where the first member is accessed and their are no padding bytes ... *) @@ -522,7 +529,7 @@ module Concrete : Memory = struct let () = Printf.fprintf stderr "addr: %s <--> alloc.base: %s\n" (Z.to_string addr) (Z.to_string alloc.base) in let () = Printf.fprintf stderr "|lvalue_ty|: %s <--> |alloc|: %s\n" - (Z.to_string (sizeof lvalue_ty)) (Z.to_string alloc.size) in + (Z.to_string (sizeof ~tagDefs lvalue_ty)) (Z.to_string alloc.size) in return true | _ -> return false @@ -730,14 +737,18 @@ module Concrete : Memory = struct return alloc_id - (* INTERNAL abst: ctype -> AbsByte.t list -> [`NoTaint | `NewTaint of storage_instance_id list] * mem_value * AbsByte.t list *) + (* INTERNAL abst: ctype -> AbsByte.t list -> + [`NoTaint | `NewTaint of storage_instance_id list] * mem_value * AbsByte.t list *) (* ASSUMES: has_size ty /\ |bs| >= sizeof ty*) (* property that should hold: forall ty bs bs' mval. has_size ty -> |bs| >= sizeof ty -> abst ty bs = (mval, bs') -> |bs'| + sizeof ty = |bs| /\ typeof mval = ty *) - let rec abst ?(is_zap=false) find_overlaping ~(addr : address) unionmap funptrmap (Ctype (_, ty) as cty) (bs : AbsByte.t list) : [`NoTaint | `NewTaint of storage_instance_id list] * mem_value * AbsByte.t list = - let self ?(offset=0) = abst find_overlaping ~addr:(Z.add addr (Z.of_int offset)) unionmap funptrmap in + let rec abst ?(is_zap=false) ~tagDefs find_overlaping ~(addr : address) unionmap funptrmap + (Ctype (_, ty) as cty) (bs : AbsByte.t list) + : [`NoTaint | `NewTaint of storage_instance_id list] * mem_value * AbsByte.t list = + let self ?(offset=0) = + abst ~tagDefs find_overlaping ~addr:(Z.add addr (Z.of_int offset)) unionmap funptrmap in let extract_unspec xs = List.fold_left (fun acc_opt c_opt -> match acc_opt, c_opt with @@ -749,7 +760,7 @@ module Concrete : Memory = struct Some (c :: acc) ) (Some []) (List.rev xs) in - if Z.lt (Z.of_int (List.length bs)) (sizeof cty) then + if Z.lt (Z.of_int (List.length bs)) (sizeof ~tagDefs cty) then failwith "abst, |bs| < sizeof(ty)"; let merge_taint x y = @@ -770,7 +781,7 @@ module Concrete : Memory = struct (* ty must have a known size *) assert false | Basic (Integer ity) -> - let (bs1, bs2) = L.split_at (Z.to_int (sizeof cty)) bs in + let (bs1, bs2) = L.split_at (Z.to_int (sizeof ~tagDefs cty)) bs in let (prov, bs1') = AbsByte.pvi_split_bytes bs1 in (* PNVI-ae-udi *) ( AbsByte.provs_of_bytes bs1 @@ -795,7 +806,7 @@ module Concrete : Memory = struct MVunspecified cty end , bs2) | Basic (Floating fty) -> - let (bs1, bs2) = L.split_at (Z.to_int (sizeof cty)) bs in + let (bs1, bs2) = L.split_at (Z.to_int (sizeof ~tagDefs cty)) bs in (* we don't care about provenances for floats *) let (_, _, bs1') = AbsByte.split_bytes bs1 in ( `NoTaint @@ -816,7 +827,7 @@ module Concrete : Memory = struct in aux (Z.to_int n) (`NoTaint, []) bs | Pointer (_, ref_ty) -> - let (bs1, bs2) = L.split_at (Z.to_int (sizeof cty)) bs in + let (bs1, bs2) = L.split_at (Z.to_int (sizeof ~tagDefs cty)) bs in Cerb_debug.print_debug 1 [] (fun () -> "TODO: Concrete, assuming pointer repr is unsigned??"); let (prov, prov_status, bs1') = AbsByte.split_bytes bs1 in ( `NoTaint (* PNVI-ae-udi *) @@ -884,21 +895,21 @@ module Concrete : Memory = struct self atom_ty bs | Struct tag_sym -> (* TODO: the Z.to_int on the sizeof() will raise Overflow on huge structs *) - let (bs1, bs2) = L.split_at (Z.to_int (sizeof cty)) bs in + let (bs1, bs2) = L.split_at (Z.to_int (sizeof ~tagDefs cty)) bs in let (taint, rev_xs, _, bs') = List.fold_left (fun (taint_acc, acc_xs, previous_offset, acc_bs) (memb_ident, memb_ty, memb_offset) -> (* TODO: the Z.to_int will raise Overflow if the member is huge *) let pad = Z.to_int (Z.sub memb_offset previous_offset) in let (taint, mval, acc_bs') = self ~offset:pad memb_ty (L.drop pad acc_bs) in - (merge_taint taint taint_acc, (memb_ident, memb_ty, mval)::acc_xs, Z.add memb_offset (sizeof memb_ty), acc_bs') - ) (`NoTaint, [], Z.zero, bs1) (fst (offsetsof ~ignore_flexible:true (Tags.tagDefs ()) tag_sym)) in + (merge_taint taint taint_acc, (memb_ident, memb_ty, mval)::acc_xs, Z.add memb_offset (sizeof ~tagDefs memb_ty), acc_bs') + ) (`NoTaint, [], Z.zero, bs1) (fst (offsetsof ~ignore_flexible:true tagDefs tag_sym)) in (* TODO: check that bs' = last padding of the struct *) (taint, MVstruct (tag_sym, List.rev rev_xs), bs2) | Union tag_sym -> - let (bs1, bs2) = L.split_at (Z.to_int (sizeof cty)) bs in + let (bs1, bs2) = L.split_at (Z.to_int (sizeof ~tagDefs cty)) bs in if is_zap then (* TODO: hack to prevent pointer zap from crashing if a union is in the memory *) ( `NoTaint, MVunspecified cty, bs2) - else (match Pmap.find tag_sym (Tags.tagDefs ()) with + else (match Pmap.find tag_sym tagDefs with | _, UnionDef ((first_membr_def :: _) as membrs) -> let (membr_ident, (_, _, _, membr_ty)) = match IntMap.find_opt addr unionmap with @@ -959,23 +970,23 @@ module Concrete : Memory = struct ) (* INTERNAL repr *) - let rec repr funptrmap mval : ((Digest.t * string) IntMap.t * AbsByte.t list) = + let rec repr ~tagDefs funptrmap mval : ((Digest.t * string) IntMap.t * AbsByte.t list) = let ret bs = (funptrmap, bs) in match mval with | MVunspecified ty -> (* TODO: the Z.to_int on the sizeof() will raise Overflow on huge structs/unions *) - ret @@ List.init (Z.to_int (sizeof ty)) (fun _ -> AbsByte.v Prov_none None) + ret @@ List.init (Z.to_int (sizeof ~tagDefs ty)) (fun _ -> AbsByte.v Prov_none None) | MVinteger (ity, IV (prov, n)) -> ret @@List.map (AbsByte.v prov) begin bytes_of_int (AilTypesAux.is_signed_ity ity) - (Z.to_int (sizeof (Ctype ([], Basic (Integer ity))))) n + (Z.to_int (sizeof ~tagDefs (Ctype ([], Basic (Integer ity))))) n end | MVfloating (fty, fval) -> ret @@ List.map (AbsByte.v Prov_none) begin bytes_of_int true (* TODO: check that *) - (Z.to_int (sizeof (Ctype ([], Basic (Floating fty))))) (Z.of_int64 (Int64.bits_of_float fval)) + (Z.to_int (sizeof ~tagDefs (Ctype ([], Basic (Floating fty))))) (Z.of_int64 (Int64.bits_of_float fval)) end | MVpointer (_, PV (prov, ptrval_)) -> Cerb_debug.print_debug 1 [] (fun () -> "NOTE: we fix the sizeof pointers to 8 bytes"); @@ -1016,39 +1027,39 @@ module Concrete : Memory = struct | MVarray mvals -> let (funptrmap, bs_s) = List.fold_left begin fun (funptrmap, bs) mval -> - let (funptrmap, bs') = repr funptrmap mval in + let (funptrmap, bs') = repr ~tagDefs funptrmap mval in (funptrmap, bs' :: bs) end (funptrmap, []) mvals in (* TODO: use a fold? *) (funptrmap, L.concat @@ List.rev bs_s) | MVstruct (tag_sym, xs) -> let padding_byte _ = AbsByte.v Prov_none None in - let (offs, last_off) = offsetsof ~ignore_flexible:true (Tags.tagDefs ()) tag_sym in + let (offs, last_off) = offsetsof ~ignore_flexible:true tagDefs tag_sym in (* NOTE: this Z.to_int is fine because we can't have huge paddings *) - let final_pad = Z.(to_int (sub (sizeof (Ctype ([], Struct tag_sym))) last_off)) in + let final_pad = Z.(to_int (sub (sizeof ~tagDefs (Ctype ([], Struct tag_sym))) last_off)) in (* TODO: rewrite now that offsetsof returns the paddings *) let (funptrmap, _, bs) = List.fold_left2 begin fun (funptrmap, last_off, acc) (ident, ty, off) (_, _, mval) -> (* NOTE: this Z.to_int is fine because we can't have huge paddings *) let pad = Z.to_int (Z.sub off last_off) in - let (funptrmap, bs) = repr funptrmap mval in - (funptrmap, Z.add off (sizeof ty), acc @ List.init pad padding_byte @ bs) + let (funptrmap, bs) = repr ~tagDefs funptrmap mval in + (funptrmap, Z.add off (sizeof ~tagDefs ty), acc @ List.init pad padding_byte @ bs) end (funptrmap, Z.zero, []) offs xs in (funptrmap, bs @ List.init final_pad padding_byte) | MVunion (tag_sym, memb_ident, mval) -> (* TODO: the Z.to_int on the sizeof() will raise Overflow on huge structs/unions *) - let size = Z.to_int (sizeof (Ctype ([], Union tag_sym))) in - let (funptrmap', bs) = repr funptrmap mval in + let size = Z.to_int (sizeof ~tagDefs (Ctype ([], Union tag_sym))) in + let (funptrmap', bs) = repr ~tagDefs funptrmap mval in (funptrmap', bs @ List.init (size - List.length bs) (fun _ -> AbsByte.v Prov_none None)) (* BEGIN DEBUG *) - let dot_of_mem_state st = + let dot_of_mem_state ~tagDefs st = let get_value alloc = let bs = fetch_bytes st.bytemap alloc.base (Z.to_int alloc.size) in match alloc.ty with | Some ty -> - let (_, mval, _) = abst (find_overlaping st) ~addr:alloc.base st.last_used_union_members st.funptrmap ty bs in + let (_, mval, _) = abst ~tagDefs (find_overlaping st) ~addr:alloc.base st.last_used_union_members st.funptrmap ty bs in mval | None -> failwith "Concrete.dot_of_mem_state: alloc.ty = None" @@ -1109,8 +1120,9 @@ module Concrete : Memory = struct failwith "allocator_with_address ==> requested adddress has wrong alignment" let allocate_object tid pref (*is_zero_init*) (IV (_, align)) ty req_addr_opt init_opt : pointer_value memM = + get_tagDefs >>= fun tagDefs -> (* print_bytemap "ENTERING ALLOC_STATIC" >>= fun () -> *) - let size = sizeof ty in + let size = sizeof ~tagDefs ty in begin match req_addr_opt with | None -> allocator size align @@ -1138,7 +1150,7 @@ module Concrete : Memory = struct IntMap.add addr b acc ) st.bytemap bs else - let (_, pre_bs) = repr st.funptrmap (MVunspecified ty) in + let (_, pre_bs) = repr ~tagDefs st.funptrmap (MVunspecified ty) in let bs = List.mapi (fun i b -> (Z.add addr (Z.of_int i), b)) pre_bs in List.fold_left (fun acc (addr, b) -> IntMap.add addr b acc @@ -1156,7 +1168,7 @@ module Concrete : Memory = struct let alloc = {prefix= pref; base= addr; size= size; ty= Some ty; is_readonly= readonly_status; taint= `Unexposed} in (* TODO: factorise this with do_store inside Concrete.store *) update (fun st -> - let (funptrmap, pre_bs) = repr st.funptrmap mval in + let (funptrmap, pre_bs) = repr ~tagDefs st.funptrmap mval in let bs = List.mapi (fun i b -> (Z.add addr (Z.of_int i), b)) pre_bs in { st with allocations= IntMap.add alloc_id alloc st.allocations; @@ -1184,7 +1196,7 @@ module Concrete : Memory = struct Cerb_debug.warn [] (fun () -> "update_prefix: wrong arguments"); return () - let prefix_of_pointer (PV (prov, pv)) : string option memM = + let prefix_of_pointer tagDefs (PV (prov, pv)) : string option memM = let open String_symbol in let rec aux addr alloc = function | None @@ -1200,7 +1212,7 @@ module Concrete : Memory = struct Some (string_of_prefix alloc.prefix ^ " + " ^ Z.to_string offset) | Some (Ctype (_, Struct tag_sym)) -> (* TODO: nested structs *) let offset = Z.sub addr alloc.base in - let (offs, _) = offsetsof (Tags.tagDefs ()) tag_sym in + let (offs, _) = offsetsof tagDefs tag_sym in let rec find = function | [] -> None @@ -1213,7 +1225,7 @@ module Concrete : Memory = struct | Some (Ctype (_, Array (ty, _))) -> let offset = Z.sub addr alloc.base in if Z.lt offset alloc.size then - let n = Z.div offset (sizeof ty) in + let n = Z.div offset (sizeof ~tagDefs ty) in Some (string_of_prefix alloc.prefix ^ "[" ^ Z.to_string n ^ "]") else None @@ -1259,7 +1271,7 @@ module Concrete : Memory = struct (* zap (make unspecified) any pointer in the memory with provenance matching a given allocation id *) - let zap_pointers alloc_id = + let zap_pointers ~tagDefs alloc_id = modify (fun st -> let bytemap' = IntMap.fold (fun _ alloc acc -> let bs = fetch_bytes st.bytemap alloc.base (Z.to_int alloc.size) in @@ -1268,7 +1280,7 @@ module Concrete : Memory = struct (* TODO: zapping doesn't work yet for dynamically allocated pointers *) acc | Some ty -> - begin match abst ~is_zap:true (find_overlaping st) ~addr:alloc.base st.last_used_union_members st.funptrmap ty bs with + begin match abst ~is_zap:true ~tagDefs (find_overlaping st) ~addr:alloc.base st.last_used_union_members st.funptrmap ty bs with | (_, MVpointer (ref_ty, (PV (Prov_some ptr_alloc_id, _))), []) when alloc_id = ptr_alloc_id -> let bs' = List.init (Z.to_int alloc.size) (fun i -> (Z.add alloc.base (Z.of_int i), AbsByte.v Prov_none None) @@ -1331,7 +1343,8 @@ module Concrete : Memory = struct allocations= IntMap.remove alloc_id st.allocations} end >>= fun () -> if Switches.(has_switch SW_zap_dead_pointers) then - zap_pointers alloc_id + get_tagDefs >>= fun tagDefs -> + zap_pointers ~tagDefs alloc_id else return () @@ -1365,7 +1378,8 @@ module Concrete : Memory = struct allocations= IntMap.remove alloc_id st.allocations} end >>= fun () -> if Switches.(has_switch SW_zap_dead_pointers) then - zap_pointers alloc_id + get_tagDefs >>= fun tagDefs -> + zap_pointers ~tagDefs alloc_id else return () end else @@ -1376,11 +1390,12 @@ module Concrete : Memory = struct Cerb_debug.print_debug 10(*KKK*) [] (fun () -> "ENTERING LOAD: " ^ Cerb_location.location_to_string loc ); + get_tagDefs >>= fun tagDefs -> let do_load alloc_id_opt addr = get >>= fun st -> (* TODO: the Z.to_int will fail on huge objects *) - let bs = fetch_bytes st.bytemap addr (Z.to_int (sizeof ty)) in - let (taint, mval, bs') = abst (find_overlaping st) ~addr st.last_used_union_members st.funptrmap ty bs in + let bs = fetch_bytes st.bytemap addr (Z.to_int (sizeof ~tagDefs ty)) in + let (taint, mval, bs') = abst ~tagDefs (find_overlaping st) ~addr st.last_used_union_members st.funptrmap ty bs in (* PNVI-ae-udi *) begin if Switches.(has_switch (SW_PNVI `AE) || has_switch (SW_PNVI `AE_UDI)) then expose_allocations taint @@ -1388,7 +1403,7 @@ module Concrete : Memory = struct return () end >>= fun () -> update (fun st -> { st with last_used= alloc_id_opt }) >>= fun () -> - let fp = FP (`R, addr, (sizeof ty)) in + let fp = FP (`R, addr, (sizeof ~tagDefs ty)) in begin match bs' with | [] -> Cerb_debug.print_debug 10(*KKK*) [] (fun () -> @@ -1432,7 +1447,7 @@ module Concrete : Memory = struct | (Prov_none, _) -> fail ~loc (MerrAccess (LoadAccess, OutOfBoundPtr)) | (Prov_device, PVconcrete (_, addr)) -> - begin is_within_device ty addr >>= function + begin is_within_device ~tagDefs ty addr >>= function | false -> fail ~loc (MerrAccess (LoadAccess, OutOfBoundPtr)) | true -> @@ -1449,11 +1464,11 @@ module Concrete : Memory = struct | true -> return (`FAIL (loc, MerrAccess (LoadAccess, DeadPtr))) | false -> - begin is_within_bound ~loc z ty addr >>= function + begin is_within_bound ~tagDefs ~loc z ty addr >>= function | false -> return (`FAIL (loc, MerrAccess (LoadAccess, OutOfBoundPtr))) | true -> - begin is_atomic_member_access ~loc z ty addr >>= function + begin is_atomic_member_access ~tagDefs ~loc z ty addr >>= function | true -> return (`FAIL (loc, MerrAccess (LoadAccess, AtomicMemberof))) | false -> @@ -1471,14 +1486,14 @@ module Concrete : Memory = struct | false -> return () end >>= fun () -> - begin is_within_bound ~loc alloc_id ty addr >>= function + begin is_within_bound ~tagDefs ~loc alloc_id ty addr >>= function | false -> Cerb_debug.print_debug 1 [] (fun () -> "LOAD out of bound, alloc_id=" ^ Z.to_string alloc_id ); fail ~loc (MerrAccess (LoadAccess, OutOfBoundPtr)) | true -> - begin is_atomic_member_access ~loc alloc_id ty addr >>= function + begin is_atomic_member_access ~tagDefs ~loc alloc_id ty addr >>= function | true -> fail ~loc (MerrAccess (LoadAccess, AtomicMemberof)) | false -> @@ -1488,6 +1503,7 @@ module Concrete : Memory = struct let store loc ty is_locking (PV (prov, ptrval_)) mval = + get_tagDefs >>= fun tagDefs -> Cerb_debug.print_debug 10(*KKK*) [] (fun () -> "ENTERING STORE: ty=" ^ String_core_ctype.string_of_ctype ty ^ " -> @" ^ Pp_utils.to_plain_string (pp_pointer_value (PV (prov, ptrval_))) ^ @@ -1505,7 +1521,7 @@ module Concrete : Memory = struct end else let do_store alloc_id_opt addr = update begin fun st -> - let (funptrmap, pre_bs) = repr st.funptrmap mval in + let (funptrmap, pre_bs) = repr ~tagDefs st.funptrmap mval in let bs = List.mapi (fun i b -> (Z.add addr (Z.of_int i), b)) pre_bs in { st with last_used= alloc_id_opt; bytemap= @@ -1523,7 +1539,7 @@ module Concrete : Memory = struct return () end >>= fun () -> print_bytemap ("AFTER STORE => " ^ Cerb_location.location_to_string loc) >>= fun () -> - return (FP (`W, addr, (sizeof ty))) in + return (FP (`W, addr, (sizeof ~tagDefs ty))) in let select_ro_kind = function | Symbol.PrefTemporaryLifetime _ -> ReadonlyTemporaryLifetime @@ -1539,7 +1555,7 @@ module Concrete : Memory = struct | (Prov_none, _) -> fail ~loc (MerrAccess (StoreAccess, OutOfBoundPtr)) | (Prov_device, PVconcrete (_, addr)) -> - begin is_within_device ty addr >>= function + begin is_within_device ~tagDefs ty addr >>= function | false -> fail ~loc (MerrAccess (StoreAccess, OutOfBoundPtr)) | true -> @@ -1552,7 +1568,7 @@ module Concrete : Memory = struct PNVI-ae-udi stuff separated to avoid polluting the vanilla PNVI code) *) let precondition z = - is_within_bound ~loc z ty addr >>= function + is_within_bound ~tagDefs ~loc z ty addr >>= function | false -> return (`FAIL (loc, MerrAccess (StoreAccess, OutOfBoundPtr))) | true -> @@ -1561,7 +1577,7 @@ module Concrete : Memory = struct | IsReadOnly ro_kind -> return (`FAIL (loc, MerrWriteOnReadOnly ro_kind)) | IsWritable -> - begin is_atomic_member_access ~loc z ty addr >>= function + begin is_atomic_member_access ~tagDefs ~loc z ty addr >>= function | true -> return (`FAIL (loc, MerrAccess (LoadAccess, AtomicMemberof))) | false -> @@ -1583,7 +1599,7 @@ module Concrete : Memory = struct return fp | (Prov_some alloc_id, PVconcrete (_, addr)) -> - begin is_within_bound alloc_id ~loc ty addr >>= function + begin is_within_bound ~tagDefs alloc_id ~loc ty addr >>= function | false -> fail ~loc (MerrAccess (StoreAccess, OutOfBoundPtr)) | true -> @@ -1592,7 +1608,7 @@ module Concrete : Memory = struct | IsReadOnly ro_kind -> fail ~loc (MerrWriteOnReadOnly ro_kind) | IsWritable -> - begin is_atomic_member_access ~loc alloc_id ty addr >>= function + begin is_atomic_member_access ~tagDefs ~loc alloc_id ty addr >>= function | true -> fail ~loc (MerrAccess (LoadAccess, AtomicMemberof)) | false -> @@ -1775,6 +1791,7 @@ module Concrete : Memory = struct let diff_ptrval loc diff_ty ptrval1 ptrval2 = + get_tagDefs >>= fun tagDefs -> let precond alloc addr1 addr2 = Z.leq alloc.base addr1 && Z.leq addr1 (Z.add alloc.base alloc.size) @@ -1787,7 +1804,7 @@ module Concrete : Memory = struct elem_ty | _ -> diff_ty in - return (IV (Prov_none, Z.div (Z.sub addr1 addr2) (sizeof diff_ty'))) in + return (IV (Prov_none, Z.div (Z.sub addr1 addr2) (sizeof ~tagDefs diff_ty'))) in let error_postcond = fail ~loc MerrPtrdiff in if Switches.(has_switch (SW_pointer_arith `PERMISSIVE)) then @@ -1902,7 +1919,8 @@ module Concrete : Memory = struct Printf.printf "addr: %s\n" (Z.to_string addr); Printf.printf "align: %d\n" (alignof ref_ty); *) - return (Z.(equal (modulus addr (alignof ref_ty)) zero)) + get_tagDefs >>= fun tagDefs -> + return (Z.(equal (modulus addr (alignof ~tagDefs ref_ty)) zero)) end (* Following §6.5.3.3, footnote 102) *) @@ -2023,30 +2041,31 @@ module Concrete : Memory = struct | None -> failwith "Concrete.offsetof_ival: invalid memb_ident" - let array_shift_ptrval (PV (prov, ptrval_)) ty (IV (_, ival)) = + let array_shift_ptrval tagDefs loc (PV (prov, ptrval_)) ty (IV (_, ival)) = (* As a GNU extension ty may be void, in which case the pointer arithmetic is performed at the byte granularity *) - let sz = if AilTypesAux.is_void ty then Z.one else sizeof ty in + let sz = if AilTypesAux.is_void ty then Z.one else sizeof ~tagDefs ty in let offset = (Z.(mul sz ival)) in match prov with (* PNVI-ae-udi *) | Prov_symbolic iota -> failwith "Concrete.array_shift_ptrval found a Prov_symbolic" | _ -> - PV (prov, match ptrval_ with + begin match ptrval_ with | PVnull _ -> - (* TODO: this seems to be undefined in ISO C *) - (* NOTE: in C++, if offset = 0, this is defined and returns a PVnull *) - failwith ("TODO(pure shift a null pointer should be undefined behaviour), offset:" ^ Z.to_string offset) + (* TODO: in C++ and potentially C2y (see N3322), if offset = 0, this is + defined and returns a PVnull *) + Undefined.(undef loc [UB046_array_pointer_outside]) | PVfunction _ -> - failwith "Concrete.array_shift_ptrval, PVfunction" + Undefined.(undef loc [UB046_array_pointer_outside]) | PVconcrete (membr_opt, addr) -> - PVconcrete (membr_opt, Z.add addr offset)) + Undefined.return0 (PV (prov, PVconcrete (membr_opt, Z.add addr offset))) + end - let member_shift_ptrval (PV (prov, ptrval_)) tag_sym memb_ident = - let IV (_, offset) = offsetof_ival (Tags.tagDefs ()) tag_sym memb_ident in + let member_shift_ptrval tagDefs (PV (prov, ptrval_)) tag_sym memb_ident = + let IV (_, offset) = offsetof_ival tagDefs tag_sym memb_ident in let membr_opt = - match Pmap.lookup tag_sym (Tags.tagDefs ()) with + match Pmap.lookup tag_sym tagDefs with | Some (_, UnionDef _) -> Some memb_ident | _ -> @@ -2065,8 +2084,9 @@ module Concrete : Memory = struct PVconcrete (membr_opt, Z.add addr offset)) let eff_array_shift_ptrval loc ptrval ty (IV (_, ival)) = + get_tagDefs >>= fun tagDefs -> (* KKK print_endline ("HELLO eff_array_shift_ptrval ==> " ^ Pp_utils.to_plain_string (pp_pointer_value ptrval)); *) - let offset = (Z.(mul (sizeof ty) ival)) in + let offset = (Z.(mul (sizeof ~tagDefs ty) ival)) in match ptrval with | PV (_, PVnull _) -> (* TODO: this seems to be undefined in ISO C *) @@ -2089,8 +2109,8 @@ module Concrete : Memory = struct || (is_PNVI () && not (Switches.(has_switch (SW_pointer_arith `PERMISSIVE)))) then get_allocation ~loc z >>= fun alloc -> if Z.leq alloc.base shifted_addr - && Z.leq (Z.add shifted_addr (sizeof ty)) - (Z.add (Z.add alloc.base alloc.size) (sizeof ty)) then + && Z.leq (Z.add shifted_addr (sizeof ~tagDefs ty)) + (Z.add (Z.add alloc.base alloc.size) (sizeof ~tagDefs ty)) then return true else return false @@ -2161,8 +2181,8 @@ module Concrete : Memory = struct || (is_PNVI () && not (Switches.(has_switch (SW_pointer_arith `PERMISSIVE)))) then get_allocation ~loc alloc_id >>= fun alloc -> if Z.leq alloc.base shifted_addr - && Z.leq (Z.add shifted_addr (sizeof ty)) - (Z.add (Z.add alloc.base alloc.size) (sizeof ty)) then + && Z.leq (Z.add shifted_addr (sizeof ~tagDefs ty)) + (Z.add (Z.add alloc.base alloc.size) (sizeof ~tagDefs ty)) then return (PV (Prov_some alloc_id, PVconcrete (None, shifted_addr))) else fail ~loc MerrArrayShift @@ -2179,7 +2199,8 @@ module Concrete : Memory = struct return (PV (Prov_device, PVconcrete (None, Z.add addr offset))) let eff_member_shift_ptrval _ tag_sym membr_ident ptrval = - return (member_shift_ptrval tag_sym membr_ident ptrval) + get_tagDefs >>= fun tagDefs -> + return (member_shift_ptrval tagDefs tag_sym membr_ident ptrval) let concurRead_ival ity sym = failwith "TODO: concurRead_ival" @@ -2451,12 +2472,15 @@ VIP:type pointer_value = (* TODO check *) let memcpy loc ptrval1 ptrval2 (IV (_, size_n)) = + get_tagDefs >>= fun tagDefs -> (* TODO: if ptrval1 and ptrval2 overlap ==> UB *) (* TODO: copy ptrval2 into ptrval1 *) let rec aux i = if Z.lt i size_n then - load loc Ctype.unsigned_char (array_shift_ptrval ptrval2 Ctype.unsigned_char (IV (Prov_none, i))) >>= fun (_, mval) -> - store loc Ctype.unsigned_char false (array_shift_ptrval ptrval1 Ctype.unsigned_char (IV (Prov_none, i))) mval >>= fun _ -> + Nondeterminism.lift_undef (array_shift_ptrval tagDefs loc ptrval1 Ctype.unsigned_char (IV (Prov_none, i))) >>= fun ptrval1' -> + Nondeterminism.lift_undef (array_shift_ptrval tagDefs loc ptrval2 Ctype.unsigned_char (IV (Prov_none, i))) >>= fun ptrval2' -> + load loc Ctype.unsigned_char ptrval2' >>= fun (_, mval) -> + store loc Ctype.unsigned_char false ptrval1' mval >>= fun _ -> aux (Z.succ i) else return ptrval1 in @@ -2464,14 +2488,15 @@ VIP:type pointer_value = (* TODO: validate more, but looks good *) - let memcmp ptrval1 ptrval2 (IV (_, size_n)) = + let memcmp loc ptrval1 ptrval2 (IV (_, size_n)) = + get_tagDefs >>= fun tagDefs -> let rec get_bytes ptrval acc = function | 0 -> return (List.rev acc) | size -> - load Cerb_location.unknown Ctype.unsigned_char ptrval >>= function + load loc Ctype.unsigned_char ptrval >>= function | (_, MVinteger (_, (IV (byte_prov, byte_n)))) -> - let ptr' = array_shift_ptrval ptrval Ctype.unsigned_char (IV (Prov_none, Z.one)) in + Nondeterminism.lift_undef (array_shift_ptrval tagDefs loc ptrval Ctype.unsigned_char (IV (Prov_none, Z.one))) >>= fun ptr' -> get_bytes ptr' (byte_n :: acc) (size-1) | _ -> assert false in @@ -2626,7 +2651,7 @@ VIP:type pointer_value = let mk_ui_values = mk_ui_values st in let mk_scalar kind v p bs_opt = (* TODO: the Z.to_int on the sizeof() will raise Overflow on huge objects *) - [{ kind; size = Z.to_int (sizeof ty); path = []; value = v; + [{ kind; size = Z.to_int (sizeof ~tagDefs:st.tagDefs ty); path = []; value = v; prov = p; typ = Some ty; bytes = bs_opt }] in let mk_pad n v = { kind = `Padding; size = n; typ = None; path = []; value = v; @@ -2661,7 +2686,7 @@ VIP:type pointer_value = begin match ty with | Ctype (_, Array (elem_ty, _)) -> (* TODO: the Z.to_int on the sizeof() will raise Overflow on huge structs/unions *) - let size = Z.to_int (sizeof elem_ty) in + let size = Z.to_int (sizeof ~tagDefs:st.tagDefs elem_ty) in let (rev_rows, _, _) = List.fold_left begin fun (acc, i, acc_bs) mval -> let row = List.map (add_path (string_of_int i)) @@ mk_ui_values acc_bs elem_ty mval in (row::acc, i+1, L.drop size acc_bs) @@ -2674,18 +2699,18 @@ VIP:type pointer_value = let open Z in (* NOTE: we recombine the bytes to get paddings *) (* TODO: the Z.to_int on the sizeof() will raise Overflow on huge structs *) - let (bs1, bs2) = L.split_at (to_int (sizeof ty)) bs in + let (bs1, bs2) = L.split_at (to_int (sizeof ~tagDefs:st.tagDefs ty)) bs in let (rev_rowss, _, bs') = List.fold_left begin fun (acc_rowss, previous_offset, acc_bs) (Symbol.Identifier (_, memb), memb_ty, memb_offset) -> let pad = to_int (sub memb_offset previous_offset) in let acc_bs' = L.drop pad acc_bs in - let (_, mval, acc_bs'') = abst (find_overlaping st) ~addr:Z.zero(*TODO!!!!*) st.last_used_union_members st.funptrmap memb_ty acc_bs' in + let (_, mval, acc_bs'') = abst ~tagDefs:st.tagDefs (find_overlaping st) ~addr:Z.zero(*TODO!!!!*) st.last_used_union_members st.funptrmap memb_ty acc_bs' in let rows = mk_ui_values acc_bs' memb_ty mval in let rows' = List.map (add_path memb) rows in (* TODO: set padding value here *) let rows'' = if pad = 0 then rows' else mk_pad pad "" :: rows' in - (rows''::acc_rowss, Z.add memb_offset (sizeof memb_ty), acc_bs'') - end ([], Z.zero, bs1) (fst (offsetsof (Tags.tagDefs ()) tag_sym)) + (rows''::acc_rowss, Z.add memb_offset (sizeof ~tagDefs:st.tagDefs memb_ty), acc_bs'') + end ([], Z.zero, bs1) (fst (offsetsof st.tagDefs tag_sym)) in List.concat (List.rev rev_rowss) | MVunion (tag_sym, Symbol.Identifier (_, memb), mval) -> List.map (add_path memb) (mk_ui_values bs ty mval) (* FIXME: THE TYPE IS WRONG *) @@ -2694,7 +2719,7 @@ VIP:type pointer_value = let ty = match alloc.ty with Some ty -> ty | None -> Ctype ([], Array (Ctype ([], Basic (Integer Char)), Some alloc.size)) in let size = Z.to_int alloc.size in let bs = fetch_bytes st.bytemap alloc.base size in - let (_, mval, _) = abst (find_overlaping st) ~addr:alloc.base st.last_used_union_members st.funptrmap ty bs in + let (_, mval, _) = abst ~tagDefs:st.tagDefs (find_overlaping st) ~addr:alloc.base st.last_used_union_members st.funptrmap ty bs in { id = id; base = Z.to_string alloc.base; prefix = alloc.prefix; diff --git a/memory/dune b/memory/dune index bd6dfbca4..17f82a65e 100644 --- a/memory/dune +++ b/memory/dune @@ -1,4 +1,4 @@ -(dirs cheri-coq concrete symbolic vip) +(dirs cheri-coq concrete vip) diff --git a/memory/symbolic/dune b/memory/symbolic/dune deleted file mode 100644 index 0bd6a55b7..000000000 --- a/memory/symbolic/dune +++ /dev/null @@ -1,8 +0,0 @@ -(library - (name mem_symbolic) - ; (public_name cerberus.mem.symbolic) - (flags (:standard -w -27-32)) - (private_modules mem_simplify) - (implements cerb_frontend) - (c_library_flags -lstdc++) ; FIXME - (libraries z3)) diff --git a/memory/symbolic/impl_mem.ml b/memory/symbolic/impl_mem.ml deleted file mode 100644 index 74f024944..000000000 --- a/memory/symbolic/impl_mem.ml +++ /dev/null @@ -1,700 +0,0 @@ -open Memory_model -(* we need to do this because of Lem's renaming not understanding modules... *) - -let name = "I am the defacto memory model" (* TODO: debug *) -type pointer_value = Defacto_memory_types.impl_pointer_value -type integer_value = Defacto_memory_types.impl_integer_value -type floating_value = Defacto_memory_types.impl_floating_value -type mem_value = Defacto_memory_types.impl_mem_value -type mem_iv_constraint = integer_value Mem_common.mem_constraint - - - -module Constraints = struct - type t = mem_iv_constraint - let negate x = Mem_common.MC_not x - - module Sym = Symbol - open Z3 - - let mk_forall ctx syms sorts expr = - Quantifier.mk_forall ctx sorts syms expr None [] [] None None - - type solver_state = { - submitted: t list; - ctx: context; - slv: Solver.solver; - - addrSort: Sort.sort; - integerBaseTypeSort: Sort.sort; - integerTypeSort: Sort.sort; - basicTypeSort: Sort.sort; - ctypeSort: Sort.sort; - - ivminDecl: FuncDecl.func_decl; - ivmaxDecl: FuncDecl.func_decl; - ivsizeofDecl: FuncDecl.func_decl; - ivalignofDecl: FuncDecl.func_decl; - fromptrDecl: FuncDecl.func_decl; - - in_device_memDecl: FuncDecl.func_decl; - } - - let init_solver () : solver_state = - let ctx = mk_context [(*("timeout", "")*)] in - - let mk_ctor str = - Datatype.mk_constructor_s ctx str (Symbol.mk_string ctx ("is_" ^ str)) [] [] [] in - let integerBaseTypeSort = Datatype.mk_sort_s ctx "IntegerBaseType" - [ mk_ctor "ichar_ibty" - ; mk_ctor "short_ibty" - ; mk_ctor "int_ibty" - ; mk_ctor "long_ibty" - ; mk_ctor "long_long_ibty" - ; Datatype.mk_constructor_s ctx "intN_t_ibty" (Symbol.mk_string ctx "is_intN_t_ibty") - [Symbol.mk_string ctx "intN_size"] [Some (Arithmetic.Integer.mk_sort ctx)] - [0(*TODO: no idea with I'm doing*)] - ; mk_ctor "intmax_t_ibty" - ; mk_ctor "intptr_t_ibty" ] in - - let integerTypeSort = - Datatype.mk_sort_s ctx "IntegerType" - [ mk_ctor "char_ity" - ; mk_ctor "bool_ity" - ; Datatype.mk_constructor_s ctx "Signed_ity" (Symbol.mk_string ctx "is_Signed_ity") - [Symbol.mk_string ctx "_Signed_ity"] [Some integerBaseTypeSort] - [0(*TODO: no idea with I'm doing*)] - ; Datatype.mk_constructor_s ctx "Unsigned_ity" (Symbol.mk_string ctx "is_Unsigned_ity") - [Symbol.mk_string ctx "_Unsigned_ity"] [Some integerBaseTypeSort] - [0(*TODO: no idea with I'm doing*)] - ; mk_ctor "size_t_ity" - ; mk_ctor "ptrdiff_t_ity" - ; mk_ctor "ptraddr_t_ity" - ] in - - let basicTypeSort = - Datatype.mk_sort_s ctx "BasicType" - [ Datatype.mk_constructor_s ctx "Integer_bty" (Symbol.mk_string ctx "is_Integer_bty") - [Symbol.mk_string ctx "_Integer_bty"] [Some integerTypeSort] - [0(*TODO: no idea with I'm doing*)] - ; Datatype.mk_constructor_s ctx "Floating" - (Symbol.mk_string ctx "is_Floating") [] [] [] - ] in - - let ctypeSort = - (* TODO: Function, Struct, Union, Builtin *) - Datatype.mk_sort_s ctx "Ctype" - [ mk_ctor "void_ty" - ; Datatype.mk_constructor_s ctx "Basic_ty" (Symbol.mk_string ctx "is_Basic_ty") - [Symbol.mk_string ctx "_Basic_ty"] [Some basicTypeSort] - [0(*TODO: no idea with I'm doing*)] - ; Datatype.mk_constructor_s ctx "Array_ty" (Symbol.mk_string ctx "is_Array_ty") - [Symbol.mk_string ctx "elem_Array_ty"; Symbol.mk_string ctx "size_Array_ty"] - [None; Some (Arithmetic.Integer.mk_sort ctx)] - [0; 0(*TODO: no idea with I'm doing*)] - ; Datatype.mk_constructor_s ctx "Pointer_ty" (Symbol.mk_string ctx "is_Pointer_ty") - [Symbol.mk_string ctx "_Pointer_ty"] [None] - [0(*TODO: no idea with I'm doing*)] ] in - - let intSort = Arithmetic.Integer.mk_sort ctx in - let boolSort = Boolean.mk_sort ctx in - let slvSt = { - (* allocations= []; *) - submitted= []; - ctx= ctx; - slv= Solver.mk_solver ctx None; - addrSort= Arithmetic.Integer.mk_sort ctx; - integerBaseTypeSort= integerBaseTypeSort; - integerTypeSort= integerTypeSort; - basicTypeSort= basicTypeSort; - ctypeSort= ctypeSort; - ivminDecl= FuncDecl.mk_func_decl_s ctx "ivmin" [integerTypeSort] intSort; - ivmaxDecl= FuncDecl.mk_func_decl_s ctx "ivmax" [integerTypeSort] intSort; - ivsizeofDecl= FuncDecl.mk_func_decl_s ctx "ivsizeof" [ctypeSort] intSort; - ivalignofDecl= FuncDecl.mk_func_decl_s ctx "ivalignof" [ctypeSort] intSort; - fromptrDecl= FuncDecl.mk_func_decl_s ctx "fromptr" [ctypeSort; integerTypeSort; intSort] intSort; - in_device_memDecl= FuncDecl.mk_func_decl_s ctx "in_device_mem" [intSort] boolSort; - } in - - (* axiom1 ==> forall ty: Ctype, ivsizeof(ty) > 0 *) - let axiom1 = - let ty_sym = Symbol.mk_string ctx "ty" in - let var_e = Quantifier.mk_bound ctx 0 ctypeSort in - Quantifier.expr_of_quantifier ( - mk_forall ctx [ty_sym] [ctypeSort] - (Arithmetic.mk_gt ctx (Expr.mk_app ctx slvSt.ivsizeofDecl [var_e]) - (Arithmetic.Integer.mk_numeral_i ctx 0)) - ) in - - (* axiom2 ==> forall ty: Ctype, ivmin(ty) < ivmax(ty) *) - let axiom2 = - let ity_sym = Symbol.mk_string ctx "ity" in - let var_e = Quantifier.mk_bound ctx 0 integerTypeSort in - Quantifier.expr_of_quantifier ( - mk_forall ctx [ity_sym] [integerTypeSort] - (Arithmetic.mk_lt ctx (Expr.mk_app ctx slvSt.ivminDecl [var_e]) - (Expr.mk_app ctx slvSt.ivmaxDecl [var_e])) - ) in - - (* axiom3 ==> forall ity: Ctype, ivmin(ity) <= fromptr(_, ity, _) <= ivmax(ity) *) - let axiom3 = - let ty_sym = Symbol.mk_string ctx "ty" in - let ity_sym = Symbol.mk_string ctx "ity" in - let ptr_i_sym = Symbol.mk_string ctx "ptr_i" in - let ty_e = Quantifier.mk_bound ctx 2 ctypeSort in - let ity_e = Quantifier.mk_bound ctx 1 integerTypeSort in - let ptr_i_e = Quantifier.mk_bound ctx 0 intSort in - Quantifier.expr_of_quantifier ( - mk_forall ctx [ty_sym; ity_sym; ptr_i_sym] [ctypeSort; integerTypeSort; intSort] - (Boolean.mk_and ctx - [ Arithmetic.mk_le ctx (Expr.mk_app ctx slvSt.ivminDecl [ity_e]) - (Expr.mk_app slvSt.ctx slvSt.fromptrDecl [ty_e; ity_e; ptr_i_e]) - ; Arithmetic.mk_le ctx (Expr.mk_app slvSt.ctx slvSt.fromptrDecl [ty_e; ity_e; ptr_i_e]) - (Expr.mk_app ctx slvSt.ivmaxDecl [ity_e]) ]) - ) in - - Solver.add slvSt.slv [axiom1; axiom2; axiom3]; - - (* If the size of pointer is given specified, we can assert fromptr() - say within this size *) - (* NOTE: we assume 2's complement encoding with no padding bits *) - (* - begin match Ocaml_implementation.Impl.sizeof_pointer with - | None -> - () - | Some ptr_size -> - let ptr_min - - - let axiom3 = - let ival_sym = Symbol.mk_string ctx "ival" in - Quantifier.expr_of_quantifier ( - mk_forall ctx [ival_sym] [intSort] - (Arithmetic.mk_lt ctx - ) in - end; - *) - - (* assert that all the struct/union paddings are positive *) - begin - (* FIXME VICTOR *) - Pmap.iter (fun (Sym.Symbol (_, tag_sym_n, _)) tagDef -> - let xs = match tagDef with - | _, Ctype.StructDef (z, None) -> - z - | _, Ctype.StructDef (z, Some (FlexibleArrayMember (attrs, ident, qs, elem_ty))) -> - z @ [(ident, (attrs, None, qs, Ctype ([], Array (elem_ty, None))))] - | _, Ctype.UnionDef z -> - z in - List.iter (fun (Sym.Identifier (_, membr_str), _) -> - let padding_str = "padding__tag_" ^ string_of_int tag_sym_n ^ "__" ^ membr_str in - Solver.add slvSt.slv [ - Arithmetic.mk_le ctx (Arithmetic.Integer.mk_numeral_i ctx 0) - (Expr.mk_const_s slvSt.ctx padding_str slvSt.addrSort) - ] - ) xs - ) (Tags.tagDefs ()) - end; - - slvSt - - type 'a eff = - | Eff of (solver_state -> 'a) - - let return a = - Eff (fun _ -> a) - - let bind (Eff ma) f = - Eff (fun st -> - let a = ma st in - let Eff mb = f a in - mb st - ) - - let rec foldlM f a = function - | [] -> return a - | b::bs -> bind (f a b) (fun a' -> foldlM f a' bs) - - let runEff (Eff mk) = - mk (init_solver ()) - - - let string_of_solver = - Eff (fun st -> - List.mapi (fun i (cs) -> - "\n[" ^ (string_of_int i) ^ "] -- '" (*^ str*) ^ "'\n" ^ String_defacto_memory.string_of_iv_memory_constraint cs - ) (List.rev st.submitted) - -(* - [Solver.to_string st.slv] -*) - ) - - let check_sat = - Eff (fun st -> - match Solver.check st.slv [] with - | UNSATISFIABLE -> `UNSAT - | _ -> `SAT - ) - - -(* - val with_constraints: string -> t -> 'a eff -> 'a eff -*) -open Mem_common - - - - - -let integerBaseType_to_expr slvSt ibty = - let fdecls = Datatype.get_constructors slvSt.integerBaseTypeSort in - Ctype.(match ibty with - | Ichar -> - Expr.mk_app slvSt.ctx (List.nth fdecls 0) [] - | Short -> - Expr.mk_app slvSt.ctx (List.nth fdecls 1) [] - | Int_ -> - Expr.mk_app slvSt.ctx (List.nth fdecls 2) [] - | Long -> - Expr.mk_app slvSt.ctx (List.nth fdecls 3) [] - | LongLong -> - Expr.mk_app slvSt.ctx (List.nth fdecls 4) [] - | IntN_t n -> - Expr.mk_app slvSt.ctx (List.nth fdecls 5) [Arithmetic.Integer.mk_numeral_i slvSt.ctx n] - | Int_leastN_t _ -> - failwith "TODO Smt.integerBaseType_to_expr, Int_leastN_t" - | Int_fastN_t _ -> - failwith "TODO Smt.integerBaseType_to_expr, Int_fastN_t" - | Intmax_t -> - Expr.mk_app slvSt.ctx (List.nth fdecls 6) [] - | Intptr_t -> - Expr.mk_app slvSt.ctx (List.nth fdecls 7) [] - ) - -let integerType_to_expr slvSt (ity: Ctype.integerType) = - let fdecls = Datatype.get_constructors slvSt.integerTypeSort in - Ctype.(match ity with - | Char -> - Expr.mk_app slvSt.ctx (List.nth fdecls 0) [] - | Bool -> - Expr.mk_app slvSt.ctx (List.nth fdecls 1) [] - | Signed ibty -> - Expr.mk_app slvSt.ctx (List.nth fdecls 2) [integerBaseType_to_expr slvSt ibty] - | Unsigned ibty -> - Expr.mk_app slvSt.ctx (List.nth fdecls 3) [integerBaseType_to_expr slvSt ibty] - | Enum _ -> - failwith "TODO Smt.integerType_to_expr, Enum" - | Size_t -> - Expr.mk_app slvSt.ctx (List.nth fdecls 4) [] - | Ptrdiff_t -> - Expr.mk_app slvSt.ctx (List.nth fdecls 5) [] - | Ptraddr_t -> - Expr.mk_app slvSt.ctx (List.nth fdecls 6) [] - | Wint_t - | Wchar_t -> - assert false (* TODO *) - ) - -let basicType_to_expr slvSt (bty: Ctype.basicType) = - let fdecls = Datatype.get_constructors slvSt.basicTypeSort in - Ctype.(match bty with - | Integer ity -> - Expr.mk_app slvSt.ctx (List.nth fdecls 0) [integerType_to_expr slvSt ity] - | Floating _ -> - (* TODO: this is probably wrong *) - Expr.mk_app slvSt.ctx (List.nth fdecls 1) [] - (* failwith "Smt.basicType_to_expr, Floating" *) - ) - -let rec ctype_to_expr slvSt (Ctype.Ctype (_, ty)) = - let fdecls = Datatype.get_constructors slvSt.ctypeSort in - Ctype.( - match ty with - | Void -> - Expr.mk_app slvSt.ctx (List.nth fdecls 0) [] - | Byte -> - Expr.mk_app slvSt.ctx (List.nth fdecls 1) [basicType_to_expr slvSt (Integer (Unsigned Ichar))] - | Basic bty -> - Expr.mk_app slvSt.ctx (List.nth fdecls 1) [basicType_to_expr slvSt bty] - | Array (_, None) -> - (* Ail type error *) - assert false - | Array (elem_ty, Some n) -> - Expr.mk_app slvSt.ctx (List.nth fdecls 2) - [ctype_to_expr slvSt elem_ty; Arithmetic.Integer.mk_numeral_i slvSt.ctx (Z.to_int n)] - | Pointer (_, ref_ty) -> - Expr.mk_app slvSt.ctx (List.nth fdecls 3) - [ctype_to_expr slvSt ref_ty] - | Function _ - | FunctionNoParams _ -> - failwith "TODO: Smt.ctype_to_expr, Function" - | Atomic _ -> - failwith "TODO: Smt.ctype_to_expr, Atomic" - | Struct tag_sym -> - failwith "TODO: Smt.ctype_to_expr, Struct" - | Union _ -> - failwith "TODO: Smt.ctype_to_expr, Union" -(* - | _ -> - failwith "TODO: Smt.ctype_to_expr" - (* Expr.mk_const_s slvSt.ctx "void_ty" slvSt.ctypeSort *) -*) - ) - -let address_expression_of_pointer_base = function - | Defacto_memory_types.PVunspecified ty -> - failwith "PVunspecified" - | Defacto_memory_types.PVnull ty -> - failwith "PVnull" - | Defacto_memory_types.PVfunction sym -> - failwith "PVfunction" - | Defacto_memory_types.PVbase (alloc_id, pref) -> - Defacto_memory_types.IVaddress (alloc_id, pref) - | Defacto_memory_types.PVfromint ival_ -> - ival_ - -let integer_value_base_to_expr slvSt ival_ = - let rec aux = function - | Defacto_memory_types.IVunspecified -> - failwith "IVunspecified" - | Defacto_memory_types.IVconcurRead _ -> - failwith "Smt.integer_value_base_to_expr: IVconcurRead" - | Defacto_memory_types.IVconcrete n -> - Arithmetic.Integer.mk_numeral_s slvSt.ctx (Z.to_string n) - | Defacto_memory_types.IVaddress (alloc_id, _) -> - Expr.mk_const_s slvSt.ctx ("addr_" ^ string_of_int alloc_id) slvSt.addrSort - | Defacto_memory_types.IVfromptr (ty, ity, ptrval_, sh) -> - (* the result of a cast from pointer to integer. The first - parameter is the referenced type of the pointer value, the - second is the integer type *) - let ty_e = ctype_to_expr slvSt ty in - let ity_e = integerType_to_expr slvSt ity in - let ptrval_e = (* WIP *) aux (Mem_simplify.lifted_simplify_integer_value_base (address_expression_of_pointer_base ptrval_)) in - let sh_ival_e = (* WIP *) aux (Mem_simplify.lifted_simplify_integer_value_base (Defacto_memory.integer_value_baseFromShift_path sh)) in - if Mem_simplify.simple_fromptr then begin - Arithmetic.mk_add slvSt.ctx [ptrval_e; sh_ival_e] - end else begin - Expr.mk_app slvSt.ctx slvSt.fromptrDecl [ty_e; ity_e; Arithmetic.mk_add slvSt.ctx [ptrval_e; sh_ival_e]] - end - | Defacto_memory_types.IVop (iop, [ival_1; ival_2]) -> - let mk_op = function - | IntAdd -> - fun e1 e2 -> Arithmetic.mk_add slvSt.ctx [e1; e2] - | IntSub -> - fun e1 e2 -> Arithmetic.mk_sub slvSt.ctx [e1; e2] - | IntMul -> - fun e1 e2 -> Arithmetic.mk_mul slvSt.ctx [e1; e2] - | IntDiv -> - Arithmetic.mk_div slvSt.ctx - | IntRem_t -> - failwith "TODO Smt: IntRem_t" - | IntRem_f -> - Arithmetic.Integer.mk_mod slvSt.ctx - | IntExp -> - Arithmetic.mk_power slvSt.ctx in - mk_op iop (aux ival_1) (aux ival_2) - | Defacto_memory_types.IVop _ -> - (* Core type error *) - assert false - | Defacto_memory_types.IVmin ity -> - Expr.mk_app slvSt.ctx slvSt.ivminDecl [integerType_to_expr slvSt ity] - | Defacto_memory_types.IVmax ity -> - Expr.mk_app slvSt.ctx slvSt.ivmaxDecl [integerType_to_expr slvSt ity] - | Defacto_memory_types.IVsizeof ty -> - Expr.mk_app slvSt.ctx slvSt.ivsizeofDecl [ctype_to_expr slvSt ty] - | Defacto_memory_types.IValignof (Ctype.Ctype ([], Ctype.Struct tag_sym)) -> - prerr_endline "BOGUS!!!!"; - Arithmetic.Integer.mk_numeral_s slvSt.ctx "8" - | Defacto_memory_types.IValignof ty -> - Expr.mk_app slvSt.ctx slvSt.ivalignofDecl [ctype_to_expr slvSt ty] - | Defacto_memory_types.IVoffsetof (tag_sym, memb_ident) -> - failwith "TODO Smt: IVoffsetof" - | Defacto_memory_types.IVpadding (Sym.Symbol (_, tag_sym_n, _), Sym.Identifier (_, membr_str)) -> - Expr.mk_const_s slvSt.ctx ("padding__tag_" ^ string_of_int tag_sym_n ^ "__" ^ membr_str) slvSt.addrSort - | Defacto_memory_types.IVptrdiff (diff_ty, (ptrval_1, sh1), (ptrval_2, sh2)) -> - let ptrval_e1 = (* WIP *) aux (Defacto_memory_types.IVop (IntAdd, [ address_expression_of_pointer_base ptrval_1 - ; Defacto_memory.integer_value_baseFromShift_path sh1 ])) in - let ptrval_e2 = (* WIP *) aux (Defacto_memory_types.IVop (IntAdd, [ address_expression_of_pointer_base ptrval_2 - ; Defacto_memory.integer_value_baseFromShift_path sh2 ])) in - (* TODO: maybe have that conversion be done when the IVptrdiff is created? *) - (* TODO: check that this is correct for arrays of arrays ... *) - let diff_ty' = begin match diff_ty with - | Ctype.Ctype (_, Ctype.Array (elem_ty, _)) -> - elem_ty - | _ -> - diff_ty - end in - Arithmetic.mk_div slvSt.ctx - (Arithmetic.mk_sub slvSt.ctx [ptrval_e1; ptrval_e2]) - (aux (Mem_simplify.lifted_simplify_integer_value_base (Defacto_memory_types.IVsizeof diff_ty'))) - | Defacto_memory_types.IVbyteof (ival_, mval) -> - failwith "TODO Smt: IVbyteof" - | Defacto_memory_types.IVcomposite ival_s -> - failwith "TODO Smt: IVcomposite" - | Defacto_memory_types.IVbitwise (ity, bwop) -> - let is_signed = AilTypesAux.is_signed_ity ity in - let size_ity = 8 (* TODO: should be 64 *) in - BitVector.mk_bv2int slvSt.ctx begin match bwop with - | Defacto_memory_types.BW_complement ival_ -> - BitVector.mk_not slvSt.ctx - (Arithmetic.Integer.mk_int2bv slvSt.ctx size_ity (aux ival_)) - | Defacto_memory_types.BW_AND (ival_1, ival_2) -> - BitVector.mk_and slvSt.ctx - (Arithmetic.Integer.mk_int2bv slvSt.ctx size_ity (aux ival_1)) - (Arithmetic.Integer.mk_int2bv slvSt.ctx size_ity (aux ival_2)) - | Defacto_memory_types.BW_OR (ival_1, ival_2) -> - BitVector.mk_or slvSt.ctx - (Arithmetic.Integer.mk_int2bv slvSt.ctx size_ity (aux ival_1)) - (Arithmetic.Integer.mk_int2bv slvSt.ctx size_ity (aux ival_2)) - | Defacto_memory_types.BW_XOR (ival_1, ival_2) -> - BitVector.mk_xor slvSt.ctx - (Arithmetic.Integer.mk_int2bv slvSt.ctx size_ity (aux ival_1)) - (Arithmetic.Integer.mk_int2bv slvSt.ctx size_ity (aux ival_2)) - end is_signed - in - aux (Either.either_case - (fun n -> Defacto_memory_types.IVconcrete n) - (fun z -> z) - (Mem_simplify.simplify_integer_value_base ival_) - ) - - -let mem_constraint_to_expr st (constr: mem_iv_constraint) = - let rec aux = function - | MC_empty -> - None - | MC_eq (Defacto_memory_types.IV (_, ival_1), Defacto_memory_types.IV (_, ival_2)) -> - Some (Boolean.mk_eq st.ctx (integer_value_base_to_expr st ival_1) (integer_value_base_to_expr st ival_2)) - | MC_lt (Defacto_memory_types.IV (_, ival_1), Defacto_memory_types.IV (_, ival_2)) -> - Some (Arithmetic.mk_lt st.ctx (integer_value_base_to_expr st ival_1) (integer_value_base_to_expr st ival_2)) - | MC_le (Defacto_memory_types.IV (_, ival_1), Defacto_memory_types.IV (_, ival_2)) -> - Some (Arithmetic.mk_le st.ctx (integer_value_base_to_expr st ival_1) (integer_value_base_to_expr st ival_2)) - | MC_or (cs1, cs2) -> - begin match (aux cs1, aux cs2) with - | (Some e1, Some e2) -> - Some (Boolean.mk_or st.ctx [e1; e2]) - | (Some e1, None) -> - Some e1 - | (None, Some e2) -> - Some e2 - | (None, None) -> - None - end - | MC_conj css -> - Some (Boolean.mk_and st.ctx ( - List.fold_left (fun acc cs -> - match aux cs with - | Some e -> - e :: acc - | None -> - acc - ) [] css - )) - | MC_not cs -> - begin match aux cs with - | Some e -> - Some (Boolean.mk_not st.ctx e) - | None -> - None - end - | MC_in_device (Defacto_memory_types.IV (_, ival_)) -> - Some (Expr.mk_app st.ctx st.in_device_memDecl [integer_value_base_to_expr st ival_]) - in aux constr - - - let with_constraints debug_str cs (Eff m) = - Eff (fun st -> - Solver.push st.slv; -(* - if !Cerb_debug.debug_level >= 1 then begin - prerr_endline ("ADDING CONSTRAINT [" ^ debug_str ^ "] ==> " ^ String_mem.string_of_iv_memory_constraint cs) - end; -*) - begin match mem_constraint_to_expr st cs with - | Some e -> -(* Wip.add [(debug_str, cs)]; *) - Solver.add st.slv [e] - | None -> - () - end; - let st' = { st with submitted= cs :: st.submitted } in - let ret = m st' in - Solver.pop st.slv 1; - ret - ) - -end - - - - - - - - - - - - - - - - - -(* -let cs_module = (module struct - type t = mem_iv_constraint - let negate x = Mem_common.MC_not x - - type 'a eff = 'a - let return a = a - let bind ma f = f ma - let foldlM f a bs = List.fold_left f a bs - - let runEff a = a - -(* let init_solver = return () *) - let string_of_solver = return [] - let check_sat = return `SAT - - let with_constraints _ _ a = a -end : Constraints with type t = mem_iv_constraint) -*) -let cs_module = (module Constraints : Constraints with type t = mem_iv_constraint) - -type footprint = Defacto_memory_types.impl_footprint -let overlapping _ _ = false -type mem_state = Defacto_memory.impl_mem_state -let initial_mem_state = Defacto_memory.impl_initial_mem_state -type 'a memM = - ('a, string, Mem_common.mem_error, integer_value Mem_common.mem_constraint, mem_state) Nondeterminism.ndM -let return = Defacto_memory.impl_return -let bind = Nondeterminism.nd_bind -let allocate_object = Defacto_memory.impl_allocate_object - -let allocate_region = Defacto_memory.impl_allocate_region -let kill = Defacto_memory.impl_kill -let load = Defacto_memory.impl_load -let store = Defacto_memory.impl_store -let null_ptrval = Defacto_memory.impl_null_ptrval -let fun_ptrval = Defacto_memory.impl_fun_ptrval -let concrete_ptrval _ _ = failwith "symbolic: concrete_ptrval" -let case_ptrval _ _ _ = failwith "symbolic: case_ptrval" -let case_funsym_opt _ _ = failwith "symbolic: case_funsym_val" -let eq_ptrval = Defacto_memory.impl_eq_ptrval -let ne_ptrval = Defacto_memory.impl_ne_ptrval -let lt_ptrval = Defacto_memory.impl_lt_ptrval -let gt_ptrval = Defacto_memory.impl_gt_ptrval -let le_ptrval = Defacto_memory.impl_le_ptrval -let ge_ptrval = Defacto_memory.impl_ge_ptrval -let diff_ptrval = Defacto_memory.impl_diff_ptrval -let update_prefix _ = return () -let prefix_of_pointer _ = return None -let validForDeref_ptrval = Defacto_memory.impl_validForDeref_ptrval -let isWellAligned_ptrval = Defacto_memory.impl_isWellAligned_ptrval -let ptrfromint = Defacto_memory.impl_ptrcast_ival -let intfromptr = Defacto_memory.impl_intcast_ptrval -let derive_cap _ _ _ _ = assert false (* CHERI only *) -let cap_assign_value _ _ _ = assert false (* CHERI only *) -let ptr_t_int_value _ = assert false (* CHERI only *) -let get_intrinsic_type_spec _ = assert false (* CHERI only *) -let call_intrinsic _ _ _ = assert false (* CHERI only *) -let null_cap _ = assert false (* CHERI only *) -let array_shift_ptrval = Defacto_memory.impl_array_shift_ptrval -let member_shift_ptrval = Defacto_memory.impl_member_shift_ptrval -let eff_array_shift_ptrval _ _ = failwith "Defacto_memory.impl_array_shift_ptrval" -let eff_member_shift_ptrval _ ptrval tag_sym membr_ident = return (member_shift_ptrval ptrval tag_sym membr_ident) -let memcpy = Defacto_memory.impl_memcpy -let memcmp = Defacto_memory.impl_memcmp -let realloc _ _ _ _ _ = failwith "Defacto: realloc!" -let va_start _ = failwith "Defacto: va_start" -let va_copy _ = failwith "Defacto: va_copy" -let va_arg _ _ = failwith "Defacto: va_arg" -let va_end _ = failwith "Defacto: va_end" -let va_list _ = failwith "Defacto: va_list" -let copy_alloc_id _ _ = failwith "Defacto: copy_alloc_id" -let bytefromint = Defacto_memory.impl_bytefromint -let intfrombyte = Defacto_memory.impl_intfrombyte -let concurRead_ival = Defacto_memory.impl_concurRead_ival -let integer_ival = Defacto_memory.impl_integer_ival -let max_ival = Defacto_memory.impl_max_ival -let min_ival = Defacto_memory.impl_min_ival -let op_ival = Defacto_memory.impl_op_ival -let offsetof_ival = Defacto_memory.impl_offsetof_ival -let bitwise_complement_ival = Defacto_memory.impl_bitwise_complement_ival -let bitwise_and_ival = Defacto_memory.impl_bitwise_and_ival -let bitwise_or_ival = Defacto_memory.impl_bitwise_or_ival -let bitwise_xor_ival = Defacto_memory.impl_bitwise_xor_ival -let case_integer_value = Defacto_memory.impl_case_integer_value -let is_specified_ival = Defacto_memory.impl_is_specified_ival -let eq_ival = Defacto_memory.impl_eq_ival -let lt_ival = Defacto_memory.impl_lt_ival -let le_ival = Defacto_memory.impl_le_ival -let eval_integer_value = Defacto_memory.impl_eval_integer_value -let zero_fval = Defacto_memory.impl_zero_fval -let one_fval = Defacto_memory.impl_one_fval -let str_fval = Defacto_memory.impl_str_fval -let case_fval = Defacto_memory.impl_case_fval -let op_fval = Defacto_memory.impl_op_fval -let eq_fval = Defacto_memory.impl_eq_fval -let lt_fval = Defacto_memory.impl_lt_fval -let le_fval = Defacto_memory.impl_le_fval -let fvfromint = Defacto_memory.impl_fvfromint -let ivfromfloat _ = Defacto_memory.impl_ivfromfloat -let unspecified_mval = Defacto_memory.impl_unspecified_mval -let integer_value_mval = Defacto_memory.impl_integer_value_mval -let floating_value_mval = Defacto_memory.impl_floating_value_mval -let pointer_mval = Defacto_memory.impl_pointer_mval -let array_mval = Defacto_memory.impl_array_mval -let struct_mval = Defacto_memory.impl_struct_mval -let union_mval = Defacto_memory.impl_union_mval -let case_mem_value = Defacto_memory.impl_case_mem_value -let sequencePoint = Defacto_memory.impl_sequencePoint - -include Pp_defacto_memory - -let pp_integer_value_for_coq _ = PPrint.string "DON'T USE SYMBOLIC FROM COQ" -let pp_pointer_value_for_coq _ _ = PPrint.string "DON'T USE SYMBOLIC FROM COQ" -let pp_mem_value_for_coq _ _ _ _ _ _ = PPrint.string "DON'T USE SYMBOLIC FROM COQ" -let pp_floating_value_for_coq _ = PPrint.string "DON'T USE SYMBOLIC FROM COQ" - -(* JSON serialisation *) - -let serialise_prov = function - | Defacto_memory_types.Prov_some (n, _) -> `Int n - | Defacto_memory_types.Prov_none -> `Null - | Defacto_memory_types.Prov_device -> `String "Device" - | Defacto_memory_types.Prov_wildcard -> `String "Wildcard" - -let serialise_mem_value mv = - `String (String_defacto_memory.string_of_mem_value mv) - -let serialise_storage = function - | Defacto_memory.Storage_static (_, ty, mv_opt) -> - `Assoc [("type", `String (String_core_ctype.string_of_ctype ty)); - ("value", Cerb_json.of_option serialise_mem_value mv_opt)] - | Defacto_memory.Storage_dynamic _ -> `Null - -let serialise_map f m = - let serialise_entry (k, v) = (string_of_int k, f v) - in `Assoc (List.map serialise_entry (Pmap.bindings_list m)) - -let serialise_mem_state _ (m:mem_state) = - let not_dead x _ = not @@ Pset.mem x m.dead_allocations in - let allocs = Pmap.filter not_dead m.allocations in - `Assoc [("kind", `String "symbolic"); - ("allocations", serialise_map serialise_storage allocs)] - -let string_of_integer_value ival = - Pp_utils.to_plain_string (pp_integer_value ival) - -let string_of_mem_value mval = - Pp_utils.to_plain_string begin - (* TODO: factorise *) - let saved = !Cerb_colour.do_colour in - Cerb_colour.do_colour := false; - let ret = pp_mem_value mval in - Cerb_colour.do_colour := saved; - ret - end diff --git a/memory/symbolic/mem_simplify.ml b/memory/symbolic/mem_simplify.ml deleted file mode 100644 index 9176f9804..000000000 --- a/memory/symbolic/mem_simplify.ml +++ /dev/null @@ -1,433 +0,0 @@ -open Defacto_memory_types -(* open Mem *) -open Mem_common - -open Ctype - -module Z = struct - include Z - let quomod = ediv_rem - let modulus = erem - let integerRem_t = (mod) - let integerRem_f = Big_int_Z.mod_big_int -end -open Z - -open Either - -(*open Ocaml_implementation*) - - -let simple_fromptr = - false (* false = fromptr is an uninterpreted function for Z3 + the sizeof/_Alignof of - (u)intptr_t and unsigned long are left symbolic *) - - - -let rec simplify_integer_value_base ival_ = - let lifted_self x = - either_case (fun n -> IVconcrete n) (fun z -> z) (simplify_integer_value_base x) in - match ival_ with - | IVunspecified - | IVconcurRead _ -> - Right ival_ - | IVconcrete n -> - Left n - | IVaddress (alloc_id, pref) -> - Right ival_ - | IVfromptr (ty, ity, ptrval, sh) -> - (* TODO *) - Right ival_ - | IVop (iop, [ival_1; ival_2]) -> - let num_op = match iop with - | IntAdd -> - add - | IntSub -> - sub - | IntMul -> - mul - | IntDiv -> - fun x y -> if equal y (of_int 0) then of_int 0 else div x y - | IntRem_t -> - fun x y -> if equal y (of_int 0) then of_int 0 else integerRem_t x y - | IntRem_f -> - fun x y -> if equal y (of_int 0) then of_int 0 else integerRem_f x y - | IntExp -> - fun x y -> pow x (Stdlib.abs (to_int y)) - in - begin match (simplify_integer_value_base ival_1, simplify_integer_value_base ival_2) with - | (Left n1, Left n2) -> - Left (num_op n1 n2) - | (x, y) -> - let f = either_case (fun z -> IVconcrete z) (fun z -> z) in - Right (IVop (iop, [f x; f y])) - end - | IVop _ -> - (* Core type error *) - assert false - | IVmin ity -> - begin match ity with - | Char -> - if (Ocaml_implementation.get()).is_signed_ity Char then - Left (neg (pow (of_int 2) Stdlib.(8-1))) - else - Left (of_int 0) - | Bool - | Size_t -> - (* all of these are unsigned *) - Left (of_int 0) - | Unsigned ibty -> - if not simple_fromptr && (ibty = Long || ibty = Intptr_t) then - Right ival_ - else - (* all of these are unsigned *) - Left (of_int 0) - | Ptrdiff_t -> - (* and all of these are signed *) - begin match (Ocaml_implementation.get()).sizeof_ity ity with - | Some n -> - Left (neg (pow (of_int 2) Stdlib.(8*n-1))) - | None -> - Right ival_ - end - | Ptraddr_t -> - Left (of_int 0) - - | Signed ibty -> - if not simple_fromptr && ibty = Intptr_t then - Right ival_ - else - (* and all of these are signed *) - begin match (Ocaml_implementation.get()).sizeof_ity ity with - | Some n -> - Left (neg (pow (of_int 2) Stdlib.(8*n-1))) - | None -> - Right ival_ - end - | Wchar_t - | Wint_t -> - assert false (* TODO *) - | Enum _ -> - failwith "IVmin Enum" - end - - | IVmax ity -> - if not simple_fromptr - && (ity = Unsigned Long || ity = Unsigned Intptr_t || ity = Signed Intptr_t) then - Right ival_ - else begin match (Ocaml_implementation.get()).sizeof_ity ity with - | Some n -> - let signed_max = - (sub (pow (of_int 2) Stdlib.(8*n-1)) (of_int 1)) in - let unsigned_max = - (sub (pow (of_int 2) Stdlib.(8*n)) (of_int 1)) in - begin match ity with - | Char -> - Left (if (Ocaml_implementation.get()).is_signed_ity Char then - signed_max - else - unsigned_max) - | Bool -> - (* TODO: not sure about this (maybe it should be 1 and not 255? *) - Left unsigned_max - | Size_t - | Unsigned _ -> - Left unsigned_max - | Ptrdiff_t - | Signed _ -> - Left signed_max - | Ptraddr_t -> - Left unsigned_max - | Enum _ -> - failwith "IVmax Enum" - | Wchar_t - | Wint_t -> - assert false (* TODO *) - end - | None -> - Right ival_ - end - - | IVsizeof (Ctype (_, ty)) -> - begin match ty with - | Void -> - (* Ail type error *) - assert false - | Byte -> Left (of_int 1) - | Basic (Integer ity) -> - begin match (Ocaml_implementation.get()).sizeof_ity ity with - | Some n -> - Left (of_int n) - | None -> - prerr_endline (String_core_ctype.string_of_ctype (Ctype ([], ty))); - Right ival_ - end - | Basic (Floating fty) -> - begin match (Ocaml_implementation.get()).sizeof_fty fty with - | Some n -> - Left (of_int n) - | None -> - Right ival_ - end - | Array (elem_ty, None) -> - (* Ail type error *) - assert false - | Array (elem_ty, Some n) -> - simplify_integer_value_base (IVop (IntMul, [IVsizeof elem_ty; IVconcrete n])) - | Function _ - | FunctionNoParams _ -> - (* Ail type error *) - assert false - | Pointer (_, ref_ty) -> - Left (of_int 8) - | Atomic atom_ty -> - simplify_integer_value_base (IVsizeof atom_ty) - | Struct tag_sym -> - let membrs = match Pmap.find tag_sym (Tags.tagDefs ()) with - | _, StructDef (membrs, None) -> - membrs - | _, StructDef (membrs, Some (FlexibleArrayMember (attrs, ident, qs, elem_ty))) -> - membrs @ [(ident, (attrs, None, qs, Ctype ([], Array (elem_ty, None))))] - | _ -> assert false - in - simplify_integer_value_base begin - List.fold_left (fun acc (ident, (_, _, _, ty)) -> - IVop (IntAdd, [lifted_self (IVsizeof ty); IVop (IntAdd, [IVpadding (tag_sym, ident); acc])]) - ) (IVconcrete (of_int 0)) membrs - end - | Union tag_sym -> - (* TODO: clean *) - (* NOTE: the size of a union type is maximum size among its - members PLUS some padding to make it so that the address - just one past the union respect it's own alignment constraint - (i.e. we wan't to be able to have arrays of unions) *) - let membrs = match Pmap.find tag_sym (Tags.tagDefs ()) with - | _, UnionDef membrs -> membrs - | _ -> assert false - in - let align = - match simplify_integer_value_base (IValignof (Ctype ([], Union tag_sym))) with - | Left n -> - n - | Right _ -> - assert false - in - begin match List.map (fun (memb_ident, (_, _, _, ty)) -> - match simplify_integer_value_base (IVsizeof ty) with - | Left n -> - n - | Right _ -> - failwith ("all the types used by members of a union type\ - must have their sizeof constraint specified in\ - the implementation. Please specify _Alignof(" ^ - String_core_ctype.string_of_ctype ty) - ) membrs with - | [] -> assert false - | size::sizes -> - let max_size = List.fold_left (fun acc z -> max z acc) size sizes in - Left (add max_size (sub align (integerRem_f max_size align))) - end - end - | IValignof (Ctype (_, ty)) -> - begin match ty with - | Void -> - (* Ail type error *) - assert false - | Byte -> Left (of_int 1) - | Basic (Integer ity) -> - begin match (Ocaml_implementation.get()).alignof_ity ity with - | Some n -> - Left (of_int n) - | None -> - Right ival_ - end - | Basic (Floating fty) -> - begin match (Ocaml_implementation.get()).alignof_fty fty with - | Some n -> - Left (of_int n) - | None -> - Right ival_ - end - | Array (elem_ty, _) -> - simplify_integer_value_base (IValignof elem_ty) - | Function _ - | FunctionNoParams _ -> - (* Ail type error *) - assert false - | Pointer (_, ref_ty) -> - Left (of_int 8) - | Atomic atom_ty -> - simplify_integer_value_base (IValignof atom_ty) - | Struct tag_sym -> - (* This is done in Smt, because we need to actually generate constraints *) - Right ival_ - | Union tag_sym -> - (* NOTE: these two partial patterns are ok by typing of Ail *) - let membrs = match Pmap.find tag_sym (Tags.tagDefs ()) with - | _, UnionDef membrs -> membrs - | _ -> assert false - in - begin match List.map (fun (memb_ident, (_, align_opt, _, ty)) -> - let align_iv = - match align_opt with - | None -> - IValignof ty - | Some (AlignInteger al_n) -> - IVconcrete al_n - | Some (AlignType al_ty) -> - IValignof al_ty in - match simplify_integer_value_base align_iv with - | Left n -> - n - | Right _ -> - failwith ("all the types used by members of a union type\ - must have their alignment constraint specified in\ - the implementation. Please specify _Alignof(" ^ - String_core_ctype.string_of_ctype ty) - ) membrs with - | [] -> assert false - | (n::ns) -> - (* NOTE: the alignment constraint of a union type is the largest - alignment constraint of any of its member *) - Left (List.fold_left (fun acc z -> max z acc) n ns) - end - end - | IVoffsetof (tag_sym, memb_ident) -> - failwith "simplify_integer_value: IVoffsetof" - | IVpadding _ -> - Right ival_ - | IVptrdiff (ty, ptrval1, ptrval2) -> - (* TODO: check *) - Right ival_ - - | IVbyteof (ival_, mval) -> - begin match (ival_, mval) with - | (IVconcrete n, MVcomposite (xs, mval')) -> - let pred = function - | IVconcrete n' when n = n' -> true - | _ -> false in - begin match List.find_opt (fun (z, _) -> pred z) xs with - | Some (_, IV (_, ival_')) -> - simplify_integer_value_base ival_' - | None -> - failwith "Mem_simplify, IVbyteof ==> need to look inside a MVcomposite" - end - | _ -> - failwith ("Mem_simplify, IVbyteof ==> " ^ - String_defacto_memory.string_of_integer_value (IV (Prov_none, ival_)) ^ - " -- " ^ String_defacto_memory.string_of_mem_value mval) - - end -(* - (* TODO/NOTE: assuming little endian two's complement encoding *) -*) -(* -let byteof i n = let n' = n `div` (2 ^ (i * 8)) in mod n' 256 -*) - - - - | IVcomposite _ -> - failwith "simplify_integer_value: IVcomposite" - | IVbitwise (ity, BW_complement ival_1) -> - begin match ((Ocaml_implementation.get()).sizeof_ity ity, simplify_integer_value_base ival_1) with - | (Some width, Left n1) -> - Left (Defacto_memory_aux.tmp_compl width n1) - | (_, x) -> - let f = either_case (fun z -> IVconcrete z) (fun z -> z) in - Right (IVbitwise (ity, BW_complement (f x))) - end - | IVbitwise (ity, BW_AND (ival_1, ival_2)) -> - begin match (simplify_integer_value_base ival_1, simplify_integer_value_base ival_2) with - | (Left n1, Left n2) -> - Left (Z.logand n1 n2) - | (x, y) -> - let f = either_case (fun z -> IVconcrete z) (fun z -> z) in - Right (IVbitwise (ity, BW_AND (f x, f y))) - end - | IVbitwise (ity, BW_OR (ival_1, ival_2)) -> - begin match (simplify_integer_value_base ival_1, simplify_integer_value_base ival_2) with - | (Left n1, Left n2) -> - Left (Z.logor n1 n2) - | (x, y) -> - let f = either_case (fun z -> IVconcrete z) (fun z -> z) in - Right (IVbitwise (ity, BW_OR (f x, f y))) - end - | IVbitwise (ity, BW_XOR (ival_1, ival_2)) -> - begin match (simplify_integer_value_base ival_1, simplify_integer_value_base ival_2) with - | (Left n1, Left n2) -> - Left (Z.logxor n1 n2) - | (x, y) -> - let f = either_case (fun z -> IVconcrete z) (fun z -> z) in - Right (IVbitwise (ity, BW_XOR (f x, f y))) - end - - -let lifted_simplify_integer_value_base ival_ = - Either.either_case - (fun n -> IVconcrete n) - (fun z -> z) - (simplify_integer_value_base ival_) - - -let simplify_integer_value (IV (prov, ival_)) : (Z.t, impl_integer_value) either = - match simplify_integer_value_base ival_ with - | Left n -> - Left n - | Right ival_' -> - Right (IV (prov, ival_')) - - - -(* -let simplify_mem_constraint constr = - let lift = either_case (fun z -> (IV (Prov_none, IVconcrete z))) (fun z -> z) in - let simplify_binary acc op ival_1 ival_2 = - begin match (simplify_integer_value ival_1, simplify_integer_value ival_2) with - | (Left n1, Left n2) -> - if n1 = n2 then - Some acc - else - None - | (x, y) -> - Some (MC_eq (lift x, lift y) :: acc) - end in - let rec aux _acc constr = - match _acc with - | None -> - None - | Some acc -> - begin match constr with - | MC_empty -> - _acc - | MC_eq (ival_1, ival_2) -> - simplify_binary acc (=) ival_1 ival_2 - | MC_le (ival_1, ival_2) -> - simplify_binary acc (<=) ival_1 ival_2 - | MC_lt (ival_1, ival_2) -> - simplify_binary acc (<) ival_1 ival_2 - | MC_or (constr1, constr2) -> - begin match (aux (Some []) constr1, aux (Some []) constr2) with - | (None, Some cs) - | (Some cs, None) -> - Some (cs @ acc) - | (None, None) -> - None - | (Some cs1, Some cs2) -> - Some (MC_or (MC_conj cs1, MC_conj cs2) :: acc) - end - | MC_conj constrs -> - List.fold_left aux _acc constrs - | MC_not _ -> - (* TODO *) - Some (constr :: acc) - end - in - match aux (Some []) constr with - | None -> - MC_empty - | Some constrs -> - MC_conj constrs - - -*) diff --git a/memory/vip/common.ml b/memory/vip/common.ml index 54ab77d51..dec01c6bb 100644 --- a/memory/vip/common.ml +++ b/memory/vip/common.ml @@ -7,8 +7,8 @@ let ident_equal x y = let offsetsof = Ocaml_implementation.offsetsof (* TODO(state-removal) *) -let sizeof ?(tagDefs= Tags.tagDefs ()) ty = Ocaml_implementation.sizeof tagDefs ty -let alignof ?(tagDefs= Tags.tagDefs ()) ty = Ocaml_implementation.alignof tagDefs ty +let sizeof ~tagDefs ty = Ocaml_implementation.sizeof tagDefs ty +let alignof ~tagDefs ty = Ocaml_implementation.alignof tagDefs ty let ity_max ity = let open Z in diff --git a/memory/vip/impl_mem.ml b/memory/vip/impl_mem.ml index b2ce27c70..ae8b66ef4 100644 --- a/memory/vip/impl_mem.ml +++ b/memory/vip/impl_mem.ml @@ -170,15 +170,19 @@ type mem_state = { (* Web user-interface stuff *) last_used: allocation_id option; + + (* READONLY (TODO: move this to the config part when the monad is changed) *) + tagDefs: Ctype.tag_definitions; } [@@warning "-unused-field"] -let initial_mem_state: mem_state = +let initial_mem_state tagDefs: mem_state = { allocations= IntMap.empty ; bytemap= IntMap.empty ; funptrmap= IntMap.empty ; next_alloc_id= Z.zero ; last_address= Z.of_int 0xFFFFFFFFFFFF - ; last_used= None } + ; last_used= None + ; tagDefs } type 'a memM = ('a, string, MC.mem_error, integer_value MC.mem_constraint, mem_state) Nondeterminism.ndM @@ -243,9 +247,9 @@ let lookup_alloc alloc_id : allocation memM = return alloc (* [a .. a + sizeof(ty) − 1] ⊆ [a_i .. a_i + n_1 - 1] *) -let check_bounds addr ty alloc = +let check_bounds ~tagDefs addr ty alloc = Z.leq alloc.base addr -&& Z.leq (Z.add addr (Z.pred (Common.sizeof ty))) +&& Z.leq (Z.add addr (Z.pred (Common.sizeof ~tagDefs ty))) (Z.add alloc.base (Z.pred alloc.length)) @@ -306,12 +310,13 @@ end else Some (char_of_int (Z.to_int (Z.extract i (8*n) 8))) ) -let rec repr funptrmap mval : ((Digest.t * string) IntMap.t * AbsByte.t list) = +let rec repr ~tagDefs funptrmap mval : ((Digest.t * string) IntMap.t * AbsByte.t list) = + let repr = repr ~tagDefs in let ret bs = (funptrmap, bs) in match mval with | MVunspecified ty -> (* TODO(fix-Overflow) *) - let sz = Z.to_int (Common.sizeof ty) in + let sz = Z.to_int (Common.sizeof ~tagDefs ty) in ret @@ List.init sz (fun _ -> AbsByte.{prov= Prov_empty; value= None; ptrfrag_idx= None}) | MVinteger (ity, ival) -> @@ -374,28 +379,28 @@ let rec repr funptrmap mval : ((Digest.t * string) IntMap.t * AbsByte.t list) = (funptrmap, L.concat @@ List.rev bs_s) | MVstruct (tag_sym, xs) -> let padding_byte _ = AbsByte.{prov= Prov_empty; value= None; ptrfrag_idx= None} in - let (offs, last_off) = Common.offsetsof (Tags.tagDefs ()) tag_sym in - let sz = Common.sizeof (Ctype ([], Struct tag_sym)) in + let (offs, last_off) = Common.offsetsof tagDefs tag_sym in + let sz = Common.sizeof ~tagDefs (Ctype ([], Struct tag_sym)) in (* TODO(fix-Overflow) *) let final_pad = Z.(to_int (sz - last_off)) in let (funptrmap, _, bs) = List.fold_left2 begin fun (funptrmap, last_off, acc) (ident, ty, off) (_, _, mval) -> (* TODO(fix-Overflow) *) let pad = Z.(to_int (off - last_off)) in let (funptrmap, bs) = repr funptrmap mval in - (funptrmap, Z.add off (Common.sizeof ty), acc @ List.init pad padding_byte @ bs) + (funptrmap, Z.add off (Common.sizeof ~tagDefs ty), acc @ List.init pad padding_byte @ bs) end (funptrmap, Z.zero, []) offs xs in (funptrmap, bs @ List.init final_pad padding_byte) | MVunion (tag_sym, memb_ident, mval) -> let padding_byte _ = AbsByte.{prov= Prov_empty; value= None; ptrfrag_idx= None} in (* TODO(fix-Overflow) *) - let size = Z.to_int (Common.sizeof (Ctype ([], Union tag_sym))) in + let size = Z.to_int (Common.sizeof ~tagDefs (Ctype ([], Union tag_sym))) in let (funptrmap', bs) = repr funptrmap mval in (funptrmap', bs @ List.init (size - List.length bs) padding_byte) -let rec abst (*allocations*) (*funptrmap*) (Ctype (_, ty) as cty) (bs : AbsByte.t list) : mem_value * AbsByte.t list = -let self ty bs = abst (*allocations*) ty bs in +let rec abst ~tagDefs (*allocations*) (*funptrmap*) (Ctype (_, ty) as cty) (bs : AbsByte.t list) : mem_value * AbsByte.t list = +let self ty bs = abst ~tagDefs (*allocations*) ty bs in let interp_bytes xs : [ `SPECIFIED of [ `PROV of allocation_id | `NOPROV ] * [ `PROV2 of allocation_id | `NOPROV2 ] * char list @@ -443,7 +448,7 @@ let interp_bytes xs : [ `SPECIFIED of [ `PROV of allocation_id | `NOPROV ] `INVALID_PTRFRAG in `SPECIFIED (prov_status', prov2_status', c :: cs, ptrfrag_status') ) (`SPECIFIED (`NOPROV, `NOPROV2, [], `VALID_PTRFRAG 0)) (List.rev xs) in -let cty_sz = Common.sizeof cty in +let cty_sz = Common.sizeof ~tagDefs cty in if Z.lt (Z.of_int (List.length bs)) cty_sz then failwith "INTERNAL ERROR: Vip.abst, |bs| < sizeof(ty)"; match ty with @@ -553,8 +558,8 @@ match ty with (* TODO(fix-Overflow) *) let pad = Z.(to_int (memb_offset - previous_offset)) in let (mval, acc_bs') = self memb_ty (L.drop pad acc_bs) in - ((memb_ident, memb_ty, mval)::acc_xs, Z.(memb_offset + (Common.sizeof memb_ty)), acc_bs') - ) ([], Z.zero, bs1) (fst (Common.offsetsof (Tags.tagDefs ()) tag_sym)) in + ((memb_ident, memb_ty, mval)::acc_xs, Z.(memb_offset + (Common.sizeof ~tagDefs memb_ty)), acc_bs') + ) ([], Z.zero, bs1) (fst (Common.offsetsof tagDefs tag_sym)) in (* TODO: check that bs' = last padding of the struct *) (MVstruct (tag_sym, List.rev rev_xs), bs2) | Union tag_sym -> @@ -567,14 +572,16 @@ let in_bounds addr alloc = let allocate_object tid prefix al_ival ty _ init_opt : pointer_value memM = - let n = Common.sizeof ty in + get >>= fun st -> + let tagDefs = st.tagDefs in + let n = Common.sizeof ~tagDefs ty in allocator n (ival_to_int al_ival) >>= fun (alloc_id, addr) -> let init_mval = match init_opt with | None -> MVunspecified ty | Some mval -> mval in update (fun st -> - let (funptrmap, pre_bs) = repr st.funptrmap init_mval in + let (funptrmap, pre_bs) = repr ~tagDefs st.funptrmap init_mval in let bs = List.mapi (fun i b -> (Z.add addr (Z.of_int i), b)) pre_bs in { st with allocations= IntMap.add alloc_id {base= addr; length= n; killed= false; ty; prefix} st.allocations; @@ -610,6 +617,8 @@ let kill loc is_dyn ptrval : unit memM = let load loc ty ptrval : (footprint * mem_value) memM = + get >>= fun st -> + let tagDefs = st.tagDefs in match ptrval with | PVnull -> fail ~loc (MerrAccess (LoadAccess, NullPtr)) @@ -619,20 +628,22 @@ let load loc ty ptrval : (footprint * mem_value) memM = lookup_alloc alloc_id >>= fun alloc -> if alloc.killed then fail ~loc (MerrAccess (LoadAccess, DeadPtr)) - else if not (check_bounds addr ty alloc) then + else if not (check_bounds ~tagDefs addr ty alloc) then fail ~loc (MerrAccess (LoadAccess, OutOfBoundPtr)) else get >>= fun st -> put { st with last_used= Some alloc_id } >>= fun () -> (* TODO(fix-Overflow) *) - let sz = Z.to_int (Common.sizeof ty) in + let sz = Z.to_int (Common.sizeof ~tagDefs ty) in let bs = fetch_bytes st.bytemap addr sz in - return (FOOTPRINT, fst (abst (*st.allocations*) ty bs)) + return (FOOTPRINT, fst (abst ~tagDefs (*st.allocations*) ty bs)) | PVfunptr _ -> fail ~loc (MerrAccess (LoadAccess, FunctionPtr)) let store loc ty is_locking ptrval mval : footprint memM = + get >>= fun st -> + let tagDefs = st.tagDefs in match ptrval with | PVnull -> fail ~loc (MerrAccess (StoreAccess, NullPtr)) @@ -642,11 +653,11 @@ let store loc ty is_locking ptrval mval : footprint memM = lookup_alloc alloc_id >>= fun alloc -> if alloc.killed then fail ~loc (MerrAccess (StoreAccess, DeadPtr)) - else if not (check_bounds addr ty alloc) then + else if not (check_bounds ~tagDefs addr ty alloc) then fail ~loc (MerrAccess (StoreAccess, OutOfBoundPtr)) else update begin fun st -> - let (funptrmap, pre_bs) = repr st.funptrmap mval in + let (funptrmap, pre_bs) = repr ~tagDefs st.funptrmap mval in let bs = List.mapi (fun i b -> (Z.add addr (Z.of_int i), b)) pre_bs in { st with last_used= Some alloc_id; bytemap= @@ -730,6 +741,8 @@ let ge_ptrval loc ptrval1 ptrval2 : bool memM = rel_op_ptrval loc Z.geq ptrval1 ptrval2 let diff_ptrval loc diff_ty ptrval1 ptrval2 : integer_value memM = + get >>= fun st -> + let tagDefs = st.tagDefs in match ptrval1, ptrval2 with | PVloc (Prov_some alloc_id1, addr1) , PVloc (Prov_some alloc_id2, addr2) when Z.equal alloc_id1 alloc_id2 -> @@ -743,7 +756,7 @@ let diff_ptrval loc diff_ty ptrval1 ptrval2 : integer_value memM = elem_ty | _ -> diff_ty in - return (IVint (Z.div (Z.sub addr1 addr2) (Common.sizeof diff_ty'))) + return (IVint (Z.div (Z.sub addr1 addr2) (Common.sizeof ~tagDefs diff_ty'))) else fail ~loc (MerrVIP VIP_diffptr_out_of_bound) | _ -> @@ -753,10 +766,12 @@ let update_prefix: (Symbol.prefix * mem_value) -> unit memM = fun _ -> (* TODO: VIP.update_prefix isn't doing anything *) return () -let prefix_of_pointer: pointer_value -> string option memM = +let prefix_of_pointer _ : pointer_value -> string option memM = fun _ -> return None (* TODO *) let isWellAligned_ptrval ref_ty ptrval = + get >>= fun st -> + let tagDefs = st.tagDefs in (* TODO: catch builtin function types *) match unatomic_ ref_ty with | Void @@ -767,7 +782,7 @@ let isWellAligned_ptrval ref_ty ptrval = | PVnull -> return true | PVloc (_, addr) -> - return (Z.(equal (modulus addr (Common.alignof ref_ty)) zero)) + return (Z.(equal (modulus addr (Common.alignof ~tagDefs ref_ty)) zero)) | PVfunptr _ -> fail (MerrOther "called isWellAligned_ptrval on function pointer") end @@ -864,20 +879,19 @@ let intcast _ _ ival = Either.Right ival (* Pointer shifting constructors *) -let array_shift_ptrval ptrval ty ival : pointer_value = +let array_shift_ptrval tagDefs loc ptrval ty ival : pointer_value Undefined.t0 = (* TODO: "VIP memory model should be called SWITCH strict_pointer_arith" *) match ptrval with | PVnull -> - (* TODO *) - failwith "UB: array_offset ==> NULL" + Undefined.(undef loc [UB046_array_pointer_outside]) | PVloc (Prov_empty, _) -> (* TODO *) - failwith "UB: array_offset ==> @empty" + Undefined.(undef loc [UB046_array_pointer_outside]) | PVloc (Prov_some alloc_id, addr) -> (* lookup_alloc alloc_id >>= fun alloc -> *) (* As a GNU extension ty may be void, in which case the pointer arithmetic is performed at the byte granularity *) - let sz = if AilTypesAux.is_void ty then Z.one else Common.sizeof ty in + let sz = if AilTypesAux.is_void ty then Z.one else Common.sizeof ~tagDefs ty in let addr' = Z.(add addr (mul (ival_to_int ival) sz)) in (* TODO *) (* if alloc.killed then @@ -886,10 +900,9 @@ let array_shift_ptrval ptrval ty ival : pointer_value = failwith "TODO UB, array_offset ==> out-of-bound" else *) (* TODO: hack *) - PVloc (Prov_some alloc_id, addr') + Undefined.return0 (PVloc (Prov_some alloc_id, addr')) | PVfunptr sym -> - (* TODO *) - failwith "UB: array_offset ==> funptr" + Undefined.(undef loc [UB046_array_pointer_outside]) let offsetof_ival tagDefs tag_sym membr_ident = let (xs, _) = Common.offsetsof tagDefs tag_sym in @@ -902,7 +915,7 @@ let offsetof_ival tagDefs tag_sym membr_ident = (* NOTE: this is an internal error *) failwith "VIP.offsetof_ival: invalid membr_ident" -let member_shift_ptrval ptrval tag_sym membr_ident : pointer_value = +let member_shift_ptrval tagDefs ptrval tag_sym membr_ident : pointer_value = (* TODO: need an effectful variant in the interface to have the errors inside the monad *) match ptrval with | PVnull -> @@ -910,10 +923,10 @@ let member_shift_ptrval ptrval tag_sym membr_ident : pointer_value = | PVloc (Prov_empty, _) -> failwith "UB: member_offset ==> @empty" | PVloc (Prov_some alloc_id, addr) -> - let addr' = Z.(add addr (ival_to_int (offsetof_ival (Tags.tagDefs ()) tag_sym membr_ident))) in + let addr' = Z.(add addr (ival_to_int (offsetof_ival tagDefs tag_sym membr_ident))) in PVloc (Prov_some alloc_id, addr') (* lookup_alloc alloc_id >>= fun alloc -> - let addr' = Z.add addr (Z.of_int (Common.sizeof ty)) in + let addr' = Z.add addr (Z.of_int (Common.sizeof ~tagDefs ty)) in if alloc.killed then failwith "TODO UB, member_offset ==> killed" else if not (in_bounds addr' alloc) then @@ -924,6 +937,8 @@ let member_shift_ptrval ptrval tag_sym membr_ident : pointer_value = failwith "UB: member_offset ==> funptr" let eff_array_shift_ptrval loc ptrval ty ival : pointer_value memM = + get >>= fun st -> + let tagDefs = st.tagDefs in match ptrval with | PVnull -> fail (MerrVIP (VIP_array_shift VIP_null)) @@ -931,7 +946,7 @@ let eff_array_shift_ptrval loc ptrval ty ival : pointer_value memM = fail (MerrVIP (VIP_array_shift VIP_empty)) | PVloc (Prov_some alloc_id, addr) -> lookup_alloc alloc_id >>= fun alloc -> - let addr' = Z.(add addr (mul (ival_to_int ival) (Common.sizeof ty))) in + let addr' = Z.(add addr (mul (ival_to_int ival) (Common.sizeof ~tagDefs ty))) in if not (in_bounds addr' alloc) then fail (MerrVIP (VIP_array_shift VIP_out_of_bound)) else @@ -940,23 +955,28 @@ let eff_array_shift_ptrval loc ptrval ty ival : pointer_value memM = fail (MerrVIP (VIP_array_shift VIP_funptr)) let eff_member_shift_ptrval _ tag_sym membr_ident ptrval = - return (member_shift_ptrval tag_sym membr_ident ptrval) + get >>= fun st -> + return (member_shift_ptrval st.tagDefs tag_sym membr_ident ptrval) let memcpy loc ptrval1 ptrval2 sz_ival : pointer_value memM = + get >>= fun st -> let sz = ival_to_int sz_ival in (* TODO: if ptrval1 and ptrval2 overlap ==> UB *) (* TODO: copy ptrval2 into ptrval1 *) (* NOTE: we are using the pure array_shift because if we go out of bound there is a UB right away *) let rec aux i = if Z.lt i sz then - load loc Ctype.unsigned_char (array_shift_ptrval ptrval2 Ctype.unsigned_char (IVint i)) >>= fun (_, mval) -> - store loc Ctype.unsigned_char false (array_shift_ptrval ptrval1 Ctype.unsigned_char (IVint i)) mval >>= fun _ -> + Nondeterminism.lift_undef (array_shift_ptrval st.tagDefs loc ptrval1 Ctype.unsigned_char (IVint i)) >>= fun ptrval1' -> + Nondeterminism.lift_undef (array_shift_ptrval st.tagDefs loc ptrval2 Ctype.unsigned_char (IVint i)) >>= fun ptrval2' -> + load loc Ctype.unsigned_char ptrval2' >>= fun (_, mval) -> + store loc Ctype.unsigned_char false ptrval1' mval >>= fun _ -> aux (Z.succ i) else return ptrval1 in aux Z.zero -let memcmp ptrval1 ptrval2 sz_ival : integer_value memM = +let memcmp loc ptrval1 ptrval2 sz_ival : integer_value memM = + get >>= fun st -> let size_n = ival_to_int sz_ival in let rec get_bytes ptrval acc = function | 0 -> @@ -964,7 +984,7 @@ let memcmp ptrval1 ptrval2 sz_ival : integer_value memM = | size -> load Cerb_location.unknown Ctype.unsigned_char ptrval >>= function | (_, MVinteger (_, byte_ival)) -> - let ptr' = array_shift_ptrval ptrval Ctype.unsigned_char (IVint Z.one) in + Nondeterminism.lift_undef (array_shift_ptrval st.tagDefs loc ptrval Ctype.unsigned_char (IVint Z.one)) >>= fun ptr' -> get_bytes ptr' (ival_to_int byte_ival :: acc) (size-1) | _ -> assert false in @@ -1052,9 +1072,6 @@ let op_ival op ival1 ival2 : integer_value = | IntExp -> fun x y -> Z.pow x (Z.to_int y) in IVint (op (ival_to_int ival1) (ival_to_int ival2)) -let sizeof_ival ty = IVint (Common.sizeof ty) -let alignof_ival ty = IVint (Common.alignof ty) - let bitwise_complement_ival _ ival = IVint (Z.(sub (neg (ival_to_int ival)) one)) let bitwise_and_ival _ ival1 ival2 = @@ -1337,7 +1354,7 @@ let rec mk_ui_values st bs ty mval : ui_value list = let mk_ui_values = mk_ui_values st in let mk_scalar kind v p bs_opt = (* TODO(fix-Overflow) *) - let size = Z.to_int (Common.sizeof ty) in + let size = Z.to_int (Common.sizeof ~tagDefs:st.tagDefs ty) in [{ kind; size; path = []; value = v; prov = p; typ = Some ty; bytes = bs_opt }] in let mk_pad n v = @@ -1377,7 +1394,7 @@ let rec mk_ui_values st bs ty mval : ui_value list = | Ctype (_, Array (elem_ty, _)) -> (* the Z.to_int on the sizeof() will raise Overflow on huge structs/unions *) (* TODO(fix-Overflow) *) - let size = Z.to_int (Common.sizeof elem_ty) in + let size = Z.to_int (Common.sizeof ~tagDefs:st.tagDefs elem_ty) in let (rev_rows, _, _) = List.fold_left begin fun (acc, i, acc_bs) mval -> let row = List.map (add_path (string_of_int i)) @@ mk_ui_values acc_bs elem_ty mval in (row::acc, i+1, L.drop size acc_bs) @@ -1391,19 +1408,19 @@ let rec mk_ui_values st bs ty mval : ui_value list = (* NOTE: we recombine the bytes to get paddings *) (* the Z.to_int on the sizeof() will raise Overflow on huge structs *) (* TODO(fix-Overflow) *) - let size = Z.to_int (Common.sizeof ty) in + let size = Z.to_int (Common.sizeof ~tagDefs:st.tagDefs ty) in let (bs1, bs2) = L.split_at size bs in let (rev_rowss, _, bs') = List.fold_left begin fun (acc_rowss, previous_offset, acc_bs) (Symbol.Identifier (_, memb), memb_ty, memb_offset) -> let pad = to_int (sub memb_offset previous_offset) in let acc_bs' = L.drop pad acc_bs in - let (mval, acc_bs'') = abst memb_ty acc_bs' in + let (mval, acc_bs'') = abst ~tagDefs:st.tagDefs memb_ty acc_bs' in let rows = mk_ui_values acc_bs' memb_ty mval in let rows' = List.map (add_path memb) rows in (* TODO: set padding value here *) let rows'' = if Int.(pad = 0) then rows' else mk_pad pad "" :: rows' in - (rows''::acc_rowss, Z.add memb_offset (Common.sizeof memb_ty), acc_bs'') - end ([], Z.zero, bs1) (fst (Common.offsetsof (Tags.tagDefs ()) tag_sym)) + (rows''::acc_rowss, Z.add memb_offset (Common.sizeof ~tagDefs:st.tagDefs memb_ty), acc_bs'') + end ([], Z.zero, bs1) (fst (Common.offsetsof st.tagDefs tag_sym)) in List.concat (List.rev rev_rowss) | MVunion (tag_sym, Symbol.Identifier (_, memb), mval) -> List.map (add_path memb) (mk_ui_values bs ty mval) (* FIXME: THE TYPE IS WRONG *) @@ -1412,7 +1429,7 @@ let mk_ui_alloc st id (alloc: allocation) : ui_alloc = (* let ty = match alloc.ty with Some ty -> ty | None -> Ctype ([], Array (Ctype ([], Basic (Integer Char)), Some alloc.length)) in *) let length = Z.to_int alloc.length in let bs = fetch_bytes st.bytemap alloc.base length in - let (mval, _) = abst alloc.ty bs in + let (mval, _) = abst ~tagDefs:st.tagDefs alloc.ty bs in { id; base = Z.to_string alloc.base; diff --git a/ocaml_frontend/dune b/ocaml_frontend/dune index b3ca5e653..2b745506b 100644 --- a/ocaml_frontend/dune +++ b/ocaml_frontend/dune @@ -5,7 +5,7 @@ (public_name cerberus-lib.frontend) (synopsis "Cerberus frontend") (flags (:standard -w @8@11@12-9-27-33-67)) - (modules :standard \ pp_naive_memory pp_symbolic pp_constraints pp_cmm pp_sb) + (modules :standard \ pp_sb) (virtual_modules impl_mem) (libraries unix lem monomorphic pprint cerb_util sibylfs)) diff --git a/ocaml_frontend/memory_model.ml b/ocaml_frontend/memory_model.ml index 285c1328c..b836a433d 100644 --- a/ocaml_frontend/memory_model.ml +++ b/ocaml_frontend/memory_model.ml @@ -36,7 +36,7 @@ module type Memory = sig val overlapping: footprint -> footprint -> bool type mem_state - val initial_mem_state: mem_state + val initial_mem_state: Ctype.tag_definitions -> mem_state type 'a memM = ('a, string, Mem_common.mem_error, integer_value Mem_common.mem_constraint, mem_state) Nondeterminism.ndM @@ -88,7 +88,10 @@ module type Memory = sig val diff_ptrval: Cerb_location.t -> Ctype.ctype -> pointer_value -> pointer_value -> integer_value memM val update_prefix: (Symbol.prefix * mem_value) -> unit memM - val prefix_of_pointer: pointer_value -> string option memM + val prefix_of_pointer: + Ctype.tag_definitions -> + pointer_value -> + string option memM val validForDeref_ptrval: Ctype.ctype -> pointer_value -> bool memM val isWellAligned_ptrval: Ctype.ctype -> pointer_value -> bool memM @@ -106,14 +109,19 @@ module type Memory = sig val null_cap : bool(* is_signed *) -> integer_value (* Pointer shifting constructors *) - val array_shift_ptrval: pointer_value -> Ctype.ctype -> integer_value -> pointer_value - val member_shift_ptrval: pointer_value -> Symbol.sym -> Symbol.identifier -> pointer_value + val array_shift_ptrval: + Ctype.tag_definitions -> + Cerb_location.t -> pointer_value -> Ctype.ctype -> integer_value -> + pointer_value Undefined.t0 + val member_shift_ptrval: + Ctype.tag_definitions -> + pointer_value -> Symbol.sym -> Symbol.identifier -> pointer_value val eff_array_shift_ptrval: Cerb_location.t -> pointer_value -> Ctype.ctype -> integer_value -> pointer_value memM val eff_member_shift_ptrval: Cerb_location.t -> pointer_value -> Symbol.sym -> Symbol.identifier -> pointer_value memM val memcpy: Cerb_location.t -> pointer_value -> pointer_value -> integer_value -> pointer_value memM - val memcmp: pointer_value -> pointer_value -> integer_value -> integer_value memM + val memcmp: Cerb_location.t -> pointer_value -> pointer_value -> integer_value -> integer_value memM val realloc: Cerb_location.t -> Mem_common.thread_id -> integer_value -> pointer_value -> integer_value -> pointer_value memM val va_start: (Ctype.ctype * pointer_value) list -> integer_value memM @@ -135,7 +143,7 @@ module type Memory = sig val max_ival: Ctype.integerType -> integer_value val min_ival: Ctype.integerType -> integer_value val op_ival: Mem_common.integer_operator -> integer_value -> integer_value -> integer_value - val offsetof_ival: (Symbol.sym, Cerb_location.t * Ctype.tag_definition) Pmap.map -> Symbol.sym -> Symbol.identifier -> integer_value + val offsetof_ival: Ctype.tag_definitions -> Symbol.sym -> Symbol.identifier -> integer_value val bitwise_complement_ival: Ctype.integerType -> integer_value -> integer_value val bitwise_and_ival: Ctype.integerType -> integer_value -> integer_value -> integer_value @@ -176,7 +184,6 @@ module type Memory = sig (* Memory value constructors *) - (*symbolic_mval: Symbolic.symbolic mem_value pointer_value -> mem_value *) val unspecified_mval: Ctype.ctype -> mem_value val integer_value_mval: Ctype.integerType -> integer_value -> mem_value val floating_value_mval: Ctype.floatingType -> floating_value -> mem_value diff --git a/ocaml_frontend/milicore.ml b/ocaml_frontend/milicore.ml index 686aec52d..4fc8c3c6b 100644 --- a/ocaml_frontend/milicore.ml +++ b/ocaml_frontend/milicore.ml @@ -30,7 +30,7 @@ type mi_funinfo = (Symbol.sym, (Cerb_location.t * Annot.attributes * Ctype.ctype (* a Core file is just a set of named functions *) type ('a, 'TY) mi_file = { mi_main : symbol option; - mi_tagDefs : Core.core_tag_definitions; + mi_tagDefs : Ctype.tag_definitions; mi_stdlib : 'TY mi_fun_map; mi_impl : 'TY Core.generic_impl; mi_globs : (Symbol.sym * ('a, 'TY) Core.generic_globs) list; diff --git a/ocaml_frontend/ocaml_implementation.ml b/ocaml_frontend/ocaml_implementation.ml index b4d77cbb0..3d333242f 100644 --- a/ocaml_frontend/ocaml_implementation.ml +++ b/ocaml_frontend/ocaml_implementation.ml @@ -563,7 +563,7 @@ and alignof tagDefs (Ctype (_, ty)) : Z.t = ) init membrs end | Union tag_sym -> - begin match Pmap.find tag_sym (Tags.tagDefs ()) with + begin match Pmap.find tag_sym tagDefs with | _, StructDef _ -> assert false | _, UnionDef membrs -> (* NOTE: Structs (and unions) alignment is that of the maximum alignment diff --git a/ocaml_frontend/pprinters/pp_cmm.ml b/ocaml_frontend/pprinters/pp_cmm.ml deleted file mode 100644 index dd245af10..000000000 --- a/ocaml_frontend/pprinters/pp_cmm.ml +++ /dev/null @@ -1,220 +0,0 @@ -open Cmm_csem - - -(* -let pp_constraints (Constraints.Constraints asserts) = - let pp x = Boot_pprint.to_plain_string (Pp_core.pp_symbolic x) in - List.fold_left (fun acc eq -> - (match eq with - | Constraints.Assert_eq (symb1, symb2) -> - pp symb1 ^ " = " ^ pp symb2 - | Constraints.Assert_neq (symb1, symb2) -> - pp symb1 ^ " /= " ^ pp symb2 - | Constraints.Assert_lt (symb1, symb2) -> - pp symb1 ^ " < " ^ pp symb2 - | Constraints.Assert_ge (symb1, symb2) -> - pp symb1 ^ " >= " ^ pp symb2 - ) ^ ";\\n" ^ acc - ) "" asserts -*) - -(* -let pp_constraints (Smt_wrapper.Assertions (_, xs)) = - String.concat ";\n" xs -*) - -open Constraints -let pp_old_constraints (Constraints xs) = - let strs = List.map (fun z -> Pp_utils.to_plain_string (Pp_symbolic.pp_symbolic Pp_core.pp_object_value Pp_mem.pp_pointer_value z)) xs in - "[" ^ String.concat ", " strs ^ "]" - - - -let string_of_memory_order = function - | NA -> - "na" - | Seq_cst -> - "sc" - | Relaxed -> - "rlx" - | Release -> - "rel" - | Acquire -> - "acq" - | Consume -> - "cons" - | Acq_rel -> - "acq_rel" - - -let string_of_location ptr_val = Pp_utils.to_plain_string (Pp_mem.pp_pretty_pointer_value ptr_val) -let string_of_cvalue mval = Pp_utils.to_plain_string (Pp_mem.pp_pretty_mem_value ~use_upper:false mval) - - -let string_of_action_aux = function - | Lock (aid, tid, loc, lock) -> - Printf.sprintf "Lock[%d]" aid - | Unlock (aid, tid, loc) -> - Printf.sprintf "Unlock[%d]" aid - | Load (aid, tid, mo, loc, v) -> - Printf.sprintf "%d: R_{%s} %s = %s" - aid - (string_of_memory_order mo) - (string_of_location loc) - (string_of_cvalue v) - - | Store (aid, tid, mo, loc, v) -> - Printf.sprintf "%d: W_{%s} %s := %s" - aid - (string_of_memory_order mo) - (string_of_location loc) - (string_of_cvalue v) - - | RMW (aid, tid, mo, loc, v1, v2) -> - Printf.sprintf "RMW[%d]" aid - | Fence (aid, tid, mo) -> - Printf.sprintf "Fence[%d]" aid - | Blocked_rmw (aid, tid, loc) -> - Printf.sprintf "Blocked_rmw[%d]" aid - | Alloc (aid, tid, loc) -> - Printf.sprintf "%d: Create %s" - aid - (string_of_location loc) - - | Dealloc (aid, tid, loc) -> - Printf.sprintf "Dealloc[%d]" aid - -let string_of_action act = String.escaped (string_of_action_aux act) - - -let string_of_pre_execution preEx = - let str = - Printf.sprintf "actions= {%s};\n" (Pset.fold (fun act acc -> string_of_action act ^ ", " ^ acc) preEx.actions "") ^ - Printf.sprintf "sb= %s;\n" (Pset.fold (fun (act1, act2) acc -> "(" ^ string_of_action act1 ^ ", " ^ - string_of_action act2 ^ " ), " ^ acc) preEx.sb "") ^ - Printf.sprintf "asw= %s;" (Pset.fold (fun (act1, act2) acc -> "(" ^ string_of_action act1 ^ ", " ^ - string_of_action act2 ^ " ), " ^ acc) preEx.asw "") in - Printf.sprintf "preEx {\n%s\n}" str - - -let dot_of_pre_execution preEx value_str eqs_str = - "digraph G {" ^ - "value [shape=box, label= \"Value: " ^ value_str ^ "\"];" ^ - "eqs [shape=box, label= \"" ^ eqs_str ^ "\"];" ^ - "subgraph cluster1 {" ^ - (Pset.fold (fun (act1, act2) acc -> "\"" ^ string_of_action act1 ^ "\" -> \"" ^ - string_of_action act2 ^ "\";" ^ acc) preEx.sb "") ^ - (Pset.fold (fun (act1, act2) acc -> "\"" ^ string_of_action act1 ^ "\" -> \"" ^ - string_of_action act2 ^ "\" [color=\"deeppink4\"];" ^ acc) preEx.asw "") ^ - "}}" - - -open Cmm_op - -(* -let dot_of_exeState st value_str eqs_str = - "digraph G {" ^ - "value [shape=box, label= \"Value: " ^ value_str ^ "\"];" ^ - "eqs [shape=box, label= \"" ^ eqs_str ^ "\"];" ^ - "subgraph cluster1 {" ^ - (Pset.fold (fun (act1, act2) acc -> "\"" ^ string_of_action act1 ^ "\" -> \"" ^ - string_of_action act2 ^ "\";" ^ acc) st.symPre.sb "") ^ - (Pset.fold (fun (act1, act2) acc -> "\"" ^ string_of_action act1 ^ "\" -> \"" ^ - string_of_action act2 ^ "\" [color=\"deeppink4\"];" ^ acc) st.symPre.asw "") ^ - - (Pset.fold (fun (act1, act2) acc -> "\"" ^ string_of_action act1 ^ "\" -> \"" ^ - string_of_action act2 ^ "\" [color=\"red\"];" ^ acc) st.symWit.rf "") ^ - (Pset.fold (fun (act1, act2) acc -> "\"" ^ string_of_action act1 ^ "\" -> \"" ^ - string_of_action act2 ^ "\" [color=\"blue\"];" ^ acc) st.symWit.mo "") ^ - - "}}" -*) - - - - - -open Cerb_pp_prelude - -let pp_action act = - !^ (string_of_action act) - -let pp_symState (st: Cmm_op.symState) : PPrint.document = - let pp_aid act = P.dquotes (!^ ("aid_" ^ string_of_int (Cmm_csem.aid_of act))) in - let (asw_colour, rf_colour, mo_colour) = ("deeppink4", "red", "blue") in - - let thread_docs = List.fold_left (fun acc act -> - let tid = Cmm_csem.tid_of act in - let xs' = (pp_aid act ^^^ P.brackets (!^ "label" ^^ P.equals ^^^ P.dquotes (pp_action act) ^^ - (if List.mem act st.symCommitted then -P.comma ^^^ !^ "style" ^^ P.equals ^^^ P.dquotes (!^"filled") else P.empty))) :: - match Pmap.lookup tid acc with - | Some xs -> - xs - | None -> - [] in - Pmap.add tid xs' acc - ) (Pmap.empty compare) (Pset.elements st.symPre.actions) in - - !^ "digraph G" ^^^ P.braces ( - !^ "node" ^^ P.brackets (!^ "fillcolor" ^^ P.equals ^^^ P.dquotes (!^ "grey")) ^^ P.semi ^^^ - P.nest 2 (P.hardline ^^ - P.separate (P.semi ^^ P.hardline) begin - (* listing the actions by their aid *) - Pmap.fold (fun tid docs acc -> - begin - !^ ("subgraph cluster_" ^ string_of_int tid) ^^ P.braces (P.hardline ^^ - P.separate (P.semi ^^ P.hardline) begin - (!^ "label" ^^ P.equals ^^^ P.dquotes (!^ ("Thread " ^ string_of_int tid))) :: docs - end - ^^ P.hardline) - end :: acc - ) thread_docs [] @ - - -(* - List.map (fun act -> - pp_aid act ^^^ P.brackets (!^ "label" ^^ P.equals ^^^ P.dquotes (pp_action act)) - ) (Pset.elements st.symPre.actions) @ -*) - (* sb, asw, rf, mo *) - List.map (fun (act1, act2) -> - pp_aid act1 ^^^ P.minus ^^ P.rangle ^^^ pp_aid act2 - ) (Pset.elements st.symPre.sb) @ - List.map (fun (act1, act2) -> - pp_aid act1 ^^^ P.minus ^^ P.rangle ^^^ pp_aid act2 ^^^ P.brackets (!^ "color" ^^ P.equals ^^^ P.dquotes (!^ asw_colour)) - ) (Pset.elements st.symPre.asw) @ - List.map (fun (act1, act2) -> - pp_aid act1 ^^^ P.minus ^^ P.rangle ^^^ pp_aid act2 ^^^ P.brackets (!^ "color" ^^ P.equals ^^^ P.dquotes (!^ rf_colour)) - ) (Pset.elements st.symWit.rf) @ - List.map (fun (act1, act2) -> - pp_aid act1 ^^^ P.minus ^^ P.rangle ^^^ pp_aid act2 ^^^ P.brackets (!^ "color" ^^ P.equals ^^^ P.dquotes (!^ mo_colour)) - ) (Pset.elements st.symWit.mo) - end - ) ^^ P.hardline - ) - - -let dot_of_exeState st _ _ = - Pp_utils.to_plain_string (pp_symState st) - -let string_of_exeState st = - dot_of_exeState st "" "" - - -let pp_execState st = - dot_of_exeState st "" "" - -(* - type pre_execution = - <| actions : set (action); - threads : set (tid); - lk : location -> location_kind; - sb : set (action * action) ; - asw : set (action * action) ; - dd : set (action * action) ; - |> -*) - -let pp_constraints_symbolic symb = - Pp_utils.to_plain_string (Pp_symbolic.pp_symbolic Pp_core.pp_object_value Pp_mem.pp_pointer_value symb) diff --git a/ocaml_frontend/pprinters/pp_cmm.mli b/ocaml_frontend/pprinters/pp_cmm.mli deleted file mode 100644 index df851cc40..000000000 --- a/ocaml_frontend/pprinters/pp_cmm.mli +++ /dev/null @@ -1,7 +0,0 @@ -val pp_old_constraints: Constraints.old_constraints -> string -val dot_of_pre_execution: Cmm_csem.pre_execution -> string -> string -> string -val dot_of_exeState: Cmm_op.symState -> string -> string -> string -val pp_execState: Cmm_op.symState -> string -val string_of_exeState: Cmm_op.symState -> string - -val pp_constraints_symbolic: (Core.object_value, Mem.pointer_value) Symbolic.symbolic -> string diff --git a/ocaml_frontend/pprinters/pp_constraints.ml b/ocaml_frontend/pprinters/pp_constraints.ml deleted file mode 100644 index 283f546d5..000000000 --- a/ocaml_frontend/pprinters/pp_constraints.ml +++ /dev/null @@ -1,4 +0,0 @@ -open Constraints -let pp_old_constraints (Constraints xs) = - let strs = List.map (fun z -> Pp_utils.to_plain_string (Pp_symbolic.pp_symbolic Pp_core.pp_object_value Pp_mem.pp_pointer_value z)) xs in - "[" ^ String.concat ", " strs ^ "]" diff --git a/ocaml_frontend/pprinters/pp_core.ml b/ocaml_frontend/pprinters/pp_core.ml index 23f283895..2658e9221 100644 --- a/ocaml_frontend/pprinters/pp_core.ml +++ b/ocaml_frontend/pprinters/pp_core.ml @@ -280,10 +280,6 @@ let rec pp_object_value = function Impl_mem.case_fval fval (fun () -> !^ "unspec(floating)") (fun fval -> !^(string_of_float fval)) -(* - | OVsymbolic symb -> - !^ "SYMB" ^^ P.parens (Pp_symbolic.pp_symbolic pp_object_value Pp_mem.pp_pointer_value symb) -*) | OVpointer ptr_val -> Impl_mem.pp_pointer_value ptr_val | OVarray lvals -> diff --git a/ocaml_frontend/pprinters/pp_defacto_memory.ml b/ocaml_frontend/pprinters/pp_defacto_memory.ml deleted file mode 100644 index b0e1f2152..000000000 --- a/ocaml_frontend/pprinters/pp_defacto_memory.ml +++ /dev/null @@ -1,288 +0,0 @@ -open Defacto_memory_types -open Cerb_pp_prelude - -(* Use this to pprint things not yet recognised by the Core parser *) -(* let nonvalid = - P.enclose (!^ "{#") (!^ "#}") *) - - -let string_of_integer_operator = function - | Mem_common.IntAdd -> - "+" - | Mem_common.IntSub -> - "-" - | Mem_common.IntMul -> - "*" - | Mem_common.IntDiv -> - "/" - | Mem_common.IntRem_t -> - "rem_t" - | Mem_common.IntRem_f -> - "rem_f" - | Mem_common.IntExp -> - "**" - - - -let pp_provenance_id prov_id = - !^ (string_of_int prov_id) - -let pp_allocation_id alloc_id = - !^ (string_of_int alloc_id) - - -let pp_provenance = function - | Prov_wildcard -> - !^ "Prov_wildcard" - | Prov_none -> - !^ "Prov_none" - | Prov_device -> - !^ "Prov_device" - | Prov_some (id, pref) -> - !^ "Prov_some" ^^ pp_provenance_id id ^^ Pp_symbol.pp_prefix pref - - -let rec pp_pointer_value ?(is_verbose=false) (PV (prov, ptr_val_, sh)) = - !^ "PV" ^^ P.parens (pp_provenance prov ^^ P.comma ^^^ pp_pointer_value_base ptr_val_ ^^ P.comma ^^^ pp_shift_path sh) - -and pp_pointer_value_base = function - | PVunspecified ty -> - !^ "PVunspecified" ^^ P.parens (Pp_core_ctype.pp_ctype ty) - | PVnull ty -> - !^ "PVnull" ^^ P.parens (Pp_core_ctype.pp_ctype ty) - | PVfunction sym -> - !^ "PVfunction" ^^ P.parens (P.parens (!^ (Pp_symbol.to_string_pretty sym))) - | PVbase (alloc_id, pref) -> - !^ "PVbase" ^^ P.parens (pp_allocation_id alloc_id ^^ P.comma ^^^ Pp_symbol.pp_prefix pref) - | PVfromint ival_ -> - !^ "PVfromint" ^^ P.parens (pp_integer_value_base ival_) - -and pp_shift_path_element = function - | SPE_array (ty, ival_) -> - !^ "SPE_array" ^^ P.parens (Pp_core_ctype.pp_ctype ty ^^ P.comma ^^ pp_integer_value_base ival_) - | SPE_member (tag_sym, (Symbol.Identifier (_, memb_str))) -> - !^ "SPE_member" ^^ P.parens (!^ (Pp_symbol.to_string_pretty tag_sym) ^^ P.comma ^^^ !^ memb_str) - -and pp_shift_path sh = - P.brackets (comma_list pp_shift_path_element sh) - - -and pp_integer_value_base = function - | IVconcurRead (ity, sym) -> - !^ "IVconcurRead" ^^ P.parens (Pp_ail.pp_integerType ity ^^ P.comma ^^^ !^ (Pp_symbol.to_string_pretty sym)) - | IVunspecified -> - !^ "IVunspecified" - | IVconcrete n -> - !^ "IVconcrete" ^^ P.parens (!^ (Z.to_string n)) - | IVaddress (alloc_id, pref) -> - !^ "IVaddress" ^^ P.parens (!^ (string_of_int alloc_id) ^^ Pp_symbol.pp_prefix pref) - | IVfromptr (ty, ity, ptr_val_, sh) -> - !^ "IVfromptr" ^^ P.parens ( - Pp_core_ctype.pp_ctype ty ^^ P.comma ^^^ - Pp_ail.pp_integerType ity ^^ P.comma ^^^ - pp_pointer_value_base ptr_val_ ^^ P.comma ^^^ - pp_shift_path sh - ) - | IVop (iop, ival_s) -> - !^ "IVop" ^^ P.parens (!^ (string_of_integer_operator iop) ^^ P.comma ^^^ comma_list pp_integer_value_base ival_s) - | IVmax ity -> - !^ "IVmax" ^^ P.parens (Pp_ail.pp_integerType ity) - | IVmin ity -> - !^ "IVmin" ^^ P.parens (Pp_ail.pp_integerType ity) - | IVsizeof ty -> - !^ "IVsizeof" ^^ P.parens (Pp_core_ctype.pp_ctype ty) - | IValignof ty -> - !^ "IValignof" ^^ P.parens (Pp_core_ctype.pp_ctype ty) - | IVoffsetof (tag_sym, Symbol.Identifier (_, memb_str)) -> - !^ "IVoffset" ^^ P.parens (!^ (Pp_symbol.to_string_pretty tag_sym) ^^ P.comma ^^^ !^ memb_str) - | IVpadding (tag_sym, Symbol.Identifier (_, memb_str)) -> - !^ "IVpadding" ^^ P.parens (!^ (Pp_symbol.to_string_pretty tag_sym) ^^ P.comma ^^^ !^ memb_str) - | IVptrdiff (ty, (ptr_val_1, sh1), (ptr_val_2, sh2)) -> - !^ "IVptrdiff" ^^ P.parens ( - Pp_core_ctype.pp_ctype ty ^^ P.comma ^^^ - P.parens (pp_pointer_value_base ptr_val_1 ^^ P.comma ^^^ pp_shift_path sh1) ^^ P.comma ^^^ - P.parens (pp_pointer_value_base ptr_val_2 ^^ P.comma ^^^ pp_shift_path sh2) - ) - | IVbyteof (ival_, mval) -> - !^ "IVbyteof" ^^ P.parens (pp_integer_value_base ival_ ^^ P.comma ^^^ pp_mem_value mval) - | IVcomposite _ -> - !^ "IVcomposite(TODO)" - | IVbitwise (ity, BW_complement ival_) -> - !^ "IVbitwise" ^^ P.parens ( - !^ "BW_complement" ^^ P.parens (Pp_ail.pp_integerType ity ^^ P.comma ^^^ pp_integer_value_base ival_) - ) - | IVbitwise (ity, BW_AND (ival_1, ival_2)) -> - !^ "IVbitwise" ^^ P.parens ( - !^ "BW_AND" ^^ P.parens (Pp_ail.pp_integerType ity ^^ P.comma ^^^ pp_integer_value_base ival_1 ^^ P.comma ^^^ pp_integer_value_base ival_2) - ) - | IVbitwise (ity, BW_OR (ival_1, ival_2)) -> - !^ "IVbitwise" ^^ P.parens ( - !^ "BW_OR" ^^ P.parens (Pp_ail.pp_integerType ity ^^ P.comma ^^^ pp_integer_value_base ival_1 ^^ P.comma ^^^ pp_integer_value_base ival_2) - ) - | IVbitwise (ity, BW_XOR (ival_1, ival_2)) -> - !^ "IVbitwise" ^^ P.parens ( - !^ "BW_XOR" ^^ P.parens (Pp_ail.pp_integerType ity ^^ P.comma ^^^ pp_integer_value_base ival_1 ^^ P.comma ^^^ pp_integer_value_base ival_2) - ) - - -and pp_integer_value (IV (prov, ival_)) = - !^ "IV" ^^ P.parens (pp_provenance prov ^^ P.comma ^^^ pp_integer_value_base ival_) - -and pp_mem_value = function -(* - | MVsymbolic symb -> - !^ "MVsymbolic" ^^ P.parens (Pp_symbolic.pp_symbolic pp_mem_value pp_pointer_value symb) -*) -(* - | MVunspecified ty -> - !^ "MVunspecified" ^^ P.parens (Pp_core_ctype.pp_ctype ty) -*) - | MVinteger (ity, ival) -> - !^ "MVinteger" ^^ P.parens (Pp_ail_raw.pp_integerType_raw ity ^^ P.comma ^^^ pp_integer_value ival) - | MVfloating (fty, FVconcrete x) -> - !^ ("MVfloating(" ^ string_of_float x ^ ")") - | MVfloating (fty, FVunspecified) -> - !^ ("MVfloating(unspec)") - | MVpointer (ty, ptr_val) -> - !^ "MVpointer" ^^ P.parens (Pp_core_ctype.pp_ctype ty ^^ P.comma ^^^ pp_pointer_value ptr_val) - | MVarray mem_vals -> - !^ "MVarray" ^^ P.parens (comma_list pp_mem_value mem_vals) -| MVstruct (tag_sym, xs) -> - P.parens ( - !^ "struct" ^^^ !^ (Pp_symbol.to_string_pretty tag_sym) - ) ^^^ - P.braces ( - comma_list (fun (mb_ident, _, mval) -> - P.dot ^^ Pp_symbol.pp_identifier mb_ident ^^ P.equals ^^^ pp_mem_value mval - ) xs - ) - | MVunion (tag_sym, mb_ident, mval) -> - P.parens ( - !^ "union" ^^^ !^ (Pp_symbol.to_string_pretty tag_sym) - ) ^^^ - P.braces ( - P.dot ^^ Pp_symbol.pp_identifier mb_ident ^^ P.equals ^^^ pp_mem_value mval - ) - | MVdelayed (xs, mval) -> - !^ "MVcomposite" ^^ - P.parens (P.brackets (comma_list (fun (sh, mval) -> - P.parens (pp_shift_path sh ^^ P.comma ^^^ pp_mem_value mval) - ) xs) ^^ P.comma ^^^ pp_mem_value mval) - | MVcomposite (xs, mval) -> - !^ "MVcomposite" ^^ - P.parens (P.brackets (comma_list (fun (off_ival_, byte_ival) -> - P.parens (pp_integer_value_base off_ival_ ^^ P.comma ^^^ pp_integer_value byte_ival) - ) xs) ^^ P.comma ^^^ pp_mem_value mval) - - -let pp_pretty_pointer_value (PV (_, ptr_val_, sh) as ptr_val) = - match ptr_val_ with - | PVnull ty -> - !^ "null" - | PVfunction sym -> - !^ "funptr" ^^ P.braces (!^ (Pp_symbol.to_string_pretty sym)) - | PVbase (_, pref) -> - Pp_symbol.pp_prefix pref - | PVfromint _ -> - pp_pointer_value ptr_val - | _ -> - assert false - - -let pp_pretty_integer_value ?basis ~use_upper (IV (_, ival_)) = - let rec aux = function - | IVconcurRead (_, sym) -> - !^ ("concur(" ^ Pp_symbol.to_string_pretty sym ^ ")") - | IVunspecified -> - !^ "UNSPEC" - | IVconcrete n -> - !^ begin - let b = match basis with - | Some `Octal -> - 8 - | Some `Decimal | None -> - 10 - | Some `Hexadecimal -> - 16 - | Some `Binary -> - 2 in - let chars = String_nat_big_num.chars_of_num_with_basis b use_upper n in - let bts = Bytes.create (List.length chars) in - List.iteri (Bytes.set bts) chars; - Bytes.to_string bts - end - | IVaddress (alloc_id, pref) -> - P.at ^^ !^ (string_of_int alloc_id) ^^ Pp_symbol.pp_prefix pref - | IVfromptr (ty, ity, ptr_val_, sh) -> - !^ "fromptr" ^^ P.parens ( - Pp_core_ctype.pp_ctype ty ^^ P.comma ^^^ - Pp_ail.pp_integerType ity ^^ P.comma ^^^ - pp_pointer_value_base ptr_val_ ^^ P.comma ^^^ - pp_shift_path sh - ) - | IVop (iop, [ival_1; ival_2]) -> - P.parens (aux ival_1 ^^^ !^ (string_of_integer_operator iop) ^^^ aux ival_2) - | IVop _ -> - !^ "ERROR_IVop_illtyped" - | IVmax ity -> - !^ "ivmax" ^^ P.parens (Pp_ail.pp_integerType ity) - | IVmin ity -> - !^ "ivmin" ^^ P.parens (Pp_ail.pp_integerType ity) - | IVsizeof ty -> - !^ "ivsizeof" ^^ P.parens (Pp_core_ctype.pp_ctype ty) - | IValignof ty -> - !^ "ivalignof" ^^ P.parens (Pp_core_ctype.pp_ctype ty) - | IVoffsetof (tag_sym, Symbol.Identifier (_, memb_str)) -> - !^ "IVoffsetof" - | IVpadding (tag_sym, Symbol.Identifier (_, memb_str)) -> - !^ "padding" ^^ P.parens (!^ (Pp_symbol.to_string_pretty tag_sym) ^^ P.comma ^^^ !^ memb_str) - | IVptrdiff (ty, (ptr_val_1, sh1), (ptr_val_2, sh2)) -> - !^ "ptrdiff" ^^ P.parens ( - Pp_core_ctype.pp_ctype ty ^^ P.comma ^^^ - P.parens (pp_pointer_value_base ptr_val_1 ^^ P.comma ^^^ pp_shift_path sh1) ^^ P.comma ^^^ - P.parens (pp_pointer_value_base ptr_val_2 ^^ P.comma ^^^ pp_shift_path sh2) - ) - | IVbyteof (ival_, mval) -> - !^ "IVbyteof" ^^ P.parens (aux ival_ ^^ P.comma ^^^ pp_mem_value mval) - | IVcomposite _ -> - !^ "IVcomposite(TODO)" - | IVbitwise (ity, BW_complement ival_) -> - !^ "compl" ^^ P.parens (aux ival_) - | IVbitwise (ity, BW_AND (ival_1, ival_2)) -> - P.parens (aux ival_1 ^^^ P.ampersand ^^^ aux ival_2) - | IVbitwise (ity, BW_OR (ival_1, ival_2)) -> - P.parens (aux ival_1 ^^^ P.bar ^^^ aux ival_2) - | IVbitwise (ity, BW_XOR (ival_1, ival_2)) -> - P.parens (aux ival_1 ^^^ P.caret ^^^ aux ival_2) - in - aux ival_ - -let pp_pretty_mem_value ?basis ~use_upper = function - | MVinteger (_, ival) -> - pp_pretty_integer_value ?basis ~use_upper ival - | MVfloating (fty, FVconcrete fval) -> - !^(string_of_float fval) - | MVfloating (fty, FVunspecified) -> - !^ "unspec(floating)" -(* - | MVunspecified ty -> - !^ "unspec" ^^ P.parens (Pp_core_ctype.pp_ctype ty) -*) - | mval -> - pp_mem_value mval - - -let pp_integer_value_for_core (IV (prov, ival_)) = - match ival_ with - | IVconcrete n -> - !^ (Z.to_string n) - | IVmax ity -> - !^ "Ivmax" ^^ P.parens (P.dquotes (Pp_ail.pp_integerType ity)) - | IVmin ity -> - !^ "Ivmin" ^^ P.parens (P.dquotes (Pp_ail.pp_integerType ity)) - | IVsizeof ty -> - !^ "Ivsizeof" ^^ P.parens (P.dquotes (Pp_core_ctype.pp_ctype ty)) - | IValignof ty -> - !^ "Ivalignof" ^^ P.parens (P.dquotes (Pp_core_ctype.pp_ctype ty)) - | _ -> - !^ "TODO[IV] " ^^ P.parens (pp_provenance prov ^^ P.comma ^^ pp_integer_value_base ival_) diff --git a/ocaml_frontend/pprinters/pp_defacto_memory.mli b/ocaml_frontend/pprinters/pp_defacto_memory.mli deleted file mode 100644 index 8e1183ca7..000000000 --- a/ocaml_frontend/pprinters/pp_defacto_memory.mli +++ /dev/null @@ -1,14 +0,0 @@ -open Defacto_memory_types - -val pp_pointer_value: ?is_verbose:bool -> impl_pointer_value -> PPrint.document -val pp_integer_value: impl_integer_value -> PPrint.document -val pp_integer_value_for_core: impl_integer_value -> PPrint.document -val pp_mem_value: impl_mem_value -> PPrint.document - -val pp_pretty_pointer_value: impl_pointer_value -> PPrint.document -val pp_pretty_integer_value: ?basis:Memory_model.basis -> use_upper:bool -> impl_integer_value -> PPrint.document -val pp_pretty_mem_value: ?basis:Memory_model.basis -> use_upper:bool -> impl_mem_value -> PPrint.document - - -(* FOR DEBUG *) -val pp_shift_path: shift_path -> PPrint.document diff --git a/ocaml_frontend/pprinters/pp_errors.ml b/ocaml_frontend/pprinters/pp_errors.ml index d0a1a17ed..cd00e40a8 100644 --- a/ocaml_frontend/pprinters/pp_errors.ml +++ b/ocaml_frontend/pprinters/pp_errors.ml @@ -10,6 +10,21 @@ open Cerb_location open Cerb_colour open Cerb_pp_prelude +let string_of_cause_kind = function + | CPP _ -> "cpp" + | CPARSER _ -> "parser" + | EXTENSION _ -> "extension" + | DESUGAR _ -> "desugar" + | AIL_TYPING _ -> "ail_typing" + | CORE_PARSER _ -> "core_parser" + | CORE_TYPING _ -> "core_typing" + | CORE_LINKING _ -> "core_linking" + | CORE_RUN _ -> "core_run" + | DRIVER _ -> "driver" + | UNSUPPORTED _ -> "unsupported" + | INTERNAL_ERROR _ -> "internal_error" + + type kind = | Error | Warning @@ -214,7 +229,9 @@ let string_of_constraint_violation = function | LabelRedefinition l -> "redefinition of '" ^ string_of_cid l ^ "'" | SwitchStatementControllingExpressionNotInteger -> - "statement requires expression of integer type" + "switch statement requires expression of integer type" + | CaseNotIntegerConstantExpression -> + "expression is not an integer constant expression" | CaseStatementOverlap prev_loc -> "duplicate case value" | MutipleDefaultStatement prev_loc -> @@ -391,7 +408,7 @@ let string_of_desugar_cause = function | Desugar_NotYetSupported str -> "feature not yet supported: " ^ str | Desugar_agnosticFailure str -> - "agnostic mode could not carry on: `" ^ str ^ "' (consider removing --agnotic)" + "agnostic mode could not carry on: `" ^ str ^ "' (consider removing --agnostic)" | Desugar_illtypedIntegerConstant -> "failed to typecheck an integer constant expression" | Desugar_CN e -> @@ -424,7 +441,7 @@ let string_of_ail_typing_error = function | TError_NotYetSupported str -> "feature not yet supported: " ^ str | TError_AgnosticFailure str -> - "agnostic mode could not carry on: `" ^ str ^ "' (consider removing --agnotic)" + "agnostic mode could not carry on: `" ^ str ^ "' (consider removing --agnostic)" | TError_CN Cn.CNErr_typing_TODO -> "CN typing error" @@ -474,6 +491,11 @@ let string_of_core_typing_cause = function (if !Cerb_debug.debug_level > 0 then "(" ^ str ^ "):\n" else "") ^ (match m_found with Some found -> "this expression is of type '" ^ string_of_bty found ^ "' but " | None -> "") ^ "an expression of type '" ^ expected ^ "' was expected" + | ArityMismatchRun (expected, found) -> + Printf.sprintf + "wrong number of arguments to a run(): expected %d but %d were found" + expected + found | CFunctionExpected nm -> "symbol '" ^ string_of_name nm ^ "' has incorrect type, a symbol of type 'cfunction' was expected" | CFunctionParamsType -> diff --git a/ocaml_frontend/pprinters/pp_naive_memory.ml b/ocaml_frontend/pprinters/pp_naive_memory.ml deleted file mode 100644 index ab7a10658..000000000 --- a/ocaml_frontend/pprinters/pp_naive_memory.ml +++ /dev/null @@ -1,139 +0,0 @@ -open Naive_memory -open Cerb_pp_prelude - -(* Use this to pprint things not yet recognised by the Core parser *) -let nonvalid = - P.enclose (!^ "{#") (!^ "#}") - - - -let pp_pointer_shift ptr_sh = - let rec aux = function - | [] -> - P.empty - | (ty, n) :: ptr_sh' -> - Pp_core_ctype.pp_ctype ty ^^^ !^ "x" ^^^ !^ (Z.to_string n) ^^ P.comma ^^^ - aux ptr_sh' - in - P.brackets (aux ptr_sh) - - -let pp_pointer_value_aux is_nonvalid ptr_val = - (if is_nonvalid then (fun z -> z) else nonvalid) - (match ptr_val with - | PVnull0 ty -> - !^ "nullptr" ^^ P.parens (Pp_core_ctype.pp_ctype ty) - | PVobject ((n, pref), ptr_sh) -> - !^ ("@" ^ string_of_int n) ^^ pp_pointer_shift ptr_sh ^^ P.braces (Pp_symbol.pp_prefix pref) - | PVfunction0 sym -> - !^ "funptr" ^^ P.parens (!^ (Pp_symbol.to_string_pretty sym))) - -let pp_pointer_value = - pp_pointer_value_aux false - - -let string_of_integer_operator = function - | Mem_common.IntAdd -> - "+" - | Mem_common.IntSub -> - "-" - | Mem_common.IntMul -> - "*" - | Mem_common.IntDiv -> - "/" - | Mem_common.IntMod -> - "mod" - | Mem_common.IntExp -> - "^" - -let pp_integer_value = - let rec aux is_nonvalid ival = - let nonvalid = if is_nonvalid then fun z -> z else nonvalid in - match ival with - | IVinteger n -> - !^ (Z.to_string n) - | IVsymbolic symb -> - nonvalid (Pp_symbolic.pp_symbolic symb) - | IVptrdiff0 (ptr_val1, ptr_val2) -> - nonvalid ( - !^ "ptrdiff" ^^ P.parens ( - pp_pointer_value ptr_val1 ^^ P.comma ^^^ pp_pointer_value ptr_val2 - ) - ) - | IVintptr ptr_val -> - nonvalid ( - !^ "intptr" ^^ P.parens ( - pp_pointer_value ptr_val - ) - ) - | IVop0 (iop, ival1, ival2) -> - aux is_nonvalid ival1 ^^^ !^ (string_of_integer_operator iop) ^^^ aux is_nonvalid ival2 - in aux false - - -(* - - - - - - Mem.case_mem_value mval - (fun ty -> - - (fun ival -> - Mem.case_integer_value ival - (fun n -> - - ( fun _ -> - !^ "TODO(MVinteger SYMB_integer_value)") - (fun () -> - !^ "TODO(complex ival)") - ) - (fun str -> - !^ ("TODO(MVfloation " ^ str ^ ")")) - (fun ptr_val -> -(* - | Mem.MVpointer (Mem.PVobject ((n, pref), ptr_sh)) -> - !^ ("@" ^ string_of_int n) ^^ pp_pointer_shift ptr_sh ^^ P.braces (pp_prefix pref) - | Mem.MVpointer ptr_val -> - !^ "TODO(MVpointer)" -*) - failwith "WIP" - ) - (fun mvals -> - - (fun tag ident_mvals -> - - (fun _ _ _ -> - !^ "TODO(MVunion)") -*) - - - -let rec pp_mem_value = function - | MVunspecified0 ty -> - !^ "unspec" ^^ P.parens (Pp_core_ctype.pp_ctype ty) - | MVinteger0 ival -> - pp_integer_value ival - | MVfloating0 str -> - !^ str - | MVpointer0 ptr_val -> - pp_pointer_value ptr_val - | MVarray0 mvals -> - !^ "array" ^^ P.parens (comma_list pp_mem_value mvals) - | MVstruct0 (tag_sym, xs) -> - P.parens ( - !^ "struct" ^^^ !^ (Pp_symbol.to_string_pretty tag_sym) - ) ^^^ - P.braces ( - comma_list (fun (mb_ident, mval) -> - P.dot ^^ Pp_cabs.pp_cabs_identifier mb_ident ^^ P.equals ^^^ pp_mem_value mval - ) xs - ) - | MVunion0 (tag_sym, mb_ident, mval) -> - P.parens ( - !^ "union" ^^^ !^ (Pp_symbol.to_string_pretty tag_sym) - ) ^^^ - P.braces ( - P.dot ^^ Pp_cabs.pp_cabs_identifier mb_ident ^^ P.equals ^^^ pp_mem_value mval - ) diff --git a/ocaml_frontend/pprinters/pp_naive_memory.mli b/ocaml_frontend/pprinters/pp_naive_memory.mli deleted file mode 100644 index 49412f843..000000000 --- a/ocaml_frontend/pprinters/pp_naive_memory.mli +++ /dev/null @@ -1,5 +0,0 @@ -open Naive_memory - -val pp_pointer_value: pointer_value1 -> PPrint.document -val pp_integer_value: integer_value1 -> PPrint.document -val pp_mem_value: mem_value1 -> PPrint.document diff --git a/ocaml_frontend/pprinters/pp_symbolic.ml b/ocaml_frontend/pprinters/pp_symbolic.ml deleted file mode 100644 index 40c55253d..000000000 --- a/ocaml_frontend/pprinters/pp_symbolic.ml +++ /dev/null @@ -1,46 +0,0 @@ -open Symbolic -open Cerb_pp_prelude - - -let pp_symbolic_name = function - | SYMBfsym sym -> !^ (Pp_symbol.to_string_pretty sym) - | SYMBimpl iCst -> !^ (Implementation_.string_of_implementation_constant iCst) - -let rec pp_symbolic ppA ppB = function - | SYMBtrue -> - !^ "true" - | SYMBfalse -> - !^ "false" - | SYMBconst cst -> - ppA cst - | SYMBptrval ptr_val -> - ppB ptr_val - | SYMBmember_shift (symb, tag_sym, memb_ident) -> - !^ "member_shift" ^^ P.parens (pp_symbolic ppA ppB symb ^^ P.comma ^^^ !^ (Pp_symbol.to_string_pretty tag_sym) ^^ P.comma ^^^ Pp_cabs.pp_cabs_identifier memb_ident) - | SYMBctype ty -> - Pp_core_ctype.pp_ctype ty - | SYMBsym (_, sym) -> - !^ (Pp_symbol.to_string_pretty sym) - | SYMBnot symb -> - !^ "not" ^^ P.parens (pp_symbolic ppA ppB symb) - | SYMBop (op, symb1, symb2) -> - let str_opt = match op with - | Add0 -> "+" - | Sub0 -> "-" - | Mul0 -> "*" - | Div0 -> "/" - | Rem_t -> "rem_t" - | Rem_f -> "rem_f" - | Exp -> "exp" - | Eq0 -> "==" - | Neq -> "/=" - | Lt0 -> "<" - | Ge0 -> ">=" - | And0 -> "and" - | Or0 -> "or" in - P.parens (!^ str_opt ^^^ pp_symbolic ppA ppB symb1 ^^^ pp_symbolic ppA ppB symb2) - | SYMBite (symb1, symb2, symb3) -> - P.parens (!^ "ite" ^^^ pp_symbolic ppA ppB symb1 ^^^ pp_symbolic ppA ppB symb2 ^^^ pp_symbolic ppA ppB symb3) - | SYMBcall (symb_nm, symbs) -> - P.parens (!^ "call" ^^^ pp_symbolic_name symb_nm ^^^ P.separate_map (P.space) (pp_symbolic ppA ppB) symbs) - diff --git a/ocaml_frontend/pprinters/pp_symbolic.mli b/ocaml_frontend/pprinters/pp_symbolic.mli deleted file mode 100644 index d381ec816..000000000 --- a/ocaml_frontend/pprinters/pp_symbolic.mli +++ /dev/null @@ -1,3 +0,0 @@ -open Symbolic - -val pp_symbolic: ('a -> PPrint.document) -> ('b -> PPrint.document) -> ('a, 'b) symbolic -> PPrint.document diff --git a/ocaml_frontend/pprinters/string_defacto_memory.ml b/ocaml_frontend/pprinters/string_defacto_memory.ml deleted file mode 100644 index d9e899162..000000000 --- a/ocaml_frontend/pprinters/string_defacto_memory.ml +++ /dev/null @@ -1,23 +0,0 @@ -open Pp_defacto_memory - -let string_of_pointer_value ptr_val = - Pp_utils.to_plain_string (pp_pointer_value ptr_val) - -let string_of_integer_value ival = - Pp_utils.to_plain_string (pp_integer_value ival) - -let string_of_mem_value mval = - Pp_utils.to_plain_string (pp_mem_value mval) - -let string_pretty_of_mem_value ?basis ~use_upper mval = - Pp_utils.to_plain_string (pp_pretty_mem_value ?basis ~use_upper mval) - - -let string_of_iv_memory_constraint cs = - Pp_utils.to_plain_string (Pp_mem.pp_mem_constraint (Pp_defacto_memory.pp_pretty_integer_value ~basis:`Decimal ~use_upper:false) cs) - - - -(* FOR DEBUG *) -let string_of_shift_path sh = - Pp_utils.to_plain_string (pp_shift_path sh) diff --git a/ocaml_frontend/smt2.ml b/ocaml_frontend/smt2.ml index e1cf38763..50e2f93e5 100644 --- a/ocaml_frontend/smt2.ml +++ b/ocaml_frontend/smt2.ml @@ -131,6 +131,12 @@ let runND exec_mode (type cs) cs_module (m: ('a, Driver.step_kind, 'err, cs, 'st end >>= fun xs2 -> return (xs1 @ xs2) end + | (NDstep (_, [(_, m_act')]), st') -> + (* A step with a single alternative (the driver wraps every step it + performs in such an NDstep, for the web UI): continue directly + with a tail call, so that long deterministic executions neither + grow the stack nor pay the cost of a choice at every step. *) + aux m_act' st' | (NDstep (info, str_ms), st') -> (* Printf.fprintf stderr "%sNDstep[%s]\n" (String.make !pad ' ') (Driver.instance_Show_Show_Driver_step_kind_dict.show_method info); diff --git a/ocaml_frontend/switches.ml b/ocaml_frontend/switches.ml index b5fb99bbf..e9ff023cc 100644 --- a/ocaml_frontend/switches.ml +++ b/ocaml_frontend/switches.ml @@ -43,6 +43,10 @@ type cerb_switch = (* eliminate pure expr rebindings: let pat = C[pure(pexpr)] -> substitute pexpr *) | SW_copy_prop + (* set branching on an unspecified value as non-deterministic (rather than the + * default: undefined behaviour) *) + | SW_branching_on_unspec_is_nd + let internal_ref = ref [] @@ -99,6 +103,8 @@ let set strs = Some (SW_magic_comment_char_dollar) | "copy_prop" -> Some SW_copy_prop + | "branching_on_unspec_is_nd" -> + Some SW_branching_on_unspec_is_nd | _ -> None in let pred x = function @@ -128,7 +134,8 @@ let set strs = | SW_zero_initialised | SW_at_magic_comments | SW_magic_comment_char_dollar - | SW_copy_prop as y -> + | SW_copy_prop + | SW_branching_on_unspec_is_nd as y -> x = y in List.iter (fun str -> match read_switch str with diff --git a/ocaml_frontend/switches.mli b/ocaml_frontend/switches.mli index bba98f841..73432e508 100644 --- a/ocaml_frontend/switches.mli +++ b/ocaml_frontend/switches.mli @@ -43,6 +43,10 @@ type cerb_switch = (* eliminate pure symbol rebindings: let alias = pure(sym) → substitute sym *) | SW_copy_prop + (* set branching on an unspecified value as non-deterministic (rather than the + * default: undefined behaviour) *) + | SW_branching_on_unspec_is_nd + val get_switches: unit -> cerb_switch list val has_switch: cerb_switch -> bool val has_switch_pred: (cerb_switch -> bool) -> cerb_switch option diff --git a/ocaml_frontend/tags.ml b/ocaml_frontend/tags.ml deleted file mode 100644 index ceee7d142..000000000 --- a/ocaml_frontend/tags.ml +++ /dev/null @@ -1,27 +0,0 @@ -open Ctype - -let _tagDefs = - ref (false, None) - -let reset_tagDefs () = - _tagDefs := (false, None) - -let set_tagDefs v = - if fst !_tagDefs then - failwith "Tags definitions can be set only once" - else - _tagDefs := (true, Some v) - -let tagDefs () = - match snd !_tagDefs with - | Some v -> - v - | None -> - failwith "Tags definitions must be set by Tags.set_tagDefs before any use" - -let with_tagDefs tagDefs f = - let saved = !_tagDefs in - _tagDefs := (true, Some tagDefs); - let ret = f () in - _tagDefs := saved; - ret diff --git a/ocaml_frontend/tags.mli b/ocaml_frontend/tags.mli deleted file mode 100644 index ad2d20907..000000000 --- a/ocaml_frontend/tags.mli +++ /dev/null @@ -1,5 +0,0 @@ -val set_tagDefs: (Symbol.sym, Cerb_location.t * Ctype.tag_definition) Pmap.map -> unit -val tagDefs: unit -> (Symbol.sym, Cerb_location.t * Ctype.tag_definition) Pmap.map -val reset_tagDefs: unit -> unit - -val with_tagDefs: (Symbol.sym, Cerb_location.t * Ctype.tag_definition) Pmap.map -> (unit -> 'a) -> 'a diff --git a/parsers/c/c_parser.mly b/parsers/c/c_parser.mly index 1576730bb..ff5739e2e 100644 --- a/parsers/c/c_parser.mly +++ b/parsers/c/c_parser.mly @@ -1224,19 +1224,19 @@ direct_abstract_declarator: array_abstract_declarator: | dabs_decltor= ioption(direct_abstract_declarator) LBRACK tquals= ioption(type_qualifier_list) expr= assignment_expression? RBRACK - { DAbs_array (dabs_decltor, ADecl (Cerb_location.unknown, + { DAbs_array (dabs_decltor, ADecl (region ($startpos, $endpos) noCursor, Option.fold ~none:[] ~some:id tquals, false, Option.map (fun e -> ADeclSize_expression e) expr)) } | dabs_decltor= ioption(direct_abstract_declarator) LBRACK STATIC tquals= type_qualifier_list? expr= assignment_expression RBRACK - { DAbs_array (dabs_decltor, ADecl (Cerb_location.unknown, + { DAbs_array (dabs_decltor, ADecl (region ($startpos, $endpos) noCursor, Option.fold ~none:[] ~some:id tquals, true, Some (ADeclSize_expression expr))) } | dabs_decltor= ioption(direct_abstract_declarator) LBRACK tquals= type_qualifier_list STATIC expr= assignment_expression RBRACK - { DAbs_array (dabs_decltor, ADecl (Cerb_location.unknown, tquals, true, + { DAbs_array (dabs_decltor, ADecl (region ($startpos, $endpos) noCursor, tquals, true, Some (ADeclSize_expression expr))) } | dabs_decltor= ioption(direct_abstract_declarator) LBRACK STAR RBRACK - { DAbs_array (dabs_decltor, ADecl (Cerb_location.unknown, [], false, + { DAbs_array (dabs_decltor, ADecl (region ($startpos, $endpos) noCursor, [], false, Some ADeclSize_asterisk)) } ; diff --git a/public/dist/index.html b/public/dist/index.html index eabfc4a8b..29f956e89 100644 --- a/public/dist/index.html +++ b/public/dist/index.html @@ -47,7 +47,7 @@ Concrete-allocation-address memory model