source: trunk/source/compiler/X86/X8632/x8632-arch.lisp @ 15191

Last change on this file since 15191 was 15191, checked in by gb, 7 years ago

Use a cast in the code that sets up errno_loc in the TCR.
Revive jvm_init(), since Apple's JVM still/again clobbers Mach exception
ports.

Add kernel-import info for jvm-init for all architectures. (The kernel
import table isn't architecture-specific, though some entries effectively
are.)

Tweak jni.lisp a bit; still needs lots of work.

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