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

Last change on this file since 15094 was 15094, checked in by gb, 8 years ago

So much for "the buildbot will catch any problems after r15093".
Add a couple of missing close parens.

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