source: branches/x8664-call/ccl/compiler/X86/x86-lap.lisp @ 6313

Last change on this file since 6313 was 6313, checked in by gb, 15 years ago

Support for :talign pseudo-op: aligns the -end- of the next instruction
on a specified boundary. (This is intended to allow use of CALL instructions
in some cases, forcing the return address to be tagged properly.)

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