# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1468448479 0
# Node ID eec2064a08b61b3f3ff02251549ce152ab88b2ca
# Parent  31305584b29bc7df3c499f895c44f3f7cdc40b83
Put the actual functor conses into the store

It's happening!

diff -r 31305584b29b -r eec2064a08b6 src/wam/compiler.lisp
--- a/src/wam/compiler.lisp	Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/compiler.lisp	Wed Jul 13 22:21:19 2016 +0000
@@ -134,6 +134,7 @@
    (tail :accessor node-tail :type node :initarg :tail)))
 
 
+; todo functor -> fname
 (defun* make-top-level-node ((functor symbol) (arity arity) (arguments list))
   (:returns top-level-node)
   (values (make-instance 'top-level-node
@@ -1126,7 +1127,7 @@
            ;; OP functor reg
            (push destination-register seen)
            (push-instruction (find-opcode-structure mode)
-                             (wam-ensure-functor-index wam (cons functor arity))
+                             (wam-unique-functor wam (cons functor arity))
                              destination-register))
          (handle-list (register)
            (push register seen)
@@ -1142,7 +1143,7 @@
              ;; [CALL/JUMP] functor
              (push-instruction
                (if is-jump :jump :call)
-               (cons functor arity)))
+               (wam-unique-functor wam (cons functor arity))))
            ;; This is a little janky, but at this point the body goals have been
            ;; turned into one single stream of tokens, so we don't have a nice
            ;; clean way to tell when one ends.  But in practice, a body goal is
@@ -1392,10 +1393,11 @@
 
 (defun* optimize-constants ((wam wam) (instructions circle))
   (:returns circle)
+  (declare (ignore wam))
   ;; From the book and the erratum, there are four optimizations we can do for
   ;; constants (0-arity structures).
   (flet ((constant-p (functor)
-           (zerop (wam-functor-arity wam functor))))
+           (zerop (cdr functor))))
     (loop :for node = (circle-forward instructions) :then (circle-forward node)
           :while node
           :for (opcode . arguments) = (circle-value node)
@@ -1525,7 +1527,7 @@
     ;; todo: simplify this to a single `if` once the store is fully split
     (null 0) ; ugly choice point args that'll be filled later...
     (register (register-number argument)) ; bytecode just needs register numbers
-    (functor argument) ; functor for a CALL/JUMP
+    (functor argument) ; functors just get literally included
     (number argument))) ; just a numeric argument, e.g. alloc 0
 
 (defun* render-bytecode ((store generic-code-store)
@@ -1584,7 +1586,8 @@
                     (arity arity)
                     (address code-index))
   "Set the code label `functor`/`arity` to point at `address`."
-  (setf (wam-code-label wam functor arity) address))
+  (setf (wam-code-label wam functor arity)
+        address))
 
 (defun* render-rules ((wam wam)
                       (functor symbol)
diff -r 31305584b29b -r eec2064a08b6 src/wam/constants.lisp
--- a/src/wam/constants.lisp	Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/constants.lisp	Wed Jul 13 22:21:19 2016 +0000
@@ -77,8 +77,7 @@
   :documentation "Maximum size of the WAM heap.")
 
 (define-constant +functor-limit+ array-total-size-limit
-  ;; Functors are referred to by their index into the functor array.  This index
-  ;; is stored in the value part of functor cells.
+  ;; Functors are stored in a functor table.
   :documentation "The maximum number of functors the WAM can keep track of.")
 
 
diff -r 31305584b29b -r eec2064a08b6 src/wam/dump.lisp
--- a/src/wam/dump.lisp	Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/dump.lisp	Wed Jul 13 22:21:19 2016 +0000
@@ -11,10 +11,9 @@
                         "unbound variable "
                         (format nil "var pointer to ~8,'0X " r)))
       ((:structure s) (format nil "struct pointer to ~8,'0X " s))
-      ((:functor f) (destructuring-bind (functor . arity)
-                        (wam-functor-lookup wam f)
+      ((:functor f) (destructuring-bind (functor . arity) f
                       (format nil "~A/~D " functor arity)))
-      ((:constant c) (format nil "~A/0 " (wam-functor-symbol wam c)))
+      ((:constant c) (format nil "~A/0 " (car c)))
       (t ""))))
 
 
@@ -22,7 +21,7 @@
   ;; todo flesh this out
   (typecase value
     (fixnum (format nil "~16,'0X" value))
-    (t "~16{#<lisp object>~;~}")))
+    (t (format nil "~16<#<lisp object>~;~>"))))
 
 
 (defun dump-heap (wam from to)
@@ -44,7 +43,7 @@
           :do (progn
                 (print-cell address indent)
                 (cell-typecase (wam address)
-                  ((:functor f) (setf indent (wam-functor-arity wam f)))
+                  ((:functor f) (setf indent (cdr f)))
                   (t (when (not (zerop indent))
                        (decf indent)))))))
   (when (< to (wam-heap-pointer wam))
@@ -140,11 +139,9 @@
   (format t "  +----------+------------------+-------------------------------+~%"))
 
 
-(defun pretty-functor (functor-index functor-list)
-  (when functor-list
-    (destructuring-bind (symbol . arity)
-        (elt functor-list functor-index)
-      (format nil "~A/~D" symbol arity))))
+(defun pretty-functor (functor)
+  (destructuring-bind (symbol . arity) functor
+    (format nil "~A/~D" symbol arity)))
 
 (defun pretty-argument (argument)
   (typecase argument
@@ -155,115 +152,115 @@
   (format nil "~10<~{ ~A~}~;~>" (mapcar #'pretty-argument arguments)))
 
 
-(defgeneric instruction-details (opcode arguments functor-list))
+(defgeneric instruction-details (opcode arguments))
 
-(defmethod instruction-details ((opcode t) arguments functor-list)
+(defmethod instruction-details ((opcode t) arguments)
   (format nil "~A~A"
           (opcode-short-name opcode)
           (pretty-arguments arguments)))
 
 
-(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments)
   (format nil "GETS~A ; X~A = ~A"
           (pretty-arguments arguments)
           (second arguments)
-          (pretty-functor (first arguments) functor-list)))
+          (pretty-functor (first arguments))))
 
-(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments)
   (format nil "PUTS~A ; X~A <- new ~A"
           (pretty-arguments arguments)
           (second arguments)
-          (pretty-functor (first arguments) functor-list)))
+          (pretty-functor (first arguments))))
 
-(defmethod instruction-details ((opcode (eql +opcode-get-variable-local+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-variable-local+)) arguments)
   (format nil "GVAR~A ; X~A <- A~A"
           (pretty-arguments arguments)
           (first arguments)
           (second arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-get-variable-stack+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-variable-stack+)) arguments)
   (format nil "GVAR~A ; Y~A <- A~A"
           (pretty-arguments arguments)
           (first arguments)
           (second arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-get-value-local+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-value-local+)) arguments)
   (format nil "GVLU~A ; X~A = A~A"
           (pretty-arguments arguments)
           (first arguments)
           (second arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-get-value-stack+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-value-stack+)) arguments)
   (format nil "GVLU~A ; Y~A = A~A"
           (pretty-arguments arguments)
           (first arguments)
           (second arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-put-variable-local+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-variable-local+)) arguments)
   (format nil "PVAR~A ; X~A <- A~A <- new unbound REF"
           (pretty-arguments arguments)
           (first arguments)
           (second arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-put-variable-stack+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-variable-stack+)) arguments)
   (format nil "PVAR~A ; Y~A <- A~A <- new unbound REF"
           (pretty-arguments arguments)
           (first arguments)
           (second arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-put-value-local+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-value-local+)) arguments)
   (format nil "PVLU~A ; A~A <- X~A"
           (pretty-arguments arguments)
           (second arguments)
           (first arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-put-value-stack+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-value-stack+)) arguments)
   (format nil "PVLU~A ; A~A <- Y~A"
           (pretty-arguments arguments)
           (second arguments)
           (first arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments)
   (format nil "CALL~A ; call ~A"
           (pretty-arguments arguments)
           (first arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-jump+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-jump+)) arguments)
   (format nil "JUMP~A ; jump ~A"
           (pretty-arguments arguments)
           (first arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-dynamic-call+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-dynamic-call+)) arguments)
   (format nil "DYCL~A ; dynamic call"
           (pretty-arguments arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-dynamic-jump+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-dynamic-jump+)) arguments)
   (format nil "DYJP~A ; dynamic jump"
           (pretty-arguments arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-get-constant+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-constant+)) arguments)
   (format nil "GCON~A ; X~A = CONSTANT ~A"
           (pretty-arguments arguments)
           (second arguments)
-          (pretty-functor (first arguments) functor-list)))
+          (pretty-functor (first arguments))))
 
-(defmethod instruction-details ((opcode (eql +opcode-put-constant+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-constant+)) arguments)
   (format nil "PCON~A ; X~A <- CONSTANT ~A"
           (pretty-arguments arguments)
           (second arguments)
-          (pretty-functor (first arguments) functor-list)))
+          (pretty-functor (first arguments))))
 
-(defmethod instruction-details ((opcode (eql +opcode-subterm-constant+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-subterm-constant+)) arguments)
   (format nil "SCON~A ; SUBTERM CONSTANT ~A"
           (pretty-arguments arguments)
-          (pretty-functor (first arguments) functor-list)))
+          (pretty-functor (first arguments))))
 
-(defmethod instruction-details ((opcode (eql +opcode-get-list+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-list+)) arguments)
   (format nil "GLST~A ; X~A = [vvv | vvv]"
           (pretty-arguments arguments)
           (first arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-put-list+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-list+)) arguments)
   (format nil "PLST~A ; X~A = [vvv | vvv]"
           (pretty-arguments arguments)
           (first arguments)))
@@ -287,15 +284,14 @@
             (let ((lbl (gethash addr lbls))) ; forgive me
               (when lbl
                 (format t ";;;; BEGIN ~A~%"
-                        (pretty-functor lbl (wam-functors wam)))))
+                        (pretty-functor lbl))))
             (format t ";~A~4,'0X: "
                     (if (= (wam-program-counter wam) addr)
                       ">>"
                       "  ")
                     addr)
             (format t "~A~%" (instruction-details (aref instruction 0)
-                                                  (rest (coerce instruction 'list))
-                                                  (wam-functors wam)))))
+                                                  (rest (coerce instruction 'list))))))
         (incf addr (length instruction))))))
 
 (defun dump-code
@@ -335,12 +331,10 @@
 
 (defun dump-labels (wam)
   (format t "LABELS:~%~{  ~A -> ~4,'0X~^~%~}~%"
-          (loop :for functor-index
+          (loop :for functor
                 :being :the :hash-keys :of (wam-code-labels wam)
                 :using (hash-value address)
-                :nconc (list (pretty-functor functor-index
-                                             (wam-functors wam))
-                             address))))
+                :nconc (list (pretty-functor functor) address))))
 
 
 (defun dump-wam (wam from to)
diff -r 31305584b29b -r eec2064a08b6 src/wam/types.lisp
--- a/src/wam/types.lisp	Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/types.lisp	Wed Jul 13 22:21:19 2016 +0000
@@ -1,10 +1,13 @@
 (in-package #:bones.wam)
 
+; (deftype cell-type () ; todo: pick one of these...
+;   `(integer 0 ,(1- +number-of-cell-types+)))
+
 (deftype cell-type ()
-  `(integer 0 ,(1- +number-of-cell-types+)))
+  'fixnum)
 
 (deftype cell-value ()
-  `(unsigned-byte 60)); soon...
+  '(or fixnum t))
 
 
 (deftype type-store ()
@@ -29,15 +32,15 @@
 (deftype register-index ()
   `(integer 0 ,(1- +register-count+)))
 
-(deftype functor-index ()
-  `(integer 0 ,(1- +functor-limit+)))
 
+(deftype fname ()
+  'symbol)
 
 (deftype arity ()
   `(integer 0 ,+maximum-arity+))
 
 (deftype functor ()
-  '(cons symbol arity))
+  '(cons fname arity))
 
 
 (deftype code-index ()
diff -r 31305584b29b -r eec2064a08b6 src/wam/vm.lisp
--- a/src/wam/vm.lisp	Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/vm.lisp	Wed Jul 13 22:21:19 2016 +0000
@@ -34,28 +34,28 @@
   "
   (wam-heap-push! wam +cell-type-list+ (1+ (wam-heap-pointer wam))))
 
-(defun* push-new-functor! ((wam wam) (functor functor-index))
+(defun* push-new-functor! ((wam wam) (functor functor))
   (:returns heap-index)
   "Push a new functor cell onto the heap, returning its address."
   (wam-heap-push! wam +cell-type-functor+ functor))
 
-(defun* push-new-constant! ((wam wam) (constant functor-index))
+(defun* push-new-constant! ((wam wam) (constant functor))
   (:returns heap-index)
   "Push a new constant cell onto the heap, returning its address."
   (wam-heap-push! wam +cell-type-constant+ constant))
 
 
-(defun* functors-match-p ((f1 functor-index)
-                          (f2 functor-index))
+(defun* functors-match-p ((f1 functor)
+                          (f2 functor))
   (:returns boolean)
   "Return whether the two functor cell values represent the same functor."
-  (= f1 f2))
+  (eq f1 f2))
 
-(defun* constants-match-p ((c1 functor-index)
-                           (c2 functor-index))
+(defun* constants-match-p ((c1 functor)
+                           (c2 functor))
   (:returns boolean)
   "Return whether the two constant cells represent the same functor."
-  (= c1 c2))
+  (eq c1 c2))
 
 
 ;;;; "Ancillary" Functions
@@ -222,7 +222,7 @@
              (if (functors-match-p f1 f2)
                ;; If the functors match, push their pairs of arguments onto
                ;; the stack to be unified.
-               (loop :with arity = (wam-functor-arity wam f1)
+               (loop :with arity = (cdr f1)
                      :for i :from 1 :to arity :do
                      (wam-unification-stack-push! wam (+ s1 i))
                      (wam-unification-stack-push! wam (+ s2 i)))
@@ -324,7 +324,7 @@
 ;;;; Query Instructions
 (define-instruction (%put-structure)
     ((wam wam)
-     (functor functor-index)
+     (functor functor)
      (register register-index))
   (wam-set-local-register! wam register
                            +cell-type-structure+
@@ -358,7 +358,7 @@
 
 ;;;; Program Instructions
 (define-instruction (%get-structure) ((wam wam)
-                                      (functor functor-index)
+                                      (functor functor)
                                       (register register-index))
   (cell-typecase (wam (deref wam register) address)
     ;; If the register points at an unbound reference cell, we push two new
@@ -476,8 +476,7 @@
                           (functor functor)
                           (program-counter-increment instruction-size)
                           (is-tail boolean))
-  (let* ((findex (wam-ensure-functor-index wam functor)) ; todo unfuck this once we finish splitting
-         (target (wam-code-label wam findex)))
+  (let* ((target (wam-code-label wam functor)))
     (if (not target)
       ;; Trying to call an unknown procedure.
       (backtrack! wam)
@@ -486,7 +485,7 @@
           (setf (wam-continuation-pointer wam) ; CP <- next instruction
                 (+ (wam-program-counter wam) program-counter-increment)))
         (setf (wam-number-of-arguments wam) ; set NARGS
-              (wam-functor-arity wam findex)
+              (cdr functor)
 
               (wam-cut-pointer wam) ; set B0 in case we have a cut
               (wam-backtrack-pointer wam)
@@ -512,18 +511,19 @@
        ;; conveniently live contiguously right after the functor cell.
        (cell-typecase (wam functor-address)
          ((:functor f)
-          (load-arguments (wam-functor-arity wam f) (1+ functor-address))
-          (%go (wam-functor-lookup wam f)))))
-      ((:constant c)
-       ;; Zero-arity functors don't need to set up anything at all -- we can
-       ;; just call them immediately.
-       (%go (wam-functor-lookup wam c)))
-      (:reference
-       ;; It's okay to do (call :var), but :var has to be bound by the time you
-       ;; actually reach it at runtime.
-       (error "Cannot dynamically call an unbound variable."))
-      (t ; You can't call/1 anything else.
-       (error "Cannot dynamically call something other than a structure.")))))
+          (load-arguments (cdr f) (1+ functor-address))
+          (%go f))))
+
+      ;; Zero-arity functors don't need to set up anything at all -- we can
+      ;; just call them immediately.
+      ((:constant c) (%go c))
+
+      ;; It's okay to do (call :var), but :var has to be bound by the time you
+      ;; actually reach it at runtime.
+      (:reference (error "Cannot dynamically call an unbound variable."))
+
+      ; You can't call/1 anything else.
+      (t (error "Cannot dynamically call something other than a structure.")))))
 
 
 (define-instruction (%jump) ((wam wam) (functor functor))
@@ -645,7 +645,7 @@
 
 (defun* %%match-constant
     ((wam wam)
-     (constant functor-index)
+     (constant functor)
      (address store-index))
   (cell-typecase (wam (deref wam address) address)
     (:reference
@@ -653,7 +653,7 @@
      (trail! wam address))
 
     ((:constant c)
-     (when (not (= constant c))
+     (when (not (eq constant c))
        (backtrack! wam)))
 
     (t (backtrack! wam))))
@@ -661,7 +661,7 @@
 
 (define-instruction (%put-constant)
     ((wam wam)
-     (constant functor-index)
+     (constant functor)
      (register register-index))
   (wam-set-local-register! wam register +cell-type-constant+ constant)
   ; todo we can probably elide this because constants never have subterms...
@@ -669,13 +669,13 @@
 
 (define-instruction (%get-constant)
     ((wam wam)
-     (constant functor-index)
+     (constant functor)
      (register register-index))
   (%%match-constant wam constant register))
 
 (define-instruction (%subterm-constant)
     ((wam wam)
-     (constant functor-index))
+     (constant functor))
   (ecase (wam-mode wam)
     (:read (%%match-constant wam constant (wam-subterm wam)))
     (:write (push-new-constant! wam constant)))
@@ -722,10 +722,9 @@
              ((:reference r) (extract-var r))
              ((:structure s) (recur s))
              ((:list l) (cons (recur l) (recur (1+ l))))
-             ((:constant c) (wam-functor-symbol wam c))
+             ((:constant c) (car c))
              ((:functor f)
-              (destructuring-bind (functor . arity)
-                  (wam-functor-lookup wam f)
+              (destructuring-bind (functor . arity) f
                 (list* functor
                        (loop :repeat arity
                              :for subterm :from (+ address 1)
diff -r 31305584b29b -r eec2064a08b6 src/wam/wam.lisp
--- a/src/wam/wam.lisp	Wed Jul 13 18:33:09 2016 +0000
+++ b/src/wam/wam.lisp	Wed Jul 13 22:21:19 2016 +0000
@@ -130,8 +130,7 @@
 ;;; value is bound to.  Unbound variables contain their own store index as
 ;;; a value.
 ;;;
-;;; FUNCTOR cell values are an index into the WAM's functor array where the
-;;; `(symbol . arity)` cons lives.
+;;; FUNCTOR cell values are a pointer to a `(fname . arity)` cons.
 ;;;
 ;;; CONSTANT cells are the same as functor cells, except that they always happen
 ;;; to refer to functors with an arity of zero.
@@ -193,8 +192,8 @@
   (define-unsafe %unsafe-null-value (eql 0))
   (define-unsafe %unsafe-structure-value store-index)
   (define-unsafe %unsafe-reference-value store-index)
-  (define-unsafe %unsafe-functor-value store-index)
-  (define-unsafe %unsafe-constant-value store-index)
+  (define-unsafe %unsafe-functor-value functor)
+  (define-unsafe %unsafe-constant-value functor)
   (define-unsafe %unsafe-list-value store-index)
   (define-unsafe %unsafe-stack-value stack-word))
 
@@ -721,17 +720,16 @@
     :adjustable nil
     :element-type 'code-word))
 
-(defun* wam-code-label ((wam wam)
-                        (functor functor-index))
+(defun* wam-code-label ((wam wam) (functor functor))
   (:returns (or null code-index))
   (gethash functor (wam-code-labels wam)))
 
 (defun* (setf wam-code-label) ((new-value code-index)
                                (wam wam)
-                               (functor symbol)
+                               (functor fname)
                                (arity arity))
   ;; Note that this takes a functor/arity and not a cons.
-  (setf (gethash (wam-ensure-functor-index wam (cons functor arity))
+  (setf (gethash (wam-unique-functor wam (cons functor arity))
                  (wam-code-labels wam))
         new-value))
 
@@ -830,7 +828,7 @@
     "Cannot add clause ~S without an open logic stack frame."
     clause)
   (multiple-value-bind (functor arity) (find-predicate clause)
-    (let ((label (wam-ensure-functor-index wam (cons functor arity))))
+    (let ((label (wam-unique-functor wam (cons functor arity))))
       (assert-label-not-already-compiled wam clause label)
       (with-slots (predicates)
           (wam-current-logic-frame wam)
@@ -980,39 +978,19 @@
 
 
 ;;;; Functors
-;;; Functors are stored in an adjustable array.  Cells refer to a functor using
-;;; the functor's address in this array.
+;;; Functors are stored in an adjustable array to uniquify them... for now.
 
-(declaim (inline wam-functor-lookup
-                 wam-functor-symbol
-                 wam-functor-arity))
-
-
-(defun* wam-ensure-functor-index ((wam wam) (functor functor))
-  (:returns functor-index)
-  "Return the index of the functor in the WAM's functor table.
+(defun* wam-unique-functor ((wam wam) (functor functor))
+  (:returns functor)
+  "Return a unique version of the functor cons.
 
   If the functor is not already in the table it will be added.
 
   "
-  (let ((functors (wam-functors wam)))
-    (or (position functor functors :test #'equal)
-        (vector-push-extend functor functors))))
-
-(defun* wam-functor-lookup ((wam wam) (functor-index functor-index))
-  (:returns functor)
-  "Return the functor with the given index in the WAM."
-  (aref (wam-functors wam) functor-index))
-
-(defun* wam-functor-symbol ((wam wam) (functor-index functor-index))
-  (:returns symbol)
-  "Return the symbol of the functor with the given index in the WAM."
-  (car (wam-functor-lookup wam functor-index)))
-
-(defun* wam-functor-arity ((wam wam) (functor-index functor-index))
-  (:returns arity)
-  "Return the arity of the functor with the given index in the WAM."
-  (cdr (wam-functor-lookup wam functor-index)))
+  (or (find functor (wam-functors wam) :test #'equal)
+      (progn
+        (vector-push-extend functor (wam-functors wam))
+        functor)))
 
 
 ;;;; Unification Stack