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

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

WITH-SHORT-STACK-FLOATS macro

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