source: branches/win64/compiler/X86/x86-lap.lisp @ 8648

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

PARSE-X86-OPERAND: recognize (:RCONTEXT disp) a a memory operand, using
a segment register or GPR depending on the backend's LISP-CONTEXT-REGISTER.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 61.7 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2005, Clozure Associates and contributors.
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(require "X86-ASM")
20
21(eval-when (:compile-toplevel :load-toplevel :execute)
22  (require "DLL-NODE"))
23
24(def-standard-initial-binding *x86-lap-label-freelist* (make-dll-node-freelist))
25
26(def-standard-initial-binding *x86-lap-frag-vector-freelist* (%cons-pool))
27
28(defun %allocate-vector-list-segment ()
29  (without-interrupts
30   (let* ((data (pool.data *x86-lap-frag-vector-freelist*)))
31     (if data
32       (progn
33         (when (null (list-length data))
34           (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;;; (:rcontext x) -> memory operand, using segment register or gpr
673;;; x -> labelref
674(defun parse-x86-operand (form)
675  (if (consp form)
676    (let* ((head (car form))
677           (designator nil))
678      (if (symbolp head)
679        (cond ((string= head '$)
680               (destructuring-bind (immval) (cdr form)
681                 (let* ((expr (parse-x86-lap-expression immval))
682                        (val (early-x86-lap-expression-value expr))
683                        (type (if val
684                                (smallest-imm-type val)
685                                (x86::encode-operand-type :imm32s))))
686                   (x86::make-x86-immediate-operand :type type
687                                             :value expr))))
688              ((eq head :rcontext)
689               (if (>= (backend-lisp-context-register *target-backend*)
690                       x86::+x86-segment-register-offset+)
691                 (parse-x86-memory-operand `((% :rcontext) ,(cadr form)))
692                 (parse-x86-memory-operand `(,(cadr form) (% :rcontext)))))
693              ((setq designator (x86-register-designator form))
694               (destructuring-bind (reg) (cdr form)
695                 (parse-x86-register-operand reg designator)))
696              ((string= head '@)
697               (parse-x86-memory-operand  (cdr form)))
698              (t (error "unknown X86 operand: ~s" form)))
699        (error "unknown X86 operand: ~s" form)))
700    ;; Treat an atom as a label.
701    (parse-x86-label-reference form)))
702
703
704
705
706;;; Initialize some fields in the instruction from the template;
707;;; set other fields (which depend on operand values) to NIL.
708(defun set-x86-instruction-template (i template)
709  (setf (x86::x86-instruction-opcode-template i) template
710        (x86::x86-instruction-base-opcode i) (x86::x86-opcode-template-base-opcode template)
711        (x86::x86-instruction-modrm-byte i) (x86::x86-opcode-template-modrm-byte template)
712        (x86::x86-instruction-rex-prefix i) (x86::x86-opcode-template-rex-prefix template)
713        (x86::x86-instruction-sib-byte i) nil
714        (x86::x86-instruction-seg-prefix i) nil
715        (x86::x86-instruction-disp i) nil
716        (x86::x86-instruction-imm i) nil
717        (x86::x86-instruction-extra i) nil))
718
719
720(defun init-x86-instruction (instruction template parsed-operands)
721  (set-x86-instruction-template instruction template)
722  (let* ((insert-classes (x86::x86-opcode-template-operand-classes template))
723         (insert-functions x86::*x86-operand-insert-functions*))
724    (dotimes (i (length parsed-operands) instruction)
725      (funcall (svref insert-functions (svref insert-classes i))
726               instruction
727               (pop parsed-operands)))))
728
729
730
731(defun smallest-imm-type (val)
732  (if (eql val 1)
733    (x86::encode-operand-type :Imm1 :Imm8 :Imm8S :Imm16 :Imm32 :Imm32S :Imm64)
734    (typecase val
735      ((signed-byte 8)
736       (x86::encode-operand-type :Imm8S :imm8 :Imm16 :Imm32 :Imm32S :Imm64))
737      ((unsigned-byte 8)
738       (x86::encode-operand-type  :imm8 :Imm16 :Imm32 :Imm32S :Imm64))
739      ((signed-byte 16)
740       (x86::encode-operand-type  :Imm16 :Imm32 :Imm32S :Imm64))
741      ((unsigned-byte 16)
742       (x86::encode-operand-type  :Imm16 :Imm32 :Imm32S :Imm64))
743      ((signed-byte 32)
744       (x86::encode-operand-type :Imm32 :Imm32S :Imm64))
745      ((unsigned-byte 32)
746       (x86::encode-operand-type :Imm32 :Imm64))
747      (t (x86::encode-operand-type :Imm64)))))
748
749   
750(defun x86-optimize-imm (operands suffix)
751  (unless suffix
752    ;; See if we can determine an implied suffix from operands.
753    (do* ((i (1- (length operands)) (1- i)))
754         ((< i 0))
755      (declare (fixnum i))
756      (let* ((op (svref operands i))
757             (optype (x86::x86-operand-type op)))
758        (when (logtest optype (x86::encode-operand-type :reg))
759          (cond ((logtest optype (x86::encode-operand-type :reg8))
760                 (setq suffix #\b))
761                ((logtest optype (x86::encode-operand-type :reg16))
762                 (setq suffix #\w))
763                ((logtest optype (x86::encode-operand-type :reg32))
764                 (setq suffix #\l))
765                ((logtest optype (x86::encode-operand-type :reg64))
766                 (setq suffix #\q)))
767          (return)))))
768  (dotimes (i (length operands))
769    (let* ((op (svref operands i))
770           (optype (x86::x86-operand-type op)))
771      (when (logtest optype (x86::encode-operand-type :imm))
772        (let* ((val (x86::x86-immediate-operand-value op)))
773          (cond ((typep val 'constant-x86-lap-expression)
774                 (case suffix
775                   (#\l (setf (x86::x86-operand-type op)
776                              (logior optype (x86::encode-operand-type
777                                              :imm32 :imm64))))
778                   (#\w (setf (x86::x86-operand-type op)
779                              (logior optype (x86::encode-operand-type
780                                              :imm16 :imm32S  :imm32 :imm64))))
781                   (#\b (setf (x86::x86-operand-type op)
782                              (logior optype (x86::encode-operand-type
783                                              :imm8 :imm16 :imm32S  :imm32 :imm64)))))
784                 (setf (x86::x86-operand-type op)
785                       (logior (x86::x86-operand-type op)
786                               (smallest-imm-type (x86-lap-expression-value val))))
787                 (when (eql suffix #\q)
788                   (setf (x86::x86-operand-type op)
789                         (logandc2 (x86::x86-operand-type op)
790                                   (x86::encode-operand-type :imm32)))))
791                (t ; immediate value not constant
792                 (case suffix
793                   (#\q (setf (x86::x86-operand-type op)
794                              (logior optype
795                                      (x86::encode-operand-type :imm64 :imm32S))))
796                   (#\l (setf (x86::x86-operand-type op)
797                              (logior optype
798                                      (x86::encode-operand-type :imm32))))
799                   (#\w (setf (x86::x86-operand-type op)
800                              (logior optype
801                                      (x86::encode-operand-type :imm16))))
802                   (#\b  (setf (x86::x86-operand-type op)
803                              (logior optype
804                                      (x86::encode-operand-type :imm8))))))))))))
805
806(defun get-x86-opcode-templates (form)
807  (let* ((name (string (car form))))
808    (or
809     (gethash name x86::*x86-opcode-template-lists*)
810     ;; Try to determine a suffix, based on the size of the last
811     ;; register argument (if any.)  If that can be determined,
812     ;; tack it on to the end of NAME and try again.
813     (let* ((suffix nil))
814       (dolist (arg (cdr form))
815         (let* ((designator (x86-register-designator arg)))
816           (when designator
817             (destructuring-bind (regname) (cdr arg)
818               (let* ((reg (lookup-x86-register regname designator)))
819                 (when reg
820                   (let* ((type (x86::reg-entry-reg-type reg)))
821                     (cond ((logtest type (x86::encode-operand-type :reg8))
822                            (setq suffix #\b))
823                           ((logtest type (x86::encode-operand-type :reg16))
824                            (setq suffix #\w))
825                           ((logtest type (x86::encode-operand-type :reg32))
826                            (setq suffix #\l))
827                           ((logtest type (x86::encode-operand-type :reg64))
828                            (setq suffix #\q))))))))))
829       (when suffix
830         (let* ((n (length name))
831                (m (1+ n))
832                (s (make-string m)))
833           (declare (fixnum n m) (dynamic-extent s))
834           (dotimes (i n) (setf (schar s i) (char name i)))
835           (setf (schar s n) suffix)
836           (gethash s x86::*x86-opcode-template-lists*)))))))
837         
838               
839         
840     
841 
842;;; FORM is a list; its car doesn't name a macro or pseudo op.  If we
843;;; can find a matching opcode template, initialize the
844;;; x86-instruction with that template and these operands.
845;;; Note that this doesn't handle "prefix" instructions at all.
846;;; Things that would change the operand or address size are
847;;; of limited utility, as are REP* prefixes on string instructions
848;;; (because of the way that the lisp used %[E|R]DI and %[E|R]SI).
849;;; LOCK can be used in the preceding instruction.
850(defun parse-x86-instruction (form instruction)
851    (let* ((templates (or
852                       (get-x86-opcode-templates form)
853                       (error "Unknown X86 instruction ~s" form)))
854           (operands (cdr form)))
855      (let* ((parsed-operands (if operands
856                                (mapcar #'parse-x86-operand operands)))
857             (operand-types (mapcar #'x86::x86-operand-type parsed-operands))
858             (type0 (pop operand-types))
859             (type1 (pop operand-types))
860             (type2 (car operand-types)))
861
862        ;; (x86-optimize-imm parsed-operands suffix)
863        (dolist (template templates (error "Operands or suffix invalid in ~s" form))
864          (when (x86::match-template-types template type0 type1 type2)
865            (init-x86-instruction instruction template parsed-operands)
866            ;(check-suffix instruction form)
867            ;(x86-finalize-operand-types instruction)
868            (return instruction))))))
869
870
871
872
873             
874
875(defun optimize-displacement-type (disp)
876  (if disp
877    (let* ((value (early-x86-lap-expression-value disp)))
878      (if value
879        (if (typep value '(signed-byte 8))
880          (x86::encode-operand-type :disp8 :disp32 :disp32s :disp64)
881          (if (typep value '(signed-byte 32))
882            (x86::encode-operand-type :disp32s :disp64)
883            (if (typep value '(unsigned-byte 32))
884              (x86::encode-operand-type :disp32 :disp64)
885              (x86::encode-operand-type :disp64))))
886        (x86::encode-operand-type :disp32s :disp64)))
887    0))
888
889(defun optimize-displacements (operands)
890  (dotimes (i (length operands))
891    (let* ((op (svref operands i)))
892      (when (typep op 'x86::x86-memory-operand)
893        (let* ((disp (x86::x86-memory-operand-disp op))
894               (val (if disp (early-x86-lap-expression-value disp))))
895          (if (typep val '(signed-byte 32))
896            (setf (x86::x86-operand-type op)
897                  (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp32s))))
898          (if (typep val '(unsigned-byte 32))
899            (setf (x86::x86-operand-type op)
900                  (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp32))))
901          (if (and (logtest (x86::x86-operand-type op)
902                            (x86::encode-operand-type :disp32 :disp32S :disp16))
903                   (typep val '(signed-byte 8)))
904            (setf (x86::x86-operand-type op)
905                  (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp8)))))))))
906
907(defun x86-output-branch (frag-list insn)
908  (dolist (b (x86::x86-opcode-template-prefixes
909              (x86::x86-instruction-opcode-template insn)))
910    (when (or (= b x86::+data-prefix-opcode+)
911              (= b x86::+cs-prefix-opcode+)
912              (= b x86::+ds-prefix-opcode+))
913      (frag-list-push-byte frag-list b)))
914  (finish-frag-for-branch frag-list
915                          (x86::x86-instruction-base-opcode insn)
916                          (x86::x86-instruction-extra insn)))
917
918
919(defun x86-generate-instruction-code (frag-list insn)
920  (let* ((template (x86::x86-instruction-opcode-template insn))
921         (opcode-modifier (x86::x86-opcode-template-flags template))
922         (prefixes (x86::x86-opcode-template-prefixes template)))
923    (let* ((explicit-seg-prefix (x86::x86-instruction-seg-prefix insn)))
924      (when explicit-seg-prefix
925        (push explicit-seg-prefix prefixes)))
926    (cond
927      ((logtest (x86::encode-opcode-modifier :jump) opcode-modifier)
928       ;; a variable-length pc-relative branch, possibly preceded
929       ;; by prefixes (used for branch prediction, mostly.)
930       (x86-output-branch frag-list insn))
931      (t
932       (let* ((base-opcode (x86::x86-instruction-base-opcode insn)))
933         (declare (fixnum base-opcode))
934         (dolist (b prefixes)
935           (frag-list-push-byte frag-list b))
936         (let* ((rex-bits (logand #x8f
937                                  (or (x86::x86-instruction-rex-prefix insn)
938                                      0))))
939           (declare (fixnum rex-bits))
940           (unless (= 0 rex-bits)
941             (frag-list-push-byte frag-list (logior #x40 (logand rex-bits #xf)))))
942         (when (logtest base-opcode #xff00)
943           (frag-list-push-byte frag-list (ldb (byte 8 8) base-opcode)))
944         (frag-list-push-byte frag-list (ldb (byte 8 0) base-opcode)))
945       (let* ((modrm (x86::x86-instruction-modrm-byte insn)))
946         (when modrm
947           (frag-list-push-byte frag-list modrm)
948           (let* ((sib (x86::x86-instruction-sib-byte insn)))
949             (when sib
950               (frag-list-push-byte frag-list sib)))))
951       (let* ((operands (x86::x86-opcode-template-operand-types template)))
952         (if (and (= (length operands) 1)
953                  (= (x86::encode-operand-type :label) (aref operands 0)))
954           (let* ((label (x86::x86-instruction-extra insn))
955                  (frag (frag-list-current frag-list))
956                  (pos (frag-list-position frag-list)))
957             (push (make-reloc :type :branch32
958                               :arg label
959                               :frag frag
960                               :pos pos)
961                   (frag-relocs frag))
962             (frag-list-push-32 frag-list 0))
963           (let* ((disp (x86::x86-instruction-disp insn)))
964             (when disp
965               (let* ((optype (x86::x86-instruction-extra insn))
966                      (pcrel (and (logtest (x86::encode-operand-type :label) optype)
967                              (typep disp 'label-x86-lap-expression)))
968                  (val (unless pcrel (early-x86-lap-expression-value disp))))
969             (if (null val)
970               ;; We can do better job here, but (for now)
971               ;; generate a 32-bit relocation
972               (let* ((frag (frag-list-current frag-list))
973                      (pos (frag-list-position frag-list)))
974                 (push (make-reloc :type (if pcrel :branch32 :expr32)
975                                   :arg (if pcrel (label-x86-lap-expression-label disp) disp)
976                                   :frag frag
977                                   :pos pos)
978                       (frag-relocs frag))
979                 (frag-list-push-32 frag-list 0))
980               (if (logtest optype (x86::encode-operand-type :disp8))
981                 (frag-list-push-byte frag-list (logand val #xff))
982                 (if (logtest optype (x86::encode-operand-type :disp32 :disp32s))
983                   (frag-list-push-32 frag-list val)
984                   (frag-list-push-64 frag-list val)))))))))
985       ;; Emit immediate operand(s).
986       (let* ((op (x86::x86-instruction-imm insn)))
987         (when op
988           (let* ((optype (x86::x86-operand-type op))
989                  (expr (x86::x86-immediate-operand-value op))
990                  (val (early-x86-lap-expression-value expr)))
991             (if (null val)
992               (let* ((frag (frag-list-current frag-list))
993                      (pos (frag-list-position frag-list))
994                      (size 4)
995                      (reloctype :expr32))
996                 (when (logtest optype
997                                (x86::encode-operand-type
998                                 :imm8 :imm8S :imm16 :imm64))
999                   (setq size 2 reloctype :expr16)
1000                   (if (logtest optype (x86::encode-operand-type
1001                                        :imm8 :imm8s))
1002                     (setq size 1 reloctype :expr8)
1003                     (if (logtest optype (x86::encode-operand-type :imm64))
1004                       (setq size 8 reloctype :expr64))))
1005                 (push (make-reloc :type reloctype
1006                                   :arg expr
1007                                   :frag frag
1008                                   :pos pos)
1009                       (frag-relocs frag))
1010                 (dotimes (b size)
1011                   (frag-list-push-byte frag-list 0)))
1012               (if (logtest optype (x86::encode-operand-type :imm8 :imm8s))
1013                 (frag-list-push-byte frag-list (logand val #xff))
1014                 (if (logtest optype (x86::encode-operand-type :imm16))
1015                   (frag-list-push-16 frag-list (logand val #xffff))
1016                   (if (logtest optype (x86::encode-operand-type :imm64))
1017                     (frag-list-push-64 frag-list val)
1018                     (frag-list-push-32 frag-list val))))))))))
1019    (let* ((frag (frag-list-current frag-list)))
1020      (if (eq (car (frag-type frag)) :pending-talign)
1021        (finish-pending-talign-frag frag-list)))))
1022
1023;;; Returns the active frag list after processing directive(s).
1024(defun x86-lap-directive (frag-list directive arg &optional main-frag-list exception-frag-list)
1025  (declare (ignorable main-frag-list exception-frag-list))
1026  (case directive
1027    (:tra
1028     (finish-frag-for-align frag-list 3)
1029     (x86-lap-directive frag-list :long `(:^ ,arg))
1030     (emit-x86-lap-label frag-list arg))
1031    (:fixed-constants
1032     (dolist (constant arg)
1033       (ensure-x86-lap-constant-label constant)))
1034    (:arglist (setq *x86-lap-lfun-bits* (encode-lambda-list arg)))
1035    ((:uuo :uuo-section)
1036     (if exception-frag-list
1037       (progn
1038         (setq frag-list exception-frag-list)
1039         (finish-frag-for-align frag-list 2))))
1040    ((:main :main-section)
1041     (when main-frag-list (setq frag-list main-frag-list)))
1042    (:anchored-uuo-section
1043     (setq frag-list (x86-lap-directive frag-list :uuo-section nil main-frag-list exception-frag-list))
1044     (setq frag-list (x86-lap-directive frag-list :long `(:^ ,arg) main-frag-list exception-frag-list)))
1045    (t (let* ((exp (parse-x86-lap-expression arg))
1046              (constantp (or (constant-x86-lap-expression-p exp)
1047                             (not (x86-lap-expression-p exp)))))
1048         
1049         (if constantp
1050           (let* ((val (x86-lap-expression-value exp)))
1051             (ecase directive
1052               (:code-size
1053                (if *x86-lap-fixed-code-words*
1054                  (error "Duplicate :CODE-SIZE directive")
1055                  (setq *x86-lap-fixed-code-words* val)))
1056               (:byte (frag-list-push-byte frag-list val))
1057               (:short (frag-list-push-16 frag-list val))
1058               (:long (frag-list-push-32 frag-list val))
1059               (:quad (frag-list-push-64 frag-list val))
1060               (:align (finish-frag-for-align frag-list val))
1061               (:talign (finish-frag-for-talign frag-list val))
1062               (:org (finish-frag-for-org frag-list val))))
1063           (let* ((pos (frag-list-position frag-list))
1064                  (frag (frag-list-current frag-list))
1065                  (reloctype nil))
1066             (ecase directive
1067               (:byte (frag-list-push-byte frag-list 0)
1068                      (setq reloctype :expr8))
1069               (:short (frag-list-push-16 frag-list 0)
1070                       (setq reloctype :expr16))
1071               (:long (frag-list-push-32 frag-list 0)
1072                      (setq reloctype :expr32))
1073               (:quad (frag-list-push-64 frag-list 0)
1074                      (setq reloctype :expr64))
1075               (:align (error ":align expression ~s not constant" arg))
1076               (:talign (error ":talign expression ~s not constant" arg)))
1077             (when reloctype
1078               (push
1079                (make-reloc :type reloctype
1080                            :arg exp
1081                            :pos pos
1082                            :frag frag)
1083                (frag-relocs frag))))))))
1084  frag-list)
1085
1086
1087(defun x862-lap-process-regsave-info (frag-list regsave-label regsave-mask regsave-addr)
1088  (when regsave-label
1089    (let* ((label-diff (min (- (x86-lap-label-address regsave-label)
1090                               *x86-lap-entry-offset*)
1091                            255))
1092           (first-frag (frag-list-succ frag-list)))
1093      (setf (frag-ref first-frag 4) label-diff
1094            (frag-ref first-frag 5) regsave-addr
1095            (frag-ref first-frag 6) regsave-mask))
1096    t))
1097                       
1098         
1099
1100(defun x86-lap-form (form frag-list instruction  main-frag-list exception-frag-list)
1101  (if (and form (symbolp form))
1102    (emit-x86-lap-label frag-list form)
1103    (if (or (atom form) (not (symbolp (car form))))
1104      (error "Unknown X86-LAP form ~s ." form)
1105      (multiple-value-bind (expansion expanded)
1106          (x86-lap-macroexpand-1 form)
1107        (if expanded
1108          (x86-lap-form expansion frag-list instruction main-frag-list exception-frag-list)
1109          (if (typep (car form) 'keyword)
1110            (destructuring-bind (op &optional arg) form
1111              (setq frag-list (x86-lap-directive frag-list op arg main-frag-list exception-frag-list)))
1112            (case (car form)
1113              (progn
1114                (dolist (f (cdr form))
1115                  (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list))))
1116              (let
1117                  (destructuring-bind (equates &body body)
1118                      (cdr form)
1119                    (setq frag-list (x86-lap-equate-form equates frag-list instruction body main-frag-list exception-frag-list))))
1120              (t
1121               (parse-x86-instruction form instruction)
1122               (x86-generate-instruction-code frag-list instruction))))))))
1123  frag-list)
1124
1125(defun relax-align (address bits)
1126  (let* ((mask (1- (ash 1 bits))))
1127    (- (logandc2 (+ address mask) mask) address)))
1128
1129(defun relax-talign (address mask)
1130  (do* ((i 0 (1+ i)))
1131       ((= (logand address 7) mask) i)
1132    (incf address)))
1133
1134
1135(defun relax-frag-list (frag-list)
1136  ;; First, assign tentative addresses to all frags, assuming that
1137  ;; span-dependent instructions have short displacements.
1138  ;; While doing that, find branches to the next instruction and
1139  ;; remove them.  In some cases, that'll cause the containing
1140  ;; frag to become empty; that could introduce branches to the
1141  ;; next instruction, so we repeat this process until we can
1142  ;; make it all the way through the frag-list.
1143  (loop
1144    (let* ((address 8))
1145      (declare (fixnum address))
1146      (when (do-dll-nodes (frag frag-list t)
1147              (setf (frag-address frag) address)
1148              (incf address (frag-length frag))
1149              (case (car (frag-type frag))
1150                (:org
1151                 ;; Do nothing, for now
1152                 )
1153                (:align
1154                 (incf address (relax-align address (cadr (frag-type frag)))))
1155                (:talign
1156                 (let* ((arg (cadr (frag-type frag))))
1157                   (if (null arg)
1158                     ;;; Never generated code in :pending-talign frag
1159                     (setf (frag-type frag) nil)
1160                     (incf address (relax-talign address arg)))))
1161                ((:assumed-short-branch :assumed-short-conditional-branch)
1162                 (destructuring-bind (label pos reloc) (cdr (frag-type frag))
1163                   (let* ((next (frag-succ frag)))
1164                     (when (and (eq (x86-lap-label-frag label) next)
1165                                (eql (x86-lap-label-offset label) 0))
1166                       ;; Delete the reloc associated with this branch.
1167                       (setf (frag-relocs frag)
1168                             (delete reloc (frag-relocs frag)))
1169                       ;; This will be a "normal" frag
1170                       (setf (frag-type frag) nil)
1171                       ;; Remove the (short) branch, and remove the frag
1172                       ;; if it becomes empty.  If the frag does become
1173                       ;; empty, migrate any labels to the next frag.
1174                       (when (zerop (setf (frag-length frag)
1175                                        (1- pos)))
1176
1177                         (do* ((labels (frag-labels frag)))
1178                              ((null labels))
1179                           (let* ((lab (pop labels)))
1180                             (setf (x86-lap-label-frag lab) next
1181                                   (x86-lap-label-offset lab) 0)
1182                             (push lab (frag-labels next))))
1183                         (remove-dll-node frag))
1184                       (return nil)))))))
1185        (return))))
1186  ;; Repeatedly "stretch" frags containing span-dependent instructions
1187  ;; until nothing's stretched.  It may take several iterations to
1188  ;; converge; is convergence guaranteed ?
1189  (loop
1190    (let* ((stretch 0)                  ;cumulative growth in frag sizes
1191           (stretched nil))             ;any change on this pass ?
1192      (do-dll-nodes (frag frag-list)
1193        (let* ((growth 0)
1194               (fragtype (frag-type frag))
1195               (was-address (frag-address frag))
1196               (address (incf (frag-address frag) stretch)))
1197          (case (car fragtype)
1198            (:org
1199             (let* ((target (cadr (frag-type frag)))
1200                    (next-address (frag-address (frag-succ frag))))
1201               (setq growth (- target next-address))
1202               (if (< growth 0)
1203                 (error "Code size exceeds :CODE-SIZE constraint ~s"
1204                        (ash target -3))
1205                 (decf growth stretch))))
1206            (:align
1207             (let* ((bits (cadr fragtype))
1208                    (len (frag-length frag))
1209                    (oldoff (relax-align (+ was-address len) bits))
1210                    (newoff (relax-align (+ address len) bits)))
1211               (setq growth (- newoff oldoff))))
1212            (:talign
1213             (let* ((arg (cadr fragtype))
1214                    (len (frag-length frag))
1215                    (oldoff (relax-talign (+ was-address len) arg))
1216                    (newoff (relax-talign (+ address len) arg)))
1217               (setq growth (- newoff oldoff))))
1218            ;; If we discover - on any iteration - that a short
1219            ;; branch doesn't fit, we change the type (and the reloc)
1220            ;; destructively to a wide branch indicator and will
1221            ;; never change our minds about that, so we only have
1222            ;; to look here at conditional branches that may still
1223            ;; be able to use a 1-byte displacement.
1224            ((:assumed-short-branch :assumed-short-conditional-branch)
1225             (destructuring-bind (label pos reloc) (cdr (frag-type frag))
1226               (declare (fixnum pos))
1227               (let* ((label-address (x86-lap-label-address label))
1228                      (branch-pos (+ address (1+ pos)))
1229                      (diff (- label-address branch-pos)))
1230                 (unless (typep diff '(signed-byte 8))
1231                   (cond ((eq (car fragtype) :assumed-short-branch)
1232                          ;; replace the opcode byte
1233                          (setf (frag-ref frag (the fixnum (1- pos)))
1234                                x86::+jump-pc-relative+)
1235                          (frag-push-byte frag 0)
1236                          (frag-push-byte frag 0)
1237                          (frag-push-byte frag 0)
1238                          (setf (reloc-type reloc) :branch32)
1239                          (setf (car fragtype) :long-branch)
1240                          (setq growth 3))
1241                         (t
1242                          ;; Conditional branch: must change
1243                          ;; 1-byte opcode to 2 bytes, add 4-byte
1244                          ;; displacement
1245                          (let* ((old-opcode (frag-ref frag (1- pos))))
1246                            (setf (frag-ref frag (1- pos)) #x0f
1247                                  (frag-ref frag pos) (+ old-opcode #x10))
1248                            (frag-push-byte frag 0)
1249                            (frag-push-byte frag 0)
1250                            (frag-push-byte frag 0)
1251                            (frag-push-byte frag 0)
1252                            (setf (reloc-type reloc) :branch32
1253                                  (reloc-pos reloc) (1+ pos))
1254                            (setf (car fragtype) :long-conditional-branch
1255                                  (caddr fragtype) (1+ pos))
1256                            (setq growth 4)))))))))
1257          (unless (eql 0 growth)
1258            (incf stretch growth)
1259            (setq stretched t))))
1260      (unless stretched (return)))))
1261
1262(defun apply-relocs (frag-list)
1263  (flet ((emit-byte (frag pos b)
1264           (setf (frag-ref frag pos) (logand b #xff))))
1265    (flet ((emit-short (frag pos s)
1266             (setf (frag-ref frag pos) (ldb (byte 8 0) s)
1267                   (frag-ref frag (1+ pos)) (ldb (byte 8 8) s))))
1268      (flet ((emit-long (frag pos l)
1269               (emit-short frag pos (ldb (byte 16 0) l))
1270               (emit-short frag (+ pos 2) (ldb (byte 16 16) l))))
1271        (flet ((emit-quad (frag pos q)
1272                 (emit-long frag pos (ldb (byte 32 0) q))
1273                 (emit-long frag (+ pos 4) (ldb (byte 32 32) q))))
1274          (do-dll-nodes (frag frag-list)
1275            (let* ((address (frag-address frag)))
1276              (dolist (reloc (frag-relocs frag))
1277                (let* ((pos (reloc-pos reloc))
1278                       (arg (reloc-arg reloc)))
1279                  (ecase (reloc-type reloc)
1280                    (:branch8 (let* ((target (x86-lap-label-address arg))
1281                                     (refpos (+ address (1+ pos))))
1282                                (emit-byte frag pos (- target refpos))))
1283                    (:branch32 (let* ((target (x86-lap-label-address arg))
1284                                     (refpos (+ address pos 4)))
1285                                (emit-long frag pos (- target refpos))))
1286                    (:expr8 (emit-byte frag pos  (x86-lap-expression-value arg)))
1287                    (:expr16 (emit-short frag pos (x86-lap-expression-value arg)))
1288                    (:expr32 (emit-long frag pos (x86-lap-expression-value arg)))
1289                    (:expr64 (emit-quad frag pos (x86-lap-expression-value arg)))))))))))))
1290                             
1291
1292(defun frag-emit-nops (frag count)
1293  (let* ((nnops (ash (+ count 3) -2))
1294         (len (floor count nnops))
1295         (remains (- count (* nnops len))))
1296    (dotimes (i remains)
1297      (dotimes (k len) (frag-push-byte frag #x66))
1298      (frag-push-byte frag #x90))
1299    (do* ((i remains (1+ i)))
1300         ((= i nnops))
1301      (dotimes (k (1- len)) (frag-push-byte frag #x66))
1302      (frag-push-byte frag #x90))))
1303 
1304(defun fill-for-alignment (frag-list)
1305  (ccl::do-dll-nodes (frag frag-list)
1306    (let* ((next (ccl::dll-node-succ frag)))
1307      (unless (eq next frag-list)
1308        (let* ((addr (frag-address frag))
1309               (nextaddr (frag-address next))
1310               (pad (- nextaddr (+ addr (frag-length frag)))))
1311          (unless (eql 0 pad)
1312            (frag-emit-nops frag pad)))))))
1313
1314(defun show-frag-bytes (frag-list)
1315  (ccl::do-dll-nodes (frag frag-list)
1316    (format t "~& frag at #x~x" (frag-address frag))
1317    (dotimes (i (frag-length frag))
1318      (unless (logtest 15 i)
1319        (format t "~&"))
1320      (format t "~2,'0x " (frag-ref frag i)))))
1321
1322(defun x86-lap-equate-form (eqlist fraglist instruction  body main-frag exception-frag) 
1323  (let* ((symbols (mapcar #'(lambda (x)
1324                              (let* ((name (car x)))
1325                                (or
1326                                 (and name 
1327                                      (symbolp name)
1328                                      (not (constant-symbol-p name))
1329                                      (or (not (gethash (string name)
1330                                                        x86::*x86-registers*))
1331                                          (error "Symbol ~s already names and x86 register" name))
1332                                      name)
1333                                 (error 
1334                                  "~S is not a bindable symbol name ." name))))
1335                          eqlist))
1336         (values (mapcar #'(lambda (x) (x86-register-ordinal-or-expression
1337                                        (cadr x)))
1338                         eqlist)))
1339    (progv symbols values
1340      (dolist (form body fraglist)
1341        (setq fraglist (x86-lap-form form fraglist instruction main-frag exception-frag))))))
1342               
1343(defun cross-create-x86-function (name frag-list constants bits debug-info)
1344  (let* ((constants-vector (%alloc-misc (+ (length constants)
1345                                           (+ 2
1346                                              (if name 1 0)
1347                                              (if debug-info 1 0)))
1348                                        target::subtag-xfunction)))
1349    (unless name (setq bits (logior bits (ash -1 $lfbits-noname-bit))))
1350    (let* ((last (1- (uvsize constants-vector))))
1351      (declare (fixnum last))
1352      (setf (uvref constants-vector last) bits)
1353      (when name
1354        (setf (uvref constants-vector (decf last)) name))
1355      (when debug-info
1356        (setf (uvref constants-vector (decf last)) debug-info))
1357      (dolist (c constants)
1358        (setf (uvref constants-vector (decf last)) (car c)))
1359      (let* ((nbytes 0))
1360        (do-dll-nodes (frag frag-list)
1361          (incf nbytes (frag-length frag)))
1362        (let* ((code-vector (make-array nbytes
1363                                        :element-type '(unsigned-byte 8)))
1364               (target-offset 0))
1365          (declare (fixnum target-offset))
1366          (setf (uvref constants-vector 0) code-vector)
1367          (do-dll-nodes (frag frag-list)
1368            (incf target-offset (frag-output-bytes frag code-vector target-offset)))
1369          constants-vector)))))
1370
1371#+x86-target
1372(defun create-x86-function (name frag-list constants bits debug-info)
1373  (unless name (setq bits (logior bits (ash -1 $lfbits-noname-bit))))
1374  (let* ((code-bytes (let* ((nbytes 0))
1375                       (do-dll-nodes (frag frag-list nbytes)
1376                         (incf nbytes (frag-length frag)))))
1377         (code-words (ash code-bytes (- target::word-shift)))
1378         (function-vector (allocate-typed-vector :function code-words)))
1379    (declare (fixnum num-constants code-bytes code-words))
1380    (let* ((target-offset 0))
1381      (declare (fixnum target-offset))
1382      (do-dll-nodes (frag frag-list)
1383        (incf target-offset (frag-output-bytes frag function-vector target-offset))))
1384    (let* ((last (1- (uvsize function-vector))))
1385      (declare (fixnum last))
1386      (setf (uvref function-vector last) bits)
1387      (when name
1388        (setf (uvref function-vector (decf last)) name))
1389      (when debug-info
1390        (setf (uvref function-vector (decf last)) debug-info))
1391      (dolist (c constants)
1392        (setf (uvref function-vector (decf last)) (car c)))
1393      (%function-vector-to-function function-vector))))
1394
1395
1396     
1397(defun %define-x86-lap-function (name forms &optional (bits 0))
1398  (let* ((*x86-lap-labels* ())
1399         (*x86-lap-constants* ())
1400         (*x86-lap-fixed-code-words* nil)
1401         (*x86-lap-lfun-bits* bits)
1402         (end-code-tag (gensym))
1403         (entry-code-tag (gensym))
1404         (instruction (x86::make-x86-instruction))
1405         (main-frag-list (make-frag-list))
1406         (exception-frag-list (make-frag-list))
1407         (frag-list main-frag-list))
1408    (make-x86-lap-label end-code-tag)
1409    (make-x86-lap-label entry-code-tag)
1410    (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
1411                                              *x86-lap-entry-offset*) -3))
1412    (x86-lap-directive frag-list :byte 0) ;regsave pc
1413    (x86-lap-directive frag-list :byte 0) ;regsave ea
1414    (x86-lap-directive frag-list :byte 0) ;regsave mask
1415    (emit-x86-lap-label frag-list entry-code-tag)
1416
1417    (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction main-frag-list exception-frag-list)
1418    (dolist (f forms)
1419      (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list)))
1420    (setq frag-list main-frag-list)
1421    (merge-dll-nodes frag-list exception-frag-list)
1422    (x86-lap-directive frag-list :align 3)
1423    (when *x86-lap-fixed-code-words*
1424      (x86-lap-directive frag-list :org (ash *x86-lap-fixed-code-words* 3)))
1425    (x86-lap-directive frag-list :quad x8664::function-boundary-marker)
1426    (emit-x86-lap-label frag-list end-code-tag)
1427    (dolist (c (reverse *x86-lap-constants*))
1428      (emit-x86-lap-label frag-list (x86-lap-label-name (cdr c)))
1429      (x86-lap-directive frag-list :quad 0))
1430    (when name
1431      (x86-lap-directive frag-list :quad 0))
1432    ;; room for lfun-bits
1433    (x86-lap-directive frag-list :quad 0)
1434    (relax-frag-list frag-list)
1435    (apply-relocs frag-list)
1436    (fill-for-alignment frag-list)
1437    ;;(show-frag-bytes frag-list)
1438    (funcall #-x86-target #'cross-create-x86-function
1439             #+x86-target (if (eq *target-backend* *host-backend*)
1440                            #'create-x86-function
1441                            #'cross-create-x86-function)
1442             name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil)))
1443
1444
1445(defmacro defx86lapfunction (&environment env name arglist &body body
1446                             &aux doc)
1447  (if (not (endp body))
1448      (and (stringp (car body))
1449           (cdr body)
1450           (setq doc (car body))
1451           (setq body (cdr body))))
1452  `(progn
1453     (eval-when (:compile-toplevel)
1454       (note-function-info ',name t ,env))
1455     #-x86-target
1456     (progn
1457       (eval-when (:load-toplevel)
1458         (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))
1459       (eval-when (:execute)
1460         (%define-x86-lap-function ',name '((let ,arglist ,@body)))))
1461     #+x86-target       ; just shorthand for defun
1462     (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)))
Note: See TracBrowser for help on using the repository browser.