| 1 | ;;;-*- Mode: Lisp; Package: CCL -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; Copyright (C) 2005, Clozure Associates and contributors.
|
|---|
| 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 | (in-package "CCL")
|
|---|
| 18 |
|
|---|
| 19 | (require "X86-ASM")
|
|---|
| 20 |
|
|---|
| 21 | (eval-when (:compile-toplevel :load-toplevel :execute)
|
|---|
| 22 | (require "DLL-NODE"))
|
|---|
| 23 |
|
|---|
| 24 | (def-standard-initial-binding *x86-lap-label-freelist* (make-dll-node-freelist))
|
|---|
| 25 |
|
|---|
| 26 | (def-standard-initial-binding *x86-lap-frag-vector-freelist* (%cons-pool))
|
|---|
| 27 |
|
|---|
| 28 | (defun %allocate-vector-list-segment ()
|
|---|
| 29 | (without-interrupts
|
|---|
| 30 | (let* ((data (pool.data *x86-lap-frag-vector-freelist*)))
|
|---|
| 31 | (if data
|
|---|
| 32 | (progn
|
|---|
| 33 | (when (null (list-length data))
|
|---|
| 34 | (break "frag-vector freelist is circular"))
|
|---|
| 35 | (setf (pool.data *x86-lap-frag-vector-freelist*) (cdr data))
|
|---|
| 36 | (rplacd data nil))
|
|---|
| 37 | (cons (make-array 24 :element-type '(unsigned-byte 8)) nil)))))
|
|---|
| 38 |
|
|---|
| 39 | (defun %free-vector-list-segment (segment)
|
|---|
| 40 | (without-interrupts
|
|---|
| 41 | (setf (pool.data *x86-lap-frag-vector-freelist*)
|
|---|
| 42 | (nconc segment (pool.data *x86-lap-frag-vector-freelist*)))))
|
|---|
| 43 |
|
|---|
| 44 | (defun %vector-list-ref (vector-list index)
|
|---|
| 45 | (do* ((i index (- i len))
|
|---|
| 46 | (vl vector-list (cdr vl))
|
|---|
| 47 | (v (car vl) (car vl))
|
|---|
| 48 | (len (length v) (length v)))
|
|---|
| 49 | ((null vl) (error "Index ~s is out of bounds for ~s" index vector-list))
|
|---|
| 50 | (if (< i len)
|
|---|
| 51 | (return (aref v i)))))
|
|---|
| 52 |
|
|---|
| 53 | (defun (setf %vector-list-ref) (new vector-list index)
|
|---|
| 54 | (do* ((i index (- i len))
|
|---|
| 55 | (vl vector-list (cdr vl))
|
|---|
| 56 | (v (car vl) (car vl))
|
|---|
| 57 | (len (length v) (length v)))
|
|---|
| 58 | ((< i len) (setf (aref v i) new))
|
|---|
| 59 | (when (null (cdr vl))
|
|---|
| 60 | (setf (cdr vl) (%allocate-vector-list-segment)))))
|
|---|
| 61 |
|
|---|
| 62 | (defun %truncate-vector-list (vector-list newlen)
|
|---|
| 63 | (do* ((vl vector-list (cdr vl))
|
|---|
| 64 | (v (car vl) (car vl))
|
|---|
| 65 | (len (length v) (length v))
|
|---|
| 66 | (total len (+ total len)))
|
|---|
| 67 | ((null (cdr vl)))
|
|---|
| 68 | (when (> total newlen)
|
|---|
| 69 | (%free-vector-list-segment (cdr vl))
|
|---|
| 70 | (return (setf (cdr vl) nil)))))
|
|---|
| 71 |
|
|---|
| 72 |
|
|---|
| 73 |
|
|---|
| 74 |
|
|---|
| 75 |
|
|---|
| 76 | (eval-when (:execute :load-toplevel)
|
|---|
| 77 |
|
|---|
| 78 | (defstruct (x86-lap-note (:include ccl::dll-node))
|
|---|
| 79 | peer
|
|---|
| 80 | id)
|
|---|
| 81 |
|
|---|
| 82 | (defstruct (x86-lap-note-begin (:include x86-lap-note)))
|
|---|
| 83 | (defstruct (x86-lap-note-end (:include x86-lap-note)))
|
|---|
| 84 |
|
|---|
| 85 | (defstruct (x86-lap-label (:constructor %%make-x86-lap-label (name)))
|
|---|
| 86 | name
|
|---|
| 87 | frag
|
|---|
| 88 | offset
|
|---|
| 89 | )
|
|---|
| 90 |
|
|---|
| 91 | (defstruct (frag (:include ccl::dll-node)
|
|---|
| 92 | (:constructor %make-frag))
|
|---|
| 93 | address
|
|---|
| 94 | last-address ; address may change during relax
|
|---|
| 95 | type ; nil, or (:TYPE &rest args)
|
|---|
| 96 | relocs ; relocations against this frag
|
|---|
| 97 | (position 0) ; position in code-buffer
|
|---|
| 98 | (code-buffer (%allocate-vector-list-segment)) ; a VECTOR-LIST
|
|---|
| 99 | labels ; labels defined in this frag
|
|---|
| 100 | ))
|
|---|
| 101 |
|
|---|
| 102 | (def-standard-initial-binding *frag-freelist* (make-dll-node-freelist))
|
|---|
| 103 |
|
|---|
| 104 |
|
|---|
| 105 | (defun frag-push-byte (frag b)
|
|---|
| 106 | (let* ((pos (frag-position frag)))
|
|---|
| 107 | (setf (%vector-list-ref (frag-code-buffer frag) pos) b
|
|---|
| 108 | (frag-position frag) (1+ pos))
|
|---|
| 109 | b))
|
|---|
| 110 |
|
|---|
| 111 | (defun frag-ref (frag index)
|
|---|
| 112 | (%vector-list-ref (frag-code-buffer frag) index))
|
|---|
| 113 |
|
|---|
| 114 | (defun (setf frag-ref) (new frag index)
|
|---|
| 115 | (setf (%vector-list-ref (frag-code-buffer frag) index) new))
|
|---|
| 116 |
|
|---|
| 117 | (defun frag-length (frag)
|
|---|
| 118 | (frag-position frag))
|
|---|
| 119 |
|
|---|
| 120 | (defun (setf frag-length) (new frag)
|
|---|
| 121 | (%truncate-vector-list (frag-code-buffer frag) new)
|
|---|
| 122 | (setf (frag-position frag) new))
|
|---|
| 123 |
|
|---|
| 124 |
|
|---|
| 125 | ;;; Push 1, 2, 4, or 8 bytes onto the frag-list's current-frag's buffer.
|
|---|
| 126 | ;;; (If pushing more than one byte, do so in little-endian order.)
|
|---|
| 127 | (defun frag-list-push-byte (frag-list b)
|
|---|
| 128 | (frag-push-byte (frag-list-current frag-list) b))
|
|---|
| 129 |
|
|---|
| 130 | (defun frag-list-push-16 (frag-list w)
|
|---|
| 131 | (let* ((frag (frag-list-current frag-list)))
|
|---|
| 132 | (frag-push-byte frag (ldb (byte 8 0) w))
|
|---|
| 133 | (frag-push-byte frag (ldb (byte 8 8) w))))
|
|---|
| 134 |
|
|---|
| 135 | (defun frag-list-push-32 (frag-list w)
|
|---|
| 136 | (let* ((frag (frag-list-current frag-list)))
|
|---|
| 137 | (frag-push-byte frag (ldb (byte 8 0) w))
|
|---|
| 138 | (frag-push-byte frag (ldb (byte 8 8) w))
|
|---|
| 139 | (frag-push-byte frag (ldb (byte 8 16) w))
|
|---|
| 140 | (frag-push-byte frag (ldb (byte 8 24) w))
|
|---|
| 141 | w))
|
|---|
| 142 |
|
|---|
| 143 | (defun frag-list-push-64 (frag-list w)
|
|---|
| 144 | (let* ((frag (frag-list-current frag-list)))
|
|---|
| 145 | (frag-push-byte frag (ldb (byte 8 0) w))
|
|---|
| 146 | (frag-push-byte frag (ldb (byte 8 8) w))
|
|---|
| 147 | (frag-push-byte frag (ldb (byte 8 16) w))
|
|---|
| 148 | (frag-push-byte frag (ldb (byte 8 24) w))
|
|---|
| 149 | (frag-push-byte frag (ldb (byte 8 32) w))
|
|---|
| 150 | (frag-push-byte frag (ldb (byte 8 40) w))
|
|---|
| 151 | (frag-push-byte frag (ldb (byte 8 48) w))
|
|---|
| 152 | (frag-push-byte frag (ldb (byte 8 56) w))
|
|---|
| 153 | w))
|
|---|
| 154 |
|
|---|
| 155 | ;;; Returns the length of the current frag
|
|---|
| 156 | (defun frag-list-position (frag-list)
|
|---|
| 157 | (frag-length (frag-list-current frag-list)))
|
|---|
| 158 |
|
|---|
| 159 | (defun frag-output-bytes (frag target target-offset)
|
|---|
| 160 | (let* ((buffer (frag-code-buffer frag))
|
|---|
| 161 | (n (frag-length frag))
|
|---|
| 162 | (remain n))
|
|---|
| 163 | (loop
|
|---|
| 164 | (when (zerop remain) (return n))
|
|---|
| 165 | (let* ((v (pop buffer))
|
|---|
| 166 | (len (length v))
|
|---|
| 167 | (nout (min remain len)))
|
|---|
| 168 | (%copy-ivector-to-ivector v
|
|---|
| 169 | 0
|
|---|
| 170 | target
|
|---|
| 171 | target-offset
|
|---|
| 172 | nout)
|
|---|
| 173 | (incf target-offset nout)
|
|---|
| 174 | (decf remain nout)))))
|
|---|
| 175 |
|
|---|
| 176 | (defun make-frag ()
|
|---|
| 177 | (let* ((frag (alloc-dll-node *frag-freelist*)))
|
|---|
| 178 | (if frag
|
|---|
| 179 | (let* ((buffer (frag-code-buffer frag)))
|
|---|
| 180 | (when buffer
|
|---|
| 181 | (setf (frag-length frag) 0))
|
|---|
| 182 | (setf (frag-address frag) nil
|
|---|
| 183 | (frag-last-address frag) nil
|
|---|
| 184 | (frag-type frag) nil
|
|---|
| 185 | (frag-relocs frag) nil
|
|---|
| 186 | (frag-labels frag) nil)
|
|---|
| 187 | frag)
|
|---|
| 188 | (%make-frag))))
|
|---|
| 189 |
|
|---|
| 190 |
|
|---|
| 191 | ;;; Intentionally very similar to RISC-LAP, but with some extensions
|
|---|
| 192 | ;;; to deal with alignment and with variable-length and/or span-
|
|---|
| 193 | ;;; dependent instructions.
|
|---|
| 194 |
|
|---|
| 195 | (defvar *x86-lap-labels* ())
|
|---|
| 196 | (defvar *x86-lap-constants* ())
|
|---|
| 197 | (defparameter *x86-lap-entry-offset* 15)
|
|---|
| 198 | (defparameter *x86-lap-fixed-code-words* nil)
|
|---|
| 199 | (defvar *x86-lap-macros* (make-hash-table :test #'equalp))
|
|---|
| 200 | (defvar *x86-lap-lfun-bits* 0)
|
|---|
| 201 |
|
|---|
| 202 |
|
|---|
| 203 |
|
|---|
| 204 | (defun x86-lap-macro-function (name)
|
|---|
| 205 | (gethash (string name) #|(backend-lap-macros *target-backend*)|#
|
|---|
| 206 | *x86-lap-macros*))
|
|---|
| 207 |
|
|---|
| 208 | (defun (setf x86-lap-macro-function) (def name)
|
|---|
| 209 | (let* ((s (string name)))
|
|---|
| 210 | (when (gethash s x86::*x86-opcode-template-lists*)
|
|---|
| 211 | (error "~s already defines an x86 instruction . " name))
|
|---|
| 212 | (setf (gethash s *x86-lap-macros* #|(backend-lap-macros *x86-backend*)|#) def)))
|
|---|
| 213 |
|
|---|
| 214 | (defmacro defx86lapmacro (name arglist &body body)
|
|---|
| 215 | `(progn
|
|---|
| 216 | (setf (x86-lap-macro-function ',name)
|
|---|
| 217 | (nfunction (x86-lap-macro ,name) ,(ccl::parse-macro name arglist body)))
|
|---|
| 218 | (record-source-file ',name 'x86-lap)
|
|---|
| 219 | ',name))
|
|---|
| 220 |
|
|---|
| 221 | (defun x86-lap-macroexpand-1 (form)
|
|---|
| 222 | (unless (and (consp form) (atom (car form)))
|
|---|
| 223 | (values form nil))
|
|---|
| 224 | (let* ((expander (x86-lap-macro-function (car form))))
|
|---|
| 225 | (if expander
|
|---|
| 226 | (values (funcall expander form nil) t)
|
|---|
| 227 | (values form nil))))
|
|---|
| 228 |
|
|---|
| 229 |
|
|---|
| 230 | (defmethod print-object ((l x86-lap-label) stream)
|
|---|
| 231 | (print-unreadable-object (l stream :type t)
|
|---|
| 232 | (format stream "~a" (x86-lap-label-name l))))
|
|---|
| 233 |
|
|---|
| 234 | ;;; Labels
|
|---|
| 235 |
|
|---|
| 236 | (defun %make-x86-lap-label (name)
|
|---|
| 237 | (let* ((lab (alloc-dll-node *x86-lap-label-freelist*)))
|
|---|
| 238 | (if lab
|
|---|
| 239 | (progn
|
|---|
| 240 | (setf (x86-lap-label-frag lab) nil
|
|---|
| 241 | (x86-lap-label-offset lab) nil
|
|---|
| 242 | (x86-lap-label-name lab) name)
|
|---|
| 243 | lab)
|
|---|
| 244 | (%%make-x86-lap-label name))))
|
|---|
| 245 |
|
|---|
| 246 | (defun make-x86-lap-label (name)
|
|---|
| 247 | (let* ((lab (%make-x86-lap-label name)))
|
|---|
| 248 | (if (typep *x86-lap-labels* 'hash-table)
|
|---|
| 249 | (setf (gethash name *x86-lap-labels*) lab)
|
|---|
| 250 | (progn
|
|---|
| 251 | (push lab *x86-lap-labels*)
|
|---|
| 252 | (if (> (length *x86-lap-labels*) 255)
|
|---|
| 253 | (let* ((hash (make-hash-table :size 512 :test #'eq)))
|
|---|
| 254 | (dolist (l *x86-lap-labels* (setq *x86-lap-labels* hash))
|
|---|
| 255 | (setf (gethash (x86-lap-label-name l) hash) l))))))
|
|---|
| 256 | lab))
|
|---|
| 257 |
|
|---|
| 258 | (defun find-x86-lap-label (name)
|
|---|
| 259 | (if (typep *x86-lap-labels* 'hash-table)
|
|---|
| 260 | (gethash name *x86-lap-labels*)
|
|---|
| 261 | (car (member name *x86-lap-labels* :test #'eq :key #'x86-lap-label-name))))
|
|---|
| 262 |
|
|---|
| 263 | (defun find-or-create-x86-lap-label (name)
|
|---|
| 264 | (or (find-x86-lap-label name)
|
|---|
| 265 | (make-x86-lap-label name)))
|
|---|
| 266 |
|
|---|
| 267 |
|
|---|
| 268 | ;;; A label can only be emitted once. Once it's been emitted, its frag
|
|---|
| 269 | ;;; slot will be non-nil.
|
|---|
| 270 |
|
|---|
| 271 | (defun x86-lap-label-emitted-p (lab)
|
|---|
| 272 | (not (null (x86-lap-label-frag lab))))
|
|---|
| 273 |
|
|---|
| 274 | (defun emit-x86-lap-label (frag-list name)
|
|---|
| 275 | (let* ((lab (find-or-create-x86-lap-label name))
|
|---|
| 276 | (current (frag-list-current frag-list)))
|
|---|
| 277 | (when (x86-lap-label-emitted-p lab)
|
|---|
| 278 | (error "Label ~s: multiply defined." name))
|
|---|
| 279 | (setf (x86-lap-label-frag lab) current
|
|---|
| 280 | (x86-lap-label-offset lab) (frag-list-position frag-list))
|
|---|
| 281 | (push lab (frag-labels current))
|
|---|
| 282 | lab))
|
|---|
| 283 |
|
|---|
| 284 |
|
|---|
| 285 |
|
|---|
| 286 |
|
|---|
| 287 |
|
|---|
| 288 | (defstruct reloc
|
|---|
| 289 | type ; a keyword
|
|---|
| 290 | arg ; a label-operand or an expression, etc.
|
|---|
| 291 | frag ; the (redundant) containing frag
|
|---|
| 292 | pos ; octet position withing frag
|
|---|
| 293 | )
|
|---|
| 294 |
|
|---|
| 295 |
|
|---|
| 296 |
|
|---|
| 297 |
|
|---|
| 298 | (defstruct (frag-list (:include ccl::dll-header)))
|
|---|
| 299 |
|
|---|
| 300 | ;;; ccl::dll-header-last is unit-time
|
|---|
| 301 | (defun frag-list-current (frag-list)
|
|---|
| 302 | (ccl::dll-header-last frag-list))
|
|---|
| 303 |
|
|---|
| 304 | ;;; Add a new (empty) frag to the end of FRAG-LIST and make the new frag
|
|---|
| 305 | ;;; current
|
|---|
| 306 | (defun new-frag (frag-list)
|
|---|
| 307 | (ccl::append-dll-node (make-frag) frag-list))
|
|---|
| 308 |
|
|---|
| 309 | ;;; Make a frag list, and make an empty frag be its current frag.
|
|---|
| 310 | (defun make-frag-list ()
|
|---|
| 311 | (let* ((header (ccl::make-dll-header)))
|
|---|
| 312 | (new-frag header)
|
|---|
| 313 | header))
|
|---|
| 314 |
|
|---|
| 315 |
|
|---|
| 316 |
|
|---|
| 317 | ;;; Finish the current frag, marking it as containing a PC-relative
|
|---|
| 318 | ;;; branch to the indicated label, with a one-byte opcode and
|
|---|
| 319 | ;;; one byte of displacement.
|
|---|
| 320 | (defun finish-frag-for-branch (frag-list opcode label)
|
|---|
| 321 | (let* ((frag (frag-list-current frag-list)))
|
|---|
| 322 | (frag-push-byte frag opcode)
|
|---|
| 323 | (let* ((pos (frag-length frag))
|
|---|
| 324 | (reloc (make-reloc :type :branch8
|
|---|
| 325 | :arg label
|
|---|
| 326 | :pos pos)))
|
|---|
| 327 | (push reloc (frag-relocs frag))
|
|---|
| 328 | (frag-push-byte frag 0)
|
|---|
| 329 | (setf (frag-type frag) (list (if (eql opcode #xeb)
|
|---|
| 330 | :assumed-short-branch
|
|---|
| 331 | :assumed-short-conditional-branch)
|
|---|
| 332 | label
|
|---|
| 333 | pos
|
|---|
| 334 | reloc))
|
|---|
| 335 | (new-frag frag-list))))
|
|---|
| 336 |
|
|---|
| 337 | ;;; Mark the current frag as -ending- with an align directive.
|
|---|
| 338 | ;;; p2align is the power of 2 at which code in the next frag
|
|---|
| 339 | ;;; should be aligned.
|
|---|
| 340 | ;;; Start a new frag.
|
|---|
| 341 | (defun finish-frag-for-align (frag-list p2align)
|
|---|
| 342 | (let* ((frag (frag-list-current frag-list)))
|
|---|
| 343 | (setf (frag-type frag) (list :align p2align))
|
|---|
| 344 | (new-frag frag-list)))
|
|---|
| 345 |
|
|---|
| 346 | ;;; Make the current frag be of type :talign; set that frag-type's
|
|---|
| 347 | ;;; argument to NIL initially. Start a new frag of type :pending-talign;
|
|---|
| 348 | ;;; that frag will contain at most one instruction. When an
|
|---|
| 349 | ;;; instuction is ouput in the pending-talign frag, adjust the preceding
|
|---|
| 350 | ;;; :talign frag's argument and set the type of the :pending-talign
|
|---|
| 351 | ;;; frag to NIL. (The :talign frag will have 0-7 NOPs of some form
|
|---|
| 352 | ;;; appended to it, so the first instruction in the successor will end
|
|---|
| 353 | ;;; on an address that matches the argument below.)
|
|---|
| 354 | ;;; That instruction can not be a relaxable branch.
|
|---|
| 355 | (defun finish-frag-for-talign (frag-list arg)
|
|---|
| 356 | (let* ((current (frag-list-current frag-list))
|
|---|
| 357 | (new (new-frag frag-list)))
|
|---|
| 358 | (setf (frag-type current) (list :talign nil))
|
|---|
| 359 | (setf (frag-type new) (list :pending-talign arg))))
|
|---|
| 360 |
|
|---|
| 361 | ;;; Having generated an instruction in a :pending-talign frag, set the
|
|---|
| 362 | ;;; frag-type argument of the preceding :talign frag to the :pendint-talign
|
|---|
| 363 | ;;; frag's argument - the length of the pending-talign's first instruction
|
|---|
| 364 | ;;; mod 8, and clear the type of the "pending" frag.
|
|---|
| 365 | ;;; cadr of the frag-type
|
|---|
| 366 | (defun finish-pending-talign-frag (frag-list)
|
|---|
| 367 | (let* ((frag (frag-list-current frag-list))
|
|---|
| 368 | (pred (frag-pred frag))
|
|---|
| 369 | (arg (cadr (frag-type frag)))
|
|---|
| 370 | (pred-arg (frag-type pred)))
|
|---|
| 371 | (setf (cadr pred-arg) (logand 7 (- arg (frag-length frag)))
|
|---|
| 372 | (frag-type frag) nil)
|
|---|
| 373 | (new-frag frag-list)))
|
|---|
| 374 |
|
|---|
| 375 | (defun finish-frag-for-org (frag-list org)
|
|---|
| 376 | (let* ((frag (frag-list-current frag-list)))
|
|---|
| 377 | (setf (frag-type frag) (list :org org))
|
|---|
| 378 | (new-frag frag-list)))
|
|---|
| 379 |
|
|---|
| 380 |
|
|---|
| 381 | (defun lookup-x86-register (regname designator)
|
|---|
| 382 | (let* ((r (typecase regname
|
|---|
| 383 | (symbol (or (gethash (string regname) x86::*x86-registers*)
|
|---|
| 384 | (if (eq regname :rcontext)
|
|---|
| 385 | (svref x86::*x8664-register-entries*
|
|---|
| 386 | (ccl::backend-lisp-context-register *target-backend*)))
|
|---|
| 387 | (and (boundp regname)
|
|---|
| 388 | (let* ((val (symbol-value regname)))
|
|---|
| 389 | (and (typep val 'fixnum)
|
|---|
| 390 | (>= val 0)
|
|---|
| 391 | (< val (length x86::*x8664-register-entries*))
|
|---|
| 392 | (svref x86::*x8664-register-entries* val))))))
|
|---|
| 393 | (string (gethash regname x86::*x86-registers*))
|
|---|
| 394 | (fixnum (if (and (typep regname 'fixnum)
|
|---|
| 395 | (>= regname 0)
|
|---|
| 396 | (< regname (length x86::*x8664-register-entries*)))
|
|---|
| 397 | (svref x86::*x8664-register-entries* regname))))))
|
|---|
| 398 |
|
|---|
| 399 | (when r
|
|---|
| 400 | (if (eq designator :%)
|
|---|
| 401 | r
|
|---|
| 402 | (let* ((regtype (x86::reg-entry-reg-type r)))
|
|---|
| 403 | (unless (logtest regtype (x86::encode-operand-type :reg8 :reg16 :reg32 :reg64))
|
|---|
| 404 | (error "Designator ~a can't be used with register ~a"
|
|---|
| 405 | designator (x86::reg-entry-reg-name r)))
|
|---|
| 406 | (case designator
|
|---|
| 407 | (:%b (x86::x86-reg8 r))
|
|---|
| 408 | (:%w (x86::x86-reg16 r))
|
|---|
| 409 | (:%l (x86::x86-reg32 r))
|
|---|
| 410 | (:%q (x86::x86-reg64 r))))))))
|
|---|
| 411 |
|
|---|
| 412 | (defun x86-register-ordinal-or-expression (form)
|
|---|
| 413 | (let* ((r (if (typep form 'symbol)
|
|---|
| 414 | (lookup-x86-register form :%))))
|
|---|
| 415 | (if r
|
|---|
| 416 | (x86::reg-entry-ordinal64 r)
|
|---|
| 417 | (multiple-value-bind (val condition)
|
|---|
| 418 | (ignore-errors (eval form))
|
|---|
| 419 | (if condition
|
|---|
| 420 | (error "Condition ~a signaled during assembly-time evalation of ~s."
|
|---|
| 421 | condition form)
|
|---|
| 422 | val)))))
|
|---|
| 423 |
|
|---|
| 424 |
|
|---|
| 425 | ;;; It may seem strange to have an expression language in a lisp-based
|
|---|
| 426 | ;;; assembler, since lisp is itself a fairly reasonable expression
|
|---|
| 427 | ;;; language and EVAL is (in this context, at least) an adequate evaluation
|
|---|
| 428 | ;;; mechanism. This may indeed be overkill, but there are reasons for
|
|---|
| 429 | ;;; wanting something beyond EVAL.
|
|---|
| 430 | ;;; This assumes that any expression that doesn't involve label addresses
|
|---|
| 431 | ;;; will always evaluate to the same value (in "the same" execution context).
|
|---|
| 432 | ;;; Expressions that do involve label references might only be evaluable
|
|---|
| 433 | ;;; after all labels are defined, and the value of such an expression may
|
|---|
| 434 | ;;; change (as label addresses are adjusted.)
|
|---|
| 435 |
|
|---|
| 436 | ;;; A "label address expression" looks like (:^ lab), syntactically. Tree-walk
|
|---|
| 437 | ;;; FORM, and return T if it contains a label address expression.
|
|---|
| 438 |
|
|---|
| 439 | (defun label-address-expression-p (form)
|
|---|
| 440 | (and (consp form)
|
|---|
| 441 | (eq (car form) :^)
|
|---|
| 442 | (consp (cdr form))
|
|---|
| 443 | (null (cddr form))))
|
|---|
| 444 |
|
|---|
| 445 | (defun contains-label-address-expression (form)
|
|---|
| 446 | (cond ((label-address-expression-p form) t)
|
|---|
| 447 | ((typep form 'application-x86-lap-expression) t)
|
|---|
| 448 | ((atom form) nil)
|
|---|
| 449 | (t (dolist (sub (cdr form))
|
|---|
| 450 | (when (contains-label-address-expression sub)
|
|---|
| 451 | (return t))))))
|
|---|
| 452 |
|
|---|
| 453 | (defstruct x86-lap-expression
|
|---|
| 454 | )
|
|---|
| 455 |
|
|---|
| 456 |
|
|---|
| 457 | (defstruct (label-x86-lap-expression (:include x86-lap-expression))
|
|---|
| 458 | label)
|
|---|
| 459 |
|
|---|
| 460 |
|
|---|
| 461 | ;;; Represents a constant
|
|---|
| 462 | (defstruct (constant-x86-lap-expression (:include x86-lap-expression))
|
|---|
| 463 | value)
|
|---|
| 464 |
|
|---|
| 465 |
|
|---|
| 466 |
|
|---|
| 467 | ;;; Also support 0, 1, 2, and many args, where at least one of those args
|
|---|
| 468 | ;;; is or contains a label reference.
|
|---|
| 469 | (defstruct (application-x86-lap-expression (:include x86-lap-expression))
|
|---|
| 470 | operator)
|
|---|
| 471 |
|
|---|
| 472 |
|
|---|
| 473 | (defstruct (unary-x86-lap-expression (:include application-x86-lap-expression))
|
|---|
| 474 | operand)
|
|---|
| 475 |
|
|---|
| 476 |
|
|---|
| 477 | (defstruct (binary-x86-lap-expression (:include application-x86-lap-expression))
|
|---|
| 478 | operand0
|
|---|
| 479 | operand1)
|
|---|
| 480 |
|
|---|
| 481 | (defstruct (n-ary-x86-lap-expression (:include application-x86-lap-expression))
|
|---|
| 482 | operands)
|
|---|
| 483 |
|
|---|
| 484 | ;;; Looks like a job for DEFMETHOD.
|
|---|
| 485 | (defun x86-lap-expression-value (exp)
|
|---|
| 486 | (typecase exp
|
|---|
| 487 | (label-x86-lap-expression (- (x86-lap-label-address (label-x86-lap-expression-label exp)) *x86-lap-entry-offset*))
|
|---|
| 488 | (unary-x86-lap-expression (funcall (unary-x86-lap-expression-operator exp)
|
|---|
| 489 | (x86-lap-expression-value (unary-x86-lap-expression-operand exp))))
|
|---|
| 490 | (binary-x86-lap-expression (funcall (binary-x86-lap-expression-operator exp)
|
|---|
| 491 | (x86-lap-expression-value (binary-x86-lap-expression-operand0 exp))
|
|---|
| 492 | (x86-lap-expression-value (binary-x86-lap-expression-operand1 exp))))
|
|---|
| 493 | (n-ary-x86-lap-expression (apply (n-ary-x86-lap-expression-operator exp)
|
|---|
| 494 | (mapcar #'x86-lap-expression-value (n-ary-x86-lap-expression-operands exp))))
|
|---|
| 495 | (constant-x86-lap-expression (constant-x86-lap-expression-value exp))
|
|---|
| 496 | (t exp)))
|
|---|
| 497 |
|
|---|
| 498 | ;;; Expression might contain unresolved labels. Return nil if so (even
|
|---|
| 499 | ;;; if everything -could- be resolved.)
|
|---|
| 500 | (defun early-x86-lap-expression-value (expression)
|
|---|
| 501 | (typecase expression
|
|---|
| 502 | (constant-x86-lap-expression (constant-x86-lap-expression-value expression))
|
|---|
| 503 | (x86-lap-expression nil)
|
|---|
| 504 | (t expression)))
|
|---|
| 505 |
|
|---|
| 506 | (define-condition undefined-x86-lap-label (simple-program-error)
|
|---|
| 507 | ((label-name :initarg :label-name))
|
|---|
| 508 | (:report (lambda (c s)
|
|---|
| 509 | (format s "Label ~s was referenced but not defined."
|
|---|
| 510 | (slot-value c 'label-name)))))
|
|---|
| 511 |
|
|---|
| 512 | (defun x86-lap-label-address (lab)
|
|---|
| 513 | (let* ((frag (or (x86-lap-label-frag lab)
|
|---|
| 514 | (error 'undefined-x86-lap-label :label-name (x86-lap-label-name lab)))))
|
|---|
| 515 | (+ (frag-address frag)
|
|---|
| 516 | (x86-lap-label-offset lab))))
|
|---|
| 517 |
|
|---|
| 518 |
|
|---|
| 519 | (defun ensure-x86-lap-constant-label (val)
|
|---|
| 520 | (or (cdr (assoc val *x86-lap-constants*
|
|---|
| 521 | :test #'eq))
|
|---|
| 522 | (let* ((label (make-x86-lap-label
|
|---|
| 523 | (gensym)))
|
|---|
| 524 | (pair (cons val label)))
|
|---|
| 525 | (push pair *x86-lap-constants*)
|
|---|
| 526 | label)))
|
|---|
| 527 |
|
|---|
| 528 | (defun parse-x86-lap-expression (form)
|
|---|
| 529 | (if (typep form 'x86-lap-expression)
|
|---|
| 530 | form
|
|---|
| 531 | (progn
|
|---|
| 532 | (when (quoted-form-p form)
|
|---|
| 533 | (let* ((val (cadr form)))
|
|---|
| 534 | (if (typep val 'fixnum)
|
|---|
| 535 | (setq form (ash val 3 #|x8664::fixnumshift|#))
|
|---|
| 536 | (let* ((constant-label (ensure-x86-lap-constant-label val )))
|
|---|
| 537 | (setq form `(:^ ,(x86-lap-label-name constant-label)))))))
|
|---|
| 538 | (if (null form)
|
|---|
| 539 | (setq form (arch::target-nil-value (backend-target-arch *target-backend*)))
|
|---|
| 540 | (if (eq form t)
|
|---|
| 541 | (setq form
|
|---|
| 542 | (+ (arch::target-nil-value (backend-target-arch *target-backend*))
|
|---|
| 543 | (arch::target-t-offset (backend-target-arch *target-backend*))))))
|
|---|
| 544 |
|
|---|
| 545 | (if (label-address-expression-p form)
|
|---|
| 546 | (make-label-x86-lap-expression :label (find-or-create-x86-lap-label (cadr form)))
|
|---|
| 547 | (if (contains-label-address-expression form)
|
|---|
| 548 | (destructuring-bind (op &rest args) form
|
|---|
| 549 | (case (length args)
|
|---|
| 550 | (1 (make-unary-x86-lap-expression :operator op :operand (parse-x86-lap-expression (car args))))
|
|---|
| 551 | (2 (make-binary-x86-lap-expression :operator op :operand0 (parse-x86-lap-expression (car args))
|
|---|
| 552 | :operand1 (parse-x86-lap-expression (cadr args))))
|
|---|
| 553 | (t (make-n-ary-x86-lap-expression :operator op :operands (mapcar #'parse-x86-lap-expression args)))))
|
|---|
| 554 | (multiple-value-bind (value condition)
|
|---|
| 555 | (ignore-errors
|
|---|
| 556 | (eval (if (atom form)
|
|---|
| 557 | form
|
|---|
| 558 | (cons (car form)
|
|---|
| 559 | (mapcar #'(lambda (x)
|
|---|
| 560 | (if (typep x 'constant-x86-lap-expression)
|
|---|
| 561 | (constant-x86-lap-expression-value
|
|---|
| 562 | x)
|
|---|
| 563 | x))
|
|---|
| 564 | (cdr form))))))
|
|---|
| 565 | (if condition
|
|---|
| 566 | (error "~a signaled during assembly-time evaluation of form ~s" condition form)
|
|---|
| 567 | value #|(make-constant-x86-lap-expression :value value)|#)))))))
|
|---|
| 568 |
|
|---|
| 569 | (defun parse-x86-register-operand (regname designator)
|
|---|
| 570 | (let* ((r (lookup-x86-register regname designator)))
|
|---|
| 571 | (if r
|
|---|
| 572 | (x86::make-x86-register-operand :type (logandc2 (x86::reg-entry-reg-type r)
|
|---|
| 573 | (x86::encode-operand-type :baseIndex))
|
|---|
| 574 | :entry r)
|
|---|
| 575 | (error "Unknown X86 register ~s" regname))))
|
|---|
| 576 |
|
|---|
| 577 | (defun parse-x86-label-reference (name)
|
|---|
| 578 | (let* ((lab (find-or-create-x86-lap-label name)))
|
|---|
| 579 | (x86::make-x86-label-operand :type (x86::encode-operand-type :label)
|
|---|
| 580 | :label lab)))
|
|---|
| 581 |
|
|---|
| 582 |
|
|---|
| 583 |
|
|---|
| 584 | (defun x86-register-designator (form)
|
|---|
| 585 | (when (and (consp form)
|
|---|
| 586 | (symbolp (car form)))
|
|---|
| 587 | (let* ((sym (car form)))
|
|---|
| 588 | (cond ((string= sym '%) :%)
|
|---|
| 589 | ((string= sym '%b) :%b)
|
|---|
| 590 | ((string= sym '%w) :%w)
|
|---|
| 591 | ((string= sym '%l) :%l)
|
|---|
| 592 | ((string= sym '%q) :%q)))))
|
|---|
| 593 |
|
|---|
| 594 |
|
|---|
| 595 | ;;; Syntax is:
|
|---|
| 596 | ;;; ([seg] [disp] [base] [index] [scale])
|
|---|
| 597 | ;;; A [seg] by itself isn't too meaningful; the same is true
|
|---|
| 598 | ;;; of a few other combinations.
|
|---|
| 599 | (defun parse-x86-memory-operand (form)
|
|---|
| 600 | (flet ((register-operand-p (form)
|
|---|
| 601 | (let* ((designator (x86-register-designator form)))
|
|---|
| 602 | (when designator
|
|---|
| 603 | (destructuring-bind (regname) (cdr form)
|
|---|
| 604 | (or (lookup-x86-register regname designator)
|
|---|
| 605 | (error "Unknown register ~s" regname)))))))
|
|---|
| 606 | (let* ((seg nil)
|
|---|
| 607 | (disp nil)
|
|---|
| 608 | (base nil)
|
|---|
| 609 | (index nil)
|
|---|
| 610 | (scale nil))
|
|---|
| 611 | (do* ((f form (cdr f)))
|
|---|
| 612 | ((null f)
|
|---|
| 613 | (if (or disp base index)
|
|---|
| 614 | (progn
|
|---|
| 615 | ;;(check-base-and-index-regs instruction base index)
|
|---|
| 616 | (x86::make-x86-memory-operand
|
|---|
| 617 | :type (if (or base index)
|
|---|
| 618 | (if disp
|
|---|
| 619 | (logior (optimize-displacement-type disp)
|
|---|
| 620 | (x86::encode-operand-type :baseindex))
|
|---|
| 621 | (x86::encode-operand-type :baseindex))
|
|---|
| 622 | (optimize-displacement-type disp))
|
|---|
| 623 | :seg seg
|
|---|
| 624 | :disp disp
|
|---|
| 625 | :base base
|
|---|
| 626 | :index index
|
|---|
| 627 | :scale scale))
|
|---|
| 628 | (error "No displacement, base, or index in ~s" form)))
|
|---|
| 629 | (let* ((head (car f))
|
|---|
| 630 | (r (register-operand-p head)))
|
|---|
| 631 | (if r
|
|---|
| 632 | (if (logtest (x86::reg-entry-reg-type r)
|
|---|
| 633 | (x86::encode-operand-type :sreg2 :sreg3))
|
|---|
| 634 | ;; A segment register - if present - must be first
|
|---|
| 635 | (if (eq f form)
|
|---|
| 636 | (setq seg (svref x86::*x86-seg-entries* (x86::reg-entry-reg-num r)))
|
|---|
| 637 | (error "Segment register ~s not valid in ~s" form))
|
|---|
| 638 | ;; Some other register. Assume base if this is the
|
|---|
| 639 | ;; first gpr. If we find only one gpr and a significant
|
|---|
| 640 | ;; scale factor, make that single gpr be the index.
|
|---|
| 641 | (if base
|
|---|
| 642 | (if index
|
|---|
| 643 | (error "Extra register ~s in memory address ~s" head form)
|
|---|
| 644 | (setq index r))
|
|---|
| 645 | (setq base r)))
|
|---|
| 646 | ;; Not a register, so head is either a displacement or
|
|---|
| 647 | ;; a scale factor.
|
|---|
| 648 | (if (and (null (cdr f))
|
|---|
| 649 | (or disp base index))
|
|---|
| 650 | (let* ((exp (parse-x86-lap-expression head))
|
|---|
| 651 | (val (if (or (typep exp 'constant-x86-lap-expression)
|
|---|
| 652 | (not (x86-lap-expression-p exp)))
|
|---|
| 653 | (x86-lap-expression-value exp))))
|
|---|
| 654 | (case val
|
|---|
| 655 | ((1 2 4 8)
|
|---|
| 656 | (if (and base (not index))
|
|---|
| 657 | (setq index base base nil))
|
|---|
| 658 | (setq scale (1- (integer-length val))))
|
|---|
| 659 | (t
|
|---|
| 660 | (error "Invalid scale factor ~s in ~s" head form))))
|
|---|
| 661 | (if (not (or disp base index))
|
|---|
| 662 | (setq disp (parse-x86-lap-expression head))
|
|---|
| 663 | (error "~& not expected in ~s" head form)))))))))
|
|---|
| 664 |
|
|---|
| 665 |
|
|---|
| 666 |
|
|---|
| 667 |
|
|---|
| 668 | ;;; Operand syntax:
|
|---|
| 669 | ;;; (% x) -> register
|
|---|
| 670 | ;;; ($ x) -> immediate
|
|---|
| 671 | ;;; (@ x) -> memory operand
|
|---|
| 672 | ;;; x -> labelref
|
|---|
| 673 | (defun parse-x86-operand (form)
|
|---|
| 674 | (if (consp form)
|
|---|
| 675 | (let* ((head (car form))
|
|---|
| 676 | (designator nil))
|
|---|
| 677 | (if (symbolp head)
|
|---|
| 678 | (cond ((string= head '$)
|
|---|
| 679 | (destructuring-bind (immval) (cdr form)
|
|---|
| 680 | (let* ((expr (parse-x86-lap-expression immval))
|
|---|
| 681 | (val (early-x86-lap-expression-value expr))
|
|---|
| 682 | (type (if val
|
|---|
| 683 | (smallest-imm-type val)
|
|---|
| 684 | (x86::encode-operand-type :imm32s))))
|
|---|
| 685 | (x86::make-x86-immediate-operand :type type
|
|---|
| 686 | :value expr))))
|
|---|
| 687 | ((setq designator (x86-register-designator form))
|
|---|
| 688 | (destructuring-bind (reg) (cdr form)
|
|---|
| 689 | (parse-x86-register-operand reg designator)))
|
|---|
| 690 | ((string= head '@)
|
|---|
| 691 | (parse-x86-memory-operand (cdr form)))
|
|---|
| 692 | (t (error "unknown X86 operand: ~s" form)))
|
|---|
| 693 | (error "unknown X86 operand: ~s" form)))
|
|---|
| 694 | ;; Treat an atom as a label.
|
|---|
| 695 | (parse-x86-label-reference form)))
|
|---|
| 696 |
|
|---|
| 697 |
|
|---|
| 698 |
|
|---|
| 699 |
|
|---|
| 700 | ;;; Initialize some fields in the instruction from the template;
|
|---|
| 701 | ;;; set other fields (which depend on operand values) to NIL.
|
|---|
| 702 | (defun set-x86-instruction-template (i template)
|
|---|
| 703 | (setf (x86::x86-instruction-opcode-template i) template
|
|---|
| 704 | (x86::x86-instruction-base-opcode i) (x86::x86-opcode-template-base-opcode template)
|
|---|
| 705 | (x86::x86-instruction-modrm-byte i) (x86::x86-opcode-template-modrm-byte template)
|
|---|
| 706 | (x86::x86-instruction-rex-prefix i) (x86::x86-opcode-template-rex-prefix template)
|
|---|
| 707 | (x86::x86-instruction-sib-byte i) nil
|
|---|
| 708 | (x86::x86-instruction-seg-prefix i) nil
|
|---|
| 709 | (x86::x86-instruction-disp i) nil
|
|---|
| 710 | (x86::x86-instruction-imm i) nil
|
|---|
| 711 | (x86::x86-instruction-extra i) nil))
|
|---|
| 712 |
|
|---|
| 713 |
|
|---|
| 714 | (defun init-x86-instruction (instruction template parsed-operands)
|
|---|
| 715 | (set-x86-instruction-template instruction template)
|
|---|
| 716 | (let* ((insert-classes (x86::x86-opcode-template-operand-classes template))
|
|---|
| 717 | (insert-functions x86::*x86-operand-insert-functions*))
|
|---|
| 718 | (dotimes (i (length parsed-operands) instruction)
|
|---|
| 719 | (funcall (svref insert-functions (svref insert-classes i))
|
|---|
| 720 | instruction
|
|---|
| 721 | (pop parsed-operands)))))
|
|---|
| 722 |
|
|---|
| 723 |
|
|---|
| 724 |
|
|---|
| 725 | (defun smallest-imm-type (val)
|
|---|
| 726 | (if (eql val 1)
|
|---|
| 727 | (x86::encode-operand-type :Imm1 :Imm8 :Imm8S :Imm16 :Imm32 :Imm32S :Imm64)
|
|---|
| 728 | (typecase val
|
|---|
| 729 | ((signed-byte 8)
|
|---|
| 730 | (x86::encode-operand-type :Imm8S :imm8 :Imm16 :Imm32 :Imm32S :Imm64))
|
|---|
| 731 | ((unsigned-byte 8)
|
|---|
| 732 | (x86::encode-operand-type :imm8 :Imm16 :Imm32 :Imm32S :Imm64))
|
|---|
| 733 | ((signed-byte 16)
|
|---|
| 734 | (x86::encode-operand-type :Imm16 :Imm32 :Imm32S :Imm64))
|
|---|
| 735 | ((unsigned-byte 16)
|
|---|
| 736 | (x86::encode-operand-type :Imm16 :Imm32 :Imm32S :Imm64))
|
|---|
| 737 | ((signed-byte 32)
|
|---|
| 738 | (x86::encode-operand-type :Imm32 :Imm32S :Imm64))
|
|---|
| 739 | ((unsigned-byte 32)
|
|---|
| 740 | (x86::encode-operand-type :Imm32 :Imm64))
|
|---|
| 741 | (t (x86::encode-operand-type :Imm64)))))
|
|---|
| 742 |
|
|---|
| 743 |
|
|---|
| 744 | (defun x86-optimize-imm (operands suffix)
|
|---|
| 745 | (unless suffix
|
|---|
| 746 | ;; See if we can determine an implied suffix from operands.
|
|---|
| 747 | (do* ((i (1- (length operands)) (1- i)))
|
|---|
| 748 | ((< i 0))
|
|---|
| 749 | (declare (fixnum i))
|
|---|
| 750 | (let* ((op (svref operands i))
|
|---|
| 751 | (optype (x86::x86-operand-type op)))
|
|---|
| 752 | (when (logtest optype (x86::encode-operand-type :reg))
|
|---|
| 753 | (cond ((logtest optype (x86::encode-operand-type :reg8))
|
|---|
| 754 | (setq suffix #\b))
|
|---|
| 755 | ((logtest optype (x86::encode-operand-type :reg16))
|
|---|
| 756 | (setq suffix #\w))
|
|---|
| 757 | ((logtest optype (x86::encode-operand-type :reg32))
|
|---|
| 758 | (setq suffix #\l))
|
|---|
| 759 | ((logtest optype (x86::encode-operand-type :reg64))
|
|---|
| 760 | (setq suffix #\q)))
|
|---|
| 761 | (return)))))
|
|---|
| 762 | (dotimes (i (length operands))
|
|---|
| 763 | (let* ((op (svref operands i))
|
|---|
| 764 | (optype (x86::x86-operand-type op)))
|
|---|
| 765 | (when (logtest optype (x86::encode-operand-type :imm))
|
|---|
| 766 | (let* ((val (x86::x86-immediate-operand-value op)))
|
|---|
| 767 | (cond ((typep val 'constant-x86-lap-expression)
|
|---|
| 768 | (case suffix
|
|---|
| 769 | (#\l (setf (x86::x86-operand-type op)
|
|---|
| 770 | (logior optype (x86::encode-operand-type
|
|---|
| 771 | :imm32 :imm64))))
|
|---|
| 772 | (#\w (setf (x86::x86-operand-type op)
|
|---|
| 773 | (logior optype (x86::encode-operand-type
|
|---|
| 774 | :imm16 :imm32S :imm32 :imm64))))
|
|---|
| 775 | (#\b (setf (x86::x86-operand-type op)
|
|---|
| 776 | (logior optype (x86::encode-operand-type
|
|---|
| 777 | :imm8 :imm16 :imm32S :imm32 :imm64)))))
|
|---|
| 778 | (setf (x86::x86-operand-type op)
|
|---|
| 779 | (logior (x86::x86-operand-type op)
|
|---|
| 780 | (smallest-imm-type (x86-lap-expression-value val))))
|
|---|
| 781 | (when (eql suffix #\q)
|
|---|
| 782 | (setf (x86::x86-operand-type op)
|
|---|
| 783 | (logandc2 (x86::x86-operand-type op)
|
|---|
| 784 | (x86::encode-operand-type :imm32)))))
|
|---|
| 785 | (t ; immediate value not constant
|
|---|
| 786 | (case suffix
|
|---|
| 787 | (#\q (setf (x86::x86-operand-type op)
|
|---|
| 788 | (logior optype
|
|---|
| 789 | (x86::encode-operand-type :imm64 :imm32S))))
|
|---|
| 790 | (#\l (setf (x86::x86-operand-type op)
|
|---|
| 791 | (logior optype
|
|---|
| 792 | (x86::encode-operand-type :imm32))))
|
|---|
| 793 | (#\w (setf (x86::x86-operand-type op)
|
|---|
| 794 | (logior optype
|
|---|
| 795 | (x86::encode-operand-type :imm16))))
|
|---|
| 796 | (#\b (setf (x86::x86-operand-type op)
|
|---|
| 797 | (logior optype
|
|---|
| 798 | (x86::encode-operand-type :imm8))))))))))))
|
|---|
| 799 |
|
|---|
| 800 | (defun get-x86-opcode-templates (form)
|
|---|
| 801 | (let* ((name (string (car form))))
|
|---|
| 802 | (or
|
|---|
| 803 | (gethash name x86::*x86-opcode-template-lists*)
|
|---|
| 804 | ;; Try to determine a suffix, based on the size of the last
|
|---|
| 805 | ;; register argument (if any.) If that can be determined,
|
|---|
| 806 | ;; tack it on to the end of NAME and try again.
|
|---|
| 807 | (let* ((suffix nil))
|
|---|
| 808 | (dolist (arg (cdr form))
|
|---|
| 809 | (let* ((designator (x86-register-designator arg)))
|
|---|
| 810 | (when designator
|
|---|
| 811 | (destructuring-bind (regname) (cdr arg)
|
|---|
| 812 | (let* ((reg (lookup-x86-register regname designator)))
|
|---|
| 813 | (when reg
|
|---|
| 814 | (let* ((type (x86::reg-entry-reg-type reg)))
|
|---|
| 815 | (cond ((logtest type (x86::encode-operand-type :reg8))
|
|---|
| 816 | (setq suffix #\b))
|
|---|
| 817 | ((logtest type (x86::encode-operand-type :reg16))
|
|---|
| 818 | (setq suffix #\w))
|
|---|
| 819 | ((logtest type (x86::encode-operand-type :reg32))
|
|---|
| 820 | (setq suffix #\l))
|
|---|
| 821 | ((logtest type (x86::encode-operand-type :reg64))
|
|---|
| 822 | (setq suffix #\q))))))))))
|
|---|
| 823 | (when suffix
|
|---|
| 824 | (let* ((n (length name))
|
|---|
| 825 | (m (1+ n))
|
|---|
| 826 | (s (make-string m)))
|
|---|
| 827 | (declare (fixnum n m) (dynamic-extent s))
|
|---|
| 828 | (dotimes (i n) (setf (schar s i) (char name i)))
|
|---|
| 829 | (setf (schar s n) suffix)
|
|---|
| 830 | (gethash s x86::*x86-opcode-template-lists*)))))))
|
|---|
| 831 |
|
|---|
| 832 |
|
|---|
| 833 |
|
|---|
| 834 |
|
|---|
| 835 |
|
|---|
| 836 | ;;; FORM is a list; its car doesn't name a macro or pseudo op. If we
|
|---|
| 837 | ;;; can find a matching opcode template, initialize the
|
|---|
| 838 | ;;; x86-instruction with that template and these operands.
|
|---|
| 839 | ;;; Note that this doesn't handle "prefix" instructions at all.
|
|---|
| 840 | ;;; Things that would change the operand or address size are
|
|---|
| 841 | ;;; of limited utility, as are REP* prefixes on string instructions
|
|---|
| 842 | ;;; (because of the way that the lisp used %[E|R]DI and %[E|R]SI).
|
|---|
| 843 | ;;; LOCK can be used in the preceding instruction.
|
|---|
| 844 | (defun parse-x86-instruction (form instruction)
|
|---|
| 845 | (let* ((templates (or
|
|---|
| 846 | (get-x86-opcode-templates form)
|
|---|
| 847 | (error "Unknown X86 instruction ~s" form)))
|
|---|
| 848 | (operands (cdr form)))
|
|---|
| 849 | (let* ((parsed-operands (if operands
|
|---|
| 850 | (mapcar #'parse-x86-operand operands)))
|
|---|
| 851 | (operand-types (mapcar #'x86::x86-operand-type parsed-operands))
|
|---|
| 852 | (type0 (pop operand-types))
|
|---|
| 853 | (type1 (pop operand-types))
|
|---|
| 854 | (type2 (car operand-types)))
|
|---|
| 855 |
|
|---|
| 856 | ;; (x86-optimize-imm parsed-operands suffix)
|
|---|
| 857 | (dolist (template templates (error "Operands or suffix invalid in ~s" form))
|
|---|
| 858 | (when (x86::match-template-types template type0 type1 type2)
|
|---|
| 859 | (init-x86-instruction instruction template parsed-operands)
|
|---|
| 860 | ;(check-suffix instruction form)
|
|---|
| 861 | ;(x86-finalize-operand-types instruction)
|
|---|
| 862 | (return instruction))))))
|
|---|
| 863 |
|
|---|
| 864 |
|
|---|
| 865 |
|
|---|
| 866 |
|
|---|
| 867 |
|
|---|
| 868 |
|
|---|
| 869 | (defun optimize-displacement-type (disp)
|
|---|
| 870 | (if disp
|
|---|
| 871 | (let* ((value (early-x86-lap-expression-value disp)))
|
|---|
| 872 | (if value
|
|---|
| 873 | (if (typep value '(signed-byte 8))
|
|---|
| 874 | (x86::encode-operand-type :disp8 :disp32 :disp32s :disp64)
|
|---|
| 875 | (if (typep value '(signed-byte 32))
|
|---|
| 876 | (x86::encode-operand-type :disp32s :disp64)
|
|---|
| 877 | (if (typep value '(unsigned-byte 32))
|
|---|
| 878 | (x86::encode-operand-type :disp32 :disp64)
|
|---|
| 879 | (x86::encode-operand-type :disp64))))
|
|---|
| 880 | (x86::encode-operand-type :disp32s :disp64)))
|
|---|
| 881 | 0))
|
|---|
| 882 |
|
|---|
| 883 | (defun optimize-displacements (operands)
|
|---|
| 884 | (dotimes (i (length operands))
|
|---|
| 885 | (let* ((op (svref operands i)))
|
|---|
| 886 | (when (typep op 'x86::x86-memory-operand)
|
|---|
| 887 | (let* ((disp (x86::x86-memory-operand-disp op))
|
|---|
| 888 | (val (if disp (early-x86-lap-expression-value disp))))
|
|---|
| 889 | (if (typep val '(signed-byte 32))
|
|---|
| 890 | (setf (x86::x86-operand-type op)
|
|---|
| 891 | (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp32s))))
|
|---|
| 892 | (if (typep val '(unsigned-byte 32))
|
|---|
| 893 | (setf (x86::x86-operand-type op)
|
|---|
| 894 | (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp32))))
|
|---|
| 895 | (if (and (logtest (x86::x86-operand-type op)
|
|---|
| 896 | (x86::encode-operand-type :disp32 :disp32S :disp16))
|
|---|
| 897 | (typep val '(signed-byte 8)))
|
|---|
| 898 | (setf (x86::x86-operand-type op)
|
|---|
| 899 | (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp8)))))))))
|
|---|
| 900 |
|
|---|
| 901 | (defun x86-output-branch (frag-list insn)
|
|---|
| 902 | (dolist (b (x86::x86-opcode-template-prefixes
|
|---|
| 903 | (x86::x86-instruction-opcode-template insn)))
|
|---|
| 904 | (when (or (= b x86::+data-prefix-opcode+)
|
|---|
| 905 | (= b x86::+cs-prefix-opcode+)
|
|---|
| 906 | (= b x86::+ds-prefix-opcode+))
|
|---|
| 907 | (frag-list-push-byte frag-list b)))
|
|---|
| 908 | (finish-frag-for-branch frag-list
|
|---|
| 909 | (x86::x86-instruction-base-opcode insn)
|
|---|
| 910 | (x86::x86-instruction-extra insn)))
|
|---|
| 911 |
|
|---|
| 912 |
|
|---|
| 913 | (defun x86-generate-instruction-code (frag-list insn)
|
|---|
| 914 | (let* ((template (x86::x86-instruction-opcode-template insn))
|
|---|
| 915 | (opcode-modifier (x86::x86-opcode-template-flags template))
|
|---|
| 916 | (prefixes (x86::x86-opcode-template-prefixes template)))
|
|---|
| 917 | (let* ((explicit-seg-prefix (x86::x86-instruction-seg-prefix insn)))
|
|---|
| 918 | (when explicit-seg-prefix
|
|---|
| 919 | (push explicit-seg-prefix prefixes)))
|
|---|
| 920 | (cond
|
|---|
| 921 | ((logtest (x86::encode-opcode-modifier :jump) opcode-modifier)
|
|---|
| 922 | ;; a variable-length pc-relative branch, possibly preceded
|
|---|
| 923 | ;; by prefixes (used for branch prediction, mostly.)
|
|---|
| 924 | (x86-output-branch frag-list insn))
|
|---|
| 925 | (t
|
|---|
| 926 | (let* ((base-opcode (x86::x86-instruction-base-opcode insn)))
|
|---|
| 927 | (declare (fixnum base-opcode))
|
|---|
| 928 | (dolist (b prefixes)
|
|---|
| 929 | (frag-list-push-byte frag-list b))
|
|---|
| 930 | (let* ((rex-bits (logand #x8f
|
|---|
| 931 | (or (x86::x86-instruction-rex-prefix insn)
|
|---|
| 932 | 0))))
|
|---|
| 933 | (declare (fixnum rex-bits))
|
|---|
| 934 | (unless (= 0 rex-bits)
|
|---|
| 935 | (frag-list-push-byte frag-list (logior #x40 (logand rex-bits #xf)))))
|
|---|
| 936 | (when (logtest base-opcode #xff00)
|
|---|
| 937 | (frag-list-push-byte frag-list (ldb (byte 8 8) base-opcode)))
|
|---|
| 938 | (frag-list-push-byte frag-list (ldb (byte 8 0) base-opcode)))
|
|---|
| 939 | (let* ((modrm (x86::x86-instruction-modrm-byte insn)))
|
|---|
| 940 | (when modrm
|
|---|
| 941 | (frag-list-push-byte frag-list modrm)
|
|---|
| 942 | (let* ((sib (x86::x86-instruction-sib-byte insn)))
|
|---|
| 943 | (when sib
|
|---|
| 944 | (frag-list-push-byte frag-list sib)))))
|
|---|
| 945 | (let* ((operands (x86::x86-opcode-template-operand-types template)))
|
|---|
| 946 | (if (and (= (length operands) 1)
|
|---|
| 947 | (= (x86::encode-operand-type :label) (aref operands 0)))
|
|---|
| 948 | (let* ((label (x86::x86-instruction-extra insn))
|
|---|
| 949 | (frag (frag-list-current frag-list))
|
|---|
| 950 | (pos (frag-list-position frag-list)))
|
|---|
| 951 | (push (make-reloc :type :branch32
|
|---|
| 952 | :arg label
|
|---|
| 953 | :frag frag
|
|---|
| 954 | :pos pos)
|
|---|
| 955 | (frag-relocs frag))
|
|---|
| 956 | (frag-list-push-32 frag-list 0))
|
|---|
| 957 | (let* ((disp (x86::x86-instruction-disp insn)))
|
|---|
| 958 | (when disp
|
|---|
| 959 | (let* ((optype (x86::x86-instruction-extra insn))
|
|---|
| 960 | (pcrel (and (logtest (x86::encode-operand-type :label) optype)
|
|---|
| 961 | (typep disp 'label-x86-lap-expression)))
|
|---|
| 962 | (val (unless pcrel (early-x86-lap-expression-value disp))))
|
|---|
| 963 | (if (null val)
|
|---|
| 964 | ;; We can do better job here, but (for now)
|
|---|
| 965 | ;; generate a 32-bit relocation
|
|---|
| 966 | (let* ((frag (frag-list-current frag-list))
|
|---|
| 967 | (pos (frag-list-position frag-list)))
|
|---|
| 968 | (push (make-reloc :type (if pcrel :branch32 :expr32)
|
|---|
| 969 | :arg (if pcrel (label-x86-lap-expression-label disp) disp)
|
|---|
| 970 | :frag frag
|
|---|
| 971 | :pos pos)
|
|---|
| 972 | (frag-relocs frag))
|
|---|
| 973 | (frag-list-push-32 frag-list 0))
|
|---|
| 974 | (if (logtest optype (x86::encode-operand-type :disp8))
|
|---|
| 975 | (frag-list-push-byte frag-list (logand val #xff))
|
|---|
| 976 | (if (logtest optype (x86::encode-operand-type :disp32 :disp32s))
|
|---|
| 977 | (frag-list-push-32 frag-list val)
|
|---|
| 978 | (frag-list-push-64 frag-list val)))))))))
|
|---|
| 979 | ;; Emit immediate operand(s).
|
|---|
| 980 | (let* ((op (x86::x86-instruction-imm insn)))
|
|---|
| 981 | (when op
|
|---|
| 982 | (let* ((optype (x86::x86-operand-type op))
|
|---|
| 983 | (expr (x86::x86-immediate-operand-value op))
|
|---|
| 984 | (val (early-x86-lap-expression-value expr)))
|
|---|
| 985 | (if (null val)
|
|---|
| 986 | (let* ((frag (frag-list-current frag-list))
|
|---|
| 987 | (pos (frag-list-position frag-list))
|
|---|
| 988 | (size 4)
|
|---|
| 989 | (reloctype :expr32))
|
|---|
| 990 | (when (logtest optype
|
|---|
| 991 | (x86::encode-operand-type
|
|---|
| 992 | :imm8 :imm8S :imm16 :imm64))
|
|---|
| 993 | (setq size 2 reloctype :expr16)
|
|---|
| 994 | (if (logtest optype (x86::encode-operand-type
|
|---|
| 995 | :imm8 :imm8s))
|
|---|
| 996 | (setq size 1 reloctype :expr8)
|
|---|
| 997 | (if (logtest optype (x86::encode-operand-type :imm64))
|
|---|
| 998 | (setq size 8 reloctype :expr64))))
|
|---|
| 999 | (push (make-reloc :type reloctype
|
|---|
| 1000 | :arg expr
|
|---|
| 1001 | :frag frag
|
|---|
| 1002 | :pos pos)
|
|---|
| 1003 | (frag-relocs frag))
|
|---|
| 1004 | (dotimes (b size)
|
|---|
| 1005 | (frag-list-push-byte frag-list 0)))
|
|---|
| 1006 | (if (logtest optype (x86::encode-operand-type :imm8 :imm8s))
|
|---|
| 1007 | (frag-list-push-byte frag-list (logand val #xff))
|
|---|
| 1008 | (if (logtest optype (x86::encode-operand-type :imm16))
|
|---|
| 1009 | (frag-list-push-16 frag-list (logand val #xffff))
|
|---|
| 1010 | (if (logtest optype (x86::encode-operand-type :imm64))
|
|---|
| 1011 | (frag-list-push-64 frag-list val)
|
|---|
| 1012 | (frag-list-push-32 frag-list val))))))))))
|
|---|
| 1013 | (let* ((frag (frag-list-current frag-list)))
|
|---|
| 1014 | (if (eq (car (frag-type frag)) :pending-talign)
|
|---|
| 1015 | (finish-pending-talign-frag frag-list)))))
|
|---|
| 1016 |
|
|---|
| 1017 | (defun x86-lap-directive (frag-list directive arg)
|
|---|
| 1018 | (if (eq directive :tra)
|
|---|
| 1019 | (progn
|
|---|
| 1020 | (finish-frag-for-align frag-list 3)
|
|---|
| 1021 | (x86-lap-directive frag-list :long `(:^ ,arg))
|
|---|
| 1022 | (emit-x86-lap-label frag-list arg))
|
|---|
| 1023 | (if (eq directive :fixed-constants)
|
|---|
| 1024 | (dolist (constant arg)
|
|---|
| 1025 | (ensure-x86-lap-constant-label constant))
|
|---|
| 1026 | (if (eq directive :arglist)
|
|---|
| 1027 | (setq *x86-lap-lfun-bits* (encode-lambda-list arg))
|
|---|
| 1028 | (let* ((exp (parse-x86-lap-expression arg))
|
|---|
| 1029 | (constantp (or (constant-x86-lap-expression-p exp)
|
|---|
| 1030 | (not (x86-lap-expression-p exp)))))
|
|---|
| 1031 |
|
|---|
| 1032 | (if constantp
|
|---|
| 1033 | (let* ((val (x86-lap-expression-value exp)))
|
|---|
| 1034 | (ecase directive
|
|---|
| 1035 | (:code-size
|
|---|
| 1036 | (if *x86-lap-fixed-code-words*
|
|---|
| 1037 | (error "Duplicate :CODE-SIZE directive")
|
|---|
| 1038 | (setq *x86-lap-fixed-code-words* val)))
|
|---|
| 1039 | (:byte (frag-list-push-byte frag-list val))
|
|---|
| 1040 | (:short (frag-list-push-16 frag-list val))
|
|---|
| 1041 | (:long (frag-list-push-32 frag-list val))
|
|---|
| 1042 | (:quad (frag-list-push-64 frag-list val))
|
|---|
| 1043 | (:align (finish-frag-for-align frag-list val))
|
|---|
| 1044 | (:talign (finish-frag-for-talign frag-list val))
|
|---|
| 1045 | (:org (finish-frag-for-org frag-list val))))
|
|---|
| 1046 | (let* ((pos (frag-list-position frag-list))
|
|---|
| 1047 | (frag (frag-list-current frag-list))
|
|---|
| 1048 | (reloctype nil))
|
|---|
| 1049 | (ecase directive
|
|---|
| 1050 | (:byte (frag-list-push-byte frag-list 0)
|
|---|
| 1051 | (setq reloctype :expr8))
|
|---|
| 1052 | (:short (frag-list-push-16 frag-list 0)
|
|---|
| 1053 | (setq reloctype :expr16))
|
|---|
| 1054 | (:long (frag-list-push-32 frag-list 0)
|
|---|
| 1055 | (setq reloctype :expr32))
|
|---|
| 1056 | (:quad (frag-list-push-64 frag-list 0)
|
|---|
| 1057 | (setq reloctype :expr64))
|
|---|
| 1058 | (:align (error ":align expression ~s not constant" arg))
|
|---|
| 1059 | (:talign (error ":talign expression ~s not constant" arg)))
|
|---|
| 1060 | (when reloctype
|
|---|
| 1061 | (push
|
|---|
| 1062 | (make-reloc :type reloctype
|
|---|
| 1063 | :arg exp
|
|---|
| 1064 | :pos pos
|
|---|
| 1065 | :frag frag)
|
|---|
| 1066 | (frag-relocs frag)))))
|
|---|
| 1067 | nil)))))
|
|---|
| 1068 |
|
|---|
| 1069 |
|
|---|
| 1070 | (defun x862-lap-process-regsave-info (frag-list regsave-label regsave-mask regsave-addr)
|
|---|
| 1071 | (when regsave-label
|
|---|
| 1072 | (let* ((label-diff (min (- (x86-lap-label-address regsave-label)
|
|---|
| 1073 | *x86-lap-entry-offset*)
|
|---|
| 1074 | 255))
|
|---|
| 1075 | (first-frag (frag-list-succ frag-list)))
|
|---|
| 1076 | (setf (frag-ref first-frag 4) label-diff
|
|---|
| 1077 | (frag-ref first-frag 5) regsave-addr
|
|---|
| 1078 | (frag-ref first-frag 6) regsave-mask))
|
|---|
| 1079 | t))
|
|---|
| 1080 |
|
|---|
| 1081 |
|
|---|
| 1082 |
|
|---|
| 1083 | (defun x86-lap-form (form frag-list instruction)
|
|---|
| 1084 | (if (and form (symbolp form))
|
|---|
| 1085 | (emit-x86-lap-label frag-list form)
|
|---|
| 1086 | (if (or (atom form) (not (symbolp (car form))))
|
|---|
| 1087 | (error "Unknown X86-LAP form ~s ." form)
|
|---|
| 1088 | (multiple-value-bind (expansion expanded)
|
|---|
| 1089 | (x86-lap-macroexpand-1 form)
|
|---|
| 1090 | (if expanded
|
|---|
| 1091 | (x86-lap-form expansion frag-list instruction)
|
|---|
| 1092 | (if (typep (car form) 'keyword)
|
|---|
| 1093 | (destructuring-bind (op arg) form
|
|---|
| 1094 | (x86-lap-directive frag-list op arg))
|
|---|
| 1095 | (case (car form)
|
|---|
| 1096 | (progn
|
|---|
| 1097 | (dolist (f (cdr form))
|
|---|
| 1098 | (x86-lap-form f frag-list instruction)))
|
|---|
| 1099 | (let
|
|---|
| 1100 | (destructuring-bind (equates &body body)
|
|---|
| 1101 | (cdr form)
|
|---|
| 1102 | (x86-lap-equate-form equates frag-list instruction body)))
|
|---|
| 1103 | (t
|
|---|
| 1104 | (parse-x86-instruction form instruction)
|
|---|
| 1105 | (x86-generate-instruction-code frag-list instruction)))))))))
|
|---|
| 1106 |
|
|---|
| 1107 | (defun relax-align (address bits)
|
|---|
| 1108 | (let* ((mask (1- (ash 1 bits))))
|
|---|
| 1109 | (- (logandc2 (+ address mask) mask) address)))
|
|---|
| 1110 |
|
|---|
| 1111 | (defun relax-talign (address mask)
|
|---|
| 1112 | (do* ((i 0 (1+ i)))
|
|---|
| 1113 | ((= (logand address 7) mask) i)
|
|---|
| 1114 | (incf address)))
|
|---|
| 1115 |
|
|---|
| 1116 |
|
|---|
| 1117 | (defun relax-frag-list (frag-list)
|
|---|
| 1118 | ;; First, assign tentative addresses to all frags, assuming that
|
|---|
| 1119 | ;; span-dependent instructions have short displacements.
|
|---|
| 1120 | ;; While doing that, find branches to the next instruction and
|
|---|
| 1121 | ;; remove them. In some cases, that'll cause the containing
|
|---|
| 1122 | ;; frag to become empty; that could introduce branches to the
|
|---|
| 1123 | ;; next instruction, so we repeat this process until we can
|
|---|
| 1124 | ;; make it all the way through the frag-list.
|
|---|
| 1125 | (loop
|
|---|
| 1126 | (let* ((address 8))
|
|---|
| 1127 | (declare (fixnum address))
|
|---|
| 1128 | (when (do-dll-nodes (frag frag-list t)
|
|---|
| 1129 | (setf (frag-address frag) address)
|
|---|
| 1130 | (incf address (frag-length frag))
|
|---|
| 1131 | (case (car (frag-type frag))
|
|---|
| 1132 | (:org
|
|---|
| 1133 | ;; Do nothing, for now
|
|---|
| 1134 | )
|
|---|
| 1135 | (:align
|
|---|
| 1136 | (incf address (relax-align address (cadr (frag-type frag)))))
|
|---|
| 1137 | (:talign
|
|---|
| 1138 | (let* ((arg (cadr (frag-type frag))))
|
|---|
| 1139 | (if (null arg)
|
|---|
| 1140 | ;;; Never generated code in :pending-talign frag
|
|---|
| 1141 | (setf (frag-type frag) nil)
|
|---|
| 1142 | (incf address (relax-talign address arg)))))
|
|---|
| 1143 | ((:assumed-short-branch :assumed-short-conditional-branch)
|
|---|
| 1144 | (destructuring-bind (label pos reloc) (cdr (frag-type frag))
|
|---|
| 1145 | (let* ((next (frag-succ frag)))
|
|---|
| 1146 | (when (and (eq (x86-lap-label-frag label) next)
|
|---|
| 1147 | (eql (x86-lap-label-offset label) 0))
|
|---|
| 1148 | ;; Delete the reloc associated with this branch.
|
|---|
| 1149 | (setf (frag-relocs frag)
|
|---|
| 1150 | (delete reloc (frag-relocs frag)))
|
|---|
| 1151 | ;; This will be a "normal" frag
|
|---|
| 1152 | (setf (frag-type frag) nil)
|
|---|
| 1153 | ;; Remove the (short) branch, and remove the frag
|
|---|
| 1154 | ;; if it becomes empty. If the frag does become
|
|---|
| 1155 | ;; empty, migrate any labels to the next frag.
|
|---|
| 1156 | (when (zerop (setf (frag-length frag)
|
|---|
| 1157 | (1- pos)))
|
|---|
| 1158 |
|
|---|
| 1159 | (do* ((labels (frag-labels frag)))
|
|---|
| 1160 | ((null labels))
|
|---|
| 1161 | (let* ((lab (pop labels)))
|
|---|
| 1162 | (setf (x86-lap-label-frag lab) next
|
|---|
| 1163 | (x86-lap-label-offset lab) 0)
|
|---|
| 1164 | (push lab (frag-labels next))))
|
|---|
| 1165 | (remove-dll-node frag))
|
|---|
| 1166 | (return nil)))))))
|
|---|
| 1167 | (return))))
|
|---|
| 1168 | ;; Repeatedly "stretch" frags containing span-dependent instructions
|
|---|
| 1169 | ;; until nothing's stretched. It may take several iterations to
|
|---|
| 1170 | ;; converge; is convergence guaranteed ?
|
|---|
| 1171 | (loop
|
|---|
| 1172 | (let* ((stretch 0) ;cumulative growth in frag sizes
|
|---|
| 1173 | (stretched nil)) ;any change on this pass ?
|
|---|
| 1174 | (do-dll-nodes (frag frag-list)
|
|---|
| 1175 | (let* ((growth 0)
|
|---|
| 1176 | (fragtype (frag-type frag))
|
|---|
| 1177 | (was-address (frag-address frag))
|
|---|
| 1178 | (address (incf (frag-address frag) stretch)))
|
|---|
| 1179 | (case (car fragtype)
|
|---|
| 1180 | (:org
|
|---|
| 1181 | (let* ((target (cadr (frag-type frag)))
|
|---|
| 1182 | (next-address (frag-address (frag-succ frag))))
|
|---|
| 1183 | (setq growth (- target next-address))
|
|---|
| 1184 | (if (< growth 0)
|
|---|
| 1185 | (error "Code size exceeds :CODE-SIZE constraint ~s"
|
|---|
| 1186 | (ash target -3))
|
|---|
| 1187 | (decf growth stretch))))
|
|---|
| 1188 | (:align
|
|---|
| 1189 | (let* ((bits (cadr fragtype))
|
|---|
| 1190 | (len (frag-length frag))
|
|---|
| 1191 | (oldoff (relax-align (+ was-address len) bits))
|
|---|
| 1192 | (newoff (relax-align (+ address len) bits)))
|
|---|
| 1193 | (setq growth (- newoff oldoff))))
|
|---|
| 1194 | (:talign
|
|---|
| 1195 | (let* ((arg (cadr fragtype))
|
|---|
| 1196 | (len (frag-length frag))
|
|---|
| 1197 | (oldoff (relax-talign (+ was-address len) arg))
|
|---|
| 1198 | (newoff (relax-talign (+ address len) arg)))
|
|---|
| 1199 | (setq growth (- newoff oldoff))))
|
|---|
| 1200 | ;; If we discover - on any iteration - that a short
|
|---|
| 1201 | ;; branch doesn't fit, we change the type (and the reloc)
|
|---|
| 1202 | ;; destructively to a wide branch indicator and will
|
|---|
| 1203 | ;; never change our minds about that, so we only have
|
|---|
| 1204 | ;; to look here at conditional branches that may still
|
|---|
| 1205 | ;; be able to use a 1-byte displacement.
|
|---|
| 1206 | ((:assumed-short-branch :assumed-short-conditional-branch)
|
|---|
| 1207 | (destructuring-bind (label pos reloc) (cdr (frag-type frag))
|
|---|
| 1208 | (declare (fixnum pos))
|
|---|
| 1209 | (let* ((label-address (x86-lap-label-address label))
|
|---|
| 1210 | (branch-pos (+ address (1+ pos)))
|
|---|
| 1211 | (diff (- label-address branch-pos)))
|
|---|
| 1212 | (unless (typep diff '(signed-byte 8))
|
|---|
| 1213 | (cond ((eq (car fragtype) :assumed-short-branch)
|
|---|
| 1214 | ;; replace the opcode byte
|
|---|
| 1215 | (setf (frag-ref frag (the fixnum (1- pos)))
|
|---|
| 1216 | x86::+jump-pc-relative+)
|
|---|
| 1217 | (frag-push-byte frag 0)
|
|---|
| 1218 | (frag-push-byte frag 0)
|
|---|
| 1219 | (frag-push-byte frag 0)
|
|---|
| 1220 | (setf (reloc-type reloc) :branch32)
|
|---|
| 1221 | (setf (car fragtype) :long-branch)
|
|---|
| 1222 | (setq growth 3))
|
|---|
| 1223 | (t
|
|---|
| 1224 | ;; Conditional branch: must change
|
|---|
| 1225 | ;; 1-byte opcode to 2 bytes, add 4-byte
|
|---|
| 1226 | ;; displacement
|
|---|
| 1227 | (let* ((old-opcode (frag-ref frag (1- pos))))
|
|---|
| 1228 | (setf (frag-ref frag (1- pos)) #x0f
|
|---|
| 1229 | (frag-ref frag pos) (+ old-opcode #x10))
|
|---|
| 1230 | (frag-push-byte frag 0)
|
|---|
| 1231 | (frag-push-byte frag 0)
|
|---|
| 1232 | (frag-push-byte frag 0)
|
|---|
| 1233 | (frag-push-byte frag 0)
|
|---|
| 1234 | (setf (reloc-type reloc) :branch32
|
|---|
| 1235 | (reloc-pos reloc) (1+ pos))
|
|---|
| 1236 | (setf (car fragtype) :long-conditional-branch
|
|---|
| 1237 | (caddr fragtype) (1+ pos))
|
|---|
| 1238 | (setq growth 4)))))))))
|
|---|
| 1239 | (unless (eql 0 growth)
|
|---|
| 1240 | (incf stretch growth)
|
|---|
| 1241 | (setq stretched t))))
|
|---|
| 1242 | (unless stretched (return)))))
|
|---|
| 1243 |
|
|---|
| 1244 | (defun apply-relocs (frag-list)
|
|---|
| 1245 | (flet ((emit-byte (frag pos b)
|
|---|
| 1246 | (setf (frag-ref frag pos) (logand b #xff))))
|
|---|
| 1247 | (flet ((emit-short (frag pos s)
|
|---|
| 1248 | (setf (frag-ref frag pos) (ldb (byte 8 0) s)
|
|---|
| 1249 | (frag-ref frag (1+ pos)) (ldb (byte 8 8) s))))
|
|---|
| 1250 | (flet ((emit-long (frag pos l)
|
|---|
| 1251 | (emit-short frag pos (ldb (byte 16 0) l))
|
|---|
| 1252 | (emit-short frag (+ pos 2) (ldb (byte 16 16) l))))
|
|---|
| 1253 | (flet ((emit-quad (frag pos q)
|
|---|
| 1254 | (emit-long frag pos (ldb (byte 32 0) q))
|
|---|
| 1255 | (emit-long frag (+ pos 4) (ldb (byte 32 32) q))))
|
|---|
| 1256 | (do-dll-nodes (frag frag-list)
|
|---|
| 1257 | (let* ((address (frag-address frag)))
|
|---|
| 1258 | (dolist (reloc (frag-relocs frag))
|
|---|
| 1259 | (let* ((pos (reloc-pos reloc))
|
|---|
| 1260 | (arg (reloc-arg reloc)))
|
|---|
| 1261 | (ecase (reloc-type reloc)
|
|---|
| 1262 | (:branch8 (let* ((target (x86-lap-label-address arg))
|
|---|
| 1263 | (refpos (+ address (1+ pos))))
|
|---|
| 1264 | (emit-byte frag pos (- target refpos))))
|
|---|
| 1265 | (:branch32 (let* ((target (x86-lap-label-address arg))
|
|---|
| 1266 | (refpos (+ address pos 4)))
|
|---|
| 1267 | (emit-long frag pos (- target refpos))))
|
|---|
| 1268 | (:expr8 (emit-byte frag pos (x86-lap-expression-value arg)))
|
|---|
| 1269 | (:expr16 (emit-short frag pos (x86-lap-expression-value arg)))
|
|---|
| 1270 | (:expr32 (emit-long frag pos (x86-lap-expression-value arg)))
|
|---|
| 1271 | (:expr64 (emit-quad frag pos (x86-lap-expression-value arg)))))))))))))
|
|---|
| 1272 |
|
|---|
| 1273 |
|
|---|
| 1274 | (defun frag-emit-nops (frag count)
|
|---|
| 1275 | (let* ((nnops (ash (+ count 3) -2))
|
|---|
| 1276 | (len (floor count nnops))
|
|---|
| 1277 | (remains (- count (* nnops len))))
|
|---|
| 1278 | (dotimes (i remains)
|
|---|
| 1279 | (dotimes (k len) (frag-push-byte frag #x66))
|
|---|
| 1280 | (frag-push-byte frag #x90))
|
|---|
| 1281 | (do* ((i remains (1+ i)))
|
|---|
| 1282 | ((= i nnops))
|
|---|
| 1283 | (dotimes (k (1- len)) (frag-push-byte frag #x66))
|
|---|
| 1284 | (frag-push-byte frag #x90))))
|
|---|
| 1285 |
|
|---|
| 1286 | (defun fill-for-alignment (frag-list)
|
|---|
| 1287 | (ccl::do-dll-nodes (frag frag-list)
|
|---|
| 1288 | (let* ((next (ccl::dll-node-succ frag)))
|
|---|
| 1289 | (unless (eq next frag-list)
|
|---|
| 1290 | (let* ((addr (frag-address frag))
|
|---|
| 1291 | (nextaddr (frag-address next))
|
|---|
| 1292 | (pad (- nextaddr (+ addr (frag-length frag)))))
|
|---|
| 1293 | (unless (eql 0 pad)
|
|---|
| 1294 | (if (eq (car (frag-type frag)) :talign)
|
|---|
| 1295 | (frag-emit-nops frag pad)
|
|---|
| 1296 | (dotimes (i pad) (frag-push-byte frag #xcc)))))))))
|
|---|
| 1297 |
|
|---|
| 1298 | (defun show-frag-bytes (frag-list)
|
|---|
| 1299 | (ccl::do-dll-nodes (frag frag-list)
|
|---|
| 1300 | (format t "~& frag at #x~x" (frag-address frag))
|
|---|
| 1301 | (dotimes (i (frag-length frag))
|
|---|
| 1302 | (unless (logtest 15 i)
|
|---|
| 1303 | (format t "~&"))
|
|---|
| 1304 | (format t "~2,'0x " (frag-ref frag i)))))
|
|---|
| 1305 |
|
|---|
| 1306 | (defun x86-lap-equate-form (eqlist fraglist instruction body)
|
|---|
| 1307 | (let* ((symbols (mapcar #'(lambda (x)
|
|---|
| 1308 | (let* ((name (car x)))
|
|---|
| 1309 | (or
|
|---|
| 1310 | (and name
|
|---|
| 1311 | (symbolp name)
|
|---|
| 1312 | (not (constant-symbol-p name))
|
|---|
| 1313 | (or (not (gethash (string name)
|
|---|
| 1314 | x86::*x86-registers*))
|
|---|
| 1315 | (error "Symbol ~s already names and x86 register" name))
|
|---|
| 1316 | name)
|
|---|
| 1317 | (error
|
|---|
| 1318 | "~S is not a bindable symbol name ." name))))
|
|---|
| 1319 | eqlist))
|
|---|
| 1320 | (values (mapcar #'(lambda (x) (x86-register-ordinal-or-expression
|
|---|
| 1321 | (cadr x)))
|
|---|
| 1322 | eqlist)))
|
|---|
| 1323 | (progv symbols values
|
|---|
| 1324 | (dolist (form body)
|
|---|
| 1325 | (x86-lap-form form fraglist instruction)))))
|
|---|
| 1326 |
|
|---|
| 1327 | (defun cross-create-x86-function (name frag-list constants bits debug-info)
|
|---|
| 1328 | (let* ((constants-vector (%alloc-misc (+ (length constants)
|
|---|
| 1329 | (+ 2
|
|---|
| 1330 | (if name 1 0)
|
|---|
| 1331 | (if debug-info 1 0)))
|
|---|
| 1332 | target::subtag-xfunction)))
|
|---|
| 1333 | (unless name (setq bits (logior bits (ash -1 $lfbits-noname-bit))))
|
|---|
| 1334 | (let* ((last (1- (uvsize constants-vector))))
|
|---|
| 1335 | (declare (fixnum last))
|
|---|
| 1336 | (setf (uvref constants-vector last) bits)
|
|---|
| 1337 | (when name
|
|---|
| 1338 | (setf (uvref constants-vector (decf last)) name))
|
|---|
| 1339 | (when debug-info
|
|---|
| 1340 | (setf (uvref constants-vector (decf last)) debug-info))
|
|---|
| 1341 | (dolist (c constants)
|
|---|
| 1342 | (setf (uvref constants-vector (decf last)) (car c)))
|
|---|
| 1343 | (let* ((nbytes 0))
|
|---|
| 1344 | (do-dll-nodes (frag frag-list)
|
|---|
| 1345 | (incf nbytes (frag-length frag)))
|
|---|
| 1346 | (let* ((code-vector (make-array nbytes
|
|---|
| 1347 | :element-type '(unsigned-byte 8)))
|
|---|
| 1348 | (target-offset 0))
|
|---|
| 1349 | (declare (fixnum target-offset))
|
|---|
| 1350 | (setf (uvref constants-vector 0) code-vector)
|
|---|
| 1351 | (do-dll-nodes (frag frag-list)
|
|---|
| 1352 | (incf target-offset (frag-output-bytes frag code-vector target-offset)))
|
|---|
| 1353 | constants-vector)))))
|
|---|
| 1354 |
|
|---|
| 1355 | #+x86-target
|
|---|
| 1356 | (defun create-x86-function (name frag-list constants bits debug-info)
|
|---|
| 1357 | (unless name (setq bits (logior bits (ash -1 $lfbits-noname-bit))))
|
|---|
| 1358 | (let* ((code-bytes (let* ((nbytes 0))
|
|---|
| 1359 | (do-dll-nodes (frag frag-list nbytes)
|
|---|
| 1360 | (incf nbytes (frag-length frag)))))
|
|---|
| 1361 | (code-words (ash code-bytes (- target::word-shift)))
|
|---|
| 1362 | (function-vector (allocate-typed-vector :function code-words)))
|
|---|
| 1363 | (declare (fixnum num-constants code-bytes code-words))
|
|---|
| 1364 | (let* ((target-offset 0))
|
|---|
| 1365 | (declare (fixnum target-offset))
|
|---|
| 1366 | (do-dll-nodes (frag frag-list)
|
|---|
| 1367 | (incf target-offset (frag-output-bytes frag function-vector target-offset))))
|
|---|
| 1368 | (let* ((last (1- (uvsize function-vector))))
|
|---|
| 1369 | (declare (fixnum last))
|
|---|
| 1370 | (setf (uvref function-vector last) bits)
|
|---|
| 1371 | (when name
|
|---|
| 1372 | (setf (uvref function-vector (decf last)) name))
|
|---|
| 1373 | (when debug-info
|
|---|
| 1374 | (setf (uvref function-vector (decf last)) debug-info))
|
|---|
| 1375 | (dolist (c constants)
|
|---|
| 1376 | (setf (uvref function-vector (decf last)) (car c)))
|
|---|
| 1377 | (%function-vector-to-function function-vector))))
|
|---|
| 1378 |
|
|---|
| 1379 |
|
|---|
| 1380 |
|
|---|
| 1381 | (defun %define-x86-lap-function (name forms &optional (bits 0))
|
|---|
| 1382 | (let* ((*x86-lap-labels* ())
|
|---|
| 1383 | (*x86-lap-constants* ())
|
|---|
| 1384 | (*x86-lap-fixed-code-words* nil)
|
|---|
| 1385 | (*x86-lap-lfun-bits* bits)
|
|---|
| 1386 | (end-code-tag (gensym))
|
|---|
| 1387 | (entry-code-tag (gensym))
|
|---|
| 1388 | (instruction (x86::make-x86-instruction))
|
|---|
| 1389 | (frag-list (make-frag-list)))
|
|---|
| 1390 | (make-x86-lap-label end-code-tag)
|
|---|
| 1391 | (make-x86-lap-label entry-code-tag)
|
|---|
| 1392 | (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
|
|---|
| 1393 | *x86-lap-entry-offset*) -3))
|
|---|
| 1394 | (x86-lap-directive frag-list :byte 0) ;regsave pc
|
|---|
| 1395 | (x86-lap-directive frag-list :byte 0) ;regsave ea
|
|---|
| 1396 | (x86-lap-directive frag-list :byte 0) ;regsave mask
|
|---|
| 1397 | (emit-x86-lap-label frag-list entry-code-tag)
|
|---|
| 1398 | (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction)
|
|---|
| 1399 | (dolist (f forms)
|
|---|
| 1400 | (x86-lap-form f frag-list instruction))
|
|---|
| 1401 | (x86-lap-directive frag-list :align 3)
|
|---|
| 1402 | (when *x86-lap-fixed-code-words*
|
|---|
| 1403 | (x86-lap-directive frag-list :org (ash *x86-lap-fixed-code-words* 3)))
|
|---|
| 1404 | (x86-lap-directive frag-list :quad x8664::function-boundary-marker)
|
|---|
| 1405 | (emit-x86-lap-label frag-list end-code-tag)
|
|---|
| 1406 | (dolist (c (reverse *x86-lap-constants*))
|
|---|
| 1407 | (emit-x86-lap-label frag-list (x86-lap-label-name (cdr c)))
|
|---|
| 1408 | (x86-lap-directive frag-list :quad 0))
|
|---|
| 1409 | (when name
|
|---|
| 1410 | (x86-lap-directive frag-list :quad 0))
|
|---|
| 1411 | ;; room for lfun-bits
|
|---|
| 1412 | (x86-lap-directive frag-list :quad 0)
|
|---|
| 1413 | (relax-frag-list frag-list)
|
|---|
| 1414 | (apply-relocs frag-list)
|
|---|
| 1415 | (fill-for-alignment frag-list)
|
|---|
| 1416 | ;;(show-frag-bytes frag-list)
|
|---|
| 1417 | (funcall #-x86-target #'cross-create-x86-function
|
|---|
| 1418 | #+x86-target (if (eq *target-backend* *host-backend*)
|
|---|
| 1419 | #'create-x86-function
|
|---|
| 1420 | #'cross-create-x86-function)
|
|---|
| 1421 | name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil)))
|
|---|
| 1422 |
|
|---|
| 1423 |
|
|---|
| 1424 | (defmacro defx86lapfunction (&environment env name arglist &body body
|
|---|
| 1425 | &aux doc)
|
|---|
| 1426 | (if (not (endp body))
|
|---|
| 1427 | (and (stringp (car body))
|
|---|
| 1428 | (cdr body)
|
|---|
| 1429 | (setq doc (car body))
|
|---|
| 1430 | (setq body (cdr body))))
|
|---|
| 1431 | `(progn
|
|---|
| 1432 | (eval-when (:compile-toplevel)
|
|---|
| 1433 | (note-function-info ',name t ,env))
|
|---|
| 1434 | #-x86-target
|
|---|
| 1435 | (progn
|
|---|
| 1436 | (eval-when (:load-toplevel)
|
|---|
| 1437 | (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))
|
|---|
| 1438 | (eval-when (:execute)
|
|---|
| 1439 | (%define-x86-lap-function ',name '((let ,arglist ,@body)))))
|
|---|
| 1440 | #+x86-target ; just shorthand for defun
|
|---|
| 1441 | (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)))
|
|---|
