source: trunk/source/compiler/X86/X8664/x8664-arch.lisp @ 11659

Last change on this file since 11659 was 11659, checked in by gz, 11 years ago

Make print-call-history and backtrace-as-list support a :process argument to get the backtrace of that process without interrupting it.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 45.2 KB
Line 
1;;;-*- Mode: Lisp; Package: (X8664 :use CL) -*-
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(defpackage "X8664"
18  (:use "CL")
19  #+x8664-target
20  (:nicknames "TARGET"))
21
22(in-package "X8664")
23
24(eval-when (:compile-toplevel :load-toplevel :execute)
25  (require "X86-ARCH")
26  (require "X86-LAP")
27 
28(defparameter *x8664-symbolic-register-names*
29  (make-hash-table :test #'equal)
30  "For the disassembler, mostly")
31
32;;; define integer constants which map to
33;;; indices in the X86::*X8664-REGISTER-ENTRIES* array.
34(ccl::defenum ()
35  rax
36  rcx
37  rdx
38  rbx
39  rsp
40  rbp
41  rsi
42  rdi
43  r8
44  r9
45  r10
46  r11
47  r12
48  r13
49  r14
50  r15
51  ;; 32-bit registers
52  eax
53  ecx
54  edx
55  ebx
56  esp
57  ebp
58  esi
59  edi
60  r8d
61  r9d
62  r10d
63  r11d
64  r12d
65  r13d
66  r14d
67  r15d
68  ;; 16-bit-registers
69  ax
70  cx
71  dx
72  bx
73  sp
74  bp
75  si
76  di
77  r8w
78  r9w
79  r10w
80  r11w
81  r12w
82  r13w
83  r14w
84  r15w
85  ;; 8-bit registers
86  al
87  cl
88  dl
89  bl
90  spl
91  bpl
92  sil
93  dil
94  r8b
95  r9b
96  r10b
97  r11b
98  r12b
99  r13b
100  r14b
101  r15b
102       ;;; xmm registers
103  xmm0
104  xmm1
105  xmm2
106  xmm3
107  xmm4
108  xmm5
109  xmm6
110  xmm7
111  xmm8
112  xmm9
113  xmm10
114  xmm11
115  xmm12
116  xmm13
117  xmm14
118  xmm15
119  ;; MMX registers
120  mm0
121  mm1
122  mm2
123  mm3
124  mm4
125  mm5
126  mm6
127  mm7
128  ;; x87 FP regs.  May or may not be useful.
129  st[0]
130  st[1]
131  st[2]
132  st[3]
133  st[4]
134  st[5]
135  st[6]
136  st[7]
137  ;; Segment registers
138  cs
139  ds
140  ss
141  es
142  fs
143  gs
144  rip
145  )
146
147(defmacro defx86reg (alias known)
148  (let* ((known-entry (gensym)))
149    `(let* ((,known-entry (gethash ,(string known) x86::*x8664-registers*)))
150      (unless ,known-entry
151        (error "register ~a not defined" ',known))
152      (setf (gethash ,(string alias) x86::*x8664-registers*) ,known-entry)
153      (unless (gethash ,(string-downcase (string known)) *x8664-symbolic-register-names*)
154        (setf (gethash ,(string-downcase (string known)) *x8664-symbolic-register-names*)
155              (string-downcase ,(string alias))))
156      (defconstant ,alias ,known))))
157
158(defx86reg imm0 rax)
159(defx86reg imm0.l eax)
160(defx86reg imm0.w ax)
161(defx86reg imm0.b al)
162
163(defx86reg temp0 rbx)
164(defx86reg temp0.l ebx)
165(defx86reg temp0.w bx)
166(defx86reg temp0.b bl)
167
168(defx86reg imm2 rcx)
169(defx86reg nargs ecx)
170(defx86reg imm2.l ecx)
171(defx86reg nargs.w cx)
172(defx86reg nargs.q rcx)
173(defx86reg imm2.w cx)
174(defx86reg imm2.b cl)
175(defx86reg shift cl)
176
177(defx86reg imm1 rdx)
178(defx86reg imm1.l edx)
179(defx86reg imm1.w dx)
180(defx86reg imm1.b dl)
181
182(defx86reg arg_z rsi)
183(defx86reg arg_z.l esi)
184(defx86reg arg_z.w si)
185(defx86reg arg_z.b sil)
186
187(defx86reg arg_y rdi)
188(defx86reg arg_y.l edi)
189(defx86reg arg_y.w di)
190(defx86reg arg_y.b dil)
191
192(defx86reg arg_x r8)
193(defx86reg arg_x.l r8d)
194(defx86reg arg_x.w r8w)
195(defx86reg arg_x.b r8b)
196
197(defx86reg temp1 r9)
198(defx86reg temp1.l r9d)
199(defx86reg temp1.w r9w)
200(defx86reg temp1.b r9b)
201
202(defx86reg ra0 r10)
203(defx86reg ra0.l r10d)
204(defx86reg ra0.w r10w)
205(defx86reg ra0.b r10b)
206
207(defx86reg temp2 r10)
208(defx86reg temp2.l r10d)
209(defx86reg temp2.w r10w)
210(defx86reg temp2.b r10b)
211
212
213(defx86reg save3 r11)
214(defx86reg save3.l r11d)
215(defx86reg save3.w r11w)
216(defx86reg save3.b r11b)
217
218(defx86reg save2 r12)
219(defx86reg save2.l r12d)
220(defx86reg save2.w r12w)
221(defx86reg save2.b r12b)
222
223(defx86reg fn r13)
224(defx86reg fn.l r13d)
225(defx86reg fn.w r13w)
226(defx86reg fn.b r13b)
227
228(defx86reg save1 r14)
229(defx86reg save1.l r14d)
230(defx86reg save1.w r14w)
231(defx86reg save1.b r14b)
232
233(defx86reg save0 r15)
234(defx86reg save0.l r15d)
235(defx86reg save0.w r15w)
236(defx86reg save0.b r15b)
237
238;;; Use xmm regs for floating-point.  (They can also hold integer values.)
239(defx86reg fp0 xmm0)
240(defx86reg fp1 xmm1)
241(defx86reg fp2 xmm2)
242(defx86reg fp3 xmm3)
243(defx86reg fp4 xmm4)
244(defx86reg fp5 xmm5)
245(defx86reg fp6 xmm6)
246(defx86reg fp7 xmm7)
247(defx86reg fp8 xmm8)
248(defx86reg fp9 xmm9)
249(defx86reg fp10 xmm10)
250(defx86reg fp11 xmm11)
251(defx86reg fp12 xmm12)
252(defx86reg fp13 xmm13)
253(defx86reg fp14 xmm14)
254(defx86reg fpzero xmm15)
255(defx86reg fp15 xmm15)
256
257;;; There are only 8 mmx registers, and they overlap the x87 FPU.
258(defx86reg stack-temp mm7)
259
260
261;;; NEXT-METHOD-CONTEXT is passed from gf-dispatch code to the method
262;;; functions that it funcalls.  FNAME is only meaningful when calling
263;;; globally named functions through the function cell of a symbol.
264;;; It appears that they're never live at the same time.
265;;; (We can also consider passing next-method context on the stack.)
266
267(defx86reg fname temp0)
268(defx86reg next-method-context temp0)
269;;; We rely one at least one of %ra0/%fn pointing to the current function
270;;; (or to a TRA that references the function) at all times.  When we
271;;; tail call something, we want %RA0 to point to our caller's TRA and
272;;; %FN to point to the new function.  Unless we go out of line to
273;;; do tail calls, we need some register not involved in the calling
274;;; sequence to hold the current function, since it might get GCed otherwise.
275;;; (The odds of this happening are low, but non-zero.)
276(defx86reg xfn temp1)
277
278(defx86reg ra1 fn)
279
280(defx86reg allocptr temp0)
281
282   
283(defconstant nbits-in-word 64)
284(defconstant nbits-in-byte 8)
285(defconstant ntagbits 4)
286(defconstant nlisptagbits 3)
287(defconstant nfixnumtagbits 3)
288(defconstant num-subtag-bits 8)
289(defconstant fixnumshift 3)
290(defconstant fixnum-shift 3)
291(defconstant fulltagmask 15)
292(defconstant tagmask 7)
293(defconstant fixnummask 7)
294(defconstant ncharcodebits 8)
295(defconstant charcode-shift 8)
296(defconstant word-shift 3)
297(defconstant word-size-in-bytes 8)
298(defconstant node-size word-size-in-bytes)
299(defconstant dnode-size 16)
300(defconstant dnode-align-bits 4)
301(defconstant dnode-shift dnode-align-bits)
302(defconstant bitmap-shift 6)
303
304(defconstant fixnumone (ash 1 fixnumshift))
305(defconstant fixnum-one fixnumone)
306(defconstant fixnum1 fixnumone)
307
308(defconstant target-most-negative-fixnum (ash -1 (1- (- nbits-in-word nfixnumtagbits))))
309(defconstant target-most-positive-fixnum (1- (ash 1 (1- (- nbits-in-word nfixnumtagbits)))))
310
311;;; 3-bit "lisptag" values
312
313(defconstant tag-fixnum 0)
314(defconstant tag-imm-0 1)               ;subtag-single-float ONLY
315(defconstant tag-imm-1 2)               ;subtag-character, internal markers
316(defconstant tag-list 3)                ;fulltag-cons or NIL
317(defconstant tag-tra 4)                 ;tagged return-address
318(defconstant tag-misc 5)                ;random uvector
319(defconstant tag-symbol 6)              ;non-null symbol
320(defconstant tag-function 7)            ;function entry point
321
322(defconstant tag-single-float tag-imm-0)
323
324;;; 4-bit "fulltag" values
325(defconstant fulltag-even-fixnum 0)
326(defconstant fulltag-imm-0 1)           ;subtag-single-float ONLY
327(defconstant fulltag-imm-1 2)           ;characters, markers
328(defconstant fulltag-cons 3)
329(defconstant fulltag-tra-0 4)           ;tagged return address
330(defconstant fulltag-nodeheader-0 5)
331(defconstant fulltag-nodeheader-1 6)
332(defconstant fulltag-immheader-0 7)
333(defconstant fulltag-odd-fixnum 8)
334(defconstant fulltag-immheader-1 9)
335(defconstant fulltag-immheader-2 10)
336(defconstant fulltag-nil 11)
337(defconstant fulltag-tra-1 12)
338(defconstant fulltag-misc 13)
339(defconstant fulltag-symbol 14)
340(defconstant fulltag-function 15)
341
342(defconstant fulltag-single-float fulltag-imm-0)
343
344(defmacro define-subtag (name tag value)
345  `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,value ntagbits))))
346
347
348(define-subtag arrayH fulltag-nodeheader-0 10)
349(define-subtag vectorH fulltag-nodeheader-1 10)
350(define-subtag simple-vector fulltag-nodeheader-1 11)
351(defconstant min-vector-subtag  subtag-vectorH)
352(defconstant min-array-subtag  subtag-arrayH)
353
354(defconstant ivector-class-64-bit  fulltag-immheader-2)
355(defconstant ivector-class-32-bit  fulltag-immheader-1)
356(defconstant ivector-class-other-bit  fulltag-immheader-0)
357
358(define-subtag fixnum-vector ivector-class-64-bit 12)
359(define-subtag s64-vector ivector-class-64-bit 13)
360(define-subtag u64-vector ivector-class-64-bit 14)
361(define-subtag double-float-vector ivector-class-64-bit 15)
362
363(define-subtag simple-base-string ivector-class-32-bit 12)
364(define-subtag s32-vector ivector-class-32-bit 13)
365(define-subtag u32-vector ivector-class-32-bit 14)
366(define-subtag single-float-vector ivector-class-32-bit 15)
367       
368(define-subtag s16-vector ivector-class-other-bit 10)
369(define-subtag u16-vector ivector-class-other-bit 11)
370
371(define-subtag s8-vector ivector-class-other-bit 13)
372(define-subtag u8-vector ivector-class-other-bit 14)
373(defconstant min-8-bit-ivector-subtag subtag-s8-vector)
374(defconstant max-8-bit-ivector-subtag subtag-u8-vector)
375(define-subtag bit-vector ivector-class-other-bit 15)
376
377
378;;; There's some room for expansion in non-array ivector space.
379(define-subtag macptr ivector-class-64-bit 1)
380(define-subtag dead-macptr ivector-class-64-bit 2)
381(define-subtag bignum ivector-class-32-bit 1)
382(define-subtag double-float ivector-class-32-bit 2)
383(define-subtag xcode-vector ivector-class-32-bit 3)
384
385
386       
387;;; Note the difference between (e.g) fulltag-function - which
388;;; defines what the low 4 bytes of a function pointer look like -
389;;; and subtag-function - which describes what the subtag byte
390;;; in a function header looks like.  (Likewise for fulltag-symbol
391;;; and subtag-symbol)
392
393;;; don't use nodheader/0, since that would conflict with tag-misc
394(define-subtag symbol fulltag-nodeheader-0 1)
395(define-subtag catch-frame fulltag-nodeheader-0 2)
396(define-subtag hash-vector fulltag-nodeheader-0 3)
397(define-subtag pool fulltag-nodeheader-0 4)
398(define-subtag weak fulltag-nodeheader-0 5)
399(define-subtag package fulltag-nodeheader-0 6)
400(define-subtag slot-vector fulltag-nodeheader-0 7)
401(define-subtag basic-stream fulltag-nodeheader-0 8)
402(define-subtag function fulltag-nodeheader-0 9)
403
404(define-subtag ratio fulltag-nodeheader-1 1)
405(define-subtag complex fulltag-nodeheader-1 2)
406(define-subtag struct fulltag-nodeheader-1 3)
407(define-subtag istruct fulltag-nodeheader-1 4)
408(define-subtag value-cell fulltag-nodeheader-1 5)
409(define-subtag xfunction fulltag-nodeheader-1 6)
410(define-subtag lock fulltag-nodeheader-1 7)
411(define-subtag instance fulltag-nodeheader-1 8)
412
413       
414(defconstant canonical-nil-value (+ #x13000 fulltag-nil))
415(defconstant canonical-t-value (+ #x13020 fulltag-symbol))
416(defconstant misc-bias fulltag-misc)
417(defconstant cons-bias fulltag-cons)
418(defconstant t-offset (- canonical-t-value canonical-nil-value))
419
420
421(defconstant misc-header-offset (- fulltag-misc))
422(defconstant misc-data-offset (+ misc-header-offset node-size))
423(defconstant misc-subtag-offset misc-header-offset)
424(defconstant misc-dfloat-offset misc-data-offset)
425(defconstant misc-symbol-offset (- node-size fulltag-symbol))
426(defconstant misc-function-offset (- node-size fulltag-function))
427 
428(define-subtag single-float fulltag-imm-0 0)
429
430(define-subtag character fulltag-imm-1 0)
431
432(define-subtag unbound fulltag-imm-1 1)
433(defconstant unbound-marker subtag-unbound)
434(defconstant undefined unbound-marker)
435(define-subtag slot-unbound fulltag-imm-1 2)
436(defconstant slot-unbound-marker subtag-slot-unbound)
437(define-subtag illegal fulltag-imm-1 3)
438(defconstant illegal-marker subtag-illegal)
439(define-subtag no-thread-local-binding fulltag-imm-1 4)
440(defconstant no-thread-local-binding-marker subtag-no-thread-local-binding)
441(define-subtag reserved-frame fulltag-imm-1 5)
442(defconstant reserved-frame-marker subtag-reserved-frame)
443
444;;; This has two functions: it tells the link-inverting marker where the
445;;; code ends and the constants start, and it ensures that the 0th constant
446;;; will never be in the same memozized dnode as some (unboxed) word of
447;;; machine code.  I'm not sure if there's a better way to do either of those
448;;; things.
449;;; Depending on how you look at it, we either lose 8 bytes per function, or gain
450;;; 7 bytes of otherwise unused space for debugging info.
451(define-subtag function-boundary-marker fulltag-imm-1 15)
452(defconstant function-boundary-marker subtag-function-boundary-marker)
453
454(defconstant max-64-bit-constant-index (ash (+ #x7fffffff x8664::misc-dfloat-offset) -3))
455(defconstant max-32-bit-constant-index (ash (+ #x7fffffff x8664::misc-data-offset) -2))
456(defconstant max-16-bit-constant-index (ash (+ #x7fffffff x8664::misc-data-offset) -1))
457(defconstant max-8-bit-constant-index (+ #x7fffffff x8664::misc-data-offset))
458(defconstant max-1-bit-constant-index (ash (+ #x7fffffff x8664::misc-data-offset) 5))
459
460)
461(defmacro define-storage-layout (name origin &rest cells)
462  `(progn
463    (ccl::defenum (:start ,origin :step 8)
464        ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells))
465    (defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells)
466                                                      8))))
467
468(defmacro define-lisp-object (name tagname &rest cells)
469  `(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells))
470
471(defmacro define-fixedsized-object (name (&optional (fulltag 'fulltag-misc))
472                                         &rest non-header-cells)
473  `(progn
474     (define-lisp-object ,name ,fulltag header ,@non-header-cells)
475     (ccl::defenum ()
476       ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells))
477     (defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells))))
478
479;;; Order of CAR and CDR doesn't seem to matter much - there aren't
480;;; too many tricks to be played with predecrement/preincrement addressing.
481;;; Keep them in the confusing MCL 3.0 order, to avoid confusion.
482(define-lisp-object cons fulltag-cons 
483  cdr 
484  car)
485
486(define-fixedsized-object ratio ()
487  numer
488  denom)
489
490;;; It's slightly easier (for bootstrapping reasons)
491;;; to view a DOUBLE-FLOAT as being UVECTOR with 2 32-bit elements
492;;; (rather than 1 64-bit element).
493
494(defconstant double-float.value misc-data-offset)
495(defconstant double-float.value-cell 0)
496(defconstant double-float.val-low double-float.value)
497(defconstant double-float.val-low-cell 0)
498(defconstant double-float.val-high (+ double-float.value 4))
499(defconstant double-float.val-high-cell 1)
500(defconstant double-float.element-count 2)
501(defconstant double-float.size 16)
502
503(define-fixedsized-object complex ()
504  realpart
505  imagpart
506)
507
508;;; There are two kinds of macptr; use the length field of the header if you
509;;; need to distinguish between them
510(define-fixedsized-object macptr ()
511  address
512  domain
513  type
514)
515
516(define-fixedsized-object xmacptr ()
517  address
518  domain
519  type
520  flags
521  link
522)
523
524
525;;; Need to think about catch frames on x8664.
526(define-fixedsized-object catch-frame ()
527  catch-tag                             ; #<unbound> -> unwind-protect, else catch
528  link                                  ; tagged pointer to next older catch frame
529  mvflag                                ; 0 if single-value, 1 if uwp or multiple-value
530  rsp                                   ;
531  rbp
532  foreign-sp
533  db-link                               ; value of dynamic-binding link on thread entry.
534  save-save3                            ; saved nvrs
535  save-save2
536  save-save1
537  save-save0
538  xframe                                ; exception-frame link
539  pc                                    ; tra of catch exit/unwind cleanup
540)
541
542(define-fixedsized-object lock ()
543  _value                                ;finalizable pointer to kernel object
544  kind                                  ; '0 = recursive-lock, '1 = rwlock
545  writer                                ;tcr of owning thread or 0
546  name
547  whostate
548  whostate-2
549  )
550
551
552
553;;; If we're pointing at the "symbol-vector", we can use these
554(define-fixedsized-object symptr ()
555  pname
556  vcell
557  fcell
558  package-predicate
559  flags
560  plist
561  binding-index
562)
563
564(define-fixedsized-object symbol (fulltag-symbol)
565  pname
566  vcell
567  fcell
568  package-predicate
569  flags
570  plist
571  binding-index
572)
573
574(defconstant nilsym-offset (+ t-offset symbol.size))
575
576
577(define-fixedsized-object vectorH ()
578  logsize                               ; fillpointer if it has one, physsize otherwise
579  physsize                              ; total size of (possibly displaced) data vector
580  data-vector                           ; object this header describes
581  displacement                          ; true displacement or 0
582  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
583)
584
585(define-lisp-object arrayH fulltag-misc
586  header                                ; subtag = subtag-arrayH
587  rank                                  ; NEVER 1
588  physsize                              ; total size of (possibly displaced) data vector
589  data-vector                           ; object this header describes
590  displacement                          ; true displacement or 0 
591  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
592 ;; Dimensions follow
593)
594
595(defconstant arrayH.rank-cell 0)
596(defconstant arrayH.physsize-cell 1)
597(defconstant arrayH.data-vector-cell 2)
598(defconstant arrayH.displacement-cell 3)
599(defconstant arrayH.flags-cell 4)
600(defconstant arrayH.dim0-cell 5)
601
602(defconstant arrayH.flags-cell-bits-byte (byte 8 0))
603(defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
604
605(define-fixedsized-object value-cell ()
606  value)
607
608
609(define-storage-layout lisp-frame 0
610  backptr
611  return-address
612  xtra)
613
614(define-storage-layout tsp-frame 0
615  backptr
616  rbp)
617
618(define-storage-layout csp-frame 0
619  backptr
620  rbp)
621
622
623(define-storage-layout xcf 0            ;"exception callback frame"
624  backptr
625  return-address                        ; always 0
626  nominal-function
627  relative-pc
628  containing-object
629  xp
630  ra0
631  foreign-sp                            ; value of tcr.foreign_sp
632  prev-xframe                           ; tcr.xframe before exception
633                                        ; (last 2 needed by apply-in-frame)
634  )
635
636;;; The kernel uses these (rather generically named) structures
637;;; to keep track of various memory regions it (or the lisp) is
638;;; interested in.
639
640
641(define-storage-layout area 0
642  pred                                  ; pointer to preceding area in DLL
643  succ                                  ; pointer to next area in DLL
644  low                                   ; low bound on area addresses
645  high                                  ; high bound on area addresses.
646  active                                ; low limit on stacks, high limit on heaps
647  softlimit                             ; overflow bound
648  hardlimit                             ; another one
649  code                                  ; an area-code; see below
650  markbits                              ; bit vector for GC
651  ndwords                               ; "active" size of dynamic area or stack
652  older                                 ; in EGC sense
653  younger                               ; also for EGC
654  h                                     ; Handle or null pointer
655  softprot                              ; protected_area structure pointer
656  hardprot                              ; another one.
657  owner                                 ; fragment (library) which "owns" the area
658  refbits                               ; bitvector for intergenerational refernces
659  threshold                             ; for egc
660  gc-count                              ; generational gc count.
661  static-dnodes                         ; for honsing. etc
662  static-used                           ; bitvector
663)
664
665
666(define-storage-layout protected-area 0
667  next
668  start                                 ; first byte (page-aligned) that might be protected
669  end                                   ; last byte (page-aligned) that could be protected
670  nprot                                 ; Might be 0
671  protsize                              ; number of bytes to protect
672  why)
673
674(eval-when (:compile-toplevel :load-toplevel :execute)
675(defconstant tcr-bias 0)
676)
677
678(define-storage-layout tcr (- tcr-bias)
679  prev                                  ; in doubly-linked list
680  next                                  ; in doubly-linked list
681  single-float-convert                  ; faster to box/unbox through memory
682  linear
683  save-rbp                              ; lisp frame ptr for foreign code
684  lisp-fpscr-high
685  db-link                               ; special binding chain head
686  catch-top                             ; top catch frame
687  save-vsp                              ; SP when in foreign code
688  save-tsp                              ; TSP, at all times
689  foreign-sp                            ; SP when in lisp code
690  cs-area                               ; cstack area pointer
691  vs-area                               ; vstack area pointer
692  ts-area                               ; tstack area pointer
693  cs-limit                              ; cstack overflow limit
694  total-bytes-allocated
695  log2-allocation-quantum               ; unboxed
696  interrupt-pending                     ; fixnum
697  xframe                                ; exception frame linked list
698  errno-loc                             ; thread-private, maybe
699  ffi-exception                         ; fpscr bits from ff-call.
700  osid                                  ; OS thread id
701  valence                               ; odd when in foreign code
702  foreign-exception-status
703  native-thread-info
704  native-thread-id
705  last-allocptr
706  save-allocptr
707  save-allocbase
708  reset-completion
709  activate
710  suspend-count
711  suspend-context
712  pending-exception-context
713  suspend                               ; semaphore for suspension notify
714  resume                                ; sempahore for resumption notify
715  flags                                 ; foreign, being reset, ...
716  gc-context
717  termination-semaphore
718  unwinding
719  tlb-limit
720  tlb-pointer
721  shutdown-count
722  next-tsp
723  safe-ref-address
724  pending-io-info
725  io-datum
726)
727
728(defconstant tcr.single-float-convert.value (+ 4 tcr.single-float-convert))
729
730
731(defconstant interrupt-level-binding-index (ash 1 fixnumshift))
732
733(define-storage-layout lockptr 0
734  avail
735  owner
736  count
737  signal
738  waiting
739  malloced-ptr
740  spinlock)
741
742(define-storage-layout rwlock 0
743  spin
744  state
745  blocked-writers
746  blocked-readers
747  writer
748  reader-signal
749  writer-signal
750  malloced-ptr
751  )
752
753(defmacro define-header (name element-count subtag)
754  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
755
756(define-header double-float-header double-float.element-count subtag-double-float)
757
758;;; We could possibly have a one-digit bignum header when dealing
759;;; with "small bignums" in some bignum code.  Like other cases of
760;;; non-normalized bignums, they should never escape from the lab.
761(define-header one-digit-bignum-header 1 subtag-bignum)
762(define-header two-digit-bignum-header 2 subtag-bignum)
763(define-header three-digit-bignum-header 3 subtag-bignum)
764(define-header four-digit-bignum-header 4 subtag-bignum)
765(define-header five-digit-bignum-header 5 subtag-bignum)
766(define-header symbol-header symbol.element-count subtag-symbol)
767(define-header value-cell-header value-cell.element-count subtag-value-cell)
768(define-header macptr-header macptr.element-count subtag-macptr)
769
770
771(defconstant gf-code-size 18)
772
773(defun %kernel-global (sym)
774  (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=)))
775    (if pos
776      (- (+ fulltag-nil (* (1+ pos) node-size)))
777      (error "Unknown kernel global : ~s ." sym))))
778
779(defmacro kernel-global (sym)
780  (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=)))
781    (if pos
782      (- (+ fulltag-nil (* (1+ pos) node-size)))
783      (error "Unknown kernel global : ~s ." sym))))
784
785(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step node-size)
786  fd-setsize-bytes
787  do-fd-set
788  do-fd-clr
789  do-fd-is-set
790  do-fd-zero
791  MakeDataExecutable
792  GetSharedLibrary
793  FindSymbol
794  malloc
795  free
796  jvm-init
797  tcr-frame-ptr
798  register_cstack
799  open-debug-output
800  get-r-debug
801  restore-soft-stack-limit
802  egc-control
803  lisp-bug
804  NewThread
805  YieldToThread
806  DisposeThread
807  ThreadCurrentStackSpace
808  usage-exit
809  save-fp-context
810  restore-fp-context
811  put-altivec-registers
812  get-altivec-registers
813  new-semaphore
814  wait-on-semaphore
815  signal-semaphore
816  destroy-semaphore
817  new-recursive-lock
818  lock-recursive-lock
819  unlock-recursive-lock
820  destroy-recursive-lock
821  suspend-other-threads
822  resume-other-threads
823  suspend-tcr
824  resume-tcr
825  rwlock-new
826  rwlock-destroy
827  rwlock-rlock
828  rwlock-wlock
829  rwlock-unlock
830  recursive-lock-trylock
831  foreign-name-and-offset
832  lisp-read
833  lisp-write
834  lisp-open
835  lisp-fchmod
836  lisp-lseek
837  lisp-close
838  lisp-ftruncate
839  lisp-stat
840  lisp-fstat
841  lisp-futex
842  lisp-opendir
843  lisp-readdir
844  lisp-closedir
845  lisp-pipe
846  lisp-gettimeofday
847)
848
849(defmacro nrs-offset (name)
850  (let* ((pos (position name x86::*x86-nilreg-relative-symbols* :test #'eq)))
851    (if pos (* (1- pos) symbol.size))))
852
853(defparameter *x8664-target-uvector-subtags*
854  `((:bignum . ,subtag-bignum)
855    (:ratio . ,subtag-ratio)
856    (:single-float . ,subtag-single-float)
857    (:double-float . ,subtag-double-float)
858    (:complex . ,subtag-complex  )
859    (:symbol . ,subtag-symbol)
860    (:function . ,subtag-function )
861    (:xcode-vector . ,subtag-xcode-vector)
862    (:macptr . ,subtag-macptr )
863    (:catch-frame . ,subtag-catch-frame)
864    (:struct . ,subtag-struct )   
865    (:istruct . ,subtag-istruct )
866    (:pool . ,subtag-pool )
867    (:population . ,subtag-weak )
868    (:hash-vector . ,subtag-hash-vector )
869    (:package . ,subtag-package )
870    (:value-cell . ,subtag-value-cell)
871    (:instance . ,subtag-instance )
872    (:lock . ,subtag-lock )
873    (:basic-stream . ,subtag-basic-stream)
874    (:slot-vector . ,subtag-slot-vector)
875    (:simple-string . ,subtag-simple-base-string )
876    (:bit-vector . ,subtag-bit-vector )
877    (:signed-8-bit-vector . ,subtag-s8-vector )
878    (:unsigned-8-bit-vector . ,subtag-u8-vector )
879    (:signed-16-bit-vector . ,subtag-s16-vector )
880    (:unsigned-16-bit-vector . ,subtag-u16-vector )
881    (:signed-32-bit-vector . ,subtag-s32-vector )
882    (:unsigned-32-bit-vector . ,subtag-u32-vector )
883    (:signed-64-bit-vector . ,subtag-s64-vector)
884    (:fixnum-vector . ,subtag-fixnum-vector)
885    (:unsigned-64-bit-vector . ,subtag-u64-vector)   
886    (:single-float-vector . ,subtag-single-float-vector)
887    (:double-float-vector . ,subtag-double-float-vector )
888    (:simple-vector . ,subtag-simple-vector )
889    (:vector-header . ,subtag-vectorH)
890    (:array-header . ,subtag-arrayH)))
891
892;;; This should return NIL unless it's sure of how the indicated
893;;; type would be represented (in particular, it should return
894;;; NIL if the element type is unknown or unspecified at compile-time.
895(defun x8664-array-type-name-from-ctype (ctype)
896  (when (typep ctype 'ccl::array-ctype)
897    (let* ((element-type (ccl::array-ctype-element-type ctype)))
898      (typecase element-type
899        (ccl::class-ctype
900         (let* ((class (ccl::class-ctype-class element-type)))
901           (if (or (eq class ccl::*character-class*)
902                   (eq class ccl::*base-char-class*)
903                   (eq class ccl::*standard-char-class*))
904             :simple-string
905             :simple-vector)))
906        (ccl::numeric-ctype
907         (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
908           :simple-vector
909           (case (ccl::numeric-ctype-class element-type)
910             (integer
911              (let* ((low (ccl::numeric-ctype-low element-type))
912                     (high (ccl::numeric-ctype-high element-type)))
913                (cond ((or (null low) (null high))
914                       :simple-vector)
915                      ((and (>= low 0) (<= high 1))
916                       :bit-vector)
917                      ((and (>= low 0) (<= high 255))
918                       :unsigned-8-bit-vector)
919                      ((and (>= low 0) (<= high 65535))
920                       :unsigned-16-bit-vector)
921                      ((and (>= low 0) (<= high #xffffffff))
922                       :unsigned-32-bit-vector)
923                      ((and (>= low 0) (<= high #xffffffffffffffff))
924                       :unsigned-64-bit-vector)
925                      ((and (>= low -128) (<= high 127))
926                       :signed-8-bit-vector)
927                      ((and (>= low -32768) (<= high 32767))
928                       :signed-16-bit-vector)
929                      ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
930                       :signed-32-bit-vector)
931                      ((and (>= low target-most-negative-fixnum)
932                            (<= high target-most-positive-fixnum))
933                       :fixnum-vector)
934                      ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63))))
935                       :signed-64-bit-vector)
936                      (t :simple-vector))))
937             (float
938              (case (ccl::numeric-ctype-format element-type)
939                ((double-float long-float) :double-float-vector)
940                ((single-float short-float) :single-float-vector)
941                (t :simple-vector)))
942             (t :simple-vector))))
943        (ccl::unknown-ctype)
944        (ccl::named-ctype
945         (if (eq element-type ccl::*universal-type*)
946           :simple-vector))
947        (t)))))
948
949(defun x8664-misc-byte-count (subtag element-count)
950  (declare (fixnum subtag))
951  (if (logbitp (logand subtag fulltagmask)
952               (logior (ash 1 fulltag-nodeheader-0)
953                       (ash 1 fulltag-nodeheader-1)))
954    (ash element-count 3)
955    (case (logand subtag fulltagmask)
956      (#.ivector-class-64-bit (ash element-count 3))
957      (#.ivector-class-32-bit (ash element-count 2))
958      (t
959       (if (= subtag subtag-bit-vector)
960         (ash (+ 7 element-count) -3)
961         (if (>= subtag min-8-bit-ivector-subtag)
962           element-count
963           (ash element-count 1)))))))
964
965(defparameter *x8664-subprims-shift* 3)
966(defconstant x8664-subprims-base #x15000)
967
968
969(declaim (special *x8664-subprims*))
970
971;;; For now, nothing's nailed down and we don't say anything about
972;;; registers clobbered.
973(let* ((origin x8664-subprims-base)
974       (step (ash 1 *x8664-subprims-shift*)))
975  (flet ((define-x8664-subprim (name)
976             (ccl::make-subprimitive-info :name (string name)
977                                          :offset (prog1 origin
978                                                    (incf origin step)))))
979    (macrolet ((defx8664subprim (name)
980                   `(define-x8664-subprim ',name)))
981      (defparameter *x8664-subprims*
982        (vector
983         (defx8664subprim .SPjmpsym)
984         (defx8664subprim .SPjmpnfn)
985         (defx8664subprim .SPfuncall)
986         (defx8664subprim .SPmkcatch1v)
987         (defx8664subprim .SPmkunwind)
988         (defx8664subprim .SPmkcatchmv)
989         (defx8664subprim .SPthrow)
990         (defx8664subprim .SPnthrowvalues)
991         (defx8664subprim .SPnthrow1value)
992         (defx8664subprim .SPbind)
993         (defx8664subprim .SPbind-self)
994         (defx8664subprim .SPbind-nil)
995         (defx8664subprim .SPbind-self-boundp-check)
996         (defx8664subprim .SPrplaca)
997         (defx8664subprim .SPrplacd)
998         (defx8664subprim .SPconslist)
999         (defx8664subprim .SPconslist-star)
1000         (defx8664subprim .SPstkconslist)
1001         (defx8664subprim .SPstkconslist-star)
1002         (defx8664subprim .SPmkstackv)
1003         (defx8664subprim .SPsubtag-misc-ref)
1004         (defx8664subprim .SPsetqsym)
1005         (defx8664subprim .SPprogvsave)
1006         (defx8664subprim .SPstack-misc-alloc)
1007         (defx8664subprim .SPgvector)
1008         (defx8664subprim .SPnvalret)
1009         (defx8664subprim .SPmvpass)
1010         (defx8664subprim .SPrecover-values-for-mvcall)
1011         (defx8664subprim .SPnthvalue)
1012         (defx8664subprim .SPvalues)
1013         (defx8664subprim .SPdefault-optional-args)
1014         (defx8664subprim .SPopt-supplied-p)
1015         (defx8664subprim .SPheap-rest-arg)
1016         (defx8664subprim .SPreq-heap-rest-arg)
1017         (defx8664subprim .SPheap-cons-rest-arg)
1018         (defx8664subprim .SPsimple-keywords)
1019         (defx8664subprim .SPkeyword-args)
1020         (defx8664subprim .SPkeyword-bind)
1021         (defx8664subprim .SPffcall)
1022         (defx8664subprim .SParef2)
1023         (defx8664subprim .SPksignalerr)
1024         (defx8664subprim .SPstack-rest-arg)
1025         (defx8664subprim .SPreq-stack-rest-arg)
1026         (defx8664subprim .SPstack-cons-rest-arg)
1027         (defx8664subprim .SPpoweropen-callbackX)
1028         (defx8664subprim .SPcall-closure)
1029         (defx8664subprim .SPgetXlong)
1030         (defx8664subprim .SPspreadargz)
1031         (defx8664subprim .SPtfuncallgen)
1032         (defx8664subprim .SPtfuncallslide)
1033         (defx8664subprim .SPtfuncallvsp)
1034         (defx8664subprim .SPtcallsymgen)
1035         (defx8664subprim .SPtcallsymslide)
1036         (defx8664subprim .SPtcallsymvsp)
1037         (defx8664subprim .SPtcallnfngen)
1038         (defx8664subprim .SPtcallnfnslide)
1039         (defx8664subprim .SPtcallnfnvsp)
1040         (defx8664subprim .SPmisc-ref)
1041         (defx8664subprim .SPmisc-set)
1042         (defx8664subprim .SPstkconsyz)
1043         (defx8664subprim .SPstkvcell0)
1044         (defx8664subprim .SPstkvcellvsp)
1045         (defx8664subprim .SPmakestackblock)
1046         (defx8664subprim .SPmakestackblock0)
1047         (defx8664subprim .SPmakestacklist)
1048         (defx8664subprim .SPstkgvector)
1049         (defx8664subprim .SPmisc-alloc)
1050         (defx8664subprim .SPpoweropen-ffcallX)
1051         (defx8664subprim .SPgvset)
1052         (defx8664subprim .SPmacro-bind)
1053         (defx8664subprim .SPdestructuring-bind)
1054         (defx8664subprim .SPdestructuring-bind-inner)
1055         (defx8664subprim .SPrecover-values)
1056         (defx8664subprim .SPvpopargregs)
1057         (defx8664subprim .SPinteger-sign)
1058         (defx8664subprim .SPsubtag-misc-set)
1059         (defx8664subprim .SPspread-lexpr-z)
1060         (defx8664subprim .SPstore-node-conditional)
1061         (defx8664subprim .SPreset)
1062         (defx8664subprim .SPmvslide)
1063         (defx8664subprim .SPsave-values)
1064         (defx8664subprim .SPadd-values)
1065         (defx8664subprim .SPcallback)
1066         (defx8664subprim .SPmisc-alloc-init)
1067         (defx8664subprim .SPstack-misc-alloc-init)
1068         (defx8664subprim .SPset-hash-key)
1069         (defx8664subprim .SPaset2)
1070         (defx8664subprim .SPcallbuiltin)
1071         (defx8664subprim .SPcallbuiltin0)
1072         (defx8664subprim .SPcallbuiltin1)
1073         (defx8664subprim .SPcallbuiltin2)
1074         (defx8664subprim .SPcallbuiltin3)
1075         (defx8664subprim .SPpopj)
1076         (defx8664subprim .SPrestorefullcontext)
1077         (defx8664subprim .SPsavecontextvsp)
1078         (defx8664subprim .SPsavecontext0)
1079         (defx8664subprim .SPrestorecontext)
1080         (defx8664subprim .SPlexpr-entry)
1081         (defx8664subprim .SPpoweropen-syscall)
1082         (defx8664subprim .SPbuiltin-plus)
1083         (defx8664subprim .SPbuiltin-minus)
1084         (defx8664subprim .SPbuiltin-times)
1085         (defx8664subprim .SPbuiltin-div)
1086         (defx8664subprim .SPbuiltin-eq)
1087         (defx8664subprim .SPbuiltin-ne)
1088         (defx8664subprim .SPbuiltin-gt)
1089         (defx8664subprim .SPbuiltin-ge)
1090         (defx8664subprim .SPbuiltin-lt)
1091         (defx8664subprim .SPbuiltin-le)
1092         (defx8664subprim .SPbuiltin-eql)
1093         (defx8664subprim .SPbuiltin-length)
1094         (defx8664subprim .SPbuiltin-seqtype)
1095         (defx8664subprim .SPbuiltin-assq)
1096         (defx8664subprim .SPbuiltin-memq)
1097         (defx8664subprim .SPbuiltin-logbitp)
1098         (defx8664subprim .SPbuiltin-logior)
1099         (defx8664subprim .SPbuiltin-logand)
1100         (defx8664subprim .SPbuiltin-ash)
1101         (defx8664subprim .SPbuiltin-negate)
1102         (defx8664subprim .SPbuiltin-logxor)
1103         (defx8664subprim .SPbuiltin-aref1)
1104         (defx8664subprim .SPbuiltin-aset1)
1105         (defx8664subprim .SPbreakpoint)
1106         (defx8664subprim .SPeabi-ff-call)
1107         (defx8664subprim .SPeabi-callback)
1108         (defx8664subprim .SPsyscall)
1109         (defx8664subprim .SPgetu64)
1110         (defx8664subprim .SPgets64)
1111         (defx8664subprim .SPmakeu64)
1112         (defx8664subprim .SPmakes64)
1113         (defx8664subprim .SPspecref)
1114         (defx8664subprim .SPspecset)
1115         (defx8664subprim .SPspecrefcheck)
1116         (defx8664subprim .SPrestoreintlevel)
1117         (defx8664subprim .SPmakes32)
1118         (defx8664subprim .SPmakeu32)
1119         (defx8664subprim .SPgets32)
1120         (defx8664subprim .SPgetu32)
1121         (defx8664subprim .SPfix-overflow)
1122         (defx8664subprim .SPmvpasssym)
1123         (defx8664subprim .SParef3)
1124         (defx8664subprim .SPaset3)
1125         (defx8664subprim .SPffcall-return-registers)
1126         (defx8664subprim .SPunused-5)
1127         (defx8664subprim .SPset-hash-key-conditional)
1128         (defx8664subprim .SPunbind-interrupt-level)
1129         (defx8664subprim .SPunbind)
1130         (defx8664subprim .SPunbind-n)
1131         (defx8664subprim .SPunbind-to)
1132         (defx8664subprim .SPbind-interrupt-level-m1)
1133         (defx8664subprim .SPbind-interrupt-level)
1134         (defx8664subprim .SPbind-interrupt-level-0)
1135         (defx8664subprim .SPprogvrestore)
1136         (defx8664subprim .SPnmkunwind)
1137         
1138         )))))
1139
1140(defparameter *x8664-target-arch*
1141  (arch::make-target-arch :name :x8664
1142                          :lisp-node-size 8
1143                          :nil-value canonical-nil-value
1144                          :fixnum-shift fixnumshift
1145                          :most-positive-fixnum (1- (ash 1 (1- (- 64 fixnumshift))))
1146                          :most-negative-fixnum (- (ash 1 (1- (- 64 fixnumshift))))
1147                          :misc-data-offset misc-data-offset
1148                          :misc-dfloat-offset misc-dfloat-offset
1149                          :nbits-in-word 64
1150                          :ntagbits 4
1151                          :nlisptagbits 3
1152                          :uvector-subtags *x8664-target-uvector-subtags*
1153                          :max-64-bit-constant-index max-64-bit-constant-index
1154                          :max-32-bit-constant-index max-32-bit-constant-index
1155                          :max-16-bit-constant-index max-16-bit-constant-index
1156                          :max-8-bit-constant-index max-8-bit-constant-index
1157                          :max-1-bit-constant-index max-1-bit-constant-index
1158                          :word-shift 3
1159                          :code-vector-prefix nil
1160                          :gvector-types '(:ratio :complex :symbol :function
1161                                           :catch-frame :struct :istruct
1162                                           :pool :population :hash-vector
1163                                           :package :value-cell :instance
1164                                           :lock :slot-vector
1165                                           :simple-vector)
1166                          :1-bit-ivector-types '(:bit-vector)
1167                          :8-bit-ivector-types '(:signed-8-bit-vector
1168                                                 :unsigned-8-bit-vector)
1169                          :16-bit-ivector-types '(:signed-16-bit-vector
1170                                                  :unsigned-16-bit-vector)
1171                          :32-bit-ivector-types '(:signed-32-bit-vector
1172                                                  :unsigned-32-bit-vector
1173                                                  :single-float-vector
1174                                                  :double-float
1175                                                  :bignum
1176                                                  :simple-string)
1177                          :64-bit-ivector-types '(:double-float-vector
1178                                                  :unsigned-64-bit-vector
1179                                                  :signed-64-bit-vector
1180                                                  :fixnum-vector)
1181                          :array-type-name-from-ctype-function
1182                          #'x8664-array-type-name-from-ctype
1183                          :package-name "X8664"
1184                          :t-offset t-offset
1185                          :array-data-size-function #'x8664-misc-byte-count
1186                          :numeric-type-name-to-typecode-function
1187                          #'(lambda (type-name)
1188                              (ecase type-name
1189                                (fixnum tag-fixnum)
1190                                (bignum subtag-bignum)
1191                                ((short-float single-float) subtag-single-float)
1192                                ((long-float double-float) subtag-double-float)
1193                                (ratio subtag-ratio)
1194                                (complex subtag-complex)))
1195                          :subprims-base x8664-subprims-base
1196                          :subprims-shift x8664::*x8664-subprims-shift*
1197                          :subprims-table x8664::*x8664-subprims*
1198                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus x8664::*x8664-subprims*)))
1199                          :unbound-marker-value unbound-marker
1200                          :slot-unbound-marker-value slot-unbound-marker
1201                          :fixnum-tag tag-fixnum
1202                          :single-float-tag subtag-single-float
1203                          :single-float-tag-is-subtag nil
1204                          :double-float-tag subtag-double-float
1205                          :cons-tag fulltag-cons
1206                          :null-tag fulltag-nil
1207                          :symbol-tag fulltag-symbol
1208                          :symbol-tag-is-subtag nil
1209                          :function-tag fulltag-function
1210                          :function-tag-is-subtag nil
1211                          :big-endian nil
1212                          :misc-subtag-offset misc-subtag-offset
1213                          :car-offset cons.car
1214                          :cdr-offset cons.cdr
1215                          :subtag-char subtag-character
1216                          :charcode-shift charcode-shift
1217                          :fulltagmask fulltagmask
1218                          :fulltag-misc fulltag-misc
1219                          :char-code-limit #x110000
1220                          ))
1221
1222;;; arch macros
1223(defmacro defx8664archmacro (name lambda-list &body body)
1224  `(arch::defarchmacro :x8664 ,name ,lambda-list ,@body))
1225
1226(defx8664archmacro ccl::%make-sfloat ()
1227  (error "~s shouldn't be used in code targeting :X8664" 'ccl::%make-sfloat))
1228
1229(defx8664archmacro ccl::%make-dfloat ()
1230  `(ccl::%alloc-misc x8664::double-float.element-count x8664::subtag-double-float))
1231
1232(defx8664archmacro ccl::%numerator (x)
1233  `(ccl::%svref ,x x8664::ratio.numer-cell))
1234
1235(defx8664archmacro ccl::%denominator (x)
1236  `(ccl::%svref ,x x8664::ratio.denom-cell))
1237
1238(defx8664archmacro ccl::%realpart (x)
1239  `(ccl::%svref ,x x8664::complex.realpart-cell))
1240                   
1241(defx8664archmacro ccl::%imagpart (x)
1242  `(ccl::%svref ,x x8664::complex.imagpart-cell))
1243
1244;;;
1245(defx8664archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
1246 `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)))
1247
1248(defx8664archmacro ccl::codevec-header-p (word)
1249  (declare (ignore word))
1250  (error "~s makes no sense on :X8664" 'ccl::codevec-header-p))
1251
1252;;;
1253
1254(defx8664archmacro ccl::immediate-p-macro (thing)
1255  (let* ((tag (gensym)))
1256    `(let* ((,tag (ccl::lisptag ,thing)))
1257      (declare (type (unsigned-byte 3) ,tag))
1258      (logbitp ,tag (logior (ash 1 x8664::tag-fixnum)
1259                    (ash 1 x8664::tag-imm-0)
1260                    (ash 1 x8664::tag-imm-1))))))
1261
1262(defx8664archmacro ccl::hashed-by-identity (thing)
1263  (let* ((typecode (gensym)))
1264    `(let* ((,typecode (ccl::typecode ,thing)))
1265      (declare (fixnum ,typecode))
1266      (or (= ,typecode  x8664::subtag-instance)
1267       (and (<= ,typecode x8664::fulltag-symbol)
1268        (logbitp (the (integer 0 #.x8664::fulltag-symbol) ,typecode)
1269                 (logior (ash 1 x8664::tag-fixnum)
1270                         (ash 1 x8664::tag-imm-0)
1271                         (ash 1 x8664::tag-imm-1)
1272                         (ash 1 x8664::fulltag-symbol))))))))
1273
1274;;;
1275(defx8664archmacro ccl::%get-kernel-global (name)
1276  `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value)
1277                        ,(%kernel-global
1278                         (if (ccl::quoted-form-p name)
1279                           (cadr name)
1280                           name)))))
1281
1282(defx8664archmacro ccl::%get-kernel-global-ptr (name dest)
1283  `(ccl::%setf-macptr
1284    ,dest
1285    (ccl::%int-to-ptr (ccl::%fixnum-ref-natural 0 (+ ,(ccl::target-nil-value)
1286                                 ,(%kernel-global
1287                                   (if (ccl::quoted-form-p name)
1288                                     (cadr name)
1289                                     name)))))))
1290
1291(defx8664archmacro ccl::%target-kernel-global (name)
1292  `(x8664::%kernel-global ,name))
1293
1294(defx8664archmacro ccl::lfun-vector (fun)
1295  `(ccl::%function-to-function-vector ,fun))
1296
1297(defx8664archmacro ccl::lfun-vector-lfun (lfv)
1298  `(ccl::%function-vector-to-function ,lfv))
1299
1300(defx8664archmacro ccl::area-code ()
1301  area.code)
1302
1303(defx8664archmacro ccl::area-succ ()
1304  area.succ)
1305
1306(defx8664archmacro ccl::nth-immediate (f i)
1307  `(ccl::%nth-immediate ,f (the fixnum (- (the fixnum ,i) 1))))
1308
1309(defx8664archmacro ccl::set-nth-immediate (f i new)
1310  `(ccl::%set-nth-immediate ,f (the fixnum (- (the fixnum ,i) 1)) ,new))
1311
1312(defx8664archmacro ccl::symptr->symvector (s)
1313  `(ccl::%symptr->symvector ,s))
1314
1315(defx8664archmacro ccl::symvector->symptr (s)
1316  `(ccl::%symvector->symptr ,s))
1317
1318(defx8664archmacro ccl::function-to-function-vector (f)
1319  `(ccl::%function-to-function-vector ,f))
1320
1321(defx8664archmacro ccl::function-vector-to-function (v)
1322  `(ccl::%function-vector-to-function ,v))
1323
1324(defx8664archmacro ccl::with-ffcall-results ((buf) &body body)
1325  ;; Reserve space for rax,rdx,xmm0,xmm1 only.
1326  (let* ((size (+ (* 2 8) (* 2 8))))
1327    `(ccl::%stack-block ((,buf ,size :clear t))
1328      ,@body)))
1329
1330;;; an (lea (@ disp (% rip)) (% fn)) instruction following a tagged
1331;;; return address helps the runtime map from the return address to
1332;;; the containing function.  That instuction is 7 bytes long: 3
1333;;; bytes of code followed by 4 bytes of displacement.  The constant
1334;;; part of that - assuming that FN is R13 - looks like #x4c #x8d #x2d.
1335
1336(defconstant recover-fn-from-rip-length 7)
1337(defconstant recover-fn-from-rip-disp-offset 3)
1338(defconstant recover-fn-from-rip-word0 #x8d4c)
1339(defconstant recover-fn-from-rip-byte2 #x2d)
1340
1341;;; For backtrace: the relative PC of an argument-check trap
1342;;; must be less than or equal to this value.  (Because of
1343;;; the way that we do "anchored" UUOs, it should always be =.)
1344
1345(defconstant arg-check-trap-pc-limit 7)
1346
1347(provide "X8664-ARCH")
Note: See TracBrowser for help on using the repository browser.