cb3cc671d18d

--- a/package.lisp	Mon Jul 11 22:33:25 2016 +0000
+++ b/package.lisp	Mon Jul 11 23:37:37 2016 +0000
@@ -17,6 +17,7 @@
     #:megabytes
     #:gethash-or-init
     #:define-lookup
+    #:queue
     #:make-queue
     #:enqueue
     #:dequeue

--- a/src/utils.lisp	Mon Jul 11 22:33:25 2016 +0000
+++ b/src/utils.lisp	Mon Jul 11 23:37:37 2016 +0000
@@ -129,48 +129,45 @@
 
 
 ;;;; Queues
-;;; From PAIP (thanks, Norvig).
+;;; Based on the PAIP queues (thanks, Norvig), but beefed up a little bit to add
+;;; tracking of the queue size.
+
+(declaim (inline make-queue enqueue dequeue queue-empty-p))
 
-(deftype queue () '(cons list list))
-(declaim (inline queue-contents make-queue
-                 enqueue dequeue
-                 queue-empty-p queue-append))
+(defstruct (queue (:constructor make-queue%))
+  (contents nil :type list)
+  (last nil :type list)
+  (size 0 :type fixnum))
 
 
-(defun* queue-contents ((q queue))
-  (:returns list)
-  (cdr q))
-
 (defun* make-queue ()
   (:returns queue)
-  (let ((q (cons nil nil)))
-    (setf (car q) q)))
+  (make-queue%))
+
+(defun* queue-empty-p ((q queue))
+  (:returns boolean)
+  (zerop (queue-size q)))
 
 (defun* enqueue ((item t) (q queue))
-  (:returns queue)
-  (setf (car q)
-        (setf (rest (car q))
-              (cons item nil)))
-  q)
+  (:returns fixnum)
+  (let ((cell (cons item nil)))
+    (setf (queue-last q)
+          (if (queue-empty-p q)
+            (setf (queue-contents q) cell)
+            (setf (cdr (queue-last q)) cell))))
+  (incf (queue-size q)))
 
 (defun* dequeue ((q queue))
   (:returns t)
-  (prog1
-      (pop (cdr q))
-    (if (null (cdr q))
-      (setf (car q) q))))
-
-(defun* queue-empty-p ((q queue))
-  (:returns boolean)
-  (null (queue-contents q)))
+  (when (zerop (decf (queue-size q)))
+    (setf (queue-last q) nil))
+  (pop (queue-contents q)))
 
 (defun* queue-append ((q queue) (l list))
-  (:returns queue)
-  (when l
-    (setf (car q)
-          (last (setf (rest (car q))
-                      l))))
-  q)
+  (:returns fixnum) ; todo make a structure sharing version of this
+  (loop :for item :in l
+        :for size = (enqueue item q)
+        :finally (return size)))
 
 
 ;;;; Lookup Tables

--- a/src/wam/compiler.lisp	Mon Jul 11 22:33:25 2016 +0000
+++ b/src/wam/compiler.lisp	Mon Jul 11 23:37:37 2016 +0000
@@ -541,7 +541,7 @@
 ;;; We now return you to your regularly scheduled Lisp code.
 
 (defstruct allocation-state
-  (local-registers (vector) :type (vector t *)) ; todo should this be a (vector symbol) instead?
+  (local-registers (make-queue) :type queue)
   (stack-registers nil :type list)
   (permanent-variables nil :type list)
   (anonymous-variables nil :type list)
@@ -553,9 +553,12 @@
 (defun* find-variable ((state allocation-state) (variable symbol))
   (:returns (or register null))
   "Return the register that already contains this variable, or `nil` otherwise."
-  (or (when-let (r (position variable (allocation-state-local-registers state)))
+  (or (when-let (r (position variable
+                             (queue-contents
+                               (allocation-state-local-registers state))))
         (make-temporary-register r (allocation-state-actual-arity state)))
-      (when-let (s (position variable (allocation-state-stack-registers state)))
+      (when-let (s (position variable
+                             (allocation-state-stack-registers state)))
         (make-permanent-register s))
       nil))
 
@@ -572,7 +575,7 @@
   "
   (make-register
     :local
-    (vector-push-extend variable (allocation-state-local-registers state))))
+    (1- (enqueue variable (allocation-state-local-registers state)))))
 
 (defun* ensure-variable ((state allocation-state) (variable symbol))
   (:returns register)
@@ -605,7 +608,7 @@
   ;; never need to look them up later (like we do with variables), so we'll just
   ;; shove a nil into the local registers array as a placeholder.
   (make-temporary-register
-    (vector-push-extend nil (allocation-state-local-registers state))
+    (enqueue nil (allocation-state-local-registers state))
     (allocation-state-actual-arity state)))
 
 
@@ -650,13 +653,7 @@
        (reserved-variables (when nead
                              (clause-nead-vars clause-props)))
        (permanent-variables (clause-permanent-vars clause-props))
-       ;; Preallocate enough registers for all of the arguments.  We'll fill
-       ;; them in later.  Note that things are more complicated in the head and
-       ;; first body term of a clause (see above).
-       (local-registers (make-array 64
-                          :fill-pointer (or reserved-arity actual-arity)
-                          :adjustable t
-                          :initial-element 0))
+       (local-registers (make-queue))
        ;; We essentially "preallocate" all the permanent variables up front
        ;; because we need them to always be in the same stack registers across
        ;; all the terms of our clause.
@@ -673,10 +670,15 @@
            :reserved-variables reserved-variables
            :reserved-arity reserved-arity
            :actual-arity actual-arity)))
+    ;; Preallocate enough registers for all of the arguments.  We'll fill
+    ;; them in later.  Note that things are more complicated in the head and
+    ;; first body term of a clause (see above).
+    (loop :repeat (or reserved-arity actual-arity)
+          :do (enqueue nil local-registers))
     ;; Actually reserve the reserved (but non-permanent, see above) variables.
     ;; They need to live in consistent spots for the head and first body term.
     (loop :for variable :in reserved-variables
-          :do (vector-push-extend variable local-registers))
+          :do (enqueue variable local-registers))
     (recursively ((remaining (list node)))
       (when remaining
         (destructuring-bind (node . remaining) remaining