# HG changeset patch # User Steve Losh # Date 1468632844 0 # Node ID f1ef8f905a1d4f583e59547de2de1e8d7ba34bba # Parent ec2fab887b0fdcbded2b99f6b4e0cd20bf30f90b Split functor cells into separate functor and arity cells This lets us keep everything we need for unification right in the contiguous main store array. It also makes GC a bit easier to deal with, because all the references to things outside the WAM are kept in basically one place. diff -r ec2fab887b0f -r f1ef8f905a1d src/wam/bytecode.lisp --- a/src/wam/bytecode.lisp Fri Jul 15 23:12:18 2016 +0000 +++ b/src/wam/bytecode.lisp Sat Jul 16 01:34:04 2016 +0000 @@ -104,13 +104,13 @@ " (#.+opcode-noop+ 1) - (#.+opcode-get-structure+ 3) + (#.+opcode-get-structure+ 4) (#.+opcode-get-variable-local+ 3) (#.+opcode-get-variable-stack+ 3) (#.+opcode-get-value-local+ 3) (#.+opcode-get-value-stack+ 3) - (#.+opcode-put-structure+ 3) + (#.+opcode-put-structure+ 4) (#.+opcode-put-variable-local+ 3) (#.+opcode-put-variable-stack+ 3) (#.+opcode-put-value-local+ 3) @@ -122,8 +122,8 @@ (#.+opcode-subterm-value-stack+ 2) (#.+opcode-subterm-void+ 2) - (#.+opcode-jump+ 2) - (#.+opcode-call+ 2) + (#.+opcode-jump+ 3) + (#.+opcode-call+ 3) (#.+opcode-dynamic-jump+ 1) (#.+opcode-dynamic-call+ 1) (#.+opcode-proceed+ 1) diff -r ec2fab887b0f -r f1ef8f905a1d src/wam/compiler/5-precompilation.lisp --- a/src/wam/compiler/5-precompilation.lisp Fri Jul 15 23:12:18 2016 +0000 +++ b/src/wam/compiler/5-precompilation.lisp Sat Jul 16 01:34:04 2016 +0000 @@ -201,7 +201,8 @@ ;; OP functor reg (push destination-register seen) (push-instruction (find-opcode-structure mode) - (cons functor arity) + functor + arity destination-register)) (handle-list (register) (push register seen) @@ -219,9 +220,7 @@ ;; DYNAMIC-[CALL/JUMP] (push-instruction (if is-jump :dynamic-jump :dynamic-call)) ;; [CALL/JUMP] functor - (push-instruction - (if is-jump :jump :call) - (cons functor arity))) + (push-instruction (if is-jump :jump :call) functor arity)) ;; This is a little janky, but at this point the body goals have been ;; turned into one single stream of tokens, so we don't have a nice ;; clean way to tell when one ends. But in practice, a body goal is diff -r ec2fab887b0f -r f1ef8f905a1d src/wam/compiler/6-optimization.lisp --- a/src/wam/compiler/6-optimization.lisp Fri Jul 15 23:12:18 2016 +0000 +++ b/src/wam/compiler/6-optimization.lisp Sat Jul 16 01:34:04 2016 +0000 @@ -71,13 +71,13 @@ :do (match (circle-value node) - (`(:put-structure (,functor . 0) ,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)))) - (`(:get-structure (,functor . 0) ,register) + (`(:get-structure ,functor 0 ,register) (setf node (if (register-argument-p register) (optimize-get-constant node functor register) diff -r ec2fab887b0f -r f1ef8f905a1d src/wam/constants.lisp --- a/src/wam/constants.lisp Fri Jul 15 23:12:18 2016 +0000 +++ b/src/wam/constants.lisp Sat Jul 16 01:34:04 2016 +0000 @@ -49,7 +49,7 @@ :documentation "The maximum size (in bytes of bytecode) a query may compile to.") -(define-constant +maximum-instruction-size+ 3 +(define-constant +maximum-instruction-size+ 4 :documentation "The maximum number of code words an instruction (including opcode) might be.") diff -r ec2fab887b0f -r f1ef8f905a1d src/wam/dump.lisp --- a/src/wam/dump.lisp Fri Jul 15 23:12:18 2016 +0000 +++ b/src/wam/dump.lisp Sat Jul 16 01:34:04 2016 +0000 @@ -11,9 +11,8 @@ "unbound variable " (format nil "var pointer to ~8,'0X " r))) ((: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 " c)) + ((:functor f) (format nil "functor symbol ~A " f)) + ((:constant c) (format nil "constant symbol ~A " c)) (t "")))) @@ -43,7 +42,7 @@ :do (progn (print-cell address indent) (cell-typecase (wam address) - ((:functor f) (setf indent (cdr f))) + ((:functor f n) (declare (ignore f)) (setf indent n)) (t (when (not (zerop indent)) (decf indent))))))) (when (< to (wam-heap-pointer wam)) @@ -163,16 +162,18 @@ (defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments) - (format nil "GETS~A ; X~A = ~A" + (format nil "GETS~A ; X~A = ~A/~D" (pretty-arguments arguments) - (second arguments) - (pretty-functor (first arguments)))) + (third arguments) + (first arguments) + (second arguments))) (defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments) - (format nil "PUTS~A ; X~A <- new ~A" + (format nil "PUTS~A ; X~A <- new ~A/~D" (pretty-arguments arguments) - (second arguments) - (pretty-functor (first arguments)))) + (third arguments) + (first arguments) + (second arguments))) (defmethod instruction-details ((opcode (eql +opcode-get-variable-local+)) arguments) (format nil "GVAR~A ; X~A <- A~A" @@ -223,14 +224,16 @@ (first arguments))) (defmethod instruction-details ((opcode (eql +opcode-call+)) arguments) - (format nil "CALL~A ; call ~A" + (format nil "CALL~A ; call ~A/~D" (pretty-arguments arguments) - (first arguments))) + (first arguments) + (second arguments))) (defmethod instruction-details ((opcode (eql +opcode-jump+)) arguments) - (format nil "JUMP~A ; jump ~A" + (format nil "JUMP~A ; jump ~A/~D" (pretty-arguments arguments) - (first arguments))) + (first arguments) + (second arguments))) (defmethod instruction-details ((opcode (eql +opcode-dynamic-call+)) arguments) (format nil "DYCL~A ; dynamic call" diff -r ec2fab887b0f -r f1ef8f905a1d src/wam/types.lisp --- a/src/wam/types.lisp Fri Jul 15 23:12:18 2016 +0000 +++ b/src/wam/types.lisp Sat Jul 16 01:34:04 2016 +0000 @@ -39,9 +39,6 @@ (deftype arity () `(integer 0 ,+maximum-arity+)) -(deftype functor () - '(cons fname arity)) - (deftype code-index () ;; either an address or the sentinel diff -r ec2fab887b0f -r f1ef8f905a1d src/wam/vm.lisp --- a/src/wam/vm.lisp Fri Jul 15 23:12:18 2016 +0000 +++ b/src/wam/vm.lisp Sat Jul 16 01:34:04 2016 +0000 @@ -34,10 +34,12 @@ " (wam-heap-push! wam +cell-type-list+ (1+ (wam-heap-pointer wam)))) -(defun* push-new-functor! ((wam wam) (functor functor)) +(defun* push-new-functor! ((wam wam) (functor fname) (arity arity)) (:returns heap-index) - "Push a new functor cell onto the heap, returning its address." - (wam-heap-push! wam +cell-type-functor+ functor)) + "Push a new functor cell pair onto the heap, returning its address." + (prog1 + (wam-heap-push! wam +cell-type-functor+ functor) + (wam-heap-push! wam +cell-type-lisp-object+ arity))) (defun* push-new-constant! ((wam wam) (constant fname)) (:returns heap-index) @@ -45,10 +47,12 @@ (wam-heap-push! wam +cell-type-constant+ constant)) -(defun* functors-match-p ((f1 functor) (f2 functor)) +(defun* functors-match-p ((f1 fname) (a1 arity) + (f2 fname) (a2 arity)) (:returns boolean) "Return whether the two functor cell values represent the same functor." - (equal f1 f2)) + (and (eq f1 f2) + (= a1 a2))) (defun* constants-match-p ((c1 fname) (c2 fname)) (:returns boolean) @@ -228,14 +232,15 @@ (let* ((s1 (wam-store-value wam d1)) ; find where they (s2 (wam-store-value wam d2)) ; start on the heap (f1 (wam-store-value wam s1)) ; grab the - (f2 (wam-store-value wam s2))) ; functors - (if (functors-match-p f1 f2) + (f2 (wam-store-value wam s2)) ; functors + (a1 (wam-store-value wam (1+ s1))) ; and the + (a2 (wam-store-value wam (1+ s2)))) ; arities + (if (functors-match-p f1 a1 f2 a2) ;; If the functors match, push their pairs of arguments onto ;; the stack to be unified. - (loop :with arity = (cdr f1) - :repeat arity - :for subterm1 :from (1+ s1) - :for subterm2 :from (1+ s2) + (loop :repeat a1 + :for subterm1 :from (+ 2 s1) + :for subterm2 :from (+ 2 s2) :do (wam-unification-stack-push! wam subterm1 subterm2)) ;; Otherwise we're hosed. (backtrack! wam)))) @@ -335,11 +340,12 @@ ;;;; Query Instructions (define-instruction (%put-structure) ((wam wam) - (functor functor) + (functor fname) + (arity arity) (register register-index)) (wam-set-local-register! wam register +cell-type-structure+ - (push-new-functor! wam functor)) + (push-new-functor! wam functor arity)) (setf (wam-mode wam) :write)) (define-instruction (%put-list) @@ -370,14 +376,16 @@ ;;;; Program Instructions (define-instruction (%get-structure) ((wam wam) - (functor functor) + (functor fname) + (arity arity) (register register-index)) (cell-typecase (wam (deref wam register) address) - ;; If the register points at an unbound reference cell, we push two new + ;; If the register points at an unbound reference cell, we push three new ;; cells onto the heap: ;; ;; | N | STR | N+1 | - ;; | N+1 | FUN | f/n | + ;; | N+1 | FUN | f | + ;; | N+2 | OBJ | n | ;; | | | | <- S ;; ;; Then we bind this reference cell to point at the new structure, set @@ -389,34 +397,30 @@ ;; mode). (:reference (let ((structure-address (push-new-structure! wam)) - (functor-address (push-new-functor! wam functor))) + (functor-address (push-new-functor! wam functor arity))) (bind! wam address structure-address) (setf (wam-mode wam) :write - (wam-subterm wam) (1+ functor-address)))) + (wam-subterm wam) (+ 2 functor-address)))) ;; If the register points at a structure cell, then we look at where - ;; that cell points (which will be the functor cell for the structure): + ;; that cell points (which will be the functor for the structure): ;; ;; | N | STR | M | points at the structure, not necessarily contiguous ;; | ... | - ;; | M | FUN | f/2 | the functor (hopefully it matches) - ;; | M+1 | ... | ... | pieces of the structure, always contiguous - ;; | M+2 | ... | ... | and always right after the functor + ;; | M | FUN | f | the functor (hopefully it matches) + ;; | M+1 | OBJ | 2 | the arity (hopefully it matches) + ;; | M+2 | ... | ... | pieces of the structure, always contiguous + ;; | M+3 | ... | ... | and always right after the functor ;; ;; If it matches the functor we're looking for, we can proceed. We set ;; the S register to the address of the first subform we need to match - ;; (M+1 in the example above). - ;; - ;; What about if it's a 0-arity functor? The S register will be set to - ;; garbage. But that's okay, because we know the next thing in the - ;; stream of instructions will be another get-structure and we'll just - ;; blow away the S register there. + ;; (M+2 in the example above). ((:structure functor-address) (cell-typecase (wam functor-address) - ((:functor f) - (if (functors-match-p functor f) + ((:functor f n) + (if (functors-match-p functor arity f n) (setf (wam-mode wam) :read - (wam-subterm wam) (1+ functor-address)) + (wam-subterm wam) (+ 2 functor-address)) (backtrack! wam))))) ;; Otherwise we can't unify, so backtrack. @@ -525,10 +529,9 @@ ;; argument registers before we call it. Luckily all the arguments ;; conveniently live contiguously right after the functor cell. (cell-typecase (wam functor-address) - ((:functor f) - (destructuring-bind (functor . arity) f - (load-arguments arity (1+ functor-address)) - (%go functor arity))))) + ((:functor functor arity) + (load-arguments arity (+ 2 functor-address)) + (%go functor arity)))) ;; Zero-arity functors don't need to set up anything at all -- we can ;; just call them immediately. @@ -542,15 +545,13 @@ (t (error "Cannot dynamically call something other than a structure."))))) -(define-instruction (%jump) ((wam wam) (functor functor)) - (%%procedure-call wam - (car functor) (cdr functor) +(define-instruction (%jump) ((wam wam) (functor fname) (arity arity)) + (%%procedure-call wam functor arity (instruction-size +opcode-jump+) t)) -(define-instruction (%call) ((wam wam) (functor functor)) - (%%procedure-call wam - (car functor) (cdr functor) +(define-instruction (%call) ((wam wam) (functor fname) (arity arity)) + (%%procedure-call wam functor arity (instruction-size +opcode-call+) nil)) @@ -766,12 +767,11 @@ ((:structure s) (recur s)) ((:list l) (cons (recur l) (recur (1+ l)))) ((:constant c) c) - ((:functor f) - (destructuring-bind (functor . arity) f - (list* functor - (loop :repeat arity - :for subterm :from (+ address 1) - :collect (recur subterm))))) + ((:functor functor arity) + (list* functor + (loop :repeat arity + :for subterm :from (+ 2 address) + :collect (recur subterm)))) ((:lisp-object o) o) (t (error "What to heck is this?"))))) (mapcar #'recur addresses)))) @@ -933,9 +933,7 @@ term &key ((result-function function) - (lambda (results) (declare (ignore results)))) - ((status-function function) - (lambda (failp) (declare (ignore failp))))) + (lambda (results) (declare (ignore results))))) "Compile query `term` and run the instructions on the `wam`. Resets the heap, etc before running. @@ -945,14 +943,12 @@ " (let ((vars (compile-query wam term))) - (wam-reset! wam) (setf (wam-program-counter wam) 0 (wam-continuation-pointer wam) +code-sentinel+) (run wam (lambda () (funcall result-function - (extract-query-results wam vars)))) - (when status-function - (funcall status-function (wam-fail wam)))) + (extract-query-results wam vars))))) + (wam-reset! wam) (values)) diff -r ec2fab887b0f -r f1ef8f905a1d src/wam/wam.lisp --- a/src/wam/wam.lisp Fri Jul 15 23:12:18 2016 +0000 +++ b/src/wam/wam.lisp Sat Jul 16 01:34:04 2016 +0000 @@ -195,14 +195,14 @@ (defun* ,name ((wam wam) (address store-index)) (:returns ,return-type) (aref (wam-value-store wam) address))))) - (define-unsafe %unsafe-null-value (eql 0)) - (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 fname) - (define-unsafe %unsafe-list-value store-index) + (define-unsafe %unsafe-null-value (eql 0)) + (define-unsafe %unsafe-structure-value store-index) + (define-unsafe %unsafe-reference-value store-index) + (define-unsafe %unsafe-functor-value fname) + (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)) + (define-unsafe %unsafe-stack-value stack-word)) (defun %type-designator-constant (designator) @@ -226,6 +226,30 @@ (:list '%unsafe-list-value) (:lisp-object '%unsafe-lisp-object-value))) +(defun parse-cell-typecase-clause (wam address clause) + "Parse a `cell-typecase` clause into the appropriate `ecase` clause." + (destructuring-bind (binding . body) clause + (destructuring-bind + (type-designator &optional value-symbol secondary-value-symbol) + (if (symbolp binding) (list binding) binding) ; normalize binding + (let ((primary-let-binding + (when value-symbol + `((,value-symbol (,(%type-designator-accessor type-designator) + ,wam ,address))))) + (secondary-let-binding + (when secondary-value-symbol + `((,secondary-value-symbol + ,(ecase type-designator + (:functor + `(the arity (%unsafe-lisp-object-value ; yolo + ,wam + (1+ ,address)))))))))) + ; build the ecase clause (const ...body...) + (list + (%type-designator-constant type-designator) + `(let (,@primary-let-binding + ,@secondary-let-binding) + ,@body)))))) (defmacro cell-typecase ((wam address &optional address-symbol) &rest clauses) "Dispatch on the type of the cell at `address` in the WAM store. @@ -252,31 +276,15 @@ " (once-only (wam address) - (labels - ((normalize-binding (binding) - (cond - ((symbolp binding) (list binding nil)) - ((= 1 (length binding)) (list (car binding) nil)) - (t binding))) - (parse-clause (clause) - (destructuring-bind (binding . body) clause - (destructuring-bind (type-designator value-symbol) - (normalize-binding binding) - `(,(%type-designator-constant type-designator) - (let (,@(when value-symbol - (list - `(,value-symbol - (,(%type-designator-accessor type-designator) - ,wam ,address))))) - ,@body)))))) - `(progn - (policy-cond:policy-if (or (= safety 3) (= debug 3)) - (wam-sanity-check-store-read ,wam ,address) - nil) - (let (,@(when address-symbol - (list `(,address-symbol ,address)))) - (case (wam-store-type ,wam ,address) - ,@(mapcar #'parse-clause clauses))))))) + `(progn + (policy-cond:policy-if (or (= safety 3) (= debug 3)) + (wam-sanity-check-store-read ,wam ,address) + nil) + (let (,@(when address-symbol + (list `(,address-symbol ,address)))) + (case (wam-store-type ,wam ,address) + ,@(mapcar (curry #'parse-cell-typecase-clause wam address) + clauses)))))) (defmacro cell-type= (type type-designator) @@ -708,6 +716,7 @@ ;; todo we can't elide this once we start storing live objects... :( (wam-reset-local-registers! wam) nil) ; fuck it + (fill (wam-code wam) 0 :start 0 :end +maximum-query-size+) (setf (wam-program-counter wam) 0 (wam-continuation-pointer wam) 0 (wam-environment-pointer wam) +stack-start+