Permalink
Browse files

[cleanup] bsl: opacapize cpsRewriter

  • Loading branch information...
Raja Thomas Refis
Raja authored and Thomas Refis committed Sep 13, 2011
1 parent 64d71ea commit 4756eb92630e7284e0ea52969b1b1fb1c0abd5a6
Showing with 87 additions and 73 deletions.
  1. +31 −31 opabsl/mlbsl/bslCps.ml
  2. +26 −0 opacapi/opacapi.ml
  3. +30 −42 qmlcps/qmlCpsRewriter.ml
View
@@ -32,7 +32,7 @@
Runtime debug output. Based on {b MLSTATE_CPS_DEBUG}.
@see 'debugVariables.ml' for details
*)
-##register debug : int, string -> void
+##register [opacapi] debug : int, string -> void
let debug __minlevel __s =
#<If:CPS_DEBUG$minlevel __minlevel>
Printf.fprintf stderr "[Cps] %s\n%!" __s
@@ -49,41 +49,41 @@ let debug __minlevel __s =
let qml_unit = ServerLib.make_record ServerLib.empty_record_constructor
-##register [no-projection, restricted : cps] wait \ `QmlCpsServerLib.wait` : Cps.future('a), continuation('a) -> void
-##register [no-projection : cps, restricted : cps] spawn \ `QmlCpsServerLib.spawn` : (_unit, continuation('a) -> _unit) -> Cps.future('a)
+##register [opacapi, no-projection, restricted : cps] wait \ `QmlCpsServerLib.wait` : Cps.future('a), continuation('a) -> void
+##register [opacapi, no-projection : cps, restricted : cps] spawn \ `QmlCpsServerLib.spawn` : (_unit, continuation('a) -> _unit) -> Cps.future('a)
(* Fixme: Check with Valentin. extern _unit ?? *)
-##register [no-projection : cps, restricted : cps] callcc_directive \ `QmlCpsServerLib.callcc_directive` : \
+##register [opacapi, no-projection : cps, restricted : cps] callcc_directive \ `QmlCpsServerLib.callcc_directive` : \
(continuation('a), _unit_continuation -> _unit), continuation('a) -> _unit
(* thread_context needs a projection because of the returned option *)
-##register [no-projection : cps] thread_context \ `QmlCpsServerLib.thread_context` : continuation('a) -> option(opa['thread_context])
-##register [no-projection, restricted : cps] with_thread_context \ `QmlCpsServerLib.with_thread_context` : opa['b], continuation('a) -> continuation('a)
-##register [no-projection, restricted : cps] handler_cont \ `QmlCpsServerLib.handler_cont` : continuation('a) -> continuation('c)
-##register [no-projection : cps, restricted : cps] catch_native \ `QmlCpsServerLib.catch_ml` : \
+##register [opacapi, no-projection : cps] thread_context \ `QmlCpsServerLib.thread_context` : continuation('a) -> option(opa['thread_context])
+##register [opacapi, no-projection, restricted : cps] with_thread_context \ `QmlCpsServerLib.with_thread_context` : opa['b], continuation('a) -> continuation('a)
+##register [opacapi, no-projection, restricted : cps] handler_cont \ `QmlCpsServerLib.handler_cont` : continuation('a) -> continuation('c)
+##register [opacapi, no-projection : cps, restricted : cps] catch_native \ `QmlCpsServerLib.catch_ml` : \
(opa['c], continuation('a) -> _unit), continuation('a) -> continuation('a)
-##register [no-projection : cps, restricted : cps] catch \ `QmlCpsServerLib.catch` : Closure.t, continuation('a) -> continuation('a)
-##register [no-projection : cps, restricted : cps] cont_native \ `QmlCpsServerLib.cont_ml` : ('a -> _unit) -> continuation('a)
-##register [no-projection : cps, restricted : cps] cont \ `QmlCpsServerLib.cont` : Closure.t -> continuation('a)
-
-##register [no-projection : cps, restricted : cps] ccont_native \ `QmlCpsServerLib.ccont_ml` : continuation('d), ('a -> _unit) -> continuation('a)
-##register [no-projection : cps, restricted : cps] ccont \ `QmlCpsServerLib.ccont` : continuation('d), Closure.t -> continuation('a)
-##register [no-projection, restricted : cps] return \ `QmlCpsServerLib.return` : continuation('a), 'a -> void
-##register [no-projection, restricted : cps] magic_func \ `QmlCpsServerLib.magic_func` : func('a, 'd) -> func('e, 'f)
-##register [no-projection, restricted : cps] make_barrier \ `QmlCpsServerLib.make_barrier` : string -> Cps.future('a)
-##register [no-projection, restricted : cps] black_make_barrier \ `QmlCpsServerLib.black_make_barrier` : string -> black_future
-##register [no-projection, restricted : cps] release_barrier \ `QmlCpsServerLib.release_barrier` : Cps.future('a), 'a -> void
-##register [no-projection, restricted : cps] black_release_barrier \ `QmlCpsServerLib.black_release_barrier` : black_future, 'a -> void
-
-##register [no-projection, restricted : cps] uncps_native : string, continuation('d), (continuation('a) -> _unit) -> 'a
+##register [opacapi, no-projection : cps, restricted : cps] catch \ `QmlCpsServerLib.catch` : Closure.t, continuation('a) -> continuation('a)
+##register [opacapi, no-projection : cps, restricted : cps] cont_native \ `QmlCpsServerLib.cont_ml` : ('a -> _unit) -> continuation('a)
+##register [opacapi, no-projection : cps, restricted : cps] cont \ `QmlCpsServerLib.cont` : Closure.t -> continuation('a)
+
+##register [opacapi, no-projection : cps, restricted : cps] ccont_native \ `QmlCpsServerLib.ccont_ml` : continuation('d), ('a -> _unit) -> continuation('a)
+##register [opacapi, no-projection : cps, restricted : cps] ccont \ `QmlCpsServerLib.ccont` : continuation('d), Closure.t -> continuation('a)
+##register [opacapi, no-projection, restricted : cps] return \ `QmlCpsServerLib.return` : continuation('a), 'a -> void
+##register [opacapi, no-projection, restricted : cps] magic_func \ `QmlCpsServerLib.magic_func` : func('a, 'd) -> func('e, 'f)
+##register [opacapi, no-projection, restricted : cps] make_barrier \ `QmlCpsServerLib.make_barrier` : string -> Cps.future('a)
+##register [opacapi, no-projection, restricted : cps] black_make_barrier \ `QmlCpsServerLib.black_make_barrier` : string -> black_future
+##register [opacapi, no-projection, restricted : cps] release_barrier \ `QmlCpsServerLib.release_barrier` : Cps.future('a), 'a -> void
+##register [opacapi, no-projection, restricted : cps] black_release_barrier \ `QmlCpsServerLib.black_release_barrier` : black_future, 'a -> void
+
+##register [opacapi, no-projection, restricted : cps] uncps_native : string, continuation('d), (continuation('a) -> _unit) -> 'a
##register [no-projection, restricted : cps] uncps : string, continuation('d), Closure.t -> 'a
let uncps_ml = QmlCpsServerLib.uncps_ml
let uncps_native = uncps_ml
let uncps = QmlCpsServerLib.uncps
-##register [no-projection, restricted : cps] before_wait \ `QmlCpsServerLib.before_wait` : -> void
+##register [opacapi, no-projection, restricted : cps] before_wait \ `QmlCpsServerLib.before_wait` : -> void
-##register [no-projection, restricted : cps] toplevel_wait : Cps.future('a) -> 'a
+##register [opacapi, no-projection, restricted : cps] toplevel_wait : Cps.future('a) -> 'a
let toplevel_wait b =
let is_released () = QmlCpsServerLib.is_released b in
#<If:CPS_BLOCKING_WAIT>
@@ -92,7 +92,7 @@ let toplevel_wait b =
let () = Scheduler.loop_until BslScheduler.opa is_released in
QmlCpsServerLib.toplevel_wait b
-##register [no-projection, restricted : cps] black_toplevel_wait : black_future -> 'a
+##register [opacapi, no-projection, restricted : cps] black_toplevel_wait : black_future -> 'a
let black_toplevel_wait (black : QmlCpsServerLib.black_future) =
let b = (( Obj.magic black ) : _ QmlCpsServerLib.future ) in
toplevel_wait b
@@ -111,9 +111,9 @@ let user_cont_cps f k =
##register user_cont : ('a -> void) -> continuation('a)
let user_cont f = QmlCpsServerLib.cont_ml (fun a -> ignore (f a))
-##register [no-projection] bt_add \ `QmlCpsServerLib.bt_add` : string -> void
+##register [opacapi, no-projection] bt_add \ `QmlCpsServerLib.bt_add` : string -> void
##register [no-projection] bt_take \ `QmlCpsServerLib.bt_take` : -> string
-##register [no-projection] fun_args2string \ `QmlCpsServerLib.fun_args2string` : string, 'a -> string
+##register [opacapi, no-projection] fun_args2string \ `QmlCpsServerLib.fun_args2string` : string, 'a -> string
(* The argument is the first world displayed, e.g. "Raised" or "Interrupted" *)
##register [no-projection] display_backtrace \ `QmlCpsServerLib.display_backtrace` : string -> void
@@ -131,18 +131,18 @@ let loop_schedule _ = Scheduler.run BslScheduler.opa
##module Notcps_compatibility
let fatal_error = fun s -> Logger.critical "%s" s; BslSys.do_exit 1
- ##register [no-projection, restricted : cps] dummy_cont : continuation(void)
+ ##register [opacapi, no-projection, restricted : cps] dummy_cont : continuation(void)
let dummy_cont = QmlCpsServerLib.cont_ml (fun x -> x)
(** return always None *)
-##register thread_context : opa['g] -> option(opa['c])
+##register [opacapi] thread_context : opa['g] -> option(opa['c])
let thread_context _ = None
(** identity, ignore the context *)
-##register with_thread_context : opa['g], 'a -> 'a
+ ##register with_thread_context : opa['g], 'a -> 'a
let with_thread_context _ a = a
-##register callcc_directive : (continuation('a) -> void) -> 'a
+ ##register callcc_directive : (continuation('a) -> void) -> 'a
let callcc_directive f =
QmlCpsServerLib.uncps_ml "CheatedCALLCC"
(QmlCpsServerLib.cont_ml (fun () -> ()))
View
@@ -524,10 +524,36 @@ struct
module BslCps =
struct
let (!!) s = !! ("BslCps." ^ s)
+ let before_wait = !! "before_wait"
+ let black_make_barrier = !! "black_make_barrier"
+ let black_release_barrier = !! "black_release_barrier"
+ let black_toplevel_wait = !! "black_toplevel_wait"
+ let bt_add = !! "bt_add"
+ let callcc_directive = !! "callcc_directive"
+ let catch = !! "catch"
+ let catch_native = !! "catch_native"
+ let ccont = !! "ccont"
+ let ccont_native = !! "ccont_native"
+ let cont = !! "cont"
+ let cont_native = !! "cont_native"
+ let debug = !! "debug"
+ let fun_args2string = !! "fun_args2string"
+ let handler_cont = !! "handler_cont"
+ let magic_func = !! "magic_func"
+ let make_barrier = !! "make_barrier"
+ let release_barrier = !! "release_barrier"
+ let return = !! "return"
+ let spawn = !! "spawn"
+ let thread_context = !! "thread_context"
+ let toplevel_wait = !! "toplevel_wait"
+ let uncps_native = !! "uncps_native"
+ let wait = !! "wait"
+ let with_thread_context = !! "with_thread_context"
module Notcps_compatibility =
struct
let (!!) s = !! ("Notcps_compatibility." ^ s)
let thread_context = !! "thread_context"
+ let dummy_cont = !! "dummy_cont"
end
end
Oops, something went wrong.

0 comments on commit 4756eb9

Please sign in to comment.