source: branches/working-0710/ccl/compiler/X86/X8664/x8664-arch.lisp @ 7388

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

Storage layout for new rwlock.

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