├── .gitignore ├── README.md ├── alloc1.lisp ├── asm.lisp ├── coder.lisp ├── compare ├── README.md ├── ctest4.pl ├── grandfather.pl ├── ltest16.pl ├── ltest17.pl ├── ltest18.pl ├── ltest7.pl ├── ltest8.pl ├── t13.pl ├── t14.pl ├── t15.pl └── test0.pl ├── const.lisp ├── io.lisp ├── opcodes.lisp ├── package.lisp ├── parse.lisp ├── readme ├── store.lisp ├── tags.lisp ├── test ├── parse-test.lisp └── test.lisp ├── wam-debug.lisp ├── wam.asd ├── wam.lisp └── wutil.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *64xfasl 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | WAM is essentially a byte-code compiler and interpreter. 2 | 3 | As compilation proceeds, byte-codes are shoved (linearly, as a stream) into the "HEAP". 4 | 5 | L0 compilation of queries uses 3 bytecodes: 6 | 7 | (NB, the text refers to the HEAP as a stack, but it is not used as a push/pop stack, it has only one operation "push") 8 | 9 | 1. put_structure 10 | - places a bytecode into the heap 11 | - if the structure has not yet been seen, then it is compiled into the heap immediately after the bytecode 12 | -- a bytecode 13 | -- the rest of the terms belonging to the structure (constants, Variables, nested structs) compiled to bytecodes 14 | - if the structure has been seen, then there are no succeeding bytecodes and the addr part of the bytecode points backwards in the heap to the address of the already-seen structure 15 | 16 | 2. set_variable 17 | - create a (logic) variable in the heap 18 | - copy it into the given register (I've broken this into 2 bytecodes, one for Xi and another for Yi) 19 | 20 | 3. set_value 21 | 22 | 23 | PUT and GET bytecodes 24 | 25 | In general, "Put" bytecodes move items into the argument (Ai) registers. 26 | 27 | In general, "Get" bytecodes move items from the argument (Ai) registers. 28 | 29 | 30 | EXAMPLE: 31 | 32 | LTEST0: 33 | 34 | prolog: 35 | father(son-of-paul, paul). 36 | ?- fathter(X,paul). 37 | 38 | intermediate sexprs: 39 | (wam:defrel father 40 | ((father son-of-paul paul))) 41 | (wam:?- (father ?X paul)) 42 | 43 | emitted WAM code: 44 | $FATHER/2 45 | WAM::GET-CONSTANT "SON-OF-PAUL" 1 46 | WAM::GET-CONSTANT "PAUL" 2 47 | WAM::PROCEED 48 | $QUERY/0 49 | WAM::ALLOCATE 50 | WAM::PUT-Y-VARIABLE 1 1 51 | WAM::PUT-CONSTANT "PAUL" 2 52 | WAM::CALL ?FATHER/2 1 53 | WAM::DONE 54 | WAM::DEALLOCATE 55 | 56 | explanation of emitted code: 57 | "$" is a label 58 | "?" is a reference to a label 59 | 60 | 1. The $FATHER code says to get the constant "SON-OF-PAUL from A1. If A1 contains a prolog variable (), then unify the variable with the constant. 61 | 62 | 2. Then, get the constant "PAUL" from A2. 63 | 64 | 3. PROCEED: End the current execution leg. In this case, there is only one leg. 65 | 66 | $query/0 67 | 68 | 4. Allocate a new frame. bug? Allocate should be told to allocate 1 local 69 | 70 | 5. Create a Variable unbound in the 1st local and 71 | 72 | 6. Call ?FATHER/2 and leave 1 local on the stack afterwards. 73 | 74 | 7. DONE is not defined by WAM. It is a utility byte-code in this implementation. 75 | 76 | 8. DEALLOCATE - pops the environment (for $query/0) off of the stack, removing local variables in the process. 77 | 78 | 79 | LTEST1: 80 | 81 | prolog: 82 | 83 | father(paul,father_of_paul). 84 | father(son_of_paul,paul). 85 | father(daughter_of_paul,paul). 86 | ?- father(X,Y). 87 | 88 | sexprs: 89 | (wam:defrel father 90 | ((father paul father-of-paul)) 91 | ((father son-of-paul paul)) 92 | ((father daughter-of-paul paul))) 93 | (wam:?- (father ?X ?Y))) 94 | 95 | WAM: 96 | $FATHER/2 97 | WAM::TRY-ME-ELSE ?L1 98 | WAM::GET-CONSTANT "PAUL" 1 99 | WAM::GET-CONSTANT "FATHER-OF-PAUL" 2 100 | WAM::PROCEED 101 | $L1 102 | WAM::RETRY-ME-ELSE ?L2 103 | WAM::GET-CONSTANT "SON-OF-PAUL" 1 104 | WAM::GET-CONSTANT "PAUL" 2 105 | WAM::PROCEED 106 | $L2 107 | WAM::TRUST-ME 108 | WAM::GET-CONSTANT "DAUGHTER-OF-PAUL" 1 109 | WAM::GET-CONSTANT "PAUL" 2 110 | WAM::PROCEED 111 | $QUERY/0 112 | WAM::ALLOCATE 113 | WAM::PUT-Y-VARIABLE 1 1 114 | WAM::PUT-Y-VARIABLE 2 2 115 | WAM::CALL ?FATHER/2 2 116 | WAM::DONE 117 | WAM::DEALLOCATE 118 | 119 | almost the same as above, except with backtracking "legs" TRY-ME-ELSE, RETRY-ME-ELSE, TRUST-ME. 120 | 121 | 122 | LTEST7: 123 | 124 | prolog: 125 | s(a,b,c). 126 | ?- s(X). 127 | 128 | sexprs: 129 | (wam:defrel s ((s #(a b c)))) 130 | (wam:?- (s ?X)))) 131 | 132 | WAM: 133 | 134 | $S/1 135 | QUOTE 136 | WAM::GET-STRUCTURE "A/2" 1 137 | WAM::UNIFY-CONSTANT "B" 138 | WAM::UNIFY-CONSTANT "C" 139 | WAM::PROCEED 140 | $QUERY/0 141 | WAM::ALLOCATE 142 | WAM::PUT-Y-VARIABLE 1 1 143 | WAM::CALL ?S/1 1 144 | WAM::DONE 145 | WAM::DEALLOCATE 146 | -------------------------------------------------------------------------------- /alloc1.lisp: -------------------------------------------------------------------------------- 1 | ; $Id: alloc1.lisp,v 1.4 2006/02/08 05:28:12 tarvydas Exp $ 2 | ; Copyright 2006 Paul Tarvydas 3 | 4 | ;; rewrite parse tree to include allocation information 5 | 6 | ;; now each node of kind const/var/list/struct contains 7 | ;; an extra item specifying where the item resides - in an 8 | ;; X (temporary) register or a Y (stacked) register 9 | 10 | ;; A (argument) registers are not treated by this allocator 11 | ;; since they are trivially decided by the parse - e.g. 12 | ;; the first argument always goes in the A1 register, the 13 | ;; second into A2, etc. 14 | 15 | ;; To allow the "environment trimming" optimization, 16 | ;; Y registers must be assigned in reverse order 17 | ;; of longevity, i.e. the lowest Y registers are 18 | ;; assigned to the variables that appear last in 19 | ;; rule body. 20 | 21 | ;; Y registers are assigned to any variable that 22 | ;; appears in more than one clause in the body - i.e. 23 | ;; variables that appear in more than one clause 24 | ;; must be stacked (Y) to preserve their value 25 | ;; through the subsequent calls. All other variables 26 | ;; and temporary results are put into X registers (X 27 | ;; registers are not stacked and can be overwritten 28 | ;; by subsequent calls). 29 | 30 | ;; For purposes of allocation, the head of a rule is 31 | ;; considered to be merged with the first clause of 32 | ;; the body. 33 | 34 | ;; During allocation, we maintain a simplistic symbol 35 | ;; table (an alist). After allocation the parse tree 36 | ;; itself contains the resulting information and the 37 | ;; symbol table is discarded. 38 | 39 | (in-package :wam) 40 | 41 | (defun allocate (tree) 42 | (let ((symbols (nreverse (alloc-top-level tree 0 nil))) 43 | (has-locals nil)) 44 | (setf has-locals 45 | (if (is-query tree) 46 | (mark-all-symbols-as-y symbols) 47 | (find-y-variables symbols))) 48 | (when (has-cut tree) 49 | (setf has-locals t)) 50 | (when symbols 51 | (let ((y-sorted (sort-by-longevity (extract-y-vars symbols)))) 52 | (assign-y-regs y-sorted (if (has-cut tree) 1 0)))) 53 | (assign-x-regs tree symbols) 54 | (assign-call-locals tree symbols) 55 | (values tree symbols has-locals))) 56 | 57 | (defun has-cut (tree) 58 | (or (eq 'rule-with-cut (caar tree)) 59 | (eq 'query-with-cut (caar tree)))) 60 | 61 | (defstruct alloc 62 | is-temp 63 | reg 64 | first-clause 65 | last-clause 66 | is-seen) 67 | 68 | (defun make-temp (clause-num) 69 | (make-alloc :is-temp t :first-clause clause-num :last-clause clause-num 70 | :is-seen nil)) 71 | 72 | (defun lookup (sym symbol-table) 73 | (assoc sym symbol-table)) 74 | 75 | (defun alloc-top-level (tree clause-num symbols) 76 | (if (null tree) 77 | symbols 78 | (alloc-top-level (cdr tree) (1+ clause-num) 79 | (alloc (car tree) clause-num symbols nil)))) 80 | 81 | (defun alloc (tree clause-num symbols nested) 82 | (if (null tree) 83 | symbols 84 | (if (listp (car tree)) 85 | (alloc (cdr tree) clause-num 86 | (alloc (car tree) clause-num symbols nested) nested) 87 | (ecase (car tree) 88 | ((rule rule-with-cut) 89 | (alloc (cdddr tree) clause-num symbols nested)) 90 | ((query query-with-cut) 91 | (alloc-top-level (cdr tree) 0 symbols)) 92 | (proc 93 | (alloc (cddr tree) clause-num symbols nested)) 94 | ((cut neck-cut) 95 | symbols) 96 | (struct 97 | ; create a temp reg to hold the struct, if not at top-level 98 | (let ((temp (if nested (make-temp clause-num) nil))) 99 | (when temp 100 | (push (cons '+anon+ temp) symbols)) 101 | (setf (cdddr tree) 102 | `(,temp ,@(cdddr tree))) 103 | (alloc (cddddr tree) clause-num symbols t))) 104 | (list 105 | ;; create a temp for every cell of a list 106 | ;; modify the list so that contains a list of 107 | ;; pairs - the first of each pair is the cell's temp 108 | ;; descriptor, the second of each pair is the 109 | ;; list item, properly allocated 110 | ;; restricted to [x|y] form, so we're only ever 111 | ;; working with one cell at a time 112 | (let ((list-temp (make-temp clause-num))) 113 | (push (cons '+lanon+ list-temp) symbols) 114 | ;; now allocate everything inside of the list and 115 | ;; keep updating the symbols table 116 | (mapc #'(lambda (item) 117 | (let ((new-syms (alloc item clause-num symbols t))) 118 | (setf symbols new-syms))) 119 | (cdr tree)) 120 | ;; now rearrange the tree so that the first node is 121 | ;; the list temp, the rest is the list 122 | (setf (cdr tree) 123 | (cons list-temp (cdr tree))) 124 | symbols)) 125 | (const 126 | symbols) 127 | (var 128 | (let* ((sym (second tree)) 129 | (v (lookup sym symbols)) 130 | (alloc (if v (cdr v) (make-temp clause-num)))) 131 | (when (> clause-num (alloc-last-clause alloc)) 132 | (setf (alloc-last-clause alloc) clause-num)) 133 | (setf (cdr tree) 134 | `(,alloc 135 | ,(second tree))) 136 | (if v 137 | symbols 138 | (cons (cons sym alloc) symbols)))))))) 139 | 140 | (defun assign-call-locals (tree symbols) 141 | (if (is-query tree) 142 | (let ((nlocals (all-locals symbols))) 143 | (when (has-cut tree) 144 | (incf nlocals)) 145 | (loop for clause in (cdar tree) 146 | do (when (eq 'proc (first clause)) 147 | (let ((c (second clause))) 148 | (setf (call-locals c) nlocals))))) 149 | (let ((nloc (if (has-cut tree) 1 0))) 150 | (loop for clause-num from 0 below (length tree) 151 | for clause in tree 152 | do (when (eq 'proc (first clause)) 153 | (let ((c (second clause))) 154 | (setf (call-locals c) 155 | (count-locals clause-num symbols nloc)))))))) 156 | 157 | (defun all-locals (symbols) 158 | ; return a count of all the local symbols in the symbols list 159 | (let ((count 0)) 160 | (dolist (sym symbols) 161 | (let ((alloc (cdr sym))) 162 | (when (not (alloc-is-temp alloc)) 163 | (incf count)))) 164 | count)) 165 | 166 | (defun count-locals (clause-num symbols start) 167 | ; return a count of the locals which remain active after 168 | ; the given clause 169 | (let ((count start)) 170 | (dolist (sym symbols) 171 | (let ((alloc (cdr sym))) 172 | (when (and (not (alloc-is-temp alloc)) 173 | (< clause-num (alloc-last-clause alloc))) 174 | (incf count)))) 175 | count)) 176 | 177 | (defun find-y-variables (symbols) 178 | ; A Y variable (one that is saved to the stack) is 179 | ; one whose lifetime spans two or more clauses, where 180 | ; the rule head (clause #0) is considered to be the same 181 | ; as the first clause (clause #1) 182 | ; This routine sets the is-temp flag to nil for every Y variable. 183 | (mapc #'mark-y symbols) 184 | (some #'(lambda (pair) (not (alloc-is-temp (cdr pair)))) symbols)) ; return t if any locals 185 | 186 | (defun mark-y (var) 187 | (let* ((alloc (cdr var)) 188 | (first-clause (alloc-first-clause alloc)) 189 | (last-clause (alloc-last-clause alloc))) 190 | (unless (or (= first-clause last-clause) 191 | (and (= first-clause 0) 192 | (= last-clause 1))) 193 | (setf (alloc-is-temp alloc) nil)))) 194 | 195 | (defun mark-all-symbols-as-y (symbols) 196 | (let ((has-locals nil)) 197 | (mapc #'(lambda (var) 198 | (setf has-locals t) 199 | (setf (alloc-is-temp (cdr var)) nil) 200 | (setf (alloc-last-clause (cdr var)) most-positive-fixnum)) 201 | symbols) 202 | has-locals)) 203 | 204 | (defun is-query (tree) 205 | (or (eq 'query (caar tree)) 206 | (eq 'query-with-cut (caar tree)))) 207 | 208 | (defun extract-y-vars (symbols) 209 | ; return a new list of (pointers to) the y-variables 210 | (if (null symbols) 211 | nil 212 | (if (alloc-is-temp (cdar symbols)) 213 | (extract-y-vars (cdr symbols)) 214 | (cons (car symbols) (extract-y-vars (cdr symbols)))))) 215 | 216 | (defun sort-by-longevity (y-list) 217 | (sort y-list #'(lambda (a b) 218 | (> (alloc-last-clause (cdr a)) 219 | (alloc-last-clause (cdr b)))))) 220 | 221 | (defun assign-y-regs (y-list extra) 222 | ;; extra is 0 if no cut, 1 if cut (alloc extra y reg for cut reg) 223 | (loop for reg from 1 upto (length y-list) 224 | for y in y-list 225 | do (setf (alloc-reg (cdr y)) (+ reg extra)))) 226 | 227 | (defun assign-x-regs (tree symbols) 228 | (let ((reg (if (eq 'query (caar tree)) 229 | 0 230 | (third (car tree))))) 231 | (loop for var in symbols 232 | do (when (alloc-is-temp (cdr var)) 233 | (setf (alloc-reg (cdr var)) (incf reg)))))) 234 | 235 | 236 | 237 | (defun atest0 () 238 | (multiple-value-bind (tree symbols n-locals) 239 | (allocate (parse-rule '((father paul albin)))) 240 | (pprint symbols) 241 | (pprint tree) 242 | (print n-locals))) 243 | 244 | (defun atest1 () 245 | (multiple-value-bind (tree symbols n-locals) 246 | (allocate (parse-rule '((grandfather ?x ?y) (father ?x ?y) (father ?z ?y)))) 247 | (pprint symbols) 248 | (pprint tree) 249 | (print n-locals))) 250 | 251 | (defun atest2 () 252 | (multiple-value-bind (tree symbols n-locals) 253 | (allocate (parse-rule '((p #(f ?X) #(h ?Y #(f a)) ?Y)))) 254 | (pprint symbols) 255 | (pprint tree) 256 | (print n-locals))) 257 | 258 | (defun atest3 () 259 | (multiple-value-bind (tree symbols n-locals) 260 | (allocate (parse-rule '((append () ?x ?x)))) 261 | (pprint symbols) 262 | (pprint tree) 263 | (print n-locals))) 264 | 265 | (defun atest4 () 266 | (multiple-value-bind (tree symbols n-locals) 267 | (allocate (parse-rule '((append (?u . ?x) ?y (?u . ?z)) 268 | (append ?x ?y ?z)))) 269 | (pprint symbols) 270 | (pprint tree) 271 | (print n-locals))) 272 | 273 | (defun atest5 () 274 | (multiple-value-bind (tree symbols n-locals) 275 | (allocate (parse-query '((p ?Z #(h ?Z ?W) #(f ?W))))) 276 | (pprint symbols) 277 | (pprint tree) 278 | (print n-locals))) 279 | 280 | (defun atest6 () 281 | (multiple-value-bind (tree symbols n-locals) 282 | (allocate (parse-rule '((p #(f ?X) #(h ?Y #(f a)) ?Y) (father #(y ?X) #(z ?Y))))) 283 | (pprint symbols) 284 | (pprint tree) 285 | (print n-locals))) 286 | 287 | (defun atest7 () 288 | (multiple-value-bind (tree symbols n-locals) 289 | (allocate (parse-query '((father ?X ?Y)))) 290 | (pprint symbols) 291 | (pprint tree) 292 | (print n-locals))) 293 | 294 | (defun atest8 () 295 | (multiple-value-bind (tree symbols n-locals) 296 | (allocate (parse-query '((father ?X ?Y) (father ?Y ?X)))) 297 | (pprint symbols) 298 | (pprint tree) 299 | (print n-locals))) 300 | 301 | (defun atest9 () 302 | (multiple-value-bind (tree symbols n-locals) 303 | (allocate (parse-rule '((p (?X ?Y))))) 304 | (pprint symbols) 305 | (pprint tree) 306 | (print n-locals))) 307 | 308 | (defun atest10 () 309 | (multiple-value-bind (tree symbols n-locals) 310 | (allocate (parse-rule '((p (?X ?Y)) (bb ?X ?Y) ! (bb ?Y ?X)))) 311 | (pprint symbols) 312 | (pprint tree) 313 | (print n-locals))) 314 | 315 | 316 | -------------------------------------------------------------------------------- /asm.lisp: -------------------------------------------------------------------------------- 1 | ; $Id: asm.lisp,v 1.2 2006/02/08 05:28:12 tarvydas Exp $ 2 | ; Copyright 2005 Paul Tarvydas 3 | 4 | ;; 5 | ;; assembler 6 | ;; 7 | ;; integer -> write one byte 8 | ;; string -> write a constant id (2 bytes), install constant into table 9 | ;; %integer -> write two bytes 10 | ;; &integer -> write three bytes 11 | ;; ^integer -> write four bytes 12 | ;; 'c -> write one character 13 | ;; $name -> label definition 14 | ;; ?name -> label reference absolute 15 | ;; if the name has a / in it, it is a prolog proc+arity name: 16 | ;; $name/n -> proc+arity definition, installs proc using "make-proc" 17 | ;; ?name/n -> proc+arity reference absolute 18 | ;; (base name) -> label reference, base-relative 19 | ;; (base number) -> label + number 20 | ;; (= name number) -> equate name to number (byte) 21 | ;; 22 | ;; uses objects of type io for input and output 23 | 24 | (in-package :wam) 25 | 26 | (defvar *pc* 0) 27 | (defvar *labels* nil) 28 | (defvar *pc-start* 0) 29 | 30 | (defun as-keyword (sym) 31 | (intern (symbol-name sym) "KEYWORD")) 32 | 33 | (defun symbol-first-char (sym) 34 | (and (symbolp sym) (char (symbol-name sym) 0))) 35 | 36 | (define-condition asm-error (error) 37 | ((message :initarg :message :reader message)) 38 | (:report (lambda (condition stream) 39 | (format stream "Assembler error: ~A" (message condition))))) 40 | 41 | (defun error-if (pred msg &rest ignore) 42 | (declare (ignore ignore)) 43 | (when pred 44 | (error msg))) 45 | 46 | (defun reset-asm () 47 | (if *labels* 48 | (clrhash *labels*) 49 | (setf *labels* (make-hash-table :test 'equal))) 50 | (setf *pc* 0 51 | *pc-start* 0)) 52 | 53 | 54 | (defun assemble (in out) 55 | ;; pass 1 - collect labels, go through motions of emitting 56 | (progn 57 | (setf *pc-start* *pc*) 58 | (setf *pc* *pc-start*) 59 | (loop for item = (next-element in) 60 | while item do 61 | (assemble-1 item nil nil)) 62 | ;; pass 2 63 | (reset in) 64 | (setf *pc* *pc-start*) 65 | (loop for item = (next-element in) 66 | while item do 67 | (assemble-1 item out t)))) 68 | 69 | (defun assemble-1 (item outf emit) ;; emit = nil on pass 1, = t on pass 2 70 | (cond 71 | 72 | ((numberp item) (out-byte item outf emit) 73 | (incf *pc*)) 74 | 75 | ((characterp item) (out-byte (char-code item) outf emit) 76 | (incf *pc*)) 77 | 78 | ((listp item) 79 | (if (eq '= (first item)) 80 | ;; equate 81 | (progn 82 | (unless emit (assert (null (gethash (as-keyword (second item)) *labels*)))) 83 | (setf (gethash (as-keyword (second item)) *labels*) (third item))) 84 | (if (eq 'quote (first item)) 85 | ;; char emit 86 | (progn (out-byte (char-code (char (format nil "~A" (second item)) 0)) 87 | outf emit) (incf *pc*)) 88 | 89 | (let ((base (first item)) (name (second item))) 90 | (multiple-value-bind (b success) (gethash (as-keyword base) *labels*) 91 | (error-if (and emit (not success)) (format nil "ASM: base label ~A is not defined" base) 92 | :ex 'asm-error) 93 | (if (numberp name) 94 | (if emit (let ((diff (+ b name))) 95 | (setf *pc* (+ *pc* (calc-word-size diff))) 96 | (out-flexi-num diff outf emit)) 97 | (setf *pc* (+ *pc* (calc-word-size 0)))) 98 | 99 | (multiple-value-bind (v success) (gethash (as-keyword name) *labels*) 100 | (error-if (and emit (not success)) (format nil "ASM: label ~A is not defined in file" name) :ex 'asm-error) 101 | ;(when (and emit (null v)) (break)) 102 | (if emit (let ((diff (- (if v v 0) b))) 103 | (setf *pc* (+ *pc* (calc-word-size diff))) 104 | (out-flexi-num diff outf emit)) 105 | (setf *pc* (+ *pc* (calc-word-size 0))))))))))) 106 | 107 | ((symbolp item) 108 | (case (symbol-first-char item) 109 | 110 | (#\% (setf *pc* (+ (out-word (strip-to-int item emit) outf emit) *pc*))) 111 | 112 | (#\& (setf *pc* (+ (out-three (strip-to-int item emit) outf emit) *pc*))) 113 | (#\^ (setf *pc* (+ (out-long (strip-to-int item emit) outf emit) *pc*))) 114 | 115 | ; label definition - active only on first pass 116 | (#\$ (when (not emit) 117 | (let ((name (strip-to-symbol item))) 118 | (multiple-value-bind (v success) (gethash (as-keyword name) *labels*) (declare (ignore v)) 119 | (error-if success (format nil "ASM: label ~A already defined" name))) 120 | (setf (gethash (as-keyword name) *labels*) 121 | (if (prolog-p name) 122 | (multiple-value-bind (name-part arity) 123 | (prolog-split name) 124 | (make-proc *pc* name-part arity)) 125 | *pc*))))) 126 | 127 | ; label reference - all labels are pc-relative 128 | (#\? (let ((name (strip-to-symbol item))) 129 | (multiple-value-bind (v success) (gethash (as-keyword name) *labels*) 130 | (error-if (and emit (not success)) (format nil "ASM: label ~A is not defined" name) :ex 'asm-error) 131 | (if (prolog-p name) 132 | (progn 133 | (incf *pc* 3) 134 | (out-three v outf emit)) 135 | (progn 136 | (incf *pc* (calc-word-size v)) 137 | (out-word v outf emit)))))) 138 | 139 | (otherwise (setf *pc* (+ (assemble-opcode item outf emit) *pc*))))) 140 | 141 | ((stringp item) 142 | ;; use external call - get-constant - to install constant into table return an id 143 | (let ((id (fetch-constant item))) 144 | (incf *pc* (out-word id outf emit)))) 145 | 146 | (t (assert nil)))) 147 | 148 | (defun asm-get-name (name) 149 | (gethash (as-keyword name) *labels*)) 150 | 151 | (defun prolog-p (s) 152 | (position #\/ (symbol-name s))) 153 | 154 | (defun prolog-split (s) 155 | (let* ((n (symbol-name s)) 156 | (p (position #\/ n))) 157 | (values (subseq n 0 p) 158 | (parse-integer (subseq n (1+ p)))))) 159 | 160 | (defun assemble-opcode (item outf emit) 161 | (multiple-value-bind (v succ) (gethash item *opcodes*) 162 | (error-if (not succ) (format nil "ASM: opcode ~S is not defined" item) :ex 'asm-error) 163 | (out-byte v outf emit)) 164 | 1) 165 | 166 | (defun strip-to-int (item emit) 167 | "remove 1st character from symbol, then return it as an integer 168 | if second character is ? then resolve the label to an integer" 169 | (with-input-from-string (s (subseq (symbol-name item) 1)) 170 | (let ((r (read s))) 171 | (when (symbolp r) 172 | (let ((name (strip-to-symbol r)) (temp-pc 0)) 173 | (multiple-value-bind (v success) (gethash (as-keyword name) *labels*) 174 | (error-if (and emit (not success)) (format nil "ASM: label ~A is not defined" name) :ex 'asm-error) 175 | (setf temp-pc (+ *pc* (calc-word-size v))) 176 | (setf r (if v (- v temp-pc) 0))))) 177 | r))) 178 | 179 | (defun strip-to-symbol (item) 180 | "remove 1st character from symbol, then return it as a string" 181 | (intern (subseq (symbol-name item) 1))) 182 | 183 | (defun out-word (item outf emit) 184 | (when emit 185 | (out-byte (logand #xff (ash item -8)) outf emit) 186 | (out-byte (logand #xff item) outf emit)) 187 | 2) 188 | 189 | (defun out-three (item outf emit) 190 | (when emit 191 | (out-byte (logand #xff (ash item -16)) outf emit) 192 | (out-byte (logand #xff (ash item -8)) outf emit) 193 | (out-byte (logand #xff item) outf emit)) 194 | 3) 195 | 196 | (defun out-long (item outf emit) 197 | (when emit 198 | (out-byte (logand #xff (ash item -24)) outf emit) 199 | (out-byte (logand #xff (ash item -16)) outf emit) 200 | (out-byte (logand #xff (ash item -8)) outf emit) 201 | (out-byte (logand #xff item) outf emit)) 202 | 4) 203 | 204 | (defun calc-word-size (item) 205 | "return the size of item as it will be emitted" 206 | (declare (ignore item)) 207 | 2) 208 | 209 | (defun out-flexi-num (item outf emit) 210 | "write the flexinum, return final size; high-bit set means 1-byte, unset two bytes" 211 | (assert (zerop (logand #x80 (ash item -8)))) 212 | (if nil ;(<= 0 item 127) 213 | (progn 214 | (when emit (out-byte (logior #x80 item) outf emit)) 215 | 1) 216 | (progn 217 | (when emit 218 | (out-byte (logand #x7f (ash item -8)) outf emit) 219 | (out-byte (logand #xff item) outf emit)) 220 | 2))) 221 | 222 | (defun out-byte (item outf emit) 223 | (when emit 224 | (put-byte outf (logand #xff item)))) 225 | 226 | ;; temp stuff 227 | (defun string-to-binary (s) 228 | (let ((r nil) (i 0)) 229 | (loop until (= i (length s)) do 230 | (let ((c (char s i)) (val #\Space)) 231 | (case c 232 | (#\\ (incf i) 233 | (case (char s i) 234 | (#\n (setf val #\Newline) (incf i)) 235 | (#\b (setf val #\Backspace) (incf i)) 236 | (#\t (setf val #\Tab) (incf i)) 237 | (#\f (setf val #\Formfeed) (incf i)) 238 | (#\r (setf val #\Return) (incf i)) 239 | ((#\" #\' #\\) (setf val (char s i)) (incf i)) 240 | (otherwise 241 | (multiple-value-setq (val i) 242 | (parse-integer s :start i :radix 8 :junk-allowed t)) 243 | (setf val (code-char val)))) 244 | (push val r)) 245 | 246 | (otherwise (push c r) (incf i))))) 247 | (coerce (reverse r) 'string))) 248 | 249 | (defun dumpasm () 250 | (maphash #'(lambda (key val) (format t "~A : ~A~%" key val)) *labels*)) -------------------------------------------------------------------------------- /coder.lisp: -------------------------------------------------------------------------------- 1 | ; $Id: coder.lisp,v 1.5 2006/02/08 05:28:12 tarvydas Exp $ 2 | ; Copyright 2006 Paul Tarvydas 3 | 4 | ;; Emit code (to a list) for the given tree 5 | 6 | ;; Here, we keep track of whether a variable has 7 | ;; actually been created - the emitted instructions 8 | ;; differ in the cases where the variable has not 9 | ;; been created vs. where the variable has already 10 | ;; been seen and created. 11 | 12 | ;; The top level of the coder is the defrel function which 13 | ;; defines groups of relations - all with the same name, but 14 | ;; possibly with different arities 15 | (in-package :wam) 16 | 17 | (defvar *ctable* (make-hash-table)) 18 | (defvar *next-label* 0) 19 | 20 | (defmacro defrel (name &rest rules) 21 | `(let ((r-code (defrel-1 ',name ',rules))) 22 | (when *wam-debug* 23 | (wam/debug:tprint r-code)) 24 | (assemble (make-instance 'list-io :list r-code) *code-io*))) 25 | 26 | (defmacro defrel0 (name &rest rules) 27 | `(defrel-1 ',name ',rules)) 28 | 29 | (defmacro defquery (name &body body) 30 | `(defquery-with-body ',name ',(car body))) 31 | 32 | (defun defrel-1 (name rules) 33 | ;; all similarly-named rules with the same arity 34 | ;; must be compiled together 35 | (clrhash *ctable*) 36 | (let ((arity-list 37 | (sort 38 | (delete-duplicates 39 | (mapcar #'(lambda (rule) 40 | (hash-by-arity name rule)) 41 | rules)) 42 | #'<))) 43 | (put-rules-in-original-order) 44 | (compile-rules-by-arity arity-list name))) 45 | 46 | (defun hash-by-arity (name rule) 47 | (unless (eq name (caar rule)) 48 | (error "functor mismatch in ~A (~A)" name (caar rule))) 49 | (let ((arity (1- (length (car rule))))) 50 | (setf (gethash arity *ctable*) (cons rule (gethash arity *ctable*))) 51 | arity)) 52 | 53 | (defun put-rules-in-original-order () 54 | (maphash #'(lambda (k v) (setf (gethash k *ctable*) (nreverse v))) *ctable*)) 55 | 56 | (defun compile-rules-by-arity (arity-list name) 57 | (mapcan #'(lambda (i) (compile-arity i name (gethash i *ctable*))) arity-list)) 58 | 59 | (defun compile-arity (arity name trees) 60 | ;; if there is more than one rule at the given 61 | ;; arity, we must compile try/retry jumps around 62 | ;; the possible choices 63 | (let ((proc-name (make-arity-label name arity))) 64 | (case (length trees) 65 | (0 nil) 66 | (1 67 | `(,(lab-def proc-name) 68 | ,@(code-rule name arity (first trees)) 69 | proceed)) 70 | (2 71 | (let ((lab (gen-label))) 72 | `(,(lab-def proc-name) 73 | try-me-else ,(lab-ref lab) 74 | ,@(code-rule name arity (first trees)) 75 | proceed 76 | ,(lab-def lab) 77 | trust-me 78 | ,@(code-rule name arity (second trees)) 79 | proceed))) 80 | (otherwise 81 | (let ((lab (gen-label))) 82 | `(,(lab-def proc-name) 83 | try-me-else ,(lab-ref lab) 84 | ,@(code-rule name arity (first trees)) 85 | proceed 86 | ,(lab-def lab) 87 | ,@(code-retries name arity (butlast (rest trees))) 88 | trust-me 89 | ,@(code-rule name arity (car (last trees))) 90 | proceed)))))) 91 | 92 | (defun code-retries (name arity trees) 93 | (when trees 94 | (let ((lab (gen-label))) 95 | `(retry-me-else ,(lab-ref lab) 96 | ,@(code-rule name arity (car trees)) 97 | proceed 98 | ,(lab-def lab) 99 | ,@(code-retries name arity (rest trees)))))) 100 | 101 | (defun code-rule (name arity source-tree) 102 | (multiple-value-bind (tree symbols has-locals) 103 | (allocate (parse-rule source-tree)) 104 | (declare (ignore symbols)) 105 | (let ((head (code-head name arity (first tree))) 106 | (body (code-body name arity (rest tree))) 107 | (has-cut (has-cut tree))) 108 | (if has-locals 109 | (if has-cut 110 | `(allocate get-level 1 ,@head ,@body deallocate) 111 | `(allocate ,@head ,@body deallocate)) 112 | `(,@head ,@body))))) 113 | 114 | 115 | (defun code-head (name arity head) 116 | ; the basic function of the head code is to 117 | ; move data from the argument registers (A) 118 | ; into the appropriate temp (X) and stack (Y) 119 | ; registers 120 | (code-1-head name arity 1 (cdddr head) nil)) 121 | 122 | (defun code-1-head (name arity a-reg list nested) 123 | (when list 124 | (let ((item (car list)) 125 | (rest (rest list))) 126 | (flet ((tail () (code-1-head name arity (1+ a-reg) rest nested))) 127 | (ecase (car item) 128 | (var 129 | (let* ((alloc (second item)) 130 | (reg (alloc-reg alloc)) 131 | (is-temp (alloc-is-temp alloc))) 132 | (prog1 133 | (if nested 134 | (if (alloc-is-seen alloc) 135 | `(,(if is-temp 'unify-x-value 'unify-y-value) 136 | ,reg ,@(tail)) 137 | `(,(if is-temp 'unify-x-variable 'unify-y-variable) 138 | ,reg ,@(tail))) 139 | (if (alloc-is-seen alloc) 140 | `(,(if is-temp 'get-x-value 'get-y-value) 141 | ,reg ,a-reg ,@(tail)) 142 | `(,(if is-temp 'get-x-variable 'get-y-variable) 143 | ,reg ,a-reg ,@(tail)))) 144 | (set-seen alloc)))) 145 | (const 146 | (let ((k (const-kind item))) 147 | (if nested 148 | `(,(choose-k k 'unify-byte-constant 'unify-word-constant 149 | 'unify-tri-constant 'unify-constant) 150 | ,(const-name k item) ,@(tail)) 151 | `(,(choose-k k 'get-byte-constant 'get-word-constant 152 | 'get-tri-constant 'get-constant) 153 | ,(const-name k item) ,a-reg ,@(tail))))) 154 | (struct 155 | (let ((struct-name (make-arity-label (second item) (third item)))) 156 | (flet ((struct-tail () 157 | (code-1-head name arity a-reg (nthcdr 4 item) t))) 158 | (if nested 159 | (let ((reg (alloc-reg (fourth item)))) 160 | `(unify-x-variable ,reg 161 | ,@(tail) 162 | get-structure ,struct-name ,reg 163 | ,@(struct-tail))) 164 | `(get-structure ,struct-name ,a-reg 165 | ,@(struct-tail) 166 | ,@(tail)))))) 167 | (list 168 | `(get-list ,a-reg 169 | ,@(code-1-head name arity a-reg (list (third item)) t) 170 | ,@(code-1-head name arity a-reg 171 | (list (or (fourth item) 172 | '(const nil))) 173 | t) 174 | ,@(tail)))))))) 175 | 176 | (defun code-body (name arity body) 177 | ; The basic function of the body code is to 178 | ; match the body of the procedure against 179 | ; the actual data in the heap. 180 | ; When calling procedures, the body code 181 | ; moves data from the registers (X,Y) 182 | ; into the appropriate argument (A) registers 183 | ; then calls the procedures. 184 | ; Returns a list of wam code. 185 | (code-1-body name arity body nil 1)) 186 | 187 | (defun code-1-body (name arity body nested a-reg) 188 | (when body 189 | (let ((rest (cdr body)) 190 | (item (car body))) 191 | (flet ((tail () (code-1-body name arity rest nested (1+ a-reg)))) 192 | (ecase (car item) 193 | (proc 194 | (let* ((proc (second item)) 195 | (cname (call-name proc)) 196 | (carity (call-arity proc)) 197 | (clocals (call-locals proc))) 198 | `(,@(code-1-body name arity (cddr item) nested 1) 199 | call ,(lab-ref (make-arity-label cname carity)) ,clocals 200 | ,@(tail)))) 201 | (var 202 | (let* ((alloc (second item)) 203 | (reg (alloc-reg alloc)) 204 | (is-temp (alloc-is-temp alloc))) 205 | (prog1 206 | (if nested 207 | (if (alloc-is-seen alloc) 208 | `(,(if is-temp 'unify-x-value 'unify-y-value) 209 | ,reg ,@(tail)) 210 | `(,(if is-temp 'unify-x-variable 'unify-y-variable) 211 | ,reg ,@(tail))) 212 | (if (alloc-is-seen alloc) 213 | `(,(if is-temp 'put-x-value 'put-y-value) 214 | ,reg ,a-reg ,@(tail)) 215 | `(,(if is-temp 'put-x-variable 'put-y-variable) 216 | ,reg ,a-reg ,@(tail)))) 217 | (set-seen alloc)))) 218 | (const 219 | (let ((k (const-kind item))) 220 | `(,(if nested 221 | (choose-k k 'unify-byte-constant 'unify-word-constant 222 | 'unify-tri-constant 'unify-constant) 223 | (choose-k k 'put-byte-constant 'put-word-constant 224 | 'put-tri-constant 'put-constant)) 225 | ,(const-name k item) ,a-reg ,@(tail)))) 226 | (struct 227 | (let ((struct-name (make-arity-label (second item) (third item)))) 228 | (flet ((struct-tail () 229 | (code-1-body name arity (nthcdr 4 item) t a-reg))) 230 | (if nested 231 | `(unify-variable ,(alloc-reg (fourth item)) 232 | ,@(tail) 233 | put-structure ,struct-name ,(alloc-reg (fourth item)) 234 | ,@(struct-tail)) 235 | `(put-structure ,struct-name ,a-reg 236 | ,@(struct-tail) 237 | ,@(tail)))))) 238 | (list 239 | `(,(if nested 'unify-list 'put-list) ,(alloc-reg (second item)) 240 | ,@(code-1-body name arity (list (third item)) t a-reg) 241 | ,@(code-1-body name arity 242 | (list (or (fourth item) 243 | '(const nil))) 244 | t a-reg) 245 | ,@(tail))) 246 | (cut 247 | `(cut 1 ,@(tail))) 248 | (neck-cut 249 | `(neck-cut ,@(tail)))))))) 250 | 251 | 252 | (defun query-body (name arity body) 253 | ; The basic function of the query body code is to 254 | ; create a matchable pattern on the heap, 255 | ; then to call some rule. 256 | (query-1-body name arity body nil 1)) 257 | 258 | (defun query-1-body (name arity body nested a-reg) 259 | (when body 260 | (let ((rest (cdr body)) 261 | (item (car body))) 262 | (flet ((tail () (query-1-body name arity rest nested (1+ a-reg)))) 263 | (ecase (car item) 264 | (proc 265 | (let* ((proc (second item)) 266 | (cname (call-name proc)) 267 | (carity (call-arity proc)) 268 | (clocals (call-locals proc))) 269 | `(,@(query-1-body name arity (cddr item) nested 1) 270 | call ,(lab-ref (make-arity-label cname carity)) ,clocals 271 | ,@(tail)))) 272 | (var 273 | (let* ((alloc (second item)) 274 | (reg (alloc-reg alloc)) 275 | (is-temp (alloc-is-temp alloc))) 276 | (prog1 277 | (if nested 278 | (if (alloc-is-seen alloc) 279 | `(,(if is-temp 'set-x-value 'set-y-value) 280 | ,reg ,@(tail)) 281 | `(,(if is-temp 'set-x-variable 'set-y-variable) 282 | ,reg ,@(tail))) 283 | (if (alloc-is-seen alloc) 284 | `(,(if is-temp 'put-x-value 'put-y-value) 285 | ,reg ,a-reg ,@(tail)) 286 | `(,(if is-temp 'put-x-variable 'put-y-variable) 287 | ,reg ,a-reg ,@(tail)))) 288 | (set-seen alloc)))) 289 | (const 290 | (let ((k (const-kind item))) 291 | (if nested 292 | `(,(choose-k k 'set-byte-constant 'set-word-constant 293 | 'set-tri-constant 'set-constant) 294 | ,(const-name k item) ,@(tail)) 295 | `(,(choose-k k 'put-byte-constant 'put-word-constant 296 | 'put-tri-constant 'put-constant) 297 | ,(const-name k item) ,a-reg ,@(tail))))) 298 | (struct 299 | (let ((struct-name (make-arity-label (second item) (third item)))) 300 | (flet ((struct-tail () 301 | (query-1-body name arity (nthcdr 4 item) t a-reg))) 302 | (if nested 303 | `(set-variable ,(alloc-reg (fourth item)) 304 | ,@(tail) 305 | 'put-structure ,struct-name ,(alloc-reg (fourth item)) 306 | ,@(struct-tail)) 307 | `(put-structure ,struct-name ,a-reg 308 | ,@(struct-tail) 309 | ,@(tail)))))) 310 | (list 311 | `(,(if nested 'set-list 'put-list) ,(alloc-reg (second item)) 312 | ,@(query-1-body name arity (list (third item)) t a-reg) 313 | ,@(query-1-body name arity 314 | (list (or (fourth item) 315 | '(const nil))) 316 | t a-reg) 317 | ,@(tail)))))))) 318 | 319 | (defun const-kind (item) 320 | (let ((c (second item))) 321 | (if (numberp c) 322 | (cond ((<= -128 c 127) 0) 323 | ((<= -65536 c 65535) 1) 324 | (t 2)) 325 | 3))) 326 | 327 | (defun choose-k (k a b c d) 328 | (ecase k 329 | (0 a) 330 | (1 b) 331 | (2 c) 332 | (3 d))) 333 | 334 | (defun const-name (k item) 335 | (let ((c (second item))) 336 | (ecase k 337 | (0 c) 338 | (1 (format nil "%~A" c)) 339 | (2 (format nil "&~A" c)) 340 | (3 (format nil "~A" (second item)))))) 341 | 342 | (defun set-seen (alloc) 343 | (setf (alloc-is-seen alloc) t)) 344 | 345 | (defun varp (sym) 346 | (and (symbolp sym) (char= #\? (char (symbol-name sym) 0)))) 347 | 348 | (defun gen-label () 349 | (format nil "L~A" (incf *next-label*))) 350 | 351 | (defun make-arity-label (name arity) 352 | (format nil "~A/~A" name arity)) 353 | 354 | (defun lab-def (lab) 355 | (intern (format nil "$~A" lab))) 356 | 357 | (defun lab-ref (lab) 358 | (intern (format nil "?~A" lab))) 359 | 360 | 361 | ;; a query is a conjunction of goals - just like a body 362 | ;; of a rule (without the head) 363 | 364 | ;; this is just for the defquery macro (test.lisp) 365 | (defun defquery-with-body (name body) 366 | (let* ((query-name (make-arity-label name 0)) 367 | (tree (car (allocate (parse-query body)))) 368 | (goals (cdr tree))) 369 | `(,(lab-def query-name) 370 | allocate 371 | ,@(query-body name 0 goals) 372 | done 373 | deallocate))) 374 | 375 | (defun defquery% (name alloc-tree) 376 | (let* ((query-name (make-arity-label name 0)) 377 | (tree (car alloc-tree)) 378 | (goals (cdr tree))) 379 | `(,(lab-def query-name) 380 | allocate 381 | ,@(query-body name 0 goals) 382 | done 383 | deallocate))) 384 | 385 | (defmacro ?- (&body body) 386 | `(run-query ',body)) 387 | 388 | (defun run-query (body &optional (display nil)) 389 | (multiple-value-bind (tree symbols has-locals) 390 | (allocate (parse-query body)) 391 | (let ((q-code (defquery% 'query tree))) 392 | (when display 393 | (wam/debug:tprint q-code) 394 | (terpri)) 395 | (assemble (make-instance 'list-io :list q-code) *code-io*) 396 | (interp-wam (asm-get-name 'query/0) 397 | (remove-if #'(lambda (x) (eq '+lanon+ (car x))) symbols))))) 398 | 399 | -------------------------------------------------------------------------------- /compare/README.md: -------------------------------------------------------------------------------- 1 | This directory contains various tests of the WAM. 2 | 3 | Currently, the tests are compiled by gplc to WAM code, then manually 4 | compared to the emitted (Lisp) WAM code. 5 | 6 | to compile to wam 7 | 8 | gplc -W file.pl 9 | -------------------------------------------------------------------------------- /compare/ctest4.pl: -------------------------------------------------------------------------------- 1 | p(f(X),h(Y,f(a)),Y) :- 2 | father(y(X),z(Y)). 3 | -------------------------------------------------------------------------------- /compare/grandfather.pl: -------------------------------------------------------------------------------- 1 | father(paul,albin). 2 | father(justin,paul). 3 | father(austina,paul). 4 | grandfather(X,Y) :- father(X,Z),father(Z,Y). 5 | q :- grandfather(justin,G). 6 | :- initialization(q). 7 | -------------------------------------------------------------------------------- /compare/ltest16.pl: -------------------------------------------------------------------------------- 1 | h(2,3). 2 | f(3). 3 | p(Z,h(Z,W),f(W)). 4 | x(W,Z) :- p(Z,h(Z,W),f(W)). 5 | 6 | % query is ?- x(W,Z). --> yes 7 | % ltest16 8 | -------------------------------------------------------------------------------- /compare/ltest17.pl: -------------------------------------------------------------------------------- 1 | h(2,3). 2 | f(3). 3 | p(Z,h(W,Z),f(W)). 4 | x(W,Z) :- p(W,h(W,Z),f(W)). 5 | 6 | % query is ?- x(W,Z). --> Z = W 7 | % ltest17 8 | -------------------------------------------------------------------------------- /compare/ltest18.pl: -------------------------------------------------------------------------------- 1 | h(2,3). 2 | f(3). 3 | p(11,h(4,5),f(6)). 4 | x(W,Z) :- p(W,h(W,Z),f(W)). 5 | 6 | % query is ?- x(W,Z). --> no 7 | % ltest18 8 | -------------------------------------------------------------------------------- /compare/ltest7.pl: -------------------------------------------------------------------------------- 1 | s(a(b,c)). 2 | 3 | % ?- s(X). --> X = a(b,c) 4 | -------------------------------------------------------------------------------- /compare/ltest8.pl: -------------------------------------------------------------------------------- 1 | struct(a(b,c)). 2 | % | ?- struct(a(X,Y)). 3 | % 4 | % X = b 5 | % Y = c 6 | % 7 | % yes 8 | % | ?- 9 | 10 | -------------------------------------------------------------------------------- /compare/t13.pl: -------------------------------------------------------------------------------- 1 | bb(1,1). 2 | bb(2,3). 3 | bb(3,1). 4 | bb(4,2). 5 | bb(2,2). 6 | bb(a,b). 7 | 8 | getbb(X,Y) :- bb(X,Y), !, bb(Y,X). 9 | getbb2(X,Y) :- bb(X,Y), bb(Y,X). 10 | -------------------------------------------------------------------------------- /compare/t14.pl: -------------------------------------------------------------------------------- 1 | bb(1,1). 2 | bb(2,3). 3 | bb(3,1). 4 | bb(4,2). 5 | bb(2,2). 6 | bb(a,b). 7 | 8 | getbb2(X,Y) :- !, bb(X,Y), bb(Y,X). 9 | 10 | getbb(X,Y) :- getbb(X,Y), !, bb(X,Y), gg(Y,X). 11 | -------------------------------------------------------------------------------- /compare/t15.pl: -------------------------------------------------------------------------------- 1 | bb(1,1). 2 | bb(2,3). 3 | bb(3,1). 4 | bb(4,2). 5 | bb(2,2). 6 | bb(a,b). 7 | 8 | getbb(X,_) :- bb(X,1), !. 9 | getbb(X,Y) :- bb(X,Y). 10 | -------------------------------------------------------------------------------- /compare/test0.pl: -------------------------------------------------------------------------------- 1 | h(2,3). 2 | f(3). 3 | p(Z,h(Z,W),f(W)). 4 | x(W,Z) :- p(Z,h(Z,W),f(W)). 5 | -------------------------------------------------------------------------------- /const.lisp: -------------------------------------------------------------------------------- 1 | (in-package wam) 2 | 3 | (defconstant put-x-variable 1) 4 | (defconstant put-y-variable 2) 5 | (defconstant put-x-value 3) 6 | (defconstant put-y-value 4) 7 | (defconstant put-y-unsafe-value 5) 8 | (defconstant put-structure 6) 9 | (defconstant put-list 7) 10 | (defconstant put-byte-constant 8) 11 | (defconstant get-x-variable 9) 12 | (defconstant get-y-variable 10) 13 | (defconstant get-x-value 11) 14 | (defconstant get-y-value 12) 15 | (defconstant get-structure 13) 16 | (defconstant get-list 14) 17 | (defconstant get-byte-constant 15) 18 | (defconstant set-x-variable 16) 19 | (defconstant set-y-variable 17) 20 | (defconstant set-x-value 18) 21 | (defconstant set-y-value 19) 22 | (defconstant set-byte-constant 20) 23 | (defconstant set-void 21) 24 | (defconstant unify-x-variable 22) 25 | (defconstant unify-y-variable 23) 26 | (defconstant unify-x-value 24) 27 | (defconstant unify-y-value 25) 28 | (defconstant unify-byte-constant 26) 29 | (defconstant unify-void 27) 30 | (defconstant allocate 28) 31 | (defconstant deallocate 29) 32 | (defconstant call 30) 33 | (defconstant execute 31) 34 | (defconstant proceed 32) 35 | (defconstant try-me-else 33) 36 | (defconstant retry-me-else 34) 37 | (defconstant trust-me 35) 38 | (defconstant try 36) 39 | (defconstant retry 37) 40 | (defconstant trust 38) 41 | (defconstant switch-on-term 39) 42 | (defconstant switch-on-constant 40) 43 | (defconstant switch-on-structure 41) 44 | (defconstant neck-cut 42) 45 | (defconstant get-level 43) 46 | (defconstant cut 44) 47 | (defconstant get-nil 45) 48 | (defconstant put-nil 46) 49 | 50 | (defconstant put-word-constant 47) 51 | (defconstant put-tri-constant 48) 52 | (defconstant put-constant 49) 53 | 54 | (defconstant get-word-constant 50) 55 | (defconstant get-tri-constant 51) 56 | (defconstant get-constant 52) 57 | 58 | (defconstant set-word-constant 53) 59 | (defconstant set-tri-constant 54) 60 | (defconstant set-constant 55) 61 | 62 | (defconstant unify-word-constant 56) 63 | (defconstant unify-tri-constant 57) 64 | (defconstant unify-constant 58) 65 | 66 | 67 | (defconstant done 59) 68 | 69 | (defconstant last-opcode 59) 70 | 71 | 72 | ;; defparameter instead of defconstant because of SBCL (see "idiosyncracies" in sbcl manual) 73 | (defparameter opcode-array (make-array 60 74 | :initial-contents '(nil 75 | f-put-x-variable 76 | f-put-y-variable 77 | f-put-x-value 78 | f-put-y-value 79 | f-put-y-unsafe-value 80 | f-put-structure 81 | f-put-list 82 | f-put-byte-constant 83 | f-get-x-variable 84 | f-get-y-variable 85 | f-get-x-value 86 | f-get-y-value 87 | f-get-structure 88 | f-get-list 89 | f-get-byte-constant 90 | f-set-x-variable 91 | f-set-y-variable 92 | f-set-x-value 93 | f-set-y-value 94 | f-set-byte-constant 95 | f-set-void 96 | f-unify-x-variable 97 | f-unify-y-variable 98 | f-unify-x-value 99 | f-unify-y-value 100 | f-unify-byte-constant 101 | f-unify-void 102 | f-allocate 103 | f-deallocate 104 | f-call 105 | f-execute 106 | f-proceed 107 | f-try-me-else 108 | f-retry-me-else 109 | f-trust-me 110 | f-try 111 | f-retry 112 | f-trust 113 | f-switch-on-term 114 | f-switch-on-constant 115 | f-switch-on-structure 116 | f-neck-cut 117 | f-get-level 118 | f-cut 119 | f-get-nil 120 | f-put-nil 121 | f-put-word-constant 122 | f-put-tri-constant 123 | f-put-constant 124 | f-get-word-constant 125 | f-get-tri-constant 126 | f-get-constant 127 | f-set-word-constant 128 | f-set-tri-constant 129 | f-set-constant 130 | f-unify-word-constant 131 | f-unify-tri-constant 132 | f-unify-constant 133 | f-done 134 | ))) 135 | 136 | 137 | -------------------------------------------------------------------------------- /io.lisp: -------------------------------------------------------------------------------- 1 | ; $Id: io.lisp,v 1.1 2006/02/04 06:34:22 tarvydas Exp $ 2 | ; Copyright 2005 Paul Tarvydas 3 | 4 | (in-package :wam) 5 | 6 | (defclass io () ()) 7 | (defgeneric next-element (x)) 8 | (defgeneric reset (x)) 9 | (defgeneric put-byte (x b)) 10 | (defgeneric tell (x)) 11 | 12 | (defclass list-io (io) 13 | ((head :accessor head) 14 | (current :accessor current))) 15 | 16 | (defmethod initialize-instance :after ((obj list-io) &rest init-options &key list 17 | &allow-other-keys) 18 | (setf (head obj) list) 19 | (setf (current obj) list)) 20 | 21 | 22 | (defmethod next-element ((x list-io)) 23 | (if (current x) 24 | (pop (current x)) 25 | nil)) 26 | 27 | (defmethod reset ((x list-io)) 28 | (setf (current x) (head x))) 29 | 30 | (defclass array-io (io) 31 | ((contents :accessor contents) 32 | (io-index :accessor io-index))) 33 | 34 | (defmethod initialize-instance :after ((obj array-io) &rest init-options &key array 35 | &allow-other-keys) 36 | (setf (contents obj) array) 37 | (setf (io-index obj) 0)) 38 | 39 | (defmethod put-byte ((x array-io) b) 40 | (setf (aref (contents x) (io-index x)) b) 41 | (incf (io-index x))) 42 | 43 | (defmethod tell ((x array-io)) 44 | (io-index x)) 45 | 46 | (defmethod reset ((x array-io)) 47 | (setf (io-index x) 0)) 48 | 49 | -------------------------------------------------------------------------------- /opcodes.lisp: -------------------------------------------------------------------------------- 1 | ; $Id: opcodes.lisp,v 1.4 2006/02/18 22:49:02 tarvydas Exp $ 2 | ;; Copyright 2005 Paul Tarvydas 3 | 4 | (in-package :wam) 5 | 6 | (defparameter *opcodes* (make-hash-table :test 'equal)) 7 | 8 | (defun init-opcodes () 9 | (clrhash *opcodes*) 10 | (setf (gethash 'put-x-variable *opcodes*) put-x-variable) 11 | (setf (gethash 'put-y-variable *opcodes*) put-y-variable) 12 | (setf (gethash 'put-x-value *opcodes*) put-x-value) 13 | (setf (gethash 'put-y-value *opcodes*) put-y-value) 14 | (setf (gethash 'put-y-unsafe-value *opcodes*) put-y-unsafe-value) 15 | (setf (gethash 'put-structure *opcodes*) put-structure) 16 | (setf (gethash 'put-list *opcodes*) put-list) 17 | (setf (gethash 'put-constant *opcodes*) put-constant) 18 | (setf (gethash 'put-byte-constant *opcodes*) put-byte-constant) 19 | (setf (gethash 'put-word-constant *opcodes*) put-word-constant) 20 | (setf (gethash 'put-tri-constant *opcodes*) put-tri-constant) 21 | (setf (gethash 'put-nil *opcodes*) put-nil) 22 | (setf (gethash 'get-x-variable *opcodes*) get-x-variable) 23 | (setf (gethash 'get-y-variable *opcodes*) get-y-variable) 24 | (setf (gethash 'get-x-value *opcodes*) get-x-value) 25 | (setf (gethash 'get-y-value *opcodes*) get-y-value) 26 | (setf (gethash 'get-structure *opcodes*) get-structure) 27 | (setf (gethash 'get-list *opcodes*) get-list) 28 | (setf (gethash 'get-constant *opcodes*) get-constant) 29 | (setf (gethash 'get-byte-constant *opcodes*) get-byte-constant) 30 | (setf (gethash 'get-word-constant *opcodes*) get-word-constant) 31 | (setf (gethash 'get-tri-constant *opcodes*) get-tri-constant) 32 | (setf (gethash 'get-nil *opcodes*) get-nil) 33 | (setf (gethash 'set-x-variable *opcodes*) set-x-variable) 34 | (setf (gethash 'set-y-variable *opcodes*) set-y-variable) 35 | (setf (gethash 'set-x-value *opcodes*) set-x-value) 36 | (setf (gethash 'set-y-value *opcodes*) set-y-value) 37 | (setf (gethash 'set-y-value *opcodes*) set-y-value) 38 | (setf (gethash 'set-constant *opcodes*) set-constant) 39 | (setf (gethash 'set-byte-constant *opcodes*) set-byte-constant) 40 | (setf (gethash 'set-word-constant *opcodes*) set-word-constant) 41 | (setf (gethash 'set-tri-constant *opcodes*) set-tri-constant) 42 | (setf (gethash 'set-void *opcodes*) set-void) 43 | (setf (gethash 'unify-x-variable *opcodes*) unify-x-variable) 44 | (setf (gethash 'unify-x-value *opcodes*) unify-x-value) 45 | (setf (gethash 'unify-y-value *opcodes*) unify-y-value) 46 | (setf (gethash 'unify-constant *opcodes*) unify-constant) 47 | (setf (gethash 'unify-byte-constant *opcodes*) unify-byte-constant) 48 | (setf (gethash 'unify-word-constant *opcodes*) unify-word-constant) 49 | (setf (gethash 'unify-tri-constant *opcodes*) unify-tri-constant) 50 | (setf (gethash 'unify-void *opcodes*) unify-void) 51 | (setf (gethash 'allocate *opcodes*) allocate) 52 | (setf (gethash 'deallocate *opcodes*) deallocate) 53 | (setf (gethash 'call *opcodes*) call) 54 | (setf (gethash 'execute *opcodes*) execute) 55 | (setf (gethash 'proceed *opcodes*) proceed) 56 | (setf (gethash 'try-me-else *opcodes*) try-me-else) 57 | (setf (gethash 'retry-me-else *opcodes*) retry-me-else) 58 | (setf (gethash 'trust-me *opcodes*) trust-me) 59 | (setf (gethash 'try *opcodes*) try) 60 | (setf (gethash 'retry *opcodes*) retry) 61 | (setf (gethash 'trust *opcodes*) trust) 62 | (setf (gethash 'switch-on-term *opcodes*) switch-on-term) 63 | (setf (gethash 'switch-on-constant *opcodes*) switch-on-constant) 64 | (setf (gethash 'switch-on-structure *opcodes*) switch-on-structure) 65 | (setf (gethash 'neck-cut *opcodes*) neck-cut) 66 | (setf (gethash 'get-level *opcodes*) get-level) 67 | (setf (gethash 'cut *opcodes*) cut) 68 | (setf (gethash 'done *opcodes*) done)) 69 | 70 | 71 | (defun disassem (x) 72 | (case x 73 | (#.put-x-variable 'put-x-variable) 74 | (#.put-y-variable 'put-y-variable) 75 | (#.put-x-value 'put-x-value) 76 | (#.put-y-value 'put-y-value) 77 | (#.put-y-unsafe-value 'put-y-unsafe-value) 78 | (#.put-structure 'put-structure) 79 | (#.put-list 'put-list) 80 | (#.put-constant 'put-constant) 81 | (#.put-byte-constant 'put-byte-constant) 82 | (#.put-word-constant 'put-word-constant) 83 | (#.put-tri-constant 'put-tri-constant) 84 | (#.put-nil 'put-nil) 85 | (#.get-x-variable 'get-x-variable) 86 | (#.get-y-variable 'get-y-variable) 87 | (#.get-x-value 'get-x-value) 88 | (#.get-y-value 'get-y-value) 89 | (#.get-structure 'get-structure) 90 | (#.get-list 'get-list) 91 | (#.get-constant 'get-constant) 92 | (#.get-byte-constant 'get-byte-constant) 93 | (#.get-word-constant 'get-word-constant) 94 | (#.get-tri-constant 'get-tri-constant) 95 | (#.get-nil 'get-nil) 96 | (#.set-x-variable 'set-x-variable) 97 | (#.set-x-value 'set-x-value) 98 | (#.set-y-variable 'set-y-variable) 99 | (#.set-y-value 'set-y-value) 100 | (#.set-constant 'set-constant) 101 | (#.set-byte-constant 'set-byte-constant) 102 | (#.set-word-constant 'set-word-constant) 103 | (#.set-tri-constant 'set-tri-constant) 104 | (#.set-void 'set-void) 105 | (#.unify-x-variable 'unify-x-variable) 106 | (#.unify-x-value 'unify-x-value) 107 | (#.unify-y-value 'unify-x-value) 108 | (#.unify-constant 'unify-constant) 109 | (#.unify-byte-constant 'unify-byte-constant) 110 | (#.unify-word-constant 'unify-word-constant) 111 | (#.unify-tri-constant 'unify-tri-constant) 112 | (#.unify-void 'unify-void) 113 | (#.allocate 'allocate) 114 | (#.deallocate 'deallocate) 115 | (#.call 'call) 116 | (#.execute 'execute) 117 | (#.proceed 'proceed) 118 | (#.try-me-else 'try-me-else) 119 | (#.retry-me-else 'retry-me-else) 120 | (#.trust-me 'trust-me) 121 | (#.try 'try) 122 | (#.retry 'retry) 123 | (#.trust 'trust) 124 | (#.switch-on-term 'switch-on-term) 125 | (#.switch-on-constant 'switch-on-constant) 126 | (#.switch-on-structure 'switch-on-structure) 127 | (#.neck-cut 'neck-cut) 128 | (#.get-level 'get-level) 129 | (#.cut 'cut) 130 | (#.done 'done) 131 | (otherwise nil))) 132 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage wam 2 | (:use :cl) 3 | (:export 4 | #:code 5 | #:defrel0 6 | #:defrel 7 | #:defquery 8 | #:init-opcodes 9 | #:reset-code 10 | #:reset-asm 11 | #:?- 12 | #:regx 13 | #:parse-query 14 | #:parse-rule 15 | 16 | #:store 17 | #:*wam-debug*)) 18 | 19 | (defpackage wam/debug 20 | (:use :cl 21 | :wam) 22 | (:export 23 | #:tprint 24 | #:dump)) 25 | 26 | (defpackage wam/tags 27 | (:use :cl 28 | :wam) 29 | (:export 30 | #:untag 31 | #:funtag 32 | #:tag 33 | #:int 34 | #:ref 35 | #:con 36 | #:spcl 37 | #:lis 38 | #:str 39 | #:tag-int 40 | #:tag-ref 41 | #:tag-con 42 | #:tag-spcl 43 | #:tag-lis 44 | #:tag-str)) 45 | 46 | (defpackage wam/test 47 | (:use :cl 48 | :wam)) 49 | 50 | -------------------------------------------------------------------------------- /parse.lisp: -------------------------------------------------------------------------------- 1 | ; $Id: parse.lisp,v 1.7 2006/02/18 22:49:02 tarvydas Exp $ 2 | ; Copyright 2006 Paul Tarvydas 3 | (in-package :Wam) 4 | 5 | (defun parse-rule (list) 6 | (let* ((head (car list)) 7 | (neck (cadr list)) 8 | (body (cddr list)) 9 | (phead (parse-head head)) 10 | (pneck (parse-neck neck)) 11 | (pbody (parse-body body)) 12 | (has-cut (or (contains-cut pneck) 13 | (contains-cut pbody)))) 14 | (when has-cut 15 | (setf (caar phead) 'rule-with-cut)) 16 | `(,@phead 17 | ,@pneck 18 | ,@pbody))) 19 | 20 | (defun parse-query (list) 21 | (let ((body (parse-body list))) 22 | (if (contains-cut body) 23 | `((query-with-cut ,@body)) 24 | `((query ,@body))))) 25 | 26 | (defun contains-cut (list) 27 | (dolist (i list) 28 | (when (equal '(cut) i) (return-from contains-cut t))) 29 | nil) 30 | 31 | (defun parse-head (list) 32 | `((rule ,(car list) ,(1- (length list)) 33 | ,@(mapcar #'parse-arg (cdr list))))) 34 | 35 | (defun parse-neck (clause) 36 | (when clause 37 | (if (eq clause '!) 38 | '((neck-cut)) 39 | (list (parse-clause clause))))) 40 | 41 | (defun parse-body (list) 42 | (when list 43 | (mapcar #'parse-clause list))) 44 | 45 | (defun parse-args (list) 46 | (when list 47 | `(body ,@(mapcar #'parse-arg list)))) 48 | 49 | (defun parse-arg (item) 50 | `(,@(cond 51 | ((varp item) 52 | `(var ,item)) 53 | ((symbolp item) 54 | `(const ,item)) 55 | ((stringp item) 56 | `(const ,item)) 57 | ((numberp item) 58 | `(const ,item)) 59 | ((vectorp item) 60 | `(struct ,(aref item 0) ,(1- (length item)) ,@(parse-struct item 1))) 61 | ((listp item) 62 | `(list ,@(mapcar #'parse-arg item)))))) 63 | 64 | (defun parse-struct (vec index) 65 | (when (< index (length vec)) 66 | `(,(parse-arg (aref vec index)) 67 | ,@ (parse-struct vec (1+ index))))) 68 | 69 | (defstruct call 70 | name 71 | arity 72 | locals) 73 | 74 | (defun array-to-list (a) 75 | (map 'list #'identity a)) 76 | 77 | (defun parse-clause (clause) 78 | (if (and (symbolp clause) (string= "!" (symbol-name clause))) ;;(eq clause '!) 79 | '(cut) 80 | (let ((cl (if (vectorp clause) 81 | (array-to-list clause) 82 | clause))) 83 | `(proc ,(make-call :name (car cl) :arity (1- (length cl)) :locals 0) 84 | ,@(mapcar #'parse-arg (cdr cl)))))) 85 | 86 | 87 | -------------------------------------------------------------------------------- /readme: -------------------------------------------------------------------------------- 1 | # WAM Prolog 2 | 3 | Paul Tarvydes 4 | 5 | ## Locating the source 6 | 7 | Place into places that implementations look for ASDF systems. For 8 | example, if you have Quicklisp installed, it always looks in 9 | 10 | 11 | c.f. -------------------------------------------------------------------------------- /store.lisp: -------------------------------------------------------------------------------- 1 | (in-package :wam) 2 | 3 | (defparameter *wam-debug* t) 4 | 5 | (defvar *code-io*) ;; class IO - used to hold compiled code 6 | 7 | (defmacro next-byte () 8 | `(prog1 (logand #xff (aref code p)) (incf p))) 9 | 10 | ; the store contains registers, followed by heap, followed by stack followed by trail stack 11 | ; all must be addressable by 20-bit indices - i.e. total size 1048576 12 | ; 13 | ; code and PDL stack are in different address spaces 14 | 15 | (defconstant n-regs 256) 16 | ;(defconstant heap-size 786176) 17 | ;(defconstant stack-size 131072) 18 | ;(defconstant trail-size 131072) 19 | (defconstant heap-size 8192) 20 | (defconstant stack-size 4096) 21 | (defconstant trail-size 3072) 22 | 23 | (defconstant heap-start n-regs) 24 | (defconstant stack-start (+ heap-start heap-size)) 25 | (defconstant trail-start (+ stack-start stack-size)) 26 | 27 | (defconstant store-size (+ n-regs heap-size stack-size trail-size)) 28 | (assert (>= #x100000 store-size)) 29 | 30 | (defconstant code-size 10240) 31 | (defconstant pdl-size 1024) 32 | 33 | ;; most-positive-fixnum is 7fffff = 23 bits 34 | ;; store is made up of 23-bit entities 35 | ;; code is made up of bytes 36 | ;; immediate constants in code can be 1, 2, 3 bytes or indirect (2 bytes, hash index) 37 | 38 | #| 39 | 40 | ;; see B.3 (pg 117) of Hassan Ait-Kaci's tutorial on WAM, for a diagram 41 | 42 | ;; Code Area, Heap, Stack, Trail, PDL, argument registers A1...An 43 | 44 | ; Code Area: 45 | ; P : instruction pointer 46 | ; CP : continue pointer 47 | ; 48 | ; Heap 49 | ; S : next subterm to be matched 50 | ; HB : heap pointer at latest choice 51 | ; H : next heap pointer 52 | ; 53 | ; Stack 54 | ; B0 : cut register 55 | ; B : latest choice point 56 | ; Choice Point Frame 57 | ;; n : Arity 58 | ;; A1...An : arguments 59 | ;; CE : continuation environment 60 | ;; CP : continuation code (see Code Area) 61 | ;; B : previous choice point 62 | ;; BP : next clause 63 | ;; TR : trail pointer (see Trail area) 64 | ;; H : heap pointer 65 | ;; B0 : cut pointer 66 | ;; 67 | ; E : environment 68 | ;; environment frame 69 | ;; CE : continuation environment 70 | ;; CP : continuation code 71 | ;; Y1 ... Yn: local variables 72 | ; 73 | ; Trail 74 | ;; array of addresses to unbind 75 | 76 | ;; originally, wanted to make all of these variables "efficient", not specials 77 | 78 | (let ((p 0) 79 | (cp 0) 80 | (s 0) 81 | (h heap-start) 82 | (hb heap-start) 83 | (b stack-start) 84 | (b0 stack-start) 85 | (e stack-start) 86 | (tr trail-start) 87 | (store (make-array store-size :element-type 'fixnum)) 88 | (code (make-array code-size :element-type '(integer 0 255) :initial-element 0)) 89 | (pdl (make-array pdl-size :element-type 'fixnum :fill-pointer 0)) 90 | (fail nil) 91 | (mode :read) 92 | (number-of-args 0)) 93 | 94 | (declare (type fixnum p cp s h hb b b0 e tr number-of-args)) 95 | |# 96 | 97 | (defvar p 0) 98 | (defvar cp 0) 99 | (defvar s 0) 100 | (defvar h heap-start) 101 | (defvar hb heap-start) 102 | (defvar b stack-start) 103 | (defvar b0 stack-start) 104 | (defvar e stack-start) 105 | (defvar tr trail-start) 106 | (defvar store (make-array store-size :element-type 'fixnum :initial-element 0)) 107 | (defvar code (make-array code-size :element-type '(integer 0 255) :initial-element 0)) 108 | (defvar pdl (make-array pdl-size :element-type 'fixnum :fill-pointer 0)) 109 | (defvar fail nil) 110 | (defvar mode :read) 111 | (defvar number-of-args 0) 112 | 113 | 114 | (defmacro store (n) 115 | `(aref store ,n)) 116 | 117 | (defmacro heap (n) `(store ,n)) 118 | 119 | (defmacro regx (n) `(store ,n)) 120 | 121 | (defmacro rega (n) `(store ,n)) 122 | (defmacro var (n) `(store ,n)) 123 | (defmacro stack (n) `(store ,n)) 124 | (defmacro trail-stack (n) `(store ,n)) 125 | (defmacro local (n) `(store (+ e ,n 1))) 126 | 127 | (defun next-triple () 128 | (let* ((c1 (next-byte)) 129 | (c2 (next-byte)) 130 | (c3 (next-byte))) 131 | (logior (ash c1 16) (ash c2 8) c3))) 132 | 133 | (defun next-double () 134 | (let* ((c1 (next-byte)) 135 | (c2 (next-byte))) 136 | (logior (ash c1 8) c2))) 137 | 138 | (defun next-label () 139 | (next-triple)) 140 | 141 | (defun next-byte-const () 142 | (next-byte)) 143 | 144 | (defun next-word-const () 145 | (next-double)) 146 | 147 | (defun next-tri-const () 148 | (next-triple)) 149 | 150 | (defun next-const () 151 | (next-double)) 152 | 153 | (defun next-abs () 154 | ;; next absolute address in code space (no arity) 155 | (next-double)) 156 | 157 | 158 | ; a label is 20 bits - 15 msb for address, 5 lsb for arity 159 | (defmacro arity (x) 160 | `(logand ,x 31)) 161 | 162 | (defmacro code-addr (x) 163 | `(ash ,x -5)) 164 | 165 | (defmacro pdl-push (x) 166 | `(vector-push pdl ,x)) 167 | 168 | (defmacro pdl-pop () 169 | `(vector-pop pdl)) 170 | 171 | (defmacro pdl-empty () 172 | `(= 0 (fill-pointer pdl))) 173 | 174 | -------------------------------------------------------------------------------- /tags.lisp: -------------------------------------------------------------------------------- 1 | (in-package :wam/tags) 2 | 3 | ; tags 4 | (defconstant int 0) ;integer 5 | (defconstant ref 1) ;reference 6 | (defconstant con 2) ;constant 7 | (defconstant lis 3) ;list 8 | (defconstant str 4) ;structure 9 | (defconstant spcl 5) ; special 0 is nil 10 | 11 | 12 | (defmacro untag (i) 13 | `(ash ,i -3)) 14 | 15 | (defmacro tag (i) 16 | `(logand ,i 7)) 17 | 18 | (defmacro tag-int (i) 19 | `(logior (ash ,i 3) int)) 20 | 21 | (defmacro tag-ref (i) 22 | `(logior (ash ,i 3) ref)) 23 | 24 | (defmacro tag-con (i) 25 | `(logior (ash ,i 3) con)) 26 | 27 | (defmacro tag-spcl (i) 28 | `(logior (ash ,i 3) spcl)) 29 | 30 | (defmacro tag-lis (i) 31 | `(logior (ash ,i 3) lis)) 32 | 33 | (defmacro tag-str (i) 34 | `(logior (ash ,i 3) str)) 35 | -------------------------------------------------------------------------------- /test/parse-test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :wam/test) 2 | 3 | (defun test0 () 4 | (pprint (parse-rule '((father paul albin))))) 5 | 6 | (defun test1 () 7 | (pprint (parse-rule '((grandfather ?x ?y) (father ?x ?y) (father ?z ?y))))) 8 | 9 | (defun test2 () 10 | (pprint (parse-rule '((p #(f ?X) #(h ?Y #(f a)) ?Y))))) 11 | 12 | (defun test3 () 13 | (pprint (parse-rule '((append () ?x ?x))))) 14 | 15 | (defun test4 () 16 | (pprint (parse-rule '((append (?u ?x) ?y (?u ?z)) 17 | (append ?x ?y ?z))))) 18 | 19 | (defun test5 () 20 | (pprint (parse-query '((p ?Z #(h ?Z ?W) #(f ?W)))))) 21 | 22 | (defun test6 () 23 | (pprint (parse-rule '((p #(f ?X) #(h ?Y #(f a)) ?Y) (father #(y ?X) #(z Y)))))) 24 | 25 | (defun test7 () 26 | (pprint (parse-query '((father ?X ?Y))))) 27 | 28 | (defun test8 () 29 | (pprint (parse-query '((father ?X ?Y) (father ?Y ?X))))) 30 | 31 | (defun test9 () 32 | (pprint (parse-query '((p ?Z (?Z ?W) #(f ?W)))))) 33 | 34 | (defun test10 () 35 | (pprint (parse-rule '((bb 1 1 2 3 4))))) 36 | 37 | (defun test11 () 38 | (pprint (parse-rule '((bb 1 1) ! (bb 2 2))))) 39 | 40 | (defun test12 () 41 | (pprint (parse-rule '((bb 1 1) (bb 2 2) ! (bb 3 3))))) 42 | 43 | (defun test13 () 44 | (pprint (parse-rule '((lll (1 2)))))) 45 | 46 | (defun test14 () 47 | (pprint (parse-query '((lll (?X ?Y)))))) 48 | -------------------------------------------------------------------------------- /test/test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2005 Paul Tarvydas 2 | (in-package :wam/test) 3 | 4 | (defun labelp (x) 5 | (char= #\$ (char (symbol-name x) 0))) 6 | 7 | (defun refp (x) 8 | (char= #\? (char (symbol-name x) 0))) 9 | 10 | (defun tprint (x) 11 | (cond ((symbolp x) 12 | (cond ((labelp x) (terpri) (prin1 x)) 13 | ((not (refp x)) 14 | (terpri) 15 | (princ " ") 16 | (prin1 x) 17 | (princ #\space)) 18 | (t (prin1 x) 19 | (princ #\space)))) 20 | ((listp x) 21 | (if (listp (car x)) 22 | (pprint x) 23 | (dolist (i x) (tprint i)))) 24 | (t (prin1 x) (princ #\space)))) 25 | 26 | 27 | 28 | (defun ctest0 () 29 | (tprint (wam:defrel0 father ((father paul father-of-paul))))) 30 | 31 | (defun ctest1 () 32 | (tprint 33 | (wam:defrel0 father 34 | ((father paul father-of-paul)) 35 | ((father son-of-paul paul)) 36 | ((father daughter-of-paul paul))))) 37 | 38 | (defun ctest2 () 39 | (tprint 40 | (wam:defrel0 grandfather 41 | ((grandfather ?x ?y) (father ?x ?z) (father ?z ?y))))) 42 | 43 | (defun ctest3 () 44 | (tprint 45 | (wam:defrel0 p 46 | ((p ?X ?Y ?Z) (q ?U ?V ?W) (r ?Y ?Z ?U) (s ?U ?W) (t ?X ?V))))) 47 | 48 | (defun ctest4 () 49 | (tprint 50 | (wam:defrel0 p 51 | ((p #(f ?X) #(h ?Y #(f a)) ?Y) (father #(y ?X) #(z ?Y)))))) 52 | 53 | 54 | (defun ctest5 () 55 | (tprint 56 | (defquery q ((father ?X ?Y))))) 57 | 58 | (defun ctest6 () 59 | (tprint 60 | (defquery q ((father ?X ?Y) (father ?Y ?X) (father ?Y ?Z))))) 61 | 62 | (defun ctest7 () 63 | (tprint 64 | (defquery q ((p ?Z (?Z ?W) #(f ?W)))))) 65 | 66 | (defun ctest9 () 67 | (tprint 68 | (defquery q ((p (?X ?Y)))))) 69 | 70 | (defun ctest10 () 71 | (tprint 72 | (defquery q ((p (?X)))))) 73 | 74 | (defun ctest11 () 75 | (tprint 76 | (wam:defrel0 p ((p ?X ?Y) (p (?X ?Y)))))) 77 | 78 | (defun ctest12 () 79 | (tprint 80 | (wam:defrel0 p ((p (?X ?Y)))))) 81 | 82 | (defun ltest0 () 83 | (wam:init-opcodes) 84 | (wam:reset-code) 85 | (wam:reset-asm) 86 | (wam:defrel father 87 | ((father son-of-paul paul))) 88 | (let ((result (wam:?- (father ?X paul)))) 89 | (when wam:*wam-debug* (format *standard-output* "~&result = ~S~%" result)) 90 | (if (equal '(((?X . "SON-OF-PAUL"))) 91 | result) 92 | 'OK 93 | 'FAILED))) 94 | 95 | (defun ltest1 () 96 | (wam:init-opcodes) 97 | (wam:reset-code) 98 | (wam:reset-asm) 99 | (wam:defrel father 100 | ((father paul father-of-paul)) 101 | ((father son-of-paul paul)) 102 | ((father daughter-of-paul paul))) 103 | (if (equal '(((?X . "DAUGHTER-OF-PAUL") (?Y . "PAUL")) 104 | ((?X . "SON-OF-PAUL") (?Y . "PAUL")) 105 | ((?X . "PAUL") (?Y . "FATHER-OF-PAUL"))) 106 | (wam:?- (father ?X ?Y))) 107 | 'OK 108 | 'FAILED)) 109 | 110 | (defun ltest2 () 111 | (wam:init-opcodes) 112 | (wam:reset-code) 113 | (wam:reset-asm) 114 | (wam:defrel father 115 | ((father paul father-of-paul)) 116 | ((father son-of-paul paul)) 117 | ((father daughter-of-paul paul))) 118 | (wam:defrel grandfather 119 | ((grandfather ?child ?grandfather) 120 | (father ?child ?father) (father ?father ?grandfather))) 121 | (if (equal '(((?X . "DAUGHTER-OF-PAUL") (?Y . "FATHER-OF-PAUL")) ((?X . "SON-OF-PAUL") (?Y . "FATHER-OF-PAUL"))) 122 | (wam:?- (grandfather ?X ?Y))) 123 | 'OK 124 | 'FAILED)) 125 | 126 | (defun ltest4 () 127 | (wam:init-opcodes) 128 | (wam:reset-code) 129 | (wam:reset-asm) 130 | (wam:defrel father 131 | ((father paul father-of-paul)) 132 | ((father son-of-paul paul)) 133 | ((father daughter-of-paul paul))) 134 | (wam:defrel grandfather 135 | ((grandfather ?child ?grandfather) 136 | (father ?child ?father) (father ?father ?grandfather))) 137 | (if (equal '(((?X . "DAUGHTER-OF-PAUL") (?Y . "PAUL")) 138 | ((?X . "SON-OF-PAUL") (?Y . "PAUL")) 139 | ((?X . "PAUL") (?Y . "FATHER-OF-PAUL"))) 140 | (wam:?- (father ?X ?Y))) 141 | 'OK 142 | 'FAILED)) 143 | 144 | (defun ltest5 () 145 | (wam:init-opcodes) 146 | (wam:reset-code) 147 | (wam:reset-asm) 148 | (wam:defrel lll ((lll (1 2)))) 149 | (if (equal (wam:?- (lll (?X ?Y))) 150 | '(((?X . 1) (?Y . 2)))) 151 | 'OK 152 | 'FAILED)) 153 | 154 | (defun ltest6 () 155 | (wam:init-opcodes) 156 | (wam:reset-code) 157 | (wam:reset-asm) 158 | (wam:defrel lis ((lis (1 2)))) 159 | (if (equal (wam:?- (lis ?X)) '(((?X 1 2)))) 160 | 'OK 161 | 'FAILED)) 162 | 163 | (defun ltest7 () 164 | (wam:init-opcodes) 165 | (wam:reset-code) 166 | (wam:reset-asm) 167 | (wam:defrel s ((s #(a b c)))) 168 | (let ((result (wam:?- (s ?X)))) 169 | (if (equalp 170 | result 171 | '(((?X . #("A/2" "B" "C"))))) 172 | 'OK 173 | (progn 174 | (when wam:*wam-debug* (format *error-output* "~&FAIL ~S~%" result)) 175 | 'FAIL)))) 176 | 177 | (defun ltest8 () 178 | (wam:init-opcodes) 179 | (wam:reset-code) 180 | (wam:reset-asm) 181 | (wam:defrel struct ((struct #(a b c)))) 182 | (if (equalp 183 | (wam:?- (struct #(a ?X ?Y))) 184 | '(((?X . "B") (?Y . "C")))) 185 | 'OK 186 | 'FAIL)) 187 | 188 | (defun ltest9 () 189 | (wam:init-opcodes) 190 | (wam:reset-code) 191 | (wam:reset-asm) 192 | (wam:defrel struct 193 | ((struct #(a b c))) 194 | ((struct #(a e f))) 195 | ((struct #(g h i)))) 196 | (if (equalp 197 | (wam:?- (struct #(a ?X ?Y))) 198 | '(((?X . "E") (?Y . "F")) ((?X . "B") (?Y . "C")))) 199 | 'OK 200 | 'FAIL)) 201 | 202 | ;; this is illegal 203 | ;;;; (defun ltest10 () 204 | ;;;; (wam:init-opcodes) 205 | ;;;; (wam:reset-code) 206 | ;;;; (wam:reset-asm) 207 | ;;;; (wam:defrel struct 208 | ;;;; ((struct #(a b c))) 209 | ;;;; ((struct #(a e f))) 210 | ;;;; ((struct #(g h i)))) 211 | ;;;; (wam:?- (struct #(?X ?Y ?Z)))) 212 | 213 | (defun ltest10 () 214 | (wam:init-opcodes) 215 | (wam:reset-code) 216 | (wam:reset-asm) 217 | (wam:defrel struct 218 | ((struct #(a b c))) 219 | ((struct #(a 1 2))) 220 | ((struct #(g h i)))) 221 | (if (equalp 222 | (wam:?- (struct #(a ?X ?Y))) 223 | '(((?X . 1) (?Y . 2)) ((?X . "B") (?Y . "C")))) 224 | 'OK 225 | 'FAIL)) 226 | 227 | (defun ltest11 () 228 | (wam:init-opcodes) 229 | (wam:reset-code) 230 | (wam:reset-asm) 231 | (wam:defrel bb 232 | ((bb 1 1)) 233 | ((bb 2 3)) 234 | ((bb 3 1)) 235 | ((bb a b))) 236 | (if (equalp 237 | (wam:?- (bb ?id 1)) 238 | '(((?ID . 3)) ((?ID . 1)))) 239 | 'OK 240 | 'FAIL)) 241 | 242 | (defun ltest12 () 243 | (wam:init-opcodes) 244 | (wam:reset-code) 245 | (wam:reset-asm) 246 | (wam:defrel bb 247 | ((bb 1 1)) 248 | ((bb 2 3)) 249 | ((bb 3 1)) 250 | ((bb 4 2)) 251 | ((bb 2 2)) 252 | ((bb a b))) 253 | (wam:defrel get-bb 254 | ((get-bb ?X ?Y) (bb ?X ?Y) (bb ?Y ?X))) 255 | (if (equalp 256 | (wam:?- (get-bb ?id ?X)) 257 | '(((?ID . 2) (?X . 2)) ((?ID . 1) (?X . 1)))) 258 | 'OK 259 | 'FAIL)) 260 | 261 | (defun ltest13 () 262 | (wam:init-opcodes) 263 | (wam:reset-code) 264 | (wam:reset-asm) 265 | (wam:defrel bb 266 | ((bb 1 1)) 267 | ((bb 2 3)) 268 | ((bb 3 1)) 269 | ((bb 4 2)) 270 | ((bb 2 2)) 271 | ((bb a b))) 272 | (wam:defrel get-bb 273 | ((get-bb ?X ?Y) (bb ?X ?Y) ! (bb ?Y ?X))) 274 | (if (equalp 275 | (wam:?- (get-bb ?id ?X)) 276 | '(((?ID . 1) (?X . 1)))) 277 | 'OK 278 | 'FAIL)) 279 | 280 | (defun ltest13a () 281 | ;; same as ltest13, but with fewer relations 282 | (wam:init-opcodes) 283 | (wam:reset-code) 284 | (wam:reset-asm) 285 | (wam:defrel bb 286 | ((bb 1 1)) 287 | ((bb 2 2))) 288 | (wam:defrel get-bb 289 | ((get-bb ?X ?Y) (bb ?X ?Y) ! (bb ?Y ?X))) 290 | (if (equalp 291 | (wam:?- (get-bb ?id ?X)) 292 | '(((?ID . 1) (?X . 1)))) 293 | 'OK 294 | 'FAIL)) 295 | 296 | 297 | ;;; bb(1,1). 298 | ;;; bb(2,3). 299 | ;;; bb(3,1). 300 | ;;; bb(4,2). 301 | ;;; bb(2,2). 302 | ;;; bb(a,b). 303 | 304 | ;;; get-bb(X,Y) :- !,bb(X,Y),bb(Y,X). 305 | 306 | ;;; test(X,Y) :- 307 | ;;; get-bb(X,Y). 308 | 309 | (defun ltest14 () 310 | (wam:init-opcodes) 311 | (wam:reset-code) 312 | (wam:reset-asm) 313 | (wam:defrel bb 314 | ((bb 1 1)) 315 | ((bb 2 3)) 316 | ((bb 3 1)) 317 | ((bb 4 2)) 318 | ((bb 2 2)) 319 | ((bb a b))) 320 | (wam:defrel get-bb 321 | ((get-bb ?X ?Y) (bb ?X ?Y) (bb ?Y ?X))) 322 | (let ((result (wam:?- (get-bb ?id ?X)))) 323 | (if (equalp 324 | result 325 | '(((?ID . 2) (?X . 2))((?ID . 1) (?X . 1)))) 326 | 'OK 327 | (progn 328 | (when wam:*wam-debug* (format *error-output* "~&FAIL ~S~%" result)) 329 | 'FAIL)))) 330 | 331 | ;;; bb(1,1). 332 | ;;; bb(2,3). 333 | ;;; bb(3,1). 334 | ;;; bb(4,2). 335 | ;;; bb(2,2). 336 | ;;; bb(a,b). 337 | 338 | ;;; get-bb(X,Y) :- !,bb(X,Y),bb(Y,X). 339 | 340 | ;;; test(X,Y) :- 341 | ;;; get-bb(X,Y). 342 | 343 | (defun ltest14b () 344 | (wam:init-opcodes) 345 | (wam:reset-code) 346 | (wam:reset-asm) 347 | (wam:defrel bb 348 | ((bb 1 1)) 349 | ((bb 2 3)) 350 | ((bb 3 1)) 351 | ((bb 4 2)) 352 | ((bb 2 2)) 353 | ((bb a b))) 354 | (wam:defrel get-bb 355 | ((get-bb ?X ?Y) ! (bb ?X ?Y) (bb ?Y ?X))) 356 | (let ((result (wam:?- (get-bb ?id ?X)))) 357 | (if (equalp 358 | result 359 | '(((?ID . 2) (?X . 2))((?ID . 1) (?X . 1)))) 360 | 'OK 361 | (progn 362 | (when wam:*wam-debug* (format *error-output* "~&FAIL ~S~%" result)) 363 | 'FAIL)))) 364 | 365 | ;;; bb(1,1). 366 | ;;; bb(2,3). 367 | ;;; bb(3,1). 368 | ;;; bb(4,2). 369 | ;;; bb(2,2). 370 | ;;; bb(a,b). 371 | 372 | ;;; get-bb(X,Y) :- bb(X,Y),!,bb(Y,X). 373 | 374 | ;;; test(X,Y) :- 375 | ;;; get-bb(X,Y). 376 | 377 | (defun ltest14c () 378 | (wam:init-opcodes) 379 | (wam:reset-code) 380 | (wam:reset-asm) 381 | (wam:defrel bb 382 | ((bb 1 1)) 383 | ((bb 2 3)) 384 | ((bb 3 1)) 385 | ((bb 4 2)) 386 | ((bb 2 2)) 387 | ((bb a b))) 388 | (wam:defrel get-bb 389 | ((get-bb ?X ?Y) (bb ?X ?Y) ! (bb ?Y ?X))) 390 | (let ((result (wam:?- (get-bb ?id ?X)))) 391 | (if (equalp 392 | result 393 | '(((?ID . 1) (?X . 1)))) 394 | 'OK 395 | (progn 396 | (when wam:*wam-debug* (format *error-output* "~&FAIL ~S~%" result)) 397 | 'FAIL)))) 398 | 399 | ;;; bb(1,1). 400 | ;;; bb(2,3). 401 | ;;; bb(3,1). 402 | ;;; bb(4,2). 403 | ;;; bb(2,2). 404 | ;;; bb(a,b). 405 | 406 | ;;; get-bb(X,Y) :- bb(X,Y),bb(Y,X),!. 407 | 408 | ;;; test(X,Y) :- 409 | ;;; get-bb(X,Y). 410 | 411 | ;;; difference from ltest14 == cut at end of get-bb 412 | (defun ltest14a () 413 | (wam:init-opcodes) 414 | (wam:reset-code) 415 | (wam:reset-asm) 416 | (wam:defrel bb 417 | ((bb 1 1)) 418 | ((bb 2 3)) 419 | ((bb 3 1)) 420 | ((bb 4 2)) 421 | ((bb 2 2)) 422 | ((bb a b))) 423 | (wam:defrel get-bb 424 | ((get-bb ?X ?Y) (bb ?X ?Y) (bb ?Y ?X) !)) 425 | (let ((result (wam:?- (get-bb ?id ?X)))) 426 | (if (equalp 427 | result 428 | '(((?ID . 1) (?X . 1)))) 429 | 'OK 430 | (progn 431 | (when wam:*wam-debug* (format *error-output* "~&FAIL ~S~%" result)) 432 | 'FAIL)))) 433 | 434 | (defun ltest15() 435 | (wam:init-opcodes) 436 | (wam:reset-code) 437 | (wam:reset-asm) 438 | (wam:defrel bb 439 | ((bb 1 1)) 440 | ((bb 2 3)) 441 | ((bb 3 1)) 442 | ((bb 4 2)) 443 | ((bb 2 2)) 444 | ((bb a b))) 445 | (wam:defrel get-bb 446 | ((get-bb ?X ?Y) (bb ?X 1) !) 447 | ((get-bb ?X ?Y) (bb ?X ?Y))) 448 | (let ((result (wam:?- (get-bb ?X ?Y)))) 449 | (if (equalp 450 | result 451 | '(((?X . 1) (?Y . "unbound 8441")))) 452 | 'OK 453 | (progn 454 | (when wam:*wam-debug* (format *error-output* "~&FAIL ~S~%" result)) 455 | 'FAIL)))) 456 | 457 | 458 | 459 | (defun ltest15a() 460 | 'OK) 461 | 462 | ;;; h(2,3). 463 | ;;; f(3). 464 | ;;; p(Z,h(Z,W),f(W)). 465 | ;;; x(W,Z) :- p(Z,h(Z,W),f(W)). 466 | ;;; ?- x(W,Z) --> yes 467 | 468 | 469 | ;;-- ltest16 not working -- 470 | 471 | (defun ltest16 () 472 | (wam:init-opcodes) 473 | (wam:reset-code) 474 | (wam:reset-asm) 475 | (defrel h ((h #(h 2 3)))) 476 | (defrel f ((f 3))) 477 | (defrel p ((p #(p ?Z #(h ?W ?Z) #(f ?W))))) 478 | (defrel x ((x ?W ?Z) #(p ?Z (h ?Z ?W) #(f ?W)))) 479 | (wam:?- (x ?W ?Z))) 480 | 481 | ; h(2,3). 482 | ; f(3). 483 | ; p(Z,h(W,Z),f(W)). 484 | ; x(W,Z) :- p(W,h(W,Z),f(W)). 485 | 486 | ; % query is ?- x(W,Z). --> Z = W 487 | ; % ltest17 488 | (defun ltest17 () 489 | (wam:init-opcodes) 490 | (wam:reset-code) 491 | (wam:reset-asm) 492 | (defrel h ((h #(2 3)))) 493 | (defrel f ((f 3))) 494 | (defrel p ((p #(p ?Z #(h ?W ?Z) #(f ?W))))) 495 | (defrel x ((x ?W ?Z) #(p ?W (h ?W ?Z) #(f ?W)))) 496 | (wam:?- (x ?W ?Z))) 497 | 498 | ; h(2,3). 499 | ; f(3). 500 | ; p(11,h(4,5),f(6)). 501 | ; x(W,Z) :- p(W,h(W,Z),f(W)). 502 | 503 | ; % query is ?- x(W,Z). --> no 504 | ; % ltest18 505 | (defun ltest18 () 506 | (wam:init-opcodes) 507 | (wam:reset-code) 508 | (wam:reset-asm) 509 | (defrel h ((h #(2 3)))) 510 | (defrel f ((f 3))) 511 | (defrel p ((p #(p 11 #(h 4 5) #(f 6))))) 512 | (wam:?- (x ?W ?Z))) 513 | 514 | 515 | 516 | (defun test-1 (func) 517 | (let ((result (funcall func))) 518 | (format *standard-output* "~A : ~A~%" func result))) 519 | 520 | (defun test-all () 521 | (let ((wam:*wam-debug* nil)) 522 | (test-1 #'ltest0) 523 | (test-1 #'ltest1) 524 | (test-1 #'ltest2) 525 | (test-1 #'ltest4) 526 | (test-1 #'ltest5) 527 | (test-1 #'ltest6) 528 | (test-1 #'ltest7) 529 | (test-1 #'ltest8) 530 | (test-1 #'ltest9) 531 | (test-1 #'ltest10) 532 | (test-1 #'ltest11) 533 | (test-1 #'ltest12) 534 | (test-1 #'ltest13) 535 | (test-1 #'ltest13a) 536 | (test-1 #'ltest14) 537 | (test-1 #'ltest14a) 538 | (test-1 #'ltest14b) 539 | (test-1 #'ltest14c) 540 | (test-1 #'ltest15) 541 | (test-1 #'ltest15a) 542 | (test-1 #'ltest16))) 543 | -------------------------------------------------------------------------------- /wam-debug.lisp: -------------------------------------------------------------------------------- 1 | (in-package :wam/debug) 2 | 3 | (defun labelp (x) 4 | (char= #\$ (char (symbol-name x) 0))) 5 | 6 | (defun refp (x) 7 | (char= #\? (char (symbol-name x) 0))) 8 | 9 | (defun tprint (x) 10 | (cond ((symbolp x) 11 | (cond ((labelp x) (terpri) (prin1 x)) 12 | ((not (refp x)) 13 | (terpri) 14 | (princ " ") 15 | (prin1 x) 16 | (princ #\space)) 17 | (t (prin1 x) 18 | (princ #\space)))) 19 | ((listp x) 20 | (if (listp (car x)) 21 | (pprint x) 22 | (dolist (i x) (tprint i)))) 23 | (t (prin1 x) (princ #\space)))) 24 | 25 | -------------------------------------------------------------------------------- /wam.asd: -------------------------------------------------------------------------------- 1 | (defsystem wam 2 | :components ((:file "package") 3 | (:file "store"))) 4 | 5 | (defsystem wam/tags 6 | :depends-on (wam) 7 | :components ((:module source :pathname "./" :components 8 | ((:file "tags"))))) 9 | 10 | (defsystem wam/debug 11 | :depends-on (wam wam/tags) 12 | :components ((:module source :pathname "./" :components 13 | ((:file "wam-debug") 14 | (:file "wutil"))))) 15 | 16 | (defsystem wam/all 17 | :depends-on (wam wam/debug wam/tags) 18 | :components ((:module source :pathname "./" :components 19 | ((:file "const") 20 | (:file "opcodes") 21 | (:file "io") 22 | (:file "parse") 23 | (:file "asm") 24 | (:file "alloc1") 25 | (:file "coder") 26 | (:file "wam"))))) 27 | 28 | (defsystem wam/test 29 | :depends-on (wam wam/debug) 30 | :components ((:module suite :pathname "test/" :components 31 | ((:file "parse-test") 32 | (:file "test"))))) 33 | 34 | (defsystem wam/compare 35 | :depends-on (wam) 36 | :components ((:module suite :pathname "compare/" :components 37 | ((:static-file "grandfather.pl") ;; TODO add proper class for Prolog source files 38 | (:static-file "t13.pl") 39 | (:static-file "t14.pl") 40 | (:static-file "t15.pl"))))) 41 | -------------------------------------------------------------------------------- /wam.lisp: -------------------------------------------------------------------------------- 1 | ; $Id: wam.lisp,v 1.4 2006/02/18 22:49:02 tarvydas Exp $ 2 | ;; Copyright 2005 Paul Tarvydas 3 | 4 | ;; from http://wambook.sourceforge.net/ with permission (for free distribution) 5 | 6 | ;; L0 is a language that only does unification without backtracking 7 | ;; L0 has "queries" and "programs". Compile a program, then query it. Success if p unifies with q, else fail. 8 | ;; On success, variables in q will be bound to values from p. 9 | ;; L0 defines STRUCTURES and VARIABLES. It puts these in the HEAP, using TAGS to identify the kind(s) of entities. 10 | ;; Unbound VARIABLES are represented as self-referential cells (i.e. point back to themselves). 11 | 12 | ;; L0 describes a memory layout (in the HEAP) and "register" usage (called Xn) 13 | ;; example: p(Z,h(Z,W),f(W)). 14 | ;; the HEAP will contain (ref. Fig2.1) : 15 | ;; 0: STRUCT 1 16 | ;; 1: h/2 17 | ;; 2: REF 2 18 | ;; 3: REF 3 19 | ;; 4: STRUCT 5 20 | ;; 5: f/1 21 | ;; 6: REF 3 22 | ;; 7: STRUCT 8 23 | ;; 8: p/3 24 | ;; 9: REF 2 25 | ;; 10: STRUCT 1 26 | ;; 11: STRUCT 5 27 | ;; 28 | ;; this is inside-out (postfix) notation 29 | ;; h(Z,W) is represented in cells 0..3 30 | ;; 31 | ;; Z is described in cell 2 and points to itself 32 | ;; another reference to Z is in cell 9, which points to cell 2 (all references to Z refer to cell 2, with the first 33 | ;; occurence being in cell 2, pointing to itself 34 | ;; 35 | ;; W is in cell 3 (and points to itself) 36 | ;; 37 | ;; f(W) is in cells 5..6 and refers to cell 3 "W" 38 | ;; 39 | ;; p(... ... ...) is in cell 7 .. 11, pointing to cell 2 ("Z") and structs 1 and 5 40 | 41 | 42 | ;; section 2.2 discusses compilation of *queries*, section 2.3 discusses compilation of *programs*+ 43 | 44 | (in-package :wam) 45 | 46 | (proclaim '(optimize (debug 3) (safety 3) (speed 0) (space 0))) 47 | 48 | (declaim (optimize (debug 3) (safety 3) (speed 0) (space 0))) 49 | 50 | (defun reset-wam () 51 | (setf p 0 52 | cp -1 53 | s 0 54 | h heap-start 55 | hb heap-start 56 | b (1- stack-start) 57 | b0 (1- stack-start) 58 | e stack-start 59 | tr trail-start 60 | fail nil 61 | mode :read 62 | number-of-args 0 63 | (fill-pointer pdl) 0) 64 | (loop for i from 0 below store-size do 65 | (setf (aref store i) 0))) 66 | 67 | (defun interp-wam (start symbols) 68 | (let (result) 69 | (reset-wam) 70 | (setf p (code-addr start)) 71 | (when *wam-debug* 72 | (format t "p=/~s/ @p=/~A/~%" p (logand #xff (aref code p)) )) 73 | (catch 'quit 74 | (loop while (>= p 0) 75 | do (let ((byte (next-byte))) 76 | (declare (type (integer 0 255) byte)) 77 | (when *wam-debug* 78 | (format t "interp ~S ~A code[0]=~S~%" byte (disassem byte) (logand #xff (aref code 0)))) 79 | (if (= #.done byte) 80 | (progn 81 | (when symbols 82 | (push (mapcar #'(lambda (pair) 83 | (cons (car pair) (fetch pair))) 84 | symbols) 85 | result)) 86 | (backtrack)) 87 | (funcall (aref opcode-array byte) byte)) 88 | (when *wam-debug* 89 | (wam/debug:dump) 90 | (format t "~%"))))) 91 | result)) 92 | 93 | #| 94 | In general, "Put" bytecodes move items into the argument (Ai) registers. 95 | 96 | In general, "Get" bytecodes move items from the argument (Ai) registers. 97 | |# 98 | 99 | (defun f-put-x-variable (byte) 100 | "push a fresh variable (REF cell) onto the heap, and into registers (argument) Ai and (temp) Xn, consume two more 101 | bytes from the code stream (n and i resp), inc h pointer (heap) once" 102 | (declare (ignorable byte)) 103 | (let* ((x (next-byte)) 104 | (a (next-byte)) 105 | (v (wam/tags:tag-ref h))) 106 | (setf (heap h) v 107 | (regx x) v 108 | (rega a) v) 109 | (incf h))) 110 | 111 | (defun f-put-y-variable (byte) 112 | "in the current environment, set the nth local to a fresh REF cell, and set (argument) register Ai to refer to the fresh stack variable, consume two more bytes (n and i resp)." 113 | (declare (ignorable byte)) 114 | (let* ((addr (+ e (next-byte) 1)) 115 | (i (next-byte)) 116 | (v (wam/tags:tag-ref addr))) 117 | (setf (stack addr) v 118 | (rega i) v))) 119 | 120 | (defun f-put-x-value (byte) 121 | (declare (ignorable byte)) 122 | (let* ((n (next-byte)) 123 | (i (next-byte))) 124 | (setf (rega i) (store n)))) 125 | 126 | (defun f-put-y-value (byte) 127 | (declare (ignorable byte)) 128 | (let* ((n (next-byte)) 129 | (i (next-byte)) 130 | (addr (deref (+ e n 1)))) 131 | (setf (rega i) (store addr)))) 132 | 133 | (defun f-put-y-unsafe-value (byte) 134 | (declare (ignorable byte)) 135 | (let* ((n (next-byte)) 136 | (i (next-byte)) 137 | (addr (deref (+ e n 1)))) 138 | (if (< addr e) 139 | (setf (rega i) (store addr)) 140 | (let ((v (wam/tags:tag-ref h))) 141 | (setf (heap h) v) 142 | (bind addr h) 143 | (setf (rega i) v) 144 | (incf h))))) 145 | 146 | (defun f-put-structure (byte) (declare (ignorable byte)) 147 | ;; a structure on the heap is a constant (name+arity of struct) 148 | ;; followed by fields of struct (n = arity) 149 | (let* ((fn (next-const)) 150 | (i (next-byte))) 151 | (setf (heap h) fn 152 | (rega i) (wam/tags:tag-str h)) 153 | (incf h))) 154 | 155 | (defun f-put-list (byte) (declare (ignorable byte)) 156 | (setf (rega (next-byte)) (wam/tags:tag-lis h))) 157 | 158 | (defun f-put-nil (byte) (declare (ignorable byte)) 159 | (setf (rega (next-byte)) (wam/tags:tag-spcl 0))) 160 | 161 | (defun f-put-byte-constant (byte) (declare (ignorable byte)) 162 | (let* ((c (next-byte-const)) 163 | (i (next-byte))) 164 | (setf (rega i) (wam/tags:tag-int c)))) 165 | 166 | (defun f-put-word-constant (byte) (declare (ignorable byte)) 167 | (let* ((c (next-word-const)) 168 | (i (next-byte))) 169 | (setf (rega i) (wam/tags:tag-int c)))) 170 | 171 | (defun f-put-tri-constant (byte) (declare (ignorable byte)) 172 | (let* ((c (next-tri-const)) 173 | (i (next-byte))) 174 | (setf (rega i) (wam/tags:tag-int c)))) 175 | 176 | (defun f-put-constant (byte) (declare (ignorable byte)) 177 | (let* ((c (next-const)) 178 | (i (next-byte))) 179 | (setf (rega i) (wam/tags:tag-con c)))) 180 | 181 | (defun f-get-x-variable (byte) (declare (ignorable byte)) 182 | (let* ((n (next-byte)) 183 | (i (next-byte))) 184 | (setf (store n) (rega i)))) 185 | 186 | (defun f-get-y-variable (byte) (declare (ignorable byte)) 187 | (let* ((addr (+ e (next-byte) 1)) 188 | (i (next-byte))) 189 | (setf (store addr) (rega i)))) 190 | 191 | (defun f-get-x-value (byte) (declare (ignorable byte)) 192 | (let* ((n (next-byte)) 193 | (i (next-byte))) 194 | (unify (store n) (rega i)) 195 | (when fail 196 | (backtrack)))) 197 | 198 | (defun f-get-y-value (byte) (declare (ignorable byte)) 199 | (let* ((addr (+ e (next-byte) 1)) 200 | (i (next-byte))) 201 | (unify (store addr) (rega i)) 202 | (when fail 203 | (backtrack)))) 204 | 205 | (defun f-get-structure (byte) (declare (ignorable byte)) 206 | (let* ((fn (next-const)) 207 | (i (next-byte)) 208 | (addr (deref i)) 209 | (tag (wam/tags:tag (store addr)))) 210 | (setf fail nil) 211 | (case tag 212 | (#.wam/tags:ref 213 | (setf (heap h) (wam/tags:tag-str (1+ h))) 214 | (setf (heap (1+ h)) (wam/tags:tag-con fn)) 215 | (bind addr h) 216 | (incf h 2) 217 | (setf mode :write)) 218 | (#.wam/tags:str 219 | (let ((a (wam/tags:untag (store addr)))) 220 | (if (= (heap a) fn) 221 | (setf s (1+ a) 222 | mode :read) 223 | (setf fail t)))) 224 | (otherwise 225 | (setf fail t))) 226 | (when fail 227 | (backtrack)))) 228 | 229 | (defun f-get-list (byte) (declare (ignorable byte)) 230 | (let* ((i (next-byte)) 231 | (addr (deref i)) 232 | (tag (wam/tags:tag (store addr)))) 233 | (setf fail nil) 234 | (case tag 235 | (#.wam/tags:ref 236 | (setf (heap h) (wam/tags:tag-lis (1+ h))) 237 | (bind addr h) 238 | (incf h) 239 | (setf mode :write)) 240 | (#.wam/tags:lis 241 | (let ((a (wam/tags:untag (store addr)))) 242 | (setf s a 243 | mode :read))) 244 | (otherwise 245 | (setf fail t))) 246 | (when fail 247 | (backtrack)))) 248 | 249 | 250 | (defun f-get-byte-constant (byte) (declare (ignorable byte)) 251 | (let* ((c (next-byte-const)) 252 | (i (next-byte)) 253 | (addr (deref i)) 254 | (tag (wam/tags:tag (store addr)))) 255 | (setf fail nil) 256 | (case tag 257 | (#.wam/tags:ref 258 | (setf (store addr) (wam/tags:tag-int c)) 259 | (trail addr)) 260 | (#.wam/tags:int 261 | (let ((c1 (wam/tags:untag (store addr)))) 262 | (setf fail (or (/= wam/tags:int (wam/tags:tag (store addr))) 263 | (/= c c1))))) 264 | (otherwise 265 | (setf fail t))) 266 | (when fail 267 | (backtrack)))) 268 | 269 | (defun f-get-word-constant (byte) (declare (ignorable byte)) 270 | (let* ((c (next-word-const)) 271 | (i (next-byte)) 272 | (addr (deref i)) 273 | (tag (wam/tags:tag (store addr)))) 274 | (setf fail nil) 275 | (case tag 276 | (#.wam/tags:ref 277 | (setf (store addr) (wam/tags:tag-int c)) 278 | (trail addr)) 279 | (#.wam/tags:int 280 | (let ((c1 (wam/tags:untag (store addr)))) 281 | (setf fail (or (/= int (wam/tags:tag (store addr))) 282 | (/= c c1))))) 283 | (otherwise 284 | (setf fail t))) 285 | (when fail 286 | (backtrack)))) 287 | 288 | (defun f-get-tri-constant (byte) (declare (ignorable byte)) 289 | (let* ((c (next-tri-const)) 290 | (i (next-byte)) 291 | (addr (deref i)) 292 | (tag (wam/tags:tag (store addr)))) 293 | (setf fail nil) 294 | (case tag 295 | (#.wam/tags:ref 296 | (setf (store addr) (wam/tags:tag-int c)) 297 | (trail addr)) 298 | (#.wam/tags:int 299 | (let ((c1 (wam/tags:untag (store addr)))) 300 | (setf fail (or (/= int (wam/tags:tag (store addr))) 301 | (/= c c1))))) 302 | (otherwise 303 | (setf fail t))) 304 | (when fail 305 | (backtrack)))) 306 | 307 | (defun f-get-constant (byte) (declare (ignorable byte)) 308 | (let* ((c (next-const)) 309 | (i (next-byte)) 310 | (addr (deref i)) 311 | (tag (wam/tags:tag (store addr)))) 312 | (setf fail nil) 313 | (case tag 314 | (#.wam/tags:ref 315 | (setf (store addr) (wam/tags:tag-con c)) 316 | (trail addr)) 317 | (#.wam/tags:con 318 | (let ((c1 (wam/tags:untag (store addr)))) 319 | (setf fail (or (/= wam/tags:con (wam/tags:tag (store addr))) 320 | (/= c c1))))) 321 | (otherwise 322 | (setf fail t))) 323 | (when fail 324 | (backtrack)))) 325 | 326 | (defun f-get-nil (byte) (declare (ignorable byte)) 327 | (let* ((i (next-byte)) 328 | (addr (deref i)) 329 | (tag (wam/tags:tag (store addr)))) 330 | (setf fail nil) 331 | (case tag 332 | (#.wam/tags:ref 333 | (setf (store addr) (wam/tags:tag-spcl 0)) 334 | (trail addr)) 335 | (#.wam/tags:spcl 336 | (let ((c1 (wam/tags:untag (store addr)))) 337 | (setf fail (/= 0 c1)))) 338 | (otherwise 339 | (setf fail t))) 340 | (when fail 341 | (backtrack)))) 342 | 343 | (defun f-set-x-variable (byte) (declare (ignorable byte)) 344 | (let* ((n (next-byte)) 345 | (v (wam/tags:tag-ref h))) 346 | (setf (heap h) v 347 | (var n) v) 348 | (incf h))) 349 | 350 | (defun f-set-x-value (byte) (declare (ignorable byte)) 351 | (let* ((n (next-byte))) 352 | (setf (heap h) (regx n)) 353 | (incf h))) 354 | 355 | (defun f-set-y-variable (byte) (declare (ignorable byte)) 356 | (let* ((addr (+ e (next-byte) 1)) 357 | (v (wam/tags:tag-ref addr))) 358 | (setf (heap h) v) 359 | (setf (stack addr) v) 360 | (incf h))) 361 | 362 | (defun f-set-y-value (byte) (declare (ignorable byte)) 363 | (let* ((a (next-triple)) 364 | (addr (deref a))) 365 | (if (< addr h) 366 | (setf (heap h) (heap addr)) 367 | (progn 368 | (setf (heap h) (wam/tags:tag-ref h)) 369 | (bind addr h))) 370 | (incf h))) 371 | 372 | (defun f-set-byte-constant (byte) (declare (ignorable byte)) 373 | (setf (heap h) (wam/tags:tag-int (next-byte-const))) 374 | (incf h)) 375 | 376 | (defun f-set-word-constant (byte) (declare (ignorable byte)) 377 | (setf (heap h) (wam/tags:tag-int (next-word-const))) 378 | (incf h)) 379 | 380 | (defun f-set-tri-constant (byte) (declare (ignorable byte)) 381 | (setf (heap h) (wam/tags:tag-int (next-tri-const))) 382 | (incf h)) 383 | 384 | (defun f-set-constant (byte) (declare (ignorable byte)) 385 | (setf (heap h) (wam/tags:tag-con (next-const))) 386 | (incf h)) 387 | 388 | (defun f-set-void (byte) (declare (ignorable byte)) 389 | (let ((n (next-byte))) 390 | (loop for i from h below (+ h n) 391 | do (setf (heap i) (wam/tags:tag-ref i))) 392 | (incf h n))) 393 | 394 | (defun f-unify-x-variable (byte) (declare (ignorable byte)) 395 | (let ((n (next-byte))) 396 | (ecase mode 397 | (:read (setf (regx n) (heap s))) 398 | (:write 399 | (setf (regx n) 400 | (setf (heap h) (wam/tags:tag-ref h))) 401 | (incf h))) 402 | (incf s))) 403 | 404 | (defun f-unify-x-value (byte) (declare (ignorable byte)) 405 | (setf fail nil) 406 | (let ((n (next-byte))) 407 | (ecase mode 408 | (:read (unify (regx n) s)) 409 | (:write 410 | (let ((addr (deref n))) 411 | (if (< addr h) 412 | (setf (heap h) (heap addr)) 413 | (progn 414 | (setf (heap h) (wam/tags:tag-ref h)) 415 | (bind addr h)))) 416 | (incf h))) 417 | (incf s)) 418 | (when fail 419 | (backtrack))) 420 | 421 | (defun unify-word-constant (byte) 422 | (f-unify-byte-constant byte)) 423 | 424 | (defun unify-tri-constant (byte) 425 | (f-unify-byte-constant byte)) 426 | 427 | (defun f-unify-byte-constant (byte) (declare (ignorable byte)) 428 | (let ((c (ecase byte 429 | (#.unify-byte-constant (next-byte-const)) 430 | (#.unify-word-constant (next-word-const)) 431 | (#.unify-tri-constant (next-tri-const))))) 432 | (setf fail nil) 433 | (ecase mode 434 | (:read 435 | (let* ((addr (deref s)) 436 | (tag (wam/tags:tag (store addr)))) 437 | (incf s) 438 | (case tag 439 | (#.wam/tags:ref 440 | (setf (store addr) (wam/tags:tag-int c)) 441 | (trail addr)) 442 | (#.wam/tags:int 443 | (setf fail (or (/= int (wam/tags:tag (store addr))) 444 | (/= c (wam/tags:untag (store addr)))))) 445 | (otherwise 446 | (setf fail t))))) 447 | (:write 448 | (setf (heap h) (wam/tags:tag-int c)) 449 | (incf h))) 450 | (when fail 451 | (backtrack)))) 452 | 453 | (defun f-unify-constant (byte) (declare (ignorable byte)) 454 | (let ((c (next-const))) 455 | (setf fail nil) 456 | (ecase mode 457 | (:read 458 | (let* ((addr (deref s)) 459 | (tag (wam/tags:tag (store addr)))) 460 | (incf s) 461 | (case tag 462 | (#.wam/tags:ref 463 | (setf (store addr) (wam/tags:tag-con c)) 464 | (trail addr)) 465 | (#.wam/tags:con 466 | (setf fail (or (/= wam/tags:tag-con (wam/tags:tag (store addr))) 467 | (/= c (wam/tags:untag (store addr)))))) 468 | (otherwise 469 | (setf fail t))))) 470 | (:write 471 | (setf (heap h) (wam/tags:tag-con c)) 472 | (incf h))) 473 | (when fail 474 | (backtrack)))) 475 | 476 | (defun f-unify-void (byte) (declare (ignorable byte)) 477 | (let ((n (next-byte))) 478 | (ecase mode 479 | (:read (incf s n)) 480 | (:write 481 | (loop for i from h below (+ h n) 482 | do (setf (heap i) (wam/tags:tag-ref i))) 483 | (incf h n))))) 484 | 485 | (defun f-allocate (byte) (declare (ignorable byte)) 486 | "create a new environment frame on the stack, storing E and CP in the frame" 487 | (setf e (- e 10)) ;; TODO: experiment, leave 10 slots for locals - refine this later - for now, 488 | ;; it means that a max of 10 locals are available for any rule 489 | ;; this experiment causes ltest2 to fail - something is very wrong 490 | (let ((newe 491 | (cond ((= -1 cp) 492 | e) 493 | ((> e b) 494 | (+ e (aref code (1- cp)) 2)) 495 | (t (+ b (stack b) 8))))) 496 | (setf (stack newe) e 497 | (stack (1+ newe)) cp) 498 | (setf e newe))) 499 | 500 | (defun f-deallocate (byte) (declare (ignorable byte)) 501 | (setf cp (stack (1+ e))) 502 | (setf e (stack e)) 503 | (setf e (+ 10 e))) ;; TODO: see experiment above 504 | 505 | (defun f-call (byte) (declare (ignorable byte)) 506 | (let* ((proc (next-label)) 507 | (n (next-byte))) 508 | (declare (ignorable n)) 509 | (if (defined proc) 510 | (let () 511 | (setf number-of-args (arity proc)) 512 | (setf cp p) 513 | (setf b0 b) 514 | #+nil(format *standard-output* "f-call proc=~s p=~a @p=~s~%" 515 | proc (code-addr p) (logand #xff (aref code p))) 516 | (setf p (code-addr proc))) 517 | (backtrack)))) 518 | 519 | (defun f-execute (byte) (declare (ignorable byte)) 520 | (let ((proc (next-label))) 521 | (if (defined proc) 522 | (let () 523 | (setf number-of-args (arity proc)) 524 | (setf b0 b) 525 | (setf p (code-addr proc))) 526 | (backtrack)))) 527 | 528 | (defun f-proceed (byte) (declare (ignorable byte)) 529 | (setf p cp)) 530 | 531 | (defun f-try-me-else (byte) (declare (ignorable byte)) 532 | (let* ((L (next-abs)) 533 | (newB 534 | (if (> e b) 535 | (+ e (aref code (1- cp)) 2) 536 | (+ b (stack b) 8))) 537 | (n number-of-args)) 538 | (setf (stack newB) n) 539 | (loop for i from 1 to n 540 | do (setf (stack (+ newB i)) (rega i))) 541 | (let ((bn (+ newB n))) 542 | (setf (stack (+ bn 1)) e 543 | (stack (+ bn 2)) cp 544 | (stack (+ bn 3)) b 545 | (stack (+ bn 4)) L 546 | (stack (+ bn 5)) tr 547 | (stack (+ bn 6)) h 548 | (stack (+ bn 7)) b0 549 | b newB 550 | hb h)))) 551 | 552 | (defun f-retry-me-else (byte) (declare (ignorable byte)) 553 | (let* ((L (next-abs)) 554 | (n (stack b))) 555 | (loop for i from 1 to n 556 | do (setf (rega i) (stack (+ b i)))) 557 | (setf e (stack (+ b n 1)) 558 | cp (stack (+ b n 2)) 559 | (stack (+ b n 4)) L) 560 | (unwind-trail (stack (+ b n 5)) tr) 561 | (setf tr (stack (+ b n 5)) 562 | h (stack (+ b n 6)) 563 | hb h))) 564 | 565 | (defun f-trust-me (byte) (declare (ignorable byte)) 566 | (let ((n (stack b))) 567 | (loop for i from 1 to n 568 | do (setf (rega i) (stack (+ b i)))) 569 | (setf e (stack (+ b n 1)) 570 | cp (stack (+ b n 2))) 571 | (unwind-trail (stack (+ b n 5)) tr) 572 | (setf tr (stack (+ b n 5)) 573 | h (stack (+ b n 6)) 574 | b (stack (+ b n 3)) 575 | hb (stack (+ b n 6))))) 576 | 577 | (defun f-try (byte) (declare (ignorable byte)) 578 | (let ((L (next-label)) 579 | (newB (if (> e b) 580 | (+ e (aref code (1- cp)) 2) 581 | (+ b (stack b) 8))) 582 | (n number-of-args)) 583 | (setf (stack newB) n) 584 | (loop for i from 1 to n 585 | do (setf (stack (+ newB i)) (rega i))) 586 | (let ((bn (+ newB n))) 587 | (setf (stack (+ bn 1)) e 588 | (stack (+ bn 2)) cp 589 | (stack (+ bn 3)) b 590 | (stack (+ bn 4)) p 591 | (stack (+ bn 5)) tr 592 | (stack (+ bn 6)) h 593 | (stack (+ bn 7)) b0 594 | b newB 595 | hb h 596 | p (code-addr L))))) 597 | 598 | (defun f-retry (byte) (declare (ignorable byte)) 599 | (let ((L (next-label)) 600 | (n (stack b))) 601 | (loop for i from 0 to (1- n) 602 | do (setf (rega i) (stack (+ b i)))) 603 | (setf e (stack (+ b n 1)) 604 | cp (stack (+ b n 2)) 605 | (stack (+ b n 4)) p) 606 | (unwind-trail (stack (+ b n 5)) tr) 607 | (setf tr (stack (+ b n 5)) 608 | h (stack (+ b n 6)) 609 | hb h 610 | p (code-addr L)))) 611 | 612 | (defun f-trust (byte) (declare (ignorable byte)) 613 | (let ((L (next-label)) 614 | (n (stack b))) 615 | (loop for i from 1 to n 616 | do (setf (rega i) (stack (+ b i)))) 617 | (setf e (stack (+ b n 1)) 618 | cp (stack (+ b n 2))) 619 | (unwind-trail (stack (+ b n 5)) tr) 620 | (setf tr (stack (+ b n 5)) 621 | h (stack (+ b n 6)) 622 | b (stack (+ b n 3)) 623 | hb (stack (+ b n 6)) 624 | p (code-addr L)))) 625 | 626 | (defun f-switch-on-term (byte) (declare (ignorable byte)) 627 | (let* ((lv (next-label)) 628 | (lc (next-label)) 629 | (ll (next-label)) 630 | (ls (next-label))) 631 | (setf p (code-addr 632 | (ecase (wam/tags:tag (store (deref 1))) 633 | (#.wam/tags:ref lv) 634 | (#.wam/tags:con lc) 635 | (#.wam/tags:lis ll) 636 | (#.wam/tags:str ls)))))) 637 | 638 | ;;; (defun f-switch-on-constant (byte) (declare (ignorable byte)) 639 | ;;; (let* ((c (store (deref 1))) 640 | ;;; (val (wam/tags:untag c)) 641 | ;;; (n (next-byte)) 642 | ;;; (table (next-double))) 643 | ;;; (declare (ignorable n)) 644 | ;;; (multiple-value-bind (found code-addr) 645 | ;;; (gethash val (table table)) 646 | ;;; (if found 647 | ;;; (setf p code-addr) 648 | ;;; (backtrack))))) 649 | 650 | 651 | ;;; (defun f-switch-on-structure (byte) (declare (ignorable byte)) 652 | ;;; (let* ((c (store (deref 1))) 653 | ;;; (val (wam/tags:untag c)) 654 | ;;; (n (next-byte)) 655 | ;;; (table (next-double))) 656 | ;;; (declare (ignorable n)) 657 | ;;; (multiple-value-bind (found code-addr) 658 | ;;; (gethash val (table table)) 659 | ;;; (if found 660 | ;;; (setf p code-addr) 661 | ;;; (backtrack))))) 662 | 663 | (defun f-neck-cut (byte) (declare (ignorable byte)) 664 | (when (> b b0) 665 | (setf b b0) 666 | (tidy-trail))) 667 | 668 | (defun f-get-level (byte) (declare (ignorable byte)) 669 | "set local variable N to current B0 (cut pointer), consume one more byte from 670 | code stream for N" 671 | (let ((n (next-byte))) 672 | (setf (stack (+ e 1 n)) b0)) 673 | nil) 674 | 675 | (defun f-cut (byte) (declare (ignorable byte)) 676 | (let ((n (next-byte))) 677 | (when (> b (stack (+ e 1 n))) 678 | (setf b (stack (+ e 1 n))) 679 | (tidy-trail)))) 680 | 681 | (defun fetch (pair) 682 | ; given a symbol-allocation pair, fetch the 683 | ; value of the symbol and return it 684 | (let ((r (alloc-reg (cdr pair)))) 685 | (if (alloc-is-temp (cdr pair)) 686 | (fetch-temp r) 687 | (fetch-local r)))) 688 | 689 | (defun fetch-temp (r) 690 | (fetch-store (store (deref r)))) 691 | 692 | (defun fetch-local (r) 693 | (if (<= 0 (local r) (1- store-size)) 694 | (fetch-store (deref (local r))) 695 | (format nil "unbound ~A" (wam/tags:untag (local r))))) 696 | 697 | (defun fetch-store (v) 698 | ;; helper that extracts values from the environment and converts 699 | ;; them to lisp so that they can be returned by DONE 700 | (ecase (wam/tags:tag v) 701 | (#.wam/tags:int (wam/tags:untag v)) 702 | (#.wam/tags:ref (format nil "unbound ~A" (wam/tags:untag v))) 703 | (#.wam/tags:con (gethash (wam/tags:untag v) (unconsts))) 704 | (#.wam/tags:lis (list (fetch-store (store (wam/tags:untag v))) ; a lis is always car/cdr (a pair) 705 | (fetch-store (store (1+ (wam/tags:untag v)))))) 706 | (#.wam/tags:str 707 | ; first const is the struct and its name contains the arity 708 | (let* ((a (wam/tags:untag v)) 709 | (struct-con (store a))) 710 | (assert (= wam/tags:con (wam/tags:tag struct-con))) 711 | (let* ((const (wam/tags:untag struct-con)) 712 | (name-arity (gethash const (unconsts))) 713 | (arity (extract-arity-from-const name-arity)) 714 | (result (make-array (1+ arity))) 715 | (i 1)) 716 | (setf (aref result 0) name-arity) 717 | (incf a) 718 | (dotimes (j arity) 719 | (setf (aref result i) (fetch-store (store a))) 720 | (incf a) 721 | (incf i)) 722 | result))) 723 | (#.wam/tags:spcl (assert (zerop (wam/tags:untag v))) "nil"))) 724 | 725 | (defun extract-arity-from-const (name-arity-string) 726 | (parse-integer (subseq name-arity-string 727 | (1+ (position #\/ name-arity-string))))) 728 | 729 | (defun backtrack () 730 | (if (< b stack-start) 731 | (throw 'quit nil) 732 | (progn 733 | (setf b0 (stack (+ b (stack b) 7)) 734 | p (stack (+ b (stack b) 4)))))) 735 | 736 | (defun deref (a) 737 | (let* ((v (store a)) 738 | (tag (wam/tags:tag v)) 739 | (val (wam/tags:untag v))) 740 | (declare (type fixnum a v tag val)) 741 | (if (and (= tag wam/tags:ref) (/= val a)) 742 | (deref val) 743 | (the fixnum a)))) 744 | 745 | (defun bind (a1 a2) 746 | (declare (type fixnum v1 v2 t1 a1 a2)) 747 | (let* ((v1 (store a1)) 748 | (v2 (store a2)) 749 | (t1 (wam/tags:tag v1)) 750 | (t2 (wam/tags:tag v2))) 751 | (if (and (= t1 wam/tags:ref) 752 | (or (/= t2 wam/tags:ref) (< a2 a1))) 753 | (progn 754 | (setf (store a1) (store a2)) 755 | (trail a1)) 756 | (progn 757 | (setf (store a2) (store a1)) 758 | (trail a2))))) 759 | 760 | (defun trail (a) 761 | (declare (type fixnum a)) 762 | (when (or (< a hb) 763 | (and (< h a) (< a b))) 764 | (setf (trail-stack tr) a) 765 | (incf tr))) 766 | 767 | (defun unwind-trail (a1 a2) 768 | (declare (type fixnum a1 a2)) 769 | (loop for i from a1 to (1- a2) 770 | do (setf (store (trail-stack i)) (wam/tags:tag-ref (trail-stack i))))) 771 | 772 | (defun tidy-trail () 773 | (unless (< b stack-start) 774 | (loop with i = (stack (+ b (stack b) 5)) 775 | while (< i tr) 776 | do (if (or (< (trail-stack i) hb) 777 | (and (< h (trail-stack i)) (< (trail-stack i) b))) 778 | (incf i) 779 | (progn 780 | (setf (trail-stack i) (trail-stack (1- tr))) 781 | (decf tr)))))) 782 | 783 | (defun unify (a1 a2) 784 | (declare (type fixnum a1 a2)) 785 | (pdl-push a1) 786 | (pdl-push a2) 787 | (setf fail nil) 788 | (loop while (not (or (pdl-empty) fail)) do 789 | (let ((d1 (deref (pdl-pop))) 790 | (d2 (deref (pdl-pop)))) 791 | (declare (type fixnum d1 d2)) 792 | (unless (= d1 d2) 793 | (let* ((s1 (store d1)) 794 | (t1 (wam/tags:tag s1)) 795 | (v1 (wam/tags:untag s1)) 796 | (s2 (store d2)) 797 | (t2 (wam/tags:tag s2)) 798 | (v2 (wam/tags:untag s2))) 799 | (declare (type fixnum s1 t1 v1 s2 t2 v2)) 800 | (if (= ref t1) 801 | (bind d1 d2) 802 | (ecase t2 803 | (#.wam/tags:ref (bind d1 d2)) 804 | (#.wam/tags:con (setf fail (or (/= t1 con) (/= v1 v2)))) 805 | (#.wam/tags:int (setf fail (or (/= t1 con) (/= v1 v2)))) 806 | (#.wam/tags:lis (if (/= t1 lis) 807 | (setf fail t) 808 | (progn 809 | (pdl-push v1) 810 | (pdl-push v2) 811 | (pdl-push (1+ v1)) 812 | (pdl-push (1+ v2))))) 813 | (#.wam/tags:str (if (/= str t1) 814 | (setf fail t) 815 | (let ((fn1 (store v1)) 816 | (fn2 (store v2))) 817 | (declare (type fixnum fn1 fn2)) 818 | (if (/= fn1 fn2) 819 | (setf fail t) 820 | (loop for i from 1 to (arity fn1) do 821 | (pdl-push (+ v1 i)) 822 | (pdl-push (+ v2 i)))))))))))))) 823 | 824 | ; (let (code-p procs consts id) 825 | (defvar code-p) 826 | (defvar procs) 827 | (defvar consts) 828 | (defvar unconsts) 829 | (defvar id) 830 | 831 | (defun unconsts () unconsts) 832 | 833 | (defun reset-code () 834 | (if (boundp 'procs) 835 | (clrhash procs) 836 | (setf procs (make-hash-table :test 'eq))) 837 | (if (boundp 'consts) 838 | (clrhash consts) 839 | (setf consts (make-hash-table :test 'equal))) 840 | (if (boundp 'unconsts) 841 | (clrhash consts) 842 | (setf unconsts (make-hash-table :test 'eq))) 843 | (setf id 0) 844 | (setf (gethash "NIL" consts) 0) 845 | (setf (gethash 0 unconsts) "NIL") 846 | (setf code-p 0) 847 | (setf *code-io* (make-instance 'array-io :array code))) 848 | 849 | (defun next-id () 850 | (incf id)) 851 | 852 | (defun w-tell () code-p) 853 | 854 | (defun w-byte (x) 855 | (setf (aref code code-p) x) 856 | (incf code-p)) 857 | 858 | (defun w-opcode (x) 859 | (w-byte x)) 860 | 861 | (defun w-reg (n) 862 | (w-byte n)) 863 | 864 | (defun w-triple (x) 865 | (w-byte (logand (ash x -16) #xff)) 866 | (w-byte (logand (ash x -8) #xff)) 867 | (w-byte (logand x #xff))) 868 | 869 | (defun w-const (c) 870 | (w-triple c)) 871 | 872 | (defun w-label (f &optional n) 873 | (if n 874 | (w-triple (logior (ash f 5) (logand n 31))) 875 | (w-triple f))) 876 | 877 | (defun make-proc (pc name arity) 878 | (let ((lab (logior (ash pc 5) (logand arity 31)))) 879 | (assert (null (gethash lab procs))) 880 | (setf (gethash lab procs) name) 881 | lab)) 882 | 883 | (defun fetch-constant (c) 884 | (or (gethash c consts) 885 | (let ((id (next-id))) 886 | (setf (gethash c consts) id) 887 | (setf (gethash id unconsts) c) 888 | id))) 889 | 890 | (defun defined (label) 891 | (multiple-value-bind (val success) 892 | (gethash label procs) 893 | (declare (ignore val)) 894 | success)) 895 | 896 | (defun code () 897 | code) 898 | 899 | -------------------------------------------------------------------------------- /wutil.lisp: -------------------------------------------------------------------------------- 1 | ; $Id$ 2 | ; Copyright 2005 Paul Tarvydas 3 | (in-package :wam/debug) 4 | 5 | (defun dump () 6 | (format t "p=~A cp=~A s=~A h=~A hb=~A b=~A b0=~A e=~A tr=~A mode=~A~%" 7 | ;; TODO: export these 8 | wam::p wam::cp wam::s wam::h wam::hb wam::b wam::b0 wam::e wam::tr wam::mode) 9 | (format t "regs: ") 10 | (loop for i from 0 to 7 do 11 | (dump-cell i)) 12 | (format t "~%") 13 | (format t "stack[~A]: " wam::stack-start) ;; TODO: export 14 | (loop for i from wam::stack-start to (+ wam::e 2 5) do ;; TODO: export X 2 15 | (dump-cell i)) 16 | (format t "~%") 17 | (format t "heap: ") 18 | (loop for i from wam::heap-start to (+ wam::heap-start 7) do ;; TODO: export 19 | (dump-cell i)) 20 | (format t "~%")) 21 | 22 | (defun dump-cell (i) 23 | (if (= (wam:regx i) 0) 24 | (format t "-- ") 25 | (format t "[~A ~A] " 26 | (dump-tag (wam:regx i)) 27 | (if (= wam/tags:con (wam/tags:tag (wam:regx i))) 28 | (unconst (wam/tags:untag (wam:regx i))) 29 | (dump-untag (wam:regx i)))))) 30 | 31 | (defun unconst (x) 32 | (gethash x wam::unconsts)) ;; TODO: export 33 | 34 | (defun dump-tag (x) 35 | (case (wam/tags:tag x) 36 | (#.wam/tags:int "int") 37 | (#.wam/tags:ref "ref") 38 | (#.wam/tags:con "con") 39 | (#.wam/tags:lis "lis") 40 | (#.wam/tags:str "str") 41 | (#.wam/tags:spcl "spcl") 42 | (otherwise "unknown"))) 43 | 44 | (defun dump-untag (x) 45 | (wam/tags:untag x)) 46 | --------------------------------------------------------------------------------