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

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

move away from lea/jmp, towards call/ret.
rcx is now an imm reg; ra0 = temp2.
new tra scheme.

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