Stop using the fill pointer for the stack
This is ugly, but it had to be done. Shit gets too crazy once you introduce
choice points. We'll just have to manage our own memory. Ugh.
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Wed, 20 Apr 2016 17:13:31 +0000 |
| parents |
1ab41e0128dc
|
| children |
a97a1fd92f94
|
| branches/tags |
(none) |
| files |
src/wam/dump.lisp src/wam/interpreter.lisp src/wam/wam.lisp |
Changes
--- a/src/wam/dump.lisp Wed Apr 20 16:33:38 2016 +0000
+++ b/src/wam/dump.lisp Wed Apr 20 17:13:31 2016 +0000
@@ -60,42 +60,49 @@
(values)))
-(defun dump-stack (wam &optional (e (wam-environment-pointer wam)))
+(defun dump-stack (wam)
(format t "STACK~%")
(format t " +------+----------+-------------------------------+~%")
(format t " | ADDR | VALUE | |~%")
(format t " +------+----------+-------------------------------+~%")
- (loop :with n = nil
- :with arg = 0
- :for offset = 0 :then (1+ offset)
- :for cell :across (wam-stack wam)
- :for addr :from 0 :do
- (format t " | ~4,'0X | ~8,'0X | ~30A|~A~A~%"
- addr
- cell
- (cond
- ((= offset 0) "CE ===========================")
- ((= offset 1) "CP")
- ((= offset 2)
- (if (zerop cell)
- (progn
- (setf offset -1)
- "N: EMPTY")
- (progn
- (setf n cell)
- (format nil "N: ~D" cell))))
- ((< arg n)
- (prog1
- (format nil " Y~D: ~4,'0X"
- arg
- ;; look up the actual cell in the heap
- (cell-aesthetic (wam-heap-cell wam cell)))
- (when (= n (incf arg))
- (setf offset -1
- n nil
- arg 0)))))
- (if (= addr (wam-environment-pointer wam)) " <- E" "")
- (if (= addr e) " <- FRAME" "")))
+ (with-accessors ((stack wam-stack)
+ (e wam-environment-pointer)
+ (b wam-backtrack-pointer))
+ wam
+ (when (not (= e b)) ; lame way to check for an empty stack...
+ (loop :with n = nil
+ :with limit = (max (+ e 3) (+ b 7))
+ :with arg = 0
+ :for addr :from 0 :to limit
+ :for cell = (aref (wam-stack wam) addr)
+ :for offset = 0 :then (1+ offset)
+ :do
+ (format t " | ~4,'0X | ~8,'0X | ~30A|~A~A~%"
+ addr
+ cell
+ (cond
+ ((= offset 0) "CE ===========================")
+ ((= offset 1) "CP")
+ ((= offset 2)
+ (if (zerop cell)
+ (progn
+ (setf offset -1)
+ "N: EMPTY")
+ (progn
+ (setf n cell)
+ (format nil "N: ~D" cell))))
+ ((< arg n)
+ (prog1
+ (format nil " Y~D: ~4,'0X"
+ arg
+ ;; look up the actual cell in the heap
+ (cell-aesthetic (wam-heap-cell wam cell)))
+ (when (= n (incf arg))
+ (setf offset -1
+ n nil
+ arg 0)))))
+ (if (= addr e) " <- E" "")
+ (if (= addr b) " <- B" "")))))
(format t " +------+----------+-------------------------------+~%"))
--- a/src/wam/interpreter.lisp Wed Apr 20 16:33:38 2016 +0000
+++ b/src/wam/interpreter.lisp Wed Apr 20 17:13:31 2016 +0000
@@ -357,19 +357,21 @@
(wam-continuation-pointer wam)))
(define-instruction %allocate ((wam wam) (n stack-frame-argcount))
- (setf (wam-environment-pointer wam) ; E <- new E
- (->> wam
- wam-environment-pointer
- (wam-stack-push! wam) ; CE
- (nth-value 1)))
- (wam-stack-push! wam (wam-continuation-pointer wam)) ; CP
- (wam-stack-push! wam n) ; N
- (wam-stack-extend! wam n)) ; Y_n (TODO: this sucks)
+ ;; Use the slots directly here for speed. I know this sucks. I'm sorry.
+ (with-slots (stack environment-pointer) wam
+ (let* ((old-e environment-pointer)
+ (new-e (+ old-e (wam-stack-frame-size wam old-e))))
+ (wam-stack-ensure-size! wam (+ new-e 3 n))
+ (setf (aref stack new-e) old-e ; E
+ (aref stack (+ new-e 1) (wam-continuation-pointer wam)) ; CP
+ (aref stack (+ new-e 2) n) ; N
+ environment-pointer new-e)))) ; E <- new-e
(define-instruction %deallocate ((wam wam))
(setf (wam-program-counter wam)
- (wam-stack-frame-cp wam))
- (wam-stack-pop-frame! wam))
+ (wam-stack-frame-cp wam)
+ (wam-environment-pointer wam)
+ (wam-stack-frame-ce wam)))
;;;; Running
@@ -425,7 +427,6 @@
(mapcar #'recur addresses))))
(defun extract-query-results (wam vars)
- ""
(let* ((addresses (loop :for var :in vars
:for i :from 0
:collect (wam-stack-frame-arg wam i 0)))
--- a/src/wam/wam.lisp Wed Apr 20 16:33:38 2016 +0000
+++ b/src/wam/wam.lisp Wed Apr 20 17:13:31 2016 +0000
@@ -45,10 +45,7 @@
:reader wam-stack
:initform (make-array 1024
:adjustable t
- :fill-pointer 0
- ;; Initialize to the last element in the heap for debugging.
- ;; todo: don't do this
- :initial-element (1- +heap-limit+)
+ :initial-element 0
:element-type 'stack-word)
:documentation "The local stack for storing stack frames.")
(fail
@@ -169,12 +166,6 @@
;;;; Stack
-(defun* wam-stack-pointer ((wam wam))
- (:returns stack-index)
- "Return the current stack pointer of the WAM."
- (fill-pointer (wam-stack wam)))
-
-
(defun* wam-stack-word ((wam wam) (address stack-index))
(:returns stack-word)
"Return the stack word at the given address."
@@ -183,32 +174,20 @@
(defun (setf wam-stack-word) (new-value wam address)
(setf (aref (wam-stack wam) address) new-value))
+(defun* wam-stack-ensure-size! ((wam wam)
+ (address stack-index))
+ (:returns :void)
+ "Ensure the WAM stack is large enough to be able to write to `address`.
-(defun* wam-stack-push! ((wam wam) (word stack-word))
- (:returns (values stack-word stack-index))
- "Push the word onto the WAM stack and increment the stack pointer.
-
- Returns the word and the address it was pushed to.
+ It will be adjusted (but not beyond the limit) if necessary.
"
(with-slots (stack) wam
- (if (= +stack-limit+ (fill-pointer stack))
+ (if (>= address +stack-limit+)
(error "WAM stack exhausted.")
- (values word (vector-push-extend word stack)))))
-
-(defun* wam-stack-extend! ((wam wam) (words integer))
- (:returns :void)
- "Extend the WAM stack by the given number of words.
-
- Each word is initialized to 0.
-
- "
- ;; TODO: this sucks, fix it
- (with-slots (stack) wam
- (repeat words
- (if (= +stack-limit+ (fill-pointer stack))
- (error "WAM stack exhausted.")
- (vector-push-extend 0 stack))))
+ (while (>= address (array-total-size stack))
+ ;; i uh, let's just hope this never executes more than once...
+ (adjust-array stack (* 2 (array-total-size stack))))))
(values))
@@ -280,15 +259,6 @@
(+ (wam-stack-frame-n wam e) 3))
-(defun* wam-stack-pop-frame! ((wam wam))
- "Pop an environment (stack frame) off the WAM stack."
- (let ((size (wam-stack-frame-size wam)))
- (with-slots (stack environment-pointer) wam
- (setf environment-pointer
- (wam-stack-frame-ce wam environment-pointer)) ; E <- CE
- (decf (fill-pointer stack) size)))) ; its fine
-
-
;;; Choice point frames are laid out like so:
;;;
;;; |PREV|
@@ -395,22 +365,10 @@
(+ (wam-stack-choice-n wam b) 7))
-(defun* wam-stack-pop-choice! ((wam wam))
- "Pop a choice frame off the WAM stack."
- (let ((size (wam-stack-choice-size wam)))
- (with-slots (stack backtrack-pointer) wam
- (setf backtrack-pointer
- (wam-stack-choice-cb wam backtrack-pointer)) ; B <- CB
- (decf (fill-pointer stack) size)))) ; its fine
-
-
;;;; Resetting
(defun* wam-truncate-heap! ((wam wam))
(setf (fill-pointer (wam-heap wam)) 0))
-(defun* wam-truncate-stack! ((wam wam))
- (setf (fill-pointer (wam-stack wam)) 0))
-
(defun* wam-truncate-trail! ((wam wam))
(setf (fill-pointer (wam-trail wam)) 0))