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

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

Add save[0-3] fields to the TCR. These are a caller-saved spill area
for node registers. A function should clear out these fields when its
done with them so that they don't make the GC hang on to stuff that's
otherwise garbage.

As the comment says, the save0 word must be aligned on an 16 byte boundary.
This is so we can use (movapd (% fpzero) (@ (% :rcontext) tcr.save0)) to
clear the entire area quickly.

One possible wrinkle: although malloc/calloc will return suitably
aligned tcr structs, on systems with TLS, a mechanism like
attribute ((aligned (16))) or something might be needed. (Or we
could just use movupd.)

Define next-method-context and a couple of storage layouts. Define
constants used when looking for (movl ($ imm32) (% fn)) at tagged
return addresses.

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-data-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)
604
605(defconstant interrupt-level-binding-index (ash 1 fixnumshift))
606
607(define-storage-layout lockptr 0
608  avail
609  owner
610  count
611  signal
612  waiting
613  malloced-ptr
614  spinlock)
615
616(defmacro define-header (name element-count subtag)
617  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
618
619(define-header single-float-header single-float.element-count subtag-single-float)
620(define-header double-float-header double-float.element-count subtag-double-float)
621
622;;; We could possibly have a one-digit bignum header when dealing
623;;; with "small bignums" in some bignum code.  Like other cases of
624;;; non-normalized bignums, they should never escape from the lab.
625(define-header one-digit-bignum-header 1 subtag-bignum)
626(define-header two-digit-bignum-header 2 subtag-bignum)
627(define-header three-digit-bignum-header 3 subtag-bignum)
628(define-header symbol-header symbol.element-count subtag-symbol)
629(define-header value-cell-header value-cell.element-count subtag-value-cell)
630(define-header macptr-header macptr.element-count subtag-macptr)
631
632;;; see x86-clos.lisp
633(defconstant gf-code-size 18)
634
635(defun %kernel-global (sym)
636  (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=)))
637    (if pos
638      (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
639      (error "Unknown kernel global : ~s ." sym))))
640
641(defmacro kernel-global (sym)
642  (let* ((pos (position sym x86::*x86-kernel-globals* :test #'string=)))
643    (if pos
644      (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
645      (error "Unknown kernel global : ~s ." sym))))
646
647(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step node-size)
648  fd-setsize-bytes
649  do-fd-set
650  do-fd-clr
651  do-fd-is-set
652  do-fd-zero
653  MakeDataExecutable
654  GetSharedLibrary
655  FindSymbol
656  malloc
657  free
658  allocate_tstack
659  allocate_vstack
660  register_cstack
661  raise-thread-interrupt
662  get-r-debug
663  restore-soft-stack-limit
664  egc-control
665  lisp-bug
666  NewThread
667  YieldToThread
668  DisposeThread
669  ThreadCurrentStackSpace
670  usage-exit
671  save-fp-context
672  restore-fp-context
673  put-altivec-registers                 ;is there any
674  get-altivec-registers                 ;point to these on x86?
675  new-semaphore
676  wait-on-semaphore
677  signal-semaphore
678  destroy-semaphore
679  new-recursive-lock
680  lock-recursive-lock
681  unlock-recursive-lock
682  destroy-recursive-lock
683  suspend-other-threads
684  resume-other-threads
685  suspend-tcr
686  resume-tcr
687  rwlock-new
688  rwlock-destroy
689  rwlock-rlock
690  rwlock-wlock
691  rwlock-unlock
692  recursive-lock-trylock
693  foreign-name-and-offset
694)
695
696(defmacro nrs-offset (name)
697  (let* ((pos (position name x86::*x86-nilreg-relative-symbols* :test #'eq)))
698    (if pos (* (1- pos) symbol.size))))
699
700(defmacro with-stack-short-floats (specs &body body)
701  (ccl::collect ((binds)
702                 (inits)
703                 (names))
704                (dolist (spec specs)
705                  (let ((name (first spec)))
706                    (binds `(,name (ccl::%make-sfloat)))
707                    (names name)
708                    (let ((init (second spec)))
709                      (when init
710                        (inits `(ccl::%short-float ,init ,name))))))
711                `(let* ,(binds)
712                  (declare (dynamic-extent ,@(names))
713                           (short-float ,@(names)))
714                  ,@(inits)
715                  ,@body)))
716
717(defparameter *x8632-target-uvector-subtags*
718  `((:bignum . ,subtag-bignum)
719    (:ratio . ,subtag-ratio)
720    (:single-float . ,subtag-single-float)
721    (:double-float . ,subtag-double-float)
722    (:complex . ,subtag-complex  )
723    (:symbol . ,subtag-symbol)
724    (:function . ,subtag-function )
725    (:xcode-vector . ,subtag-xcode-vector)
726    (:macptr . ,subtag-macptr )
727    (:catch-frame . ,subtag-catch-frame)
728    (:struct . ,subtag-struct )   
729    (:istruct . ,subtag-istruct )
730    (:pool . ,subtag-pool )
731    (:population . ,subtag-weak )
732    (:hash-vector . ,subtag-hash-vector )
733    (:package . ,subtag-package )
734    (:value-cell . ,subtag-value-cell)
735    (:instance . ,subtag-instance )
736    (:lock . ,subtag-lock )
737    (:slot-vector . ,subtag-slot-vector)
738    (:basic-stream . ,subtag-basic-stream)
739    (:simple-string . ,subtag-simple-base-string )
740    (:bit-vector . ,subtag-bit-vector )
741    (:signed-8-bit-vector . ,subtag-s8-vector )
742    (:unsigned-8-bit-vector . ,subtag-u8-vector )
743    (:signed-16-bit-vector . ,subtag-s16-vector )
744    (:unsigned-16-bit-vector . ,subtag-u16-vector )
745    (:signed-32-bit-vector . ,subtag-s32-vector )
746    (:fixnum-vector . ,subtag-fixnum-vector)
747    (:unsigned-32-bit-vector . ,subtag-u32-vector )
748    (:single-float-vector . ,subtag-single-float-vector)
749    (:double-float-vector . ,subtag-double-float-vector )
750    (:simple-vector . ,subtag-simple-vector )
751    (:vector-header . ,subtag-vectorH)
752    (:array-header . ,subtag-arrayH)))
753
754;;; This should return NIL unless it's sure of how the indicated
755;;; type would be represented (in particular, it should return
756;;; NIL if the element type is unknown or unspecified at compile-time.
757(defun x8632-array-type-name-from-ctype (ctype)
758  (when (typep ctype 'ccl::array-ctype)
759    (let* ((element-type (ccl::array-ctype-element-type ctype)))
760      (typecase element-type
761        (ccl::class-ctype
762         (let* ((class (ccl::class-ctype-class element-type)))
763           (if (or (eq class ccl::*character-class*)
764                   (eq class ccl::*base-char-class*)
765                   (eq class ccl::*standard-char-class*))
766             :simple-string
767             :simple-vector)))
768        (ccl::numeric-ctype
769         (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
770           :simple-vector
771           (case (ccl::numeric-ctype-class element-type)
772             (integer
773              (let* ((low (ccl::numeric-ctype-low element-type))
774                     (high (ccl::numeric-ctype-high element-type)))
775                (cond ((or (null low) (null high)) :simple-vector)
776                      ((and (>= low 0) (<= high 1) :bit-vector))
777                      ((and (>= low 0) (<= high 255)) :unsigned-8-bit-vector)
778                      ((and (>= low 0) (<= high 65535)) :unsigned-16-bit-vector)
779                      ((and (>= low 0) (<= high #xffffffff) :unsigned-32-bit-vector))
780                      ((and (>= low -128) (<= high 127)) :signed-8-bit-vector)
781                      ((and (>= low -32768) (<= high 32767) :signed-16-bit-vector))
782                      ((and (>= low target-most-negative-fixnum)
783                            (<= high target-most-positive-fixnum))
784                       :fixnum-vector)
785                      ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
786                       :signed-32-bit-vector)
787                      (t :simple-vector))))
788             (float
789              (case (ccl::numeric-ctype-format element-type)
790                ((double-float long-float) :double-float-vector)
791                ((single-float short-float) :single-float-vector)
792                (t :simple-vector)))
793             (t :simple-vector))))
794        (ccl::unknown-ctype)
795        (ccl::named-ctype
796         (if (eq element-type ccl::*universal-type*)
797           :simple-vector))
798        (t nil)))))
799
800(defun x8632-misc-byte-count (subtag element-count)
801  (declare (fixnum subtag))
802  (if (or (= fulltag-nodeheader (logand subtag fulltagmask))
803          (<= subtag max-32-bit-ivector-subtag))
804    (ash element-count 2)
805    (if (<= subtag max-8-bit-ivector-subtag)
806      element-count
807      (if (<= subtag max-16-bit-ivector-subtag)
808        (ash element-count 1)
809        (if (= subtag subtag-bit-vector)
810          (ash (+ element-count 7) -3)
811          (+ 4 (ash element-count 3)))))))
812
813(defparameter *x8632-subprims-shift* 2)
814(defconstant x8632-subprims-base #x5000)
815
816(declaim (special *x8632-subprims*))
817
818(let* ((origin x8632-subprims-base)
819       (step (ash 1 *x8632-subprims-shift*)))
820  (flet ((define-x8632-subprim (name)
821           (ccl::make-subprimitive-info :name (string name)
822                                        :offset (prog1 origin
823                                                  (incf origin step)))))
824    (macrolet ((defx8632subprim (name)
825                 `(define-x8632-subprim ',name)))
826      (defparameter *x8632-subprims*
827        (vector
828         (defx8632subprim .SPjmpsym)
829         (defx8632subprim .SPjmpnfn)
830         (defx8632subprim .SPfuncall)
831         (defx8632subprim .SPmkcatch1v)
832         (defx8632subprim .SPmkunwind)
833         (defx8632subprim .SPmkcatchmv)
834         (defx8632subprim .SPthrow)
835         (defx8632subprim .SPnthrowvalues)
836         (defx8632subprim .SPnthrow1value)
837         (defx8632subprim .SPbind)
838         (defx8632subprim .SPbind-self)
839         (defx8632subprim .SPbind-nil)
840         (defx8632subprim .SPbind-self-boundp-check)
841         (defx8632subprim .SPrplaca)
842         (defx8632subprim .SPrplacd)
843         (defx8632subprim .SPconslist)
844         (defx8632subprim .SPconslist-star)
845         (defx8632subprim .SPstkconslist)
846         (defx8632subprim .SPstkconslist-star)
847         (defx8632subprim .SPmkstackv)
848         (defx8632subprim .SPsubtag-misc-ref)
849         (defx8632subprim .SPsetqsym)
850         (defx8632subprim .SPprogvsave)
851         (defx8632subprim .SPstack-misc-alloc)
852         (defx8632subprim .SPgvector)
853         (defx8632subprim .SPnvalret)
854         (defx8632subprim .SPmvpass)
855         (defx8632subprim .SPrecover-values-for-mvcall)
856         (defx8632subprim .SPnthvalue)
857         (defx8632subprim .SPvalues)
858         (defx8632subprim .SPdefault-optional-args)
859         (defx8632subprim .SPopt-supplied-p)
860         (defx8632subprim .SPheap-rest-arg)
861         (defx8632subprim .SPreq-heap-rest-arg)
862         (defx8632subprim .SPheap-cons-rest-arg)
863         (defx8632subprim .SPsimple-keywords)
864         (defx8632subprim .SPkeyword-args)
865         (defx8632subprim .SPkeyword-bind)
866         (defx8632subprim .SPffcall)
867         (defx8632subprim .SParef2)
868         (defx8632subprim .SPksignalerr)
869         (defx8632subprim .SPstack-rest-arg)
870         (defx8632subprim .SPreq-stack-rest-arg)
871         (defx8632subprim .SPstack-cons-rest-arg)
872         (defx8632subprim .SPpoweropen-callbackX) ;needed on x86?
873         (defx8632subprim .SPcall-closure)
874         (defx8632subprim .SPgetXlong)
875         (defx8632subprim .SPspreadargz)
876         (defx8632subprim .SPtfuncallgen)
877         (defx8632subprim .SPtfuncallslide)
878         (defx8632subprim .SPtfuncallvsp)
879         (defx8632subprim .SPtcallsymgen)
880         (defx8632subprim .SPtcallsymslide)
881         (defx8632subprim .SPtcallsymvsp)
882         (defx8632subprim .SPtcallnfngen)
883         (defx8632subprim .SPtcallnfnslide)
884         (defx8632subprim .SPtcallnfnvsp)
885         (defx8632subprim .SPmisc-ref)
886         (defx8632subprim .SPmisc-set)
887         (defx8632subprim .SPstkconsyz)
888         (defx8632subprim .SPstkvcell0)
889         (defx8632subprim .SPstkvcellvsp)
890         (defx8632subprim .SPmakestackblock)
891         (defx8632subprim .SPmakestackblock0)
892         (defx8632subprim .SPmakestacklist)
893         (defx8632subprim .SPstkgvector)
894         (defx8632subprim .SPmisc-alloc)
895         (defx8632subprim .SPpoweropen-ffcallX) ;needed on x86?
896         (defx8632subprim .SPgvset)
897         (defx8632subprim .SPmacro-bind)
898         (defx8632subprim .SPdestructuring-bind)
899         (defx8632subprim .SPdestructuring-bind-inner)
900         (defx8632subprim .SPrecover-values)
901         (defx8632subprim .SPvpopargregs)
902         (defx8632subprim .SPinteger-sign)
903         (defx8632subprim .SPsubtag-misc-set)
904         (defx8632subprim .SPspread-lexpr-z)
905         (defx8632subprim .SPstore-node-conditional)
906         (defx8632subprim .SPreset)
907         (defx8632subprim .SPmvslide)
908         (defx8632subprim .SPsave-values)
909         (defx8632subprim .SPadd-values)
910         (defx8632subprim .SPcallback)
911         (defx8632subprim .SPmisc-alloc-init)
912         (defx8632subprim .SPstack-misc-alloc-init)
913         (defx8632subprim .SPset-hash-key)
914         (defx8632subprim .SPaset2)
915         (defx8632subprim .SPcallbuiltin)
916         (defx8632subprim .SPcallbuiltin0)
917         (defx8632subprim .SPcallbuiltin1)
918         (defx8632subprim .SPcallbuiltin2)
919         (defx8632subprim .SPcallbuiltin3)
920         (defx8632subprim .SPpopj)
921         (defx8632subprim .SPrestorefullcontext)
922         (defx8632subprim .SPsavecontextvsp)
923         (defx8632subprim .SPsavecontext0)
924         (defx8632subprim .SPrestorecontext)
925         (defx8632subprim .SPlexpr-entry)
926         (defx8632subprim .SPpoweropen-syscall)
927         (defx8632subprim .SPbuiltin-plus)
928         (defx8632subprim .SPbuiltin-minus)
929         (defx8632subprim .SPbuiltin-times)
930         (defx8632subprim .SPbuiltin-div)
931         (defx8632subprim .SPbuiltin-eq)
932         (defx8632subprim .SPbuiltin-ne)
933         (defx8632subprim .SPbuiltin-gt)
934         (defx8632subprim .SPbuiltin-ge)
935         (defx8632subprim .SPbuiltin-lt)
936         (defx8632subprim .SPbuiltin-le)
937         (defx8632subprim .SPbuiltin-eql)
938         (defx8632subprim .SPbuiltin-length)
939         (defx8632subprim .SPbuiltin-seqtype)
940         (defx8632subprim .SPbuiltin-assq)
941         (defx8632subprim .SPbuiltin-memq)
942         (defx8632subprim .SPbuiltin-logbitp)
943         (defx8632subprim .SPbuiltin-logior)
944         (defx8632subprim .SPbuiltin-logand)
945         (defx8632subprim .SPbuiltin-ash)
946         (defx8632subprim .SPbuiltin-negate)
947         (defx8632subprim .SPbuiltin-logxor)
948         (defx8632subprim .SPbuiltin-aref1)
949         (defx8632subprim .SPbuiltin-aset1)
950         (defx8632subprim .SPbreakpoint)
951         (defx8632subprim .SPeabi-ff-call)
952         (defx8632subprim .SPeabi-callback)
953         (defx8632subprim .SPsyscall)
954         (defx8632subprim .SPgetu64)
955         (defx8632subprim .SPgets64)
956         (defx8632subprim .SPmakeu64)
957         (defx8632subprim .SPmakes64)
958         (defx8632subprim .SPspecref)
959         (defx8632subprim .SPspecset)
960         (defx8632subprim .SPspecrefcheck)
961         (defx8632subprim .SPrestoreintlevel)
962         (defx8632subprim .SPmakes32)
963         (defx8632subprim .SPmakeu32)
964         (defx8632subprim .SPgets32)
965         (defx8632subprim .SPgetu32)
966         (defx8632subprim .SPfix-overflow)
967         (defx8632subprim .SPmvpasssym)
968         (defx8632subprim .SParef3)
969         (defx8632subprim .SPaset3)
970         (defx8632subprim .SPffcall-return-registers)
971         (defx8632subprim .SPunused-5)
972         (defx8632subprim .SPunused-6)
973         (defx8632subprim .SPunbind-interrupt-level)
974         (defx8632subprim .SPunbind)
975         (defx8632subprim .SPunbind-n)
976         (defx8632subprim .SPunbind-to)
977         (defx8632subprim .SPbind-interrupt-level-m1)
978         (defx8632subprim .SPbind-interrupt-level)
979         (defx8632subprim .SPbind-interrupt-level-0)
980         (defx8632subprim .SPprogvrestore)
981         (defx8632subprim .SPnmkunwind)
982         )))))
983
984
985
986(defparameter *x8632-target-arch*
987  (arch::make-target-arch :name :x8632
988                          :lisp-node-size node-size
989                          :nil-value nil-value
990                          :fixnum-shift fixnumshift
991                          :most-positive-fixnum target-most-positive-fixnum
992                          :most-negative-fixnum target-most-negative-fixnum
993                          :misc-data-offset misc-data-offset
994                          :misc-dfloat-offset misc-dfloat-offset
995                          :nbits-in-word nbits-in-word
996                          :ntagbits ntagbits
997                          :nlisptagbits nlisptagbits
998                          :uvector-subtags *x8632-target-uvector-subtags*
999                          :max-64-bit-constant-index max-64-bit-constant-index
1000                          :max-32-bit-constant-index max-32-bit-constant-index
1001                          :max-16-bit-constant-index max-16-bit-constant-index
1002                          :max-8-bit-constant-index max-8-bit-constant-index
1003                          :max-1-bit-constant-index max-1-bit-constant-index
1004                          :word-shift word-shift
1005                          :code-vector-prefix ()
1006                          :gvector-types '(:ratio :complex :symbol :function
1007                                           :catch-frame :struct :istruct
1008                                           :pool :population :hash-vector
1009                                           :package :value-cell :instance
1010                                           :lock :slot-vector
1011                                           :simple-vector)
1012                          :1-bit-ivector-types '(:bit-vector)
1013                          :8-bit-ivector-types '(:signed-8-bit-vector
1014                                                 :unsigned-8-bit-vector)
1015                          :16-bit-ivector-types '(:signed-16-bit-vector
1016                                                  :unsigned-16-bit-vector)
1017                          :32-bit-ivector-types '(:signed-32-bit-vector
1018                                                  :unsigned-32-bit-vector
1019                                                  :single-float-vector
1020                                                  :fixnum-vector
1021                                                  :single-float
1022                                                  :double-float
1023                                                  :bignum
1024                                                  :simple-string)
1025                          :64-bit-ivector-types '(:double-float-vector)
1026                          :array-type-name-from-ctype-function
1027                          #'x8632-array-type-name-from-ctype
1028                          :package-name "X8632"
1029                          :t-offset t-offset
1030                          :array-data-size-function #'x8632-misc-byte-count
1031                          :numeric-type-name-to-typecode-function
1032                          #'(lambda (type-name)
1033                              (ecase type-name
1034                                (fixnum tag-fixnum)
1035                                (bignum subtag-bignum)
1036                                ((short-float single-float) subtag-single-float)
1037                                ((long-float double-float) subtag-double-float)
1038                                (ratio subtag-ratio)
1039                                (complex subtag-complex)))
1040                          :subprims-base x8632-subprims-base
1041                          :subprims-shift x8632::*x8632-subprims-shift*
1042                          :subprims-table x8632::*x8632-subprims*
1043                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus x8632::*x8632-subprims*)))
1044                          :unbound-marker-value unbound-marker
1045                          :slot-unbound-marker-value slot-unbound-marker
1046                          :fixnum-tag tag-fixnum
1047                          :single-float-tag subtag-single-float
1048                          :single-float-tag-is-subtag t
1049                          :double-float-tag subtag-double-float
1050                          :cons-tag fulltag-cons
1051                          :null-tag fulltag-cons
1052                          :symbol-tag subtag-symbol
1053                          :symbol-tag-is-subtag t
1054                          :function-tag subtag-function
1055                          :function-tag-is-subtag t
1056                          :big-endian nil
1057                          :misc-subtag-offset misc-subtag-offset
1058                          :car-offset cons.car
1059                          :cdr-offset cons.cdr
1060                          :subtag-char subtag-character
1061                          :charcode-shift charcode-shift
1062                          :fulltagmask fulltagmask
1063                          :fulltag-misc fulltag-misc
1064                          :char-code-limit #x110000
1065                          ))
1066
1067;; arch macros
1068
1069(defmacro defx8632archmacro (name lambda-list &body body)
1070  `(arch::defarchmacro :x8632 ,name ,lambda-list ,@body))
1071
1072(defx8632archmacro ccl::%make-sfloat ()
1073  `(ccl::%alloc-misc x8632::single-float.element-count x8632::subtag-single-float))
1074
1075(defx8632archmacro ccl::%make-dfloat ()
1076  `(ccl::%alloc-misc x8632::double-float.element-count x8632::subtag-double-float))
1077
1078(defx8632archmacro ccl::%numerator (x)
1079  `(ccl::%svref ,x x8632::ratio.numer-cell))
1080
1081(defx8632archmacro ccl::%denominator (x)
1082  `(ccl::%svref ,x x8632::ratio.denom-cell))
1083
1084(defx8632archmacro ccl::%realpart (x)
1085  `(ccl::%svref ,x x8632::complex.realpart-cell))
1086                   
1087(defx8632archmacro ccl::%imagpart (x)
1088  `(ccl::%svref ,x x8632::complex.imagpart-cell))
1089
1090;;;
1091(defx8632archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
1092 `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)
1093   (ccl::%alloc-misc 1 x8632::subtag-single-float)))
1094
1095(defx8632archmacro ccl::codevec-header-p (word)
1096  (declare (ignore word))
1097  (error "~s makes no sense on :X8632" 'ccl::codevec-header-p))
1098
1099(defx8632archmacro ccl::immediate-p-macro (thing)
1100  (let* ((tag (gensym)))
1101    `(let* ((,tag (ccl::lisptag ,thing)))
1102       (declare (fixnum ,tag))
1103       (or (= ,tag x8632::tag-fixnum)
1104           (= ,tag x8632::tag-imm)))))
1105
1106(defx8632archmacro ccl::hashed-by-identity (thing)
1107  (let* ((typecode (gensym)))
1108    `(let* ((,typecode (ccl::typecode ,thing)))
1109       (declare (fixnum ,typecode))
1110       (or
1111        (= ,typecode x8632::tag-fixnum)
1112        (= ,typecode x8632::tag-imm)
1113        (= ,typecode x8632::subtag-symbol)
1114        (= ,typecode x8632::subtag-instance)))))
1115
1116;;;
1117(defx8632archmacro ccl::%get-kernel-global (name)
1118  `(ccl::%fixnum-ref 0 (+ x8632::nil-value
1119                        ,(%kernel-global
1120                          (if (ccl::quoted-form-p name)
1121                            (cadr name)
1122                            name)))))
1123
1124(defx8632archmacro ccl::%get-kernel-global-ptr (name dest)
1125  `(ccl::%setf-macptr
1126    ,dest
1127    (ccl::%fixnum-ref-macptr 0 (+ x8632::nil-value
1128                                  ,(%kernel-global
1129                                    (if (ccl::quoted-form-p name)
1130                                      (cadr name)
1131                                      name))))))
1132
1133(defx8632archmacro ccl::%target-kernel-global (name)
1134  `(x8632::%kernel-global ,name))
1135
1136(defx8632archmacro ccl::lfun-vector (fun)
1137  `(ccl::%function-to-function-vector ,fun))
1138
1139(defx8632archmacro ccl::lfun-vector-lfun (lfv)
1140  `(ccl::%function-vector-to-function ,lfv))
1141
1142(defx8632archmacro ccl::area-code ()
1143  area.code)
1144
1145(defx8632archmacro ccl::area-succ ()
1146  area.succ)
1147
1148(defx8632archmacro ccl::nth-immediate (f i)
1149  `(ccl::%nth-immediate ,f (the fixnum (- (the fixnum ,i) 1))))
1150
1151(defx8632archmacro ccl::set-nth-immediate (f i new)
1152  `(ccl::%set-nth-immediate ,f (the fixnum (- (the fixnum ,i) 1)) ,new))
1153
1154(defx8632archmacro ccl::symptr->symvector (s)
1155  s)
1156
1157(defx8632archmacro ccl::symvector->symptr (s)
1158  s)
1159
1160(defx8632archmacro ccl::function-to-function-vector (f)
1161  f)
1162
1163(defx8632archmacro ccl::function-vector-to-function (v)
1164  v)
1165
1166(defx8632archmacro ccl::with-ffcall-results ((buf) &body body)
1167  ;; Reserve space for eax,edx,st0 only.
1168  (let* ((size (+ (* 2 4) (* 1 8))))
1169    `(ccl::%stack-block ((,buf ,size :clear t))
1170      ,@body)))
1171
1172;;; When found at a tagged return address, the instruction
1173;;; (movl ($ imm32) (% fn))
1174;;; lets the runtime easily map a return address to the containing
1175;;; function.
1176;;;
1177;;; The notation ($ :self) is used in the assembler to mean "a 32-bit
1178;;; immediate whose offset will be remembered in a table at the end of
1179;;; the function object."
1180;;;
1181;;; Before the function is made executable (or when the GC moves the
1182;;; function), these :self immediates are filled in with the actual
1183;;; address of the function.
1184
1185(defconstant recover-fn-opcode-byte #b10111111) ;when %fn is %edi
1186(defconstant recover-fn-address-offset 1)
1187
1188(provide "X8632-ARCH")
Note: See TracBrowser for help on using the repository browser.