;;;-*- Mode: Lisp; Package: CCL -*-
;;;
;;;   Copyright (C) 1994-2001 Digitool, Inc
;;;   This file is part of Opensourced MCL.
;;;
;;;   Opensourced MCL is free software; you can redistribute it and/or
;;;   modify it under the terms of the GNU Lesser General Public
;;;   License as published by the Free Software Foundation; either
;;;   version 2.1 of the License, or (at your option) any later version.
;;;
;;;   Opensourced MCL is distributed in the hope that it will be useful,
;;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;   Lesser General Public License for more details.
;;;
;;;   You should have received a copy of the GNU Lesser General Public
;;;   License along with this library; if not, write to the Free Software
;;;   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
;;;


(in-package :ccl)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "PPC-ARCH")
  (require "RISC-LAP")
  (require "DLL-NODE")
  (require "PPC-ASM")
  (require "SUBPRIMS"))

(defvar *ppc-lap-macros* (make-hash-table :test #'equalp))

(defun ppc-lap-macro-function (name)
  (gethash (string name) *ppc-lap-macros*))

(defun (setf ppc-lap-macro-function) (def name)
  (let* ((s (string name)))
    (when (gethash s ppc::*ppc-opcode-numbers*)
      (error "~s already defines a PowerPC instruction . " name))
    (when (ppc::ppc-macro-function s)

      (error "~s already defines a PowerPC macro instruction . " name))
    (setf (gethash s *ppc-lap-macros*) def)))

(defmacro defppclapmacro (name arglist &body body)
  `(progn
     (setf (ppc-lap-macro-function ',name)
           (nfunction (ppc-lap-macro ,name) ,(parse-macro name arglist body)))
     (record-source-file ',name 'ppc-lap)
     ',name))

(defvar *ppc-lap-constants* ())
(defvar *ppc-lap-regsave-reg* ())
(defvar *ppc-lap-regsave-addr* ())
(defvar *ppc-lap-regsave-label* ())
(defparameter *ppc-lwz-instruction* (svref ppc::*ppc-opcodes* (gethash "LWZ" ppc::*ppc-opcode-numbers*)))






(defun ppc-lap-macroexpand-1 (form)
  (unless (and (consp form) (atom (car form)))
    (values form nil))
  (let* ((expander (ppc-lap-macro-function (car form))))
    (if expander
      (values (funcall expander form nil) t)
      (values form nil))))



(defun ppc-lap-encode-regsave-info (maxpc)
  (declare (fixnum maxpc))
  (if *ppc-lap-regsave-label*
    (let* ((regsave-pc (ash (the fixnum (lap-label-address *ppc-lap-regsave-label*)) -2)))
      (declare (fixnum regsave-pc))
      (if (< regsave-pc #x80)
        (let* ((instr (ppc-emit-lap-instruction *ppc-lwz-instruction*
                                                (list *ppc-lap-regsave-reg*
                                                      (dpb (ldb (byte 2 5) regsave-pc) 
                                                           (byte 2 0) 
                                                           *ppc-lap-regsave-addr*)
                                                      (ldb (byte 5 0) regsave-pc)))))
          (setf (lap-instruction-address instr) maxpc)
          (incf maxpc 4))
        (warn "Can't encode register save information."))))
  maxpc)

(defun %define-ppc-lap-function (name body &optional (bits 0))
  (with-dll-node-freelist (*lap-instructions* *lap-instruction-freelist*)
      (let* ((*lap-labels* ())
             (*ppc-lap-regsave-label* ())
             (*ppc-lap-regsave-reg* ())
             (*ppc-lap-regsave-addr* ())
             (*ppc-lap-constants* ()))
        (dolist (form body)
          (ppc-lap-form form))
        #+ppc-lap-scheduler (ppc-schedule-instuctions)       ; before resolving branch targets
        (ppc-lap-generate-code name (ppc-lap-encode-regsave-info (ppc-lap-do-labels)) bits))))

; Any conditional branch that the compiler generates is currently just of the form
; BT or BF, but it'd be nice to recognize all of the other extended branch mnemonics
; as well.
; A conditional branch is "conditional" if bit 2 of the BO field is set.
(defun ppc-lap-conditional-branch-p (insn)
  (let* ((opcode (lap-instruction-opcode insn)))
    (if (= (the fixnum (arch::opcode-majorop opcode)) 16)    ; it's a BC instruction ...
      (unless (logbitp 1 (the fixnum (arch::opcode-op-low opcode)))          ; not absolute
        (let* ((bo-field (if (= #xf (ldb (byte 4 6) (the fixnum (arch::opcode-mask-high opcode))))
                           (ldb (byte 5 5) (the fixnum (arch::opcode-op-high opcode)))
                           (svref (lap-instruction-parsed-operands insn) 0))))
          (declare (fixnum bo-field))
          (if (logbitp 2 bo-field)
            bo-field))))))

; Turn an instruction that's of the form 
;   (bc[l] bo bi label) 
; into the sequence
;   (bc (invert bo) bi @new)
;   (b[l] label)
; @new
; Do do only if the instruction's a conditional branch
; and the label is more than 16 bits away from the instruction.
; Return true if we do this, false otherwise.
(defun ppc-lap-invert-conditional-branch (insn label)
  (if (ppc-lap-conditional-branch-p insn)      
    (let* ((diff (- (lap-label-address label) (lap-instruction-address insn))))
      (declare (fixnum diff))
      (if (or (< diff #x-8000) (> diff #x7ffc))
        ; Too far away, will have to invert.
        ; It's necessary to "partially assemble" the BC instruction in order to 
        ; get explicit values for the BO and BI fields of the instruction.
        (let* ((original-opcode (lap-instruction-opcode insn))
               (vals (lap-instruction-parsed-operands insn))
               (high (arch::opcode-op-high original-opcode))
               (low (arch::opcode-op-low original-opcode))
               (link-p (logbitp 0 low))
               (new-label (make-lap-label (gensym)))
               (idx -1))
          (declare (fixnum high low))
          ; Assemble all operands but the last
          (do* ((ops (arch::opcode-operands original-opcode) next)
                (next (cdr ops) (cdr next)))
               ((null next))
            (declare (list ops next))
            (let* ((operand (car ops))
                   (val (if (logbitp arch::operand-fake (arch::operand-flags operand))
                    0
                    (svref vals (incf idx))))
                   (insert-function (arch::operand-insert-function operand)))
              (setq high (if insert-function
                           (funcall insert-function high low val)
                           (ppc::insert-default operand high low val)))))
          ; "high" now contains the major opcode, BO, and BI fields of the original branch instruction.
          ; Generate a (BC (invert BO) BI new-label) instruction, and insert it before the original instruction.
          (let* ((bc-opcode (svref ppc::*ppc-opcodes* (gethash "BC" ppc::*ppc-opcode-numbers*)))
                 (bo (logxor #b1000 (the fixnum (ldb (byte 5 5) high))))
                 (bi (ldb (byte 5 0) high))
                 (new-instruction (make-lap-instruction bc-opcode))
                 (opvect (alloc-lap-operand-vector)))
            (setf (lap-instruction-parsed-operands new-instruction) opvect
                  (svref opvect 0) bo
                  (svref opvect 1) bi
                  (svref opvect 2) new-label)
            (push new-instruction (lap-label-refs new-label))
            (insert-dll-node-after new-instruction (dll-node-pred insn))
            (insert-dll-node-after new-label insn))
          ; Now, change INSN's opcode to B or BL, and make sure that it
          ; references nothing but the old label.
          (let* ((long-branch (svref ppc::*ppc-opcodes* (gethash (if link-p "BL" "B") ppc::*ppc-opcode-numbers*)))
                 (opvect (alloc-lap-operand-vector)))
            (setf (svref opvect 0) label
                  (lap-instruction-opcode insn) long-branch
                  (lap-instruction-parsed-operands insn) opvect)
            ; We're finally done.  Return t.
            t))))))
            

; Build & return list of all labels that are targets of conditional branches.
(defun ppc-lap-conditional-branch-targets ()
  (let* ((branch-target-labels ()))
    (dolist (lab *lap-labels* branch-target-labels)
      (dolist (insn (lap-label-refs lab))
        (when (ppc-lap-conditional-branch-p insn)
          (push lab branch-target-labels))))))

(defun ppc-lap-assign-addresses (delete-labels-p)
  (let* ((pc 0))
    (declare (fixnum pc))
    (do-dll-nodes (node *lap-instructions*)
      (setf (instruction-element-address node) pc)
      (if (typep node 'lap-label)
        (if delete-labels-p (remove-dll-node node))
        (incf pc 4)))
    (if (>= pc (ash 1 20)) (compiler-function-overflow))
    pc))

; The function's big enough that we might have generated conditional
; branches that are too far away from their targets.  Find the set
; of all labels that are the target of conditional branches, then
; repeatedly assign (tentative) addresses to all instructions and
; labels and iterate over the set of conditional branch targets,
; "lengthening" any condtional branches that are too far away from
; the target label.  Since lengthening a branch instruction can
; cause a spanning branch to become a candidate for lengthening, we
; have to repeat the process until all labels are the targets of
; valid (short enough or unconditional) branch instructions.
(defun ppc-lap-remove-long-branches ()
  (let* ((branch-target-labels (ppc-lap-conditional-branch-targets)))
    (do* ((done nil))
         (done (ppc-lap-assign-addresses t))
      (setq done t)
      (ppc-lap-assign-addresses nil)
      (dolist (lab branch-target-labels)
        (dolist (insn (lap-label-refs lab))
          (when (ppc-lap-invert-conditional-branch insn lab)
            (setq done nil)))))))

(defun ppc-lap-do-labels ()
  (dolist (lab *lap-labels*)
    (if (and (lap-label-refs lab) (not (lap-label-emitted-p lab)))
      (error "Label ~S was referenced but never defined. " 
             (lap-label-name lab)))
    ; Repeatedly iterate through label's refs, until none of them is the preceding
    ; instruction.  This eliminates
    ; (b @next)
    ;@next
    ;
    ; but can probably be fooled by hairier nonsense.
    (loop
      (when (dolist (ref (lap-label-refs lab) t)
              (when (eq lab (lap-instruction-succ ref))
                (remove-dll-node ref)
                (setf (lap-label-refs lab) (delete ref (lap-label-refs lab)))
                (return)))
        (return))))
  ; Assign pc to emitted labels, splice them out of the list.
  
  (if (> (the fixnum (dll-header-length *lap-instructions*)) 8191)
    ; -Might- have some conditional branches that are too long.
    ; Definitely don't  otherwise, so only bother to check in this case
    (ppc-lap-remove-long-branches)
    (ppc-lap-assign-addresses t)))

; Replace each label with the difference between the label's address
; and the referencing instruction's address.
(defun ppc-lap-resolve-labels ()
  (dolist (label *lap-labels*)
    (let* ((label-address (lap-label-address label)))
      (declare (fixnum label-address))          ; had BETTER be ...
      (dolist (insn (lap-label-refs label))
        (let* ((diff (- label-address (lap-instruction-address insn))))
          (declare (fixnum diff))
#| Can't happen anymore.
          (if (or (< diff #x-8000) (> diff #x7ffc))
            (warn "PC-relative displacement too large; write smaller functions ~
                   or smarter LAP."))
|#
          (let* ((opvals (lap-instruction-parsed-operands insn))
                 (pos (position label opvals)))
            (unless pos
              (error "Bug: label ~s should be referenced by instruction ~s, but isn't."))
            (setf (svref opvals pos) diff)))))))

(defun ppc-lap-generate-instruction (code-vector index insn)
  (let* ((op (lap-instruction-opcode insn))
         (vals (lap-instruction-parsed-operands insn))
         (high (arch::opcode-op-high op))
         (low (arch::opcode-op-low op))
         (idx -1))
    (dolist (operand (arch::opcode-operands op))
      (let* ((val (if (logbitp arch::operand-fake (arch::operand-flags operand))
                    0
                    (svref vals (incf idx))))
             (insert-function (arch::operand-insert-function operand)))
        (multiple-value-setq (high low)
          (if insert-function
            (funcall insert-function high low val)
            (ppc::insert-default operand high low val)))
        (if (null high)
          (error "Invalid operand for ~s instruction: ~d" (arch::opcode-name op) val))))
    (setf (lap-instruction-parsed-operands insn) nil)
    (free-lap-operand-vector vals)
    (locally (declare (type (simple-array (unsigned-byte 16) (*)) code-vector)
                      (optimize (speed 3) (safety 0)))
      (setf (aref code-vector (+ index index)) high
            (aref code-vector (+ index index 1)) low)
     nil)))


  
(defun ppc-lap-generate-code (name maxpc bits)
  (declare (fixnum maxpc))
  (let* ((cross-compiling (not (eq *host-backend* *target-backend*)))
	 (code-vector (%alloc-misc (ash maxpc -2)
				   (if cross-compiling
				     arch::subtag-xcode-vector
				     arch::subtag-code-vector)))
         (constants-size (+ 3 (length *ppc-lap-constants*)))
         (constants-vector (%alloc-misc
                            constants-size
			    (if cross-compiling
			      arch::subtag-xfunction
			      arch::subtag-function)))
         (i 0))
    (declare (fixnum i constants-size))
    (ppc-lap-resolve-labels)            ; all operands fully evaluated now.
    (do-dll-nodes (insn *lap-instructions*)
      (ppc-lap-generate-instruction code-vector i insn)
      (incf i))
    (dolist (immpair *ppc-lap-constants*)
      (let* ((imm (car immpair))
             (k (cdr immpair)))
        (declare (fixnum k))
        (setf (uvref constants-vector (ash (- k arch::misc-data-offset) -2))
              imm)))
    (setf (uvref constants-vector (1- constants-size)) bits       ; lfun-bits
          (uvref constants-vector (- constants-size 2)) name
          (uvref constants-vector 0) code-vector)
    #+ppc-target (%make-code-executable code-vector)
    constants-vector))

(defun ppc-lap-pseudo-op (form)
  (case (car form)
    (:regsave
     (if *ppc-lap-regsave-label*
       (warn "Duplicate :regsave form not handled (yet ?) : ~s" form)
       (destructuring-bind (reg addr) (cdr form)
         (let* ((regno (ppc-register-name-or-expression reg)))
           (if (not (<= ppc::save7 regno ppc::save0))
             (warn "Not a save register: ~s.  ~s ignored." reg form)
             (let* ((addrexp (ppc-register-name-or-expression addr)))   ; parses 'fixnum
               (if (not (and (typep addrexp 'fixnum)
                             (<= 0 addrexp #x7ffc)      ; not really right
                             (not (logtest 3 addrexp))))
                 (warn "Invalid logical VSP: ~s.  ~s ignored." addr form)
                 (setq *ppc-lap-regsave-label* (emit-lap-label (gensym))
                       *ppc-lap-regsave-reg* regno
                       *ppc-lap-regsave-addr* (- (+ addrexp)
                                                 (* 4 (1+ (- ppc::save0 regno))))))))))))))

       
(defun ppc-lap-form (form)
  (if (and form (symbolp form))
    (emit-lap-label form)
    (if (or (atom form) (not (symbolp (car form))))
      (error "~& unknown PPC-LAP form: ~S ." form)
      (multiple-value-bind (expansion expanded)
                           (ppc-lap-macroexpand-1 form)
        (if expanded
          (ppc-lap-form expansion)
          (let* ((name (car form)))
            (if (keywordp name)
              (ppc-lap-pseudo-op form)
              (case name
                ((progn) (dolist (f (cdr form)) (ppc-lap-form f)))
                ((let) (ppc-lap-equate-form (cadr form) (cddr form)))
                (t
                 ; instruction macros expand into instruction forms
                 ; (with some operands reordered/defaulted.)
                 (let* ((expander (ppc::ppc-macro-function name)))
                   (if expander
                     (ppc-lap-form (funcall expander form nil))
                     (ppc-lap-instruction name (cdr form)))))))))))))

;;; (let ((name val) ...) &body body)
;;; each "val" gets a chance to be treated as a PPC register name
;;; before being evaluated.
(defun ppc-lap-equate-form (eqlist body) 
  (let* ((symbols (mapcar #'(lambda (x)
                              (let* ((name (car x)))
                                (or
                                 (and name 
                                      (symbolp name)
                                      (not (constant-symbol-p name))
                                      name)
                                 (error 
                                  "~S is not a bindable symbol name ." name))))
                          eqlist))
         (values (mapcar #'(lambda (x) (or (ppc-vr-name-p (cadr x))
					   (ppc-fpr-name-p (cadr x))
					   (ppc-register-name-or-expression
					    (cadr x))))
                         eqlist)))
    (progv symbols values
                   (dolist (form body)
                     (ppc-lap-form form)))))

(defun ppc-lap-constant-offset (x)
  (or (cdr (assoc x *ppc-lap-constants* :test #'equal))
      (let* ((n (+ arch::misc-data-offset (ash (1+ (length *ppc-lap-constants*)) 2))))
        (push (cons x n) *ppc-lap-constants*)
        n)))

; Evaluate an arbitrary expression; warn if the result isn't a fixnum.
(defun ppc-lap-evaluated-expression (x)
  (if (typep x 'fixnum)
    x
    (let* ((val (handler-case (eval x)          ; Look! Expression evaluation!
                  (error (condition) (error "~&Evaluation of ~S signalled assembly-time error ~& ~A ."
                                            x condition)))))
      (unless (typep val 'fixnum)
        (warn "assembly-time evaluation of ~S returned ~S, which may not have been intended ."
              x val))
      val)))

(defparameter *ppc-lap-register-aliases*
  `((nfn . ,ppc::nfn)
    (fname . ,ppc::fname)))

(defparameter *ppc-lap-fp-register-aliases*
  ())

(defparameter *ppc-lap-vector-register-aliases*
  ())

(defun ppc-gpr-name-p (x)
  (and (or (symbolp x) (stringp x))
           (or
            (position (string x) ppc::*gpr-register-names* :test #'string-equal)
            (cdr (assoc x *ppc-lap-register-aliases* :test #'string-equal)))))

(defun ppc-register-name-or-expression (x)
  (or (ppc-gpr-name-p x)
      (if (and (consp x) (eq (car x) 'quote))
        (let* ((quoted-form (cadr x)))
          (if (typep quoted-form 'fixnum)
            (ash quoted-form arch::fixnumshift)
            (ppc-lap-constant-offset quoted-form)))
        (ppc-lap-evaluated-expression x))))

(defun ppc-fpr-name-p (x)
  (and (or (symbolp x) (stringp x))
                   (or
                    (position (string x) ppc::*fpr-register-names* :test #'string-equal)
                    (cdr (assoc x *ppc-lap-fp-register-aliases* :test #'string-equal)))))

(defun ppc-fp-register-name-or-expression (x)
  (or (ppc-fpr-name-p x)
      (ppc-lap-evaluated-expression x)))

(defun ppc-vr-name-p (x)
  (and (or (symbolp x) (stringp x))
	     (or
	      (position (string x) ppc::*vector-register-names* :test #'string-equal)
	      (cdr (assoc x *ppc-lap-vector-register-aliases* :test #'string-equal)))))

(defun ppc-vector-register-name-or-expression (x)
  (or (ppc-vr-name-p x)
      (ppc-lap-evaluated-expression x)))

(defun ppc-vr (r)
  (svref ppc::*vector-register-names* r))


(defparameter *ppc-cr-field-names* #(:crf0 :crf1 :crf2 :crf3 :crf4 :crf5 :crf6 :crf7))
(defparameter *ppc-cr-names* #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7))
(defparameter *ppc-cc-bit-names* #(:lt :gt :eq :so :un))
(defparameter *ppc-cc-bit-inverse-names* #(:ge :le :ne :ns :nu))

; This wants a :CC, a negated :CC, or either (:CRn :CC) or (:CRn :~CC).
; Returns the fully-qualified CR bit and an indication of whether or not the CC was 
; negated.
(defun ppc-lap-parse-test (x)
  (if (or (symbolp x) (stringp x))
    (let* ((pos (position x *ppc-cc-bit-names* :test #'string-equal)))
      (if pos
        (values (min pos 3) nil)
        (if (setq pos (position x *ppc-cc-bit-inverse-names* :test #'string-equal))
          (values (min pos 3) t)
          (error "Unknown PPC lap condition form : ~s" x))))
    (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x)))
      (let* ((field (position (car x) *ppc-cr-names*)))
        (unless field (error "Unknown CR field name : ~s" (car x)))
        (let* ((bit (position (cadr x) *ppc-cc-bit-names*)))
          (if bit 
            (values (logior (ash field 2) (min bit 3)) nil)
            (if (setq bit (position (cadr x) *ppc-cc-bit-inverse-names*))
              (values (logior (ash field 2) (min bit 3)) t)
              (error "Unknown condition name : ~s" (cadr x))))))
      (error "Unknown PPC lap condition form : ~s" x))))

; Accept either :CRn, :CC,  or (:CRFn :CC), or evaluate an expression.
(defun ppc-lap-cr-field-expression (x)
  (if (or (symbolp x) (stringp x))
    (let* ((pos (position x *ppc-cr-names* :test #'string-equal)))
      (if pos 
        (ash pos 2)
        (let* ((cc-pos (position x *ppc-cc-bit-names* :test #'string-equal)))
          (if cc-pos 
            (min cc-pos 3)
            (error "Unknown CR field name: ~s" x)))))
    (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x)))
      (let* ((field (position (car x) *ppc-cr-field-names*))
             (bit (position (cadr x) *ppc-cc-bit-names*)))
        (if (and field bit)
          (logior (min bit 3) (ash field 2))
          (error "Bad ppc-cr-field-expression: ~s" x)))
      (ppc-lap-evaluated-expression x))))
  
(defun ppc-lap-instruction (name opvals)
  (let* ((opnum (gethash (string name) ppc::*ppc-opcode-numbers*))
         (opcode (and opnum 
                          (< -1 opnum (length ppc::*ppc-opcodes*))
                          (svref ppc::*ppc-opcodes* opnum))))
    (unless opcode
          (error "Unknown PPC opcode: ~a" name))
    ;; Unless either
    ;;  a) The number of operand values in the macro call exactly
    ;;      matches the number of operands accepted by the instruction or
    ;;  b) The number of operand values is one less, and the instuction
    ;;     takes an optional operand
    ;;  we've got a wrong-number-of-args error.
    ;;  In case (b), there's at most one optional argument per instruction;
    ;;   provide 0 for the missing value.
    (let* ((operands (arch::opcode-operands opcode))
           (nmin (arch::opcode-min-args opcode))
           (nmax (arch::opcode-max-args opcode))
           (nhave (length opvals)))
      (declare (fixnum nmin nmax nhave))
      (if (= nhave nmax)
        (ppc-emit-lap-instruction opcode opvals)
        (if (> nhave nmax)
          (error "Too many operands in ~s (~a accepts at most ~d)"
                 opvals name nmax)
          (if (= nhave nmin)
            (let* ((newops ()))
              (dolist (op operands (ppc-emit-lap-instruction opcode (nreverse newops)))
                (let* ((flags (arch::operand-flags op)))
                  (unless (logbitp arch::operand-fake flags)
                    (push (if (logbitp arch::operand-optional flags)
                            0
                            (pop opvals))
                          newops)))))
            (error "Too few operands in ~s : (~a requires at least ~d)"
                   opvals name nmin)))))))

; This is pretty rudimentary: if the operand has the "ppc::$ppc-operand-relative" bit
; set, we demand a label name and note the fact that we reference the label in question.
; Otherwise, we use the "register-name-or-expression" thing.
; Like most PPC assemblers, this lets you treat everything as an expression, even if
; you've got the order of some arguments wrong ...

(defun ppc-parse-lap-operand (opvalx operand insn)
  (let* ((flags (arch::operand-flags operand)))
    (declare (fixnum flags))
    (if (logbitp ppc::$ppc-operand-relative flags)
      (lap-note-label-reference opvalx insn)
      (if (logbitp ppc::$ppc-operand-cr flags)
        (ppc-lap-cr-field-expression opvalx)
        (if (logbitp ppc::$ppc-operand-absolute flags)
          (ppc-subprimitive-address opvalx)
          (if (logbitp ppc::$ppc-operand-fpr flags)
            (ppc-fp-register-name-or-expression opvalx)
	    (if (logbitp ppc::$ppc-operand-vr flags) ; SVS
	      (ppc-vector-register-name-or-expression opvalx)
	      (ppc-register-name-or-expression opvalx))))))))

(defun ppc-subprimitive-address (x)
  (if (and x (or (symbolp x) (stringp x)))
    (let* ((info (find x *subprims* :test #'string-equal :key #'subprimitive-info-name)))
      (when info (return-from ppc-subprimitive-address
                   (subprimitive-info-offset info)))))
  (ppc-lap-evaluated-expression x))


; We've checked that the number of operand values match the number expected
; (and have set "fake" operand values to 0.)
; Labels - and some constructs that might someday do arithmetic on them -
; are about the only class of forward references we need to deal with.  This whole
; two-pass scheme seems overly general, but if/when we ever do instruction scheduling
; it'll probably make it simpler.
(defun ppc-emit-lap-instruction (opcode opvals)
  (let* ((operands (arch::opcode-operands opcode))
         (parsed-values (alloc-lap-operand-vector))
         (insn (make-lap-instruction opcode))
         (idx -1))
    (declare (fixnum idx))
    (dolist (op operands)
      (let* ((flags (arch::operand-flags op))
             (val (if (logbitp arch::operand-fake flags)
                    0
                    (ppc-parse-lap-operand (pop opvals) op insn))))
        (declare (fixnum flags))
        (setf (svref parsed-values (incf idx)) val)))
    (setf (lap-instruction-parsed-operands insn) parsed-values)
    (append-dll-node insn *lap-instructions*)))



(defmacro defppclapfunction (&environment env name arglist &body body)
  `(progn
     (eval-when (:compile-toplevel)
       (note-function-info ',name t ,env))
     #-ppc-target
     (progn
       (eval-when (:load-toplevel)
         (%defun (nfunction ,name (lambda (&lap 0) (ppc-lap-function ,name ,arglist ,@body)))))    
       (eval-when (:execute)
         (%define-ppc-lap-function ',name '((let ,arglist ,@body)))))
     #+ppc-target	; just shorthand for defun
     (%defun (nfunction ,name (lambda (&lap 0) (ppc-lap-function ,name ,arglist ,@body))))))
 


(provide "PPC-LAP")
