More Fair Scheduling

This is just a small addition to the fair scheduling, to make it reset the priorities before they overflow to negative infinity. The constant should be chosen to make sure this won't happen for the specific system...

I should make testing this code my next priority.

(* Priority Queue *)

(* Tasks are of type unit -> unit *)
type priority_queue = {mutable tasklist: ((unit -> unit) * float) option array; mutable next: int}

let new_priority_queue = {tasklist = Array.make 2 None; next = 1}

let rec sift_up place pq =
  if (place > 1) then match (pq.tasklist.(place), pq.tasklist.(place/2)) with
    (None, p) -> ()
  | (Some (t1,f1), Some (t2,f2)) when f1 <= f2 -> ()
  | (Some (t1,f1), Some (t2,f2)) when f1 > f2 ->
      pq.tasklist.(place)   <- Some (t2, f2);
      pq.tasklist.(place/2) <- Some (t1, f1);
      sift_up (place/2) pq;
  | (q, r) -> raise (Invalid_argument "sift_up");;

let double_size pq =
  pq.tasklist <- Array.append pq.tasklist (Array.make (Array.length pq.tasklist) None);;

let push_item item priority pq =
  (if not (pq.next < Array.length pq.tasklist) then double_size pq);
  pq.tasklist.(pq.next) <- Some (item, priority);
  sift_up pq.next pq;
  pq.next <- (pq.next + 1);;

let rec sift_down place pq =
  if place*2 < Array.length pq.tasklist then
    if place*2+1 < pq.next then
      let (largervalue,largerplace) =
        (match (pq.tasklist.(place*2), pq.tasklist.(place*2+1)) with
          (Some (t1,f1), Some (t2,f2)) when f1 < f2 -> (f2,place*2+1)
        | (Some (t1,f1), Some (t2,f2))              -> (f1,place*2)
        | _ -> raise (Invalid_argument "sift_down") )
      in
      match pq.tasklist.(place) with
        Some (t,f) when f < largervalue ->
          (pq.tasklist.(place) <- pq.tasklist.(largerplace);
           pq.tasklist.(largerplace) <- Some (t,f);
           sift_down largerplace pq )
      | Some (t,f) -> ()
      | _ -> raise (Invalid_argument "sift_down")
    else if place*2 < pq.next then
      match pq.tasklist.(place) with
        Some (t,f) when f < (match pq.tasklist.(place*2) with Some (t,f) -> f | _ -> 0.0) ->
          (pq.tasklist.(place) <- pq.tasklist.(place*2);
           pq.tasklist.(place*2) <- Some (t,f) )
      | Some (t,f) -> ()
      | _ -> raise (Invalid_argument "sift_down");;


let pop_item pq =
  let result = pq.tasklist.(1) in
  pq.tasklist.(1) <- pq.tasklist.(pq.next-1);
  pq.tasklist.(pq.next-1) <- None;
  if pq.next > 1 then pq.next <- pq.next-1;
  sift_down 1 pq;
  result;;

let loop_items pq =
  while not (pq.tasklist.(1) = None) do
    match pop_item pq with
      Some (item,f) ->
    item();
    |  None -> ()
  done;;

(* Fair Scheduler, implemented as a persistent codelet *)

type supertask_data = {parentq: priority_queue;
            childq: priority_queue;
            ratio: float;
            mutable priority: float}

let rec supertask data unit =
  let starttime =
    Unix.gettimeofday() in
  (match (pop_item data.childq) with
    Some (item, f) ->
      item();
  | None -> ());
  let tasktime =
    (Unix.gettimeofday() -. starttime) /. data.ratio  in
  data.priority <- (data.priority -. tasktime);
  push_item
    (supertask data)
    data.priority
    data.parentq;;

let min = -9999.0;
 
let rec reset_utils pq unit =
  Array.iter
    (fun t ->
      match t with
    Some (t, f) -> Some (t, f -. min)
      |    None -> None)
    pq.tasklist;
  push_item (reset_utils pq) min pq;;

Fair Scheduling on a Priority Queue

I'm in St. Luis for a math conference! The time zone is different, but it's still after midnight. This merges the past two projects, implementing the fair scheduler on the priority queue (which should be a performance gain, in theory).

Here is the (untested!) code.

(* Priority Queue *)

(* Tasks are of type unit -> unit *)
type priority_queue = {mutable tasklist: ((unit -> unit) * float) option array; mutable next: int}

let new_priority_queue = {tasklist = Array.make 2 None; next = 1}

let rec sift_up place pq =
  if (place > 1) then match (pq.tasklist.(place), pq.tasklist.(place/2)) with
    (None, p) -> ()
  | (Some (t1,f1), Some (t2,f2)) when f1 <= f2 -> ()
  | (Some (t1,f1), Some (t2,f2)) when f1 > f2 ->
      pq.tasklist.(place)   <- Some (t2, f2);
      pq.tasklist.(place/2) <- Some (t1, f1);
      sift_up (place/2) pq;
  | (q, r) -> raise (Invalid_argument "sift_up");;

let double_size pq =
  pq.tasklist <- Array.append pq.tasklist (Array.make (Array.length pq.tasklist) None);;

let push_item item priority pq =
  (if not (pq.next < Array.length pq.tasklist) then double_size pq);
  pq.tasklist.(pq.next) <- Some (item, priority);
  sift_up pq.next pq;
  pq.next <- (pq.next + 1);;

let rec sift_down place pq =
  if place*2 < Array.length pq.tasklist then
    if place*2+1 < pq.next then
      let (largervalue,largerplace) =
        (match (pq.tasklist.(place*2), pq.tasklist.(place*2+1)) with
          (Some (t1,f1), Some (t2,f2)) when f1 < f2 -> (f2,place*2+1)
        | (Some (t1,f1), Some (t2,f2))              -> (f1,place*2)
        | _ -> raise (Invalid_argument "sift_down") )
      in
      match pq.tasklist.(place) with
        Some (t,f) when f < largervalue ->
          (pq.tasklist.(place) <- pq.tasklist.(largerplace);
           pq.tasklist.(largerplace) <- Some (t,f);
           sift_down largerplace pq )
      | Some (t,f) -> ()
      | _ -> raise (Invalid_argument "sift_down")
    else if place*2 < pq.next then
      match pq.tasklist.(place) with
        Some (t,f) when f < (match pq.tasklist.(place*2) with Some (t,f) -> f | _ -> 0.0) ->
          (pq.tasklist.(place) <- pq.tasklist.(place*2);
           pq.tasklist.(place*2) <- Some (t,f) )
      | Some (t,f) -> ()
      | _ -> raise (Invalid_argument "sift_down");;


let pop_item pq =
  let result = pq.tasklist.(1) in
  pq.tasklist.(1) <- pq.tasklist.(pq.next-1);
  pq.tasklist.(pq.next-1) <- None;
  if pq.next > 1 then pq.next <- pq.next-1;
  sift_down 1 pq;
  result;;

let loop_items pq =
  while not (pq.tasklist.(1) = None) do
    match pop_item pq with
      Some (item,f) ->
    item();
    |  None -> ()
  done;;

(* Fair Scheduler, implemented as a persistent codelet *)

type supertask_data = {parentq: priority_queue;
            childq: priority_queue;
            ratio: float;
            mutable priority: float}

let rec supertask data unit =
  let starttime =
    Unix.gettimeofday() in
  (match (pop_item data.childq) with
    Some (item, f) ->
      item();
  | None -> ());
  let tasktime =
    (Unix.gettimeofday() -. starttime) /. data.ratio  in
  data.priority <- (data.priority -. tasktime);
  push_item
    (supertask data)
    data.priority
    data.parentq;;
 

April 11

Didn't finish what I started; may be finished tomorrow. After that, I probably won't get much opportunity to post for a few days; I'm on the road again.

April 7, 8, 9

Ok. I've been on the road quite a bit the last two days. More emacs-learning (and a little more actual programming) happened, but I didn't manage to get a post up. Today is something along similar lines to the priority queue: a fair scheduler. Written with the help of Emacs ocaml mode.

Thanks to the use of the Unix module, this needs to be linked with unix.cma at compile time (or run in an interpreter which has unix.cma loaded).

type 'qtype taskqueue =
    {queue: 'qtype;
      dotask: unit -> unit;
    target: float;
    mutable error: float}
     
let itertask taskqlist =
  let starttime =
    Unix.gettimeofday()
  and nextq =
    List.fold_left
      (fun a b -> if a.error > b.error then a else b)
      (List.hd taskqlist)
      taskqlist
  in let  nextqerror = nextq.error
  in
  nextq.dotask();
  let tasktime =
    Unix.gettimeofday() -. starttime in
  List.iter
    (fun q -> if q = nextq then
      q.error <- q.error -. nextqerror +. (tasktime /. nextq.target) )
    taskqlist;;

What Happened to April 6?

I missed a day due to trying to figure out Emacs. I've been programming with a plain text editor and command line, so naturally I was pressured by fellow programmers to do things the right way-- choose an IDE. In particular, I was advised to use Emacs. Ideally I'd like to spend just 1 hour a day for these daily exercises, and starting with Emacs took way longer than that.

So far: frustrating.

Development environments have always been a problem for me. They seem to suck up more time than they save (mostly in dealing with configuration). Maybe that's partly because I need to stick with one long-term so that I get a real feel for it; so far, though, I've found it more convenient to just avoid them altogether.

So, I spent a day trying to figure out what exactly I'm supposed to "do" with Emacs. Specifically, I decided to figure out how "do" Common Lisp in Emacs. (Other languages will come later.) I'm still feeling more like it's a pain than a helper, but this tutorial helped me see that it has some advantages. So long as I don't try to do everything in emacs, and avoid the fancy configuration stuff that everyone seems to love, I should be over the 'time-sink' hump.

So that was yesterday. Now maybe I can sit down and do today's post.

MetaOcaml Priority Queue

The idea today was just to make my OCaml priority queue from yesterday into a metaOcaml queue, so that it could queue tasks written in actual OCaml code.

MetaOCaml might sound redundant, but in fact, it simply adds a feature that is missing: quotation, as it exists in Lisp. A quoted piece of code is not executed until we explicitly evaluate it. The biggest difference is that OCaml type-checks everything, even stuff inside quotes! According to the metaocaml paper, if the type of an expression E is t, the type of a quoted expression (written .<E>.) is:

E code

What I found in my install was that it became:

('a, E) code

I have no idea what that 'a is doing there, and it made life difficult! After I put the priority queue together, I tried to write a function which repeatedly took tasks off of the queue and executed them until none remained. However, the interpreter rejected this as ill-typed, complaining that the 'a parameters might not match (more specifically, that 'a is not generalisable).

Perhaps I'll figure that one out for tomorrow. Here is the code for today:

type 'a task = ('a, unit) code

type 'a priority_queue = {mutable tasklist: (('a task) * float) option array; mutable next: int}

let new_priority_queue = {tasklist = Array.make 2 None; next = 1}

let rec sift_up place pq =
  if (place > 1) then match (pq.tasklist.(place), pq.tasklist.(place/2)) with
      (None, p) -> ()
    | (Some (t1,f1), Some (t2,f2)) when f1 <= f2 -> ()
    | (Some (t1,f1), Some (t2,f2)) when f1 > f2 ->
        pq.tasklist.(place)   <- Some (t2, f2);
        pq.tasklist.(place/2) <- Some (t1, f1);
        sift_up (place/2) pq;
    | (q, r) -> raise (Invalid_argument "sift_up");;

let double_size pq =
  pq.tasklist <- Array.append pq.tasklist (Array.make (Array.length pq.tasklist) None);;

let push_item item priority pq =
  (if not (pq.next < Array.length pq.tasklist) then double_size pq);
  pq.tasklist.(pq.next) <- Some (item, priority);
  sift_up pq.next pq;
  pq.next <- (pq.next + 1);;

let rec sift_down place pq =
  if place*2 < Array.length pq.tasklist then
    if place*2+1 < pq.next then
      let (largervalue,largerplace) =
        (match (pq.tasklist.(place*2), pq.tasklist.(place*2+1)) with
            (Some (t1,f1), Some (t2,f2)) when f1 < f2 -> (f2,place*2+1)
          | (Some (t1,f1), Some (t2,f2))              -> (f1,place*2)
          | _ -> raise (Invalid_argument "sift_down") )
        in
          match pq.tasklist.(place) with
              Some (t,f) when f < largervalue ->
                (pq.tasklist.(place) <- pq.tasklist.(largerplace);
                pq.tasklist.(largerplace) <- Some (t,f);
                sift_down largerplace pq )
            | Some (t,f) -> ()
            | _ -> raise (Invalid_argument "sift_down")
    else if place*2 < pq.next then
      match pq.tasklist.(place) with
          Some (t,f) when f < (match pq.tasklist.(place*2) with Some (t,f) -> f | _ -> 0.0) ->
            (pq.tasklist.(place) <- pq.tasklist.(place*2);
            pq.tasklist.(place*2) <- Some (t,f) )
        | Some (t,f) -> ()
        | _ -> raise (Invalid_argument "sift_down");;


let pop_item pq =
  match pq.tasklist.(1) with Some (t,f) ->
      pq.tasklist.(1) <- pq.tasklist.(pq.next-1);
      pq.tasklist.(pq.next-1) <- None;
      if pq.next > 1 then pq.next <- pq.next-1;
      sift_down 1 pq;
      t;
    | None -> .<()>.;;

First Post

The point of this blog is just to get me to write some code every day. If I miss a few days I will try to make several posts. Probably this blog will not be much fun to read regularly, but posting it publicly gives some sense of accountability.

It'll be in Lisp, Ocaml, or whatever I feel like learning.

Today's code is an ocaml priority queue. I might improve it a bit for the next couple of days.

(* This is just a placeholder for real tasks. *)
type task = Task

type priority_queue = {mutable tasklist: (task * float) option array; mutable next: int}

let new_priority_queue = {tasklist = Array.make 2 None; next = 1}

let rec sift_up place pq =
  if (place > 1) then match (pq.tasklist.(place), pq.tasklist.(place/2)) with
      (None, p) -> ()
    | (Some (t1,f1), Some (t2,f2)) when f1 <= f2 -> ()
    | (Some (t1,f1), Some (t2,f2)) when f1 > f2 ->
        pq.tasklist.(place)   <- Some (t2, f2);
        pq.tasklist.(place/2) <- Some (t1, f1);
        sift_up (place/2) pq;
    | (q, r) -> raise (Invalid_argument "sift_up");;

let double_size pq =
  pq.tasklist <- Array.append pq.tasklist (Array.make (Array.length pq.tasklist) None);;

let push_item item priority pq =
  (if not (pq.next < Array.length pq.tasklist) then double_size pq);
  pq.tasklist.(pq.next) <- Some (item, priority);
  sift_up pq.next pq;
  pq.next <- (pq.next + 1);;

let rec sift_down place pq =
  if place*2 < Array.length pq.tasklist then
    if place*2+1 < pq.next then
      let (largervalue,largerplace) =
        (match (pq.tasklist.(place*2), pq.tasklist.(place*2+1)) with
            (Some (t1,f1), Some (t2,f2)) when f1 < f2 -> (f2,place*2+1)
          | (Some (t1,f1), Some (t2,f2))              -> (f1,place*2)
          | _ -> raise (Invalid_argument "sift_down") )
        in
          match pq.tasklist.(place) with
              Some (t,f) when f < largervalue ->
                (pq.tasklist.(place) <- pq.tasklist.(largerplace);
                pq.tasklist.(largerplace) <- Some (t,f);
                sift_down largerplace pq )
            | Some (t,f) -> ()
            | _ -> raise (Invalid_argument "sift_down")
    else if place*2 < pq.next then
      match pq.tasklist.(place) with
          Some (t,f) when f < (match pq.tasklist.(place*2) with Some (t,f) -> f | _ -> 0.0) ->
            (pq.tasklist.(place) <- pq.tasklist.(place*2);
            pq.tasklist.(place*2) <- Some (t,f) )
        | Some (t,f) -> ()
        | _ -> raise (Invalid_argument "sift_down");;


let pop_item pq =
  let result = pq.tasklist.(1) in
    pq.tasklist.(1) <- pq.tasklist.(pq.next-1);
    pq.tasklist.(pq.next-1) <- None;
    if pq.next > 1 then pq.next <- pq.next-1;
    sift_down 1 pq;
    result;;