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

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

Support memory operands of the form (:rcontext displacment), which
will expand into either (@ (%seg rcontext) displacement) or
(@ displacement (% rcontext)) according to whether or not
"rcontext" is a segment register (most platforms) or a GPR (win64).

(I haven't tested this yet; am checking it in to see if it works ...)

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