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

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

Try to get unconfused about things tagged with fulltag-imm.

File size: 41.7 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
298;;; immediate subtags
299(define-subtag unbound fulltag-imm 6)
300(defconstant unbound-marker subtag-unbound)
301(defconstant undefined unbound-marker)
302(define-subtag character fulltag-imm 9)
303(define-subtag slot-unbound fulltag-imm 10)
304(defconstant slot-unbound-marker subtag-slot-unbound)
305(define-subtag illegal fulltag-imm 11)
306(defconstant illegal-marker subtag-illegal)
307(define-subtag reserved-frame fulltag-imm 29)
308(defconstant reserved-frame-marker subtag-reserved-frame)
309(define-subtag no-thread-local-binding fulltag-imm 30)
310
311;;; This has two functions: it tells the link-inverting marker where
312;;; the code ends and the self-reference table and constants start, and it
313;;; ensures that the 0th constant will never be in the same memozized
314;;; dnode as some (unboxed) word of machine code.  I'm not sure if
315;;; there's a better way to do either of those things.
316;;;
317;;; Depending on how you look at it, we either lose 8 bytes per
318;;; function, or gain 7 bytes of otherwise unused space for debugging
319;;; info.
320;;; xxx -- comments above not right for x8632
321(define-subtag function-boundary-marker fulltag-imm 31)
322(defconstant function-boundary-marker subtag-function-boundary-marker)
323(defconstant max-non-array-imm-subtag (logior (ash 19 ntagbits) fulltag-immheader))
324
325(define-node-subtag catch-frame 4)
326(defconstant min-non-numeric-node-subtag subtag-catch-frame)
327(assert (> min-non-numeric-node-subtag max-numeric-subtag))
328(define-node-subtag function 5)
329(define-node-subtag basic-stream 6)
330(define-node-subtag symbol 7)
331(define-node-subtag lock 8)
332(define-node-subtag hash-vector 9)
333(define-node-subtag pool 10)
334(define-node-subtag weak 11)
335(define-node-subtag package 12)
336(define-node-subtag slot-vector 13)
337(define-node-subtag instance 14)
338(define-node-subtag struct 15)
339(define-node-subtag istruct 16)
340(define-node-subtag value-cell 17)
341(define-node-subtag xfunction 18)       ; Function for cross-development
342
343(defconstant max-non-array-node-subtag (logior (ash 18 ntagbits) fulltag-nodeheader))
344
345(defconstant misc-header-offset (- fulltag-misc))
346(defconstant misc-subtag-offset misc-header-offset)
347(defconstant misc-data-offset (+ misc-header-offset node-size))
348(defconstant misc-dfloat-offset ( + misc-header-offset 8))
349
350(defconstant max-64-bit-constant-index (ash (+ #x7fff x8632::misc-dfloat-offset) -3))
351(defconstant max-32-bit-constant-index (ash (+ #x7fff x8632::misc-data-offset) -2))
352(defconstant max-16-bit-constant-index (ash (+ #x7fff x8632::misc-data-offset) -1))
353(defconstant max-8-bit-constant-index (+ #x7fff x8632::misc-data-offset))
354(defconstant max-1-bit-constant-index (ash (+ #x7fff x8632::misc-data-offset) 5))
355
356)  ;eval-when
357
358;;; On IA-32, the tag which was used for nil on ppc32 is now used for
359;;; tagged return addresses.  We therefore make nil a distinguished
360;;; CONS.  This way, CAR and CDR can just check the tag, and
361;;; CONSP/RPLACA/RPLACD can check the tag and complain if the argument
362;;; is NIL.
363(defconstant nil-value (+ #x3000 fulltag-cons))
364(defconstant t-value (+ #x3008 fulltag-misc))
365(defconstant t-offset (- t-value nil-value))
366
367(defconstant misc-bias fulltag-misc)
368(defconstant cons-bias fulltag-cons)
369
370
371(defmacro define-storage-layout (name origin &rest cells)
372  `(progn
373     (ccl::defenum (:start ,origin :step 4)
374         ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells))
375     (defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells) 4))))
376
377(defmacro define-lisp-object (name tagname &rest cells)
378  `(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells))
379
380(defmacro define-fixedsized-object (name &rest non-header-cells)
381  `(progn
382     (define-lisp-object ,name fulltag-misc header ,@non-header-cells)
383     (ccl::defenum ()
384         ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells))
385     (defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells))))
386
387(define-lisp-object cons tag-list 
388  cdr 
389  car)
390
391(define-fixedsized-object ratio
392  numer
393  denom)
394
395(define-fixedsized-object single-float
396  value)
397
398(define-fixedsized-object double-float
399  pad
400  value
401  val-high)
402
403(define-fixedsized-object complex
404  realpart
405  imagpart)
406
407;;; There are two kinds of macptr; use the length field of the header if you
408;;; need to distinguish between them
409(define-fixedsized-object macptr
410  address
411  domain
412  type
413)
414
415(define-fixedsized-object xmacptr
416  address
417  domain
418  type
419  flags
420  link
421)
422
423;;; Need to think about catch frames on x8632, too.
424(define-fixedsized-object catch-frame ()
425  catch-tag                             ; #<unbound> -> unwind-protect, else catch
426  link                                  ; tagged pointer to next older catch frame
427  mvflag                                ; 0 if single-value, 1 if uwp or multiple-value
428  esp                                   ;
429  ebp
430  foreign-sp
431  db-link                               ; value of dynamic-binding link on thread entry.
432  save-save3                            ; saved nvrs (probably won't have any)
433  save-save2
434  save-save1
435  save-save0
436  xframe                                ; exception-frame link
437  pc                                    ; tra of catch exit/unwind cleanup
438)
439
440(define-fixedsized-object lock
441  _value                                ;finalizable pointer to kernel object
442  kind                                  ; '0 = recursive-lock, '1 = rwlock
443  writer                                ;tcr of owning thread or 0
444  name
445  )
446
447
448
449(define-fixedsized-object symbol
450  pname
451  vcell
452  fcell
453  package-predicate
454  flags
455  plist
456  binding-index
457)
458
459(defconstant nilsym-offset (+ t-offset symbol.size))
460
461(define-fixedsized-object vectorH
462  logsize                               ; fillpointer if it has one, physsize otherwise
463  physsize                              ; total size of (possibly displaced) data vector
464  data-vector                           ; object this header describes
465  displacement                          ; true displacement or 0
466  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
467)
468
469(define-lisp-object arrayH fulltag-misc
470  header                                ; subtag = subtag-arrayH
471  rank                                  ; NEVER 1
472  physsize                              ; total size of (possibly displaced) data vector
473  data-vector                           ; object this header describes
474  displacement                          ; true displacement or 0 
475  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
476 ;; Dimensions follow
477)
478
479(defconstant arrayH.rank-cell 0)
480(defconstant arrayH.physsize-cell 1)
481(defconstant arrayH.data-vector-cell 2)
482(defconstant arrayH.displacement-cell 3)
483(defconstant arrayH.flags-cell 4)
484(defconstant arrayH.dim0-cell 5)
485
486(defconstant arrayH.flags-cell-bits-byte (byte 8 0))
487(defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
488
489
490(define-fixedsized-object value-cell
491  value)
492
493(define-storage-layout lisp-frame 0
494  backptr
495  return-address
496  xtra)
497
498(define-storage-layout xcf 0            ;"exception callback frame"
499  backptr
500  return-address                        ; always 0
501  nominal-function
502  relative-pc
503  containing-object
504  xp
505  ra0
506  )
507
508;;; The kernel uses these (rather generically named) structures
509;;; to keep track of various memory regions it (or the lisp) is
510;;; interested in.
511
512(define-storage-layout area 0
513  pred                                  ; pointer to preceding area in DLL
514  succ                                  ; pointer to next area in DLL
515  low                                   ; low bound on area addresses
516  high                                  ; high bound on area addresses.
517  active                                ; low limit on stacks, high limit on heaps
518  softlimit                             ; overflow bound
519  hardlimit                             ; another one
520  code                                  ; an area-code; see below
521  markbits                              ; bit vector for GC
522  ndnodes                               ; "active" size of dynamic area or stack
523  older                                 ; in EGC sense
524  younger                               ; also for EGC
525  h                                     ; Handle or null pointer
526  softprot                              ; protected_area structure pointer
527  hardprot                              ; another one.
528  owner                                 ; fragment (library) which "owns" the area
529  refbits                               ; bitvector for intergenerational refernces
530  threshold                             ; for egc
531  gc-count                              ; generational gc count.
532  static-dnodes                         ; for honsing, etc.
533  static-used                           ; bitvector
534)
535
536(define-storage-layout protected-area 0
537  next
538  start                                 ; first byte (page-aligned) that might be protected
539  end                                   ; last byte (page-aligned) that could be protected
540  nprot                                 ; Might be 0
541  protsize                              ; number of bytes to protect
542  why)
543
544(eval-when (:compile-toplevel :load-toplevel :execute)
545  (defconstant tcr-bias 0))
546
547(define-storage-layout tcr (- tcr-bias)
548  next                                  ; in doubly-linked list
549  prev                                  ; in doubly-linked list
550  node-regs-mask                        ; bit set means corresponding reg contains node
551  linear
552  ;; save0 *must* be aligned on a 16-byte boundary!
553  save0                                 ;spill area for node registers
554  save1                                 ; (caller saved)
555  save2                                 ; probably saved/restored in
556  save3                                 ; callout/trap handlers
557  save-ebp                              ; lisp frame ptr for foreign code
558  lisp-mxcsr
559  foreign-mxcsr
560  db-link                               ; special binding chain head
561  catch-top                             ; top catch frame
562  save-vsp                              ; SP when in foreign code
563  save-tsp                              ; TSP, at all times
564  foreign-sp                            ; SP when in lisp code
565  cs-area                               ; cstack area pointer
566  vs-area                               ; vstack area pointer
567  ts-area                               ; tstack area pointer
568  cs-limit                              ; cstack overflow limit
569  total-bytes-allocated-low
570  total-bytes-allocated-high
571  log2-allocation-quantum               ; unboxed
572  interrupt-pending                     ; fixnum
573  xframe                                ; exception frame linked list
574  errno-loc                             ; thread-private, maybe
575  ffi-exception                         ; fpscr bits from ff-call.
576  osid                                  ; OS thread id
577  valence                               ; odd when in foreign code
578  foreign-exception-status
579  native-thread-info
580  native-thread-id
581  last-allocptr
582  save-allocptr
583  save-allocbase
584  reset-completion
585  activate
586  suspend-count
587  suspend-context
588  pending-exception-context
589  suspend                               ; semaphore for suspension notify
590  resume                                ; sempahore for resumption notify
591  flags                                 ; foreign, being reset, ...
592  gc-context
593  termination-semaphore
594  unwinding
595  tlb-limit
596  tlb-pointer
597  shutdown-count
598  next-tsp
599  safe-ref-address
600  ldt-index
601  ldt-selector
602  scratch-mxcsr                         ;used for reading/writing mxcsr
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.