source: branches/ia32/compiler/X86/X8632/x8632-arch.lisp @ 8075

Last change on this file since 8075 was 8075, checked in by rme, 13 years ago

Try to get misc-dfloat-offset right; add scratch-mxcsr field to TCR.

The MXCSR fits in a 32 bit word, but must be read and written through
memory. On x86-64, we can put it in the upper part of a fixnum on the
stack, but that's not an option on IA-32, of course.

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