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

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

New Linux ARM binaries.

The image and FASL versions changed on the ARM, but (if I did it right)
not on other platforms.

(The image and FASL versions are now architecture-specific. This may
make it somewhat easier and less disruptive to change them, since the
motivation for such a change is often also architecture-specific.)
The FASL and current image version are defined (in the "TARGET" package)
in the architecture-specific *-arch.lisp files; the min, max, and current
image versions are defined in the *constants*.h file for the architecture.

Most of the changes are ARM-specific.

Each TCR now contains a 256-word table at byte offset 256. (We've
been using about 168 bytes in the TCR, so there are still 88 bytes/22
words left for expansion.) The table is initialized at TCR-creation
time to contain the absolute addresses of the subprims (there are
currently around 130 defined); we try otherwise not to reference
subprims by absolute address. Jumping to a subprim is:

(ldr pc (:@ rcontext (:$ offset-of-subprim-in-tcr-table)))

and calling one involves loading its address from that table into a
register and doing (blx reg). We canonically use LR as the register,
since it's going to be clobbered by the blx anyway and there doesn't
seem to be a performance hazard there. The old scheme (which involved
using BA and BLA pseudoinstructions to jump to/call a hidden jump table
at the end of the function) is no longer supported.

ARM Subprims no longer need to be aligned (on anything more than an
instruction boundary.) Some remnants of the consequences of an old
scheme (where subprims had to "fit" in small regions and sometimes
had to jump out of line if they would overflow that region's bounds)
still remain, but we can repair that (and it'll be a bit more straightforward
to add new ARM subprims.) We no longer care (much) about where subprims
are mapped in memory, and don't have to bias suprimitive addresses by
a platform-specific constant (and have to figure out whether or not we've
already done so) on (e.g.) Android.

Rather than setting the first element (fn.entrypoint) of a
newly-created function to the (absolute) address of a subprim that updates
that entrypoint on the first call, we use a little LAP function to correct
the address before the function can be called.

Non-function objects that can be stored in symbols' function cells
(the UNDEFINED-FUNCTION object, the things that encapsulate
special-operator names and global macro-functions) need to be
structured like FUNCTIONS: the need to have a word-aligned entrypoint
in element 0 that tracks the CODE-VECTOR object in element 1. We
don't want these things to be of type FUNCTION, but do want the GC to
adjust the entrypoint if the codevector moves. We've been essentially
out of GVECTOR subtags on 32-bit platforms, largely because of the
constraints that vector/array subtags must be greater than other
subtags and numeric types be less. The first constraint is probably
reasonable, but the second isn't: other typecodes (tag-list, etc) may
be less than the maximum numeric typecode, so tests like NUMBERP can't
reliably involve a simple comparison. (As long as a mask of all
numeric typecodes will fit in a machine word/FIXNUM, a simple LOGBITP
test can be used instead.) Removed all portable and ARM-specific code
that made assumptions about numeric typecode ordering, made a few more
gvector typecodes available, and used one of them to define a new
"pseudofunction" type. Made the GC update the entrypoints of
pseudofunctions and used them for the undefined-function object and
for the function cells of macros/special-operators.

Since we don't need the subprim jump table at the end of each function
anymore, we can more easily revive the idea of embedded pc-relative
constant data ("constant pools") and initialize FPRs from constant
data, avoiding most remaining traffic between FPRs and GPRs.

I've had a fairly-reproducible cache-coherency problem: on the first
GC in the cold load, the thread misbehaves mysteriously when it
resumes. The GC tries to synchronize the I and D caches on the entire
range of addresses that may contain newly-moved code-vectors. I'm not
at all sure why, but walking that range and flushing the cache for
each code-vector individually seems to avoid the problem (and may actually
be faster.)

Fix ticket:894

Fixed a few typos in error messages/comments/etc.

I -think- that the non-ARM-specific changes (how FASL/image versions are
defined) should bootstrap cleanly, but won't know for sure until this is
committed. (I imagine that the buildbot will complain if not.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 45.5 KB
Line 
1;;;-*- Mode: Lisp; Package: (X8664 :use CL) -*-
2;;;
3;;;   Copyright (C) 2005-2009 Clozure Associates and contributors.
4;;;   This file is part of Clozure CL. 
5;;;
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
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(defpackage "X8664"
18  (:use "CL")
19  #+x8664-target
20  (:nicknames "TARGET"))
21
22(in-package "X8664")
23
24(eval-when (:compile-toplevel :load-toplevel :execute)
25  (require "X86-ARCH")
26  (require "X86-LAP")
27 
28(defparameter *x8664-symbolic-register-names*
29  (make-hash-table :test #'equal)
30  "For the disassembler, mostly")
31
32;;; define integer constants which map to
33;;; indices in the X86::*X8664-REGISTER-ENTRIES* array.
34(ccl::defenum ()
35  rax
36  rcx
37  rdx
38  rbx
39  rsp
40  rbp
41  rsi
42  rdi
43  r8
44  r9
45  r10
46  r11
47  r12
48  r13
49  r14
50  r15
51  ;; 32-bit registers
52  eax
53  ecx
54  edx
55  ebx
56  esp
57  ebp
58  esi
59  edi
60  r8d
61  r9d
62  r10d
63  r11d
64  r12d
65  r13d
66  r14d
67  r15d
68  ;; 16-bit-registers
69  ax
70  cx
71  dx
72  bx
73  sp
74  bp
75  si
76  di
77  r8w
78  r9w
79  r10w
80  r11w
81  r12w
82  r13w
83  r14w
84  r15w
85  ;; 8-bit registers
86  al
87  cl
88  dl
89  bl
90  spl
91  bpl
92  sil
93  dil
94  r8b
95  r9b
96  r10b
97  r11b
98  r12b
99  r13b
100  r14b
101  r15b
102       ;;; xmm registers
103  xmm0
104  xmm1
105  xmm2
106  xmm3
107  xmm4
108  xmm5
109  xmm6
110  xmm7
111  xmm8
112  xmm9
113  xmm10
114  xmm11
115  xmm12
116  xmm13
117  xmm14
118  xmm15
119  ;; MMX registers
120  mm0
121  mm1
122  mm2
123  mm3
124  mm4
125  mm5
126  mm6
127  mm7
128  ;; x87 FP regs.  May or may not be useful.
129  st[0]
130  st[1]
131  st[2]
132  st[3]
133  st[4]
134  st[5]
135  st[6]
136  st[7]
137  ;; Segment registers
138  cs
139  ds
140  ss
141  es
142  fs
143  gs
144  rip
145  )
146
147(defmacro defx86reg (alias known)
148  (let* ((known-entry (gensym)))
149    `(let* ((,known-entry (gethash ,(string known) x86::*x8664-registers*)))
150      (unless ,known-entry
151        (error "register ~a not defined" ',known))
152      (setf (gethash ,(string alias) x86::*x8664-registers*) ,known-entry)
153      (unless (gethash ,(string-downcase (string known)) *x8664-symbolic-register-names*)
154        (setf (gethash ,(string-downcase (string known)) *x8664-symbolic-register-names*)
155              (string-downcase ,(string alias))))
156      (defconstant ,alias ,known))))
157
158(defx86reg imm0 rax)
159(defx86reg imm0.l eax)
160(defx86reg imm0.w ax)
161(defx86reg imm0.b al)
162
163(defx86reg temp0 rbx)
164(defx86reg temp0.l ebx)
165(defx86reg temp0.w bx)
166(defx86reg temp0.b bl)
167
168(defx86reg imm2 rcx)
169(defx86reg nargs ecx)
170(defx86reg imm2.l ecx)
171(defx86reg nargs.w cx)
172(defx86reg nargs.q rcx)
173(defx86reg imm2.w cx)
174(defx86reg imm2.b cl)
175(defx86reg shift cl)
176
177(defx86reg imm1 rdx)
178(defx86reg imm1.l edx)
179(defx86reg imm1.w dx)
180(defx86reg imm1.b dl)
181
182(defx86reg arg_z rsi)
183(defx86reg arg_z.l esi)
184(defx86reg arg_z.w si)
185(defx86reg arg_z.b sil)
186
187(defx86reg arg_y rdi)
188(defx86reg arg_y.l edi)
189(defx86reg arg_y.w di)
190(defx86reg arg_y.b dil)
191
192(defx86reg arg_x r8)
193(defx86reg arg_x.l r8d)
194(defx86reg arg_x.w r8w)
195(defx86reg arg_x.b r8b)
196
197(defx86reg temp1 r9)
198(defx86reg temp1.l r9d)
199(defx86reg temp1.w r9w)
200(defx86reg temp1.b r9b)
201
202(defx86reg temp2 r10)
203(defx86reg temp2.l r10d)
204(defx86reg temp2.w r10w)
205(defx86reg temp2.b r10b)
206
207(defx86reg ra0 r10)
208(defx86reg ra0.l r10d)
209(defx86reg ra0.w r10w)
210(defx86reg ra0.b r10b)
211
212#+(or darwin-target windows-target)
213(defx86reg rcontext r11)
214
215(defx86reg save3 r11)
216(defx86reg save3.l r11d)
217(defx86reg save3.w r11w)
218(defx86reg save3.b r11b)
219
220
221(defx86reg save2 r12)
222(defx86reg save2.l r12d)
223(defx86reg save2.w r12w)
224(defx86reg save2.b r12b)
225
226(defx86reg fn r13)
227(defx86reg fn.l r13d)
228(defx86reg fn.w r13w)
229(defx86reg fn.b r13b)
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
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)
257(defx86reg fpzero xmm15)
258(defx86reg fp15 xmm15)
259
260;;; There are only 8 mmx registers, and they overlap the x87 FPU.
261(defx86reg stack-temp mm7)
262
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.)
269
270(defx86reg fname temp0)
271(defx86reg next-method-context temp0)
272;;; We rely one at least one of %ra0/%fn pointing to the current function
273;;; (or to a TRA that references the function) at all times.  When we
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
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)
280
281(defx86reg ra1 fn)
282
283(defx86reg allocptr temp0)
284
285   
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)
300(defconstant word-size-in-bytes 8)
301(defconstant node-size word-size-in-bytes)
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
325(defconstant tag-single-float tag-imm-0)
326
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
345(defconstant fulltag-single-float fulltag-imm-0)
346
347(defmacro define-subtag (name tag value)
348  `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,value ntagbits))))
349
350
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)
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
361(define-subtag fixnum-vector ivector-class-64-bit 12)
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)
365
366(define-subtag simple-base-string ivector-class-32-bit 12)
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)
373
374(define-subtag s8-vector ivector-class-other-bit 13)
375(define-subtag u8-vector ivector-class-other-bit 14)
376(defconstant min-8-bit-ivector-subtag subtag-s8-vector)
377(defconstant max-8-bit-ivector-subtag subtag-u8-vector)
378(define-subtag bit-vector ivector-class-other-bit 15)
379
380
381;;; There's some room for expansion in non-array ivector space.
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)
387
388
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
396;;; don't use nodheader/0, since that would conflict with tag-misc
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)
404(define-subtag basic-stream fulltag-nodeheader-0 8)
405(define-subtag function fulltag-nodeheader-0 9)
406
407(define-subtag ratio fulltag-nodeheader-1 1)
408(define-subtag complex fulltag-nodeheader-1 2)
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)
414(define-subtag instance fulltag-nodeheader-1 8)
415
416       
417(defconstant canonical-nil-value (+ #x13000 fulltag-nil))
418(defconstant canonical-t-value (+ #x13020 fulltag-symbol))
419(defconstant misc-bias fulltag-misc)
420(defconstant cons-bias fulltag-cons)
421(defconstant t-offset (- canonical-t-value canonical-nil-value))
422
423
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)
428(defconstant misc-symbol-offset (- node-size fulltag-symbol))
429(defconstant misc-function-offset (- node-size fulltag-function))
430 
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)
444(define-subtag reserved-frame fulltag-imm-1 5)
445(defconstant reserved-frame-marker subtag-reserved-frame)
446
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)
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))
461(defconstant max-1-bit-constant-index (ash (+ #x7fffffff x8664::misc-data-offset) 3))
462
463)
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
533  rsp                                   ;
534  rbp
535  foreign-sp
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
542  pc                                    ; tra of catch exit/unwind cleanup
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
550  whostate
551  whostate-2
552  )
553
554
555
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
577(defconstant nilsym-offset (+ t-offset symbol.size))
578
579
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
612(define-storage-layout lisp-frame 0
613  backptr
614  return-address
615  xtra)
616
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
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
634  foreign-sp                            ; value of tcr.foreign_sp
635  prev-xframe                           ; tcr.xframe before exception
636                                        ; (last 2 needed by apply-in-frame)
637  pc-low                                ;fixnum low half of absolute pc
638  pc-high                               ;and the high half
639  )
640
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
656  ndnodes                               ; "active" size of dynamic area or stack
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.
666  static-dnodes                         ; for honsing. etc
667  static-used                           ; bitvector
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
679(eval-when (:compile-toplevel :load-toplevel :execute)
680(defconstant tcr-bias 0)
681)
682
683(define-storage-layout tcr (- tcr-bias)
684  prev                                  ; in doubly-linked list
685  next                                  ; in doubly-linked list
686  single-float-convert                  ; faster to box/unbox through memory
687  linear
688  save-rbp                              ; lisp frame ptr for foreign code
689  lisp-fpscr-high
690  db-link                               ; special binding chain head
691  catch-top                             ; top catch frame
692  save-vsp                              ; SP when in foreign code
693  save-tsp                              ; TSP, at all times
694  foreign-sp                            ; SP when in lisp code
695  cs-area                               ; cstack area pointer
696  vs-area                               ; vstack area pointer
697  ts-area                               ; tstack area pointer
698  cs-limit                              ; cstack overflow limit
699  total-bytes-allocated
700  log2-allocation-quantum               ; unboxed
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
727  next-tsp
728  safe-ref-address
729  pending-io-info
730  io-datum
731)
732
733(defconstant tcr.single-float-convert.value (+ 4 tcr.single-float-convert))
734
735
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
744  malloced-ptr
745  spinlock)
746
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
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
775
776(defconstant gf-code-size 18)
777
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
801  wait-for-signal
802  tcr-frame-ptr
803  register-xmacptr-dispose-function
804  open-debug-output
805  get-r-debug
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
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
850  lisp-pipe
851  lisp-gettimeofday
852  lisp-sigexit
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 )
879    (:basic-stream . ,subtag-basic-stream)
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)
890    (:fixnum-vector . ,subtag-fixnum-vector)
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)
937                      ((and (>= low target-most-negative-fixnum)
938                            (<= high target-most-positive-fixnum))
939                       :fixnum-vector)
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)
958               (logior (ash 1 fulltag-nodeheader-0)
959                       (ash 1 fulltag-nodeheader-1)))
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)
972(defconstant x8664-subprims-base #x15000)
973
974
975(declaim (special *x8664-subprims*))
976
977;;; For now, nothing's nailed down and we don't say anything about
978;;; registers clobbered.
979(let* ((origin x8664-subprims-base)
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)
1016         (defx8664subprim .SPrecover-values-for-mvcall)
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)
1027         (defx8664subprim .SPffcall)
1028         (defx8664subprim .SParef2)
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)
1071         (defx8664subprim .SPcallback)
1072         (defx8664subprim .SPmisc-alloc-init)
1073         (defx8664subprim .SPstack-misc-alloc-init)
1074         (defx8664subprim .SPset-hash-key)
1075         (defx8664subprim .SPaset2)
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)
1114         (defx8664subprim .SPsyscall)
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)
1129         (defx8664subprim .SParef3)
1130         (defx8664subprim .SPaset3)
1131         (defx8664subprim .SPffcall-return-registers)
1132         (defx8664subprim .SPunused-5)
1133         (defx8664subprim .SPset-hash-key-conditional)
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)
1142         (defx8664subprim .SPnmkunwind)
1143         
1144         )))))
1145
1146(defparameter *x8664-target-arch*
1147  (arch::make-target-arch :name :x8664
1148                          :lisp-node-size 8
1149                          :nil-value canonical-nil-value
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
1165                          :code-vector-prefix nil
1166                          :gvector-types '(:ratio :complex :symbol :function
1167                                           :catch-frame :struct :istruct
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
1174                                                 :unsigned-8-bit-vector)
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
1179                                                  :single-float-vector
1180                                                  :double-float
1181                                                  :bignum
1182                                                  :simple-string)
1183                          :64-bit-ivector-types '(:double-float-vector
1184                                                  :unsigned-64-bit-vector
1185                                                  :signed-64-bit-vector
1186                                                  :fixnum-vector)
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)))
1201                          :subprims-base x8664-subprims-base
1202                          :subprims-shift x8664::*x8664-subprims-shift*
1203                          :subprims-table x8664::*x8664-subprims*
1204                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus x8664::*x8664-subprims*)))
1205                          :unbound-marker-value unbound-marker
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
1217                          :big-endian nil
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
1225                          :char-code-limit #x110000
1226                          ))
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)))
1262    `(let* ((,tag (ccl::lisptag ,thing)))
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)))
1270    `(let* ((,typecode (ccl::typecode ,thing)))
1271      (declare (fixnum ,typecode))
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))))))))
1279
1280;;;
1281(defx8664archmacro ccl::%get-kernel-global (name)
1282  `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value)
1283                        ,(%kernel-global
1284                         (if (ccl::quoted-form-p name)
1285                           (cadr name)
1286                           name)))))
1287
1288(defx8664archmacro ccl::%get-kernel-global-ptr (name dest)
1289  `(ccl::%setf-macptr
1290    ,dest
1291    (ccl::%int-to-ptr (ccl::%fixnum-ref-natural 0 (+ ,(ccl::target-nil-value)
1292                                 ,(%kernel-global
1293                                   (if (ccl::quoted-form-p name)
1294                                     (cadr name)
1295                                     name)))))))
1296
1297(defx8664archmacro ccl::%target-kernel-global (name)
1298  `(x8664::%kernel-global ,name))
1299
1300(defx8664archmacro ccl::lfun-vector (fun)
1301  `(ccl::%function-to-function-vector ,fun))
1302
1303(defx8664archmacro ccl::lfun-vector-lfun (lfv)
1304  `(ccl::%function-vector-to-function ,lfv))
1305
1306(defx8664archmacro ccl::area-code ()
1307  area.code)
1308
1309(defx8664archmacro ccl::area-succ ()
1310  area.succ)
1311
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
1318(defx8664archmacro ccl::symptr->symvector (s)
1319  `(ccl::%symptr->symvector ,s))
1320
1321(defx8664archmacro ccl::symvector->symptr (s)
1322  `(ccl::%symvector->symptr ,s))
1323
1324(defx8664archmacro ccl::function-to-function-vector (f)
1325  `(ccl::%function-to-function-vector ,f))
1326
1327(defx8664archmacro ccl::function-vector-to-function (v)
1328  `(ccl::%function-vector-to-function ,v))
1329
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))))
1333    `(ccl::%stack-block ((,buf ,size :clear t))
1334      ,@body)))
1335
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.
1341
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
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 =.)
1350
1351(defconstant arg-check-trap-pc-limit 7)
1352
1353(defconstant fasl-version #x5f)
1354(defconstant fasl-max-version #x5f)
1355(defconstant fasl-min-version #x5e
1356(defparameter *image-abi-version* 1037)
1357
1358(provide "X8664-ARCH")
Note: See TracBrowser for help on using the repository browser.