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

Last change on this file was 16773, checked in by rme, 3 years ago

Add kernel-import-lisp-lstat. Use it in %%lstat.

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