source: branches/arm/compiler/ARM/arm-arch.lisp @ 13741

Last change on this file since 13741 was 13741, checked in by gb, 11 years ago

Keep moving forward. Can -almost- compile simple functions.

File size: 48.9 KB
Line 
1;;;-*- Mode: Lisp; Package: (ARM :use CL) -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   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(defpackage "ARM"
18  (:use "CL"))
19
20(require "ARCH")
21
22(in-package "ARM")
23
24
25;;; Lisp registers.
26
27
28(defvar *arm-register-names* ())
29
30
31(defun get-arm-register (name)
32  (let* ((pair (assoc (string name) *arm-register-names* :test #'string-equal)))
33    (if pair
34      (cdr pair))))
35
36(defun get-arm-gpr (name)
37  (let* ((value (get-arm-register name)))
38    (and value (< value 16) value)))
39
40(defun get-arm-sfpr (name)
41  (let* ((value (get-arm-register name)))
42    (and value (logbitp 5 value) (logand #x1f value))))
43
44(defun get-arm-dfpr (name)
45  (let* ((value (get-arm-register name)))
46    (and value (logbitp 6 value) (logand #x0f value))))
47 
48
49;;; This allows redefinition, which might be helpful while
50;;; boostrapping.  ARM-LAP-EQUATE-FORM checks for redefinition
51;;; before calling this.
52(defun define-arm-register (name val)
53  (let* ((value (if (typep val 'fixnum) val (get-arm-gpr val)))
54         (string (string name)))
55    (unless value
56      (error "invalid ARM register value ~d for ~s." val name))
57    (let* ((pair (assoc string *arm-register-names* :test #'string-equal)))
58      (if pair
59        (progn
60          (unless (eql (cdr pair) value)
61            (when ccl::*cerror-on-constant-redefinition*
62              (cerror "Redefine ARM register ~s to have value ~*~d."
63                      "ARM register ~s currently has value ~d."
64                      name (cdr pair) value)
65              (setf (cdr pair) value))))
66        (push (cons string value) *arm-register-names*))
67        value)))
68
69(defmacro defarmgpr (name val)
70  `(defconstant ,name (define-arm-register ',name ',val)))
71
72(defarmgpr r0 0)
73(defarmgpr r1 1)
74(defarmgpr r2 2)
75(defarmgpr r3 3)
76(defarmgpr r4 4)
77(defarmgpr r5 5)
78(defarmgpr r6 6)
79(defarmgpr r7 7)
80(defarmgpr r8 8)
81(defarmgpr r9 9)
82(defarmgpr r10 10)
83(defarmgpr r11 11)
84(defarmgpr r12 12)
85(defarmgpr r13 13)
86(defarmgpr r14 14)
87(defarmgpr r15 15)
88
89(defarmgpr imm0 r0)
90(defarmgpr imm1 r1)
91(defarmgpr imm2 r2)
92(defarmgpr rcontext r3)
93(defarmgpr arg_z r4)
94(defarmgpr arg_y r5)
95(defarmgpr arg_x r6)
96(defarmgpr temp0 r7)
97(defarmgpr temp1 r8)
98(defarmgpr temp2 r9)
99(defarmgpr vsp r10)
100(defarmgpr fn r11)
101(defarmgpr allocptr r12)
102(defarmgpr sp r13)
103(defarmgpr lr r14)
104(defarmgpr pc r15)
105
106
107
108;;; Calling sequence may pass additional arguments in temp registers.
109;;; "nfn" (new function) is always passed; it's the new value of "fn".
110(defarmgpr nfn temp2)
111;;; CLOS may pass the context for, e.g.., CALL-NEXT-METHOD in
112;;;; the "next-method-context" register.
113(defarmgpr next-method-context temp1)
114
115(defarmgpr fname temp1)
116
117(defarmgpr nargs imm2)
118
119(defmacro defarmsfpr (name val)
120  `(defconstant ,name (define-arm-register ',name ',val)))
121
122(defarmsfpr s0 32)
123(defarmsfpr s1 33)
124(defarmsfpr s2 34)
125(defarmsfpr s3 35)
126(defarmsfpr s4 36)
127(defarmsfpr s5 37)
128(defarmsfpr s6 38)
129(defarmsfpr s7 39)
130(defarmsfpr s8 40)
131(defarmsfpr s9 41)
132(defarmsfpr s10 42)
133(defarmsfpr s11 43)
134(defarmsfpr s12 44)
135(defarmsfpr s13 45)
136(defarmsfpr s14 46)
137(defarmsfpr s15 47)
138(defarmsfpr s16 48)
139(defarmsfpr s17 49)
140(defarmsfpr s18 50)
141(defarmsfpr s19 51)
142(defarmsfpr s20 52)
143(defarmsfpr s21 53)
144(defarmsfpr s22 54)
145(defarmsfpr s23 55)
146(defarmsfpr s24 56)
147(defarmsfpr s25 57)
148(defarmsfpr s26 58)
149(defarmsfpr s27 59)
150(defarmsfpr s28 60)
151(defarmsfpr s29 61)
152(defarmsfpr s30 62)
153(defarmsfpr s31 63)
154
155;;; The first 16 double-float registers overlap pairs of single-float
156;;; registers (d0 overlaps s0-s1, d15 overlaps s30-s31, etc.)
157
158(defmacro defarmdfpr (name val)
159  `(defconstant ,name (define-arm-register ',name ',val)))
160
161(defarmdfpr d0 64)
162(defarmdfpr d1 65)
163(defarmdfpr d2 66)
164(defarmdfpr d3 67)
165(defarmdfpr d4 68)
166(defarmdfpr d5 69)
167(defarmdfpr d6 70)
168(defarmdfpr d7 71)
169(defarmdfpr d8 72)
170(defarmdfpr d9 73)
171(defarmdfpr d10 74)
172(defarmdfpr d11 75)
173(defarmdfpr d12 76)
174(defarmdfpr d13 77)
175(defarmdfpr d14 78)
176(defarmdfpr d15 79)
177
178
179
180(defparameter *standard-arm-register-names* *arm-register-names*)
181
182
183;;; Kernel globals are allocated "below" nil.  This list (used to map
184;;; symbolic names to rnil-relative offsets) must (of course) exactly
185;;; match the kernel's notion of where things are.
186;;; The order here matches "ccl:lisp-kernel;lisp_globals.h" & the
187;;; lisp_globals record in "ccl:lisp-kernel;*constants*.s"
188(defparameter *arm-kernel-globals*
189  '(get-tcr                             ; callback to obtain (real) tcr
190    tcr-count
191    interrupt-signal                    ; used by PROCESS-INTERRUPT
192    kernel-imports                      ; some things we need to have imported for us.
193    objc-2-personality
194    savetoc                  ; used to save TOC on some platforms
195    saver13                             ; used to save r13 on some platforms
196    subprims-base                       ; start of dynamic subprims jump table
197    ret1valaddr                         ; magic multiple-values return address.
198    tcr-key                             ; tsd key for thread's tcr
199    area-lock                           ; serialize access to gc
200    exception-lock                      ; serialize exception handling
201    static-conses                       ; when FREEZE is in effect
202    default-allocation-quantum          ; log2_heap_segment_size, as a fixnum.
203    intflag                             ; interrupt-pending flag
204    gc-inhibit-count                    ; for gc locking
205    refbits                             ; oldspace refbits
206    oldspace-dnode-count                ; number of dnodes in dynamic space that are older than
207                                        ; youngest generation
208    altivec-present                     ; non-zero if cpu supports AltiVec
209    fwdnum                              ; fixnum: GC "forwarder" call count.
210    gc-count                            ; fixnum: GC call count.
211    gcable-pointers                     ; linked-list of weak macptrs.
212    heap-start                          ; start of lisp heap
213    heap-end                            ; end of lisp heap
214    statically-linked                   ; true if the lisp kernel is statically linked
215    stack-size                          ; value of --stack-size arg
216    objc-2-begin-catch                  ; objc_begin_catch
217    kernel-path
218    all-areas                           ; doubly-linked area list
219    lexpr-return                        ; multiple-value lexpr return address
220    lexpr-return1v                      ; single-value lexpr return address
221    in-gc                               ; non-zero when GC-ish thing active
222    free-static-conses                  ; fixnum
223    objc-2-end-catch                    ; _objc_end_catch
224    short-float-zero                    ; low half of 1.0d0
225    double-float-one                    ; high half of 1.0d0
226    static-cons-area                    ;
227    exception-saved-registers           ; saved registers from exception frame
228    oldest-ephemeral                    ; doublenode address of oldest ephemeral object or 0
229    tenured-area                        ; the tenured_area.
230    errno                               ; address of C lib errno
231    argv                                ; address of C lib argv
232    host-platform                       ; 0 on MacOS, 1 on ARM Linux, 2 on VxWorks ...
233    batch-flag                          ; non-zero if --batch specified
234    unwind-resume                       ; _Unwind_Resume
235    weak-gc-method                      ; weak gc algorithm.
236    image-name                          ; current image name
237    initial-tcr                         ; initial thread's context record
238    weakvll                             ; all populations as of last GC
239    ))
240
241;;; The order here matches "ccl:lisp-kernel;lisp_globals.h" and the nrs record
242;;; in "ccl:lisp-kernel;constants.s".
243(defparameter *arm-nil-relative-symbols*
244  '(t
245    nil
246    ccl::%err-disp
247    ccl::cmain
248    eval
249    ccl::apply-evaluated-function
250    error   
251    ccl::%defun
252    ccl::%defvar
253    ccl::%defconstant
254    ccl::%macro
255    ccl::%kernel-restart
256    *package*
257    ccl::*total-bytes-freed*
258    :allow-other-keys   
259    ccl::%toplevel-catch%
260    ccl::%toplevel-function%
261    ccl::%pascal-functions%   
262    ccl::*all-metered-functions*
263    ccl::*total-gc-microseconds*
264    ccl::%builtin-functions%
265    ccl::%unbound-function%
266    ccl::%init-misc
267    ccl::%macro-code%
268    ccl::%closure-code%
269    ccl::%new-gcable-ptr
270    ccl::*gc-event-status-bits*
271    ccl::*post-gc-hook*
272    ccl::%handlers%
273    ccl::%all-packages%
274    ccl::*keyword-package* 
275    ccl::%finalization-alist%
276    ccl::%foreign-thread-control
277    ))
278
279;;; Old (and slightly confusing) name; NIL used to be in a register.
280(defparameter *arm-nilreg-relative-symbols* *arm-nil-relative-symbols*)
281
282
283
284
285
286(eval-when (:compile-toplevel :load-toplevel :execute)
287(defparameter *arm-subprims-shift* 8)
288(defparameter *arm-subprims-base* (ash 9 12) )
289)
290(defvar *arm-subprims*)
291
292;;; For now, nothing's nailed down and we don't say anything about
293;;; registers clobbered.
294(let* ((origin *arm-subprims-base*)
295       (step (ash 1 *arm-subprims-shift*)))
296  (flet ((define-arm-subprim (name)
297             (ccl::make-subprimitive-info :name (string name)
298                                          :offset (prog1 origin
299                                                    (when (= origin #x10000)
300                                                      (setq step (ash 1 10)))
301                                                    (incf origin step)))))
302    (macrolet ((defarmsubprim (name)
303                   `(define-arm-subprim ',name)))
304      (setq *arm-subprims*
305        (vector
306         (defarmsubprim .SPjmpsym)
307         (defarmsubprim .SPjmpnfn)
308         (defarmsubprim .SPfuncall)
309         (defarmsubprim .SPmkcatch1v)
310         (defarmsubprim .SPmkunwind)
311         (defarmsubprim .SPmkcatchmv)
312         (defarmsubprim .SPthrow)
313         (defarmsubprim .SPnthrowvalues)
314         (defarmsubprim .SPnthrow1value)
315         (defarmsubprim .SPbind)
316         (defarmsubprim .SPbind-self)
317         (defarmsubprim .SPbind-nil)
318         (defarmsubprim .SPbind-self-boundp-check)
319         (defarmsubprim .SPrplaca)
320         (defarmsubprim .SPrplacd)
321         (defarmsubprim .SPconslist)
322         (defarmsubprim .SPconslist-star)
323         (defarmsubprim .SPstkconslist)
324         (defarmsubprim .SPstkconslist-star)
325         (defarmsubprim .SPmkstackv)
326         (defarmsubprim .SPsubtag-misc-ref)
327         (defarmsubprim .SPsetqsym)
328         (defarmsubprim .SPprogvsave)
329         (defarmsubprim .SPstack-misc-alloc)
330         (defarmsubprim .SPgvector)
331         (defarmsubprim .SPnvalret)
332         (defarmsubprim .SPmvpass)
333         (defarmsubprim .SPfitvals)
334         (defarmsubprim .SPnthvalue)
335         (defarmsubprim .SPvalues)
336         (defarmsubprim .SPdefault-optional-args)
337         (defarmsubprim .SPopt-supplied-p)
338         (defarmsubprim .SPheap-rest-arg)
339         (defarmsubprim .SPreq-heap-rest-arg)
340         (defarmsubprim .SPheap-cons-rest-arg)
341         (defarmsubprim .SPsimple-keywords)
342         (defarmsubprim .SPkeyword-args)
343         (defarmsubprim .SPkeyword-bind)
344         (defarmsubprim .SPpoweropen-ffcall)
345         (defarmsubprim .SParef2)
346         (defarmsubprim .SPksignalerr)
347         (defarmsubprim .SPstack-rest-arg)
348         (defarmsubprim .SPreq-stack-rest-arg)
349         (defarmsubprim .SPstack-cons-rest-arg)
350         (defarmsubprim .SPpoweropen-callbackX)
351         (defarmsubprim .SPcall-closure)
352         (defarmsubprim .SPgetXlong)
353         (defarmsubprim .SPspreadargz)
354         (defarmsubprim .SPtfuncallgen)
355         (defarmsubprim .SPtfuncallslide)
356         (defarmsubprim .SPtfuncallvsp)
357         (defarmsubprim .SPtcallsymgen)
358         (defarmsubprim .SPtcallsymslide)
359         (defarmsubprim .SPtcallsymvsp)
360         (defarmsubprim .SPtcallnfngen)
361         (defarmsubprim .SPtcallnfnslide)
362         (defarmsubprim .SPtcallnfnvsp)
363         (defarmsubprim .SPmisc-ref)
364         (defarmsubprim .SPmisc-set)
365         (defarmsubprim .SPstkconsyz)
366         (defarmsubprim .SPstkvcell0)
367         (defarmsubprim .SPstkvcellvsp)
368         (defarmsubprim .SPmakestackblock)
369         (defarmsubprim .SPmakestackblock0)
370         (defarmsubprim .SPmakestacklist)
371         (defarmsubprim .SPstkgvector)
372         (defarmsubprim .SPmisc-alloc)
373         (defarmsubprim .SPpoweropen-ffcallX)
374         (defarmsubprim .SPgvset)
375         (defarmsubprim .SPmacro-bind)
376         (defarmsubprim .SPdestructuring-bind)
377         (defarmsubprim .SPdestructuring-bind-inner)
378         (defarmsubprim .SPrecover-values)
379         (defarmsubprim .SPvpopargregs)
380         (defarmsubprim .SPinteger-sign)
381         (defarmsubprim .SPsubtag-misc-set)
382         (defarmsubprim .SPspread-lexpr-z)
383         (defarmsubprim .SPstore-node-conditional)
384         (defarmsubprim .SPreset)
385         (defarmsubprim .SPmvslide)
386         (defarmsubprim .SPsave-values)
387         (defarmsubprim .SPadd-values)
388         (defarmsubprim .SPpoweropen-callback)
389         (defarmsubprim .SPmisc-alloc-init)
390         (defarmsubprim .SPstack-misc-alloc-init)
391         (defarmsubprim .SPset-hash-key)
392         (defarmsubprim .SPaset2)
393         (defarmsubprim .SPcallbuiltin)
394         (defarmsubprim .SPcallbuiltin0)
395         (defarmsubprim .SPcallbuiltin1)
396         (defarmsubprim .SPcallbuiltin2)
397         (defarmsubprim .SPcallbuiltin3)
398         (defarmsubprim .SPpopj)
399         (defarmsubprim .SPrestorefullcontext)
400         (defarmsubprim .SPsavecontextvsp)
401         (defarmsubprim .SPsavecontext0)
402         (defarmsubprim .SPrestorecontext)
403         (defarmsubprim .SPlexpr-entry)
404         (defarmsubprim .SPpoweropen-syscall)
405         (defarmsubprim .SPbuiltin-plus)
406         (defarmsubprim .SPbuiltin-minus)
407         (defarmsubprim .SPbuiltin-times)
408         (defarmsubprim .SPbuiltin-div)
409         (defarmsubprim .SPbuiltin-eq)
410         (defarmsubprim .SPbuiltin-ne)
411         (defarmsubprim .SPbuiltin-gt)
412         (defarmsubprim .SPbuiltin-ge)
413         (defarmsubprim .SPbuiltin-lt)
414         (defarmsubprim .SPbuiltin-le)
415         (defarmsubprim .SPbuiltin-eql)
416         (defarmsubprim .SPbuiltin-length)
417         (defarmsubprim .SPbuiltin-seqtype)
418         (defarmsubprim .SPbuiltin-assq)
419         (defarmsubprim .SPbuiltin-memq)
420         (defarmsubprim .SPbuiltin-logbitp)
421         (defarmsubprim .SPbuiltin-logior)
422         (defarmsubprim .SPbuiltin-logand)
423         (defarmsubprim .SPbuiltin-ash)
424         (defarmsubprim .SPbuiltin-negate)
425         (defarmsubprim .SPbuiltin-logxor)
426         (defarmsubprim .SPbuiltin-aref1)
427         (defarmsubprim .SPbuiltin-aset1)
428         (defarmsubprim .SPbreakpoint)
429         (defarmsubprim .SPeabi-ff-call)
430         (defarmsubprim .SPeabi-callback)
431         (defarmsubprim .SPeabi-syscall)
432         (defarmsubprim .SPgetu64)
433         (defarmsubprim .SPgets64)
434         (defarmsubprim .SPmakeu64)
435         (defarmsubprim .SPmakes64)
436         (defarmsubprim .SPspecref)
437         (defarmsubprim .SPspecset)
438         (defarmsubprim .SPspecrefcheck)
439         (defarmsubprim .SPrestoreintlevel)
440         (defarmsubprim .SPmakes32)
441         (defarmsubprim .SPmakeu32)
442         (defarmsubprim .SPgets32)
443         (defarmsubprim .SPgetu32)
444         (defarmsubprim .SPfix-overflow)
445         (defarmsubprim .SPmvpasssym)
446         (defarmsubprim .SParef3)
447         (defarmsubprim .SPaset3)
448         (defarmsubprim .SPpoweropen-ffcall-return-registers)
449         (defarmsubprim .SPnmkunwind)
450         (defarmsubprim .SPset-hash-key-conditional)
451         (defarmsubprim .SPunbind-interrupt-level)
452         (defarmsubprim .SPunbind)
453         (defarmsubprim .SPunbind-n)
454         (defarmsubprim .SPunbind-to)
455         (defarmsubprim .SPbind-interrupt-level-m1)
456         (defarmsubprim .SPbind-interrupt-level)
457         (defarmsubprim .SPbind-interrupt-level-0)
458         (defarmsubprim .SPprogvrestore)
459         )))))
460
461
462 
463(defmacro define-storage-layout (name origin &rest cells)
464  `(progn
465     (ccl::defenum (:start ,origin :step 4)
466       ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells))
467     (defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells) 4))))
468 
469(defmacro define-lisp-object (name tagname &rest cells)
470  `(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells))
471
472(defmacro define-subtag (name tag subtag)
473  `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,subtag ntagbits))))
474
475
476(defmacro define-imm-subtag (name subtag)
477  `(define-subtag ,name fulltag-immheader ,subtag))
478
479(defmacro define-node-subtag (name subtag)
480  `(define-subtag ,name fulltag-nodeheader ,subtag))
481
482(defmacro define-fixedsized-object (name &rest non-header-cells)
483  `(progn
484     (define-lisp-object ,name fulltag-misc header ,@non-header-cells)
485     (ccl::defenum ()
486       ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells))
487     (defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells))))
488
489 
490
491
492(eval-when (:compile-toplevel :load-toplevel :execute)
493(defconstant nbits-in-word 32)
494(defconstant least-significant-bit 31)
495(defconstant nbits-in-byte 8)
496(defconstant ntagbits 3)                ; But non-header objects only use 2
497(defconstant nlisptagbits 2)
498(defconstant nfixnumtagbits 2)          ; See ?
499(defconstant num-subtag-bits 8)         ; tag part of header is 8 bits wide
500(defconstant fixnumshift nfixnumtagbits)
501(defconstant fixnum-shift fixnumshift)          ; A pet name for it.
502(defconstant fulltagmask (1- (ash 1 ntagbits)))         ; Only needed by GC/very low-level code
503(defconstant full-tag-mask fulltagmask)
504(defconstant tagmask (1- (ash 1 nlisptagbits)))
505(defconstant tag-mask tagmask)
506(defconstant fixnummask (1- (ash 1 nfixnumtagbits)))
507(defconstant fixnum-mask fixnummask)
508(defconstant subtag-mask (1- (ash 1 num-subtag-bits)))
509(defconstant ncharcodebits 24)          ; only the low 8 bits are used, currently
510(defconstant charcode-shift (- nbits-in-word ncharcodebits))
511(defconstant word-shift 2)
512(defconstant word-size-in-bytes 4)
513(defconstant node-size 4)
514(defconstant dnode-size 8)
515(defconstant dnode-align-bits 3)
516(defconstant dnode-shift dnode-align-bits)
517(defconstant bitmap-shift 5)
518
519(defconstant target-most-negative-fixnum (ash -1 (1- (- nbits-in-word nfixnumtagbits))))
520(defconstant target-most-positive-fixnum (1- (ash 1 (1- (- nbits-in-word nfixnumtagbits)))))
521(defconstant fixnumone (ash 1 fixnumshift))
522
523
524
525;; Tags.
526;; There are two-bit tags and three-bit tags.
527;; A FULLTAG is the value of the low three bits of a tagged object.
528;; A TAG is the value of the low two bits of a tagged object.
529;; A TYPECODE is either a TAG or the value of a "tag-misc" object's header-byte.
530
531;; There are 4 primary TAG values.  Any object which lisp can "see"
532;; can be classified by its TAG.  (Some headers have FULLTAGS that are
533;; congruent modulo 4 with the TAGS of other objects, but lisp can't
534;; "see" headers.)
535(ccl::defenum ()
536  tag-fixnum                            ; All fixnums, whether odd or even
537  tag-list                              ; Conses and NIL
538  tag-misc                              ; Heap-consed objects other than lists: vectors, symbols, functions, floats ...
539  tag-imm                               ; Immediate-objects: characters, UNBOUND, other markers.
540)
541
542;;; And there are 8 FULLTAG values.  Note that NIL has its own FULLTAG
543;;; (congruent mod 4 to tag-list) and that both FULLTAG-MISC and
544;;; FULLTAG-IMM have header fulltags that share the same TAG.  Things
545;;; that walk memory (and the stack) have to be careful to look at the
546;;; FULLTAG of each object that they see.
547(ccl::defenum ()
548  fulltag-even-fixnum                   ; I suppose EVENP/ODDP might care; nothing else does.
549  fulltag-cons                          ; a real (non-null) cons.  Shares TAG with fulltag-nil.
550  fulltag-nodeheader                    ; Header of heap-allocated object that contains lisp-object pointers
551  fulltag-imm                           ; a "real" immediate object.  Shares TAG with fulltag-immheader.
552  fulltag-odd-fixnum                    ;
553  fulltag-nil                           ; NIL and nothing but.  (Note that there's still a hidden NILSYM.)
554  fulltag-misc                          ; Pointer "real" tag-misc object.  Shares TAG with fulltag-nodeheader.
555  fulltag-immheader                     ; Header of heap-allocated object that contains unboxed data.
556)
557
558(defconstant misc-header-offset (- fulltag-misc))
559(defconstant misc-subtag-offset misc-header-offset)
560(defconstant misc-data-offset (+ misc-header-offset 4))
561(defconstant misc-dfloat-offset (+ misc-header-offset 8))
562
563
564(defconstant canonical-nil-value (+ #x10000000 fulltag-nil))
565(defconstant nil-value canonical-nil-value)
566
567;;; T is almost adjacent to NIL: since NIL is a misaligned CONS, it spans
568;;; two doublewords.  The arithmetic difference between T and NIL is
569;;; such that the least-significant bit and exactly one other bit is
570;;; set in the result.
571
572(defconstant t-offset (+ (- dnode-size fulltag-nil) fulltag-misc))
573
574
575;;; The order in which various header values are defined is significant in several ways:
576;;; 1) Numeric subtags precede non-numeric ones; there are further
577;;; orderings among numeric subtags.
578;;; 2) All subtags which denote CL arrays are preceded by those that
579;;; don't, with a further ordering which requires that (<
580;;; header-arrayH header-vectorH ,@all-other-CL-vector-types)
581;;; 3) The element-size of ivectors is determined by the ordering of
582;;; ivector subtags.
583;;; 4) All subtags are >= fulltag-immheader .
584
585
586;;; Numeric subtags.
587(define-imm-subtag bignum 0)
588(defconstant min-numeric-subtag subtag-bignum)
589(define-node-subtag ratio 1)
590(defconstant max-rational-subtag subtag-ratio)
591
592(define-imm-subtag single-float 1)          ; "SINGLE" float, aka short-float in the new order.
593(define-imm-subtag double-float 2)
594(defconstant min-float-subtag subtag-single-float)
595(defconstant max-float-subtag subtag-double-float)
596(defconstant max-real-subtag subtag-double-float)
597
598(define-node-subtag complex 3)
599(defconstant max-numeric-subtag subtag-complex)
600
601;;; CL array types.  There are more immediate types than node types; all CL array subtags must be > than
602;;; all non-CL-array subtags.  So we start by defining the immediate subtags in decreasing order, starting
603;;; with that subtag whose element size isn't an integral number of bits and ending with those whose
604;;; element size - like all non-CL-array fulltag-immheader types - is 32 bits.
605(define-imm-subtag bit-vector 31)
606(define-imm-subtag double-float-vector 30)
607(define-imm-subtag s16-vector 29)
608(define-imm-subtag u16-vector 28)
609(defconstant min-16-bit-ivector-subtag subtag-u16-vector)
610(defconstant max-16-bit-ivector-subtag subtag-s16-vector)
611
612
613;;(define-imm-subtag simple-base-string 27)
614(define-imm-subtag s8-vector 26)
615(define-imm-subtag u8-vector 25)
616(defconstant min-8-bit-ivector-subtag subtag-u8-vector)
617(defconstant max-8-bit-ivector-subtag (logior fulltag-immheader (ash 27 ntagbits)))
618
619(define-imm-subtag simple-base-string 24)
620(define-imm-subtag fixnum-vector 23)
621(define-imm-subtag s32-vector 22)
622(define-imm-subtag u32-vector 21)
623(define-imm-subtag single-float-vector 20)
624(defconstant max-32-bit-ivector-subtag (logior fulltag-immheader (ash 24 ntagbits)))
625(defconstant min-cl-ivector-subtag subtag-single-float-vector)
626
627(define-node-subtag vectorH 20)
628(define-node-subtag arrayH 19)
629(assert (< subtag-arrayH subtag-vectorH min-cl-ivector-subtag))
630(define-node-subtag simple-vector 21)   ; Only one such subtag
631(assert (< subtag-arrayH subtag-vectorH subtag-simple-vector))
632(defconstant min-vector-subtag subtag-vectorH)
633(defconstant min-array-subtag subtag-arrayH)
634
635;;; So, we get the remaining subtags (n: (n > max-numeric-subtag) & (n < min-array-subtag))
636;;; for various immediate/node object types.
637
638(define-imm-subtag macptr 3)
639(defconstant min-non-numeric-imm-subtag subtag-macptr)
640(assert (> min-non-numeric-imm-subtag max-numeric-subtag))
641(define-imm-subtag dead-macptr 4)
642(define-imm-subtag code-vector 5)
643(define-imm-subtag creole-object 6)
644(define-imm-subtag xcode-vector 7)  ; code-vector for cross-development
645
646(defconstant max-non-array-imm-subtag (logior (ash 19 ntagbits) fulltag-immheader))
647
648(define-node-subtag catch-frame 4)
649(defconstant min-non-numeric-node-subtag subtag-catch-frame)
650(assert (> min-non-numeric-node-subtag max-numeric-subtag))
651(define-node-subtag function 5)
652(define-node-subtag basic-stream 6)
653(define-node-subtag symbol 7)
654(define-node-subtag lock 8)
655(define-node-subtag hash-vector 9)
656(define-node-subtag pool 10)
657(define-node-subtag weak 11)
658(define-node-subtag package 12)
659(define-node-subtag slot-vector 13)
660(define-node-subtag instance 14)
661(define-node-subtag struct 15)
662(define-node-subtag istruct 16)
663(define-node-subtag value-cell 17)
664(define-node-subtag xfunction 18)       ; Function for cross-development
665(defconstant max-non-array-node-subtag (logior (ash 18 ntagbits) fulltag-nodeheader))
666
667(define-subtag lisp-frame-marker fulltag-imm 2)
668(define-subtag character fulltag-imm 9)
669(define-subtag slot-unbound fulltag-imm 10)
670(defconstant slot-unbound-marker subtag-slot-unbound)
671(define-subtag illegal fulltag-imm 11)
672(defconstant illegal-marker subtag-illegal)
673(define-subtag go-tag fulltag-imm 12)
674(define-subtag block-tag fulltag-imm 24)
675(define-subtag no-thread-local-binding fulltag-imm 30)
676(define-subtag unbound fulltag-imm 6)
677(defconstant unbound-marker subtag-unbound)
678(defconstant undefined unbound-marker)
679(defconstant lisp-frame-marker subtag-lisp-frame-marker)
680
681(defconstant max-64-bit-constant-index (ash (+ #xfff arm::misc-dfloat-offset) -3))
682(defconstant max-32-bit-constant-index (ash (+ #xfff arm::misc-data-offset) -2))
683(defconstant max-16-bit-constant-index (ash (+ #xfff arm::misc-data-offset) -1))
684(defconstant max-8-bit-constant-index (+ #xfff arm::misc-data-offset))
685(defconstant max-1-bit-constant-index (ash (+ #xfff arm::misc-data-offset) 5))
686
687
688;;; The objects themselves look something like this:
689
690;;; Order of CAR and CDR doesn't seem to matter much - there aren't
691;;; too many tricks to be played with predecrement/preincrement addressing.
692;;; Keep them in the confusing MCL 3.0 order, to avoid confusion.
693(define-lisp-object cons tag-list 
694  cdr 
695  car)
696
697
698(define-fixedsized-object ratio
699  numer
700  denom)
701
702(define-fixedsized-object single-float
703  value)
704
705(define-fixedsized-object double-float
706  pad
707  value
708  val-low)
709
710(define-fixedsized-object complex
711  realpart
712  imagpart
713)
714
715
716;;; There are two kinds of macptr; use the length field of the header if you
717;;; need to distinguish between them
718(define-fixedsized-object macptr
719  address
720  domain
721  type
722)
723
724(define-fixedsized-object xmacptr
725  address
726  domain
727  type
728  flags
729  link
730)
731
732;;; Catch frames go on the cstack, below a lisp frame whose savelr
733;;; field references the catch exit point/unwind-protect cleanup code.
734(define-fixedsized-object catch-frame
735  link                                  ; tagged pointer to next older catch frame
736  mvflag                                ; 0 if single-value, 1 if uwp or multiple-value
737  catch-tag                             ; #<unbound> -> unwind-protect, else catch
738  db-link                               ; value of dynamic-binding link on thread entry.
739  xframe                                ; exception-frame link
740
741)
742
743(define-fixedsized-object lock
744  _value                                ;finalizable pointer to kernel object
745  kind                                  ; '0 = recursive-lock, '1 = rwlock
746  writer                                ;tcr of owning thread or 0
747  name
748  whostate
749  whostate-2
750  )
751
752
753
754(define-fixedsized-object symbol
755  pname
756  vcell
757  fcell
758  package-predicate
759  flags
760  plist
761  binding-index
762)
763
764(define-fixedsized-object function
765  entrypoint
766  codevector
767  )
768
769
770
771
772(defconstant nilsym-offset (+ t-offset symbol.size))
773
774
775(define-fixedsized-object vectorH
776  logsize                               ; fillpointer if it has one, physsize otherwise
777  physsize                              ; total size of (possibly displaced) data vector
778  data-vector                           ; object this header describes
779  displacement                          ; true displacement or 0
780  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
781)
782
783(define-lisp-object arrayH fulltag-misc
784  header                                ; subtag = subtag-arrayH
785  rank                                  ; NEVER 1
786  physsize                              ; total size of (possibly displaced) data vector
787  data-vector                           ; object this header describes
788  displacement                          ; true displacement or 0 
789  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
790 ;; Dimensions follow
791)
792
793(defconstant arrayH.rank-cell 0)
794(defconstant arrayH.physsize-cell 1)
795(defconstant arrayH.data-vector-cell 2)
796(defconstant arrayH.displacement-cell 3)
797(defconstant arrayH.flags-cell 4)
798(defconstant arrayH.dim0-cell 5)
799
800(defconstant arrayH.flags-cell-bits-byte (byte 8 0))
801(defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
802
803
804(define-fixedsized-object value-cell
805  value)
806
807;;; The kernel uses these (rather generically named) structures
808;;; to keep track of various memory regions it (or the lisp) is
809;;; interested in.
810;;; The gc-area record definition in "ccl:interfaces;mcl-records.lisp"
811;;; matches this.
812
813(define-storage-layout area 0
814  pred                                  ; pointer to preceding area in DLL
815  succ                                  ; pointer to next area in DLL
816  low                                   ; low bound on area addresses
817  high                                  ; high bound on area addresses.
818  active                                ; low limit on stacks, high limit on heaps
819  softlimit                             ; overflow bound
820  hardlimit                             ; another one
821  code                                  ; an area-code; see below
822  markbits                              ; bit vector for GC
823  ndnodes                               ; "active" size of dynamic area or stack
824  older                                 ; in EGC sense
825  younger                               ; also for EGC
826  h                                     ; Handle or null pointer
827  softprot                              ; protected_area structure pointer
828  hardprot                              ; another one.
829  owner                                 ; fragment (library) which "owns" the area
830  refbits                               ; bitvector for intergenerational refernces
831  threshold                             ; for egc
832  gc-count                              ; generational gc count.
833  static-dnodes                         ; for honsing, etc.
834  static-used                           ; bitvector
835)
836
837
838(define-storage-layout protected-area 0
839  next
840  start                                 ; first byte (page-aligned) that might be protected
841  end                                   ; last byte (page-aligned) that could be protected
842  nprot                                 ; Might be 0
843  protsize                              ; number of bytes to protect
844  why)
845
846(defconstant tcr-bias 0)
847
848(define-storage-layout tcr (- tcr-bias)
849  prev                                  ; in doubly-linked list
850  next                                  ; in doubly-linked list
851  lisp-fpscr-high
852  lisp-fpscr-low
853  db-link                               ; special binding chain head
854  catch-top                             ; top catch frame
855  save-vsp                              ; VSP when in foreign code
856  save-tsp                              ; TSP when in foreign code
857  cs-area                               ; cstack area pointer
858  vs-area                               ; vstack area pointer
859  ts-area                               ; tstack area pointer
860  cs-limit                              ; cstack overflow limit
861  total-bytes-allocated-high
862  total-bytes-allocated-low
863  log2-allocation-quantum               ; unboxed
864  interrupt-pending                     ; fixnum
865  xframe                                ; exception frame linked list
866  errno-loc                             ; thread-private, maybe
867  ffi-exception                         ; fpscr bits from ff-call.
868  osid                                  ; OS thread id
869  valence                               ; odd when in foreign code
870  foreign-exception-status
871  native-thread-info
872  native-thread-id
873  last-allocptr
874  save-allocptr
875  save-allocbase
876  reset-completion
877  activate
878  suspend-count
879  suspend-context
880  pending-exception-context
881  suspend                               ; semaphore for suspension notify
882  resume                                ; sempahore for resumption notify
883  flags                                 ; foreign, being reset, ...
884  gc-context
885  termination-semaphore
886  unwinding
887  tlb-limit
888  tlb-pointer
889  shutdown-count
890  safe-ref-address
891)
892
893(defconstant interrupt-level-binding-index (ash 1 fixnumshift))
894
895(define-storage-layout lockptr 0
896  avail
897  owner
898  count
899  signal
900  waiting
901  malloced-ptr
902  spinlock)
903
904(define-storage-layout rwlock 0
905  spin
906  state
907  blocked-writers
908  blocked-readers
909  writer
910  reader-signal
911  writer-signal
912  malloced-ptr
913  )
914
915
916
917(arm::define-storage-layout lisp-frame 0
918  backlink
919  savefn
920  savelr
921  savevsp
922)
923
924
925
926
927(defmacro define-header (name element-count subtag)
928  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
929
930(define-header single-float-header single-float.element-count subtag-single-float)
931(define-header double-float-header double-float.element-count subtag-double-float)
932(define-header one-digit-bignum-header 1 subtag-bignum)
933(define-header two-digit-bignum-header 2 subtag-bignum)
934(define-header three-digit-bignum-header 3 subtag-bignum)
935(define-header symbol-header symbol.element-count subtag-symbol)
936(define-header value-cell-header value-cell.element-count subtag-value-cell)
937(define-header macptr-header macptr.element-count subtag-macptr)
938
939
940)
941
942
943
944
945(defun %kernel-global (sym)
946  ;; Returns index relative to (- nil-value fulltag-nil)
947  (let* ((pos (position sym arm::*arm-kernel-globals* :test #'string=)))
948    (if pos
949      (- (* (1+ pos) 4))
950      (error "Unknown kernel global : ~s ." sym))))
951
952(defmacro kernel-global (sym)
953  (let* ((pos (position sym arm::*arm-kernel-globals* :test #'string=)))
954    (if pos
955      (- (* (1+ pos) 4))
956      (error "Unknown kernel global : ~s ." sym))))
957
958;;; The kernel imports things that are defined in various other
959;;; libraries for us.  The objects in question are generally
960;;; fixnum-tagged; the entries in the "kernel-imports" vector are 4
961;;; bytes apart.
962(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step 4)
963  fd-setsize-bytes
964  do-fd-set
965  do-fd-clr
966  do-fd-is-set
967  do-fd-zero
968  MakeDataExecutable
969  GetSharedLibrary
970  FindSymbol
971  malloc
972  free
973  jvm-init
974  tcr-frame-ptr
975  register-xmacptr-dispose-function
976  open-debug-output
977  get-r-debug
978  restore-soft-stack-limit
979  egc-control
980  lisp-bug
981  NewThread
982  YieldToThread
983  DisposeThread
984  ThreadCurrentStackSpace
985  usage-exit
986  save-fp-context
987  restore-fp-context
988  put-altivec-registers
989  get-altivec-registers
990  new-semaphore
991  wait-on-semaphore
992  signal-semaphore
993  destroy-semaphore
994  new-recursive-lock
995  lock-recursive-lock
996  unlock-recursive-lock
997  destroy-recursive-lock
998  suspend-other-threads
999  resume-other-threads
1000  suspend-tcr
1001  resume-tcr
1002  rwlock-new
1003  rwlock-destroy
1004  rwlock-rlock
1005  rwlock-wlock
1006  rwlock-unlock
1007  recursive-lock-trylock
1008  foreign-name-and-offset
1009  lisp-read
1010  lisp-write
1011  lisp-open
1012  lisp-fchmod
1013  lisp-lseek
1014  lisp-close
1015  lisp-ftruncate
1016  lisp-stat
1017  lisp-fstat
1018  lisp-futex
1019  lisp-opendir
1020  lisp-readdir
1021  lisp-closedir
1022  lisp-pipe
1023  lisp-gettimeofday
1024  lisp-sigexit
1025)
1026
1027(defmacro nrs-offset (name)
1028  (let* ((pos (position name arm::*arm-nilreg-relative-symbols* :test #'eq)))
1029    (if pos (+ t-offset (* pos symbol.size)))))
1030
1031
1032
1033
1034
1035(defmacro with-stack-short-floats (specs &body body)
1036  (ccl::collect ((binds)
1037                 (inits)
1038                 (names))
1039                (dolist (spec specs)
1040                  (let ((name (first spec)))
1041                    (binds `(,name (ccl::%make-sfloat)))
1042                    (names name)
1043                    (let ((init (second spec)))
1044                      (when init
1045                        (inits `(ccl::%short-float ,init ,name))))))
1046                `(let* ,(binds)
1047                  (declare (dynamic-extent ,@(names))
1048                           (short-float ,@(names)))
1049                  ,@(inits)
1050                  ,@body)))
1051
1052(defparameter *arm-target-uvector-subtags*
1053  `((:bignum . ,subtag-bignum)
1054    (:ratio . ,subtag-ratio)
1055    (:single-float . ,subtag-single-float)
1056    (:double-float . ,subtag-double-float)
1057    (:complex . ,subtag-complex  )
1058    (:symbol . ,subtag-symbol)
1059    (:function . ,subtag-function )
1060    (:code-vector . ,subtag-code-vector)
1061    (:xcode-vector . ,subtag-xcode-vector)
1062    (:macptr . ,subtag-macptr )
1063    (:catch-frame . ,subtag-catch-frame)
1064    (:struct . ,subtag-struct )   
1065    (:istruct . ,subtag-istruct )
1066    (:pool . ,subtag-pool )
1067    (:population . ,subtag-weak )
1068    (:hash-vector . ,subtag-hash-vector )
1069    (:package . ,subtag-package )
1070    (:value-cell . ,subtag-value-cell)
1071    (:instance . ,subtag-instance )
1072    (:lock . ,subtag-lock )
1073    (:slot-vector . ,subtag-slot-vector)
1074    (:basic-stream . ,subtag-basic-stream)
1075    (:simple-string . ,subtag-simple-base-string )
1076    (:bit-vector . ,subtag-bit-vector )
1077    (:signed-8-bit-vector . ,subtag-s8-vector )
1078    (:unsigned-8-bit-vector . ,subtag-u8-vector )
1079    (:signed-16-bit-vector . ,subtag-s16-vector )
1080    (:unsigned-16-bit-vector . ,subtag-u16-vector )
1081    (:signed-32-bit-vector . ,subtag-s32-vector )
1082    (:fixnum-vector . ,subtag-fixnum-vector)
1083    (:unsigned-32-bit-vector . ,subtag-u32-vector )
1084    (:single-float-vector . ,subtag-single-float-vector)
1085    (:double-float-vector . ,subtag-double-float-vector )
1086    (:simple-vector . ,subtag-simple-vector )
1087    (:vector-header . ,subtag-vectorH)
1088    (:array-header . ,subtag-arrayH)))
1089
1090
1091;;; This should return NIL unless it's sure of how the indicated
1092;;; type would be represented (in particular, it should return
1093;;; NIL if the element type is unknown or unspecified at compile-time.
1094(defun arm-array-type-name-from-ctype (ctype)
1095  (when (typep ctype 'ccl::array-ctype)
1096    (let* ((element-type (ccl::array-ctype-element-type ctype)))
1097      (typecase element-type
1098        (ccl::class-ctype
1099         (let* ((class (ccl::class-ctype-class element-type)))
1100           (if (or (eq class ccl::*character-class*)
1101                   (eq class ccl::*base-char-class*)
1102                   (eq class ccl::*standard-char-class*))
1103             :simple-string
1104             :simple-vector)))
1105        (ccl::numeric-ctype
1106         (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
1107           :simple-vector
1108           (case (ccl::numeric-ctype-class element-type)
1109             (integer
1110              (let* ((low (ccl::numeric-ctype-low element-type))
1111                     (high (ccl::numeric-ctype-high element-type)))
1112                (cond ((or (null low) (null high)) :simple-vector)
1113                      ((and (>= low 0) (<= high 1) :bit-vector))
1114                      ((and (>= low 0) (<= high 255)) :unsigned-8-bit-vector)
1115                      ((and (>= low 0) (<= high 65535)) :unsigned-16-bit-vector)
1116                      ((and (>= low 0) (<= high #xffffffff) :unsigned-32-bit-vector))
1117                      ((and (>= low -128) (<= high 127)) :signed-8-bit-vector)
1118                      ((and (>= low -32768) (<= high 32767) :signed-16-bit-vector))
1119                      ((and (>= low target-most-negative-fixnum)
1120                            (<= high target-most-positive-fixnum))
1121                       :fixnum-vector)
1122                      ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
1123                       :signed-32-bit-vector)
1124                      (t :simple-vector))))
1125             (float
1126              (case (ccl::numeric-ctype-format element-type)
1127                ((double-float long-float) :double-float-vector)
1128                ((single-float short-float) :single-float-vector)
1129                (t :simple-vector)))
1130             (t :simple-vector))))
1131        (ccl::unknown-ctype)
1132        (ccl::named-ctype
1133         (if (eq element-type ccl::*universal-type*)
1134           :simple-vector))
1135        (t nil)))))
1136       
1137(defun arm-misc-byte-count (subtag element-count)
1138  (declare (fixnum subtag))
1139  (if (or (= fulltag-nodeheader (logand subtag fulltagmask))
1140          (<= subtag max-32-bit-ivector-subtag))
1141    (ash element-count 2)
1142    (if (<= subtag max-8-bit-ivector-subtag)
1143      element-count
1144      (if (<= subtag max-16-bit-ivector-subtag)
1145        (ash element-count 1)
1146        (if (= subtag subtag-bit-vector)
1147          (ash (+ element-count 7) -3)
1148          (+ 4 (ash element-count 3)))))))
1149
1150(defparameter *arm-target-arch*
1151  (arch::make-target-arch :name :arm
1152                          :lisp-node-size 4
1153                          :nil-value canonical-nil-value
1154                          :fixnum-shift fixnumshift
1155                          :most-positive-fixnum (1- (ash 1 (1- (- 32 fixnumshift))))
1156                          :most-negative-fixnum (- (ash 1 (1- (- 32 fixnumshift))))
1157                          :misc-data-offset misc-data-offset
1158                          :misc-dfloat-offset misc-dfloat-offset
1159                          :nbits-in-word 32
1160                          :ntagbits 3
1161                          :nlisptagbits 2
1162                          :uvector-subtags *arm-target-uvector-subtags*
1163                          :max-64-bit-constant-index max-64-bit-constant-index
1164                          :max-32-bit-constant-index max-32-bit-constant-index
1165                          :max-16-bit-constant-index max-16-bit-constant-index
1166                          :max-8-bit-constant-index max-8-bit-constant-index
1167                          :max-1-bit-constant-index max-1-bit-constant-index
1168                          :word-shift 2
1169                          :code-vector-prefix ()
1170                          :gvector-types '(:ratio :complex :symbol :function
1171                                           :catch-frame :struct :istruct
1172                                           :pool :population :hash-vector
1173                                           :package :value-cell :instance
1174                                           :lock :slot-vector
1175                                           :simple-vector)
1176                          :1-bit-ivector-types '(:bit-vector)
1177                          :8-bit-ivector-types '(:signed-8-bit-vector
1178                                                 :unsigned-8-bit-vector)
1179                          :16-bit-ivector-types '(:signed-16-bit-vector
1180                                                  :unsigned-16-bit-vector)
1181                          :32-bit-ivector-types '(:signed-32-bit-vector
1182                                                  :unsigned-32-bit-vector
1183                                                  :single-float-vector
1184                                                  :fixnum-vector
1185                                                  :single-float
1186                                                  :double-float
1187                                                  :bignum
1188                                                  :simple-string)
1189                          :64-bit-ivector-types '(:double-float-vector)
1190                          :array-type-name-from-ctype-function
1191                          #'arm-array-type-name-from-ctype
1192                          :package-name "ARM"
1193                          :t-offset t-offset
1194                          :array-data-size-function #'arm-misc-byte-count
1195                          :numeric-type-name-to-typecode-function
1196                          #'(lambda (type-name)
1197                              (ecase type-name
1198                                (fixnum tag-fixnum)
1199                                (bignum subtag-bignum)
1200                                ((short-float single-float) subtag-single-float)
1201                                ((long-float double-float) subtag-double-float)
1202                                (ratio subtag-ratio)
1203                                (complex subtag-complex)))
1204                          :subprims-base arm::*arm-subprims-base*
1205                          :subprims-shift arm::*arm-subprims-shift*
1206                          :subprims-table arm::*arm-subprims*
1207                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus arm::*arm-subprims*)))
1208                          :unbound-marker-value unbound-marker
1209                          :slot-unbound-marker-value slot-unbound-marker
1210                          :fixnum-tag tag-fixnum
1211                          :single-float-tag subtag-single-float
1212                          :single-float-tag-is-subtag t
1213                          :double-float-tag subtag-double-float
1214                          :cons-tag fulltag-cons
1215                          :null-tag fulltag-nil
1216                          :symbol-tag subtag-symbol
1217                          :symbol-tag-is-subtag t
1218                          :function-tag subtag-function
1219                          :function-tag-is-subtag t
1220                          :big-endian t
1221                          :misc-subtag-offset misc-subtag-offset
1222                          :car-offset cons.car
1223                          :cdr-offset cons.cdr
1224                          :subtag-char subtag-character
1225                          :charcode-shift charcode-shift
1226                          :fulltagmask fulltagmask
1227                          :fulltag-misc fulltag-misc
1228                          :char-code-limit #x110000
1229                          ))
1230
1231;;; arch macros
1232(defmacro defarmarchmacro (name lambda-list &body body)
1233  `(arch::defarchmacro :arm ,name ,lambda-list ,@body))
1234
1235(defarmarchmacro ccl::%make-sfloat ()
1236  `(ccl::%alloc-misc arm::single-float.element-count arm::subtag-single-float))
1237
1238(defarmarchmacro ccl::%make-dfloat ()
1239  `(ccl::%alloc-misc arm::double-float.element-count arm::subtag-double-float))
1240
1241(defarmarchmacro ccl::%numerator (x)
1242  `(ccl::%svref ,x arm::ratio.numer-cell))
1243
1244(defarmarchmacro ccl::%denominator (x)
1245  `(ccl::%svref ,x arm::ratio.denom-cell))
1246
1247(defarmarchmacro ccl::%realpart (x)
1248  `(ccl::%svref ,x arm::complex.realpart-cell))
1249                   
1250(defarmarchmacro ccl::%imagpart (x)
1251  `(ccl::%svref ,x arm::complex.imagpart-cell))
1252
1253;;;
1254(defarmarchmacro ccl::%get-single-float-from-double-ptr (ptr offset)
1255 `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)
1256   (ccl::%alloc-misc 1 arm::subtag-single-float)))
1257
1258(defarmarchmacro ccl::codevec-header-p (word)
1259  `(eql arm::subtag-code-vector
1260    (logand ,word arm::subtag-mask)))
1261
1262(defarmarchmacro ccl::immediate-p-macro (thing)
1263  (let* ((tag (gensym)))
1264    `(let* ((,tag (ccl::lisptag ,thing)))
1265      (declare (fixnum ,tag))
1266      (or (= ,tag arm::tag-fixnum)
1267       (= ,tag arm::tag-imm)))))
1268
1269(defarmarchmacro ccl::hashed-by-identity (thing)
1270  (let* ((typecode (gensym)))
1271    `(let* ((,typecode (ccl::typecode ,thing)))
1272      (declare (fixnum ,typecode))
1273      (or
1274       (= ,typecode arm::tag-fixnum)
1275       (= ,typecode arm::tag-imm)
1276       (= ,typecode arm::subtag-symbol)
1277       (= ,typecode arm::subtag-instance)))))
1278
1279;;;
1280(defarmarchmacro ccl::%get-kernel-global (name)
1281  `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value)
1282                        ,(%kernel-global
1283                          (if (ccl::quoted-form-p name)
1284                            (cadr name)
1285                            name)))))
1286
1287(defarmarchmacro ccl::%get-kernel-global-ptr (name dest)
1288  `(ccl::%setf-macptr
1289    ,dest
1290    (ccl::%fixnum-ref-macptr 0 (+ ,(ccl::target-nil-value)
1291                                ,(%kernel-global
1292                                  (if (ccl::quoted-form-p name)
1293                                    (cadr name)
1294                                    name))))))
1295
1296(defarmarchmacro ccl::%target-kernel-global (name)
1297  `(arm::%kernel-global ,name))
1298
1299(defarmarchmacro ccl::lfun-vector (fun)
1300  fun)
1301
1302(defarmarchmacro ccl::lfun-vector-lfun (lfv)
1303  lfv)
1304
1305(defarmarchmacro ccl::area-code ()
1306  area.code)
1307
1308(defarmarchmacro ccl::area-succ ()
1309  area.succ)
1310
1311(defarmarchmacro ccl::nth-immediate (f i)
1312  `(ccl::%svref ,f ,i))
1313
1314(defarmarchmacro ccl::set-nth-immediate (f i new)
1315  `(setf (ccl::%svref ,f ,i) ,new))
1316
1317(defarmarchmacro ccl::symptr->symvector (s)
1318  s)
1319
1320(defarmarchmacro ccl::symvector->symptr (s)
1321  s)
1322
1323(defarmarchmacro ccl::function-to-function-vector (f)
1324  f)
1325
1326(defarmarchmacro ccl::function-vector-to-function (v)
1327  v)
1328
1329(defarmarchmacro ccl::with-ffcall-results ((buf) &body body)
1330  (let* ((size (+ (* 8 4) (* 31 8))))
1331    `(%stack-block ((,buf ,size))
1332      ,@body)))
1333
1334(defconstant arg-check-trap-pc-limit 8)
1335
1336;;; UUO encoding
1337(defconstant uuo-format-nullary 0)      ; 12 bits of code
1338(defconstant uuo-format-unary 1)        ; 8 bits of info - NOT type info - 4-bit reg
1339(defconstant uuo-format-error-lisptag 2) ; 2 bits of lisptag info, 4-bit reg
1340(defconstant uuo-format-error-fulltag 3) ; 3 bits of fulltag info, 4 bit reg
1341
1342(defconstant uuo-format-error-xtype 4)  ; 8 bits of extended type/subtag info, 4 bit reg
1343(defconstant uuo-format-cerror-lisptag 10) ; continuable, lisptag, reg
1344(defconstant uuo-format-cerror-fulltag 11) ; continuable, fulltag, reg
1345(defconstant uuo-format-cerror-xtype 12) ; continuable, xtype, reg         
1346(defconstant uuo-format-binary 15)      ;  4 bits of code, r1, r0
1347
1348;;; xtypes: 8-bit integers used to report type errors for types that can't
1349;;; be represented via tags.
1350
1351(defconstant xtype-unsigned-byte-24  252)
1352(defconstant xtype-array2d  248)
1353(defconstant xtype-array3d  244)
1354(defconstant xtype-integer  4)
1355(defconstant xtype-s64  8)
1356(defconstant xtype-u64  12)
1357(defconstant xtype-s32  16)
1358(defconstant xtype-u32  20)
1359(defconstant xtype-s16  24)
1360(defconstant xtype-u16  28)
1361(defconstant xtype-s8  32)
1362(defconstant xtype-u8  36)
1363(defconstant xtype-bit  40)
1364(defconstant xtype-rational 44)
1365(defconstant xtype-real 48)
1366(defconstant xtype-number 52)
1367(defconstant xtype-char-code 56)
1368
1369;;; Condition field values.
1370(ccl::defenum (:prefix "ARM-COND-")
1371  eq
1372  ne
1373  hs
1374  lo
1375  mi
1376  pl
1377  vs
1378  vc
1379  hi
1380  ls
1381  ge
1382  lt
1383  gt
1384  le
1385  al)
1386
1387 
1388(provide "ARM-ARCH")
Note: See TracBrowser for help on using the repository browser.