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

Last change on this file since 12196 was 12196, checked in by gz, 10 years ago

Merge r11497:r11498 into trunk: pass signal number through to async quit handler so can exit by resignalling.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 45.2 KB
RevLine 
[2935]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
[2966]24(eval-when (:compile-toplevel :load-toplevel :execute)
[3927]25  (require "X86-ARCH")
26  (require "X86-LAP")
27 
[2960]28(defparameter *x8664-symbolic-register-names*
[2977]29  (make-hash-table :test #'equal)
[2960]30  "For the disassembler, mostly")
31
[2949]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
[6462]144  rip
[2949]145  )
146
[2935]147(defmacro defx86reg (alias known)
148  (let* ((known-entry (gensym)))
[10185]149    `(let* ((,known-entry (gethash ,(string known) x86::*x8664-registers*)))
[2935]150      (unless ,known-entry
151        (error "register ~a not defined" ',known))
[10185]152      (setf (gethash ,(string alias) x86::*x8664-registers*) ,known-entry)
[2977]153      (unless (gethash ,(string-downcase (string known)) *x8664-symbolic-register-names*)
154        (setf (gethash ,(string-downcase (string known)) *x8664-symbolic-register-names*)
[2960]155              (string-downcase ,(string alias))))
[2949]156      (defconstant ,alias ,known))))
[2935]157
158(defx86reg imm0 rax)
159(defx86reg imm0.l eax)
160(defx86reg imm0.w ax)
161(defx86reg imm0.b al)
162
[3273]163(defx86reg temp0 rbx)
164(defx86reg temp0.l ebx)
165(defx86reg temp0.w bx)
166(defx86reg temp0.b bl)
[2935]167
[6462]168(defx86reg imm2 rcx)
[8352]169(defx86reg nargs ecx)
[6462]170(defx86reg imm2.l ecx)
[8352]171(defx86reg nargs.w cx)
[3927]172(defx86reg nargs.q rcx)
[6462]173(defx86reg imm2.w cx)
174(defx86reg imm2.b cl)
[3273]175(defx86reg shift cl)
[2935]176
177(defx86reg imm1 rdx)
178(defx86reg imm1.l edx)
179(defx86reg imm1.w dx)
[3132]180(defx86reg imm1.b dl)
[2935]181
[3273]182(defx86reg arg_z rsi)
183(defx86reg arg_z.l esi)
184(defx86reg arg_z.w si)
185(defx86reg arg_z.b sil)
[2935]186
[3273]187(defx86reg arg_y rdi)
188(defx86reg arg_y.l edi)
189(defx86reg arg_y.w di)
190(defx86reg arg_y.b dil)
[2935]191
[3273]192(defx86reg arg_x r8)
193(defx86reg arg_x.l r8d)
194(defx86reg arg_x.w r8w)
195(defx86reg arg_x.b r8b)
[2935]196
[3273]197(defx86reg temp1 r9)
198(defx86reg temp1.l r9d)
199(defx86reg temp1.w r9w)
200(defx86reg temp1.b r9b)
[2935]201
[3273]202(defx86reg ra0 r10)
203(defx86reg ra0.l r10d)
204(defx86reg ra0.w r10w)
205(defx86reg ra0.b r10b)
[2935]206
[6462]207(defx86reg temp2 r10)
208(defx86reg temp2.l r10d)
209(defx86reg temp2.w r10w)
210(defx86reg temp2.b r10b)
211
212
[2935]213(defx86reg save3 r11)
214(defx86reg save3.l r11d)
[7624]215(defx86reg save3.w r11w)
216(defx86reg save3.b r11b)
[2935]217
218(defx86reg save2 r12)
219(defx86reg save2.l r12d)
220(defx86reg save2.w r12w)
221(defx86reg save2.b r12b)
222
[3273]223(defx86reg fn r13)
224(defx86reg fn.l r13d)
225(defx86reg fn.w r13w)
226(defx86reg fn.b r13b)
[2935]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
[2949]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)
[3648]254(defx86reg fpzero xmm15)
[2949]255(defx86reg fp15 xmm15)
256
[3273]257;;; There are only 8 mmx registers, and they overlap the x87 FPU.
[4747]258(defx86reg stack-temp mm7)
[2949]259
[3146]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.)
[8352]266
[2935]267(defx86reg fname temp0)
[3146]268(defx86reg next-method-context temp0)
[3170]269;;; We rely one at least one of %ra0/%fn pointing to the current function
[3146]270;;; (or to a TRA that references the function) at all times.  When we
[3170]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
[3146]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)
[2935]277
[2949]278(defx86reg ra1 fn)
[2935]279
280(defx86reg allocptr temp0)
281
[2949]282   
[2935]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)
[3199]297(defconstant word-size-in-bytes 8)
298(defconstant node-size word-size-in-bytes)
[2935]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
[3281]322(defconstant tag-single-float tag-imm-0)
323
[2935]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
[3281]342(defconstant fulltag-single-float fulltag-imm-0)
[2966]343
[2935]344(defmacro define-subtag (name tag value)
345  `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,value ntagbits))))
346
347
[3880]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)
[2935]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
[4643]358(define-subtag fixnum-vector ivector-class-64-bit 12)
[2935]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)
[5085]362
363(define-subtag simple-base-string ivector-class-32-bit 12)
[2935]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)
[5149]370
[2935]371(define-subtag s8-vector ivector-class-other-bit 13)
372(define-subtag u8-vector ivector-class-other-bit 14)
[5156]373(defconstant min-8-bit-ivector-subtag subtag-s8-vector)
374(defconstant max-8-bit-ivector-subtag subtag-u8-vector)
[2935]375(define-subtag bit-vector ivector-class-other-bit 15)
376
377
378;;; There's some room for expansion in non-array ivector space.
[3880]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)
[2935]384
[3435]385
[2935]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
[3880]393;;; don't use nodheader/0, since that would conflict with tag-misc
[2935]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)
[4883]401(define-subtag basic-stream fulltag-nodeheader-0 8)
[3880]402(define-subtag function fulltag-nodeheader-0 9)
[2935]403
[3880]404(define-subtag ratio fulltag-nodeheader-1 1)
405(define-subtag complex fulltag-nodeheader-1 2)
[2935]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)
[3880]411(define-subtag instance fulltag-nodeheader-1 8)
412
[2935]413       
[10959]414(defconstant canonical-nil-value (+ #x13000 fulltag-nil))
415(defconstant canonical-t-value (+ #x13020 fulltag-symbol))
[2935]416(defconstant misc-bias fulltag-misc)
417(defconstant cons-bias fulltag-cons)
[10959]418(defconstant t-offset (- canonical-t-value canonical-nil-value))
[2935]419
[3834]420
[2935]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)
[3880]425(defconstant misc-symbol-offset (- node-size fulltag-symbol))
426(defconstant misc-function-offset (- node-size fulltag-function))
427 
[2935]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)
[4267]441(define-subtag reserved-frame fulltag-imm-1 5)
442(defconstant reserved-frame-marker subtag-reserved-frame)
443
[4194]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)
[2935]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
[2966]460)
[2935]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
[3927]530  rsp                                   ;
531  rbp
532  foreign-sp
[2935]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
[3927]539  pc                                    ; tra of catch exit/unwind cleanup
[2935]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
[7716]547  whostate
548  whostate-2
[2935]549  )
550
551
[4883]552
[2935]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
[3132]574(defconstant nilsym-offset (+ t-offset symbol.size))
575
576
[2935]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
[3159]609(define-storage-layout lisp-frame 0
610  backptr
[3856]611  return-address
612  xtra)
[3159]613
[8130]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
[4443]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
[8130]631  foreign-sp                            ; value of tcr.foreign_sp
632  prev-xframe                           ; tcr.xframe before exception
633                                        ; (last 2 needed by apply-in-frame)
[4443]634  )
635
[2935]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.
[3834]661  static-dnodes                         ; for honsing. etc
662  static-used                           ; bitvector
[2935]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
[2966]674(eval-when (:compile-toplevel :load-toplevel :execute)
[3583]675(defconstant tcr-bias 0)
[2966]676)
[2935]677
678(define-storage-layout tcr (- tcr-bias)
679  prev                                  ; in doubly-linked list
680  next                                  ; in doubly-linked list
[3281]681  single-float-convert                  ; faster to box/unbox through memory
[2935]682  linear
[4077]683  save-rbp                              ; lisp frame ptr for foreign code
[2935]684  lisp-fpscr-high
685  db-link                               ; special binding chain head
686  catch-top                             ; top catch frame
[3363]687  save-vsp                              ; SP when in foreign code
[3170]688  save-tsp                              ; TSP, at all times
[3363]689  foreign-sp                            ; SP when in lisp code
[2935]690  cs-area                               ; cstack area pointer
691  vs-area                               ; vstack area pointer
692  ts-area                               ; tstack area pointer
693  cs-limit                              ; cstack overflow limit
[3170]694  total-bytes-allocated
[3304]695  log2-allocation-quantum               ; unboxed
[2935]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
[4727]722  next-tsp
[5366]723  safe-ref-address
[11093]724  pending-io-info
725  io-datum
[2935]726)
727
[3281]728(defconstant tcr.single-float-convert.value (+ 4 tcr.single-float-convert))
729
730
[2935]731(defconstant interrupt-level-binding-index (ash 1 fixnumshift))
732
733(define-storage-layout lockptr 0
734  avail
735  owner
736  count
737  signal
738  waiting
[5981]739  malloced-ptr
740  spinlock)
[2935]741
[7624]742(define-storage-layout rwlock 0
743  spin
744  state
745  blocked-writers
746  blocked-readers
747  writer
748  reader-signal
749  writer-signal
750  malloced-ptr
751  )
752
[2935]753(defmacro define-header (name element-count subtag)
754  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
755
756(define-header double-float-header double-float.element-count subtag-double-float)
757
758;;; We could possibly have a one-digit bignum header when dealing
759;;; with "small bignums" in some bignum code.  Like other cases of
760;;; non-normalized bignums, they should never escape from the lab.
761(define-header one-digit-bignum-header 1 subtag-bignum)
762(define-header two-digit-bignum-header 2 subtag-bignum)
763(define-header three-digit-bignum-header 3 subtag-bignum)
764(define-header four-digit-bignum-header 4 subtag-bignum)
765(define-header five-digit-bignum-header 5 subtag-bignum)
766(define-header symbol-header symbol.element-count subtag-symbol)
767(define-header value-cell-header value-cell.element-count subtag-value-cell)
768(define-header macptr-header macptr.element-count subtag-macptr)
769
[3856]770
[6462]771(defconstant gf-code-size 18)
[3856]772
[2935]773(defun %kernel-global (sym)
774  (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=)))
775    (if pos
776      (- (+ fulltag-nil (* (1+ pos) node-size)))
777      (error "Unknown kernel global : ~s ." sym))))
778
779(defmacro kernel-global (sym)
780  (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=)))
781    (if pos
782      (- (+ fulltag-nil (* (1+ pos) node-size)))
783      (error "Unknown kernel global : ~s ." sym))))
784
785(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step node-size)
786  fd-setsize-bytes
787  do-fd-set
788  do-fd-clr
789  do-fd-is-set
790  do-fd-zero
791  MakeDataExecutable
792  GetSharedLibrary
793  FindSymbol
794  malloc
795  free
[11379]796  jvm-init
[11659]797  tcr-frame-ptr
[11676]798  register-xmacptr-dispose-function
[11631]799  open-debug-output
[4821]800  get-r-debug
[2935]801  restore-soft-stack-limit
802  egc-control
803  lisp-bug
804  NewThread
805  YieldToThread
806  DisposeThread
807  ThreadCurrentStackSpace
808  usage-exit
809  save-fp-context
810  restore-fp-context
811  put-altivec-registers
812  get-altivec-registers
813  new-semaphore
814  wait-on-semaphore
815  signal-semaphore
816  destroy-semaphore
817  new-recursive-lock
818  lock-recursive-lock
819  unlock-recursive-lock
820  destroy-recursive-lock
821  suspend-other-threads
822  resume-other-threads
823  suspend-tcr
824  resume-tcr
825  rwlock-new
826  rwlock-destroy
827  rwlock-rlock
828  rwlock-wlock
829  rwlock-unlock
830  recursive-lock-trylock
831  foreign-name-and-offset
[10659]832  lisp-read
833  lisp-write
834  lisp-open
835  lisp-fchmod
836  lisp-lseek
837  lisp-close
838  lisp-ftruncate
839  lisp-stat
840  lisp-fstat
841  lisp-futex
842  lisp-opendir
843  lisp-readdir
844  lisp-closedir
[10677]845  lisp-pipe
[10816]846  lisp-gettimeofday
[12196]847  lisp-sigexit
[2935]848)
849
850(defmacro nrs-offset (name)
851  (let* ((pos (position name x86::*x86-nilreg-relative-symbols* :test #'eq)))
852    (if pos (* (1- pos) symbol.size))))
853
854(defparameter *x8664-target-uvector-subtags*
855  `((:bignum . ,subtag-bignum)
856    (:ratio . ,subtag-ratio)
857    (:single-float . ,subtag-single-float)
858    (:double-float . ,subtag-double-float)
859    (:complex . ,subtag-complex  )
860    (:symbol . ,subtag-symbol)
861    (:function . ,subtag-function )
862    (:xcode-vector . ,subtag-xcode-vector)
863    (:macptr . ,subtag-macptr )
864    (:catch-frame . ,subtag-catch-frame)
865    (:struct . ,subtag-struct )   
866    (:istruct . ,subtag-istruct )
867    (:pool . ,subtag-pool )
868    (:population . ,subtag-weak )
869    (:hash-vector . ,subtag-hash-vector )
870    (:package . ,subtag-package )
871    (:value-cell . ,subtag-value-cell)
872    (:instance . ,subtag-instance )
873    (:lock . ,subtag-lock )
[4883]874    (:basic-stream . ,subtag-basic-stream)
[2935]875    (:slot-vector . ,subtag-slot-vector)
876    (:simple-string . ,subtag-simple-base-string )
877    (:bit-vector . ,subtag-bit-vector )
878    (:signed-8-bit-vector . ,subtag-s8-vector )
879    (:unsigned-8-bit-vector . ,subtag-u8-vector )
880    (:signed-16-bit-vector . ,subtag-s16-vector )
881    (:unsigned-16-bit-vector . ,subtag-u16-vector )
882    (:signed-32-bit-vector . ,subtag-s32-vector )
883    (:unsigned-32-bit-vector . ,subtag-u32-vector )
884    (:signed-64-bit-vector . ,subtag-s64-vector)
[4643]885    (:fixnum-vector . ,subtag-fixnum-vector)
[2935]886    (:unsigned-64-bit-vector . ,subtag-u64-vector)   
887    (:single-float-vector . ,subtag-single-float-vector)
888    (:double-float-vector . ,subtag-double-float-vector )
889    (:simple-vector . ,subtag-simple-vector )
890    (:vector-header . ,subtag-vectorH)
891    (:array-header . ,subtag-arrayH)))
892
893;;; This should return NIL unless it's sure of how the indicated
894;;; type would be represented (in particular, it should return
895;;; NIL if the element type is unknown or unspecified at compile-time.
896(defun x8664-array-type-name-from-ctype (ctype)
897  (when (typep ctype 'ccl::array-ctype)
898    (let* ((element-type (ccl::array-ctype-element-type ctype)))
899      (typecase element-type
900        (ccl::class-ctype
901         (let* ((class (ccl::class-ctype-class element-type)))
902           (if (or (eq class ccl::*character-class*)
903                   (eq class ccl::*base-char-class*)
904                   (eq class ccl::*standard-char-class*))
905             :simple-string
906             :simple-vector)))
907        (ccl::numeric-ctype
908         (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
909           :simple-vector
910           (case (ccl::numeric-ctype-class element-type)
911             (integer
912              (let* ((low (ccl::numeric-ctype-low element-type))
913                     (high (ccl::numeric-ctype-high element-type)))
914                (cond ((or (null low) (null high))
915                       :simple-vector)
916                      ((and (>= low 0) (<= high 1))
917                       :bit-vector)
918                      ((and (>= low 0) (<= high 255))
919                       :unsigned-8-bit-vector)
920                      ((and (>= low 0) (<= high 65535))
921                       :unsigned-16-bit-vector)
922                      ((and (>= low 0) (<= high #xffffffff))
923                       :unsigned-32-bit-vector)
924                      ((and (>= low 0) (<= high #xffffffffffffffff))
925                       :unsigned-64-bit-vector)
926                      ((and (>= low -128) (<= high 127))
927                       :signed-8-bit-vector)
928                      ((and (>= low -32768) (<= high 32767))
929                       :signed-16-bit-vector)
930                      ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
931                       :signed-32-bit-vector)
[4643]932                      ((and (>= low target-most-negative-fixnum)
933                            (<= high target-most-positive-fixnum))
934                       :fixnum-vector)
[2935]935                      ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63))))
936                       :signed-64-bit-vector)
937                      (t :simple-vector))))
938             (float
939              (case (ccl::numeric-ctype-format element-type)
940                ((double-float long-float) :double-float-vector)
941                ((single-float short-float) :single-float-vector)
942                (t :simple-vector)))
943             (t :simple-vector))))
944        (ccl::unknown-ctype)
945        (ccl::named-ctype
946         (if (eq element-type ccl::*universal-type*)
947           :simple-vector))
948        (t)))))
949
950(defun x8664-misc-byte-count (subtag element-count)
951  (declare (fixnum subtag))
952  (if (logbitp (logand subtag fulltagmask)
[3670]953               (logior (ash 1 fulltag-nodeheader-0)
954                       (ash 1 fulltag-nodeheader-1)))
[2935]955    (ash element-count 3)
956    (case (logand subtag fulltagmask)
957      (#.ivector-class-64-bit (ash element-count 3))
958      (#.ivector-class-32-bit (ash element-count 2))
959      (t
960       (if (= subtag subtag-bit-vector)
961         (ash (+ 7 element-count) -3)
962         (if (>= subtag min-8-bit-ivector-subtag)
963           element-count
964           (ash element-count 1)))))))
965
966(defparameter *x8664-subprims-shift* 3)
[8397]967(defconstant x8664-subprims-base #x15000)
[2935]968
[3670]969
[2966]970(declaim (special *x8664-subprims*))
971
[2935]972;;; For now, nothing's nailed down and we don't say anything about
973;;; registers clobbered.
[3670]974(let* ((origin x8664-subprims-base)
[2935]975       (step (ash 1 *x8664-subprims-shift*)))
976  (flet ((define-x8664-subprim (name)
977             (ccl::make-subprimitive-info :name (string name)
978                                          :offset (prog1 origin
979                                                    (incf origin step)))))
980    (macrolet ((defx8664subprim (name)
981                   `(define-x8664-subprim ',name)))
982      (defparameter *x8664-subprims*
983        (vector
984         (defx8664subprim .SPjmpsym)
985         (defx8664subprim .SPjmpnfn)
986         (defx8664subprim .SPfuncall)
987         (defx8664subprim .SPmkcatch1v)
988         (defx8664subprim .SPmkunwind)
989         (defx8664subprim .SPmkcatchmv)
990         (defx8664subprim .SPthrow)
991         (defx8664subprim .SPnthrowvalues)
992         (defx8664subprim .SPnthrow1value)
993         (defx8664subprim .SPbind)
994         (defx8664subprim .SPbind-self)
995         (defx8664subprim .SPbind-nil)
996         (defx8664subprim .SPbind-self-boundp-check)
997         (defx8664subprim .SPrplaca)
998         (defx8664subprim .SPrplacd)
999         (defx8664subprim .SPconslist)
1000         (defx8664subprim .SPconslist-star)
1001         (defx8664subprim .SPstkconslist)
1002         (defx8664subprim .SPstkconslist-star)
1003         (defx8664subprim .SPmkstackv)
1004         (defx8664subprim .SPsubtag-misc-ref)
1005         (defx8664subprim .SPsetqsym)
1006         (defx8664subprim .SPprogvsave)
1007         (defx8664subprim .SPstack-misc-alloc)
1008         (defx8664subprim .SPgvector)
1009         (defx8664subprim .SPnvalret)
1010         (defx8664subprim .SPmvpass)
[4091]1011         (defx8664subprim .SPrecover-values-for-mvcall)
[2935]1012         (defx8664subprim .SPnthvalue)
1013         (defx8664subprim .SPvalues)
1014         (defx8664subprim .SPdefault-optional-args)
1015         (defx8664subprim .SPopt-supplied-p)
1016         (defx8664subprim .SPheap-rest-arg)
1017         (defx8664subprim .SPreq-heap-rest-arg)
1018         (defx8664subprim .SPheap-cons-rest-arg)
1019         (defx8664subprim .SPsimple-keywords)
1020         (defx8664subprim .SPkeyword-args)
1021         (defx8664subprim .SPkeyword-bind)
[3670]1022         (defx8664subprim .SPffcall)
[5449]1023         (defx8664subprim .SParef2)
[2935]1024         (defx8664subprim .SPksignalerr)
1025         (defx8664subprim .SPstack-rest-arg)
1026         (defx8664subprim .SPreq-stack-rest-arg)
1027         (defx8664subprim .SPstack-cons-rest-arg)
1028         (defx8664subprim .SPpoweropen-callbackX)
1029         (defx8664subprim .SPcall-closure)
1030         (defx8664subprim .SPgetXlong)
1031         (defx8664subprim .SPspreadargz)
1032         (defx8664subprim .SPtfuncallgen)
1033         (defx8664subprim .SPtfuncallslide)
1034         (defx8664subprim .SPtfuncallvsp)
1035         (defx8664subprim .SPtcallsymgen)
1036         (defx8664subprim .SPtcallsymslide)
1037         (defx8664subprim .SPtcallsymvsp)
1038         (defx8664subprim .SPtcallnfngen)
1039         (defx8664subprim .SPtcallnfnslide)
1040         (defx8664subprim .SPtcallnfnvsp)
1041         (defx8664subprim .SPmisc-ref)
1042         (defx8664subprim .SPmisc-set)
1043         (defx8664subprim .SPstkconsyz)
1044         (defx8664subprim .SPstkvcell0)
1045         (defx8664subprim .SPstkvcellvsp)
1046         (defx8664subprim .SPmakestackblock)
1047         (defx8664subprim .SPmakestackblock0)
1048         (defx8664subprim .SPmakestacklist)
1049         (defx8664subprim .SPstkgvector)
1050         (defx8664subprim .SPmisc-alloc)
1051         (defx8664subprim .SPpoweropen-ffcallX)
1052         (defx8664subprim .SPgvset)
1053         (defx8664subprim .SPmacro-bind)
1054         (defx8664subprim .SPdestructuring-bind)
1055         (defx8664subprim .SPdestructuring-bind-inner)
1056         (defx8664subprim .SPrecover-values)
1057         (defx8664subprim .SPvpopargregs)
1058         (defx8664subprim .SPinteger-sign)
1059         (defx8664subprim .SPsubtag-misc-set)
1060         (defx8664subprim .SPspread-lexpr-z)
1061         (defx8664subprim .SPstore-node-conditional)
1062         (defx8664subprim .SPreset)
1063         (defx8664subprim .SPmvslide)
1064         (defx8664subprim .SPsave-values)
1065         (defx8664subprim .SPadd-values)
[3927]1066         (defx8664subprim .SPcallback)
[2935]1067         (defx8664subprim .SPmisc-alloc-init)
1068         (defx8664subprim .SPstack-misc-alloc-init)
1069         (defx8664subprim .SPset-hash-key)
[5449]1070         (defx8664subprim .SPaset2)
[2935]1071         (defx8664subprim .SPcallbuiltin)
1072         (defx8664subprim .SPcallbuiltin0)
1073         (defx8664subprim .SPcallbuiltin1)
1074         (defx8664subprim .SPcallbuiltin2)
1075         (defx8664subprim .SPcallbuiltin3)
1076         (defx8664subprim .SPpopj)
1077         (defx8664subprim .SPrestorefullcontext)
1078         (defx8664subprim .SPsavecontextvsp)
1079         (defx8664subprim .SPsavecontext0)
1080         (defx8664subprim .SPrestorecontext)
1081         (defx8664subprim .SPlexpr-entry)
1082         (defx8664subprim .SPpoweropen-syscall)
1083         (defx8664subprim .SPbuiltin-plus)
1084         (defx8664subprim .SPbuiltin-minus)
1085         (defx8664subprim .SPbuiltin-times)
1086         (defx8664subprim .SPbuiltin-div)
1087         (defx8664subprim .SPbuiltin-eq)
1088         (defx8664subprim .SPbuiltin-ne)
1089         (defx8664subprim .SPbuiltin-gt)
1090         (defx8664subprim .SPbuiltin-ge)
1091         (defx8664subprim .SPbuiltin-lt)
1092         (defx8664subprim .SPbuiltin-le)
1093         (defx8664subprim .SPbuiltin-eql)
1094         (defx8664subprim .SPbuiltin-length)
1095         (defx8664subprim .SPbuiltin-seqtype)
1096         (defx8664subprim .SPbuiltin-assq)
1097         (defx8664subprim .SPbuiltin-memq)
1098         (defx8664subprim .SPbuiltin-logbitp)
1099         (defx8664subprim .SPbuiltin-logior)
1100         (defx8664subprim .SPbuiltin-logand)
1101         (defx8664subprim .SPbuiltin-ash)
1102         (defx8664subprim .SPbuiltin-negate)
1103         (defx8664subprim .SPbuiltin-logxor)
1104         (defx8664subprim .SPbuiltin-aref1)
1105         (defx8664subprim .SPbuiltin-aset1)
1106         (defx8664subprim .SPbreakpoint)
1107         (defx8664subprim .SPeabi-ff-call)
1108         (defx8664subprim .SPeabi-callback)
[4627]1109         (defx8664subprim .SPsyscall)
[2935]1110         (defx8664subprim .SPgetu64)
1111         (defx8664subprim .SPgets64)
1112         (defx8664subprim .SPmakeu64)
1113         (defx8664subprim .SPmakes64)
1114         (defx8664subprim .SPspecref)
1115         (defx8664subprim .SPspecset)
1116         (defx8664subprim .SPspecrefcheck)
1117         (defx8664subprim .SPrestoreintlevel)
1118         (defx8664subprim .SPmakes32)
1119         (defx8664subprim .SPmakeu32)
1120         (defx8664subprim .SPgets32)
1121         (defx8664subprim .SPgetu32)
1122         (defx8664subprim .SPfix-overflow)
1123         (defx8664subprim .SPmvpasssym)
[5511]1124         (defx8664subprim .SParef3)
1125         (defx8664subprim .SPaset3)
[5763]1126         (defx8664subprim .SPffcall-return-registers)
[2935]1127         (defx8664subprim .SPunused-5)
[10731]1128         (defx8664subprim .SPset-hash-key-conditional)
[2935]1129         (defx8664subprim .SPunbind-interrupt-level)
1130         (defx8664subprim .SPunbind)
1131         (defx8664subprim .SPunbind-n)
1132         (defx8664subprim .SPunbind-to)
1133         (defx8664subprim .SPbind-interrupt-level-m1)
1134         (defx8664subprim .SPbind-interrupt-level)
1135         (defx8664subprim .SPbind-interrupt-level-0)
1136         (defx8664subprim .SPprogvrestore)
[6462]1137         (defx8664subprim .SPnmkunwind)
1138         
[2935]1139         )))))
1140
1141(defparameter *x8664-target-arch*
1142  (arch::make-target-arch :name :x8664
1143                          :lisp-node-size 8
[10959]1144                          :nil-value canonical-nil-value
[2935]1145                          :fixnum-shift fixnumshift
1146                          :most-positive-fixnum (1- (ash 1 (1- (- 64 fixnumshift))))
1147                          :most-negative-fixnum (- (ash 1 (1- (- 64 fixnumshift))))
1148                          :misc-data-offset misc-data-offset
1149                          :misc-dfloat-offset misc-dfloat-offset
1150                          :nbits-in-word 64
1151                          :ntagbits 4
1152                          :nlisptagbits 3
1153                          :uvector-subtags *x8664-target-uvector-subtags*
1154                          :max-64-bit-constant-index max-64-bit-constant-index
1155                          :max-32-bit-constant-index max-32-bit-constant-index
1156                          :max-16-bit-constant-index max-16-bit-constant-index
1157                          :max-8-bit-constant-index max-8-bit-constant-index
1158                          :max-1-bit-constant-index max-1-bit-constant-index
1159                          :word-shift 3
[4643]1160                          :code-vector-prefix nil
[2935]1161                          :gvector-types '(:ratio :complex :symbol :function
[5460]1162                                           :catch-frame :struct :istruct
[2935]1163                                           :pool :population :hash-vector
1164                                           :package :value-cell :instance
1165                                           :lock :slot-vector
1166                                           :simple-vector)
1167                          :1-bit-ivector-types '(:bit-vector)
1168                          :8-bit-ivector-types '(:signed-8-bit-vector
[5149]1169                                                 :unsigned-8-bit-vector)
[2935]1170                          :16-bit-ivector-types '(:signed-16-bit-vector
1171                                                  :unsigned-16-bit-vector)
1172                          :32-bit-ivector-types '(:signed-32-bit-vector
1173                                                  :unsigned-32-bit-vector
[3417]1174                                                  :single-float-vector
[2935]1175                                                  :double-float
[5149]1176                                                  :bignum
1177                                                  :simple-string)
[2935]1178                          :64-bit-ivector-types '(:double-float-vector
1179                                                  :unsigned-64-bit-vector
[4643]1180                                                  :signed-64-bit-vector
1181                                                  :fixnum-vector)
[2935]1182                          :array-type-name-from-ctype-function
1183                          #'x8664-array-type-name-from-ctype
1184                          :package-name "X8664"
1185                          :t-offset t-offset
1186                          :array-data-size-function #'x8664-misc-byte-count
1187                          :numeric-type-name-to-typecode-function
1188                          #'(lambda (type-name)
1189                              (ecase type-name
1190                                (fixnum tag-fixnum)
1191                                (bignum subtag-bignum)
1192                                ((short-float single-float) subtag-single-float)
1193                                ((long-float double-float) subtag-double-float)
1194                                (ratio subtag-ratio)
1195                                (complex subtag-complex)))
[3670]1196                          :subprims-base x8664-subprims-base
[2935]1197                          :subprims-shift x8664::*x8664-subprims-shift*
1198                          :subprims-table x8664::*x8664-subprims*
[3216]1199                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus x8664::*x8664-subprims*)))
1200                          :unbound-marker-value unbound-marker
[3226]1201                          :slot-unbound-marker-value slot-unbound-marker
1202                          :fixnum-tag tag-fixnum
1203                          :single-float-tag subtag-single-float
1204                          :single-float-tag-is-subtag nil
1205                          :double-float-tag subtag-double-float
1206                          :cons-tag fulltag-cons
1207                          :null-tag fulltag-nil
1208                          :symbol-tag fulltag-symbol
1209                          :symbol-tag-is-subtag nil
1210                          :function-tag fulltag-function
1211                          :function-tag-is-subtag nil
[3569]1212                          :big-endian nil
[3633]1213                          :misc-subtag-offset misc-subtag-offset
1214                          :car-offset cons.car
1215                          :cdr-offset cons.cdr
1216                          :subtag-char subtag-character
1217                          :charcode-shift charcode-shift
1218                          :fulltagmask fulltagmask
1219                          :fulltag-misc fulltag-misc
[5149]1220                          :char-code-limit #x110000
[3226]1221                          ))
[3603]1222
1223;;; arch macros
1224(defmacro defx8664archmacro (name lambda-list &body body)
1225  `(arch::defarchmacro :x8664 ,name ,lambda-list ,@body))
1226
1227(defx8664archmacro ccl::%make-sfloat ()
1228  (error "~s shouldn't be used in code targeting :X8664" 'ccl::%make-sfloat))
1229
1230(defx8664archmacro ccl::%make-dfloat ()
1231  `(ccl::%alloc-misc x8664::double-float.element-count x8664::subtag-double-float))
1232
1233(defx8664archmacro ccl::%numerator (x)
1234  `(ccl::%svref ,x x8664::ratio.numer-cell))
1235
1236(defx8664archmacro ccl::%denominator (x)
1237  `(ccl::%svref ,x x8664::ratio.denom-cell))
1238
1239(defx8664archmacro ccl::%realpart (x)
1240  `(ccl::%svref ,x x8664::complex.realpart-cell))
1241                   
1242(defx8664archmacro ccl::%imagpart (x)
1243  `(ccl::%svref ,x x8664::complex.imagpart-cell))
1244
1245;;;
1246(defx8664archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
1247 `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)))
1248
1249(defx8664archmacro ccl::codevec-header-p (word)
1250  (declare (ignore word))
1251  (error "~s makes no sense on :X8664" 'ccl::codevec-header-p))
1252
1253;;;
1254
1255(defx8664archmacro ccl::immediate-p-macro (thing)
1256  (let* ((tag (gensym)))
[3617]1257    `(let* ((,tag (ccl::lisptag ,thing)))
[3603]1258      (declare (type (unsigned-byte 3) ,tag))
1259      (logbitp ,tag (logior (ash 1 x8664::tag-fixnum)
1260                    (ash 1 x8664::tag-imm-0)
1261                    (ash 1 x8664::tag-imm-1))))))
1262
1263(defx8664archmacro ccl::hashed-by-identity (thing)
1264  (let* ((typecode (gensym)))
[3617]1265    `(let* ((,typecode (ccl::typecode ,thing)))
[3603]1266      (declare (fixnum ,typecode))
[7935]1267      (or (= ,typecode  x8664::subtag-instance)
1268       (and (<= ,typecode x8664::fulltag-symbol)
1269        (logbitp (the (integer 0 #.x8664::fulltag-symbol) ,typecode)
1270                 (logior (ash 1 x8664::tag-fixnum)
1271                         (ash 1 x8664::tag-imm-0)
1272                         (ash 1 x8664::tag-imm-1)
1273                         (ash 1 x8664::fulltag-symbol))))))))
[3603]1274
[3617]1275;;;
[3794]1276(defx8664archmacro ccl::%get-kernel-global (name)
[10959]1277  `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value)
[3794]1278                        ,(%kernel-global
1279                         (if (ccl::quoted-form-p name)
1280                           (cadr name)
1281                           name)))))
[3603]1282
[3794]1283(defx8664archmacro ccl::%get-kernel-global-ptr (name dest)
[3617]1284  `(ccl::%setf-macptr
1285    ,dest
[10959]1286    (ccl::%int-to-ptr (ccl::%fixnum-ref-natural 0 (+ ,(ccl::target-nil-value)
[3794]1287                                 ,(%kernel-global
1288                                   (if (ccl::quoted-form-p name)
1289                                     (cadr name)
[6462]1290                                     name)))))))
[3617]1291
1292(defx8664archmacro ccl::%target-kernel-global (name)
1293  `(x8664::%kernel-global ,name))
1294
[3726]1295(defx8664archmacro ccl::lfun-vector (fun)
1296  `(ccl::%function-to-function-vector ,fun))
[3617]1297
[3712]1298(defx8664archmacro ccl::lfun-vector-lfun (lfv)
[3726]1299  `(ccl::%function-vector-to-function ,lfv))
[3712]1300
[3739]1301(defx8664archmacro ccl::area-code ()
1302  area.code)
1303
[4000]1304(defx8664archmacro ccl::area-succ ()
1305  area.succ)
1306
[3794]1307(defx8664archmacro ccl::nth-immediate (f i)
1308  `(ccl::%nth-immediate ,f (the fixnum (- (the fixnum ,i) 1))))
1309
1310(defx8664archmacro ccl::set-nth-immediate (f i new)
1311  `(ccl::%set-nth-immediate ,f (the fixnum (- (the fixnum ,i) 1)) ,new))
1312
[3834]1313(defx8664archmacro ccl::symptr->symvector (s)
1314  `(ccl::%symptr->symvector ,s))
1315
1316(defx8664archmacro ccl::symvector->symptr (s)
1317  `(ccl::%symvector->symptr ,s))
1318
[3880]1319(defx8664archmacro ccl::function-to-function-vector (f)
1320  `(ccl::%function-to-function-vector ,f))
[3856]1321
[3880]1322(defx8664archmacro ccl::function-vector-to-function (v)
1323  `(ccl::%function-vector-to-function ,v))
1324
[5768]1325(defx8664archmacro ccl::with-ffcall-results ((buf) &body body)
1326  ;; Reserve space for rax,rdx,xmm0,xmm1 only.
1327  (let* ((size (+ (* 2 8) (* 2 8))))
[5772]1328    `(ccl::%stack-block ((,buf ,size :clear t))
[5768]1329      ,@body)))
[3880]1330
[6462]1331;;; an (lea (@ disp (% rip)) (% fn)) instruction following a tagged
1332;;; return address helps the runtime map from the return address to
1333;;; the containing function.  That instuction is 7 bytes long: 3
1334;;; bytes of code followed by 4 bytes of displacement.  The constant
1335;;; part of that - assuming that FN is R13 - looks like #x4c #x8d #x2d.
[5768]1336
[6462]1337(defconstant recover-fn-from-rip-length 7)
1338(defconstant recover-fn-from-rip-disp-offset 3)
1339(defconstant recover-fn-from-rip-word0 #x8d4c)
1340(defconstant recover-fn-from-rip-byte2 #x2d)
1341
[8130]1342;;; For backtrace: the relative PC of an argument-check trap
1343;;; must be less than or equal to this value.  (Because of
1344;;; the way that we do "anchored" UUOs, it should always be =.)
[6462]1345
[8130]1346(defconstant arg-check-trap-pc-limit 7)
1347
[3603]1348(provide "X8664-ARCH")
Note: See TracBrowser for help on using the repository browser.