From 0a4e1b208853db5947867aafab4e0f1214b52faf Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Sun, 27 Mar 2016 12:07:58 -0400
Subject: [PATCH] Add (request-gc) message.

---
 prospect-gl/2d.rkt | 21 ++++++++++++++++++++-
 1 file changed, 20 insertions(+), 1 deletion(-)

diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt
index b6c51b5..4ef640e 100644
--- a/prospect-gl/2d.rkt
+++ b/prospect-gl/2d.rkt
@@ -7,6 +7,7 @@
          (struct-out scene)
          (except-out (struct-out sprite) sprite)
          (rename-out [sprite <sprite>] [make-sprite sprite])
+         (struct-out request-gc)
          simple-sprite
          update-scene
          update-sprites
@@ -54,6 +55,12 @@
 ;; toward camera. Instructions to be a sealed instruction list.
 (struct sprite (z instructions) #:transparent)
 
+;; Message. Requests that the OpenGL loop perform a major
+;; garbage-collection while *pausing the simulation's real-time
+;; correspondence*. This lets a GC take place without such severe
+;; simulation glitches as happen when doing it in-world.
+(struct request-gc () #:transparent)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define (update-scene prelude postlude #:meta-level [meta-level 1])
@@ -280,7 +287,9 @@
          (process-sprite-updates! p)
          (process-stop-requests! p)
          (process-fullscreen-requests! p)]
-        [(message body) (void)]))
+        [(message (request-gc))
+         (perform-gc-request!)]
+        [(message _) (void)]))
 
     (define (process-scene-updates! p)
       (define-values (added removed) (patch-project/set/single p scene-projection))
@@ -317,6 +326,14 @@
       (when changed?
         (send (send this get-top-level-window) fullscreen fullscreen?)))
 
+    (define (perform-gc-request!)
+      (define pre-gc (current-inexact-milliseconds))
+      (collect-garbage 'major)
+      (define post-gc (current-inexact-milliseconds))
+      (define delta (- post-gc pre-gc))
+      (log-info "(request-gc) took ~a milliseconds" delta)
+      (set! start-time (+ start-time delta)))
+
     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
     (define/override (on-paint)
@@ -373,6 +390,8 @@
 (define (2d-network #:width [width #f]
                     #:height [height #f]
                     . boot-actions)
+  (collect-garbage 'incremental)
+  (collect-garbage 'major)
   (define frame (new frame%
                      [style '(fullscreen-button)]
                      [label "prospect-gl"]