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

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

Define allocptr.

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