diff --git a/examples/minesweeper/main.ml b/examples/minesweeper/main.ml index 7a5d50a..47b51d0 100644 --- a/examples/minesweeper/main.ml +++ b/examples/minesweeper/main.ml @@ -70,14 +70,8 @@ let onload _ = Lwd.join (Lwd_table.reduce Lwd_seq.lwd_monoid boards); ] in - (*let root = Lwd.observe (Lwdom.to_fragment doc) in*) - let root = Lwd.observe doc in - Lwd.set_on_invalidate root (fun _ -> - ignore (Dom_html.window##requestAnimationFrame - (Js.wrap_callback (fun _ -> ignore (Lwd.quick_sample root))) - )); - List.iter (Dom.appendChild main) - (Lwd_seq.to_list (Lwd.quick_sample root) : _ node list :> raw_node list); + let _ : Lwdom.Scheduler.job = + Lwdom.Scheduler.append_to_dom doc main in Js._false let _ = Dom_html.window##.onload := Dom_html.handler onload diff --git a/lib/tyxml-lwd/tyxml_lwd.ml b/lib/tyxml-lwd/tyxml_lwd.ml index 45653dc..322c42d 100644 --- a/lib/tyxml-lwd/tyxml_lwd.ml +++ b/lib/tyxml-lwd/tyxml_lwd.ml @@ -1870,4 +1870,145 @@ module Lwdom = struct | xs -> Lwd_seq.bind (Lwd.pure (Lwd_seq.of_array xs)) (fun x -> x) let to_node x = x + + module Scheduler = struct + + type limit = { + cycles_warning: int; (* 5 *) + cycles_max: int; (* 15 *) + time_budget: float; (* 16.6 *) + time_warning: bool; (* true *) + } + + type job = { + root: unit Lwd.root; + mutable limit: limit; + mutable queued: bool; + mutable enabled: bool; + } + + module Next_frame = struct + let scheduled = ref false + let todo_cb = ref [] + let todo_jobs = ref [] + + let process_cb queue = + let todo_cb' = List.rev !todo_cb in + todo_cb := []; + List.iter (fun f -> + try f queue + with _exn -> + prerr_endline + "Lwdom.Scheduler: next frame callback raised an exception" + ) todo_cb' + + let process_jobs_step queue time cycle ~acc ~jobs = + List.fold_left (fun acc job -> + match () with + | () when not (job.enabled && Lwd.is_damaged job.root) -> + job.queued <- false; + acc + | () when cycle > job.limit.cycles_max -> + prerr_endline ( + "Job exceeded maximum number of cycles (" ^ + string_of_int job.limit.cycles_max ^ + ")" + ); + (job :: acc) + | () when time > job.limit.time_budget -> + if job.limit.time_warning then + prerr_endline ( + "Job exceeded time budget (" ^ + string_of_float job.limit.time_budget ^ + " ms)" + ); + (job :: acc) + | () -> + if cycle = job.limit.cycles_warning then ( + prerr_endline ( + "Warning: Job has been running for " ^ + string_of_int cycle ^ + " cycles" + ); + ); + job.queued <- false; + Lwd.sample queue job.root; + acc + ) acc jobs + + let rec process_jobs_loop queue start_time cycle acc = + match !todo_jobs with + | [] -> acc + | jobs -> + let time = Sys.time () in + todo_jobs := []; + let acc = + process_jobs_step + queue ((start_time -. time) *. 1000.0) cycle + ~acc ~jobs + in + process_jobs_loop queue start_time (cycle + 1) acc + + let rec schedule = + let process _ = + scheduled := false; + (* TODO: print runtime information on exception *) + let queue = Lwd.make_release_queue () in + process_cb queue; + begin match process_jobs_loop queue (Sys.time ()) 0 [] with + | [] -> () + | leftover -> todo_jobs := leftover; schedule () + end; + List.iter + (fun _ -> prerr_endline "Error while flushing release queue") + (Lwd.flush_release_queue queue) + in + fun () -> + if not !scheduled then ( + let cb = Js.wrap_callback process in + ignore (Dom_html.window##requestAnimationFrame cb); + scheduled := true + ) + + let register f = + todo_cb := f :: !todo_cb; + schedule () + + let queue_job job = + if not job.queued then ( + job.queued <- true; + todo_jobs := job :: !todo_jobs; + schedule () + ) + + let invalidate_job job () = + if job.enabled then queue_job job + end + + let on_next_frame = Next_frame.register + + let reenable job = + job.enabled <- true; + if Lwd.is_damaged job.root then Next_frame.queue_job job + + let disable job = + job.enabled <- false + + let default_limit = { + cycles_warning = 5; + cycles_max = 15; + time_budget = 16.6; + time_warning = true; + } + + let append_to_dom nodes dom_node = + let dom_node = (dom_node : #Dom.node Js.t :> Dom.node Js.t) in + let root = Lwd.observe (update_children dom_node nodes) in + let job = { root; limit = default_limit; queued = false; enabled = true } in + Lwd.set_on_invalidate root (Next_frame.invalidate_job job); + Next_frame.queue_job job; + job + + let set_limit job limit = job.limit <- limit + end end diff --git a/lib/tyxml-lwd/tyxml_lwd.mli b/lib/tyxml-lwd/tyxml_lwd.mli index e401045..3871a11 100644 --- a/lib/tyxml-lwd/tyxml_lwd.mli +++ b/lib/tyxml-lwd/tyxml_lwd.mli @@ -831,5 +831,23 @@ module Lwdom : sig (** Make a reactive attribute *) val to_node : _ node -> raw_node + + module Scheduler : sig + val on_next_frame : (Lwd.release_queue -> unit) -> unit + + type job + val append_to_dom : 'a node live -> #Dom.node Js.t -> job + val disable : job -> unit + val reenable : job -> unit + + type limit = { + cycles_warning: int; (* 5 *) + cycles_max: int; (* 15 *) + time_budget: float; (* 16.6 *) + time_warning: bool; (* true *) + } + + val set_limit : job -> limit -> unit + end end