diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 52024aef..c5998f80 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -607,16 +607,16 @@ let[@ocamlformat "disable"] static_base_rules = let gen_build_statements (include_dirs : string list) - (same_dir_modules : string list) + (same_dir_modules : (string * File.t) list) (item : Scan.item) : Nj.ninja = let open File in let ( ! ) = Var.( ! ) in let src = item.file_name in let modules = List.rev item.used_modules in let modfile ext modname = - if List.mem modname same_dir_modules then - (!Var.builddir / src /../ modname) ^ ext - else modname ^ ext + match List.assoc_opt modname same_dir_modules with + | Some f -> (!Var.builddir / Filename.remove_extension f) ^ ext + | None -> modname ^ ext in let inc x = !Var.builddir / x in let modd x = modfile "@module" x in @@ -627,24 +627,15 @@ let gen_build_statements ~implicit_in:(List.map inc item.included_files @ List.map modd modules) ~outputs:[inc srcv] in + let target_file ext = (!Var.builddir / !Var.src) ^ "." ^ ext in let module_deps = Option.map (fun m -> Nj.build "phony" - ~inputs: - [ - inc srcv; - (!Var.builddir / src /../ m) ^ ".cmi"; - (!Var.builddir / src /../ m) ^ ".cmxs"; - ] + ~inputs:[inc srcv; target_file "cmi"; target_file "cmxs"] ~outputs:[modd m]) item.module_def in - let target_file ext = - match item.module_def with - | Some m -> (!Var.builddir / src /../ m) ^ "." ^ ext - | None -> (!Var.builddir / !Var.src) ^ "." ^ ext - in let ml_file = target_file "ml" in let py_file = target_file "py" in let ocaml, python = @@ -667,15 +658,9 @@ let gen_build_statements in let ocamlopt = let obj = - let m = - match item.module_def with - | Some m -> m - | None -> Filename.(basename (remove_extension src)) - in - let target ext = (!Var.builddir / src /../ m) ^ "." ^ ext in Nj.build "ocaml-object" ~inputs:[ml_file] ~implicit_in:(!Var.catala_exe :: List.map modd modules) - ~outputs:(List.map target ["mli"; "cmi"; "cmo"; "cmx"; "cmt"; "o"]) + ~outputs:(List.map target_file ["mli"; "cmi"; "cmo"; "cmx"; "cmt"; "o"]) ~vars: [ ( Var.ocaml_flags, @@ -715,9 +700,9 @@ let gen_build_statements !Var.catala_exe :: List.map (fun m -> - if List.mem m same_dir_modules then - (!Var.builddir / src /../ m) ^ ".cmxs" - else m ^ "@module") + match List.assoc_opt m same_dir_modules with + | Some f -> (!Var.builddir / Filename.remove_extension f) ^ ".cmxs" + | None -> m ^ "@module") modules in let interpret = @@ -819,7 +804,10 @@ let gen_build_statements_dir (include_dirs : string list) (items : Scan.item list) : Nj.ninja = let same_dir_modules = - List.filter_map (fun item -> item.Scan.module_def) items + List.filter_map + (fun item -> + Option.map (fun name -> name, item.Scan.file_name) item.Scan.module_def) + items in Seq.flat_map (gen_build_statements include_dirs same_dir_modules) diff --git a/compiler/driver.ml b/compiler/driver.ml index a38a48e4..edf985ef 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -1142,9 +1142,13 @@ let main () = | exception Sys_error _ -> Message.debug "Could not read plugin directory %s" d) plugins_dirs; - Dynlink.allow_only ["Runtime_ocaml__Runtime"]; - (* We may use dynlink again, but only for runtime modules: no plugin - registration after this point *) + Dynlink.allow_only + (List.filter (( <> ) "Driver__Plugin") (Dynlink.all_units ())); + (* From here on, no plugin registration is allowed. However, the interpreter + may yet use Dynlink to load external modules. - TODO: This used to allow + only "Runtime_ocaml__Runtime", but forbidding external Catala modules to + use the OCaml Stdlib was a bit much. We should examine how to re-add some + more filtering here without being too restrictive. *) Plugin.list () in let command = catala_t plugins in diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index 2b99f283..79d75451 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -270,7 +270,7 @@ let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit = (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) | EmptyError -> Format.fprintf fmt "EmptyError" - | Crash -> Format.fprintf fmt "Crash" + | Crash s -> Format.fprintf fmt "(Crash %S)" s | NoValueProvided -> let pos = Mark.get exc in Format.fprintf fmt diff --git a/compiler/scalc/to_c.ml b/compiler/scalc/to_c.ml index 83a53429..85db04b7 100644 --- a/compiler/scalc/to_c.ml +++ b/compiler/scalc/to_c.ml @@ -455,7 +455,7 @@ let rec format_statement | ConflictError _ -> "catala_conflict" | EmptyError -> "catala_empty" | NoValueProvided -> "catala_no_value_provided" - | Crash -> "catala_crash") + | Crash _ -> "catala_crash") (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) | SIfThenElse { if_expr = cond; then_block = b1; else_block = b2 } -> diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index 0e9f4c97..4d404581 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -259,7 +259,7 @@ let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit = (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) | EmptyError -> Format.fprintf fmt "EmptyError" - | Crash -> Format.fprintf fmt "Crash" + | Crash _ -> Format.fprintf fmt "Crash" | NoValueProvided -> Format.fprintf fmt "NoValueProvided(@[SourcePosition(@[filename=\"%s\",@ \ diff --git a/compiler/scalc/to_r.ml b/compiler/scalc/to_r.ml index 1b13f883..b7f1bc98 100644 --- a/compiler/scalc/to_r.ml +++ b/compiler/scalc/to_r.ml @@ -265,7 +265,7 @@ let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit = (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) | EmptyError -> Format.fprintf fmt "catala_empty_error()" - | Crash -> Format.fprintf fmt "catala_crash()" + | Crash _ -> Format.fprintf fmt "catala_crash()" | NoValueProvided -> Format.fprintf fmt "catala_no_value_provided_error(@[catala_position(@[ Format.fprintf fmt "catala_conflict_error" | EmptyError -> Format.fprintf fmt "catala_empty_error" - | Crash -> Format.fprintf fmt "catala_crash" + | Crash _ -> Format.fprintf fmt "catala_crash" | NoValueProvided -> Format.fprintf fmt "catala_no_value_provided_error" let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index 20d8142f..7e07b224 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -382,7 +382,7 @@ type except = | ConflictError of Pos.t list | EmptyError | NoValueProvided - | Crash + | Crash of string (** {2 Markings} *) diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 8d0aeab2..7cd255a8 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -129,7 +129,7 @@ let rec evaluate_operator | _ -> assert false in try f x y with - | Division_by_zero -> + | Runtime.Division_by_zero -> Message.error ~extra_pos: [ @@ -663,16 +663,21 @@ let rec evaluate_expr : Message.error ~pos "wrong function call, expected %d arguments, got %d" (Bindlib.mbinder_arity binder) (List.length args) - | ECustom { obj; targs; tret } -> + | ECustom { obj; targs; tret } -> ( (* Applies the arguments one by one to the curried form *) - List.fold_left2 - (fun fobj targ arg -> - (Obj.obj fobj : Obj.t -> Obj.t) - (val_to_runtime (fun ctx -> evaluate_expr ctx lang) ctx targ arg)) - obj targs args - |> Obj.obj - |> fun o -> - runtime_to_val (fun ctx -> evaluate_expr ctx lang) ctx m tret o + match + List.fold_left2 + (fun fobj targ arg -> + (Obj.obj fobj : Obj.t -> Obj.t) + (val_to_runtime (fun ctx -> evaluate_expr ctx lang) ctx targ arg)) + obj targs args + with + | exception e -> + Format.ksprintf + (fun s -> raise (CatalaException (Crash s, pos))) + "@[This call to code from a module failed with:@ %s@]" + (Printexc.to_string e) + | o -> runtime_to_val (fun ctx -> evaluate_expr ctx lang) ctx m tret o) | _ -> Message.error ~pos "%a" Format.pp_print_text "function has not been reduced to a lambda at evaluation (should not \ @@ -927,9 +932,7 @@ let interp_failure_message ~pos = function "%a" Format.pp_print_text "There is a conflict between multiple valid consequences for assigning \ the same variable." - | Crash -> - (* This constructor seems to be never used *) - Message.error ~pos ~internal:true "The interpreter crashed" + | Crash s -> Message.error ~pos "%s" s | EmptyError -> Message.error ~pos ~internal:true "A variable without valid definition escaped" @@ -1087,10 +1090,7 @@ let load_runtime_modules prg = let load m = let obj_file = Dynlink.adapt_filename - File.( - Pos.get_file (Mark.get (ModuleName.get_info m)) - /../ ModuleName.to_string m - ^ ".cmo") + File.(Pos.get_file (Mark.get (ModuleName.get_info m)) -.- "cmo") in if not (Sys.file_exists obj_file) then Message.error diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index d819c236..bdbe23c6 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -350,7 +350,7 @@ let except (fmt : Format.formatter) (exn : except) : unit = (match exn with | EmptyError -> "EmptyError" | ConflictError _ -> "ConflictError" - | Crash -> "Crash" + | Crash s -> Printf.sprintf "Crash %S" s | NoValueProvided -> "NoValueProvided") let var_debug fmt v = diff --git a/runtimes/ocaml/runtime.ml b/runtimes/ocaml/runtime.ml index b5dc1a1e..84fdef53 100644 --- a/runtimes/ocaml/runtime.ml +++ b/runtimes/ocaml/runtime.ml @@ -53,9 +53,34 @@ exception IndivisibleDurations exception ImpossibleDate exception NoValueProvided of source_position exception NotSameLength +exception Division_by_zero (* Shadows the stdlib definition *) -(* TODO: register exception printers for the above - (Printexc.register_printer) *) +(* Register exceptions printers *) +let () = + let pos () p = + Printf.sprintf "%s:%d.%d-%d.%d" p.filename p.start_line p.start_column + p.end_line p.end_column + in + let pr fmt = Printf.ksprintf (fun s -> Some s) fmt in + Printexc.register_printer + @@ function + | EmptyError -> pr "A variable couldn't be resolved" + | AssertionFailed p -> pr "At %a: Assertion failed" pos p + | ConflictError p -> pr "At %a: Conflicting exceptions" pos p + | UncomparableDurations -> pr "Ambiguous comparison between durations" + | IndivisibleDurations -> pr "Ambiguous division between durations" + | ImpossibleDate -> pr "Invalid date" + | NoValueProvided p -> + pr "At %a: No definition applied to this variable" pos p + | NotSameLength -> pr "Attempt to traverse lists of different lengths" + | Division_by_zero -> pr "Division by zero" + | _ -> None + +let () = + Printexc.set_uncaught_exception_handler + @@ fun exc bt -> + Printf.eprintf "[ERROR] %s\n%!" (Printexc.to_string exc); + if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt let round (q : Q.t) : Z.t = (* The mathematical formula is [round(q) = sgn(q) * floor(abs(q) + 0.5)]. diff --git a/runtimes/ocaml/runtime.mli b/runtimes/ocaml/runtime.mli index 7e868355..1864d45a 100644 --- a/runtimes/ocaml/runtime.mli +++ b/runtimes/ocaml/runtime.mli @@ -76,6 +76,7 @@ exception UncomparableDurations exception IndivisibleDurations exception ImpossibleDate exception NoValueProvided of source_position +exception Division_by_zero (* Shadows the stdlib definition *) (** {1 Value Embedding} *)