source: trunk/ccl/compiler/arch.lisp @ 189

Last change on this file since 189 was 189, checked in by gb, 17 years ago

Try to be less ppc32-specific.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.3 KB
Line 
1;;;-*- Mode: Lisp; Package: (PPC32 :use CL) -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL 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(defpackage "PPC32"
17  (:nicknames "ARCH32" "ARCH" "PPC")
18  (:use "CL"))
19
20(in-package "PPC32")
21
22
23
24;; PPC-32 stuff and tags.
25(eval-when (:compile-toplevel :load-toplevel :execute)
26
27
28
29
30
31
32
33
34
35; The objects themselves look something like this:
36
37
38
39
40 
41
42
43(defconstant tcr-flag-bit-foreign 0)
44(defconstant tcr-flag-bit-awaiting-preset 1)
45
46
47
48
49
50
51
52
53
54
55)
56
57(defmacro make-vheader (element-count subtag)
58  `(logior ,subtag (ash ,element-count 8)))
59
60(defmacro ppc-fixnum (val)
61  `(ash ,val fixnum-shift))
62
63(defmacro unbox-ppc-fixnum (f)
64  `(ash ,f (- fixnum-shift)))
65
66
67; Kernel globals are allocated "below" nil.  This list (used to map symbolic names to
68; rnil-relative offsets) must (of course) exactly match the kernel's notion of where
69; things are.
70; The order here matches "ccl:pmcl;lisp_globals.h" & the lisp_globals record
71; in "ccl:pmcl;constants.s"
72(defparameter *ppc-kernel-globals*
73  '(get-tcr                             ; callback to obtain (real) tcr
74    tcr-count
75    interrupt-signal                    ; used by PROCESS-INTERRUPT
76    kernel-imports                      ; some things we need to have imported for us.
77    tcr-lock
78    emulator-registers                  ; Where the 68K registers are kept.
79    appmain                             ; application's (c-runtime) main() function
80    subprims-base                       ; start of dynamic subprims jump table
81    ret1valaddr                         ; magic multiple-values return address.
82    tcr-key                             ; tsd key for thread's tcr
83    gc-lock                             ; serialize access to gc
84    exception-lock                      ; serialize exception handling
85    go-tag-counter                      ; counter for (immediate) go tag
86    block-tag-counter                   ; counter for (immediate) block tag
87    intflag                             ; interrupt-pending flag
88    gc-inhibit-count                    ; for gc locking
89    os-trap-call                        ; callostrapunivesalproc's descriptor
90    tb-trap-call                        ; CallUniversalProc's descriptor
91    qd-globals                          ; (untagged) pointer to QD globals.
92    fwdnum                              ; fixnum: GC "forwarder" call count.
93    gc-count                            ; fixnum: GC call count.
94    gcable-pointers                     ; linked-list of weak macptrs.
95    heap-start                          ; start of lisp heap
96    heap-end                            ; end of lisp heap
97    bad-current-cs                      ; current control-stack area
98    bad-current-vs                      ; current value-stack area
99    bad-current-ts                      ; current temp-stack area
100    bad-cs-overflow-limit               ; limit for control-stack overflow check
101    all-areas                           ; doubly-linked area list
102    lexpr-return                        ; multiple-value lexpr return address
103    lexpr-return1v                      ; single-value lexpr return address
104    in-gc                               ; non-zero when GC-ish thing active
105    metering-info                       ; kernel metering structure
106    doh-head                            ; creole
107    short-float-zero                    ; low half of 1.0d0
108    double-float-one                    ; high half of 1.0d0
109    ffi-exception                       ; ffi fpscr[fex] bit
110    exception-saved-registers           ; saved registers from exception frame
111    oldest-ephemeral                    ; doubleword address of oldest ephemeral object or 0
112    tenured-area                        ; the tenured_area.
113    errno                               ; address of C lib errno
114    argv                                ; address of C lib argv
115    host-platform                       ; 0 on MacOS, 1 on PPC Linux, 2 on VxWorks ...
116    batch-flag                          ; non-zero if --batch specified
117    fpscr-save                          ; lisp's fpscr when in FFI-land
118    fpscr-save-high                     ; high word of FP reg used to save FPSCR
119    image-name                          ; current image name
120    initial-tcr                         ; initial thread's context record
121    ))
122
123(defun %kernel-global (sym)
124  (let* ((pos (position sym *ppc-kernel-globals* :test #'string=)))
125    (if pos
126      (- (+ fulltag-nil (* (1+ pos) 4)))
127      (error "Unknown kernel global : ~s ." sym))))
128
129(defmacro kernel-global (sym)
130  (let* ((pos (position sym *ppc-kernel-globals* :test #'string=)))
131    (if pos
132      (- (+ fulltag-nil (* (1+ pos) 4)))
133      (error "Unknown kernel global : ~s ." sym))))
134
135
136; The kernel imports things that are defined in various other libraries for us.
137; The objects in question are generally fixnum-tagged; the entries in the
138; "kernel-imports" vector are 4 bytes apart.
139(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step 4)
140  fd-setsize-bytes
141  do-fd-set
142  do-fd-clr
143  do-fd-is-set
144  do-fd-zero
145  MakeDataExecutable
146  GetSharedLibrary
147  FindSymbol
148  malloc
149  free
150  allocate_tstack
151  allocate_vstack
152  register_cstack
153  condemn-area
154  metering-control
155  restore-soft-stack-limit
156  egc-control
157  lisp-bug
158  NewThread
159  YieldToThread
160  DisposeThread
161  ThreadCurrentStackSpace
162  usage-exit
163  save-fp-context
164  restore-fp-context
165  put-altivec-registers
166  get-altivec-registers
167  new-semaphore
168  wait-on-semaphore
169  signal-semaphore
170  destroy-semaphore
171  new-recursive-lock
172  lock-recursive-lock
173  unlock-recursive-lock
174  destroy-recursive-lock
175  suspend-other-threads
176  resume-other-threads
177  suspend-tcr
178  resume-tcr
179  rwlock-new
180  rwlock-destroy
181  rwlock-rlock
182  rwlock-wlock
183  rwlock-unlock
184  recursive-lock-trylock
185  foreign-name-and-offset
186)
187
188(defmacro define-header (name element-count subtag)
189  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
190
191(define-header single-float-header single-float.element-count subtag-single-float)
192(define-header double-float-header double-float.element-count subtag-double-float)
193(define-header one-digit-bignum-header 1 subtag-bignum)
194(define-header two-digit-bignum-header 2 subtag-bignum)
195(define-header symbol-header symbol.element-count subtag-symbol)
196(define-header value-cell-header value-cell.element-count subtag-value-cell)
197(define-header macptr-header macptr.element-count subtag-macptr)
198
199
200;; Error numbers, as used in UU0s and such.
201;; These match "ccl:pmcl;errors.h" & "ccl:pmcl;errors.s"
202
203(defconstant error-reg-regnum 0)        ; "real" error number is in RB field of UU0.
204                                        ; Currently only used for :errchk in emulated traps
205                                        ; The errchk macro should expand into a check-trap-error vinsn, too.
206(defconstant error-udf 1)               ; Undefined function (reported by symbol-function)
207(defconstant error-udf-call 2)          ; Attempt to call undefined function
208(defconstant error-throw-tag-missing 3)
209(defconstant error-alloc-failed 4)      ; can't allocate (largish) vector
210(defconstant error-stack-overflow 5)    ; some stack overflowed.
211(defconstant error-excised-function-call 6)     ; excised function was called.
212(defconstant error-too-many-values 7)   ; too many values returned
213(defconstant error-cant-take-car 8)
214(defconstant error-cant-take-cdr 9)
215(defconstant error-cant-call 17)        ; Attempt to funcall something that is not a symbol or function.
216(eval-when (:compile-toplevel :load-toplevel :execute)
217  (defconstant error-type-error 64)
218)
219
220(defconstant error-fpu-exception-double 1024)   ; FPU exception, binary double-float op
221(defconstant error-fpu-exception-single 1025)
222
223(defconstant error-memory-full 2048)
224
225;; These are now supposed to match (mod 64) the %type-error-typespecs%
226;; array that %err-disp looks at.
227(ccl::defenum (:start  error-type-error :prefix "ERROR-OBJECT-NOT-")
228  array
229  bignum
230  fixnum
231  character
232  integer
233  list
234  number
235  sequence
236  simple-string
237  simple-vector
238  string
239  symbol
240  macptr
241  real
242  cons
243  unsigned-byte
244  radix
245  float 
246  rational
247  ratio
248  short-float
249  double-float
250  complex
251  vector
252  simple-base-string
253  function
254  unsigned-byte-16
255  unsigned-byte-8
256  unsigned-byte-32
257  signed-byte-32
258  signed-byte-16
259  signed-byte-8
260  base-char
261  bit
262  unsigned-byte-24
263  )
264
265; The order here matches "ccl:pmcl;lisp_globals.h" and the nrs record
266; in "ccl:pmcl;constants.s".
267(defparameter *ppc-nilreg-relative-symbols*
268  '(t
269    nil
270    ccl::%err-disp
271    ccl::cmain
272    eval
273    ccl::apply-evaluated-function
274    error   
275    ccl::%defun
276    ccl::%defvar
277    ccl::%defconstant
278    ccl::%macro
279    ccl::%kernel-restart
280    *package*
281    ccl::*total-bytes-freed*
282    :allow-other-keys   
283    ccl::%toplevel-catch%
284    ccl::%toplevel-function%
285    ccl::%pascal-functions%   
286    ccl::*all-metered-functions*
287    ccl::*total-gc-microseconds*
288    ccl::%builtin-functions%
289    ccl::%unbound-function%
290    ccl::%init-misc
291    ccl::%macro-code%
292    ccl::%closure-code%
293    ccl::%new-gcable-ptr
294    ccl::*gc-event-status-bits*
295    ccl::*post-gc-hook*
296    ccl::%handlers%
297    ccl::%all-packages%
298    ccl::*keyword-package* 
299    ccl::%finalization-alist%
300    ccl::%foreign-thread-control
301    ))
302
303(defmacro nrs-offset (name)
304  (let* ((pos (position name *ppc-nilreg-relative-symbols* :test #'eq)))
305    (if pos (+ t-offset (* pos symbol.size)))))
306
307(defun builtin-function-name-offset (name)
308  (and name (position name ccl::%builtin-functions% :test #'eq)))
309
310(ccl::defenum ()
311  storage-class-lisp                    ; General lisp objects
312  storage-class-imm                     ; Fixnums, chars, NIL: not relocatable
313  storage-class-wordptr                 ; "Raw" (fixnum-tagged) pointers to stack,etc
314  storage-class-u8                      ; Unsigned, untagged, 8-bit objects
315  storage-class-s8                      ; Signed, untagged, 8-bit objects
316  storage-class-u16                     ; Unsigned, untagged, 16-bit objects
317  storage-class-s16                     ; Signed, untagged, 16-bit objects
318  storage-class-u32                     ; Unsigned, untagged, 8-bit objects
319  storage-class-s32                     ; Signed, untagged, 8-bit objects
320  storage-class-address                 ; "raw" (untagged) 32-bit addresses.
321  storage-class-single-float            ; 32-bit single-float objects
322  storage-class-double-float            ; 64-bit double-float objects
323  storage-class-pc                      ; pointer to/into code vector
324  storage-class-locative                ; pointer to/into node-misc object
325  storage-class-crf                     ; condition register field
326  storage-class-crbit                   ; condition register bit: 0-31
327  storage-class-crfbit                  ; bit within condition register field : 0-3
328)
329
330;; For assembly/disassembly, at least on RISC platforms.
331(defstruct opcode 
332  (name (error "Opcode name must be present") :type (or string symbol))
333  (opcode 0 :type (unsigned-byte 32))
334  (majorop 0 :type (unsigned-byte 6))
335  (mask #xffffffff :type (unsigned-byte 32))
336  (flags 0 :type (unsigned-byte 32))
337  (operands () :type list)
338  (min-args 0 :type (unsigned-byte 3))
339  (max-args 0 :type (unsigned-byte 3))
340  (op-high 0 :type (unsigned-byte 16))
341  (op-low 0 :type (unsigned-byte 16))
342  (mask-high #xffff :type (unsigned-byte 16))
343  (mask-low #xffff :type (unsigned-byte 16))
344  (vinsn-operands () :type list)
345  (min-vinsn-args 0 :type fixnum)
346  (max-vinsn-args 0 :type fixnum))
347
348(defmethod print-object ((p opcode) stream)
349  (declare (ignore depth))
350  (print-unreadable-object (p stream :type t) 
351    (format stream "~a" (string (opcode-name p)))))
352
353(defmethod make-load-form ((p opcode) &optional env)
354  (make-load-form-saving-slots p :environment env))
355
356(defstruct operand
357  (index 0 :type unsigned-byte)
358  (width 0 :type (mod 32))
359  (offset 0 :type (mod 32))
360  (insert-function nil :type (or null symbol function))
361  (extract-function 'nil :type (or symbol function))
362  (flags 0 :type fixnum))
363
364(defmethod make-load-form ((o operand) &optional env)
365  (make-load-form-saving-slots o :environment env))
366
367(defconstant operand-optional 27)
368(defconstant operand-fake 28)
369
370(defconstant reservation-discharge #x1004)
371
372(ccl::provide "ARCH")
Note: See TracBrowser for help on using the repository browser.