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

Last change on this file since 10959 was 10959, checked in by gb, 11 years ago

Replace uses of target::nil-value with (CCL::TARGET-NIL-VALUE) and
target::t-value with (CCL::TARGET-T-VALUE).

This was very slightly hard to bootstrap (the new backend-lowmem-bias
had to be in effect and typically 0), so I'll start checking in images
in a minute.

  • 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)
725
726(defconstant tcr.single-float-convert.value (+ 4 tcr.single-float-convert))
727
728
729(defconstant interrupt-level-binding-index (ash 1 fixnumshift))
730
731(define-storage-layout lockptr 0
732  avail
733  owner
734  count
735  signal
736  waiting
737  malloced-ptr
738  spinlock)
739
740(define-storage-layout rwlock 0
741  spin
742  state
743  blocked-writers
744  blocked-readers
745  writer
746  reader-signal
747  writer-signal
748  malloced-ptr
749  )
750
751(defmacro define-header (name element-count subtag)
752  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
753
754(define-header double-float-header double-float.element-count subtag-double-float)
755
756;;; We could possibly have a one-digit bignum header when dealing
757;;; with "small bignums" in some bignum code.  Like other cases of
758;;; non-normalized bignums, they should never escape from the lab.
759(define-header one-digit-bignum-header 1 subtag-bignum)
760(define-header two-digit-bignum-header 2 subtag-bignum)
761(define-header three-digit-bignum-header 3 subtag-bignum)
762(define-header four-digit-bignum-header 4 subtag-bignum)
763(define-header five-digit-bignum-header 5 subtag-bignum)
764(define-header symbol-header symbol.element-count subtag-symbol)
765(define-header value-cell-header value-cell.element-count subtag-value-cell)
766(define-header macptr-header macptr.element-count subtag-macptr)
767
768
769(defconstant gf-code-size 18)
770
771(defun %kernel-global (sym)
772  (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=)))
773    (if pos
774      (- (+ fulltag-nil (* (1+ pos) node-size)))
775      (error "Unknown kernel global : ~s ." sym))))
776
777(defmacro kernel-global (sym)
778  (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=)))
779    (if pos
780      (- (+ fulltag-nil (* (1+ pos) node-size)))
781      (error "Unknown kernel global : ~s ." sym))))
782
783(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step node-size)
784  fd-setsize-bytes
785  do-fd-set
786  do-fd-clr
787  do-fd-is-set
788  do-fd-zero
789  MakeDataExecutable
790  GetSharedLibrary
791  FindSymbol
792  malloc
793  free
794  allocate_tstack
795  allocate_vstack
796  register_cstack
797  raise-thread-interrupt
798  get-r-debug
799  restore-soft-stack-limit
800  egc-control
801  lisp-bug
802  NewThread
803  YieldToThread
804  DisposeThread
805  ThreadCurrentStackSpace
806  usage-exit
807  save-fp-context
808  restore-fp-context
809  put-altivec-registers
810  get-altivec-registers
811  new-semaphore
812  wait-on-semaphore
813  signal-semaphore
814  destroy-semaphore
815  new-recursive-lock
816  lock-recursive-lock
817  unlock-recursive-lock
818  destroy-recursive-lock
819  suspend-other-threads
820  resume-other-threads
821  suspend-tcr
822  resume-tcr
823  rwlock-new
824  rwlock-destroy
825  rwlock-rlock
826  rwlock-wlock
827  rwlock-unlock
828  recursive-lock-trylock
829  foreign-name-and-offset
830  lisp-read
831  lisp-write
832  lisp-open
833  lisp-fchmod
834  lisp-lseek
835  lisp-close
836  lisp-ftruncate
837  lisp-stat
838  lisp-fstat
839  lisp-futex
840  lisp-opendir
841  lisp-readdir
842  lisp-closedir
843  lisp-pipe
844  lisp-gettimeofday
845)
846
847(defmacro nrs-offset (name)
848  (let* ((pos (position name x86::*x86-nilreg-relative-symbols* :test #'eq)))
849    (if pos (* (1- pos) symbol.size))))
850
851(defparameter *x8664-target-uvector-subtags*
852  `((:bignum . ,subtag-bignum)
853    (:ratio . ,subtag-ratio)
854    (:single-float . ,subtag-single-float)
855    (:double-float . ,subtag-double-float)
856    (:complex . ,subtag-complex  )
857    (:symbol . ,subtag-symbol)
858    (:function . ,subtag-function )
859    (:xcode-vector . ,subtag-xcode-vector)
860    (:macptr . ,subtag-macptr )
861    (:catch-frame . ,subtag-catch-frame)
862    (:struct . ,subtag-struct )   
863    (:istruct . ,subtag-istruct )
864    (:pool . ,subtag-pool )
865    (:population . ,subtag-weak )
866    (:hash-vector . ,subtag-hash-vector )
867    (:package . ,subtag-package )
868    (:value-cell . ,subtag-value-cell)
869    (:instance . ,subtag-instance )
870    (:lock . ,subtag-lock )
871    (:basic-stream . ,subtag-basic-stream)
872    (:slot-vector . ,subtag-slot-vector)
873    (:simple-string . ,subtag-simple-base-string )
874    (:bit-vector . ,subtag-bit-vector )
875    (:signed-8-bit-vector . ,subtag-s8-vector )
876    (:unsigned-8-bit-vector . ,subtag-u8-vector )
877    (:signed-16-bit-vector . ,subtag-s16-vector )
878    (:unsigned-16-bit-vector . ,subtag-u16-vector )
879    (:signed-32-bit-vector . ,subtag-s32-vector )
880    (:unsigned-32-bit-vector . ,subtag-u32-vector )
881    (:signed-64-bit-vector . ,subtag-s64-vector)
882    (:fixnum-vector . ,subtag-fixnum-vector)
883    (:unsigned-64-bit-vector . ,subtag-u64-vector)   
884    (:single-float-vector . ,subtag-single-float-vector)
885    (:double-float-vector . ,subtag-double-float-vector )
886    (:simple-vector . ,subtag-simple-vector )
887    (:vector-header . ,subtag-vectorH)
888    (:array-header . ,subtag-arrayH)))
889
890;;; This should return NIL unless it's sure of how the indicated
891;;; type would be represented (in particular, it should return
892;;; NIL if the element type is unknown or unspecified at compile-time.
893(defun x8664-array-type-name-from-ctype (ctype)
894  (when (typep ctype 'ccl::array-ctype)
895    (let* ((element-type (ccl::array-ctype-element-type ctype)))
896      (typecase element-type
897        (ccl::class-ctype
898         (let* ((class (ccl::class-ctype-class element-type)))
899           (if (or (eq class ccl::*character-class*)
900                   (eq class ccl::*base-char-class*)
901                   (eq class ccl::*standard-char-class*))
902             :simple-string
903             :simple-vector)))
904        (ccl::numeric-ctype
905         (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
906           :simple-vector
907           (case (ccl::numeric-ctype-class element-type)
908             (integer
909              (let* ((low (ccl::numeric-ctype-low element-type))
910                     (high (ccl::numeric-ctype-high element-type)))
911                (cond ((or (null low) (null high))
912                       :simple-vector)
913                      ((and (>= low 0) (<= high 1))
914                       :bit-vector)
915                      ((and (>= low 0) (<= high 255))
916                       :unsigned-8-bit-vector)
917                      ((and (>= low 0) (<= high 65535))
918                       :unsigned-16-bit-vector)
919                      ((and (>= low 0) (<= high #xffffffff))
920                       :unsigned-32-bit-vector)
921                      ((and (>= low 0) (<= high #xffffffffffffffff))
922                       :unsigned-64-bit-vector)
923                      ((and (>= low -128) (<= high 127))
924                       :signed-8-bit-vector)
925                      ((and (>= low -32768) (<= high 32767))
926                       :signed-16-bit-vector)
927                      ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
928                       :signed-32-bit-vector)
929                      ((and (>= low target-most-negative-fixnum)
930                            (<= high target-most-positive-fixnum))
931                       :fixnum-vector)
932                      ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63))))
933                       :signed-64-bit-vector)
934                      (t :simple-vector))))
935             (float
936              (case (ccl::numeric-ctype-format element-type)
937                ((double-float long-float) :double-float-vector)
938                ((single-float short-float) :single-float-vector)
939                (t :simple-vector)))
940             (t :simple-vector))))
941        (ccl::unknown-ctype)
942        (ccl::named-ctype
943         (if (eq element-type ccl::*universal-type*)
944           :simple-vector))
945        (t)))))
946
947(defun x8664-misc-byte-count (subtag element-count)
948  (declare (fixnum subtag))
949  (if (logbitp (logand subtag fulltagmask)
950               (logior (ash 1 fulltag-nodeheader-0)
951                       (ash 1 fulltag-nodeheader-1)))
952    (ash element-count 3)
953    (case (logand subtag fulltagmask)
954      (#.ivector-class-64-bit (ash element-count 3))
955      (#.ivector-class-32-bit (ash element-count 2))
956      (t
957       (if (= subtag subtag-bit-vector)
958         (ash (+ 7 element-count) -3)
959         (if (>= subtag min-8-bit-ivector-subtag)
960           element-count
961           (ash element-count 1)))))))
962
963(defparameter *x8664-subprims-shift* 3)
964(defconstant x8664-subprims-base #x15000)
965
966
967(declaim (special *x8664-subprims*))
968
969;;; For now, nothing's nailed down and we don't say anything about
970;;; registers clobbered.
971(let* ((origin x8664-subprims-base)
972       (step (ash 1 *x8664-subprims-shift*)))
973  (flet ((define-x8664-subprim (name)
974             (ccl::make-subprimitive-info :name (string name)
975                                          :offset (prog1 origin
976                                                    (incf origin step)))))
977    (macrolet ((defx8664subprim (name)
978                   `(define-x8664-subprim ',name)))
979      (defparameter *x8664-subprims*
980        (vector
981         (defx8664subprim .SPjmpsym)
982         (defx8664subprim .SPjmpnfn)
983         (defx8664subprim .SPfuncall)
984         (defx8664subprim .SPmkcatch1v)
985         (defx8664subprim .SPmkunwind)
986         (defx8664subprim .SPmkcatchmv)
987         (defx8664subprim .SPthrow)
988         (defx8664subprim .SPnthrowvalues)
989         (defx8664subprim .SPnthrow1value)
990         (defx8664subprim .SPbind)
991         (defx8664subprim .SPbind-self)
992         (defx8664subprim .SPbind-nil)
993         (defx8664subprim .SPbind-self-boundp-check)
994         (defx8664subprim .SPrplaca)
995         (defx8664subprim .SPrplacd)
996         (defx8664subprim .SPconslist)
997         (defx8664subprim .SPconslist-star)
998         (defx8664subprim .SPstkconslist)
999         (defx8664subprim .SPstkconslist-star)
1000         (defx8664subprim .SPmkstackv)
1001         (defx8664subprim .SPsubtag-misc-ref)
1002         (defx8664subprim .SPsetqsym)
1003         (defx8664subprim .SPprogvsave)
1004         (defx8664subprim .SPstack-misc-alloc)
1005         (defx8664subprim .SPgvector)
1006         (defx8664subprim .SPnvalret)
1007         (defx8664subprim .SPmvpass)
1008         (defx8664subprim .SPrecover-values-for-mvcall)
1009         (defx8664subprim .SPnthvalue)
1010         (defx8664subprim .SPvalues)
1011         (defx8664subprim .SPdefault-optional-args)
1012         (defx8664subprim .SPopt-supplied-p)
1013         (defx8664subprim .SPheap-rest-arg)
1014         (defx8664subprim .SPreq-heap-rest-arg)
1015         (defx8664subprim .SPheap-cons-rest-arg)
1016         (defx8664subprim .SPsimple-keywords)
1017         (defx8664subprim .SPkeyword-args)
1018         (defx8664subprim .SPkeyword-bind)
1019         (defx8664subprim .SPffcall)
1020         (defx8664subprim .SParef2)
1021         (defx8664subprim .SPksignalerr)
1022         (defx8664subprim .SPstack-rest-arg)
1023         (defx8664subprim .SPreq-stack-rest-arg)
1024         (defx8664subprim .SPstack-cons-rest-arg)
1025         (defx8664subprim .SPpoweropen-callbackX)
1026         (defx8664subprim .SPcall-closure)
1027         (defx8664subprim .SPgetXlong)
1028         (defx8664subprim .SPspreadargz)
1029         (defx8664subprim .SPtfuncallgen)
1030         (defx8664subprim .SPtfuncallslide)
1031         (defx8664subprim .SPtfuncallvsp)
1032         (defx8664subprim .SPtcallsymgen)
1033         (defx8664subprim .SPtcallsymslide)
1034         (defx8664subprim .SPtcallsymvsp)
1035         (defx8664subprim .SPtcallnfngen)
1036         (defx8664subprim .SPtcallnfnslide)
1037         (defx8664subprim .SPtcallnfnvsp)
1038         (defx8664subprim .SPmisc-ref)
1039         (defx8664subprim .SPmisc-set)
1040         (defx8664subprim .SPstkconsyz)
1041         (defx8664subprim .SPstkvcell0)
1042         (defx8664subprim .SPstkvcellvsp)
1043         (defx8664subprim .SPmakestackblock)
1044         (defx8664subprim .SPmakestackblock0)
1045         (defx8664subprim .SPmakestacklist)
1046         (defx8664subprim .SPstkgvector)
1047         (defx8664subprim .SPmisc-alloc)
1048         (defx8664subprim .SPpoweropen-ffcallX)
1049         (defx8664subprim .SPgvset)
1050         (defx8664subprim .SPmacro-bind)
1051         (defx8664subprim .SPdestructuring-bind)
1052         (defx8664subprim .SPdestructuring-bind-inner)
1053         (defx8664subprim .SPrecover-values)
1054         (defx8664subprim .SPvpopargregs)
1055         (defx8664subprim .SPinteger-sign)
1056         (defx8664subprim .SPsubtag-misc-set)
1057         (defx8664subprim .SPspread-lexpr-z)
1058         (defx8664subprim .SPstore-node-conditional)
1059         (defx8664subprim .SPreset)
1060         (defx8664subprim .SPmvslide)
1061         (defx8664subprim .SPsave-values)
1062         (defx8664subprim .SPadd-values)
1063         (defx8664subprim .SPcallback)
1064         (defx8664subprim .SPmisc-alloc-init)
1065         (defx8664subprim .SPstack-misc-alloc-init)
1066         (defx8664subprim .SPset-hash-key)
1067         (defx8664subprim .SPaset2)
1068         (defx8664subprim .SPcallbuiltin)
1069         (defx8664subprim .SPcallbuiltin0)
1070         (defx8664subprim .SPcallbuiltin1)
1071         (defx8664subprim .SPcallbuiltin2)
1072         (defx8664subprim .SPcallbuiltin3)
1073         (defx8664subprim .SPpopj)
1074         (defx8664subprim .SPrestorefullcontext)
1075         (defx8664subprim .SPsavecontextvsp)
1076         (defx8664subprim .SPsavecontext0)
1077         (defx8664subprim .SPrestorecontext)
1078         (defx8664subprim .SPlexpr-entry)
1079         (defx8664subprim .SPpoweropen-syscall)
1080         (defx8664subprim .SPbuiltin-plus)
1081         (defx8664subprim .SPbuiltin-minus)
1082         (defx8664subprim .SPbuiltin-times)
1083         (defx8664subprim .SPbuiltin-div)
1084         (defx8664subprim .SPbuiltin-eq)
1085         (defx8664subprim .SPbuiltin-ne)
1086         (defx8664subprim .SPbuiltin-gt)
1087         (defx8664subprim .SPbuiltin-ge)
1088         (defx8664subprim .SPbuiltin-lt)
1089         (defx8664subprim .SPbuiltin-le)
1090         (defx8664subprim .SPbuiltin-eql)
1091         (defx8664subprim .SPbuiltin-length)
1092         (defx8664subprim .SPbuiltin-seqtype)
1093         (defx8664subprim .SPbuiltin-assq)
1094         (defx8664subprim .SPbuiltin-memq)
1095         (defx8664subprim .SPbuiltin-logbitp)
1096         (defx8664subprim .SPbuiltin-logior)
1097         (defx8664subprim .SPbuiltin-logand)
1098         (defx8664subprim .SPbuiltin-ash)
1099         (defx8664subprim .SPbuiltin-negate)
1100         (defx8664subprim .SPbuiltin-logxor)
1101         (defx8664subprim .SPbuiltin-aref1)
1102         (defx8664subprim .SPbuiltin-aset1)
1103         (defx8664subprim .SPbreakpoint)
1104         (defx8664subprim .SPeabi-ff-call)
1105         (defx8664subprim .SPeabi-callback)
1106         (defx8664subprim .SPsyscall)
1107         (defx8664subprim .SPgetu64)
1108         (defx8664subprim .SPgets64)
1109         (defx8664subprim .SPmakeu64)
1110         (defx8664subprim .SPmakes64)
1111         (defx8664subprim .SPspecref)
1112         (defx8664subprim .SPspecset)
1113         (defx8664subprim .SPspecrefcheck)
1114         (defx8664subprim .SPrestoreintlevel)
1115         (defx8664subprim .SPmakes32)
1116         (defx8664subprim .SPmakeu32)
1117         (defx8664subprim .SPgets32)
1118         (defx8664subprim .SPgetu32)
1119         (defx8664subprim .SPfix-overflow)
1120         (defx8664subprim .SPmvpasssym)
1121         (defx8664subprim .SParef3)
1122         (defx8664subprim .SPaset3)
1123         (defx8664subprim .SPffcall-return-registers)
1124         (defx8664subprim .SPunused-5)
1125         (defx8664subprim .SPset-hash-key-conditional)
1126         (defx8664subprim .SPunbind-interrupt-level)
1127         (defx8664subprim .SPunbind)
1128         (defx8664subprim .SPunbind-n)
1129         (defx8664subprim .SPunbind-to)
1130         (defx8664subprim .SPbind-interrupt-level-m1)
1131         (defx8664subprim .SPbind-interrupt-level)
1132         (defx8664subprim .SPbind-interrupt-level-0)
1133         (defx8664subprim .SPprogvrestore)
1134         (defx8664subprim .SPnmkunwind)
1135         
1136         )))))
1137
1138(defparameter *x8664-target-arch*
1139  (arch::make-target-arch :name :x8664
1140                          :lisp-node-size 8
1141                          :nil-value canonical-nil-value
1142                          :fixnum-shift fixnumshift
1143                          :most-positive-fixnum (1- (ash 1 (1- (- 64 fixnumshift))))
1144                          :most-negative-fixnum (- (ash 1 (1- (- 64 fixnumshift))))
1145                          :misc-data-offset misc-data-offset
1146                          :misc-dfloat-offset misc-dfloat-offset
1147                          :nbits-in-word 64
1148                          :ntagbits 4
1149                          :nlisptagbits 3
1150                          :uvector-subtags *x8664-target-uvector-subtags*
1151                          :max-64-bit-constant-index max-64-bit-constant-index
1152                          :max-32-bit-constant-index max-32-bit-constant-index
1153                          :max-16-bit-constant-index max-16-bit-constant-index
1154                          :max-8-bit-constant-index max-8-bit-constant-index
1155                          :max-1-bit-constant-index max-1-bit-constant-index
1156                          :word-shift 3
1157                          :code-vector-prefix nil
1158                          :gvector-types '(:ratio :complex :symbol :function
1159                                           :catch-frame :struct :istruct
1160                                           :pool :population :hash-vector
1161                                           :package :value-cell :instance
1162                                           :lock :slot-vector
1163                                           :simple-vector)
1164                          :1-bit-ivector-types '(:bit-vector)
1165                          :8-bit-ivector-types '(:signed-8-bit-vector
1166                                                 :unsigned-8-bit-vector)
1167                          :16-bit-ivector-types '(:signed-16-bit-vector
1168                                                  :unsigned-16-bit-vector)
1169                          :32-bit-ivector-types '(:signed-32-bit-vector
1170                                                  :unsigned-32-bit-vector
1171                                                  :single-float-vector
1172                                                  :double-float
1173                                                  :bignum
1174                                                  :simple-string)
1175                          :64-bit-ivector-types '(:double-float-vector
1176                                                  :unsigned-64-bit-vector
1177                                                  :signed-64-bit-vector
1178                                                  :fixnum-vector)
1179                          :array-type-name-from-ctype-function
1180                          #'x8664-array-type-name-from-ctype
1181                          :package-name "X8664"
1182                          :t-offset t-offset
1183                          :array-data-size-function #'x8664-misc-byte-count
1184                          :numeric-type-name-to-typecode-function
1185                          #'(lambda (type-name)
1186                              (ecase type-name
1187                                (fixnum tag-fixnum)
1188                                (bignum subtag-bignum)
1189                                ((short-float single-float) subtag-single-float)
1190                                ((long-float double-float) subtag-double-float)
1191                                (ratio subtag-ratio)
1192                                (complex subtag-complex)))
1193                          :subprims-base x8664-subprims-base
1194                          :subprims-shift x8664::*x8664-subprims-shift*
1195                          :subprims-table x8664::*x8664-subprims*
1196                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus x8664::*x8664-subprims*)))
1197                          :unbound-marker-value unbound-marker
1198                          :slot-unbound-marker-value slot-unbound-marker
1199                          :fixnum-tag tag-fixnum
1200                          :single-float-tag subtag-single-float
1201                          :single-float-tag-is-subtag nil
1202                          :double-float-tag subtag-double-float
1203                          :cons-tag fulltag-cons
1204                          :null-tag fulltag-nil
1205                          :symbol-tag fulltag-symbol
1206                          :symbol-tag-is-subtag nil
1207                          :function-tag fulltag-function
1208                          :function-tag-is-subtag nil
1209                          :big-endian nil
1210                          :misc-subtag-offset misc-subtag-offset
1211                          :car-offset cons.car
1212                          :cdr-offset cons.cdr
1213                          :subtag-char subtag-character
1214                          :charcode-shift charcode-shift
1215                          :fulltagmask fulltagmask
1216                          :fulltag-misc fulltag-misc
1217                          :char-code-limit #x110000
1218                          ))
1219
1220;;; arch macros
1221(defmacro defx8664archmacro (name lambda-list &body body)
1222  `(arch::defarchmacro :x8664 ,name ,lambda-list ,@body))
1223
1224(defx8664archmacro ccl::%make-sfloat ()
1225  (error "~s shouldn't be used in code targeting :X8664" 'ccl::%make-sfloat))
1226
1227(defx8664archmacro ccl::%make-dfloat ()
1228  `(ccl::%alloc-misc x8664::double-float.element-count x8664::subtag-double-float))
1229
1230(defx8664archmacro ccl::%numerator (x)
1231  `(ccl::%svref ,x x8664::ratio.numer-cell))
1232
1233(defx8664archmacro ccl::%denominator (x)
1234  `(ccl::%svref ,x x8664::ratio.denom-cell))
1235
1236(defx8664archmacro ccl::%realpart (x)
1237  `(ccl::%svref ,x x8664::complex.realpart-cell))
1238                   
1239(defx8664archmacro ccl::%imagpart (x)
1240  `(ccl::%svref ,x x8664::complex.imagpart-cell))
1241
1242;;;
1243(defx8664archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
1244 `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)))
1245
1246(defx8664archmacro ccl::codevec-header-p (word)
1247  (declare (ignore word))
1248  (error "~s makes no sense on :X8664" 'ccl::codevec-header-p))
1249
1250;;;
1251
1252(defx8664archmacro ccl::immediate-p-macro (thing)
1253  (let* ((tag (gensym)))
1254    `(let* ((,tag (ccl::lisptag ,thing)))
1255      (declare (type (unsigned-byte 3) ,tag))
1256      (logbitp ,tag (logior (ash 1 x8664::tag-fixnum)
1257                    (ash 1 x8664::tag-imm-0)
1258                    (ash 1 x8664::tag-imm-1))))))
1259
1260(defx8664archmacro ccl::hashed-by-identity (thing)
1261  (let* ((typecode (gensym)))
1262    `(let* ((,typecode (ccl::typecode ,thing)))
1263      (declare (fixnum ,typecode))
1264      (or (= ,typecode  x8664::subtag-instance)
1265       (and (<= ,typecode x8664::fulltag-symbol)
1266        (logbitp (the (integer 0 #.x8664::fulltag-symbol) ,typecode)
1267                 (logior (ash 1 x8664::tag-fixnum)
1268                         (ash 1 x8664::tag-imm-0)
1269                         (ash 1 x8664::tag-imm-1)
1270                         (ash 1 x8664::fulltag-symbol))))))))
1271
1272;;;
1273(defx8664archmacro ccl::%get-kernel-global (name)
1274  `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value)
1275                        ,(%kernel-global
1276                         (if (ccl::quoted-form-p name)
1277                           (cadr name)
1278                           name)))))
1279
1280(defx8664archmacro ccl::%get-kernel-global-ptr (name dest)
1281  `(ccl::%setf-macptr
1282    ,dest
1283    (ccl::%int-to-ptr (ccl::%fixnum-ref-natural 0 (+ ,(ccl::target-nil-value)
1284                                 ,(%kernel-global
1285                                   (if (ccl::quoted-form-p name)
1286                                     (cadr name)
1287                                     name)))))))
1288
1289(defx8664archmacro ccl::%target-kernel-global (name)
1290  `(x8664::%kernel-global ,name))
1291
1292(defx8664archmacro ccl::lfun-vector (fun)
1293  `(ccl::%function-to-function-vector ,fun))
1294
1295(defx8664archmacro ccl::lfun-vector-lfun (lfv)
1296  `(ccl::%function-vector-to-function ,lfv))
1297
1298(defx8664archmacro ccl::area-code ()
1299  area.code)
1300
1301(defx8664archmacro ccl::area-succ ()
1302  area.succ)
1303
1304(defx8664archmacro ccl::nth-immediate (f i)
1305  `(ccl::%nth-immediate ,f (the fixnum (- (the fixnum ,i) 1))))
1306
1307(defx8664archmacro ccl::set-nth-immediate (f i new)
1308  `(ccl::%set-nth-immediate ,f (the fixnum (- (the fixnum ,i) 1)) ,new))
1309
1310(defx8664archmacro ccl::symptr->symvector (s)
1311  `(ccl::%symptr->symvector ,s))
1312
1313(defx8664archmacro ccl::symvector->symptr (s)
1314  `(ccl::%symvector->symptr ,s))
1315
1316(defx8664archmacro ccl::function-to-function-vector (f)
1317  `(ccl::%function-to-function-vector ,f))
1318
1319(defx8664archmacro ccl::function-vector-to-function (v)
1320  `(ccl::%function-vector-to-function ,v))
1321
1322(defx8664archmacro ccl::with-ffcall-results ((buf) &body body)
1323  ;; Reserve space for rax,rdx,xmm0,xmm1 only.
1324  (let* ((size (+ (* 2 8) (* 2 8))))
1325    `(ccl::%stack-block ((,buf ,size :clear t))
1326      ,@body)))
1327
1328;;; an (lea (@ disp (% rip)) (% fn)) instruction following a tagged
1329;;; return address helps the runtime map from the return address to
1330;;; the containing function.  That instuction is 7 bytes long: 3
1331;;; bytes of code followed by 4 bytes of displacement.  The constant
1332;;; part of that - assuming that FN is R13 - looks like #x4c #x8d #x2d.
1333
1334(defconstant recover-fn-from-rip-length 7)
1335(defconstant recover-fn-from-rip-disp-offset 3)
1336(defconstant recover-fn-from-rip-word0 #x8d4c)
1337(defconstant recover-fn-from-rip-byte2 #x2d)
1338
1339;;; For backtrace: the relative PC of an argument-check trap
1340;;; must be less than or equal to this value.  (Because of
1341;;; the way that we do "anchored" UUOs, it should always be =.)
1342
1343(defconstant arg-check-trap-pc-limit 7)
1344
1345(provide "X8664-ARCH")
Note: See TracBrowser for help on using the repository browser.