--- a/src/wam/compiler/0-data.lisp Fri Jul 15 22:02:11 2016 +0000
+++ b/src/wam/compiler/0-data.lisp Fri Jul 15 23:12:18 2016 +0000
@@ -5,6 +5,10 @@
;;;; , | / ,-| | ,-|
;;;; `-^--' `-^ `' `-^
+;;;; Constants
+(defconstant +choice-point-placeholder+ 'choice-point-placeholder)
+
+
;;;; Utils
(declaim (inline variablep))
--- a/src/wam/compiler/5-precompilation.lisp Fri Jul 15 22:02:11 2016 +0000
+++ b/src/wam/compiler/5-precompilation.lisp Fri Jul 15 23:12:18 2016 +0000
@@ -414,10 +414,11 @@
:for last-p = (null remaining)
:for clause-instructions = (precompile-clause head body)
:do (progn
- (circle-insert-end instructions
- (cond (first-p '(:try nil))
- (last-p '(:trust))
- (t '(:retry nil))))
+ (circle-insert-end
+ instructions
+ (cond (first-p `(:try ,+choice-point-placeholder+))
+ (last-p `(:trust))
+ (t `(:retry ,+choice-point-placeholder+))))
(circle-append-circle instructions clause-instructions))
:finally (return instructions)))
functor
--- a/src/wam/compiler/6-optimization.lisp Fri Jul 15 22:02:11 2016 +0000
+++ b/src/wam/compiler/6-optimization.lisp Fri Jul 15 23:12:18 2016 +0000
@@ -13,16 +13,20 @@
;;; circle of instructions, doing one optimization each time.
-(defun* optimize-get-constant ((node circle) constant (register register))
+(defun* optimize-get-constant ((node circle)
+ (constant fname)
+ (register register))
;; 1. get_structure c/0, Ai -> get_constant c, Ai
(circle-replace node `(:get-constant ,constant ,register)))
-(defun* optimize-put-constant ((node circle) constant (register register))
+(defun* optimize-put-constant ((node circle)
+ (constant fname)
+ (register register))
;; 2. put_structure c/0, Ai -> put_constant c, Ai
(circle-replace node `(:put-constant ,constant ,register)))
(defun* optimize-subterm-constant-query ((node circle)
- constant
+ (constant fname)
(register register))
;; 3. put_structure c/0, Xi *** WE ARE HERE
;; ...
@@ -40,7 +44,7 @@
(return previous)))
(defun* optimize-subterm-constant-program ((node circle)
- constant
+ (constant fname)
(register register))
;; 4. subterm_variable Xi -> subterm_constant c
;; ...
@@ -60,28 +64,25 @@
(:returns circle)
;; From the book and the erratum, there are four optimizations we can do for
;; constants (0-arity structures).
- (flet ((constant-p (functor)
- (zerop (cdr functor))))
- (loop :for node = (circle-forward instructions) :then (circle-forward node)
- :while node
- :for (opcode . arguments) = (circle-value node)
- :do
- (match (circle-value node)
+
+ (loop :for node = (circle-forward instructions) :then (circle-forward node)
+ :while node
+ :for (opcode . arguments) = (circle-value node)
+ :do
+ (match (circle-value node)
- ((guard `(:put-structure ,functor ,register)
- (constant-p functor))
- (setf node
- (if (register-argument-p register)
- (optimize-put-constant node functor register)
- (optimize-subterm-constant-query node functor register))))
+ (`(:put-structure (,functor . 0) ,register)
+ (setf node
+ (if (register-argument-p register)
+ (optimize-put-constant node functor register)
+ (optimize-subterm-constant-query node functor register))))
- ((guard `(:get-structure ,functor ,register)
- (constant-p functor))
- (setf node
- (if (register-argument-p register)
- (optimize-get-constant node functor register)
- (optimize-subterm-constant-program node functor register))))))
- instructions))
+ (`(:get-structure (,functor . 0) ,register)
+ (setf node
+ (if (register-argument-p register)
+ (optimize-get-constant node functor register)
+ (optimize-subterm-constant-program node functor register))))))
+ instructions)
(defun* optimize-void-runs ((instructions circle))
--- a/src/wam/compiler/7-rendering.lisp Fri Jul 15 22:02:11 2016 +0000
+++ b/src/wam/compiler/7-rendering.lisp Fri Jul 15 23:12:18 2016 +0000
@@ -80,10 +80,15 @@
(defun* render-argument (argument)
(:returns code-word)
- (etypecase argument
- (null 0) ; ugly choice point args that'll be filled later...
- (register (register-number argument)) ; bytecode just needs register numbers
- (t argument))) ; everything else just gets shoved right into the array
+ (cond
+ ;; Ugly choice point args that'll be filled later...
+ ((eq +choice-point-placeholder+ argument) 0)
+
+ ;; Bytecode just needs the register numbers.
+ ((typep argument 'register) (register-number argument))
+
+ ;; Everything else just gets shoved right into the array.
+ (t argument)))
(defun* render-bytecode ((store generic-code-store)
(instructions circle)
--- a/src/wam/dump.lisp Fri Jul 15 22:02:11 2016 +0000
+++ b/src/wam/dump.lisp Fri Jul 15 23:12:18 2016 +0000
@@ -13,7 +13,7 @@
((:structure s) (format nil "struct pointer to ~8,'0X " s))
((:functor f) (destructuring-bind (functor . arity) f
(format nil "~A/~D " functor arity)))
- ((:constant c) (format nil "~A/0 " (car c)))
+ ((:constant c) (format nil "~A/0 " c))
(t ""))))
@@ -140,8 +140,10 @@
(defun pretty-functor (functor)
- (destructuring-bind (symbol . arity) functor
- (format nil "~A/~D" symbol arity)))
+ (etypecase functor
+ (symbol (format nil "~A/0" functor))
+ (cons (destructuring-bind (symbol . arity) functor
+ (format nil "~A/~D" symbol arity)))))
(defun pretty-argument (argument)
(typecase argument
--- a/src/wam/vm.lisp Fri Jul 15 22:02:11 2016 +0000
+++ b/src/wam/vm.lisp Fri Jul 15 23:12:18 2016 +0000
@@ -39,7 +39,7 @@
"Push a new functor cell onto the heap, returning its address."
(wam-heap-push! wam +cell-type-functor+ functor))
-(defun* push-new-constant! ((wam wam) (constant functor))
+(defun* push-new-constant! ((wam wam) (constant fname))
(:returns heap-index)
"Push a new constant cell onto the heap, returning its address."
(wam-heap-push! wam +cell-type-constant+ constant))
@@ -50,10 +50,10 @@
"Return whether the two functor cell values represent the same functor."
(equal f1 f2))
-(defun* constants-match-p ((c1 functor) (c2 functor))
+(defun* constants-match-p ((c1 fname) (c2 fname))
(:returns boolean)
"Return whether the two constant cell values unify."
- (equal c1 c2))
+ (eq c1 c2))
(defun* lisp-objects-match-p ((o1 t) (o2 t))
(:returns boolean)
@@ -486,10 +486,11 @@
(defun* %%procedure-call ((wam wam)
- (functor functor)
+ (functor fname)
+ (arity arity)
(program-counter-increment instruction-size)
(is-tail boolean))
- (let* ((target (wam-code-label wam (car functor) (cdr functor))))
+ (let* ((target (wam-code-label wam functor arity)))
(if (not target)
;; Trying to call an unknown procedure.
(backtrack! wam)
@@ -498,7 +499,7 @@
(setf (wam-continuation-pointer wam) ; CP <- next instruction
(+ (wam-program-counter wam) program-counter-increment)))
(setf (wam-number-of-arguments wam) ; set NARGS
- (cdr functor)
+ arity
(wam-cut-pointer wam) ; set B0 in case we have a cut
(wam-backtrack-pointer wam)
@@ -507,16 +508,17 @@
target)))))
(defun* %%dynamic-procedure-call ((wam wam) (is-tail boolean))
- (flet ((%go (functor)
- (if is-tail
- (%%procedure-call
- wam functor (instruction-size +opcode-dynamic-jump+) t)
- (%%procedure-call
- wam functor (instruction-size +opcode-dynamic-call+) nil)))
- (load-arguments (n start-address)
- (loop :for arg :from 0 :below n
- :for source :from start-address
- :do (wam-copy-to-local-register! wam arg source))))
+ (flet*
+ ((%go (functor arity)
+ (if is-tail
+ (%%procedure-call
+ wam functor arity (instruction-size +opcode-dynamic-jump+) t)
+ (%%procedure-call
+ wam functor arity (instruction-size +opcode-dynamic-call+) nil)))
+ (load-arguments ((n arity) start-address)
+ (loop :for arg :from 0 :below n
+ :for source :from start-address
+ :do (wam-copy-to-local-register! wam arg source))))
(cell-typecase (wam (deref wam 0)) ; A_0
((:structure functor-address)
;; If we have a non-zero-arity structure, we need to set up the
@@ -524,12 +526,13 @@
;; conveniently live contiguously right after the functor cell.
(cell-typecase (wam functor-address)
((:functor f)
- (load-arguments (cdr f) (1+ functor-address))
- (%go f))))
+ (destructuring-bind (functor . arity) f
+ (load-arguments arity (1+ functor-address))
+ (%go functor arity)))))
;; Zero-arity functors don't need to set up anything at all -- we can
;; just call them immediately.
- ((:constant c) (%go c))
+ ((:constant c) (%go c 0))
;; It's okay to do (call :var), but :var has to be bound by the time you
;; actually reach it at runtime.
@@ -540,10 +543,16 @@
(define-instruction (%jump) ((wam wam) (functor functor))
- (%%procedure-call wam functor (instruction-size +opcode-jump+) t))
+ (%%procedure-call wam
+ (car functor) (cdr functor)
+ (instruction-size +opcode-jump+)
+ t))
(define-instruction (%call) ((wam wam) (functor functor))
- (%%procedure-call wam functor (instruction-size +opcode-call+) nil))
+ (%%procedure-call wam
+ (car functor) (cdr functor)
+ (instruction-size +opcode-call+)
+ nil))
(define-instruction (%dynamic-call) ((wam wam))
@@ -694,7 +703,7 @@
(defun* %%match-constant
((wam wam)
- (constant functor)
+ (constant fname)
(address store-index))
(cell-typecase (wam (deref wam address) address)
(:reference
@@ -710,19 +719,19 @@
(define-instruction (%put-constant)
((wam wam)
- (constant functor)
+ (constant fname)
(register register-index))
(wam-set-local-register! wam register +cell-type-constant+ constant))
(define-instruction (%get-constant)
((wam wam)
- (constant functor)
+ (constant fname)
(register register-index))
(%%match-constant wam constant register))
(define-instruction (%subterm-constant)
((wam wam)
- (constant functor))
+ (constant fname))
(ecase (wam-mode wam)
(:read (%%match-constant wam constant (wam-subterm wam)))
(:write (push-new-constant! wam constant)))
@@ -756,7 +765,7 @@
((:reference r) (extract-var r))
((:structure s) (recur s))
((:list l) (cons (recur l) (recur (1+ l))))
- ((:constant c) (car c))
+ ((:constant c) c)
((:functor f)
(destructuring-bind (functor . arity) f
(list* functor
--- a/src/wam/wam.lisp Fri Jul 15 22:02:11 2016 +0000
+++ b/src/wam/wam.lisp Fri Jul 15 23:12:18 2016 +0000
@@ -199,7 +199,7 @@
(define-unsafe %unsafe-structure-value store-index)
(define-unsafe %unsafe-reference-value store-index)
(define-unsafe %unsafe-functor-value functor)
- (define-unsafe %unsafe-constant-value functor)
+ (define-unsafe %unsafe-constant-value fname)
(define-unsafe %unsafe-list-value store-index)
(define-unsafe %unsafe-lisp-object-value t)
(define-unsafe %unsafe-stack-value stack-word))