| 1 | ;;;-*- Mode: Lisp; Package: CCL -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; Copyright (C) 1994-2001 Digitool, Inc
|
|---|
| 4 | ;;; This file is part of OpenMCL.
|
|---|
| 5 | ;;;
|
|---|
| 6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
|
|---|
| 7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the
|
|---|
| 8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL,
|
|---|
| 9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these
|
|---|
| 10 | ;;; conflict, the preamble takes precedence.
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY."
|
|---|
| 13 | ;;;
|
|---|
| 14 | ;;; The LLGPL is also available online at
|
|---|
| 15 | ;;; http://opensource.franz.com/preamble.html
|
|---|
| 16 |
|
|---|
| 17 |
|
|---|
| 18 | (in-package "CCL")
|
|---|
| 19 |
|
|---|
| 20 | (eval-when (:compile-toplevel :load-toplevel :execute)
|
|---|
| 21 | (require "PPC32-ARCH")
|
|---|
| 22 | (require "PPC64-ARCH")
|
|---|
| 23 | (require "RISC-LAP")
|
|---|
| 24 | (require "DLL-NODE")
|
|---|
| 25 | (require "PPC-ASM")
|
|---|
| 26 | (require "SUBPRIMS"))
|
|---|
| 27 |
|
|---|
| 28 |
|
|---|
| 29 | (defun ppc-lap-macro-function (name)
|
|---|
| 30 | (gethash (string name) (backend-lap-macros *ppc-backend*)))
|
|---|
| 31 |
|
|---|
| 32 | (defun (setf ppc-lap-macro-function) (def name)
|
|---|
| 33 | (let* ((s (string name)))
|
|---|
| 34 | (when (gethash s ppc::*ppc-opcode-numbers*)
|
|---|
| 35 | (error "~s already defines a PowerPC instruction . " name))
|
|---|
| 36 | (when (ppc::ppc-macro-function s)
|
|---|
| 37 | (error "~s already defines a PowerPC macro instruction . " name))
|
|---|
| 38 | (setf (gethash s (backend-lap-macros *ppc-backend*)) def)))
|
|---|
| 39 |
|
|---|
| 40 | (defmacro defppclapmacro (name arglist &body body)
|
|---|
| 41 | `(progn
|
|---|
| 42 | (setf (ppc-lap-macro-function ',name)
|
|---|
| 43 | (nfunction (ppc-lap-macro ,name) ,(parse-macro name arglist body)))
|
|---|
| 44 | (record-source-file ',name 'ppc-lap)
|
|---|
| 45 | ',name))
|
|---|
| 46 |
|
|---|
| 47 | (defvar *ppc-lap-constants* ())
|
|---|
| 48 | (defvar *ppc-lap-regsave-reg* ())
|
|---|
| 49 | (defvar *ppc-lap-regsave-addr* ())
|
|---|
| 50 | (defvar *ppc-lap-regsave-label* ())
|
|---|
| 51 | (defparameter *ppc-lwz-instruction* (svref ppc::*ppc-opcodes* (gethash "LWZ" ppc::*ppc-opcode-numbers*)))
|
|---|
| 52 | (defvar *ppc-lap-lfun-bits* 0)
|
|---|
| 53 |
|
|---|
| 54 |
|
|---|
| 55 |
|
|---|
| 56 |
|
|---|
| 57 |
|
|---|
| 58 | (defun ppc-lap-macroexpand-1 (form)
|
|---|
| 59 | (unless (and (consp form) (atom (car form)))
|
|---|
| 60 | (values form nil))
|
|---|
| 61 | (let* ((expander (ppc-lap-macro-function (car form))))
|
|---|
| 62 | (if expander
|
|---|
| 63 | (values (funcall expander form nil) t)
|
|---|
| 64 | (values form nil))))
|
|---|
| 65 |
|
|---|
| 66 |
|
|---|
| 67 |
|
|---|
| 68 | (defun ppc-lap-encode-regsave-info (maxpc)
|
|---|
| 69 | (declare (fixnum maxpc))
|
|---|
| 70 | (if *ppc-lap-regsave-label*
|
|---|
| 71 | (let* ((regsave-pc (ash (the fixnum (lap-label-address *ppc-lap-regsave-label*)) -2)))
|
|---|
| 72 | (declare (fixnum regsave-pc))
|
|---|
| 73 | (if (< regsave-pc #x80)
|
|---|
| 74 | (let* ((instr (ppc-emit-lap-instruction *ppc-lwz-instruction*
|
|---|
| 75 | (list *ppc-lap-regsave-reg*
|
|---|
| 76 | (dpb (ldb (byte 2 5) regsave-pc)
|
|---|
| 77 | (byte 2 0)
|
|---|
| 78 | *ppc-lap-regsave-addr*)
|
|---|
| 79 | (ldb (byte 5 0) regsave-pc)))))
|
|---|
| 80 | (setf (lap-instruction-address instr) maxpc)
|
|---|
| 81 | (incf maxpc 4))
|
|---|
| 82 | (warn "Can't encode register save information."))))
|
|---|
| 83 | maxpc)
|
|---|
| 84 |
|
|---|
| 85 | (defun %define-ppc-lap-function (name body &optional (bits 0))
|
|---|
| 86 | (with-dll-node-freelist (*lap-instructions* *lap-instruction-freelist*)
|
|---|
| 87 | (let* ((*lap-labels* ())
|
|---|
| 88 | (*ppc-lap-regsave-label* ())
|
|---|
| 89 | (*ppc-lap-regsave-reg* ())
|
|---|
| 90 | (*ppc-lap-regsave-addr* ())
|
|---|
| 91 | (*ppc-lap-constants* ())
|
|---|
| 92 | (*ppc-lap-lfun-bits* bits))
|
|---|
| 93 | (dolist (form body)
|
|---|
| 94 | (ppc-lap-form form))
|
|---|
| 95 | #+ppc-lap-scheduler (ppc-schedule-instuctions) ; before resolving branch targets
|
|---|
| 96 | (ppc-lap-generate-code name (ppc-lap-encode-regsave-info (ppc-lap-do-labels)) *ppc-lap-lfun-bits*))))
|
|---|
| 97 |
|
|---|
| 98 | ;;; Any conditional branch that the compiler generates is currently just of the form
|
|---|
| 99 | ;;; BT or BF, but it'd be nice to recognize all of the other extended branch mnemonics
|
|---|
| 100 | ;;; as well.
|
|---|
| 101 | ;;; A conditional branch is "conditional" if bit 2 of the BO field is set.
|
|---|
| 102 | (defun ppc-lap-conditional-branch-p (insn)
|
|---|
| 103 | (let* ((opcode (lap-instruction-opcode insn)))
|
|---|
| 104 | (if (= (the fixnum (opcode-majorop opcode)) 16) ; it's a BC instruction ...
|
|---|
| 105 | (unless (logbitp 1 (the fixnum (opcode-op-low opcode))) ; not absolute
|
|---|
| 106 | (let* ((bo-field (if (= #xf (ldb (byte 4 6) (the fixnum (opcode-mask-high opcode))))
|
|---|
| 107 | (ldb (byte 5 5) (the fixnum (opcode-op-high opcode)))
|
|---|
| 108 | (svref (lap-instruction-parsed-operands insn) 0))))
|
|---|
| 109 | (declare (fixnum bo-field))
|
|---|
| 110 | (if (logbitp 2 bo-field)
|
|---|
| 111 | bo-field))))))
|
|---|
| 112 |
|
|---|
| 113 | ;;; Turn an instruction that's of the form
|
|---|
| 114 | ;;; (bc[l] bo bi label)
|
|---|
| 115 | ;;; into the sequence
|
|---|
| 116 | ;;; (bc (invert bo) bi @new)
|
|---|
| 117 | ;;; (b[l] label)
|
|---|
| 118 | ;;; @new
|
|---|
| 119 | ;;; Do so only if the instruction's a conditional branch
|
|---|
| 120 | ;;; and the label is more than 16 bits away from the instruction.
|
|---|
| 121 | ;;; Return true if we do this, false otherwise.
|
|---|
| 122 | (defun ppc-lap-invert-conditional-branch (insn label)
|
|---|
| 123 | (if (ppc-lap-conditional-branch-p insn)
|
|---|
| 124 | (let* ((diff (- (lap-label-address label) (lap-instruction-address insn))))
|
|---|
| 125 | (declare (fixnum diff))
|
|---|
| 126 | (if (or (< diff #x-8000) (> diff #x7ffc))
|
|---|
| 127 | ; Too far away, will have to invert.
|
|---|
| 128 | ; It's necessary to "partially assemble" the BC instruction in order to
|
|---|
| 129 | ; get explicit values for the BO and BI fields of the instruction.
|
|---|
| 130 | (let* ((original-opcode (lap-instruction-opcode insn))
|
|---|
| 131 | (vals (lap-instruction-parsed-operands insn))
|
|---|
| 132 | (high (opcode-op-high original-opcode))
|
|---|
| 133 | (low (opcode-op-low original-opcode))
|
|---|
| 134 | (link-p (logbitp 0 low))
|
|---|
| 135 | (new-label (make-lap-label (gensym)))
|
|---|
| 136 | (idx -1))
|
|---|
| 137 | (declare (fixnum high low))
|
|---|
| 138 | ; Assemble all operands but the last
|
|---|
| 139 | (do* ((ops (opcode-operands original-opcode) next)
|
|---|
| 140 | (next (cdr ops) (cdr next)))
|
|---|
| 141 | ((null next))
|
|---|
| 142 | (declare (list ops next))
|
|---|
| 143 | (let* ((operand (car ops))
|
|---|
| 144 | (val (if (logbitp operand-fake (operand-flags operand))
|
|---|
| 145 | 0
|
|---|
| 146 | (svref vals (incf idx))))
|
|---|
| 147 | (insert-function (operand-insert-function operand)))
|
|---|
| 148 | (setq high (if insert-function
|
|---|
| 149 | (funcall insert-function high low val)
|
|---|
| 150 | (ppc::insert-default operand high low val)))))
|
|---|
| 151 | ;; "high" now contains the major opcode, BO, and BI fields
|
|---|
| 152 | ;; of the original branch instruction. Generate a (BC
|
|---|
| 153 | ;; (invert BO) BI new-label) instruction, and insert it
|
|---|
| 154 | ;; before the original instruction.
|
|---|
| 155 | (let* ((bc-opcode (svref ppc::*ppc-opcodes* (gethash "BC" ppc::*ppc-opcode-numbers*)))
|
|---|
| 156 | (bo (logxor #b1000 (the fixnum (ldb (byte 5 5) high))))
|
|---|
| 157 | (bi (ldb (byte 5 0) high))
|
|---|
| 158 | (new-instruction (make-lap-instruction bc-opcode))
|
|---|
| 159 | (opvect (alloc-lap-operand-vector)))
|
|---|
| 160 | (setf (lap-instruction-parsed-operands new-instruction) opvect
|
|---|
| 161 | (svref opvect 0) bo
|
|---|
| 162 | (svref opvect 1) bi
|
|---|
| 163 | (svref opvect 2) new-label)
|
|---|
| 164 | (push new-instruction (lap-label-refs new-label))
|
|---|
| 165 | (insert-dll-node-after new-instruction (dll-node-pred insn))
|
|---|
| 166 | (insert-dll-node-after new-label insn))
|
|---|
| 167 | ;; Now, change INSN's opcode to B or BL, and make sure that
|
|---|
| 168 | ;; it references nothing but the old label.
|
|---|
| 169 | (let* ((long-branch (svref ppc::*ppc-opcodes* (gethash (if link-p "BL" "B") ppc::*ppc-opcode-numbers*)))
|
|---|
| 170 | (opvect (alloc-lap-operand-vector)))
|
|---|
| 171 | (setf (svref opvect 0) label
|
|---|
| 172 | (lap-instruction-opcode insn) long-branch
|
|---|
| 173 | (lap-instruction-parsed-operands insn) opvect)
|
|---|
| 174 | ;; We're finally done. Return t.
|
|---|
| 175 | t))))))
|
|---|
| 176 |
|
|---|
| 177 |
|
|---|
| 178 | ; Build & return list of all labels that are targets of conditional branches.
|
|---|
| 179 | (defun ppc-lap-conditional-branch-targets ()
|
|---|
| 180 | (let* ((branch-target-labels ()))
|
|---|
| 181 | (do-lap-labels (lab branch-target-labels)
|
|---|
| 182 | (dolist (insn (lap-label-refs lab))
|
|---|
| 183 | (when (ppc-lap-conditional-branch-p insn)
|
|---|
| 184 | (push lab branch-target-labels))))))
|
|---|
| 185 |
|
|---|
| 186 | (defun ppc-lap-assign-addresses (delete-labels-p)
|
|---|
| 187 | (let* ((pc 0))
|
|---|
| 188 | (declare (fixnum pc))
|
|---|
| 189 | (do-dll-nodes (node *lap-instructions*)
|
|---|
| 190 | (setf (instruction-element-address node) pc)
|
|---|
| 191 | (if (typep node 'lap-label)
|
|---|
| 192 | (if delete-labels-p (remove-dll-node node))
|
|---|
| 193 | (incf pc 4)))
|
|---|
| 194 | ;; Don't bother checking code-vector size yet.
|
|---|
| 195 | pc))
|
|---|
| 196 |
|
|---|
| 197 | ;;; The function's big enough that we might have generated conditional
|
|---|
| 198 | ;;; branches that are too far away from their targets. Find the set
|
|---|
| 199 | ;;; of all labels that are the target of conditional branches, then
|
|---|
| 200 | ;;; repeatedly assign (tentative) addresses to all instructions and
|
|---|
| 201 | ;;; labels and iterate over the set of conditional branch targets,
|
|---|
| 202 | ;;; "lengthening" any condtional branches that are too far away from
|
|---|
| 203 | ;;; the target label. Since lengthening a branch instruction can
|
|---|
| 204 | ;;; cause a spanning branch to become a candidate for lengthening, we
|
|---|
| 205 | ;;; have to repeat the process until all labels are the targets of
|
|---|
| 206 | ;;; valid (short enough or unconditional) branch instructions.
|
|---|
| 207 | (defun ppc-lap-remove-long-branches ()
|
|---|
| 208 | (let* ((branch-target-labels (ppc-lap-conditional-branch-targets)))
|
|---|
| 209 | (do* ((done nil))
|
|---|
| 210 | (done (ppc-lap-assign-addresses t))
|
|---|
| 211 | (setq done t)
|
|---|
| 212 | (ppc-lap-assign-addresses nil)
|
|---|
| 213 | (dolist (lab branch-target-labels)
|
|---|
| 214 | (dolist (insn (lap-label-refs lab))
|
|---|
| 215 | (when (ppc-lap-invert-conditional-branch insn lab)
|
|---|
| 216 | (setq done nil)))))))
|
|---|
| 217 |
|
|---|
| 218 | (defun ppc-lap-do-labels ()
|
|---|
| 219 | (do-lap-labels (lab)
|
|---|
| 220 | (if (and (lap-label-refs lab) (not (lap-label-emitted-p lab)))
|
|---|
| 221 | (error "Label ~S was referenced but never defined. "
|
|---|
| 222 | (lap-label-name lab)))
|
|---|
| 223 | ;; Repeatedly iterate through label's refs, until none of them is
|
|---|
| 224 | ;; the preceding instruction. This eliminates
|
|---|
| 225 | ;; (b @next)
|
|---|
| 226 | ;;@next
|
|---|
| 227 | ;;
|
|---|
| 228 | ;; but can probably be fooled by hairier nonsense.
|
|---|
| 229 | (loop
|
|---|
| 230 | (when (dolist (ref (lap-label-refs lab) t)
|
|---|
| 231 | (when (eq lab (lap-instruction-succ ref))
|
|---|
| 232 | (remove-dll-node ref)
|
|---|
| 233 | (setf (lap-label-refs lab) (delete ref (lap-label-refs lab)))
|
|---|
| 234 | (return)))
|
|---|
| 235 | (return))))
|
|---|
| 236 | ;; Assign pc to emitted labels, splice them out of the list.
|
|---|
| 237 |
|
|---|
| 238 | (if (> (the fixnum (dll-header-length *lap-instructions*)) 8191)
|
|---|
| 239 | ;; -Might- have some conditional branches that are too long.
|
|---|
| 240 | ;; Definitely don't otherwise, so only bother to check in this case
|
|---|
| 241 | (ppc-lap-remove-long-branches)
|
|---|
| 242 | (ppc-lap-assign-addresses t)))
|
|---|
| 243 |
|
|---|
| 244 | ;;; Replace each label with the difference between the label's address
|
|---|
| 245 | ;;; and the referencing instruction's address.
|
|---|
| 246 | (defun ppc-lap-resolve-labels ()
|
|---|
| 247 | (do-lap-labels (label)
|
|---|
| 248 | (let* ((label-address (lap-label-address label)))
|
|---|
| 249 | (declare (fixnum label-address)) ; had BETTER be ...
|
|---|
| 250 | (dolist (insn (lap-label-refs label))
|
|---|
| 251 | (let* ((diff (- label-address (lap-instruction-address insn))))
|
|---|
| 252 | (declare (fixnum diff))
|
|---|
| 253 | (let* ((opvals (lap-instruction-parsed-operands insn))
|
|---|
| 254 | (pos (position label opvals)))
|
|---|
| 255 | (unless pos
|
|---|
| 256 | (error "Bug: label ~s should be referenced by instruction ~s, but isn't."))
|
|---|
| 257 | (setf (svref opvals pos) diff)))))))
|
|---|
| 258 |
|
|---|
| 259 | (defun ppc-lap-generate-instruction (code-vector index insn)
|
|---|
| 260 | (let* ((op (lap-instruction-opcode insn))
|
|---|
| 261 | (vals (lap-instruction-parsed-operands insn))
|
|---|
| 262 | (high (opcode-op-high op))
|
|---|
| 263 | (low (opcode-op-low op))
|
|---|
| 264 | (idx -1))
|
|---|
| 265 | (dolist (operand (opcode-operands op))
|
|---|
| 266 | (let* ((val (if (logbitp operand-fake (operand-flags operand))
|
|---|
| 267 | 0
|
|---|
| 268 | (svref vals (incf idx))))
|
|---|
| 269 | (insert-function (operand-insert-function operand)))
|
|---|
| 270 | (multiple-value-setq (high low)
|
|---|
| 271 | (if insert-function
|
|---|
| 272 | (funcall insert-function high low val)
|
|---|
| 273 | (ppc::insert-default operand high low val)))
|
|---|
| 274 | (if (null high)
|
|---|
| 275 | (error "Invalid operand for ~s instruction: ~d" (opcode-name op) val))))
|
|---|
| 276 | (setf (lap-instruction-parsed-operands insn) nil)
|
|---|
| 277 | (free-lap-operand-vector vals)
|
|---|
| 278 | (locally (declare (type (simple-array (unsigned-byte 16) (*)) code-vector)
|
|---|
| 279 | (optimize (speed 3) (safety 0)))
|
|---|
| 280 | (setf (aref code-vector (+ index index)) high
|
|---|
| 281 | (aref code-vector (+ index index 1)) low)
|
|---|
| 282 | nil)))
|
|---|
| 283 |
|
|---|
| 284 | (defparameter *use-traceback-tables* nil)
|
|---|
| 285 |
|
|---|
| 286 | (defun traceback-fullwords (pname)
|
|---|
| 287 | (if (and *use-traceback-tables* pname (typep pname 'simple-base-string))
|
|---|
| 288 | (ceiling (+ 22 (length pname)) 4)
|
|---|
| 289 | 0))
|
|---|
| 290 |
|
|---|
| 291 | (defun add-traceback-table (code-vector start pname)
|
|---|
| 292 | (flet ((out-byte (v i8 b)
|
|---|
| 293 | (declare (type (simple-array (unsigned-byte 8) (*)) v)
|
|---|
| 294 | (optimize (speed 3) (safety 0))
|
|---|
| 295 | (fixnum i8))
|
|---|
| 296 | (setf (aref v i8) b)))
|
|---|
| 297 | (flet ((out-bytes (v i32 b0 b1 b2 b3)
|
|---|
| 298 | (declare (type (simple-array (unsigned-byte 8) (*)) v)
|
|---|
| 299 | (optimize (speed 3) (safety 0))
|
|---|
| 300 | (fixnum i32))
|
|---|
| 301 | (let* ((i8 (ash i32 2)))
|
|---|
| 302 | (declare (fixnum i8))
|
|---|
| 303 | (setf (aref v i8) b0
|
|---|
| 304 | (aref v (%i+ i8 1)) b1
|
|---|
| 305 | (aref v (%i+ i8 2)) b2
|
|---|
| 306 | (aref v (%i+ i8 3)) b3))))
|
|---|
| 307 | (setf (uvref code-vector start) 0)
|
|---|
| 308 | (out-bytes code-vector (1+ start)
|
|---|
| 309 | 0 ; traceback table version
|
|---|
| 310 | 0 ; language id 7 - try 0 instead (means C) or 9 means C++
|
|---|
| 311 | #x20 ; ???
|
|---|
| 312 | #x41) ; ???
|
|---|
| 313 | (out-bytes code-vector (+ start 2)
|
|---|
| 314 | #x80 #x06 #x01 #x00) ; ??? ??? ??? ???
|
|---|
| 315 | (setf (uvref code-vector (+ start 3)) #x0)
|
|---|
| 316 | (setf (uvref code-vector (+ start 4)) (ash start 2))
|
|---|
| 317 | (let* ((namelen (length pname))
|
|---|
| 318 | (pos (ash (the fixnum (+ start 5)) 2)))
|
|---|
| 319 | (declare (fixnum namelen nwords pos))
|
|---|
| 320 | (out-byte code-vector pos (ldb (byte 8 8) namelen))
|
|---|
| 321 | (incf pos)
|
|---|
| 322 | (out-byte code-vector pos (ldb (byte 8 0) namelen))
|
|---|
| 323 | (incf pos)
|
|---|
| 324 | (dotimes (i namelen)
|
|---|
| 325 | (out-byte code-vector pos (char-code (schar pname i)))
|
|---|
| 326 | (incf pos))))))
|
|---|
| 327 |
|
|---|
| 328 | (defun ppc-lap-generate-code (name maxpc bits &optional (traceback nil))
|
|---|
| 329 | (declare (fixnum maxpc))
|
|---|
| 330 | (let* ((target-backend *target-backend*)
|
|---|
| 331 | (cross-compiling (not (eq *host-backend* target-backend)))
|
|---|
| 332 | (traceback-size
|
|---|
| 333 | (traceback-fullwords (and traceback
|
|---|
| 334 | name
|
|---|
| 335 | (setq traceback (symbol-name name)))))
|
|---|
| 336 | (prefix (arch::target-code-vector-prefix (backend-target-arch *target-backend*)))
|
|---|
| 337 | (prefix-size (length prefix))
|
|---|
| 338 | (code-vector-size (+ (ash maxpc -2) traceback-size prefix-size))
|
|---|
| 339 |
|
|---|
| 340 | (constants-size (+ 3 (length *ppc-lap-constants*)))
|
|---|
| 341 | (constants-vector (%alloc-misc
|
|---|
| 342 | constants-size
|
|---|
| 343 | (if cross-compiling
|
|---|
| 344 | target::subtag-xfunction
|
|---|
| 345 | target::subtag-function)))
|
|---|
| 346 | (i prefix-size))
|
|---|
| 347 | (declare (fixnum i constants-size))
|
|---|
| 348 | #+ppc32-target
|
|---|
| 349 | (if (>= code-vector-size (ash 1 19)) (compiler-function-overflow))
|
|---|
| 350 | (let* ((code-vector (%alloc-misc
|
|---|
| 351 | code-vector-size
|
|---|
| 352 | (if cross-compiling
|
|---|
| 353 | target::subtag-xcode-vector
|
|---|
| 354 | target::subtag-code-vector))))
|
|---|
| 355 | (dotimes (j prefix-size)
|
|---|
| 356 | (setf (uvref code-vector j) (pop prefix)))
|
|---|
| 357 | (ppc-lap-resolve-labels) ; all operands fully evaluated now.
|
|---|
| 358 | (do-dll-nodes (insn *lap-instructions*)
|
|---|
| 359 | (ppc-lap-generate-instruction code-vector i insn)
|
|---|
| 360 | (incf i))
|
|---|
| 361 | (unless (eql 0 traceback-size)
|
|---|
| 362 | (add-traceback-table code-vector i traceback))
|
|---|
| 363 | (dolist (immpair *ppc-lap-constants*)
|
|---|
| 364 | (let* ((imm (car immpair))
|
|---|
| 365 | (k (cdr immpair)))
|
|---|
| 366 | (declare (fixnum k))
|
|---|
| 367 | (setf (uvref constants-vector
|
|---|
| 368 | (ash
|
|---|
| 369 | (- k (arch::target-misc-data-offset (backend-target-arch target-backend)))
|
|---|
| 370 | (- (arch::target-word-shift (backend-target-arch target-backend)))))
|
|---|
| 371 | imm)))
|
|---|
| 372 | (setf (uvref constants-vector (1- constants-size)) bits ; lfun-bits
|
|---|
| 373 | (uvref constants-vector (- constants-size 2)) name
|
|---|
| 374 | (uvref constants-vector 0) code-vector)
|
|---|
| 375 | #+ppc-target (%make-code-executable code-vector)
|
|---|
| 376 | constants-vector)))
|
|---|
| 377 |
|
|---|
| 378 | (defun ppc-lap-pseudo-op (form)
|
|---|
| 379 | (case (car form)
|
|---|
| 380 | (:regsave
|
|---|
| 381 | (if *ppc-lap-regsave-label*
|
|---|
| 382 | (warn "Duplicate :regsave form not handled (yet ?) : ~s" form)
|
|---|
| 383 | (destructuring-bind (reg addr) (cdr form)
|
|---|
| 384 | (let* ((regno (ppc-register-name-or-expression reg)))
|
|---|
| 385 | (if (not (<= ppc::save7 regno ppc::save0))
|
|---|
| 386 | (warn "Not a save register: ~s. ~s ignored." reg form)
|
|---|
| 387 | (let* ((addrexp (ppc-register-name-or-expression addr))) ; parses 'fixnum
|
|---|
| 388 | (if (not (and (typep addrexp 'fixnum)
|
|---|
| 389 | (<= 0 addrexp #x7ffc) ; not really right
|
|---|
| 390 | (not (logtest 3 addrexp))))
|
|---|
| 391 | (warn "Invalid logical VSP: ~s. ~s ignored." addr form)
|
|---|
| 392 | (setq *ppc-lap-regsave-label* (emit-lap-label (gensym))
|
|---|
| 393 | *ppc-lap-regsave-reg* regno
|
|---|
| 394 | *ppc-lap-regsave-addr* (- (+ addrexp)
|
|---|
| 395 | (* 4 (1+ (- ppc::save0 regno))))))))))))
|
|---|
| 396 | (:arglist (setq *ppc-lap-lfun-bits* (encode-lambda-list (cadr form))))))
|
|---|
| 397 |
|
|---|
| 398 |
|
|---|
| 399 | (defun ppc-lap-form (form)
|
|---|
| 400 | (if (and form (symbolp form))
|
|---|
| 401 | (emit-lap-label form)
|
|---|
| 402 | (if (or (atom form) (not (symbolp (car form))))
|
|---|
| 403 | (error "~& unknown PPC-LAP form: ~S ." form)
|
|---|
| 404 | (multiple-value-bind (expansion expanded)
|
|---|
| 405 | (ppc-lap-macroexpand-1 form)
|
|---|
| 406 | (if expanded
|
|---|
| 407 | (ppc-lap-form expansion)
|
|---|
| 408 | (let* ((name (car form)))
|
|---|
| 409 | (if (keywordp name)
|
|---|
| 410 | (ppc-lap-pseudo-op form)
|
|---|
| 411 | (case name
|
|---|
| 412 | ((progn) (dolist (f (cdr form)) (ppc-lap-form f)))
|
|---|
| 413 | ((let) (ppc-lap-equate-form (cadr form) (cddr form)))
|
|---|
| 414 | (t
|
|---|
| 415 | ; instruction macros expand into instruction forms
|
|---|
| 416 | ; (with some operands reordered/defaulted.)
|
|---|
| 417 | (let* ((expander (ppc::ppc-macro-function name)))
|
|---|
| 418 | (if expander
|
|---|
| 419 | (ppc-lap-form (funcall expander form nil))
|
|---|
| 420 | (ppc-lap-instruction name (cdr form)))))))))))))
|
|---|
| 421 |
|
|---|
| 422 | ;;; (let ((name val) ...) &body body)
|
|---|
| 423 | ;;; each "val" gets a chance to be treated as a PPC register name
|
|---|
| 424 | ;;; before being evaluated.
|
|---|
| 425 | (defun ppc-lap-equate-form (eqlist body)
|
|---|
| 426 | (let* ((symbols (mapcar #'(lambda (x)
|
|---|
| 427 | (let* ((name (car x)))
|
|---|
| 428 | (or
|
|---|
| 429 | (and name
|
|---|
| 430 | (symbolp name)
|
|---|
| 431 | (not (constant-symbol-p name))
|
|---|
| 432 | name)
|
|---|
| 433 | (error
|
|---|
| 434 | "~S is not a bindable symbol name ." name))))
|
|---|
| 435 | eqlist))
|
|---|
| 436 | (values (mapcar #'(lambda (x) (or (ppc-vr-name-p (cadr x))
|
|---|
| 437 | (ppc-fpr-name-p (cadr x))
|
|---|
| 438 | (ppc-register-name-or-expression
|
|---|
| 439 | (cadr x))))
|
|---|
| 440 | eqlist)))
|
|---|
| 441 | (progv symbols values
|
|---|
| 442 | (dolist (form body)
|
|---|
| 443 | (ppc-lap-form form)))))
|
|---|
| 444 |
|
|---|
| 445 | (defun ppc-lap-constant-offset (x)
|
|---|
| 446 | (or (cdr (assoc x *ppc-lap-constants* :test #'equal))
|
|---|
| 447 | (let* ((target-backend *target-backend*)
|
|---|
| 448 | (n (+ (arch::target-misc-data-offset (backend-target-arch target-backend))
|
|---|
| 449 | (ash (1+ (length *ppc-lap-constants*))
|
|---|
| 450 | (arch::target-word-shift (backend-target-arch target-backend))))))
|
|---|
| 451 | (push (cons x n) *ppc-lap-constants*)
|
|---|
| 452 | n)))
|
|---|
| 453 |
|
|---|
| 454 | ; Evaluate an arbitrary expression; warn if the result isn't a fixnum.
|
|---|
| 455 | (defun ppc-lap-evaluated-expression (x)
|
|---|
| 456 | (if (typep x 'fixnum)
|
|---|
| 457 | x
|
|---|
| 458 | (if (null x)
|
|---|
| 459 | (arch::target-nil-value (backend-target-arch *target-backend*))
|
|---|
| 460 | (if (eq x t)
|
|---|
| 461 | (+ (arch::target-nil-value (backend-target-arch *target-backend*))
|
|---|
| 462 | (arch::target-t-offset (backend-target-arch *target-backend*)))
|
|---|
| 463 | (let* ((val (handler-case (eval x) ; Look! Expression evaluation!
|
|---|
| 464 | (error (condition) (error "~&Evaluation of ~S signalled assembly-time error ~& ~A ."
|
|---|
| 465 | x condition)))))
|
|---|
| 466 | (unless (typep val 'fixnum)
|
|---|
| 467 | (warn "assembly-time evaluation of ~S returned ~S, which may not have been intended ."
|
|---|
| 468 | x val))
|
|---|
| 469 | val)))))
|
|---|
| 470 |
|
|---|
| 471 | (defparameter *ppc-lap-register-aliases*
|
|---|
| 472 | `((nfn . ,ppc::nfn)
|
|---|
| 473 | (fname . ,ppc::fname)))
|
|---|
| 474 |
|
|---|
| 475 | (defparameter *ppc-lap-fp-register-aliases*
|
|---|
| 476 | ())
|
|---|
| 477 |
|
|---|
| 478 | (defparameter *ppc-lap-vector-register-aliases*
|
|---|
| 479 | ())
|
|---|
| 480 |
|
|---|
| 481 | (defun ppc-gpr-name-p (x)
|
|---|
| 482 | (and (or (symbolp x) (stringp x))
|
|---|
| 483 | (or
|
|---|
| 484 | (position (string x) ppc::*gpr-register-names* :test #'string-equal)
|
|---|
| 485 | (cdr (assoc x *ppc-lap-register-aliases* :test #'string-equal)))))
|
|---|
| 486 |
|
|---|
| 487 | (defun ppc-register-name-or-expression (x)
|
|---|
| 488 | (if x
|
|---|
| 489 | (or (ppc-gpr-name-p x)
|
|---|
| 490 | (if (and (consp x) (eq (car x) 'quote))
|
|---|
| 491 | (let* ((quoted-form (cadr x)))
|
|---|
| 492 | (if (null quoted-form)
|
|---|
| 493 | (arch::target-nil-value (backend-target-arch *target-backend*))
|
|---|
| 494 | (if (eq quoted-form t)
|
|---|
| 495 | (+ (arch::target-nil-value (backend-target-arch *target-backend*))
|
|---|
| 496 | (arch::target-t-offset (backend-target-arch *target-backend*)))
|
|---|
| 497 | (if (typep quoted-form 'fixnum)
|
|---|
| 498 | (ash quoted-form (arch::target-fixnum-shift (backend-target-arch *target-backend*)))
|
|---|
| 499 | (ppc-lap-constant-offset quoted-form)))))
|
|---|
| 500 | (ppc-lap-evaluated-expression x)))
|
|---|
| 501 | (arch::target-nil-value (backend-target-arch *target-backend*))))
|
|---|
| 502 |
|
|---|
| 503 | (defun ppc-fpr-name-p (x)
|
|---|
| 504 | (and (or (symbolp x) (stringp x))
|
|---|
| 505 | (or
|
|---|
| 506 | (position (string x) ppc::*fpr-register-names* :test #'string-equal)
|
|---|
| 507 | (cdr (assoc x *ppc-lap-fp-register-aliases* :test #'string-equal)))))
|
|---|
| 508 |
|
|---|
| 509 | (defun ppc-fp-register-name-or-expression (x)
|
|---|
| 510 | (or (ppc-fpr-name-p x)
|
|---|
| 511 | (ppc-lap-evaluated-expression x)))
|
|---|
| 512 |
|
|---|
| 513 | (defun ppc-vr-name-p (x)
|
|---|
| 514 | (and (or (symbolp x) (stringp x))
|
|---|
| 515 | (or
|
|---|
| 516 | (position (string x) ppc::*vector-register-names* :test #'string-equal)
|
|---|
| 517 | (cdr (assoc x *ppc-lap-vector-register-aliases* :test #'string-equal)))))
|
|---|
| 518 |
|
|---|
| 519 | (defun ppc-vector-register-name-or-expression (x)
|
|---|
| 520 | (or (ppc-vr-name-p x)
|
|---|
| 521 | (ppc-lap-evaluated-expression x)))
|
|---|
| 522 |
|
|---|
| 523 | (defun ppc-vr (r)
|
|---|
| 524 | (svref ppc::*vector-register-names* r))
|
|---|
| 525 |
|
|---|
| 526 |
|
|---|
| 527 | (defparameter *ppc-cr-field-names* #(:crf0 :crf1 :crf2 :crf3 :crf4 :crf5 :crf6 :crf7))
|
|---|
| 528 | (defparameter *ppc-cr-names* #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7))
|
|---|
| 529 | (defparameter *ppc-cc-bit-names* #(:lt :gt :eq :so :un))
|
|---|
| 530 | (defparameter *ppc-cc-bit-inverse-names* #(:ge :le :ne :ns :nu))
|
|---|
| 531 |
|
|---|
| 532 | ; This wants a :CC, a negated :CC, or either (:CRn :CC) or (:CRn :~CC).
|
|---|
| 533 | ; Returns the fully-qualified CR bit and an indication of whether or not the CC was
|
|---|
| 534 | ; negated.
|
|---|
| 535 | (defun ppc-lap-parse-test (x)
|
|---|
| 536 | (if (or (symbolp x) (stringp x))
|
|---|
| 537 | (let* ((pos (position x *ppc-cc-bit-names* :test #'string-equal)))
|
|---|
| 538 | (if pos
|
|---|
| 539 | (values (min pos 3) nil)
|
|---|
| 540 | (if (setq pos (position x *ppc-cc-bit-inverse-names* :test #'string-equal))
|
|---|
| 541 | (values (min pos 3) t)
|
|---|
| 542 | (error "Unknown PPC lap condition form : ~s" x))))
|
|---|
| 543 | (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x)))
|
|---|
| 544 | (let* ((field (position (car x) *ppc-cr-names*)))
|
|---|
| 545 | (unless field (error "Unknown CR field name : ~s" (car x)))
|
|---|
| 546 | (let* ((bit (position (cadr x) *ppc-cc-bit-names*)))
|
|---|
| 547 | (if bit
|
|---|
| 548 | (values (logior (ash field 2) (min bit 3)) nil)
|
|---|
| 549 | (if (setq bit (position (cadr x) *ppc-cc-bit-inverse-names*))
|
|---|
| 550 | (values (logior (ash field 2) (min bit 3)) t)
|
|---|
| 551 | (error "Unknown condition name : ~s" (cadr x))))))
|
|---|
| 552 | (error "Unknown PPC lap condition form : ~s" x))))
|
|---|
| 553 |
|
|---|
| 554 | ; Accept either :CRn, :CC, or (:CRFn :CC), or evaluate an expression.
|
|---|
| 555 | (defun ppc-lap-cr-field-expression (x)
|
|---|
| 556 | (if (or (symbolp x) (stringp x))
|
|---|
| 557 | (let* ((pos (position x *ppc-cr-names* :test #'string-equal)))
|
|---|
| 558 | (if pos
|
|---|
| 559 | (ash pos 2)
|
|---|
| 560 | (let* ((cc-pos (position x *ppc-cc-bit-names* :test #'string-equal)))
|
|---|
| 561 | (if cc-pos
|
|---|
| 562 | (min cc-pos 3)
|
|---|
| 563 | (ppc-lap-evaluated-expression x)))))
|
|---|
| 564 | (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x)))
|
|---|
| 565 | (let* ((field (position (car x) *ppc-cr-field-names*))
|
|---|
| 566 | (bit (position (cadr x) *ppc-cc-bit-names*)))
|
|---|
| 567 | (if (and field bit)
|
|---|
| 568 | (logior (min bit 3) (ash field 2))
|
|---|
| 569 | (error "Bad ppc-cr-field-expression: ~s" x)))
|
|---|
| 570 | (ppc-lap-evaluated-expression x))))
|
|---|
| 571 |
|
|---|
| 572 | (defun ppc-lap-instruction (name opvals)
|
|---|
| 573 | (let* ((opnum (gethash (string name) ppc::*ppc-opcode-numbers*))
|
|---|
| 574 | (opcode (and opnum
|
|---|
| 575 | (< -1 opnum (length ppc::*ppc-opcodes*))
|
|---|
| 576 | (svref ppc::*ppc-opcodes* opnum))))
|
|---|
| 577 | (unless opcode
|
|---|
| 578 | (error "Unknown PPC opcode: ~a" name))
|
|---|
| 579 | ;; Unless either
|
|---|
| 580 | ;; a) The number of operand values in the macro call exactly
|
|---|
| 581 | ;; matches the number of operands accepted by the instruction or
|
|---|
| 582 | ;; b) The number of operand values is one less, and the instuction
|
|---|
| 583 | ;; takes an optional operand
|
|---|
| 584 | ;; we've got a wrong-number-of-args error.
|
|---|
| 585 | ;; In case (b), there's at most one optional argument per instruction;
|
|---|
| 586 | ;; provide 0 for the missing value.
|
|---|
| 587 | (let* ((operands (opcode-operands opcode))
|
|---|
| 588 | (nmin (opcode-min-args opcode))
|
|---|
| 589 | (nmax (opcode-max-args opcode))
|
|---|
| 590 | (nhave (length opvals)))
|
|---|
| 591 | (declare (fixnum nmin nmax nhave))
|
|---|
| 592 | (if (= nhave nmax)
|
|---|
| 593 | (ppc-emit-lap-instruction opcode opvals)
|
|---|
| 594 | (if (> nhave nmax)
|
|---|
| 595 | (error "Too many operands in ~s (~a accepts at most ~d)"
|
|---|
| 596 | opvals name nmax)
|
|---|
| 597 | (if (= nhave nmin)
|
|---|
| 598 | (let* ((newops ()))
|
|---|
| 599 | (dolist (op operands (ppc-emit-lap-instruction opcode (nreverse newops)))
|
|---|
| 600 | (let* ((flags (operand-flags op)))
|
|---|
| 601 | (unless (logbitp operand-fake flags)
|
|---|
| 602 | (push (if (logbitp operand-optional flags)
|
|---|
| 603 | 0
|
|---|
| 604 | (pop opvals))
|
|---|
| 605 | newops)))))
|
|---|
| 606 | (error "Too few operands in ~s : (~a requires at least ~d)"
|
|---|
| 607 | opvals name nmin)))))))
|
|---|
| 608 |
|
|---|
| 609 | ; This is pretty rudimentary: if the operand has the "ppc::$ppc-operand-relative" bit
|
|---|
| 610 | ; set, we demand a label name and note the fact that we reference the label in question.
|
|---|
| 611 | ; Otherwise, we use the "register-name-or-expression" thing.
|
|---|
| 612 | ; Like most PPC assemblers, this lets you treat everything as an expression, even if
|
|---|
| 613 | ; you've got the order of some arguments wrong ...
|
|---|
| 614 |
|
|---|
| 615 | (defun ppc-parse-lap-operand (opvalx operand insn)
|
|---|
| 616 | (let* ((flags (operand-flags operand)))
|
|---|
| 617 | (declare (fixnum flags))
|
|---|
| 618 | (if (logbitp ppc::$ppc-operand-relative flags)
|
|---|
| 619 | (lap-note-label-reference opvalx insn)
|
|---|
| 620 | (if (logbitp ppc::$ppc-operand-cr flags)
|
|---|
| 621 | (ppc-lap-cr-field-expression opvalx)
|
|---|
| 622 | (if (logbitp ppc::$ppc-operand-absolute flags)
|
|---|
| 623 | (ppc-subprimitive-address opvalx)
|
|---|
| 624 | (if (logbitp ppc::$ppc-operand-fpr flags)
|
|---|
| 625 | (ppc-fp-register-name-or-expression opvalx)
|
|---|
| 626 | (if (logbitp ppc::$ppc-operand-vr flags) ; SVS
|
|---|
| 627 | (ppc-vector-register-name-or-expression opvalx)
|
|---|
| 628 | (ppc-register-name-or-expression opvalx))))))))
|
|---|
| 629 |
|
|---|
| 630 | (defun ppc-subprimitive-address (x)
|
|---|
| 631 | (if (and x (or (symbolp x) (stringp x)))
|
|---|
| 632 | (let* ((info (find x ppc::*ppc-subprims* :test #'string-equal :key #'subprimitive-info-name)))
|
|---|
| 633 | (when info (return-from ppc-subprimitive-address
|
|---|
| 634 | (subprimitive-info-offset info)))))
|
|---|
| 635 | (ppc-lap-evaluated-expression x))
|
|---|
| 636 |
|
|---|
| 637 |
|
|---|
| 638 | ;;; We've checked that the number of operand values match the number
|
|---|
| 639 | ;;; expected (and have set "fake" operand values to 0.) Labels - and
|
|---|
| 640 | ;;; some constructs that might someday do arithmetic on them - are
|
|---|
| 641 | ;;; about the only class of forward references we need to deal with.
|
|---|
| 642 | ;;; This whole two-pass scheme seems overly general, but if/when we
|
|---|
| 643 | ;;; ever do instruction scheduling it'll probably make it simpler.
|
|---|
| 644 | (defun ppc-emit-lap-instruction (opcode opvals)
|
|---|
| 645 | (let* ((operands (opcode-operands opcode))
|
|---|
| 646 | (parsed-values (alloc-lap-operand-vector))
|
|---|
| 647 | (insn (make-lap-instruction opcode))
|
|---|
| 648 | (idx -1))
|
|---|
| 649 | (declare (fixnum idx))
|
|---|
| 650 | (dolist (op operands)
|
|---|
| 651 | (let* ((flags (operand-flags op))
|
|---|
| 652 | (val (if (logbitp operand-fake flags)
|
|---|
| 653 | 0
|
|---|
| 654 | (ppc-parse-lap-operand (pop opvals) op insn))))
|
|---|
| 655 | (declare (fixnum flags))
|
|---|
| 656 | (setf (svref parsed-values (incf idx)) val)))
|
|---|
| 657 | (setf (lap-instruction-parsed-operands insn) parsed-values)
|
|---|
| 658 | (append-dll-node insn *lap-instructions*)))
|
|---|
| 659 |
|
|---|
| 660 |
|
|---|
| 661 |
|
|---|
| 662 | (defmacro defppclapfunction (&environment env name arglist &body body
|
|---|
| 663 | &aux doc)
|
|---|
| 664 | (if (not (endp body))
|
|---|
| 665 | (and (stringp (car body))
|
|---|
| 666 | (cdr body)
|
|---|
| 667 | (setq doc (car body))
|
|---|
| 668 | (setq body (cdr body))))
|
|---|
| 669 | `(progn
|
|---|
| 670 | (eval-when (:compile-toplevel)
|
|---|
| 671 | (note-function-info ',name t ,env))
|
|---|
| 672 | #-ppc-target
|
|---|
| 673 | (progn
|
|---|
| 674 | (eval-when (:load-toplevel)
|
|---|
| 675 | (%defun (nfunction ,name (lambda (&lap 0) (ppc-lap-function ,name ,arglist ,@body))) ,doc))
|
|---|
| 676 | (eval-when (:execute)
|
|---|
| 677 | (%define-ppc-lap-function ',name '((let ,arglist ,@body)))))
|
|---|
| 678 | #+ppc-target ; just shorthand for defun
|
|---|
| 679 | (%defun (nfunction ,name (lambda (&lap 0) (ppc-lap-function ,name ,arglist ,@body))) ,doc)))
|
|---|
| 680 |
|
|---|
| 681 |
|
|---|
| 682 |
|
|---|
| 683 | (provide "PPC-LAP")
|
|---|
