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

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

On x8632, we're using the PPC32-style DEFINE-FIXEDSIZE-OBJECT macro,
which doesn't take an &optional fulltag argument (as the x8664 one
does). Therefore, the () was causing the definition of constants
CATCH-FRAME.NIL and CATCH-FRAME.NIL-CELL, throwing off all the others
by 1.

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