[enhance] stdlib: Provide get_trace instead of print_trace

compiler/qmlcps/qmlCpsClientLib.js

@@ -247,12 +247,14 @@ function update_cont(k, pk, name, pos, args){
     return [k[0], [tc, k[1][1], k[1][2], {name:name, pos:pos, args:args, parent:parent}]];
 }
 
-function print_trace(k){
+function get_cps_trace(k){
+    var res = "";
     var tmp = k[1][3];
     while (tmp != null){
-        console.log("\t", tmp.name, tmp.pos, tmp.args);
+        res += tmp.name + "called at " + tmp.pos + "\n";
         tmp = tmp.parent;
     }
+    return res;
 }
 
 /**

compiler/qmlcps/qmlCpsServerLib.ml

@@ -1,5 +1,5 @@
 (*
-    Copyright © 2011 MLstate
+    Copyright © 2011, 2012 MLstate
 
     This file is part of Opa.
 
@@ -119,8 +119,8 @@ let update_cont cont parent name position args =
                 ; call_position = position
                 ; call_arguments = Obj.repr args } } }
 
-let generic_trace_printer ?(first_line="*** Stack trace:") printer (cont : _ continuation) =
-  Printf.eprintf "%s\n" first_line;
+let generic_trace_printer ?(first_line="*** Stack trace:") printer fmt (cont : _ continuation) =
+  Format.fprintf fmt "%s\n" first_line;
   let rec aux i infos =
     match infos.stack_infos with
     | None -> () (* not calling printer, because this 'infos' a the dummy one introduced above *)
@@ -131,9 +131,9 @@ let generic_trace_printer ?(first_line="*** Stack trace:") printer (cont : _ con
 
 let trace_printer ?(args= #<If:CPS_STACK_TRACE$contains "arg">true#<Else>false#<End>)
                   ?(thread_context= #<If:CPS_STACK_TRACE$contains "th">true#<Else>false#<End>)
-                  ?(transaction_context= #<If:CPS_STACK_TRACE$contains "tr">true#<Else>false#<End>) () =
+                  ?(transaction_context= #<If:CPS_STACK_TRACE$contains "tr">true#<Else>false#<End>) fmt =
   fun index infos stack_infos ->
-    Printf.eprintf "%3d: %20s called at %s%s%s%s\n"
+    Format.fprintf fmt "%3d: %20s called at %s%s%s%s\n"
       index
       stack_infos.callee_name
       stack_infos.call_position
@@ -148,8 +148,17 @@ let trace_printer ?(args= #<If:CPS_STACK_TRACE$contains "arg">true#<Else>false#<
          | None -> ""
          | Some transaction_context -> " with transaction_context=" ^ DebugPrint.print transaction_context
        else "")
-let print_trace_fl first_line cont = generic_trace_printer ~first_line (trace_printer ()) cont
-let print_trace cont = generic_trace_printer (trace_printer ()) cont
+let print_trace_fl first_line cont =
+  generic_trace_printer ~first_line (trace_printer Format.err_formatter)
+    Format.err_formatter cont
+let print_trace cont = generic_trace_printer (trace_printer Format.err_formatter)
+  Format.err_formatter cont
+
+let get_trace cont =
+  let buf = Buffer.create 256 in
+  let fmt = Format.formatter_of_buffer buf in
+  generic_trace_printer (trace_printer fmt) fmt cont;
+  Buffer.contents buf
 
 let thread_context b : _ option = Obj.magic (b.continuation_info.thread_context : Obj.t option)
 let with_thread_context tc b = { b with continuation_info = {b.continuation_info with thread_context = Some (Obj.repr tc) } }
@@ -283,7 +292,7 @@ let push_cont k x =
    initialization, there is not need to schedule in apply or return
    Moreover, this breaks the tail-rec optimization of ocaml code. *)
 let nb_step_apply = ref 10000
-let set_nb_step_apply n = 
+let set_nb_step_apply n =
   nb_step_apply := n
 let max_blocking_step = 1000000
 (* cannot embbed the reference for typing problem *)

compiler/qmlcps/qmlCpsServerLib.mli

@@ -1,5 +1,5 @@
 (*
-    Copyright © 2011 MLstate
+    Copyright © 2011, 2012 MLstate
 
     This file is part of Opa.
 
@@ -81,6 +81,7 @@ val execute : 'a continuation -> 'a -> unit
 
 val update_cont : 'a continuation -> _ continuation option -> string -> string -> _ -> 'a continuation
 val print_trace : 'a continuation -> unit
+val get_trace : 'a continuation -> string
 
 (** [push_cont k x] Like return but asynchronous. Create a task that
     apply the continuation to the value, and push it to the cps

lib/plugins/opabsl/jsbsl/bslCps.js

@@ -398,5 +398,5 @@ var dummy_cont = cont(function(x){return;})
  */
 
 /**
- * @register {continuation('a) -> void} print_trace print_trace
+ * @register {continuation('a) -> string} get_trace get_cps_trace
  */

lib/plugins/opabsl/mlbsl/bslCps.ml

@@ -116,7 +116,7 @@ let user_cont f = QmlCpsServerLib.cont_ml (fun a -> ignore (f a))
 ##register [no-projection] display_backtrace \ `QmlCpsServerLib.display_backtrace` : string -> void
 
 ##register update_cont \ `QmlCpsServerLib.update_cont` : continuation('a), option(continuation(_)), string, string, _ -> continuation('a)
-##register print_trace \ `QmlCpsServerLib.print_trace` : continuation('a) -> void
+##register get_trace \ `QmlCpsServerLib.get_trace` : continuation('a) -> string
 
 ##register [no-projection, restricted : cps] loop_schedule : opa['a] -> void
 let loop_schedule _ = Scheduler.run scheduler

lib/stdlib/core/cps.opa

@@ -86,25 +86,20 @@ Continuation = {{
   make = @may_cps(%%bslcps.user_cont%%) : ('a -> void) -> continuation('a)
 
   /**
-   * This bypass is defined on both sides, but the client implementation is dummy.
-   * This is done so that the code may not be sliced differently if we add some debug
-   * print of the stack trace in the middle of a client-side code.
-  **/
-  print_trace_of = %% bslcps.print_trace %% : continuation('a) -> void
-
-  /**
-   * see {!Continuation.print_trace_of}
-   * applied on the current continuation.
-  **/
-  print_trace() : void =
+   * Get the backtrace of a continuation
+   * @param kind [{current}] to have the current backtrace or [{from : k}] to have
+   *   the backtrace of [k]
+   * @return A string which represents a backtrace.
+   */
+  get_trace(kind) =
     @sliced_expr({
       server =
-        @callcc(k ->
-          do print_trace_of(k)
-          return(k,void)
-      )
-     client = void
-   })
+        match kind with
+        | {current} -> @callcc(k -> return(k, %%bslcps.get_trace%%(k)))
+        | {from = k} -> %%bslcps.get_trace%%(k)
+      client = ""
+    })
+
 }}
 
 

lib/stdlib/core/debug.opa

@@ -1,5 +1,5 @@
 /*
-    Copyright © 2011 MLstate
+    Copyright © 2011, 2012 MLstate
 
     This file is part of Opa.
 
@@ -61,21 +61,21 @@ jlog_if(b: bool, msg: -> string) = if b then jlog(msg()) else void
  */
 error_with_stack(mess: string)=
         @fail(  "ERROR = {mess:string}"
-              ^ "Stack =\n {Continuation.print_trace()}" )
+                ^ "Stack =\n {Continuation.get_trace({current})}" )
 
 /**
  * As {!Debug.jlog}, but also displays the current local stack
  */
 jlog_with_stack(mess: string)=
         jlog(  "ERROR = {mess:string}"
-             ^ "Stack =\n {Continuation.print_trace()}" )
+               ^ "Stack =\n {Continuation.get_trace({current})}" )
 
 /**
  * Return a developer-readable printout of the local stack.
  *
  * This only shows the local stack, not the full client-to-server or server-to-client stack.
  */
-@deprecated({use="Continuation.print_trace"}) get_stack = %% Bslpervasives.get_stack %%
+@deprecated({use="Continuation.get_trace"}) get_stack = %% Bslpervasives.get_stack %%
 
 /**
  * Flush all outputs.