(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_gadget.ml

  Copyright (c) 2004-2006, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*)

(*** CAN WE MAKE THIS A PURE FUNCTIONAL IMPLEMENTATION? ***)

module IMap = Cf_rbtree.Map(Cf_ordered.Int_order)

type wref = Wire of int * wref Weak.t * string option

type ('i, 'o, 'a) t = (('i, 'o) work, 'a) Cf_cmonad.t
and ('i, 'o) work = (('i, 'o) state, ('i, 'o) Cf_flow.t, unit) Cf_scmonad.t
and ('i, 'o) gate = (wref * (Obj.t -> ('i, 'o, unit) t)) Cf_seq.t
and ('i, 'o) state = {
    wireN: int;
    freeWireQ: int Cf_deque.t;
    wirePtrQ: (int * wref Weak.t) Cf_deque.t;
    msgQM: Obj.t Cf_deque.t IMap.t;
    readyQ: ('i, 'o) work Cf_deque.t;
    guardQ: ('i, 'o) gate Cf_deque.t;
    inputQ: ('i -> ('i, 'o) work) Cf_deque.t;
}

type ('x, 'i, 'o) wire = wref * wref

type ('i, 'o, 'a) guard = (('i, 'o) gate, 'a) Cf_cmonad.t

open Cf_scmonad.Op

type void = Void

type ('i, 'o) gateloop =
    | L_ready of Obj.t Cf_deque.t IMap.t * ('i, 'o) work
    | L_pending of ('i, 'o) gate
    | L_discard

let rec scheduler_ Void =
    Cf_scmonad.load >>= fun k ->
    let m, gQ, rQ = guardLoop_ k.msgQM k.guardQ Cf_deque.nil Cf_deque.nil in
    let run work rQ i =
        let k = { k with msgQM = m; readyQ = rQ; guardQ = gQ; inputQ = i } in
        Cf_scmonad.store k >>= fun () ->
        work
    in
    let rQ = Cf_deque.catenate rQ k.readyQ in
    match Cf_deque.B.pop rQ with
    | Some (hd, tl) ->
        run hd tl k.inputQ
    | None ->
        match Cf_deque.B.pop k.inputQ with
        | None ->
            Cf_scmonad.nil
        | Some (input, inputQ) ->
            Cf_flow.readSC >>= fun i ->
            let work = input i in
            let rQ = Cf_deque.map (fun f -> f i) inputQ in
            run work rQ Cf_deque.nil

and guardLoop_ m gQ gQ' rQ' =
    match Cf_deque.B.pop gQ with
    | None ->
        m, gQ', rQ'
    | Some (hd, tl) ->
        match gateLoop_ m hd Cf_deque.nil with
        | L_ready (m, r) ->
            guardLoop_ m tl gQ' (Cf_deque.A.push r rQ')
        | L_pending g ->
            guardLoop_ m tl (Cf_deque.B.push g gQ') rQ'
        | L_discard ->
            guardLoop_ m tl gQ' rQ'

and gateLoop_ m z q =
    match Lazy.force z with
    | Cf_seq.Z when Cf_deque.empty q ->
        L_discard
    | Cf_seq.Z ->
        L_pending (Cf_deque.B.to_seq q)
    | Cf_seq.P ((Wire (n, ptr, _), f as g), z) ->
        match try Some (IMap.extract n m) with Not_found -> None with
        | Some (q, m) ->
            assert (not (Cf_deque.empty q));
            let msg = Cf_deque.B.head q in
            let q = Cf_deque.B.tail q in
            let m = if Cf_deque.empty q then m else IMap.replace (n, q) m in
            let work = Cf_cmonad.eval (f msg) (scheduler_ Void) in
            L_ready (m, work)
        | None ->
            gateLoop_ m z (if Weak.check ptr 0 then Cf_deque.A.push g q else q)

let state0_ = {
    wireN = 1;
    freeWireQ = Cf_deque.nil;
    wirePtrQ = Cf_deque.nil;
    msgQM = IMap.nil;
    readyQ = Cf_deque.nil;
    guardQ = Cf_deque.nil;
    inputQ = Cf_deque.nil;
}

let eval m =
    Cf_cmonad.eval begin
        Cf_cmonad.Op.( >>= )
            (Cf_scmonad.down (Cf_cmonad.eval m (scheduler_ Void)) state0_)
            (fun _ -> Cf_cmonad.nil)
    end Cf_flow.nil

let start m c =
    let work = Cf_cmonad.eval m (scheduler_ Void) in
    Cf_scmonad.modify begin fun k ->
        { k with readyQ = Cf_deque.A.push work k.readyQ }
    end >>= c

let guard m _ =
    let guard = Cf_cmonad.eval m Cf_seq.nil in
    Cf_scmonad.modify begin fun k ->
        { k with guardQ = Cf_deque.A.push guard k.guardQ }
    end >>= fun () ->
    scheduler_ Void

let abort _ = scheduler_ Void

let wireAux0_ ?id n =
    let rxPtr = Weak.create 1 and txPtr = Weak.create 1 in
    let rx = Wire (n, txPtr, id) and tx = Wire (n, txPtr, id) in
    Weak.set rxPtr 0 (Some tx);
    Weak.set txPtr 0 (Some rx);
    rx, tx

let wireAux1_ ?id wireN freeWireQ wirePtrQ =
    match Cf_deque.B.pop freeWireQ with
    | Some (n, q) ->
        wireN, q, wirePtrQ, wireAux0_ ?id n
    | None ->
        let n = wireN in
        let rx, tx as wire = wireAux0_ ?id n in
        let ptr = Weak.create 2 in
        Weak.set ptr 0 (Some rx);
        Weak.set ptr 1 (Some tx);
        let wirePtrQ = Cf_deque.A.push (n, ptr) wirePtrQ in
        succ n, freeWireQ, wirePtrQ, wire

let wireAux_ ?id c =
    Cf_scmonad.load >>= fun k ->
    let { wireN = n; freeWireQ = fQ; wirePtrQ = pQ } = k in
    let n, fQ, pQ, wire = wireAux1_ ?id n fQ pQ in
    let k = { k with wireN = n; freeWireQ = fQ; wirePtrQ = pQ } in
    Cf_scmonad.store k >>= fun () ->
    c wire

let wirepairAux_ ?id c =
    Cf_scmonad.load >>= fun k ->
    let { wireN = n; freeWireQ = fQ; wirePtrQ = pQ } = k in
    let n, fQ, pQ, wire1 = wireAux1_ ?id n fQ pQ in
    let n, fQ, pQ, wire2 = wireAux1_ ?id n fQ pQ in
    let k = { k with wireN = n; freeWireQ = fQ; wirePtrQ = pQ } in
    Cf_scmonad.store k >>= fun () ->
    c (wire1, wire2)

let wire c = wireAux_ c
let wirepair c = wirepairAux_ c

let nullAux_ = Wire (0, Weak.create 1, Some "null")
let null c = c (nullAux_, nullAux_)

let read f =
    Cf_scmonad.modify begin fun k ->
        { k with inputQ = Cf_deque.A.push f k.inputQ }
    end >>= fun () ->
    scheduler_ Void

let write x c = Cf_flow.writeSC x >>= c

let rxGet_ (Wire (_, txPtr, _) as wref) f c =
    if Weak.check txPtr 0 then begin
        let f: Obj.t -> ('i, 'o, unit) t = Obj.magic f in
        Cf_seq.writeC (wref, f) c
    end
    else
        c ()

let txPut_ (Wire (n, rxPtr, _)) x c =
    if Weak.check rxPtr 0 then begin
        Cf_scmonad.modify begin fun k ->
            let m =
                let x = Obj.repr x in
                try
                    IMap.modify n (Cf_deque.A.push x) k.msgQM
                with
                | Not_found ->
                    IMap.replace (n, Cf_deque.A.push x Cf_deque.nil) k.msgQM
            in
            let rQ = Cf_deque.A.push (c ()) k.readyQ in
            { k with msgQM = m; readyQ = rQ }
        end >>= fun () ->
        scheduler_ Void
    end
    else
        c ()

class connector (Wire (n, ptr, id)) =
    let id =
        match id with
        | Some id -> Lazy.lazy_from_val id
        | None -> lazy (Printf.sprintf "wire%08u" n)
    in
    object
        method id = Lazy.force id
        method check = Weak.check ptr 0
    end

class ['x, 'i, 'o] rx (wref, _ : ('x, 'i, 'o) wire) = object
    inherit connector wref
    
    method get: ('x -> ('i, 'o, unit) t) -> ('i, 'o, unit) guard = fun f c ->
        rxGet_ wref f c
end

class ['x, 'i, 'o] tx (_, wref : ('x, 'i, 'o) wire) = object
    inherit connector wref
    
    method put: 'x -> ('i, 'o, unit) t = fun x c -> txPut_ wref x c
end

let connect m c = m (fun w -> c (new rx w, new tx w))
let simplex c = connect wire c

type ('x, 'y, 'i, 'o) pad = ('x, 'i, 'o) rx * ('y, 'i, 'o) tx
type ('x, 'y, 'i, 'o) fix = ('y, 'i, 'o) rx * ('x, 'i, 'o) tx

let connectpair m c =
    let f (a, b) = c ((new rx a, new tx b), (new rx b, new tx a)) in
    m f

let duplex c = connectpair wirepair c

let wrap x y =
    let x = (x :> ('x, 'i, 'o) rx) in
    let y = (y :> ('y, 'i, 'o) tx) in
    let rec loop w cc =
        match Lazy.force w with
        | Cf_flow.Z -> cc ()
        | Cf_flow.P (hd, tl) -> y#put hd (fun () -> loop tl cc)
        | Cf_flow.Q f -> guard (x#get (fun i -> loop (lazy (f i)))) cc
    in
    fun w ->
        start (loop w)

class virtual ['i, 'o] next = object(self)
    method private virtual guard: ('i, 'o, unit) guard
    method next: 'a. ('i, 'o, 'a) t = guard self#guard
end

class virtual ['i, 'o] start = object(self)
    method private virtual guard: ('i, 'o, unit) guard
    method start: ('i, 'o, unit) t = start (guard self#guard)
end

let create f c = duplex (fun (x, y) -> (f x)#start (fun () -> c y))
let createM f c = duplex (fun (x, y) -> f x (fun m -> m#start (fun () -> c y)))

(*--- End of File [ cf_gadget.ml ] ---*)
