Fix PR#6443: Ocaml segfault when List.fold_left is traced then executed

git-svn-id: http://caml.inria.fr/svn/ocaml/version/4.02@14922 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Author: Jacques Garrigue

Changes

@@ -234,6 +234,7 @@ Bug fixes:
 - PR#6408: Optional arguments given as ~?arg instead of ?arg in message
   (Michael O'Connor)
 - PR#6436: Typos in @deprecated text in stdlib/arrayLabels.mli
+- PR#6443: ocaml segfault when List.fold_left is traced then executed
 - fix -dsource printing of "external _pipe = ..."
   (Gabriel Scherer)
 - bound-checking bug in caml_string_{get,set}{16,32,64}

testsuite/tests/tool-toplevel/Makefile

@@ -0,0 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common

testsuite/tests/tool-toplevel/tracing.ml

@@ -0,0 +1,4 @@
+List.fold_left;;
+#trace List.fold_left;;
+0;;
+List.fold_left (+) 0 [1;2;3];;

testsuite/tests/tool-toplevel/tracing.ml.reference

@@ -0,0 +1,30 @@
+
+# - : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a = <fun>
+# List.fold_left is now traced.
+# - : int = 0
+# List.fold_left <-- <fun>
+List.fold_left --> <fun>
+List.fold_left* <-- <poly>
+List.fold_left* --> <fun>
+List.fold_left** <-- [<poly>; <poly>; <poly>]
+List.fold_left <-- <fun>
+List.fold_left --> <fun>
+List.fold_left* <-- <poly>
+List.fold_left* --> <fun>
+List.fold_left** <-- [<poly>; <poly>]
+List.fold_left <-- <fun>
+List.fold_left --> <fun>
+List.fold_left* <-- <poly>
+List.fold_left* --> <fun>
+List.fold_left** <-- [<poly>]
+List.fold_left <-- <fun>
+List.fold_left --> <fun>
+List.fold_left* <-- <poly>
+List.fold_left* --> <fun>
+List.fold_left** <-- []
+List.fold_left** --> <poly>
+List.fold_left** --> <poly>
+List.fold_left** --> <poly>
+List.fold_left** --> <poly>
+- : int = 6
+# 

toplevel/trace.ml

@@ -96,14 +96,18 @@ let rec instrument_result env name ppf clos_typ =
 
 (* Same as instrument_result, but for a toplevel closure (modified in place) *)
 
+exception Dummy
+let _ = Dummy
+
 let instrument_closure env name ppf clos_typ =
   match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
   | Tarrow(l, t1, t2, _) ->
       let trace_res = instrument_result env name ppf t2 in
       (fun actual_code closure arg ->
         if not !may_trace then begin
-          let res = invoke_traced_function actual_code closure arg
-          in res (* do not remove let, prevents tail-call to invoke_traced_ *)
+          try invoke_traced_function actual_code closure arg
+          with Dummy -> assert false
+          (* do not remove handler, prevents tail-call to invoke_traced_ *)
         end else begin
           may_trace := false;
           try