├── README.md ├── .gitignore ├── trace_fail.ml ├── trace_ok.ml ├── trace_mixup.ml ├── trace_inline.ml ├── trace_lwt_fail.ml ├── .ocp-indent ├── trace_lwt_ok.ml ├── Makefile └── trace_lwt_wrap.ml /README.md: -------------------------------------------------------------------------------- 1 | Trying to figure out how to obtain complete stack backtraces in OCaml. 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.annot 3 | *.cmo 4 | *.cma 5 | *.cmi 6 | *.a 7 | *.o 8 | *.cmx 9 | *.cmxs 10 | *.cmxa 11 | *.opt 12 | *.run 13 | *.out 14 | -------------------------------------------------------------------------------- /trace_fail.ml: -------------------------------------------------------------------------------- 1 | (* 2 | ocamlopt -o trace.opt -g -inline 0 trace.ml 3 | ./trace.opt 4 | *) 5 | 6 | let nothing () = 7 | if bool_of_string "false" then 8 | print_endline "nothing" 9 | 10 | let a () = 11 | if true then 12 | raise (Invalid_argument "test") 13 | 14 | let b () = 15 | nothing (); 16 | a () 17 | 18 | let main () = 19 | try b () 20 | with e -> 21 | print_endline (Printexc.to_string e); 22 | print_string (Printexc.get_backtrace ()) 23 | 24 | let () = 25 | Printexc.record_backtrace true; 26 | main () 27 | -------------------------------------------------------------------------------- /trace_ok.ml: -------------------------------------------------------------------------------- 1 | (* 2 | ocamlopt -o trace.opt -g trace.ml 3 | ./trace.opt 4 | *) 5 | 6 | let nothing () = 7 | if bool_of_string "false" then 8 | print_endline "nothing" 9 | 10 | let a () = 11 | if true then 12 | raise (Invalid_argument "test") 13 | 14 | let b () = 15 | nothing (); 16 | a (); 17 | nothing () 18 | 19 | let main () = 20 | try b () 21 | with e -> 22 | print_endline (Printexc.to_string e); 23 | print_string (Printexc.get_backtrace ()) 24 | 25 | let () = 26 | Printexc.record_backtrace true; 27 | main () 28 | -------------------------------------------------------------------------------- /trace_mixup.ml: -------------------------------------------------------------------------------- 1 | external reraise : exn -> _ = "%reraise" 2 | 3 | let nothing () = 4 | if bool_of_string "false" then 5 | print_endline "nothing" 6 | 7 | let a () = 8 | if true then 9 | raise Exit 10 | 11 | let anything () = 12 | try raise Exit 13 | with _ -> () 14 | 15 | let b () = 16 | nothing (); 17 | (try 18 | a () 19 | with e -> 20 | anything (); 21 | reraise e 22 | ); 23 | nothing () 24 | 25 | let main () = 26 | try b () 27 | with e -> 28 | print_endline (Printexc.to_string e); 29 | print_string (Printexc.get_backtrace ()) 30 | 31 | let () = 32 | Printexc.record_backtrace true; 33 | main () 34 | -------------------------------------------------------------------------------- /trace_inline.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Complete stack trace: 3 | 4 | ocamlopt -o trace.opt -g -inline 0 trace.ml 5 | ./trace.opt 6 | 7 | Incomplete stack trace: 8 | 9 | ocamlopt -o trace.opt -g trace.ml 10 | ./trace.opt 11 | *) 12 | 13 | let nothing () = 14 | if bool_of_string "false" then 15 | print_endline "nothing" 16 | 17 | let a () = 18 | if true then 19 | raise (Invalid_argument "test") 20 | 21 | let b () = 22 | a (); 23 | nothing () 24 | 25 | let main () = 26 | try b () 27 | with e -> 28 | print_endline (Printexc.to_string e); 29 | print_string (Printexc.get_backtrace ()) 30 | 31 | let () = 32 | Printexc.record_backtrace true; 33 | main () 34 | -------------------------------------------------------------------------------- /trace_lwt_fail.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | let bind = Lwt.backtrace_bind 4 | 5 | let z () = 6 | if bool_of_string "false" then 7 | print_endline "z"; 8 | Lwt_unix.sleep 0.001 9 | 10 | let a () = 11 | bind (fun e -> try raise e with e -> e) (z ()) (fun () -> 12 | if true then 13 | raise (Invalid_argument "test") 14 | else 15 | return () 16 | ) 17 | 18 | let b () = 19 | bind (fun e -> try raise e with e -> e) (z ()) (fun () -> 20 | bind (fun e -> try raise e with e -> e) (a ()) (fun () -> 21 | z () 22 | ) 23 | ) 24 | 25 | let main () = 26 | catch 27 | (fun () -> 28 | bind (fun e -> try raise e with e -> e) (z ()) (fun () -> 29 | b () 30 | ) 31 | ) 32 | (fun e -> 33 | print_endline (Printexc.to_string e); 34 | print_string (Printexc.get_backtrace ()); 35 | return () 36 | ) 37 | 38 | let () = 39 | Printexc.record_backtrace true; 40 | Lwt_main.run (main ()) 41 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | # See https://github.com/OCamlPro/ocp-indent/blob/master/.ocp-indent for more 2 | 3 | # Indent for clauses inside a pattern-match (after the arrow): 4 | # match foo with 5 | # | _ -> 6 | # ^^^^bar 7 | # the default is 2, which aligns the pattern and the expression 8 | match_clause = 4 9 | 10 | # When nesting expressions on the same line, their indentation are in 11 | # some cases stacked, so that it remains correct if you close them one 12 | # at a line. This may lead to large indents in complex code though, so 13 | # this parameter can be used to set a maximum value. Note that it only 14 | # affects indentation after function arrows and opening parens at end 15 | # of line. 16 | # 17 | # for example (left: `none`; right: `4`) 18 | # let f = g (h (i (fun x -> # let f = g (h (i (fun x -> 19 | # x) # x) 20 | # ) # ) 21 | # ) # ) 22 | max_indent = 2 23 | -------------------------------------------------------------------------------- /trace_lwt_ok.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | let bind = Lwt.backtrace_bind 4 | external reraise : exn -> _ = "%reraise" 5 | 6 | let z () = 7 | if bool_of_string "false" then 8 | print_endline "z"; 9 | Lwt_unix.sleep 0.001 10 | 11 | let a () = 12 | bind (fun e -> try reraise e with e -> e) (z ()) (fun () -> 13 | if true then 14 | raise (Invalid_argument "test") 15 | else 16 | return () 17 | ) 18 | 19 | let b () = 20 | bind (fun e -> try reraise e with e -> e) (z ()) (fun () -> 21 | bind (fun e -> try reraise e with e -> e) (a ()) (fun () -> 22 | z () 23 | ) 24 | ) 25 | 26 | let main () = 27 | catch 28 | (fun () -> 29 | bind (fun e -> try reraise e with e -> e) (z ()) (fun () -> 30 | b () 31 | ) 32 | ) 33 | (fun e -> 34 | print_endline (Printexc.to_string e); 35 | print_string (Printexc.get_backtrace ()); 36 | return () 37 | ) 38 | 39 | let () = 40 | Printexc.record_backtrace true; 41 | Lwt_main.run (main ()) 42 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: default all clean 2 | 3 | default: all 4 | all: \ 5 | trace_fail.opt trace_ok.opt trace_inline_ok.opt trace_inline_fail.opt \ 6 | trace_mixup.opt trace_lwt_ok.opt trace_lwt_fail.opt trace_lwt_wrap.opt 7 | 8 | # Missing call point despite -inline 0 9 | trace_fail.opt: trace_fail.ml 10 | ocamlopt -o trace_fail.opt -g -inline 0 trace_fail.ml 11 | ./$@ > $@.out 12 | 13 | # Complete trace with or without -inline 0 14 | trace_ok.opt: trace_ok.ml 15 | ocamlopt -o trace_ok.opt -g trace_ok.ml 16 | ./$@ > $@.out 17 | 18 | # Complete trace only with -inline 0 19 | trace_inline_ok.opt: trace_inline.ml 20 | ocamlopt -o trace_inline_ok.opt -g -inline 0 trace_inline.ml 21 | ./$@ > $@.out 22 | 23 | # Incomplete trace when not using -inline 0 24 | trace_inline_fail.opt: trace_inline.ml 25 | ocamlopt -o trace_inline_fail.opt -g trace_inline.ml 26 | ./$@ > $@.out 27 | 28 | # Misuse of reraise leading to wrong (or incomplete) trace 29 | trace_mixup.opt: trace_mixup.ml 30 | ocamlopt -o trace_mixup.opt -g trace_mixup.ml 31 | ./$@ > $@.out 32 | 33 | # Decent trace achieved with Lwt.backtrace_bind and reraise 34 | trace_lwt_ok.opt: trace_lwt_ok.ml 35 | ocamlfind ocamlopt -o trace_lwt_ok.opt \ 36 | -g -inline 0 -package lwt.unix -linkpkg \ 37 | trace_lwt_ok.ml 38 | ./$@ > $@.out 39 | 40 | # Missing trace despite using Lwt.backtrace_bind 41 | trace_lwt_fail.opt: trace_lwt_fail.ml 42 | ocamlfind ocamlopt -o trace_lwt_fail.opt \ 43 | -g -inline 0 -package lwt.unix -linkpkg \ 44 | trace_lwt_fail.ml 45 | ./$@ > $@.out 46 | 47 | # Missing trace despite using Lwt.backtrace_bind 48 | trace_lwt_wrap.opt: trace_lwt_wrap.ml 49 | ocamlfind ocamlopt -o trace_lwt_wrap.opt \ 50 | -g -package lwt.unix -linkpkg \ 51 | trace_lwt_wrap.ml 52 | ./$@ > $@.out 53 | 54 | clean: 55 | rm -f *.[oa] *.cm[ioxa] *.cmx[as] *.out *.opt *.run *~ 56 | -------------------------------------------------------------------------------- /trace_lwt_wrap.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Printf 3 | 4 | (*** Utilities meant to be in their own module ***) 5 | 6 | (* 7 | Exceptions are wrapped into a Traced exception. 8 | Printing them is done with print_exception defined below. 9 | Catching and inspecting them would require some unwrapping. 10 | *) 11 | 12 | type loc = string 13 | 14 | type traced = { 15 | exn: exn; 16 | mutable trace: loc list; 17 | } 18 | 19 | exception Traced of traced 20 | 21 | let trace_loc e loc = 22 | match e with 23 | | Traced x -> 24 | x.trace <- loc :: x.trace; 25 | raise e 26 | | e -> 27 | raise (Traced { exn = e; trace = [loc] }) 28 | 29 | let trace_bt e = 30 | let bt = Printexc.get_backtrace () in 31 | trace_loc e bt 32 | 33 | let needs_newline s = 34 | match s with 35 | | "" -> false 36 | | _ -> s.[String.length s - 1] <> '\n' 37 | 38 | (* Print exception with wrapped trace, not the stack trace *) 39 | let rec print_traced_exception buf e = 40 | match e with 41 | | Traced x -> 42 | print_traced_exception buf x.exn; 43 | List.iter (fun loc -> 44 | if needs_newline loc then 45 | bprintf buf "%s\n" loc 46 | else 47 | Buffer.add_string buf loc 48 | ) (List.rev x.trace) 49 | | e -> 50 | bprintf buf "%s\n" (Printexc.to_string e) 51 | 52 | let print_regular_exception buf e = 53 | let stack_trace = Printexc.get_backtrace () in 54 | bprintf buf "%s\n%s" 55 | (Printexc.to_string e) 56 | stack_trace 57 | 58 | let print_exception e = 59 | let buf = Buffer.create 500 in 60 | (match e with 61 | | Traced _ -> 62 | print_traced_exception buf e 63 | | e -> 64 | print_regular_exception buf e 65 | ); 66 | Buffer.contents buf 67 | 68 | let create_thread loc f x = 69 | catch 70 | (fun () -> 71 | try f x 72 | with e -> trace_bt e 73 | ) 74 | (fun e -> trace_loc e loc) 75 | 76 | (*** Test program ***) 77 | 78 | (* 79 | Each time a thread is created after a bind, 80 | we wrap the thread (normally using a preprocessor) 81 | such that exceptions are caught and wrapped into a special 82 | exception type. 83 | *) 84 | 85 | let z () = 86 | if bool_of_string "false" then 87 | print_endline "z"; 88 | Lwt_unix.sleep 0.001 89 | 90 | let nothing () = 91 | if bool_of_string "false" then 92 | print_endline "nothing" 93 | 94 | let a0 () = 95 | nothing (); 96 | nothing (); 97 | if true then 98 | raise (Invalid_argument "test"); 99 | nothing () 100 | 101 | let a () = 102 | z () >>= create_thread __LOC__ @@ fun () -> 103 | a0 (); 104 | return () 105 | 106 | let b () = 107 | z () >>= create_thread __LOC__ @@ fun () -> 108 | a () >>= create_thread __LOC__ @@ fun () -> 109 | z () 110 | 111 | let main () = 112 | catch 113 | (fun () -> 114 | z () >>= create_thread __LOC__ @@ fun () -> 115 | b () 116 | ) 117 | (fun e -> 118 | printf "%s" (print_exception e); 119 | return () 120 | ) 121 | 122 | let () = 123 | Printexc.record_backtrace true; 124 | Lwt_main.run (main ()) 125 | --------------------------------------------------------------------------------