# HG changeset patch # User Steve Losh # Date 1468624338 0 # Node ID ec2fab887b0fdcbded2b99f6b4e0cd20bf30f90b # Parent c4dd0b6c3a9148667d2d736ff6ee71762c28d0b4 Constant can just use the functor symbol directly diff -r c4dd0b6c3a91 -r ec2fab887b0f src/wam/compiler/0-data.lisp --- 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)) diff -r c4dd0b6c3a91 -r ec2fab887b0f src/wam/compiler/5-precompilation.lisp --- 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 diff -r c4dd0b6c3a91 -r ec2fab887b0f src/wam/compiler/6-optimization.lisp --- 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)) diff -r c4dd0b6c3a91 -r ec2fab887b0f src/wam/compiler/7-rendering.lisp --- 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) diff -r c4dd0b6c3a91 -r ec2fab887b0f src/wam/dump.lisp --- 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 diff -r c4dd0b6c3a91 -r ec2fab887b0f src/wam/vm.lisp --- 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 diff -r c4dd0b6c3a91 -r ec2fab887b0f src/wam/wam.lisp --- 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))