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

Last change on this file since 7075 was 7075, checked in by rme, 14 years ago

The new byte registers (sil, dil, spl, bpl) aren't on plain IA-32.

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