source: branches/ia32/compiler/X86/x86-lap.lisp @ 7245

Last change on this file since 7245 was 7245, checked in by rme, 13 years ago

Straighten out how the immediate word count in IA-32 functions
is created and used by the compiler/assembler/disassembler.

Get rid of some calls to format used for debugging.

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