From 5fd449237692e926d97be9ef108f1bc70ca7bd7b Mon Sep 17 00:00:00 2001
From: "Juan M. Bello-Rivas" <jbellorivas@rigetti.com>
Date: Mon, 28 Oct 2019 19:17:09 +0100
Subject: [PATCH] Work around out of memory issue with foreign allocator.
 (#199)

* Work around out of memory issue with foreign allocator.

* Use TRIVIAL-GARBAGE.

* Add comment.

* Trigger garbage collection only when using foreign memory allocation.

* Be explicit about the transient nature of the current fix.
---
 app/src/entry-point.lisp    | 29 ++++++++++++++++-------------
 app/src/globals.lisp        |  8 +++++++-
 app/src/handle-request.lisp | 12 +++++++++++-
 3 files changed, 34 insertions(+), 15 deletions(-)

diff --git a/app/src/entry-point.lisp b/app/src/entry-point.lisp
index 11b05102..059f736a 100644
--- a/app/src/entry-point.lisp
+++ b/app/src/entry-point.lisp
@@ -328,18 +328,17 @@ Copyright (c) 2016-2019 Rigetti Computing.~2%")
     (terpri)))
 
 (defun allocation-description-maker (kind)
-  "Return a function INTEGER -> ALLOCATION that takes a number of elements and returns a proper descriptor for the allocation."
-  (cond
-    ((string-equal kind "native")
-     (lambda (length)
-       (make-instance 'qvm:lisp-allocation :length length)))
-    ((string-equal kind "foreign")
-     (lambda (length)
-       (make-instance 'qvm:c-allocation :length length)))
-    (t
-     (error "Invalid kind of allocation ~S, wanted any of {~{~S~^, ~}"
-            kind
-            *available-allocation-kinds*))))
+  "Return a function INTEGER -> ALLOCATION that takes a number of elements and returns a proper descriptor for the allocation. In addition to said function, return the allocator description used."
+  (let ((x (assoc kind *allocation-descriptions* :test #'string=)))
+    (if x
+        (let ((description (cdr x)))
+          (values
+           (lambda (length)
+             (make-instance description :length length))
+           description))
+        (error "Invalid kind of allocation ~S, wanted any of {~{~S~^, ~}"
+               kind
+               *available-allocation-kinds*))))
 
 (defun log-level-string-to-symbol (log-level)
   (let ((log-level-kw (assoc (intern (string-upcase log-level) 'keyword)
@@ -415,7 +414,11 @@ Version ~A is available from https://www.rigetti.com/forest~%"
     (setf qvm:*transition-verbose* t))
 
   (when default-allocation
-    (setq **default-allocation** (allocation-description-maker default-allocation)))
+
+    (multiple-value-bind (allocation description)
+        (allocation-description-maker default-allocation)
+      (setf **default-allocation** allocation
+            *allocation-description* description)))
 
   (when (plusp time-limit)
     (setf *time-limit* (/ time-limit 1000.0d0)))
diff --git a/app/src/globals.lisp b/app/src/globals.lisp
index c7d4b046..a6d9f380 100644
--- a/app/src/globals.lisp
+++ b/app/src/globals.lisp
@@ -15,8 +15,14 @@
 (global-vars:define-global-var **persistent-wavefunction** nil)
 (global-vars:define-global-var **persistent-wavefunction-finalizer** (constantly nil))
 
+(defparameter *allocation-descriptions* '(("native" . qvm:lisp-allocation)
+                                          ("foreign" . qvm:c-allocation))
+  "Association list of allocation descriptions.")
+
+(defvar *allocation-description* 'qvm:lisp-allocation "Default allocation description.")
+
 (global-vars:define-global-var **default-allocation**
-    (lambda (n) (make-instance 'qvm:lisp-allocation :length n)))
+    (lambda (n) (make-instance *allocation-description* :length n)))
 
 (deftype simulation-method ()
   "Available QVM simulation methods."
diff --git a/app/src/handle-request.lisp b/app/src/handle-request.lisp
index c39c3374..e390fc6f 100644
--- a/app/src/handle-request.lisp
+++ b/app/src/handle-request.lisp
@@ -185,4 +185,14 @@ The mapping vector V specifies that the qubit as specified in the program V[i] h
                                    :measurement-noise measurement-noise)
            (load-time-value
             (with-output-to-string (s)
-              (yason:encode t s)))))))))
+              (yason:encode t s))))))))
+
+  (when (eq *allocation-description* 'qvm:c-allocation)
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ;; Trigger the garbage collector to ensure that foreign memory is freed
+    ;; (see issue #198).
+    ;;
+    ;; TODO: This is a temporary fix and is not 100% satisfactory because it
+    ;; potentially stops all threads for GC after each request.
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    (tg:gc :full t)))