source: branches/working-0711/ccl/compiler/X86/X8664/x8664-arch.lisp @ 8010

Last change on this file since 8010 was 8010, checked in by gb, 13 years ago

ARG-CHECK-TRAP-PC-LIMIT.

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