Skip to content
Browse files

[enhance] stdlib: Provide get_trace instead of print_trace

  • Loading branch information...
1 parent ed1bfbc commit 19c35213fcfeefd534eb6bfc434c442807a833a6 @BourgerieQuentin BourgerieQuentin committed Oct 11, 2012
View
6 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;
}
/**
View
25 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 *)
View
3 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
View
2 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
*/
View
2 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
View
29 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 = ""
+ })
+
}}
View
8 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.

0 comments on commit 19c3521

Please sign in to comment.
Something went wrong with that request. Please try again.