source: branches/1.2/devel/source/compiler/X86/x86-lap.lisp @ 8130

Last change on this file since 8130 was 8130, checked in by gb, 12 years ago

Merge changes from working-0711 branch

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