source: trunk/source/compiler/X86/x86-lap.lisp @ 10207

Last change on this file since 10207 was 10207, checked in by rme, 12 years ago

%DEFINE-X8632-LAP-FUNCTION: handle multiple frag lists

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 68.0 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           (compiler-bug "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* nil)
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 *target-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    (or
844     (gethash name x86::*x86-opcode-template-lists*)
845     ;; Try to determine a suffix, based on the size of the last
846     ;; register argument (if any.)  If that can be determined,
847     ;; tack it on to the end of NAME and try again.
848     (let* ((suffix nil))
849       (dolist (arg (cdr form))
850         (let* ((designator (x86-register-designator arg)))
851           (when designator
852             (destructuring-bind (regname) (cdr arg)
853               (let* ((reg (lookup-x86-register regname designator)))
854                 (when reg
855                   (let* ((type (x86::reg-entry-reg-type reg)))
856                     (cond ((logtest type (x86::encode-operand-type :reg8))
857                            (setq suffix #\b))
858                           ((logtest type (x86::encode-operand-type :reg16))
859                            (setq suffix #\w))
860                           ((logtest type (x86::encode-operand-type :reg32))
861                            (setq suffix #\l))
862                           ((logtest type (x86::encode-operand-type :reg64))
863                            (setq suffix #\q))))))))))
864       (when suffix
865         (let* ((n (length name))
866                (m (1+ n))
867                (s (make-string m)))
868           (declare (fixnum n m) (dynamic-extent s))
869           (dotimes (i n) (setf (schar s i) (char name i)))
870           (setf (schar s n) suffix)
871           (gethash s x86::*x86-opcode-template-lists*)))))))
872         
873               
874         
875     
876 
877;;; FORM is a list; its car doesn't name a macro or pseudo op.  If we
878;;; can find a matching opcode template, initialize the
879;;; x86-instruction with that template and these operands.
880;;; Note that this doesn't handle "prefix" instructions at all.
881;;; Things that would change the operand or address size are
882;;; of limited utility, as are REP* prefixes on string instructions
883;;; (because of the way that the lisp used %[E|R]DI and %[E|R]SI).
884;;; LOCK can be used in the preceding instruction.
885(defun parse-x86-instruction (form instruction)
886    (let* ((templates (or
887                       (get-x86-opcode-templates form)
888                       (error "Unknown X86 instruction ~s" form)))
889           (operands (cdr form)))
890      (let* ((parsed-operands (if operands
891                                (mapcar #'parse-x86-operand operands)))
892             (operand-types (mapcar #'x86::x86-operand-type parsed-operands))
893             (type0 (pop operand-types))
894             (type1 (pop operand-types))
895             (type2 (car operand-types)))
896
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;;; Returns the active frag list after processing directive(s).
1069(defun x86-lap-directive (frag-list directive arg &optional main-frag-list exception-frag-list)
1070  (declare (ignorable main-frag-list exception-frag-list))
1071  (case directive
1072    (:tra
1073     (finish-frag-for-align frag-list 3)
1074     (x86-lap-directive frag-list :long `(:^ ,arg))
1075     (emit-x86-lap-label frag-list arg))
1076    (:fixed-constants
1077     (dolist (constant arg)
1078       (ensure-x86-lap-constant-label constant)))
1079    (:arglist (setq *x86-lap-lfun-bits* (encode-lambda-list arg)))
1080    ((:uuo :uuo-section)
1081     (if exception-frag-list
1082       (progn
1083         (setq frag-list exception-frag-list)
1084         (finish-frag-for-align frag-list 2))))
1085    ((:main :main-section)
1086     (when main-frag-list (setq frag-list main-frag-list)))
1087    (:anchored-uuo-section
1088     (setq frag-list (x86-lap-directive frag-list :uuo-section nil main-frag-list exception-frag-list))
1089     (setq frag-list (x86-lap-directive frag-list :long `(:^ ,arg) main-frag-list exception-frag-list)))
1090    (t (let* ((exp (parse-x86-lap-expression arg))
1091              (constantp (or (constant-x86-lap-expression-p exp)
1092                             (not (x86-lap-expression-p exp)))))
1093         
1094         (if constantp
1095           (let* ((val (x86-lap-expression-value exp)))
1096             (ecase directive
1097               (:code-size
1098                (if *x86-lap-fixed-code-words*
1099                  (error "Duplicate :CODE-SIZE directive")
1100                  (setq *x86-lap-fixed-code-words* val)))
1101               (:byte (frag-list-push-byte frag-list val))
1102               (:short (frag-list-push-16 frag-list val))
1103               (:long (frag-list-push-32 frag-list val))
1104               (:quad (frag-list-push-64 frag-list val))
1105               (:align (finish-frag-for-align frag-list val))
1106               (:talign (finish-frag-for-talign frag-list val))
1107               (:org (finish-frag-for-org frag-list val))))
1108           (let* ((pos (frag-list-position frag-list))
1109                  (frag (frag-list-current frag-list))
1110                  (reloctype nil))
1111             (ecase directive
1112               (:byte (frag-list-push-byte frag-list 0)
1113                      (setq reloctype :expr8))
1114               (:short (frag-list-push-16 frag-list 0)
1115                       (setq reloctype :expr16))
1116               (:long (frag-list-push-32 frag-list 0)
1117                      (setq reloctype :expr32))
1118               (:quad (frag-list-push-64 frag-list 0)
1119                      (setq reloctype :expr64))
1120               (:align (error ":align expression ~s not constant" arg))
1121               (:talign (error ":talign expression ~s not constant" arg)))
1122             (when reloctype
1123               (push
1124                (make-reloc :type reloctype
1125                            :arg exp
1126                            :pos pos
1127                            :frag frag)
1128                (frag-relocs frag))))))))
1129  frag-list)
1130
1131
1132(defun x862-lap-process-regsave-info (frag-list regsave-label regsave-mask regsave-addr)
1133  (when regsave-label
1134    (let* ((label-diff (min (- (x86-lap-label-address regsave-label)
1135                               *x86-lap-entry-offset*)
1136                            255))
1137           (first-frag (frag-list-succ frag-list)))
1138      (setf (frag-ref first-frag 4) label-diff
1139            (frag-ref first-frag 5) regsave-addr
1140            (frag-ref first-frag 6) regsave-mask))
1141    t))
1142                       
1143         
1144
1145(defun x86-lap-form (form frag-list instruction  main-frag-list exception-frag-list)
1146  (if (and form (symbolp form))
1147    (emit-x86-lap-label frag-list form)
1148    (if (or (atom form) (not (symbolp (car form))))
1149      (error "Unknown X86-LAP form ~s ." form)
1150      (multiple-value-bind (expansion expanded)
1151          (x86-lap-macroexpand-1 form)
1152        (if expanded
1153          (x86-lap-form expansion frag-list instruction main-frag-list exception-frag-list)
1154          (if (typep (car form) 'keyword)
1155            (destructuring-bind (op &optional arg) form
1156              (setq frag-list (x86-lap-directive frag-list op arg main-frag-list exception-frag-list)))
1157            (case (car form)
1158              (progn
1159                (dolist (f (cdr form))
1160                  (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list))))
1161              (let
1162                  (destructuring-bind (equates &body body)
1163                      (cdr form)
1164                    (setq frag-list (x86-lap-equate-form equates frag-list instruction body main-frag-list exception-frag-list))))
1165              (t
1166               (parse-x86-instruction form instruction)
1167               (x86-generate-instruction-code frag-list instruction))))))))
1168  frag-list)
1169
1170(defun relax-align (address bits)
1171  (let* ((mask (1- (ash 1 bits))))
1172    (- (logandc2 (+ address mask) mask) address)))
1173
1174(defun relax-talign (address mask)
1175  (do* ((i 0 (1+ i)))
1176       ((= (logand address 7) mask) i)
1177    (incf address)))
1178
1179
1180(defun relax-frag-list (frag-list)
1181  ;; First, assign tentative addresses to all frags, assuming that
1182  ;; span-dependent instructions have short displacements.
1183  ;; While doing that, find branches to the next instruction and
1184  ;; remove them.  In some cases, that'll cause the containing
1185  ;; frag to become empty; that could introduce branches to the
1186  ;; next instruction, so we repeat this process until we can
1187  ;; make it all the way through the frag-list.
1188  (loop
1189    (let* ((address (target-arch-case (:x8632 4) (:x8664 8)))) ;after header
1190      (declare (fixnum address))
1191      (when (do-dll-nodes (frag frag-list t)
1192              (setf (frag-address frag) address)
1193              (incf address (frag-length frag))
1194              (case (car (frag-type frag))
1195                (:org
1196                 ;; Do nothing, for now
1197                 )
1198                (:align
1199                 (incf address (relax-align address (cadr (frag-type frag)))))
1200                (:talign
1201                 (let* ((arg (cadr (frag-type frag))))
1202                   (if (null arg)
1203                     ;;; Never generated code in :pending-talign frag
1204                     (setf (frag-type frag) nil)
1205                     (incf address (relax-talign address arg)))))
1206                ((:assumed-short-branch :assumed-short-conditional-branch)
1207                 (destructuring-bind (label pos reloc) (cdr (frag-type frag))
1208                   (let* ((next (frag-succ frag)))
1209                     (when (and (eq (x86-lap-label-frag label) next)
1210                                (eql (x86-lap-label-offset label) 0))
1211                       ;; Delete the reloc associated with this branch.
1212                       (setf (frag-relocs frag)
1213                             (delete reloc (frag-relocs frag)))
1214                       ;; This will be a "normal" frag
1215                       (setf (frag-type frag) nil)
1216                       ;; Remove the (short) branch, and remove the frag
1217                       ;; if it becomes empty.  If the frag does become
1218                       ;; empty, migrate any labels to the next frag.
1219                       (when (zerop (setf (frag-length frag)
1220                                        (1- pos)))
1221
1222                         (do* ((labels (frag-labels frag)))
1223                              ((null labels))
1224                           (let* ((lab (pop labels)))
1225                             (setf (x86-lap-label-frag lab) next
1226                                   (x86-lap-label-offset lab) 0)
1227                             (push lab (frag-labels next))))
1228                         (remove-dll-node frag))
1229                       (return nil)))))))
1230        (return))))
1231  ;; Repeatedly "stretch" frags containing span-dependent instructions
1232  ;; until nothing's stretched.  It may take several iterations to
1233  ;; converge; is convergence guaranteed ?
1234  (loop
1235    (let* ((stretch 0)                  ;cumulative growth in frag sizes
1236           (stretched nil))             ;any change on this pass ?
1237      (do-dll-nodes (frag frag-list)
1238        (let* ((growth 0)
1239               (fragtype (frag-type frag))
1240               (was-address (frag-address frag))
1241               (address (incf (frag-address frag) stretch)))
1242          (case (car fragtype)
1243            (:org
1244             (let* ((target (cadr (frag-type frag)))
1245                    (next-address (frag-address (frag-succ frag))))
1246               (setq growth (- target next-address))
1247               (if (< growth 0)
1248                 (error "Code size exceeds :CODE-SIZE constraint ~s"
1249                        (ash target -3))
1250                 (decf growth stretch))))
1251            (:align
1252             (let* ((bits (cadr fragtype))
1253                    (len (frag-length frag))
1254                    (oldoff (relax-align (+ was-address len) bits))
1255                    (newoff (relax-align (+ address len) bits)))
1256               (setq growth (- newoff oldoff))))
1257            (:talign
1258             (let* ((arg (cadr fragtype))
1259                    (len (frag-length frag))
1260                    (oldoff (relax-talign (+ was-address len) arg))
1261                    (newoff (relax-talign (+ address len) arg)))
1262               (setq growth (- newoff oldoff))))
1263            ;; If we discover - on any iteration - that a short
1264            ;; branch doesn't fit, we change the type (and the reloc)
1265            ;; destructively to a wide branch indicator and will
1266            ;; never change our minds about that, so we only have
1267            ;; to look here at conditional branches that may still
1268            ;; be able to use a 1-byte displacement.
1269            ((:assumed-short-branch :assumed-short-conditional-branch)
1270             (destructuring-bind (label pos reloc) (cdr (frag-type frag))
1271               (declare (fixnum pos))
1272               (let* ((label-address (x86-lap-label-address label))
1273                      (branch-pos (+ address (1+ pos)))
1274                      (diff (- label-address branch-pos)))
1275                 (unless (typep diff '(signed-byte 8))
1276                   (cond ((eq (car fragtype) :assumed-short-branch)
1277                          ;; replace the opcode byte
1278                          (setf (frag-ref frag (the fixnum (1- pos)))
1279                                x86::+jump-pc-relative+)
1280                          (frag-push-byte frag 0)
1281                          (frag-push-byte frag 0)
1282                          (frag-push-byte frag 0)
1283                          (setf (reloc-type reloc) :branch32)
1284                          (setf (car fragtype) :long-branch)
1285                          (setq growth 3))
1286                         (t
1287                          ;; Conditional branch: must change
1288                          ;; 1-byte opcode to 2 bytes, add 4-byte
1289                          ;; displacement
1290                          (let* ((old-opcode (frag-ref frag (1- pos))))
1291                            (setf (frag-ref frag (1- pos)) #x0f
1292                                  (frag-ref frag pos) (+ old-opcode #x10))
1293                            (frag-push-byte frag 0)
1294                            (frag-push-byte frag 0)
1295                            (frag-push-byte frag 0)
1296                            (frag-push-byte frag 0)
1297                            (setf (reloc-type reloc) :branch32
1298                                  (reloc-pos reloc) (1+ pos))
1299                            (setf (car fragtype) :long-conditional-branch
1300                                  (caddr fragtype) (1+ pos))
1301                            (setq growth 4)))))))))
1302          (unless (eql 0 growth)
1303            (incf stretch growth)
1304            (setq stretched t))))
1305      (unless stretched (return)))))
1306
1307(defun apply-relocs (frag-list)
1308  (flet ((emit-byte (frag pos b)
1309           (setf (frag-ref frag pos) (logand b #xff))))
1310    (flet ((emit-short (frag pos s)
1311             (setf (frag-ref frag pos) (ldb (byte 8 0) s)
1312                   (frag-ref frag (1+ pos)) (ldb (byte 8 8) s))))
1313      (flet ((emit-long (frag pos l)
1314               (emit-short frag pos (ldb (byte 16 0) l))
1315               (emit-short frag (+ pos 2) (ldb (byte 16 16) l))))
1316        (flet ((emit-quad (frag pos q)
1317                 (emit-long frag pos (ldb (byte 32 0) q))
1318                 (emit-long frag (+ pos 4) (ldb (byte 32 32) q))))
1319          (do-dll-nodes (frag frag-list)
1320            (let* ((address (frag-address frag)))
1321              (dolist (reloc (frag-relocs frag))
1322                (let* ((pos (reloc-pos reloc))
1323                       (arg (reloc-arg reloc)))
1324                  (ecase (reloc-type reloc)
1325                    (:branch8 (let* ((target (x86-lap-label-address arg))
1326                                     (refpos (+ address (1+ pos))))
1327                                (emit-byte frag pos (- target refpos))))
1328                    (:branch32 (let* ((target (x86-lap-label-address arg))
1329                                     (refpos (+ address pos 4)))
1330                                (emit-long frag pos (- target refpos))))
1331                    (:expr8 (emit-byte frag pos  (x86-lap-expression-value arg)))
1332                    (:expr16 (emit-short frag pos (x86-lap-expression-value arg)))
1333                    (:expr32 (emit-long frag pos (x86-lap-expression-value arg)))
1334                    (:expr64 (emit-quad frag pos (x86-lap-expression-value arg)))
1335                    (:self (emit-long frag pos (x86-lap-expression-value arg)))))))))))))
1336
1337(defun frag-emit-nops (frag count)
1338  (let* ((nnops (ash (+ count 3) -2))
1339         (len (floor count nnops))
1340         (remains (- count (* nnops len))))
1341    (dotimes (i remains)
1342      (dotimes (k len) (frag-push-byte frag #x66))
1343      (frag-push-byte frag #x90))
1344    (do* ((i remains (1+ i)))
1345         ((= i nnops))
1346      (dotimes (k (1- len)) (frag-push-byte frag #x66))
1347      (frag-push-byte frag #x90))))
1348 
1349(defun fill-for-alignment (frag-list)
1350  (ccl::do-dll-nodes (frag frag-list)
1351    (let* ((next (ccl::dll-node-succ frag)))
1352      (unless (eq next frag-list)
1353        (let* ((addr (frag-address frag))
1354               (nextaddr (frag-address next))
1355               (pad (- nextaddr (+ addr (frag-length frag)))))
1356          (unless (eql 0 pad)
1357            (frag-emit-nops frag pad)))))))
1358
1359(defun show-frag-bytes (frag-list)
1360  (ccl::do-dll-nodes (frag frag-list)
1361    (format t "~& frag at #x~x" (frag-address frag))
1362    (dotimes (i (frag-length frag))
1363      (unless (logtest 15 i)
1364        (format t "~&"))
1365      (format t "~2,'0x " (frag-ref frag i)))))
1366
1367(defun x86-lap-equate-form (eqlist fraglist instruction  body main-frag exception-frag) 
1368  (let* ((symbols (mapcar #'(lambda (x)
1369                              (let* ((name (car x)))
1370                                (or
1371                                 (and name 
1372                                      (symbolp name)
1373                                      (not (constant-symbol-p name))
1374                                      (or (not (gethash (string name)
1375                                                        (target-arch-case
1376                                                         (:x8632 x86::*x8632-registers*)
1377                                                         (:x8664 x86::*x8664-registers*))))
1378                                          (error "Symbol ~s already names an x86 register" name))
1379                                      name)
1380                                 (error 
1381                                  "~S is not a bindable symbol name ." name))))
1382                          eqlist))
1383         (values (mapcar #'(lambda (x) (x86-register-ordinal-or-expression
1384                                        (cadr x)))
1385                         eqlist)))
1386    (progv symbols values
1387      (dolist (form body fraglist)
1388        (setq fraglist (x86-lap-form form fraglist instruction main-frag exception-frag))))))
1389               
1390(defun cross-create-x86-function (name frag-list constants bits debug-info)
1391  (let* ((constants-vector (%alloc-misc (+ (length constants)
1392                                           (+ 2
1393                                              (if name 1 0)
1394                                              (if debug-info 1 0)))
1395                                        target::subtag-xfunction)))
1396    (unless name (setq bits (logior bits (ash -1 $lfbits-noname-bit))))
1397    (let* ((last (1- (uvsize constants-vector))))
1398      (declare (fixnum last))
1399      (setf (uvref constants-vector last) bits)
1400      (when name
1401        (setf (uvref constants-vector (decf last)) name))
1402      (when debug-info
1403        (setf (uvref constants-vector (decf last)) debug-info))
1404      (dolist (c constants)
1405        (setf (uvref constants-vector (decf last)) (car c)))
1406      (let* ((nbytes 0))
1407        (do-dll-nodes (frag frag-list)
1408          (incf nbytes (frag-length frag)))
1409        #+x8632-target
1410        (when (>= nbytes (ash 1 18)) (compiler-function-overflow))
1411        (let* ((code-vector (make-array nbytes
1412                                        :element-type '(unsigned-byte 8)))
1413               (target-offset 0))
1414          (declare (fixnum target-offset))
1415          (setf (uvref constants-vector 0) code-vector)
1416          (do-dll-nodes (frag frag-list)
1417            (incf target-offset (frag-output-bytes frag code-vector target-offset)))
1418          constants-vector)))))
1419
1420#+x86-target
1421(defun create-x86-function (name frag-list constants bits debug-info)
1422  (unless name (setq bits (logior bits (ash -1 $lfbits-noname-bit))))
1423  (let* ((code-bytes (let* ((nbytes 0))
1424                       (do-dll-nodes (frag frag-list nbytes)
1425                         (incf nbytes (frag-length frag)))))
1426         (code-words (ash code-bytes (- target::word-shift)))
1427         (function-vector (allocate-typed-vector :function code-words)))
1428    (declare (fixnum code-bytes code-words))
1429    (let* ((target-offset 0))
1430      (declare (fixnum target-offset))
1431      (do-dll-nodes (frag frag-list)
1432        (incf target-offset (frag-output-bytes frag function-vector target-offset))))
1433    (let* ((last (1- (uvsize function-vector))))
1434      (declare (fixnum last))
1435      (setf (uvref function-vector last) bits)
1436      (when name
1437        (setf (uvref function-vector (decf last)) name))
1438      (when debug-info
1439        (setf (uvref function-vector (decf last)) debug-info))
1440      (dolist (c constants)
1441        (setf (uvref function-vector (decf last)) (car c)))
1442      #+x8632-target
1443      (%update-self-references function-vector)
1444      (function-vector-to-function function-vector))))
1445
1446(defun %define-x86-lap-function (name forms &optional (bits 0))
1447  (target-arch-case
1448   (:x8632
1449    (%define-x8632-lap-function name forms bits))
1450   (:x8664
1451    (%define-x8664-lap-function name forms bits))))
1452
1453(defun %define-x8664-lap-function (name forms &optional (bits 0))
1454  (let* ((*x86-lap-labels* ())
1455         (*x86-lap-constants* ())
1456         (*x86-lap-entry-offset* x8664::fulltag-function)
1457         (*x86-lap-fixed-code-words* nil)
1458         (*x86-lap-lfun-bits* bits)
1459         (end-code-tag (gensym))
1460         (entry-code-tag (gensym))
1461         (instruction (x86::make-x86-instruction))
1462         (main-frag-list (make-frag-list))
1463         (exception-frag-list (make-frag-list))
1464         (frag-list main-frag-list))
1465    (make-x86-lap-label end-code-tag)
1466    (make-x86-lap-label entry-code-tag)
1467    (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
1468                                              *x86-lap-entry-offset*) -3))
1469    (x86-lap-directive frag-list :byte 0) ;regsave pc
1470    (x86-lap-directive frag-list :byte 0) ;regsave ea
1471    (x86-lap-directive frag-list :byte 0) ;regsave mask
1472    (emit-x86-lap-label frag-list entry-code-tag)
1473
1474    (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction main-frag-list exception-frag-list)
1475    (dolist (f forms)
1476      (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list)))
1477    (setq frag-list main-frag-list)
1478    (merge-dll-nodes frag-list exception-frag-list)
1479    (x86-lap-directive frag-list :align 3)
1480    (when *x86-lap-fixed-code-words*
1481      (x86-lap-directive frag-list :org (ash *x86-lap-fixed-code-words* 3)))
1482    (x86-lap-directive frag-list :quad x8664::function-boundary-marker)
1483    (emit-x86-lap-label frag-list end-code-tag)
1484    (dolist (c (reverse *x86-lap-constants*))
1485      (emit-x86-lap-label frag-list (x86-lap-label-name (cdr c)))
1486      (x86-lap-directive frag-list :quad 0))
1487    (when name
1488      (x86-lap-directive frag-list :quad 0))
1489    ;; room for lfun-bits
1490    (x86-lap-directive frag-list :quad 0)
1491    (relax-frag-list frag-list)
1492    (apply-relocs frag-list)
1493    (fill-for-alignment frag-list)
1494    ;;(show-frag-bytes frag-list)
1495    (funcall #-x86-target #'cross-create-x86-function
1496             #+x86-target (if (eq *target-backend* *host-backend*)
1497                            #'create-x86-function
1498                            #'cross-create-x86-function)
1499             name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil)))
1500
1501(defun %define-x8632-lap-function (name forms &optional (bits 0))
1502  (let* ((*x86-lap-labels* ())
1503         (*x86-lap-constants* ())
1504         (*x86-lap-entry-offset* x8632::fulltag-misc)
1505         (*x86-lap-fixed-code-words* nil)
1506         (*x86-lap-lfun-bits* bits)
1507         (srt-tag (gensym))
1508         (end-code-tag (gensym))
1509         (entry-code-tag (gensym))
1510         (instruction (x86::make-x86-instruction))
1511         (main-frag-list (make-frag-list))
1512         (exception-frag-list (make-frag-list))
1513         (frag-list main-frag-list))
1514    (make-x86-lap-label entry-code-tag)
1515    (make-x86-lap-label srt-tag)
1516    (make-x86-lap-label end-code-tag)
1517    ;; count of 32-bit words from header to function boundary
1518    ;; marker, inclusive.
1519    (x86-lap-directive frag-list :short `(ash (+ (- (:^ ,end-code-tag) 4)
1520                                                 *x86-lap-entry-offset*) -2))
1521    (emit-x86-lap-label frag-list entry-code-tag)
1522    (x86-lap-form '(movl ($ :self) (% x8632::fn)) frag-list instruction main-frag-list exception-frag-list)
1523    (dolist (f forms)
1524      (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list)))
1525    (setq frag-list main-frag-list)
1526    (merge-dll-nodes frag-list exception-frag-list)
1527    (x86-lap-directive frag-list :align 2)
1528    (when *x86-lap-fixed-code-words*
1529      ;; We have a code-size that we're trying to get to.  We need to
1530      ;; include the self-reference table in the code-size, so decrement
1531      ;; the size of the padding we would otherwise insert by the srt size.
1532      (let ((srt-words 1))              ;for zero between end of code and srt
1533        (do-dll-nodes (frag frag-list)
1534          (dolist (reloc (frag-relocs frag))
1535            (when (eq (reloc-type reloc) :self)
1536              (incf srt-words))))
1537        (decf *x86-lap-fixed-code-words* srt-words)
1538        (if (plusp *x86-lap-fixed-code-words*)
1539          (x86-lap-directive frag-list :org (ash *x86-lap-fixed-code-words* 2)))))
1540    ;; self reference table
1541    (x86-lap-directive frag-list :long 0)
1542    (emit-x86-lap-label frag-list srt-tag)
1543    ;; reserve space for self-reference offsets
1544    (do-dll-nodes (frag frag-list)
1545      (dolist (reloc (frag-relocs frag))
1546        (when (eq (reloc-type reloc) :self)
1547          (x86-lap-directive frag-list :long 0))))
1548    (x86-lap-directive frag-list :long x8632::function-boundary-marker)
1549    (emit-x86-lap-label frag-list end-code-tag)
1550    (dolist (c (reverse *x86-lap-constants*))
1551      (emit-x86-lap-label frag-list (x86-lap-label-name (cdr c)))
1552      (x86-lap-directive frag-list :long 0))
1553    (when name
1554      (x86-lap-directive frag-list :long 0))
1555    ;; room for lfun-bits
1556    (x86-lap-directive frag-list :long 0)
1557    (relax-frag-list frag-list)
1558    (apply-relocs frag-list)
1559    (fill-for-alignment frag-list)
1560    ;; determine start of self-reference-table
1561    (let* ((label (find srt-tag *x86-lap-labels* :test #'eq
1562                                                 :key #'x86-lap-label-name))
1563           (srt-frag (x86-lap-label-frag label))
1564           (srt-index (x86-lap-label-offset label)))
1565      ;; fill in self-reference offsets
1566      (do-dll-nodes (frag frag-list)
1567        (dolist (reloc (frag-relocs frag))
1568          (when (eq (reloc-type reloc) :self)
1569            (setf (frag-ref-32 srt-frag srt-index)
1570                  (+ (frag-address frag) (reloc-pos reloc)))
1571            (incf srt-index 4)))))
1572    ;;(show-frag-bytes frag-list)
1573    (funcall #-x8632-target #'cross-create-x86-function
1574             #+x8632-target (if (eq *target-backend* *host-backend*)
1575                              #'create-x86-function
1576                              #'cross-create-x86-function)
1577             name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil)))
1578
1579(defmacro defx86lapfunction (&environment env name arglist &body body
1580                             &aux doc)
1581  (if (not (endp body))
1582      (and (stringp (car body))
1583           (cdr body)
1584           (setq doc (car body))
1585           (setq body (cdr body))))
1586  `(progn
1587     (eval-when (:compile-toplevel)
1588       (note-function-info ',name t ,env))
1589     #-x8664-target
1590     (progn
1591       (eval-when (:load-toplevel)
1592         (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))
1593       (eval-when (:execute)
1594         (%define-x86-lap-function ',name '((let ,arglist ,@body)))))
1595     #+x8664-target     ; just shorthand for defun
1596     (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)))
1597
1598(defmacro defx8632lapfunction (&environment env name arglist &body body
1599                             &aux doc)
1600  (if (not (endp body))
1601      (and (stringp (car body))
1602           (cdr body)
1603           (setq doc (car body))
1604           (setq body (cdr body))))
1605  `(progn
1606     (eval-when (:compile-toplevel)
1607       (note-function-info ',name t ,env))
1608     #-x8632-target
1609     (progn
1610       (eval-when (:load-toplevel)
1611         (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))
1612       (eval-when (:execute)
1613         (%define-x8632-lap-function ',name '((let ,arglist ,@body)))))
1614     #+x8632-target
1615     (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)))
Note: See TracBrowser for help on using the repository browser.