Commits

Anonymous committed 35b2175

Moderate surgery on the scheduler to fix a bad stack leak. The new code is
probably a tiny bit more efficient too, because I got rid of some
unnecessary uses of {Lazy.t} in places, and there is a bit less lifting
between monads. I didn't benchmark it, though.

Comments (0)

Files changed (1)

     fun w ->
         start (loop w) ()
 
-(*---------------------------------------------------------------------------*
-
-(*
-module type X_tag = sig
-    val tag: string
-end
-
-module X_create(T: X_tag) = struct
-    let tag = Printf.sprintf "[%s] " T.tag
-
-    let printf fmt =
-        print_string tag;
-        Printf.printf fmt
-    
-    let sprintf (fmt : ('a, unit, string) format) =
-        Printf.sprintf (Obj.magic (tag ^ (Obj.magic fmt)))
-end
-
-module X = X_create(struct let tag = "Cf_gadget" end)
-*)
-
-type ('i, 'o) kernel_t = {
-    k_rdyQ_: ('i, 'o) work0_t Lazy.t Queue.t;
-    k_inpQ_: ('i -> ('i, 'o) work0_t) Queue.t;
-    mutable k_wireN_: int;
-}
-and ('i, 'o) work0_t =
-    ('i, 'o) kernel_t -> ('i, 'o) Cf_flow.t -> ('i, 'o) Cf_flow.t
-and ('x, 'i, 'o) rx0_t = {
-    rx0_txPtr_: ('x, 'i, 'o) tx0_t Weak.t;
-    rx0_pendQ_: 'x Queue.t;
-}
-and ('x, 'i, 'o) tx0_t = {
-    tx0_rxPtr_: ('x, 'i, 'o) rx0_t Weak.t;
-    tx0_gateQ_: ('x, 'i, 'o) guard0_t Queue.t;
-}
-and ('x, 'i, 'o) guard0_t = {
-    x0_txLst_: (Obj.t, 'i, 'o) tx0_t list;
-    x0_getF_: 'x -> ('i, 'o) work0_t;
-}
-
-type ('x, 'i, 'o) gate0_t = {
-    y0_rx_: ('x, 'i, 'o) rx0_t;
-    y0_getF_: 'x -> ('i, 'o) work0_t;    
-}
-
-type ('x, 'i, 'o) wire_t =
-    (('x, 'i, 'o) rx0_t * ('x, 'i, 'o) tx0_t) option * string Lazy.t
-
-let kernel_ () = {
-    k_rdyQ_ = Queue.create ();
-    k_inpQ_ = Queue.create ();
-    k_wireN_ = 0;
-}
-
-let rx0_ () = {
-    rx0_txPtr_ = Weak.create 1;
-    rx0_pendQ_ = Queue.create ();
-}
-
-let tx0_ () = {
-    tx0_rxPtr_ = Weak.create 1;
-    tx0_gateQ_ = Queue.create ();
-}
-
-let null = None, (Lazy.lazy_from_val "wire[null]")
-
-let scheduler_ k w =
-    print_char '(';
-    flush stdout;
-    match
-        try Some (Queue.take k.k_rdyQ_)
-        with Queue.Empty -> None
-    with
-    | Some r ->
-        print_char '-';
-        flush stdout;
-        let w' = Lazy.force r k w in
-        print_string "+)";
-        flush stdout;
-        w'
-    | None ->
-        try
-            let f = Queue.take k.k_inpQ_ in
-            print_string "@)\n";
-            flush stdout;
-            lazy (Cf_flow.Q (fun i -> Lazy.force (f i k w)))
-        with
-        | Queue.Empty ->
-            print_string "*)\n";
-            flush stdout;
-            Lazy.lazy_from_val Cf_flow.Z
-
-type ('s, 'i, 'o) work_t = ('s -> ('i, 'o) work0_t) -> 's -> ('i, 'o) work0_t
-type ('s, 'i, 'o) gate_t = ('s -> (Obj.t, 'i, 'o) gate0_t) Cf_seq.t
-
-type ('s, 'i, 'o, 'a) guard_t = (('s, 'i, 'o) gate_t, 'a) Cf_cmonad.t
-type ('s, 'i, 'o, 'a) t = (('s, 'i, 'o) work_t, 'a) Cf_cmonad.t
-
-let downX1_ () _ _ = scheduler_
-let downX2_ _ = scheduler_
-
-let eval m s =
-    let k = kernel_ () in
-    m downX1_ downX2_ s k (Lazy.lazy_from_val Cf_flow.Z)
-
-let start m s0 f c s1 k w =
-    Queue.add (lazy (m downX1_ downX2_ s0)) k.k_rdyQ_;
-    f () c s1 k w
-
-let wire f c s k w =
-    let n = succ k.k_wireN_ in
-    k.k_wireN_ <- n;
-    let id = lazy (Printf.sprintf "%08u" n) in
-    let rx = rx0_ () in
-    let tx = tx0_ () in
-    Weak.set tx.tx0_rxPtr_ 0 (Some rx);
-    Weak.set rx.rx0_txPtr_ 0 (Some tx);
-    f (Some (rx, tx), id) c s k w
-
-type ('x, 'i, 'o) match_t =
-    | M_blocked of
-        ('x, 'i, 'o) tx0_t list *
-        (('x, 'i, 'o) tx0_t * ('x -> ('i, 'o) work0_t)) list
-    | M_ready of
-        ('i, 'o) work0_t Lazy.t
-
-let rec match1_ txLst gLst z = 
-    match Lazy.force z with
-    | Cf_seq.Z ->
-        M_blocked (txLst, gLst)
-    | Cf_seq.P (y0, z) ->
-        let { y0_rx_ = rx0; y0_getF_ = getF } = y0 in
-        match Weak.get rx0.rx0_txPtr_ 0 with
-        | None ->
-            match1_ txLst gLst z
-        | Some tx0 ->
-            try
-                let obj = Queue.take rx0.rx0_pendQ_ in
-                M_ready (lazy (getF obj))
-            with
-            | Queue.Empty ->
-                match1_ (tx0 :: txLst) ((tx0, getF) :: gLst) z
-
-let guard m _ _ s k w =
-    let z = Cf_seq.map (fun g -> g s) (Cf_seq.evalC m) in
-    let () =
-        match match1_ [] [] z with
-        | M_ready rdy ->
-            Queue.add rdy k.k_rdyQ_;
-        | M_blocked (txLst, gLst) ->
-            List.iter begin fun (tx0, getF) ->
-                let g = { x0_txLst_ = txLst; x0_getF_ = getF } in
-                Queue.add g tx0.tx0_gateQ_
-            end gLst
-    in
-    scheduler_ k w
-
-class type connector =
-    object
-        method check: bool
-        method id: string
-    end
-
-class ['x, 'i, 'o] rx (w, id : ('x, 'i, 'o) wire_t) =
-    let rx0 =
-        match w with
-        | Some (rx0, _) -> rx0
-        | None -> rx0_ ()
-    in
-    object        
-        val rx0_ = rx0
-        
-        method id = Lazy.force id
-        method check = Weak.check rx0_.rx0_txPtr_ 0
-
-        method get:
-            's. ('x -> ('s, 'i, 'o, unit) t) -> ('s, 'i, 'o, unit) guard_t =
-            fun f ->
-                if Weak.check rx0_.rx0_txPtr_ 0 then begin
-                    Cf_seq.writeC begin fun s ->
-                        let g obj = f obj downX1_ downX2_ s in
-                        Obj.magic { y0_rx_ = rx0; y0_getF_ = g }
-                    end
-                end
-                else begin
-                    Queue.clear rx0_.rx0_pendQ_;
-                    Cf_cmonad.return ()
-                end
-    end
-
-class ['x, 'i, 'o] tx (w, id : ('x, 'i, 'o) wire_t) =
-    let tx0 =
-        match w with
-        | Some (_, tx0) -> tx0
-        | None -> tx0_ ()
-    in
-    object        
-        val tx0_ = tx0
-
-        method id = Lazy.force id
-        method check = Weak.check tx0_.tx0_rxPtr_ 0
-        
-        method put:
-            's. 'x -> ('s, 'i, 'o, unit) t =
-            fun obj f c s k w ->
-                begin
-                    try
-                        let x0 = Queue.take tx0.tx0_gateQ_ in
-                        let x0: (Obj.t, 'i, 'o) guard0_t = Obj.magic x0 in
-                        let obj = Obj.repr obj in
-                        List.iter begin fun tx0 ->
-                            let q = Queue.create () in
-                            Queue.iter begin fun x0' ->
-                                if x0'.x0_txLst_ != x0.x0_txLst_ then
-                                    Queue.add x0' q
-                            end tx0.tx0_gateQ_;
-                            Queue.clear tx0.tx0_gateQ_;
-                            Queue.transfer q tx0.tx0_gateQ_
-                        end x0.x0_txLst_;
-                        Queue.add (lazy (x0.x0_getF_ obj)) k.k_rdyQ_
-                    with
-                    | Queue.Empty ->
-                        match Weak.get tx0_.tx0_rxPtr_ 0 with
-                        | None ->
-                            Queue.clear tx0_.tx0_gateQ_
-                        | Some rx0 ->
-                            Queue.add obj rx0.rx0_pendQ_
-                end;
-                if Queue.is_empty k.k_rdyQ_ then begin
-                    f () c s k w
-                end
-                else begin
-                    Queue.add (lazy (f () c s)) k.k_rdyQ_;
-                    scheduler_ k w
-                end
-    end
-
-type ('a, 'i, 'o) simplex_t = ('a, 'i, 'o) rx * ('a, 'i, 'o) tx
-
-let fsimplex ~f g1 =
-    let g2 ch =
-        let rx, tx = f ch in
-        let rx = (rx :> ('a, 'i, 'o) rx) in
-        let tx = (tx :> ('a, 'i, 'o) tx) in
-        g1 (rx, tx)
-    in
-    wire g2
-
-let simplex f = wire (fun ch -> f (new rx ch, new tx ch))
-
-type ('a, 'b, 'i, 'o) duplex_t =
-    (('a, 'i, 'o) rx * ('b, 'i, 'o) tx) * (('b, 'i, 'o) rx * ('a, 'i, 'o) tx)
-
-let read f g s k w =
-    Queue.add (fun i -> f i g s) k.k_inpQ_;
-    scheduler_ k w
-
-let write o f c s k w = lazy (Cf_flow.P (o, f () c s k w))
-
-let load p c s = (p s) c s
-let store s f c _ = f () c s
-let modify f p c s = p () c (f s)
-
-open Cf_cmonad.Op
-
-let duplex f =
-    begin
-        simplex >>= fun (rx1, tx1) ->
-        simplex >>= fun (rx2, tx2) ->
-        Cf_cmonad.return ((rx1, tx2), (rx2, tx1))
-    end f
-
-let wrap x y =
-    let x = (x :> ('x, 'i, 'o) rx) in
-    let y = (y :> ('y, 'i, 'o) tx) in
-    let rec loop w =
-        match Lazy.force w with
-        | Cf_flow.Z ->
-            Cf_cmonad.return ()
-        | Cf_flow.P (hd, tl) ->
-            y#put hd >>= fun () ->
-            loop tl
-        | Cf_flow.Q f ->
-            guard (x#get (fun obj -> loop (lazy (f obj))))
-    in
-    fun w ->
-        start (loop w) ()
- *---------------------------------------------------------------------------*)
-
 (*--- End of File [ cf_gadget.ml ] ---*)