source: release/1.3/source/compiler/X86/x86-lap.lisp

Last change on this file was 11856, checked in by rme, 11 years ago

Port r11810 (fixes to various format/warn/etc. calls) to 1.3 branch.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 69.5 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2005, Clozure Associates and contributors.
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(require "X86-ASM")
20
21(eval-when (:compile-toplevel :load-toplevel :execute)
22  (require "DLL-NODE"))
23
24(def-standard-initial-binding *x86-lap-label-freelist* (make-dll-node-freelist))
25
26(def-standard-initial-binding *x86-lap-frag-vector-freelist* (%cons-pool))
27
28(defun %allocate-vector-list-segment ()
29  (without-interrupts
30   (let* ((data (pool.data *x86-lap-frag-vector-freelist*)))
31     (if data
32       (progn
33         (when (null (list-length data))
34           (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    (declare (fixnum code-bytes code-words))
1465    (let* ((target-offset 0))
1466      (declare (fixnum target-offset))
1467      (do-dll-nodes (frag frag-list)
1468        (incf target-offset (frag-output-bytes frag function-vector target-offset))))
1469    (let* ((last (1- (uvsize function-vector))))
1470      (declare (fixnum last))
1471      (setf (uvref function-vector last) bits)
1472      (when name
1473        (setf (uvref function-vector (decf last)) name))
1474      (when debug-info
1475        (setf (uvref function-vector (decf last)) debug-info))
1476      (dolist (c constants)
1477        (setf (uvref function-vector (decf last)) (car c)))
1478      #+x8632-target
1479      (%update-self-references function-vector)
1480      (function-vector-to-function function-vector))))
1481
1482(defun %define-x86-lap-function (name forms &optional (bits 0))
1483  (target-arch-case
1484   (:x8632
1485    (%define-x8632-lap-function name forms bits))
1486   (:x8664
1487    (%define-x8664-lap-function name forms bits))))
1488
1489(defun %define-x8664-lap-function (name forms &optional (bits 0))
1490  (let* ((*x86-lap-labels* ())
1491         (*x86-lap-constants* ())
1492         (*x86-lap-entry-offset* x8664::fulltag-function)
1493         (*x86-lap-fixed-code-words* nil)
1494         (*x86-lap-lfun-bits* bits)
1495         (end-code-tag (gensym))
1496         (entry-code-tag (gensym))
1497         (instruction (x86::make-x86-instruction))
1498         (main-frag-list (make-frag-list))
1499         (exception-frag-list (make-frag-list))
1500         (frag-list main-frag-list))
1501    (make-x86-lap-label end-code-tag)
1502    (make-x86-lap-label entry-code-tag)
1503    (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
1504                                              *x86-lap-entry-offset*) -3))
1505    (x86-lap-directive frag-list :byte 0) ;regsave pc
1506    (x86-lap-directive frag-list :byte 0) ;regsave ea
1507    (x86-lap-directive frag-list :byte 0) ;regsave mask
1508    (emit-x86-lap-label frag-list entry-code-tag)
1509
1510    (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction main-frag-list exception-frag-list)
1511    (dolist (f forms)
1512      (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list)))
1513    (setq frag-list main-frag-list)
1514    (merge-dll-nodes frag-list exception-frag-list)
1515    (x86-lap-directive frag-list :align 3)
1516    (when *x86-lap-fixed-code-words*
1517      (x86-lap-directive frag-list :org (ash *x86-lap-fixed-code-words* 3)))
1518    (x86-lap-directive frag-list :quad x8664::function-boundary-marker)
1519    (emit-x86-lap-label frag-list end-code-tag)
1520    (dolist (c (reverse *x86-lap-constants*))
1521      (emit-x86-lap-label frag-list (x86-lap-label-name (cdr c)))
1522      (x86-lap-directive frag-list :quad 0))
1523    (when name
1524      (x86-lap-directive frag-list :quad 0))
1525    ;; room for lfun-bits
1526    (x86-lap-directive frag-list :quad 0)
1527    (relax-frag-list frag-list)
1528    (apply-relocs frag-list)
1529    (fill-for-alignment frag-list)
1530    ;;(show-frag-bytes frag-list)
1531    (funcall #-x86-target #'cross-create-x86-function
1532             #+x86-target (if (eq *target-backend* *host-backend*)
1533                            #'create-x86-function
1534                            #'cross-create-x86-function)
1535             name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil)))
1536
1537(defun %define-x8632-lap-function (name forms &optional (bits 0))
1538  (let* ((*x86-lap-labels* ())
1539         (*x86-lap-constants* ())
1540         (*x86-lap-entry-offset* x8632::fulltag-misc)
1541         (*x86-lap-fixed-code-words* nil)
1542         (*x86-lap-lfun-bits* bits)
1543         (srt-tag (gensym))
1544         (end-code-tag (gensym))
1545         (entry-code-tag (gensym))
1546         (instruction (x86::make-x86-instruction))
1547         (main-frag-list (make-frag-list))
1548         (exception-frag-list (make-frag-list))
1549         (frag-list main-frag-list))
1550    (make-x86-lap-label entry-code-tag)
1551    (make-x86-lap-label srt-tag)
1552    (make-x86-lap-label end-code-tag)
1553    ;; count of 32-bit words from header to function boundary
1554    ;; marker, inclusive.
1555    (x86-lap-directive frag-list :short `(ash (+ (- (:^ ,end-code-tag) 4)
1556                                                 *x86-lap-entry-offset*) -2))
1557    (emit-x86-lap-label frag-list entry-code-tag)
1558    (x86-lap-form '(movl ($ :self) (% x8632::fn)) frag-list instruction main-frag-list exception-frag-list)
1559    (dolist (f forms)
1560      (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list)))
1561    (setq frag-list main-frag-list)
1562    (merge-dll-nodes frag-list exception-frag-list)
1563    (x86-lap-directive frag-list :align 2)
1564    (when *x86-lap-fixed-code-words*
1565      ;; We have a code-size that we're trying to get to.  We need to
1566      ;; include the self-reference table in the code-size, so decrement
1567      ;; the size of the padding we would otherwise insert by the srt size.
1568      (let ((srt-words 1))              ;for zero between end of code and srt
1569        (do-dll-nodes (frag frag-list)
1570          (dolist (reloc (frag-relocs frag))
1571            (when (eq (reloc-type reloc) :self)
1572              (incf srt-words))))
1573        (decf *x86-lap-fixed-code-words* srt-words)
1574        (if (plusp *x86-lap-fixed-code-words*)
1575          (x86-lap-directive frag-list :org (ash *x86-lap-fixed-code-words* 2)))))
1576    ;; self reference table
1577    (x86-lap-directive frag-list :long 0)
1578    (emit-x86-lap-label frag-list srt-tag)
1579    ;; reserve space for self-reference offsets
1580    (do-dll-nodes (frag frag-list)
1581      (dolist (reloc (frag-relocs frag))
1582        (when (eq (reloc-type reloc) :self)
1583          (x86-lap-directive frag-list :long 0))))
1584    (x86-lap-directive frag-list :long x8632::function-boundary-marker)
1585    (emit-x86-lap-label frag-list end-code-tag)
1586    (dolist (c (reverse *x86-lap-constants*))
1587      (emit-x86-lap-label frag-list (x86-lap-label-name (cdr c)))
1588      (x86-lap-directive frag-list :long 0))
1589    (when name
1590      (x86-lap-directive frag-list :long 0))
1591    ;; room for lfun-bits
1592    (x86-lap-directive frag-list :long 0)
1593    (relax-frag-list frag-list)
1594    (apply-relocs frag-list)
1595    (fill-for-alignment frag-list)
1596    ;; determine start of self-reference-table
1597    (let* ((label (find srt-tag *x86-lap-labels* :test #'eq
1598                                                 :key #'x86-lap-label-name))
1599           (srt-frag (x86-lap-label-frag label))
1600           (srt-index (x86-lap-label-offset label)))
1601      ;; fill in self-reference offsets
1602      (do-dll-nodes (frag frag-list)
1603        (dolist (reloc (frag-relocs frag))
1604          (when (eq (reloc-type reloc) :self)
1605            (setf (frag-ref-32 srt-frag srt-index)
1606                  (+ (frag-address frag) (reloc-pos reloc)))
1607            (incf srt-index 4)))))
1608    ;;(show-frag-bytes frag-list)
1609    (funcall #-x8632-target #'cross-create-x86-function
1610             #+x8632-target (if (eq *target-backend* *host-backend*)
1611                              #'create-x86-function
1612                              #'cross-create-x86-function)
1613             name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil)))
1614
1615(defmacro defx86lapfunction (&environment env name arglist &body body
1616                             &aux doc)
1617  (if (not (endp body))
1618      (and (stringp (car body))
1619           (cdr body)
1620           (setq doc (car body))
1621           (setq body (cdr body))))
1622  `(progn
1623     (eval-when (:compile-toplevel)
1624       (note-function-info ',name t ,env))
1625     #-x8664-target
1626     (progn
1627       (eval-when (:load-toplevel)
1628         (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))
1629       (eval-when (:execute)
1630         (%define-x86-lap-function ',name '((let ,arglist ,@body)))))
1631     #+x8664-target     ; just shorthand for defun
1632     (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)))
1633
1634(defmacro defx8632lapfunction (&environment env name arglist &body body
1635                             &aux doc)
1636  (if (not (endp body))
1637      (and (stringp (car body))
1638           (cdr body)
1639           (setq doc (car body))
1640           (setq body (cdr body))))
1641  `(progn
1642     (eval-when (:compile-toplevel)
1643       (note-function-info ',name t ,env))
1644     #-x8632-target
1645     (progn
1646       (eval-when (:load-toplevel)
1647         (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))
1648       (eval-when (:execute)
1649         (%define-x8632-lap-function ',name '((let ,arglist ,@body)))))
1650     #+x8632-target
1651     (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)))
Note: See TracBrowser for help on using the repository browser.