wait_event: Sdl.wait_event implements power saving since SDL 2.0.22

bogue.opam

@@ -31,7 +31,7 @@ depends: [
   "tsdl-image" {>= "0.3.0"}
   "tsdl-ttf" {>= "0.3"}
   "ocaml" {>= "4.08.0"}
-  "tsdl" {>= "0.9.7" & < "0.9.9"}
+  "tsdl" {> "0.9.9"}
   "directories"
   "odoc" {with-doc}
 ]
@@ -50,3 +50,4 @@ build: [
   ]
 ]
 dev-repo: "git+https://github.com/sanette/bogue.git"
+available: [ (os-distribution != "opensuse-leap" | os-version >= 16) ]

bogue.opam.template

@@ -0,0 +1 @@
+available: [ (os-distribution != "opensuse-leap" | os-version >= 16) ]

dune-project

@@ -8,6 +8,7 @@
 (authors "Vu Ngoc San <san.vu-ngoc@laposte.net>")
 (source (github sanette/bogue))
 (documentation "http://sanette.github.io/bogue/Bogue.html")
+(formatting disabled)
 
 (package
  (name bogue)
@@ -33,6 +34,6 @@ Threads when non-blocking reactions are needed.")
   (tsdl-image (>= 0.3.0))
   (tsdl-ttf (>= 0.3))
   (ocaml (>= 4.08.0))
-  (tsdl (and (>= 0.9.7) (< 0.9.9)))
+  (tsdl (and (> 0.9.9)))
   directories
 ))

lib/b_draw.ml

@@ -1225,6 +1225,17 @@ let create_window  ?x ?y ~w ~h name =
                 should try 'export SDL_VIDEO_X11_VISUALID='";
     raise (Sdl_error ("SDL ERROR: " ^ (Sdl.get_error ())))
 
+let set_vsync () =
+    (* SDL_RendererSetVSync is not bound, but it wouldn't know about adaptive vsync *)
+    match Sdl.gl_set_swap_interval (-1) with
+    | Ok () -> printd debug_graphics "Enabled Adaptive VSync"
+    | Error (`Msg m) ->
+        printd (debug_graphics+debug_warning) "Failed to enable Adaptive VSync, falling back to regular: %s" m;
+        match Sdl.gl_set_swap_interval 1 with
+        | Ok () -> printd debug_graphics "Enabled VSync"
+        | Error (`Msg m) ->
+            printd (debug_graphics+debug_error) "Failed to enable VSync: %s" m
+
 (* Sdl init. [w,h] is the physical size of the window in pixels. In case of
    High-DPI mode, SDL might actually produce a larger window. We need to correct
    this, because we have our own DPI engine.
@@ -1291,6 +1302,8 @@ let init ?window ?(name="BOGUE Window") ?fill ?x ?y ~w ~h () =
   end;
 
   printd debug_graphics "Canvas created";
+  if not (Theme.get_bool "NO_VSYNC") then
+      set_vsync ();
 
   let fill = default_lazy fill
       (lazy (fill_of_string renderer Theme.background)) in

lib/b_main.ml

@@ -878,10 +878,11 @@ let event_loop anim new_anim board =
   let e = !Trigger.my_event in
   continue e 0
 
+let nop_event_fps = Time.make_fps ()
 
 (* [one_step] is what is executed during the main loop *)
 let one_step ?before_display anim (start_fps, fps) ?clear board =
-  Timeout.run ();
+  let (_ : Time.t) = Timeout.run () in
   let new_anim = has_anim board in
   if new_anim && not anim then start_fps ();
   event_loop anim new_anim board;
@@ -919,7 +920,7 @@ let one_step ?before_display anim (start_fps, fps) ?clear board =
   end;
   (* else *)
 
-  if anim then fps () else Thread.delay 0.005;
+  if anim then fps ();
   (* even when there is no anim, we need to to be nice to other treads, in
      particular when an event is triggered very rapidly (mouse_motion) and
      captured by a connection, without anim. Should we put also here a FPS?? *)
@@ -929,6 +930,11 @@ let one_step ?before_display anim (start_fps, fps) ?clear board =
   printd debug_graphics "==> Rendering took %u ms" (Time.now () - t);
   Avar.new_frame (); (* This is used for updating animated variables. *)
   printd debug_graphics "---------- end of loop -----------";
+  if not anim then
+  if Layout.is_fresh board.windows_house then
+    nop_event_fps 60
+  else
+    Thread.delay 0.005;
   anim
 
 (* Create an SDL window for each top layout. *)
@@ -985,6 +991,17 @@ let create ?shortcuts ?(connections = []) ?on_user_event windows =
     mouse_alive = false;
     on_user_event }
 
+let get_monitor_refresh_rate board =
+    Option.bind Layout.(window_opt board.windows_house) @@ fun win ->
+    match Sdl.get_window_display_mode win with
+    | Ok Sdl.{dm_refresh_rate = Some rate; _ } -> Some rate
+    | Ok Sdl.{dm_refresh_rate = None; _ } ->
+        printd (debug_graphics + debug_warning) "No refresh rate information in display mode";
+        None
+    | Error (`Msg m) ->
+        printd (debug_graphics + debug_warning) "Cannot get display mode from window: %s" m;
+        None
+
 let of_windows = create
 
 (* Create a board from layouts. Each layout in the list will be displayed in a
@@ -1006,13 +1023,17 @@ let make ?shortcuts connections layouts =
    CTRL-L which would occur before it. "after_display" means just after all
    textures have been calculated and rendered. Of course these two will not be
    executed at all if there is no event to trigger display. *)
-let run ?before_display ?after_display board =
+let run ?(vsync=true) ?before_display ?after_display board =
   printd debug_board "==> Running board!";
   Trigger.flush_all ();
   if not (Sync.is_empty ()) then Trigger.push_action ();
   if not (Update.is_empty ()) then Update.push_all ();
   Trigger.main_tread_id := Thread.(id (self ()));
-  let fps = Time.adaptive_fps 60 in
+  let desired_fps =
+      if vsync then get_monitor_refresh_rate board |> Option.value ~default:60
+      else 60 in
+  printd debug_graphics "Desired FPS=%u" desired_fps;
+  let start, fps = Time.adaptive_fps ~vsync desired_fps in
   make_sdl_windows board;
   show board;
   Thread.delay 0.01; (* we need some delay for the initial Mouse position to be detected *)
@@ -1048,7 +1069,7 @@ let run ?before_display ?after_display board =
     (List.flatten (List.map Widget.connections (Layout.get_widgets board.windows_house)));
   Trigger.renew_my_event ();
   let rec loop anim =
-    let anim' = one_step ?before_display ~clear:true anim fps board in
+    let anim' = one_step ?before_display ~clear:true anim (start,fps) board in
     do_option after_display (fun f -> f ()); (* TODO? *)
     loop anim' in
   try

lib/b_time.ml

@@ -40,27 +40,47 @@ let delay x = Thread.delay (float x /. 1000.)
    ie. about 24 days. TODO change this? *)
 let now () : t = Int32.to_int (Sdl.get_ticks ())
 
-let make_fps () =
+let make_fps ?(min_delay=5) () =
+  assert (min_delay >= 0);
   let start = ref 0 in
   fun fps ->
-    if !start = 0 then (delay 5; start := now ())
+    if !start = 0 then (delay min_delay; start := now ())
     else
       let round_trip = now () - !start in begin
-        let wait = max 5 ((1000 / fps) - round_trip) in
+        let wait = max min_delay ((1000 / fps) - round_trip) in
         printd debug_graphics "FPS:%u (round_trip=%u)\n" (1000 / (round_trip + wait)) round_trip;
-        delay wait;
+        if wait > 0 then
+          delay wait;
         start := now ();
       end
 
-let adaptive_fps fps =
+let set_swap_interval =
+    let swap_interval = ref min_int in
+    fun desired ->
+      if !swap_interval <> desired then begin
+        match Sdl.gl_set_swap_interval desired with
+        | Ok () ->
+          swap_interval := desired;
+          true;
+        | Error (`Msg m) ->
+          printd (debug_graphics+debug_warning) "Failed to set desired swap interval to %u: %s" desired m;
+          false
+      end else true
+
+let adaptive_fps ?(vsync=false) fps =
   let start = ref 0 in
   let frame = ref 1 in
   let total_wait = ref 0 in (* only for debugging *)
+  let vsync_used = ref false in
 
   (* the start function *)
   (fun () ->
      start := now ();
      total_wait := 0;
+     if vsync then begin
+         vsync_used := set_swap_interval 1;
+         printd debug_graphics "VSync used: %b" !vsync_used;
+     end;
      frame := 1),
 
   (* the main function *)
@@ -78,7 +98,23 @@ let adaptive_fps fps =
               frame := 0;
               total_wait := 0;
               start := now ();
+              if !vsync_used then
+                  (* turn on adaptive vsync if supported *)
+                  if set_swap_interval (-1) then
+                      printd debug_graphics "Warning: Adaptive VSync enabled"
+                  else begin
+                      printd debug_graphics "Warning: Disabling VSync";
+                      (* fall back to turning vsync off *)
+                      let (_:bool) = set_swap_interval 0 in
+                      vsync_used := false
+                  end;
               5)
+        else if !vsync_used then
+            (* trust VSync and the released runtime lock in Sdl.render_present
+               to maintain FPS, but use the usual 5ms to allow other OCaml code
+               to run if needed
+             *)
+            5
         else (printd debug_graphics "Wait=%u, Avg.=%u" wait (!total_wait / !frame);
               wait) in
       delay wait;

lib/b_timeout.ml

@@ -114,8 +114,15 @@ let iter stack =
   in
   let remaining = loop list in
   (* Utils.(printd debug_custom "Remaining size %i" (List.length remaining)); *)
-  Var.update stack (fun modified -> insert_sublist modified remaining)
+  Var.update stack (fun modified -> insert_sublist modified remaining);
+  match Var.get stack with
+  | [] -> -1 (* wait forever until next event *)
+  | hd :: _ ->
+    (* ensure returned value is never negative,
+       since that would mean wait forever *)
+    max Time.(hd.timeout - Time.now ()) 0
 
 let run () =
   (* the stack should be empty most of the time, so we add a test to be faster *)
   if Var.get stack <> [] then iter stack
+  else -1 (* wait forever until next event *)

lib/b_trigger.ml

@@ -14,6 +14,7 @@ open Tsdl
 open B_utils
 module E = Sdl.Event
 module Var = B_var
+module Timeout = B_timeout
 open Result
 
 (* We initialize SDL with only the events subsystem *)
@@ -138,55 +139,7 @@ let renew_my_event () =
 let of_event ev =
   E.(get ev typ)
 
-(* See tsdl.mli *)
-(* TODO when we switch to Tsdl 0.9.8, we should use their 'Event.enum' type
-   instead, so that we don't become incompatible every time they add a new
-   variant...  See PR https://github.com/dbuenzli/tsdl/pull/54 *)
-(* Or, one could copy here the function 'enum' from tsdl.ml *)
-
-type sdl_event =
-[ `App_did_enter_background
-| `App_did_enter_foreground
-| `App_low_memory
-| `App_terminating
-| `App_will_enter_background
-| `App_will_enter_foreground
-| `Clipboard_update
-| `Controller_axis_motion
-| `Controller_button_down
-| `Controller_button_up
-| `Controller_device_added
-| `Controller_device_remapped
-| `Controller_device_removed
-| `Dollar_gesture
-| `Dollar_record
-| `Drop_file
-| `Finger_down
-| `Finger_motion
-| `Finger_up
-| `Joy_axis_motion
-| `Joy_ball_motion
-| `Joy_button_down
-| `Joy_button_up
-| `Joy_device_added
-| `Joy_device_removed
-| `Joy_hat_motion
-| `Key_down
-| `Key_up
-| `Mouse_button_down
-| `Mouse_button_up
-| `Mouse_motion
-| `Mouse_wheel
-| `Multi_gesture
-| `Quit
-| `Sys_wm_event
-| `Text_editing
-| `Text_input
-| `Unknown of int
-| `User_event
-| `Window_event
-| `Display_event
-| `Sensor_update ]
+type sdl_event = Sdl.Event.enum
 
 type bogue_event =
   [ `Bogue_startup
@@ -840,42 +793,41 @@ let mouse_pos () =
 (* check if mouse didn't move for a while *)
 (* TODO use get_touch_finger *)
 let check_mouse_rest =
-  let pos0 = ref (0,0)
-  and t = ref (Some 0.) in
+  let t = ref None in
+  let on_mouse_idle () =
+    push_event @@ create_event mouse_at_rest
+  in
+  let start_timer () =
+      t := Some (mouse_pos (), Timeout.add 1000 on_mouse_idle)
+  in
   fun () ->
     match !t with
-    | None -> (* we start timer *)
-      t := Some (Unix.gettimeofday ());
-      pos0 := mouse_pos ();
-      0.
-    | Some t0 ->
+    | None -> start_timer ()
+    | Some (pos0, timeout)  ->
       let p = mouse_pos () in
-      if p <> !pos0 (* we have moved *)
-      then t := None;
-      Unix.gettimeofday () -. t0
+      if p <> pos0 (* we have moved *)
+      then begin
+        Timeout.cancel timeout;
+        start_timer ()
+      end
+
+let no_timeout () = -1
+
+let poll_noevent_fps = B_time.make_fps ()
+
+let wait_event_timeout =
+    let major, minor, patch = Sdl.get_version () in
+    if (major, minor, patch) >= (2,0,16) then Sdl.wait_event_timeout
+    else fun ev _ -> Sdl.poll_event ev
 
 (* Wait for next event. Returns the SAME event structure e (modified) *)
-(* Remark: (Sdl.wait_event (Some e); Some e) is supposed to to the job, but
-   (quoted from DOC) as of SDL 2.0, this function does not put the application's
-   process to sleep waiting for events; it polls for events in a loop
-   internally. This may change in the future to improve power savings. *)
-(* ME: as a result, it seems that Sdl.wait_event prevents other threads from
-   executing nicely *)
-let rec wait_event ?(action = nop) e =
-  action ();
-  if Sdl.poll_event (Some e) then e
-  (* TODO send an event instead, and reset mouse *)
-  else begin
-    let t = check_mouse_rest () in (* TODO use Timeout instead *)
-    if t > 1. && not !is_mouse_at_rest
-    then (is_mouse_at_rest := true;
-          push_event (create_event mouse_at_rest))
-    (* TODO save mouse position in event *)
-    else if t < 1. && !is_mouse_at_rest
-    then is_mouse_at_rest := false; (* the mouse has moved *)
-    Thread.delay 0.01;
-    wait_event ~action e
-  end
+let rec wait_event ?(action = no_timeout) e =
+  check_mouse_rest ();
+  let timeout = action () in
+  poll_noevent_fps 100;
+  let has_event = wait_event_timeout (Some e) timeout in
+  if has_event then e
+  else wait_event ~action e
 
 let mm_pressed ev =
   Int32.logand E.(get ev mouse_motion_state) (Sdl.Button.lmask) <> 0l

lib/b_widget.ml

@@ -603,9 +603,9 @@ let check_box_with_label text =
    ok only for very fast actions. *)
 
 let mouse_over ?(enter = nop) ?(leave = nop) w =
-  let c = connect w w (fun w _ _ -> enter w) [Trigger.mouse_enter] in
+  let c = connect_main w w (fun w _ _ -> enter w) [Trigger.mouse_enter] in
   add_connection w c;
-  let c' = connect w w (fun w _ _ -> leave w) [Trigger.mouse_leave] in
+  let c' = connect_main w w (fun w _ _ -> leave w) [Trigger.mouse_leave] in
   add_connection w c'
 
 let on_click ~click w =