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

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

New Japanese character encodings cp 932, eucjp from Yoshinori Tahara.
New x8632 large function support (from rme, mostly.)
The latter's a bit hard to bootstrap; new binaries, fasl/image versions
soon.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 70.1 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) (:constructor nil)))
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" head 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                       (target-arch-case
730                        (:x8632 x86::+x8632-segment-register-offset+)
731                        (:x8664 x86::+x8664-segment-register-offset+)))
732                 (parse-x86-memory-operand `((% :rcontext) ,(cadr form)))
733                 (parse-x86-memory-operand `(,(cadr form) (% :rcontext)))))
734              ((setq designator (x86-register-designator form))
735               (destructuring-bind (reg) (cdr form)
736                 (parse-x86-register-operand reg designator)))
737              ((string= head '@)
738               (parse-x86-memory-operand  (cdr form)))
739              (t (error "unknown X86 operand: ~s" form)))
740        (error "unknown X86 operand: ~s" form)))
741    ;; Treat an atom as a label.
742    (parse-x86-label-reference form)))
743
744
745
746
747;;; Initialize some fields in the instruction from the template;
748;;; set other fields (which depend on operand values) to NIL.
749(defun set-x86-instruction-template (i template)
750  (setf (x86::x86-instruction-opcode-template i) template
751        (x86::x86-instruction-base-opcode i) (x86::x86-opcode-template-base-opcode template)
752        (x86::x86-instruction-modrm-byte i) (x86::x86-opcode-template-modrm-byte template)
753        (x86::x86-instruction-rex-prefix i) (target-arch-case
754                                             (:x8632 nil)
755                                             (:x8664
756                                              (x86::x86-opcode-template-rex-prefix template)))
757        (x86::x86-instruction-sib-byte i) nil
758        (x86::x86-instruction-seg-prefix i) nil
759        (x86::x86-instruction-disp i) nil
760        (x86::x86-instruction-imm i) nil
761        (x86::x86-instruction-extra i) nil))
762
763
764(defun init-x86-instruction (instruction template parsed-operands)
765  (set-x86-instruction-template instruction template)
766  (let* ((insert-classes (x86::x86-opcode-template-operand-classes template))
767         (insert-functions x86::*x86-operand-insert-functions*))
768    (dotimes (i (length parsed-operands) instruction)
769      (funcall (svref insert-functions (svref insert-classes i))
770               instruction
771               (pop parsed-operands)))))
772
773
774
775(defun smallest-imm-type (val)
776  (if (eql val 1)
777    (x86::encode-operand-type :Imm1 :Imm8 :Imm8S :Imm16 :Imm32 :Imm32S :Imm64)
778    (typecase val
779      ((signed-byte 8)
780       (x86::encode-operand-type :Imm8S :imm8 :Imm16 :Imm32 :Imm32S :Imm64))
781      ((unsigned-byte 8)
782       (x86::encode-operand-type  :imm8 :Imm16 :Imm32 :Imm32S :Imm64))
783      ((signed-byte 16)
784       (x86::encode-operand-type  :Imm16 :Imm32 :Imm32S :Imm64))
785      ((unsigned-byte 16)
786       (x86::encode-operand-type  :Imm16 :Imm32 :Imm32S :Imm64))
787      ((signed-byte 32)
788       (x86::encode-operand-type :Imm32 :Imm32S :Imm64))
789      ((unsigned-byte 32)
790       (x86::encode-operand-type :Imm32 :Imm64))
791      (t (x86::encode-operand-type :Imm64)))))
792
793   
794(defun x86-optimize-imm (operands suffix)
795  (unless suffix
796    ;; See if we can determine an implied suffix from operands.
797    (do* ((i (1- (length operands)) (1- i)))
798         ((< i 0))
799      (declare (fixnum i))
800      (let* ((op (svref operands i))
801             (optype (x86::x86-operand-type op)))
802        (when (logtest optype (x86::encode-operand-type :reg))
803          (cond ((logtest optype (x86::encode-operand-type :reg8))
804                 (setq suffix #\b))
805                ((logtest optype (x86::encode-operand-type :reg16))
806                 (setq suffix #\w))
807                ((logtest optype (x86::encode-operand-type :reg32))
808                 (setq suffix #\l))
809                ((logtest optype (x86::encode-operand-type :reg64))
810                 (setq suffix #\q)))
811          (return)))))
812  (dotimes (i (length operands))
813    (let* ((op (svref operands i))
814           (optype (x86::x86-operand-type op)))
815      (when (logtest optype (x86::encode-operand-type :imm))
816        (let* ((val (x86::x86-immediate-operand-value op)))
817          (cond ((typep val 'constant-x86-lap-expression)
818                 (case suffix
819                   (#\l (setf (x86::x86-operand-type op)
820                              (logior optype (x86::encode-operand-type
821                                              :imm32 :imm64))))
822                   (#\w (setf (x86::x86-operand-type op)
823                              (logior optype (x86::encode-operand-type
824                                              :imm16 :imm32S  :imm32 :imm64))))
825                   (#\b (setf (x86::x86-operand-type op)
826                              (logior optype (x86::encode-operand-type
827                                              :imm8 :imm16 :imm32S  :imm32 :imm64)))))
828                 (setf (x86::x86-operand-type op)
829                       (logior (x86::x86-operand-type op)
830                               (smallest-imm-type (x86-lap-expression-value val))))
831                 (when (eql suffix #\q)
832                   (setf (x86::x86-operand-type op)
833                         (logandc2 (x86::x86-operand-type op)
834                                   (x86::encode-operand-type :imm32)))))
835                (t ; immediate value not constant
836                 (case suffix
837                   (#\q (setf (x86::x86-operand-type op)
838                              (logior optype
839                                      (x86::encode-operand-type :imm64 :imm32S))))
840                   (#\l (setf (x86::x86-operand-type op)
841                              (logior optype
842                                      (x86::encode-operand-type :imm32))))
843                   (#\w (setf (x86::x86-operand-type op)
844                              (logior optype
845                                      (x86::encode-operand-type :imm16))))
846                   (#\b  (setf (x86::x86-operand-type op)
847                              (logior optype
848                                      (x86::encode-operand-type :imm8))))))))))))
849
850(defun get-x86-opcode-templates (form)
851  (let* ((name (string (car form))))
852    (or
853     (gethash name x86::*x86-opcode-template-lists*)
854     ;; Try to determine a suffix, based on the size of the last
855     ;; register argument (if any.)  If that can be determined,
856     ;; tack it on to the end of NAME and try again.
857     (let* ((suffix nil))
858       (dolist (arg (cdr form))
859         (let* ((designator (x86-register-designator arg)))
860           (when designator
861             (destructuring-bind (regname) (cdr arg)
862               (let* ((reg (lookup-x86-register regname designator)))
863                 (when reg
864                   (let* ((type (x86::reg-entry-reg-type reg)))
865                     (cond ((logtest type (x86::encode-operand-type :reg8))
866                            (setq suffix #\b))
867                           ((logtest type (x86::encode-operand-type :reg16))
868                            (setq suffix #\w))
869                           ((logtest type (x86::encode-operand-type :reg32))
870                            (setq suffix #\l))
871                           ((logtest type (x86::encode-operand-type :reg64))
872                            (setq suffix #\q))))))))))
873       (when suffix
874         (let* ((n (length name))
875                (m (1+ n))
876                (s (make-string m)))
877           (declare (fixnum n m) (dynamic-extent s))
878           (dotimes (i n) (setf (schar s i) (char name i)))
879           (setf (schar s n) suffix)
880           (gethash s x86::*x86-opcode-template-lists*)))))))
881         
882               
883         
884     
885 
886;;; FORM is a list; its car doesn't name a macro or pseudo op.  If we
887;;; can find a matching opcode template, initialize the
888;;; x86-instruction with that template and these operands.
889;;; Note that this doesn't handle "prefix" instructions at all.
890;;; Things that would change the operand or address size are
891;;; of limited utility, as are REP* prefixes on string instructions
892;;; (because of the way that the lisp used %[E|R]DI and %[E|R]SI).
893;;; LOCK can be used in the preceding instruction.
894(defun parse-x86-instruction (form instruction)
895    (let* ((templates (or
896                       (get-x86-opcode-templates form)
897                       (error "Unknown X86 instruction ~s" form)))
898           (operands (cdr form)))
899      (let* ((parsed-operands (if operands
900                                (mapcar #'parse-x86-operand operands)))
901             (operand-types (mapcar #'x86::x86-operand-type parsed-operands))
902             (type0 (pop operand-types))
903             (type1 (pop operand-types))
904             (type2 (car operand-types)))
905
906        ;; (x86-optimize-imm parsed-operands suffix)
907        (dolist (template templates (error "Operands or suffix invalid in ~s" form))
908          (when (x86::match-template-types template type0 type1 type2)
909            (init-x86-instruction instruction template parsed-operands)
910            ;(check-suffix instruction form)
911            ;(x86-finalize-operand-types instruction)
912            (return instruction))))))
913
914
915
916
917             
918;;; xxx - might want to omit disp64 when doing 32 bit code
919(defun optimize-displacement-type (disp)
920  (if disp
921    (let* ((value (early-x86-lap-expression-value disp)))
922      (if value
923        (if (typep value '(signed-byte 8))
924          (x86::encode-operand-type :disp8 :disp32 :disp32s :disp64)
925          (if (typep value '(signed-byte 32))
926            (x86::encode-operand-type :disp32s :disp64)
927            (if (typep value '(unsigned-byte 32))
928              (x86::encode-operand-type :disp32 :disp64)
929              (x86::encode-operand-type :disp64))))
930        (x86::encode-operand-type :disp32s :disp64)))
931    0))
932
933(defun optimize-displacements (operands)
934  (dotimes (i (length operands))
935    (let* ((op (svref operands i)))
936      (when (typep op 'x86::x86-memory-operand)
937        (let* ((disp (x86::x86-memory-operand-disp op))
938               (val (if disp (early-x86-lap-expression-value disp))))
939          (if (typep val '(signed-byte 32))
940            (setf (x86::x86-operand-type op)
941                  (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp32s))))
942          (if (typep val '(unsigned-byte 32))
943            (setf (x86::x86-operand-type op)
944                  (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp32))))
945          (if (and (logtest (x86::x86-operand-type op)
946                            (x86::encode-operand-type :disp32 :disp32S :disp16))
947                   (typep val '(signed-byte 8)))
948            (setf (x86::x86-operand-type op)
949                  (logior (x86::x86-operand-type op) (x86::encode-operand-type :disp8)))))))))
950
951(defun x86-output-branch (frag-list insn)
952  (dolist (b (x86::x86-opcode-template-prefixes
953              (x86::x86-instruction-opcode-template insn)))
954    (when (or (= b x86::+data-prefix-opcode+)
955              (= b x86::+cs-prefix-opcode+)
956              (= b x86::+ds-prefix-opcode+))
957      (frag-list-push-byte frag-list b)))
958  (finish-frag-for-branch frag-list
959                          (x86::x86-instruction-base-opcode insn)
960                          (x86::x86-instruction-extra insn)))
961
962(defun x86-generate-instruction-code (frag-list insn)
963  (let* ((template (x86::x86-instruction-opcode-template insn))
964         (flags (x86::x86-opcode-template-flags template))
965         (prefixes (x86::x86-opcode-template-prefixes template)))
966    (let* ((explicit-seg-prefix (x86::x86-instruction-seg-prefix insn)))
967      (when explicit-seg-prefix
968        (push explicit-seg-prefix prefixes)))
969    (cond
970      ((logtest (x86::encode-opcode-flags :jump) flags)
971       ;; a variable-length pc-relative branch, possibly preceded
972       ;; by prefixes (used for branch prediction, mostly.)
973       (x86-output-branch frag-list insn))
974      (t
975       (let* ((base-opcode (x86::x86-instruction-base-opcode insn)))
976         (declare (fixnum base-opcode))
977         (dolist (b prefixes)
978           (frag-list-push-byte frag-list b))
979         (let* ((rex-bits (logand #x8f
980                                  (or (x86::x86-instruction-rex-prefix insn)
981                                      0))))
982           (declare (fixnum rex-bits))
983           (unless (= 0 rex-bits)
984             (frag-list-push-byte frag-list (logior #x40 (logand rex-bits #xf)))))
985         (when (logtest base-opcode #xff00)
986           (frag-list-push-byte frag-list (ldb (byte 8 8) base-opcode)))
987         (frag-list-push-byte frag-list (ldb (byte 8 0) base-opcode)))
988       (let* ((modrm (x86::x86-instruction-modrm-byte insn)))
989         (when modrm
990           (frag-list-push-byte frag-list modrm)
991           (let* ((sib (x86::x86-instruction-sib-byte insn)))
992             (when sib
993               (frag-list-push-byte frag-list sib)))))
994       (let* ((operands (x86::x86-opcode-template-operand-types template)))
995         (if (and (= (length operands) 1)
996                  (= (x86::encode-operand-type :label) (aref operands 0)))
997           (let* ((label (x86::x86-instruction-extra insn))
998                  (frag (frag-list-current frag-list))
999                  (pos (frag-list-position frag-list)))
1000             (push (make-reloc :type :branch32
1001                               :arg label
1002                               :frag frag
1003                               :pos pos)
1004                   (frag-relocs frag))
1005             (frag-list-push-32 frag-list 0))
1006           (let* ((disp (x86::x86-instruction-disp insn)))
1007             (when disp
1008               (let* ((optype (x86::x86-instruction-extra insn))
1009                      (pcrel (and (logtest (x86::encode-operand-type :label) optype)
1010                              (typep disp 'label-x86-lap-expression)))
1011                  (val (unless pcrel (early-x86-lap-expression-value disp))))
1012             (if (null val)
1013               ;; We can do better job here, but (for now)
1014               ;; generate a 32-bit relocation
1015               (let* ((frag (frag-list-current frag-list))
1016                      (pos (frag-list-position frag-list)))
1017                 (push (make-reloc :type (if pcrel :branch32 :expr32)
1018                                   :arg (if pcrel (label-x86-lap-expression-label disp) disp)
1019                                   :frag frag
1020                                   :pos pos)
1021                       (frag-relocs frag))
1022                 (frag-list-push-32 frag-list 0))
1023               (if (logtest optype (x86::encode-operand-type :disp8))
1024                 (frag-list-push-byte frag-list (logand val #xff))
1025                 (if (logtest optype (x86::encode-operand-type :disp32 :disp32s))
1026                   (frag-list-push-32 frag-list val)
1027                   (frag-list-push-64 frag-list val)))))))))
1028       ;; Emit immediate operand(s).
1029       (let* ((op (x86::x86-instruction-imm insn)))
1030         (when op
1031           (let* ((optype (x86::x86-operand-type op))
1032                  (expr (x86::x86-immediate-operand-value op))
1033                  (val (early-x86-lap-expression-value expr)))
1034             (if (null val)
1035               (let* ((frag (frag-list-current frag-list))
1036                      (pos (frag-list-position frag-list))
1037                      (size 4)
1038                      (reloctype :expr32))
1039                 (when (logtest optype
1040                                (x86::encode-operand-type
1041                                 :imm8 :imm8S :imm16 :imm64))
1042                   (setq size 2 reloctype :expr16)
1043                   (if (logtest optype (x86::encode-operand-type
1044                                        :imm8 :imm8s))
1045                     (setq size 1 reloctype :expr8)
1046                     (if (logtest optype (x86::encode-operand-type :imm64))
1047                       (setq size 8 reloctype :expr64))))
1048                 (push (make-reloc :type reloctype
1049                                   :arg expr
1050                                   :frag frag
1051                                   :pos pos)
1052                       (frag-relocs frag))
1053                 (dotimes (b size)
1054                   (frag-list-push-byte frag-list 0)))
1055               (if (logtest optype (x86::encode-operand-type :imm8 :imm8s))
1056                 (frag-list-push-byte frag-list (logand val #xff))
1057                 (if (logtest optype (x86::encode-operand-type :imm16))
1058                   (frag-list-push-16 frag-list (logand val #xffff))
1059                   (if (logtest optype (x86::encode-operand-type :imm64))
1060                     (frag-list-push-64 frag-list val)
1061                     ;; magic value denoting function object's
1062                     ;; actual runtime address
1063                     (if (logtest optype (x86::encode-operand-type :self))
1064                       (let* ((frag (frag-list-current frag-list))
1065                              (pos (frag-list-position frag-list)))
1066                         (frag-list-push-32 frag-list 0)
1067                         (push (make-reloc :type :self
1068                                           :arg 0
1069                                           :frag frag
1070                                           :pos pos)
1071                               (frag-relocs frag)))
1072                       (frag-list-push-32 frag-list val)))))))))))
1073    (let* ((frag (frag-list-current frag-list)))
1074      (if (eq (car (frag-type frag)) :pending-talign)
1075        (finish-pending-talign-frag frag-list)))))
1076
1077;;; Returns the active frag list after processing directive(s).
1078(defun x86-lap-directive (frag-list directive arg &optional main-frag-list exception-frag-list)
1079  (declare (ignorable main-frag-list exception-frag-list))
1080  (case directive
1081    (:tra
1082     (finish-frag-for-align frag-list 3)
1083     (x86-lap-directive frag-list :long `(:^ ,arg))
1084     (emit-x86-lap-label frag-list arg))
1085    (:fixed-constants
1086     (dolist (constant arg)
1087       (ensure-x86-lap-constant-label constant)))
1088    (:arglist (setq *x86-lap-lfun-bits* (encode-lambda-list arg)))
1089    ((:uuo :uuo-section)
1090     (if exception-frag-list
1091       (progn
1092         (setq frag-list exception-frag-list)
1093         (finish-frag-for-align frag-list 2))))
1094    ((:main :main-section)
1095     (when main-frag-list (setq frag-list main-frag-list)))
1096    (:anchored-uuo-section
1097     (setq frag-list (x86-lap-directive frag-list :uuo-section nil main-frag-list exception-frag-list))
1098     (setq frag-list (x86-lap-directive frag-list :long `(:^ ,arg) main-frag-list exception-frag-list)))
1099    (t (let* ((exp (parse-x86-lap-expression arg))
1100              (constantp (or (constant-x86-lap-expression-p exp)
1101                             (not (x86-lap-expression-p exp)))))
1102         
1103         (if constantp
1104           (let* ((val (x86-lap-expression-value exp)))
1105             (ecase directive
1106               (:code-size
1107                (if *x86-lap-fixed-code-words*
1108                  (error "Duplicate :CODE-SIZE directive")
1109                  (setq *x86-lap-fixed-code-words* val)))
1110               (:byte (frag-list-push-byte frag-list val))
1111               (:short (frag-list-push-16 frag-list val))
1112               (:long (frag-list-push-32 frag-list val))
1113               (:quad (frag-list-push-64 frag-list val))
1114               (:align (finish-frag-for-align frag-list val))
1115               (:talign (finish-frag-for-talign frag-list val))
1116               (:org (finish-frag-for-org frag-list val))))
1117           (let* ((pos (frag-list-position frag-list))
1118                  (frag (frag-list-current frag-list))
1119                  (reloctype nil))
1120             (ecase directive
1121               (:byte (frag-list-push-byte frag-list 0)
1122                      (setq reloctype :expr8))
1123               (:short (frag-list-push-16 frag-list 0)
1124                       (setq reloctype :expr16))
1125               (:long (frag-list-push-32 frag-list 0)
1126                      (setq reloctype :expr32))
1127               (:quad (frag-list-push-64 frag-list 0)
1128                      (setq reloctype :expr64))
1129               (:align (error ":align expression ~s not constant" arg))
1130               (:talign (error ":talign expression ~s not constant" arg)))
1131             (when reloctype
1132               (push
1133                (make-reloc :type reloctype
1134                            :arg exp
1135                            :pos pos
1136                            :frag frag)
1137                (frag-relocs frag))))))))
1138  frag-list)
1139
1140
1141(defun x862-lap-process-regsave-info (frag-list regsave-label regsave-mask regsave-addr)
1142  (when regsave-label
1143    (let* ((label-diff (min (- (x86-lap-label-address regsave-label)
1144                               *x86-lap-entry-offset*)
1145                            255))
1146           (first-frag (frag-list-succ frag-list)))
1147      (setf (frag-ref first-frag 4) label-diff
1148            (frag-ref first-frag 5) regsave-addr
1149            (frag-ref first-frag 6) regsave-mask))
1150    t))
1151                       
1152         
1153
1154(defun x86-lap-form (form frag-list instruction  main-frag-list exception-frag-list)
1155  (if (and form (symbolp form))
1156    (emit-x86-lap-label frag-list form)
1157    (if (or (atom form) (not (symbolp (car form))))
1158      (error "Unknown X86-LAP form ~s ." form)
1159      (multiple-value-bind (expansion expanded)
1160          (x86-lap-macroexpand-1 form)
1161        (if expanded
1162          (x86-lap-form expansion frag-list instruction main-frag-list exception-frag-list)
1163          (if (typep (car form) 'keyword)
1164            (destructuring-bind (op &optional arg) form
1165              (setq frag-list (x86-lap-directive frag-list op arg main-frag-list exception-frag-list)))
1166            (case (car form)
1167              (progn
1168                (dolist (f (cdr form))
1169                  (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list))))
1170              (let
1171                  (destructuring-bind (equates &body body)
1172                      (cdr form)
1173                    (setq frag-list (x86-lap-equate-form equates frag-list instruction body main-frag-list exception-frag-list))))
1174              (t
1175               (parse-x86-instruction form instruction)
1176               (x86-generate-instruction-code frag-list instruction))))))))
1177  frag-list)
1178
1179(defun relax-align (address bits)
1180  (let* ((mask (1- (ash 1 bits))))
1181    (- (logandc2 (+ address mask) mask) address)))
1182
1183(defun relax-talign (address mask)
1184  (do* ((i 0 (1+ i)))
1185       ((= (logand address 7) mask) i)
1186    (incf address)))
1187
1188
1189(defun relax-frag-list (frag-list)
1190  ;; First, assign tentative addresses to all frags, assuming that
1191  ;; span-dependent instructions have short displacements.
1192  ;; While doing that, find branches to the next instruction and
1193  ;; remove them.  In some cases, that'll cause the containing
1194  ;; frag to become empty; that could introduce branches to the
1195  ;; next instruction, so we repeat this process until we can
1196  ;; make it all the way through the frag-list.
1197  (loop
1198    (let* ((address (target-arch-case (:x8632 4) (:x8664 8)))) ;after header
1199      (declare (fixnum address))
1200      (when (do-dll-nodes (frag frag-list t)
1201              (setf (frag-address frag) address)
1202              (incf address (frag-length frag))
1203              (case (car (frag-type frag))
1204                (:org
1205                 ;; Do nothing, for now
1206                 )
1207                (:align
1208                 (incf address (relax-align address (cadr (frag-type frag)))))
1209                (:talign
1210                 (let* ((arg (cadr (frag-type frag))))
1211                   (if (null arg)
1212                     ;;; Never generated code in :pending-talign frag
1213                     (setf (frag-type frag) nil)
1214                     (incf address (relax-talign address arg)))))
1215                ((:assumed-short-branch :assumed-short-conditional-branch)
1216                 (destructuring-bind (label pos reloc) (cdr (frag-type frag))
1217                   (let* ((next (frag-succ frag)))
1218                     (when (and (eq (x86-lap-label-frag label) next)
1219                                (eql (x86-lap-label-offset label) 0))
1220                       ;; Delete the reloc associated with this branch.
1221                       (setf (frag-relocs frag)
1222                             (delete reloc (frag-relocs frag)))
1223                       ;; This will be a "normal" frag
1224                       (setf (frag-type frag) nil)
1225                       ;; Remove the (short) branch, and remove the frag
1226                       ;; if it becomes empty.  If the frag does become
1227                       ;; empty, migrate any labels to the next frag.
1228                       (when (zerop (setf (frag-length frag)
1229                                        (1- pos)))
1230
1231                         (do* ((labels (frag-labels frag)))
1232                              ((null labels))
1233                           (let* ((lab (pop labels)))
1234                             (setf (x86-lap-label-frag lab) next
1235                                   (x86-lap-label-offset lab) 0)
1236                             (push lab (frag-labels next))))
1237                         (remove-dll-node frag))
1238                       (return nil)))))))
1239        (return))))
1240  ;; Repeatedly "stretch" frags containing span-dependent instructions
1241  ;; until nothing's stretched.  It may take several iterations to
1242  ;; converge; is convergence guaranteed ?
1243  (loop
1244    (let* ((stretch 0)                  ;cumulative growth in frag sizes
1245           (stretched nil))             ;any change on this pass ?
1246      (do-dll-nodes (frag frag-list)
1247        (let* ((growth 0)
1248               (fragtype (frag-type frag))
1249               (was-address (frag-address frag))
1250               (address (incf (frag-address frag) stretch)))
1251          (case (car fragtype)
1252            (:org
1253             (let* ((target (cadr (frag-type frag)))
1254                    (next-address (frag-address (frag-succ frag))))
1255               (setq growth (- target next-address))
1256               (if (< growth 0)
1257                 (error "Code size exceeds :CODE-SIZE constraint ~s"
1258                        (ash target -3))
1259                 (decf growth stretch))))
1260            (:align
1261             (let* ((bits (cadr fragtype))
1262                    (len (frag-length frag))
1263                    (oldoff (relax-align (+ was-address len) bits))
1264                    (newoff (relax-align (+ address len) bits)))
1265               (setq growth (- newoff oldoff))))
1266            (:talign
1267             (let* ((arg (cadr fragtype))
1268                    (len (frag-length frag))
1269                    (oldoff (relax-talign (+ was-address len) arg))
1270                    (newoff (relax-talign (+ address len) arg)))
1271               (setq growth (- newoff oldoff))))
1272            ;; If we discover - on any iteration - that a short
1273            ;; branch doesn't fit, we change the type (and the reloc)
1274            ;; destructively to a wide branch indicator and will
1275            ;; never change our minds about that, so we only have
1276            ;; to look here at conditional branches that may still
1277            ;; be able to use a 1-byte displacement.
1278            ((:assumed-short-branch :assumed-short-conditional-branch)
1279             (destructuring-bind (label pos reloc) (cdr (frag-type frag))
1280               (declare (fixnum pos))
1281               (let* ((label-address (x86-lap-label-address label))
1282                      (branch-pos (+ address (1+ pos)))
1283                      (diff (- label-address branch-pos)))
1284                 (unless (typep diff '(signed-byte 8))
1285                   (cond ((eq (car fragtype) :assumed-short-branch)
1286                          ;; replace the opcode byte
1287                          (setf (frag-ref frag (the fixnum (1- pos)))
1288                                x86::+jump-pc-relative+)
1289                          (frag-push-byte frag 0)
1290                          (frag-push-byte frag 0)
1291                          (frag-push-byte frag 0)
1292                          (setf (reloc-type reloc) :branch32)
1293                          (setf (car fragtype) :long-branch)
1294                          (setq growth 3))
1295                         (t
1296                          ;; Conditional branch: must change
1297                          ;; 1-byte opcode to 2 bytes, add 4-byte
1298                          ;; displacement
1299                          (let* ((old-opcode (frag-ref frag (1- pos))))
1300                            (setf (frag-ref frag (1- pos)) #x0f
1301                                  (frag-ref frag pos) (+ old-opcode #x10))
1302                            (frag-push-byte frag 0)
1303                            (frag-push-byte frag 0)
1304                            (frag-push-byte frag 0)
1305                            (frag-push-byte frag 0)
1306                            (setf (reloc-type reloc) :branch32
1307                                  (reloc-pos reloc) (1+ pos))
1308                            (setf (car fragtype) :long-conditional-branch
1309                                  (caddr fragtype) (1+ pos))
1310                            (setq growth 4)))))))))
1311          (unless (eql 0 growth)
1312            (incf stretch growth)
1313            (setq stretched t))))
1314      (unless stretched (return)))))
1315
1316(defun apply-relocs (frag-list)
1317  (flet ((emit-byte (frag pos b)
1318           (setf (frag-ref frag pos) (logand b #xff))))
1319    (flet ((emit-short (frag pos s)
1320             (setf (frag-ref frag pos) (ldb (byte 8 0) s)
1321                   (frag-ref frag (1+ pos)) (ldb (byte 8 8) s))))
1322      (flet ((emit-long (frag pos l)
1323               (emit-short frag pos (ldb (byte 16 0) l))
1324               (emit-short frag (+ pos 2) (ldb (byte 16 16) l))))
1325        (flet ((emit-quad (frag pos q)
1326                 (emit-long frag pos (ldb (byte 32 0) q))
1327                 (emit-long frag (+ pos 4) (ldb (byte 32 32) q))))
1328          (do-dll-nodes (frag frag-list)
1329            (let* ((address (frag-address frag)))
1330              (dolist (reloc (frag-relocs frag))
1331                (let* ((pos (reloc-pos reloc))
1332                       (arg (reloc-arg reloc)))
1333                  (ecase (reloc-type reloc)
1334                    (:branch8 (let* ((target (x86-lap-label-address arg))
1335                                     (refpos (+ address (1+ pos))))
1336                                (emit-byte frag pos (- target refpos))))
1337                    (:branch32 (let* ((target (x86-lap-label-address arg))
1338                                     (refpos (+ address pos 4)))
1339                                (emit-long frag pos (- target refpos))))
1340                    (:expr8 (emit-byte frag pos  (x86-lap-expression-value arg)))
1341                    (:expr16 (emit-short frag pos (x86-lap-expression-value arg)))
1342                    (:expr32 (emit-long frag pos (x86-lap-expression-value arg)))
1343                    (:expr64 (emit-quad frag pos (x86-lap-expression-value arg)))
1344                    (:self (emit-long frag pos (x86-lap-expression-value arg)))))))))))))
1345
1346(defstatic *x86-32-bit-lap-nops*
1347  #(
1348    #()
1349    #(#x90)                             ; nop                 
1350    #(#x89 #xf6)                        ; movl %esi,%esi       
1351    #(#x8d #x76 #x00)                   ; leal 0(%esi),%esi   
1352    #(#x8d #x74 #x26 #x00)              ; leal 0(%esi,1),%esi 
1353    #(#x90 #x8d #x74 #x26 #x00)         ; nop ; leal 0(%esi,1),%esi 
1354    #(#x8d #xb6 #x00 #x00 #x00 #x00)    ; leal 0L(%esi),%esi   
1355    #(#x8d #xb4 #x26 #x00 #x00 #x00 #x00) ; leal 0L(%esi,1),%esi
1356  )
1357  "Allegedly, many implementations recognize these instructions and
1358execute them very quickly.")
1359
1360(defstatic *x86-32-bit-lap-nops-8*
1361  #(#x90 #x8d #xb4 #x26 #x00 #x00 #x00 #x00))
1362
1363(defun frag-emit-nops (frag count)
1364  (target-word-size-case
1365   (32
1366    (do* ((c count (- c 8)))
1367         ((< c 8)
1368          (let* ((v (svref *x86-32-bit-lap-nops* c)))
1369            (dotimes (i c)
1370              (frag-push-byte frag (svref v i)))))
1371      (dotimes (i 8)
1372        (frag-push-byte frag (svref *x86-32-bit-lap-nops-8* i)))))
1373   (64
1374    (let* ((nnops (ash (+ count 3) -2))
1375           (len (floor count nnops))
1376           (remains (- count (* nnops len))))
1377      (dotimes (i remains)
1378        (dotimes (k len) (frag-push-byte frag #x66))
1379        (frag-push-byte frag #x90))
1380      (do* ((i remains (1+ i)))
1381           ((= i nnops))
1382        (dotimes (k (1- len)) (frag-push-byte frag #x66))
1383        (frag-push-byte frag #x90))))))
1384 
1385(defun fill-for-alignment (frag-list)
1386  (ccl::do-dll-nodes (frag frag-list)
1387    (let* ((next (ccl::dll-node-succ frag)))
1388      (unless (eq next frag-list)
1389        (let* ((addr (frag-address frag))
1390               (nextaddr (frag-address next))
1391               (pad (- nextaddr (+ addr (frag-length frag)))))
1392          (unless (eql 0 pad)
1393            (frag-emit-nops frag pad)))))))
1394
1395(defun show-frag-bytes (frag-list)
1396  (ccl::do-dll-nodes (frag frag-list)
1397    (format t "~& frag at #x~x" (frag-address frag))
1398    (dotimes (i (frag-length frag))
1399      (unless (logtest 15 i)
1400        (format t "~&"))
1401      (format t "~2,'0x " (frag-ref frag i)))))
1402
1403(defun x86-lap-equate-form (eqlist fraglist instruction  body main-frag exception-frag) 
1404  (let* ((symbols (mapcar #'(lambda (x)
1405                              (let* ((name (car x)))
1406                                (or
1407                                 (and name 
1408                                      (symbolp name)
1409                                      (not (constant-symbol-p name))
1410                                      (or (not (gethash (string name)
1411                                                        (target-arch-case
1412                                                         (:x8632 x86::*x8632-registers*)
1413                                                         (:x8664 x86::*x8664-registers*))))
1414                                          (error "Symbol ~s already names an x86 register" name))
1415                                      name)
1416                                 (error 
1417                                  "~S is not a bindable symbol name ." name))))
1418                          eqlist))
1419         (values (mapcar #'(lambda (x) (x86-register-ordinal-or-expression
1420                                        (cadr x)))
1421                         eqlist)))
1422    (progv symbols values
1423      (dolist (form body fraglist)
1424        (setq fraglist (x86-lap-form form fraglist instruction main-frag exception-frag))))))
1425               
1426(defun cross-create-x86-function (name frag-list constants bits debug-info)
1427  (let* ((constants-vector (%alloc-misc (+ (length constants)
1428                                           (+ 2
1429                                              (if name 1 0)
1430                                              (if debug-info 1 0)))
1431                                        target::subtag-xfunction)))
1432    (unless name (setq bits (logior bits (ash -1 $lfbits-noname-bit))))
1433    (let* ((last (1- (uvsize constants-vector))))
1434      (declare (fixnum last))
1435      (setf (uvref constants-vector last) bits)
1436      (when name
1437        (setf (uvref constants-vector (decf last)) name))
1438      (when debug-info
1439        (setf (uvref constants-vector (decf last)) debug-info))
1440      (dolist (c constants)
1441        (setf (uvref constants-vector (decf last)) (car c)))
1442      (let* ((nbytes 0))
1443        (do-dll-nodes (frag frag-list)
1444          (incf nbytes (frag-length frag)))
1445        #+x8632-target
1446        (when (>= nbytes (ash 1 18)) (compiler-function-overflow))
1447        (let* ((code-vector (make-array nbytes
1448                                        :element-type '(unsigned-byte 8)))
1449               (target-offset 0))
1450          (declare (fixnum target-offset))
1451          (setf (uvref constants-vector 0) code-vector)
1452          (do-dll-nodes (frag frag-list)
1453            (incf target-offset (frag-output-bytes frag code-vector target-offset)))
1454          constants-vector)))))
1455
1456#+x86-target
1457(defun create-x86-function (name frag-list constants bits debug-info)
1458  (unless name (setq bits (logior bits (ash -1 $lfbits-noname-bit))))
1459  (let* ((code-bytes (let* ((nbytes 0))
1460                       (do-dll-nodes (frag frag-list nbytes)
1461                         (incf nbytes (frag-length frag)))))
1462         (code-words (ash code-bytes (- target::word-shift)))
1463         (function-vector (allocate-typed-vector :function code-words))
1464         (nconstants (length constants))
1465         (ncode code-words))
1466    (declare (fixnum code-bytes code-words ncode))
1467    (when name (incf nconstants))
1468    (when debug-info (incf nconstants))
1469    (incf nconstants)
1470    (setq ncode (- code-words nconstants))
1471
1472    #+x8632-target
1473    (when (>= ncode #x8000)
1474      (if (>= nconstants #x8000)
1475        (compiler-function-overflow)
1476        (let* ((buf (car (frag-code-buffer (dll-header-first frag-list))))
1477               (new-word (logior #x8000 nconstants)))
1478          (setf (aref buf 0) (ldb (byte 8 0) new-word)
1479                (aref buf 1) (ldb (byte 8 8) new-word)))))
1480    (let* ((target-offset 0))
1481      (declare (fixnum target-offset))
1482      (do-dll-nodes (frag frag-list)
1483        (incf target-offset (frag-output-bytes frag function-vector target-offset))))
1484    (let* ((last (1- (uvsize function-vector))))
1485      (declare (fixnum last))
1486      (setf (uvref function-vector last) bits)
1487      (when name
1488        (setf (uvref function-vector (decf last)) name))
1489      (when debug-info
1490        (setf (uvref function-vector (decf last)) debug-info))
1491      (dolist (c constants)
1492        (setf (uvref function-vector (decf last)) (car c)))
1493      #+x8632-target
1494      (%update-self-references function-vector)
1495      (function-vector-to-function function-vector))))
1496
1497(defun %define-x86-lap-function (name forms &optional (bits 0))
1498  (target-arch-case
1499   (:x8632
1500    (%define-x8632-lap-function name forms bits))
1501   (:x8664
1502    (%define-x8664-lap-function name forms bits))))
1503
1504(defun %define-x8664-lap-function (name forms &optional (bits 0))
1505  (let* ((*x86-lap-labels* ())
1506         (*x86-lap-constants* ())
1507         (*x86-lap-entry-offset* x8664::fulltag-function)
1508         (*x86-lap-fixed-code-words* nil)
1509         (*x86-lap-lfun-bits* bits)
1510         (end-code-tag (gensym))
1511         (entry-code-tag (gensym))
1512         (instruction (x86::make-x86-instruction))
1513         (main-frag-list (make-frag-list))
1514         (exception-frag-list (make-frag-list))
1515         (frag-list main-frag-list))
1516    (make-x86-lap-label end-code-tag)
1517    (make-x86-lap-label entry-code-tag)
1518    (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
1519                                              *x86-lap-entry-offset*) -3))
1520    (x86-lap-directive frag-list :byte 0) ;regsave pc
1521    (x86-lap-directive frag-list :byte 0) ;regsave ea
1522    (x86-lap-directive frag-list :byte 0) ;regsave mask
1523    (emit-x86-lap-label frag-list entry-code-tag)
1524
1525    (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction main-frag-list exception-frag-list)
1526    (dolist (f forms)
1527      (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list)))
1528    (setq frag-list main-frag-list)
1529    (merge-dll-nodes frag-list exception-frag-list)
1530    (x86-lap-directive frag-list :align 3)
1531    (when *x86-lap-fixed-code-words*
1532      (x86-lap-directive frag-list :org (ash *x86-lap-fixed-code-words* 3)))
1533    (x86-lap-directive frag-list :quad x8664::function-boundary-marker)
1534    (emit-x86-lap-label frag-list end-code-tag)
1535    (dolist (c (reverse *x86-lap-constants*))
1536      (emit-x86-lap-label frag-list (x86-lap-label-name (cdr c)))
1537      (x86-lap-directive frag-list :quad 0))
1538    (when name
1539      (x86-lap-directive frag-list :quad 0))
1540    ;; room for lfun-bits
1541    (x86-lap-directive frag-list :quad 0)
1542    (relax-frag-list frag-list)
1543    (apply-relocs frag-list)
1544    (fill-for-alignment frag-list)
1545    ;;(show-frag-bytes frag-list)
1546    (funcall #-x86-target #'cross-create-x86-function
1547             #+x86-target (if (eq *target-backend* *host-backend*)
1548                            #'create-x86-function
1549                            #'cross-create-x86-function)
1550             name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil)))
1551
1552(defun %define-x8632-lap-function (name forms &optional (bits 0))
1553  (let* ((*x86-lap-labels* ())
1554         (*x86-lap-constants* ())
1555         (*x86-lap-entry-offset* x8632::fulltag-misc)
1556         (*x86-lap-fixed-code-words* nil)
1557         (*x86-lap-lfun-bits* bits)
1558         (srt-tag (gensym))
1559         (end-code-tag (gensym))
1560         (entry-code-tag (gensym))
1561         (instruction (x86::make-x86-instruction))
1562         (main-frag-list (make-frag-list))
1563         (exception-frag-list (make-frag-list))
1564         (frag-list main-frag-list))
1565    (make-x86-lap-label entry-code-tag)
1566    (make-x86-lap-label srt-tag)
1567    (make-x86-lap-label end-code-tag)
1568    ;; count of 32-bit words from header to function boundary
1569    ;; marker, inclusive.
1570    (x86-lap-directive frag-list :short `(ash (+ (- (:^ ,end-code-tag) 4)
1571                                                 *x86-lap-entry-offset*) -2))
1572    (emit-x86-lap-label frag-list entry-code-tag)
1573    (x86-lap-form '(movl ($ :self) (% x8632::fn)) frag-list instruction main-frag-list exception-frag-list)
1574    (dolist (f forms)
1575      (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list)))
1576    (setq frag-list main-frag-list)
1577    (merge-dll-nodes frag-list exception-frag-list)
1578    (x86-lap-directive frag-list :align 2)
1579    (when *x86-lap-fixed-code-words*
1580      ;; We have a code-size that we're trying to get to.  We need to
1581      ;; include the self-reference table in the code-size, so decrement
1582      ;; the size of the padding we would otherwise insert by the srt size.
1583      (let ((srt-words 1))              ;for zero between end of code and srt
1584        (do-dll-nodes (frag frag-list)
1585          (dolist (reloc (frag-relocs frag))
1586            (when (eq (reloc-type reloc) :self)
1587              (incf srt-words))))
1588        (decf *x86-lap-fixed-code-words* srt-words)
1589        (if (plusp *x86-lap-fixed-code-words*)
1590          (x86-lap-directive frag-list :org (ash *x86-lap-fixed-code-words* 2)))))
1591    ;; self reference table
1592    (x86-lap-directive frag-list :long 0)
1593    (emit-x86-lap-label frag-list srt-tag)
1594    ;; reserve space for self-reference offsets
1595    (do-dll-nodes (frag frag-list)
1596      (dolist (reloc (frag-relocs frag))
1597        (when (eq (reloc-type reloc) :self)
1598          (x86-lap-directive frag-list :long 0))))
1599    (x86-lap-directive frag-list :long x8632::function-boundary-marker)
1600    (emit-x86-lap-label frag-list end-code-tag)
1601    (dolist (c (reverse *x86-lap-constants*))
1602      (emit-x86-lap-label frag-list (x86-lap-label-name (cdr c)))
1603      (x86-lap-directive frag-list :long 0))
1604    (when name
1605      (x86-lap-directive frag-list :long 0))
1606    ;; room for lfun-bits
1607    (x86-lap-directive frag-list :long 0)
1608    (relax-frag-list frag-list)
1609    (apply-relocs frag-list)
1610    (fill-for-alignment frag-list)
1611    ;; determine start of self-reference-table
1612    (let* ((label (find srt-tag *x86-lap-labels* :test #'eq
1613                                                 :key #'x86-lap-label-name))
1614           (srt-frag (x86-lap-label-frag label))
1615           (srt-index (x86-lap-label-offset label)))
1616      ;; fill in self-reference offsets
1617      (do-dll-nodes (frag frag-list)
1618        (dolist (reloc (frag-relocs frag))
1619          (when (eq (reloc-type reloc) :self)
1620            (setf (frag-ref-32 srt-frag srt-index)
1621                  (+ (frag-address frag) (reloc-pos reloc)))
1622            (incf srt-index 4)))))
1623    ;;(show-frag-bytes frag-list)
1624    (funcall #-x8632-target #'cross-create-x86-function
1625             #+x8632-target (if (eq *target-backend* *host-backend*)
1626                              #'create-x86-function
1627                              #'cross-create-x86-function)
1628             name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil)))
1629
1630(defmacro defx86lapfunction (&environment env name arglist &body body
1631                             &aux doc)
1632  (if (not (endp body))
1633      (and (stringp (car body))
1634           (cdr body)
1635           (setq doc (car body))
1636           (setq body (cdr body))))
1637  `(progn
1638     (eval-when (:compile-toplevel)
1639       (note-function-info ',name t ,env))
1640     #-x8664-target
1641     (progn
1642       (eval-when (:load-toplevel)
1643         (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))
1644       (eval-when (:execute)
1645         (%define-x86-lap-function ',name '((let ,arglist ,@body)))))
1646     #+x8664-target     ; just shorthand for defun
1647     (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)))
1648
1649(defmacro defx8632lapfunction (&environment env name arglist &body body
1650                             &aux doc)
1651  (if (not (endp body))
1652      (and (stringp (car body))
1653           (cdr body)
1654           (setq doc (car body))
1655           (setq body (cdr body))))
1656  `(progn
1657     (eval-when (:compile-toplevel)
1658       (note-function-info ',name t ,env))
1659     #-x8632-target
1660     (progn
1661       (eval-when (:load-toplevel)
1662         (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))
1663       (eval-when (:execute)
1664         (%define-x8632-lap-function ',name '((let ,arglist ,@body)))))
1665     #+x8632-target
1666     (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)))
Note: See TracBrowser for help on using the repository browser.