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

Last change on this file since 13750 was 13750, checked in by gb, 9 years ago

Try to make subprim entries match the kernel. Will likely need to
change more.

File size: 48.1 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 .SPfix-nfn-entrypoint)
307             (defarmsubprim .SPbuiltin-plus)
308             (defarmsubprim .SPbuiltin-minus)
309             (defarmsubprim .SPbuiltin-times)
310             (defarmsubprim .SPbuiltin-div)
311             (defarmsubprim .SPbuiltin-eq)
312             (defarmsubprim .SPbuiltin-ne)
313             (defarmsubprim .SPbuiltin-gt)
314             (defarmsubprim .SPbuiltin-ge)
315             (defarmsubprim .SPbuiltin-lt)
316             (defarmsubprim .SPbuiltin-le)
317             (defarmsubprim .SPbuiltin-eql)
318             (defarmsubprim .SPbuiltin-length)
319             (defarmsubprim .SPbuiltin-seqtype)
320             (defarmsubprim .SPbuiltin-assq)
321             (defarmsubprim .SPbuiltin-memq)
322             (defarmsubprim .SPbuiltin-logbitp)
323             (defarmsubprim .SPbuiltin-logior)
324             (defarmsubprim .SPbuiltin-logand)
325             (defarmsubprim .SPbuiltin-ash)
326             (defarmsubprim .SPbuiltin-negate)
327             (defarmsubprim .SPbuiltin-logxor)
328             (defarmsubprim .SPbuiltin-aref1)
329             (defarmsubprim .SPbuiltin-aset1)
330             (defarmsubprim .SPfuncall)
331             (defarmsubprim .SPmkcatch1v)
332             (defarmsubprim .SPmkcatchmv)
333             (defarmsubprim .SPmkunwind)
334             (defarmsubprim .SPbind)
335             (defarmsubprim .SPconslist)
336             (defarmsubprim .SPconslist-star)
337             (defarmsubprim .SPmakes32)
338             (defarmsubprim .SPmakeu32)
339             (defarmsubprim .SPfix-overflow)
340             (defarmsubprim .SPmakeu64)
341             (defarmsubprim .SPmakes64)
342             (defarmsubprim .SPmvpass)
343             (defarmsubprim .SPvalues)
344             (defarmsubprim .SPnvalret)
345             (defarmsubprim .SPthrow)
346             (defarmsubprim .SPnthrowvalues)
347             (defarmsubprim .SPnthrow1value)
348             (defarmsubprim .SPbind-self)
349             (defarmsubprim .SPbind-nil)
350             (defarmsubprim .SPbind-self-boundp-check)
351             (defarmsubprim .SPrplaca)
352             (defarmsubprim .SPrplacd)
353             (defarmsubprim .SPgvset)
354             (defarmsubprim .SPset-hash-key)
355             (defarmsubprim .SPstore-node-conditional)
356             (defarmsubprim .SPset-hash-key-conditional)
357             (defarmsubprim .SPstkconslist)
358             (defarmsubprim .SPstkconslist-star)
359             (defarmsubprim .SPmkstackv)
360             (defarmsubprim .SPsetqsym)
361             (defarmsubprim .SPprogvsave)
362             (defarmsubprim .SPstack-misc-alloc)
363             (defarmsubprim .SPgvector)
364             (defarmsubprim .SPfitvals)
365             (defarmsubprim .SPnthvalue)
366             (defarmsubprim .SPdefault-optional-args)
367             (defarmsubprim .SPopt-supplied-p)
368             (defarmsubprim .SPheap-rest-arg)
369             (defarmsubprim .SPreq-heap-rest-arg)
370             (defarmsubprim .SPheap-cons-rest-arg)
371             (defarmsubprim .SPsimple-keywords)
372             (defarmsubprim .SPkeyword-args)
373             (defarmsubprim .SPkeyword-bind)
374             (defarmsubprim .SPksignalerr)
375             (defarmsubprim .SPstack-rest-arg)
376             (defarmsubprim .SPreq-stack-rest-arg)
377             (defarmsubprim .SPstack-cons-rest-arg)
378             (defarmsubprim .SPcall-closure)       
379             (defarmsubprim .SPspreadargz)
380             (defarmsubprim .SPtfuncallgen)
381             (defarmsubprim .SPtfuncallslide)
382             (defarmsubprim .SPtfuncallvsp)
383             (defarmsubprim .SPtcallsymgen)
384             (defarmsubprim .SPtcallsymslide)
385             (defarmsubprim .SPtcallnfngen)
386             (defarmsubprim .SPtcallnfnslide)
387             (defarmsubprim .SPmisc-ref)
388             (defarmsubprim .SPsubtag-misc-ref)
389             (defarmsubprim .SPmakestackblock)
390             (defarmsubprim .SPmakestackblock0)
391             (defarmsubprim .SPmakestacklist)
392             (defarmsubprim .SPstkgvector)
393             (defarmsubprim .SPmisc-alloc)
394             (defarmsubprim .SPmacro-bind)
395             (defarmsubprim .SPdestructuring-bind)
396             (defarmsubprim .SPdestructuring-bind-inner)
397             (defarmsubprim .SPrecover-values)
398             (defarmsubprim .SPinteger-sign)
399             (defarmsubprim .SPsubtag-misc-set)
400             (defarmsubprim .SPmisc-set)
401             (defarmsubprim .SPspread-lexprz)
402             (defarmsubprim .SPreset)
403             (defarmsubprim .SPmvslide)
404             (defarmsubprim .SPsave-values)
405             (defarmsubprim .SPadd-values)
406             (defarmsubprim .SPmisc-alloc-init)
407             (defarmsubprim .SPstack-misc-alloc-init)
408             (defarmsubprim .SPlexpr-entry)
409             (defarmsubprim .SPgetu64)
410             (defarmsubprim .SPgets64)
411             (defarmsubprim .SPspecref)
412             (defarmsubprim .SPspecrefcheck)
413             (defarmsubprim .SPspecset)
414             (defarmsubprim .SPgets32)
415             (defarmsubprim .SPgetu32)
416             (defarmsubprim .SPmvpasssym)
417             (defarmsubprim .SPunbind)
418             (defarmsubprim .SPunbind-n)
419             (defarmsubprim .SPunbind-to)
420             (defarmsubprim .SPprogvrestore)
421             (defarmsubprim .SPbind-interrupt-level-0)
422             (defarmsubprim .SPbind-interrupt-level-m1)
423             (defarmsubprim .SPbind-interrupt-level)
424             (defarmsubprim .SPunbind-interrupt-level)
425             (defarmsubprim .SParef2)
426             (defarmsubprim .SParef3)
427             (defarmsubprim .SPaset2)
428             (defarmsubprim .SPaset3)
429             )))))
430
431
432 
433(defmacro define-storage-layout (name origin &rest cells)
434  `(progn
435     (ccl::defenum (:start ,origin :step 4)
436       ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells))
437     (defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells) 4))))
438 
439(defmacro define-lisp-object (name tagname &rest cells)
440  `(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells))
441
442(defmacro define-subtag (name tag subtag)
443  `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,subtag ntagbits))))
444
445
446(defmacro define-imm-subtag (name subtag)
447  `(define-subtag ,name fulltag-immheader ,subtag))
448
449(defmacro define-node-subtag (name subtag)
450  `(define-subtag ,name fulltag-nodeheader ,subtag))
451
452(defmacro define-fixedsized-object (name &rest non-header-cells)
453  `(progn
454     (define-lisp-object ,name fulltag-misc header ,@non-header-cells)
455     (ccl::defenum ()
456       ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells))
457     (defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells))))
458
459 
460
461
462(eval-when (:compile-toplevel :load-toplevel :execute)
463(defconstant nbits-in-word 32)
464(defconstant least-significant-bit 31)
465(defconstant nbits-in-byte 8)
466(defconstant ntagbits 3)                ; But non-header objects only use 2
467(defconstant nlisptagbits 2)
468(defconstant nfixnumtagbits 2)          ; See ?
469(defconstant num-subtag-bits 8)         ; tag part of header is 8 bits wide
470(defconstant fixnumshift nfixnumtagbits)
471(defconstant fixnum-shift fixnumshift)          ; A pet name for it.
472(defconstant fulltagmask (1- (ash 1 ntagbits)))         ; Only needed by GC/very low-level code
473(defconstant full-tag-mask fulltagmask)
474(defconstant tagmask (1- (ash 1 nlisptagbits)))
475(defconstant tag-mask tagmask)
476(defconstant fixnummask (1- (ash 1 nfixnumtagbits)))
477(defconstant fixnum-mask fixnummask)
478(defconstant subtag-mask (1- (ash 1 num-subtag-bits)))
479(defconstant ncharcodebits 24)          ; only the low 8 bits are used, currently
480(defconstant charcode-shift (- nbits-in-word ncharcodebits))
481(defconstant word-shift 2)
482(defconstant word-size-in-bytes 4)
483(defconstant node-size 4)
484(defconstant dnode-size 8)
485(defconstant dnode-align-bits 3)
486(defconstant dnode-shift dnode-align-bits)
487(defconstant bitmap-shift 5)
488
489(defconstant target-most-negative-fixnum (ash -1 (1- (- nbits-in-word nfixnumtagbits))))
490(defconstant target-most-positive-fixnum (1- (ash 1 (1- (- nbits-in-word nfixnumtagbits)))))
491(defconstant fixnumone (ash 1 fixnumshift))
492
493
494
495;; Tags.
496;; There are two-bit tags and three-bit tags.
497;; A FULLTAG is the value of the low three bits of a tagged object.
498;; A TAG is the value of the low two bits of a tagged object.
499;; A TYPECODE is either a TAG or the value of a "tag-misc" object's header-byte.
500
501;; There are 4 primary TAG values.  Any object which lisp can "see"
502;; can be classified by its TAG.  (Some headers have FULLTAGS that are
503;; congruent modulo 4 with the TAGS of other objects, but lisp can't
504;; "see" headers.)
505(ccl::defenum ()
506  tag-fixnum                            ; All fixnums, whether odd or even
507  tag-list                              ; Conses and NIL
508  tag-misc                              ; Heap-consed objects other than lists: vectors, symbols, functions, floats ...
509  tag-imm                               ; Immediate-objects: characters, UNBOUND, other markers.
510)
511
512;;; And there are 8 FULLTAG values.  Note that NIL has its own FULLTAG
513;;; (congruent mod 4 to tag-list) and that both FULLTAG-MISC and
514;;; FULLTAG-IMM have header fulltags that share the same TAG.  Things
515;;; that walk memory (and the stack) have to be careful to look at the
516;;; FULLTAG of each object that they see.
517(ccl::defenum ()
518  fulltag-even-fixnum                   ; I suppose EVENP/ODDP might care; nothing else does.
519  fulltag-cons                          ; a real (non-null) cons.  Shares TAG with fulltag-nil.
520  fulltag-nodeheader                    ; Header of heap-allocated object that contains lisp-object pointers
521  fulltag-imm                           ; a "real" immediate object.  Shares TAG with fulltag-immheader.
522  fulltag-odd-fixnum                    ;
523  fulltag-nil                           ; NIL and nothing but.  (Note that there's still a hidden NILSYM.)
524  fulltag-misc                          ; Pointer "real" tag-misc object.  Shares TAG with fulltag-nodeheader.
525  fulltag-immheader                     ; Header of heap-allocated object that contains unboxed data.
526)
527
528(defconstant misc-header-offset (- fulltag-misc))
529(defconstant misc-subtag-offset misc-header-offset)
530(defconstant misc-data-offset (+ misc-header-offset 4))
531(defconstant misc-dfloat-offset (+ misc-header-offset 8))
532
533
534(defconstant canonical-nil-value (+ #x10000000 fulltag-nil))
535(defconstant nil-value canonical-nil-value)
536
537;;; T is almost adjacent to NIL: since NIL is a misaligned CONS, it spans
538;;; two doublewords.  The arithmetic difference between T and NIL is
539;;; such that the least-significant bit and exactly one other bit is
540;;; set in the result.
541
542(defconstant t-offset (+ (- dnode-size fulltag-nil) fulltag-misc))
543
544
545;;; The order in which various header values are defined is significant in several ways:
546;;; 1) Numeric subtags precede non-numeric ones; there are further
547;;; orderings among numeric subtags.
548;;; 2) All subtags which denote CL arrays are preceded by those that
549;;; don't, with a further ordering which requires that (<
550;;; header-arrayH header-vectorH ,@all-other-CL-vector-types)
551;;; 3) The element-size of ivectors is determined by the ordering of
552;;; ivector subtags.
553;;; 4) All subtags are >= fulltag-immheader .
554
555
556;;; Numeric subtags.
557(define-imm-subtag bignum 0)
558(defconstant min-numeric-subtag subtag-bignum)
559(define-node-subtag ratio 1)
560(defconstant max-rational-subtag subtag-ratio)
561
562(define-imm-subtag single-float 1)          ; "SINGLE" float, aka short-float in the new order.
563(define-imm-subtag double-float 2)
564(defconstant min-float-subtag subtag-single-float)
565(defconstant max-float-subtag subtag-double-float)
566(defconstant max-real-subtag subtag-double-float)
567
568(define-node-subtag complex 3)
569(defconstant max-numeric-subtag subtag-complex)
570
571;;; CL array types.  There are more immediate types than node types; all CL array subtags must be > than
572;;; all non-CL-array subtags.  So we start by defining the immediate subtags in decreasing order, starting
573;;; with that subtag whose element size isn't an integral number of bits and ending with those whose
574;;; element size - like all non-CL-array fulltag-immheader types - is 32 bits.
575(define-imm-subtag bit-vector 31)
576(define-imm-subtag double-float-vector 30)
577(define-imm-subtag s16-vector 29)
578(define-imm-subtag u16-vector 28)
579(defconstant min-16-bit-ivector-subtag subtag-u16-vector)
580(defconstant max-16-bit-ivector-subtag subtag-s16-vector)
581
582
583;;(define-imm-subtag simple-base-string 27)
584(define-imm-subtag s8-vector 26)
585(define-imm-subtag u8-vector 25)
586(defconstant min-8-bit-ivector-subtag subtag-u8-vector)
587(defconstant max-8-bit-ivector-subtag (logior fulltag-immheader (ash 27 ntagbits)))
588
589(define-imm-subtag simple-base-string 24)
590(define-imm-subtag fixnum-vector 23)
591(define-imm-subtag s32-vector 22)
592(define-imm-subtag u32-vector 21)
593(define-imm-subtag single-float-vector 20)
594(defconstant max-32-bit-ivector-subtag (logior fulltag-immheader (ash 24 ntagbits)))
595(defconstant min-cl-ivector-subtag subtag-single-float-vector)
596
597(define-node-subtag vectorH 20)
598(define-node-subtag arrayH 19)
599(assert (< subtag-arrayH subtag-vectorH min-cl-ivector-subtag))
600(define-node-subtag simple-vector 21)   ; Only one such subtag
601(assert (< subtag-arrayH subtag-vectorH subtag-simple-vector))
602(defconstant min-vector-subtag subtag-vectorH)
603(defconstant min-array-subtag subtag-arrayH)
604
605;;; So, we get the remaining subtags (n: (n > max-numeric-subtag) & (n < min-array-subtag))
606;;; for various immediate/node object types.
607
608(define-imm-subtag macptr 3)
609(defconstant min-non-numeric-imm-subtag subtag-macptr)
610(assert (> min-non-numeric-imm-subtag max-numeric-subtag))
611(define-imm-subtag dead-macptr 4)
612(define-imm-subtag code-vector 5)
613(define-imm-subtag creole-object 6)
614(define-imm-subtag xcode-vector 7)  ; code-vector for cross-development
615
616(defconstant max-non-array-imm-subtag (logior (ash 19 ntagbits) fulltag-immheader))
617
618(define-node-subtag catch-frame 4)
619(defconstant min-non-numeric-node-subtag subtag-catch-frame)
620(assert (> min-non-numeric-node-subtag max-numeric-subtag))
621(define-node-subtag function 5)
622(define-node-subtag basic-stream 6)
623(define-node-subtag symbol 7)
624(define-node-subtag lock 8)
625(define-node-subtag hash-vector 9)
626(define-node-subtag pool 10)
627(define-node-subtag weak 11)
628(define-node-subtag package 12)
629(define-node-subtag slot-vector 13)
630(define-node-subtag instance 14)
631(define-node-subtag struct 15)
632(define-node-subtag istruct 16)
633(define-node-subtag value-cell 17)
634(define-node-subtag xfunction 18)       ; Function for cross-development
635(defconstant max-non-array-node-subtag (logior (ash 18 ntagbits) fulltag-nodeheader))
636
637(define-subtag lisp-frame-marker fulltag-imm 2)
638(define-subtag character fulltag-imm 9)
639(define-subtag slot-unbound fulltag-imm 10)
640(defconstant slot-unbound-marker subtag-slot-unbound)
641(define-subtag illegal fulltag-imm 11)
642(defconstant illegal-marker subtag-illegal)
643(define-subtag go-tag fulltag-imm 12)
644(define-subtag block-tag fulltag-imm 24)
645(define-subtag no-thread-local-binding fulltag-imm 30)
646(define-subtag unbound fulltag-imm 6)
647(defconstant unbound-marker subtag-unbound)
648(defconstant undefined unbound-marker)
649(defconstant lisp-frame-marker subtag-lisp-frame-marker)
650
651(defconstant max-64-bit-constant-index (ash (+ #xfff arm::misc-dfloat-offset) -3))
652(defconstant max-32-bit-constant-index (ash (+ #xfff arm::misc-data-offset) -2))
653(defconstant max-16-bit-constant-index (ash (+ #xfff arm::misc-data-offset) -1))
654(defconstant max-8-bit-constant-index (+ #xfff arm::misc-data-offset))
655(defconstant max-1-bit-constant-index (ash (+ #xfff arm::misc-data-offset) 5))
656
657
658;;; The objects themselves look something like this:
659
660;;; Order of CAR and CDR doesn't seem to matter much - there aren't
661;;; too many tricks to be played with predecrement/preincrement addressing.
662;;; Keep them in the confusing MCL 3.0 order, to avoid confusion.
663(define-lisp-object cons tag-list 
664  cdr 
665  car)
666
667
668(define-fixedsized-object ratio
669  numer
670  denom)
671
672(define-fixedsized-object single-float
673  value)
674
675(define-fixedsized-object double-float
676  pad
677  value
678  val-low)
679
680(define-fixedsized-object complex
681  realpart
682  imagpart
683)
684
685
686;;; There are two kinds of macptr; use the length field of the header if you
687;;; need to distinguish between them
688(define-fixedsized-object macptr
689  address
690  domain
691  type
692)
693
694(define-fixedsized-object xmacptr
695  address
696  domain
697  type
698  flags
699  link
700)
701
702;;; Catch frames go on the cstack, below a lisp frame whose savelr
703;;; field references the catch exit point/unwind-protect cleanup code.
704(define-fixedsized-object catch-frame
705  link                                  ; tagged pointer to next older catch frame
706  mvflag                                ; 0 if single-value, 1 if uwp or multiple-value
707  catch-tag                             ; #<unbound> -> unwind-protect, else catch
708  db-link                               ; value of dynamic-binding link on thread entry.
709  xframe                                ; exception-frame link
710
711)
712
713(define-fixedsized-object lock
714  _value                                ;finalizable pointer to kernel object
715  kind                                  ; '0 = recursive-lock, '1 = rwlock
716  writer                                ;tcr of owning thread or 0
717  name
718  whostate
719  whostate-2
720  )
721
722
723
724(define-fixedsized-object symbol
725  pname
726  vcell
727  fcell
728  package-predicate
729  flags
730  plist
731  binding-index
732)
733
734(define-fixedsized-object function
735  entrypoint
736  codevector
737  )
738
739
740
741
742(defconstant nilsym-offset (+ t-offset symbol.size))
743
744
745(define-fixedsized-object vectorH
746  logsize                               ; fillpointer if it has one, physsize otherwise
747  physsize                              ; total size of (possibly displaced) data vector
748  data-vector                           ; object this header describes
749  displacement                          ; true displacement or 0
750  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
751)
752
753(define-lisp-object arrayH fulltag-misc
754  header                                ; subtag = subtag-arrayH
755  rank                                  ; NEVER 1
756  physsize                              ; total size of (possibly displaced) data vector
757  data-vector                           ; object this header describes
758  displacement                          ; true displacement or 0 
759  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
760 ;; Dimensions follow
761)
762
763(defconstant arrayH.rank-cell 0)
764(defconstant arrayH.physsize-cell 1)
765(defconstant arrayH.data-vector-cell 2)
766(defconstant arrayH.displacement-cell 3)
767(defconstant arrayH.flags-cell 4)
768(defconstant arrayH.dim0-cell 5)
769
770(defconstant arrayH.flags-cell-bits-byte (byte 8 0))
771(defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
772
773
774(define-fixedsized-object value-cell
775  value)
776
777;;; The kernel uses these (rather generically named) structures
778;;; to keep track of various memory regions it (or the lisp) is
779;;; interested in.
780;;; The gc-area record definition in "ccl:interfaces;mcl-records.lisp"
781;;; matches this.
782
783(define-storage-layout area 0
784  pred                                  ; pointer to preceding area in DLL
785  succ                                  ; pointer to next area in DLL
786  low                                   ; low bound on area addresses
787  high                                  ; high bound on area addresses.
788  active                                ; low limit on stacks, high limit on heaps
789  softlimit                             ; overflow bound
790  hardlimit                             ; another one
791  code                                  ; an area-code; see below
792  markbits                              ; bit vector for GC
793  ndnodes                               ; "active" size of dynamic area or stack
794  older                                 ; in EGC sense
795  younger                               ; also for EGC
796  h                                     ; Handle or null pointer
797  softprot                              ; protected_area structure pointer
798  hardprot                              ; another one.
799  owner                                 ; fragment (library) which "owns" the area
800  refbits                               ; bitvector for intergenerational refernces
801  threshold                             ; for egc
802  gc-count                              ; generational gc count.
803  static-dnodes                         ; for honsing, etc.
804  static-used                           ; bitvector
805)
806
807
808(define-storage-layout protected-area 0
809  next
810  start                                 ; first byte (page-aligned) that might be protected
811  end                                   ; last byte (page-aligned) that could be protected
812  nprot                                 ; Might be 0
813  protsize                              ; number of bytes to protect
814  why)
815
816(defconstant tcr-bias 0)
817
818(define-storage-layout tcr (- tcr-bias)
819  prev                                  ; in doubly-linked list
820  next                                  ; in doubly-linked list
821  lisp-fpscr-high
822  lisp-fpscr-low
823  db-link                               ; special binding chain head
824  catch-top                             ; top catch frame
825  save-vsp                              ; VSP when in foreign code
826  save-tsp                              ; TSP when in foreign code
827  cs-area                               ; cstack area pointer
828  vs-area                               ; vstack area pointer
829  ts-area                               ; tstack area pointer
830  cs-limit                              ; cstack overflow limit
831  total-bytes-allocated-high
832  total-bytes-allocated-low
833  log2-allocation-quantum               ; unboxed
834  interrupt-pending                     ; fixnum
835  xframe                                ; exception frame linked list
836  errno-loc                             ; thread-private, maybe
837  ffi-exception                         ; fpscr bits from ff-call.
838  osid                                  ; OS thread id
839  valence                               ; odd when in foreign code
840  foreign-exception-status
841  native-thread-info
842  native-thread-id
843  last-allocptr
844  save-allocptr
845  save-allocbase
846  reset-completion
847  activate
848  suspend-count
849  suspend-context
850  pending-exception-context
851  suspend                               ; semaphore for suspension notify
852  resume                                ; sempahore for resumption notify
853  flags                                 ; foreign, being reset, ...
854  gc-context
855  termination-semaphore
856  unwinding
857  tlb-limit
858  tlb-pointer
859  shutdown-count
860  safe-ref-address
861)
862
863(defconstant interrupt-level-binding-index (ash 1 fixnumshift))
864
865(define-storage-layout lockptr 0
866  avail
867  owner
868  count
869  signal
870  waiting
871  malloced-ptr
872  spinlock)
873
874(define-storage-layout rwlock 0
875  spin
876  state
877  blocked-writers
878  blocked-readers
879  writer
880  reader-signal
881  writer-signal
882  malloced-ptr
883  )
884
885
886
887(arm::define-storage-layout lisp-frame 0
888  backlink
889  savefn
890  savelr
891  savevsp
892)
893
894
895
896
897(defmacro define-header (name element-count subtag)
898  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
899
900(define-header single-float-header single-float.element-count subtag-single-float)
901(define-header double-float-header double-float.element-count subtag-double-float)
902(define-header one-digit-bignum-header 1 subtag-bignum)
903(define-header two-digit-bignum-header 2 subtag-bignum)
904(define-header three-digit-bignum-header 3 subtag-bignum)
905(define-header symbol-header symbol.element-count subtag-symbol)
906(define-header value-cell-header value-cell.element-count subtag-value-cell)
907(define-header macptr-header macptr.element-count subtag-macptr)
908
909
910)
911
912
913
914
915(defun %kernel-global (sym)
916  ;; Returns index relative to (- nil-value fulltag-nil)
917  (let* ((pos (position sym arm::*arm-kernel-globals* :test #'string=)))
918    (if pos
919      (- (* (1+ pos) 4))
920      (error "Unknown kernel global : ~s ." sym))))
921
922(defmacro kernel-global (sym)
923  (let* ((pos (position sym arm::*arm-kernel-globals* :test #'string=)))
924    (if pos
925      (- (* (1+ pos) 4))
926      (error "Unknown kernel global : ~s ." sym))))
927
928;;; The kernel imports things that are defined in various other
929;;; libraries for us.  The objects in question are generally
930;;; fixnum-tagged; the entries in the "kernel-imports" vector are 4
931;;; bytes apart.
932(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step 4)
933  fd-setsize-bytes
934  do-fd-set
935  do-fd-clr
936  do-fd-is-set
937  do-fd-zero
938  MakeDataExecutable
939  GetSharedLibrary
940  FindSymbol
941  malloc
942  free
943  jvm-init
944  tcr-frame-ptr
945  register-xmacptr-dispose-function
946  open-debug-output
947  get-r-debug
948  restore-soft-stack-limit
949  egc-control
950  lisp-bug
951  NewThread
952  YieldToThread
953  DisposeThread
954  ThreadCurrentStackSpace
955  usage-exit
956  save-fp-context
957  restore-fp-context
958  put-altivec-registers
959  get-altivec-registers
960  new-semaphore
961  wait-on-semaphore
962  signal-semaphore
963  destroy-semaphore
964  new-recursive-lock
965  lock-recursive-lock
966  unlock-recursive-lock
967  destroy-recursive-lock
968  suspend-other-threads
969  resume-other-threads
970  suspend-tcr
971  resume-tcr
972  rwlock-new
973  rwlock-destroy
974  rwlock-rlock
975  rwlock-wlock
976  rwlock-unlock
977  recursive-lock-trylock
978  foreign-name-and-offset
979  lisp-read
980  lisp-write
981  lisp-open
982  lisp-fchmod
983  lisp-lseek
984  lisp-close
985  lisp-ftruncate
986  lisp-stat
987  lisp-fstat
988  lisp-futex
989  lisp-opendir
990  lisp-readdir
991  lisp-closedir
992  lisp-pipe
993  lisp-gettimeofday
994  lisp-sigexit
995)
996
997(defmacro nrs-offset (name)
998  (let* ((pos (position name arm::*arm-nilreg-relative-symbols* :test #'eq)))
999    (if pos (+ t-offset (* pos symbol.size)))))
1000
1001
1002
1003
1004
1005(defmacro with-stack-short-floats (specs &body body)
1006  (ccl::collect ((binds)
1007                 (inits)
1008                 (names))
1009                (dolist (spec specs)
1010                  (let ((name (first spec)))
1011                    (binds `(,name (ccl::%make-sfloat)))
1012                    (names name)
1013                    (let ((init (second spec)))
1014                      (when init
1015                        (inits `(ccl::%short-float ,init ,name))))))
1016                `(let* ,(binds)
1017                  (declare (dynamic-extent ,@(names))
1018                           (short-float ,@(names)))
1019                  ,@(inits)
1020                  ,@body)))
1021
1022(defparameter *arm-target-uvector-subtags*
1023  `((:bignum . ,subtag-bignum)
1024    (:ratio . ,subtag-ratio)
1025    (:single-float . ,subtag-single-float)
1026    (:double-float . ,subtag-double-float)
1027    (:complex . ,subtag-complex  )
1028    (:symbol . ,subtag-symbol)
1029    (:function . ,subtag-function )
1030    (:code-vector . ,subtag-code-vector)
1031    (:xcode-vector . ,subtag-xcode-vector)
1032    (:macptr . ,subtag-macptr )
1033    (:catch-frame . ,subtag-catch-frame)
1034    (:struct . ,subtag-struct )   
1035    (:istruct . ,subtag-istruct )
1036    (:pool . ,subtag-pool )
1037    (:population . ,subtag-weak )
1038    (:hash-vector . ,subtag-hash-vector )
1039    (:package . ,subtag-package )
1040    (:value-cell . ,subtag-value-cell)
1041    (:instance . ,subtag-instance )
1042    (:lock . ,subtag-lock )
1043    (:slot-vector . ,subtag-slot-vector)
1044    (:basic-stream . ,subtag-basic-stream)
1045    (:simple-string . ,subtag-simple-base-string )
1046    (:bit-vector . ,subtag-bit-vector )
1047    (:signed-8-bit-vector . ,subtag-s8-vector )
1048    (:unsigned-8-bit-vector . ,subtag-u8-vector )
1049    (:signed-16-bit-vector . ,subtag-s16-vector )
1050    (:unsigned-16-bit-vector . ,subtag-u16-vector )
1051    (:signed-32-bit-vector . ,subtag-s32-vector )
1052    (:fixnum-vector . ,subtag-fixnum-vector)
1053    (:unsigned-32-bit-vector . ,subtag-u32-vector )
1054    (:single-float-vector . ,subtag-single-float-vector)
1055    (:double-float-vector . ,subtag-double-float-vector )
1056    (:simple-vector . ,subtag-simple-vector )
1057    (:vector-header . ,subtag-vectorH)
1058    (:array-header . ,subtag-arrayH)))
1059
1060
1061;;; This should return NIL unless it's sure of how the indicated
1062;;; type would be represented (in particular, it should return
1063;;; NIL if the element type is unknown or unspecified at compile-time.
1064(defun arm-array-type-name-from-ctype (ctype)
1065  (when (typep ctype 'ccl::array-ctype)
1066    (let* ((element-type (ccl::array-ctype-element-type ctype)))
1067      (typecase element-type
1068        (ccl::class-ctype
1069         (let* ((class (ccl::class-ctype-class element-type)))
1070           (if (or (eq class ccl::*character-class*)
1071                   (eq class ccl::*base-char-class*)
1072                   (eq class ccl::*standard-char-class*))
1073             :simple-string
1074             :simple-vector)))
1075        (ccl::numeric-ctype
1076         (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
1077           :simple-vector
1078           (case (ccl::numeric-ctype-class element-type)
1079             (integer
1080              (let* ((low (ccl::numeric-ctype-low element-type))
1081                     (high (ccl::numeric-ctype-high element-type)))
1082                (cond ((or (null low) (null high)) :simple-vector)
1083                      ((and (>= low 0) (<= high 1) :bit-vector))
1084                      ((and (>= low 0) (<= high 255)) :unsigned-8-bit-vector)
1085                      ((and (>= low 0) (<= high 65535)) :unsigned-16-bit-vector)
1086                      ((and (>= low 0) (<= high #xffffffff) :unsigned-32-bit-vector))
1087                      ((and (>= low -128) (<= high 127)) :signed-8-bit-vector)
1088                      ((and (>= low -32768) (<= high 32767) :signed-16-bit-vector))
1089                      ((and (>= low target-most-negative-fixnum)
1090                            (<= high target-most-positive-fixnum))
1091                       :fixnum-vector)
1092                      ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
1093                       :signed-32-bit-vector)
1094                      (t :simple-vector))))
1095             (float
1096              (case (ccl::numeric-ctype-format element-type)
1097                ((double-float long-float) :double-float-vector)
1098                ((single-float short-float) :single-float-vector)
1099                (t :simple-vector)))
1100             (t :simple-vector))))
1101        (ccl::unknown-ctype)
1102        (ccl::named-ctype
1103         (if (eq element-type ccl::*universal-type*)
1104           :simple-vector))
1105        (t nil)))))
1106       
1107(defun arm-misc-byte-count (subtag element-count)
1108  (declare (fixnum subtag))
1109  (if (or (= fulltag-nodeheader (logand subtag fulltagmask))
1110          (<= subtag max-32-bit-ivector-subtag))
1111    (ash element-count 2)
1112    (if (<= subtag max-8-bit-ivector-subtag)
1113      element-count
1114      (if (<= subtag max-16-bit-ivector-subtag)
1115        (ash element-count 1)
1116        (if (= subtag subtag-bit-vector)
1117          (ash (+ element-count 7) -3)
1118          (+ 4 (ash element-count 3)))))))
1119
1120(defparameter *arm-target-arch*
1121  (arch::make-target-arch :name :arm
1122                          :lisp-node-size 4
1123                          :nil-value canonical-nil-value
1124                          :fixnum-shift fixnumshift
1125                          :most-positive-fixnum (1- (ash 1 (1- (- 32 fixnumshift))))
1126                          :most-negative-fixnum (- (ash 1 (1- (- 32 fixnumshift))))
1127                          :misc-data-offset misc-data-offset
1128                          :misc-dfloat-offset misc-dfloat-offset
1129                          :nbits-in-word 32
1130                          :ntagbits 3
1131                          :nlisptagbits 2
1132                          :uvector-subtags *arm-target-uvector-subtags*
1133                          :max-64-bit-constant-index max-64-bit-constant-index
1134                          :max-32-bit-constant-index max-32-bit-constant-index
1135                          :max-16-bit-constant-index max-16-bit-constant-index
1136                          :max-8-bit-constant-index max-8-bit-constant-index
1137                          :max-1-bit-constant-index max-1-bit-constant-index
1138                          :word-shift 2
1139                          :code-vector-prefix ()
1140                          :gvector-types '(:ratio :complex :symbol :function
1141                                           :catch-frame :struct :istruct
1142                                           :pool :population :hash-vector
1143                                           :package :value-cell :instance
1144                                           :lock :slot-vector
1145                                           :simple-vector)
1146                          :1-bit-ivector-types '(:bit-vector)
1147                          :8-bit-ivector-types '(:signed-8-bit-vector
1148                                                 :unsigned-8-bit-vector)
1149                          :16-bit-ivector-types '(:signed-16-bit-vector
1150                                                  :unsigned-16-bit-vector)
1151                          :32-bit-ivector-types '(:signed-32-bit-vector
1152                                                  :unsigned-32-bit-vector
1153                                                  :single-float-vector
1154                                                  :fixnum-vector
1155                                                  :single-float
1156                                                  :double-float
1157                                                  :bignum
1158                                                  :simple-string)
1159                          :64-bit-ivector-types '(:double-float-vector)
1160                          :array-type-name-from-ctype-function
1161                          #'arm-array-type-name-from-ctype
1162                          :package-name "ARM"
1163                          :t-offset t-offset
1164                          :array-data-size-function #'arm-misc-byte-count
1165                          :numeric-type-name-to-typecode-function
1166                          #'(lambda (type-name)
1167                              (ecase type-name
1168                                (fixnum tag-fixnum)
1169                                (bignum subtag-bignum)
1170                                ((short-float single-float) subtag-single-float)
1171                                ((long-float double-float) subtag-double-float)
1172                                (ratio subtag-ratio)
1173                                (complex subtag-complex)))
1174                          :subprims-base arm::*arm-subprims-base*
1175                          :subprims-shift arm::*arm-subprims-shift*
1176                          :subprims-table arm::*arm-subprims*
1177                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus arm::*arm-subprims*)))
1178                          :unbound-marker-value unbound-marker
1179                          :slot-unbound-marker-value slot-unbound-marker
1180                          :fixnum-tag tag-fixnum
1181                          :single-float-tag subtag-single-float
1182                          :single-float-tag-is-subtag t
1183                          :double-float-tag subtag-double-float
1184                          :cons-tag fulltag-cons
1185                          :null-tag fulltag-nil
1186                          :symbol-tag subtag-symbol
1187                          :symbol-tag-is-subtag t
1188                          :function-tag subtag-function
1189                          :function-tag-is-subtag t
1190                          :big-endian t
1191                          :misc-subtag-offset misc-subtag-offset
1192                          :car-offset cons.car
1193                          :cdr-offset cons.cdr
1194                          :subtag-char subtag-character
1195                          :charcode-shift charcode-shift
1196                          :fulltagmask fulltagmask
1197                          :fulltag-misc fulltag-misc
1198                          :char-code-limit #x110000
1199                          ))
1200
1201;;; arch macros
1202(defmacro defarmarchmacro (name lambda-list &body body)
1203  `(arch::defarchmacro :arm ,name ,lambda-list ,@body))
1204
1205(defarmarchmacro ccl::%make-sfloat ()
1206  `(ccl::%alloc-misc arm::single-float.element-count arm::subtag-single-float))
1207
1208(defarmarchmacro ccl::%make-dfloat ()
1209  `(ccl::%alloc-misc arm::double-float.element-count arm::subtag-double-float))
1210
1211(defarmarchmacro ccl::%numerator (x)
1212  `(ccl::%svref ,x arm::ratio.numer-cell))
1213
1214(defarmarchmacro ccl::%denominator (x)
1215  `(ccl::%svref ,x arm::ratio.denom-cell))
1216
1217(defarmarchmacro ccl::%realpart (x)
1218  `(ccl::%svref ,x arm::complex.realpart-cell))
1219                   
1220(defarmarchmacro ccl::%imagpart (x)
1221  `(ccl::%svref ,x arm::complex.imagpart-cell))
1222
1223;;;
1224(defarmarchmacro ccl::%get-single-float-from-double-ptr (ptr offset)
1225 `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)
1226   (ccl::%alloc-misc 1 arm::subtag-single-float)))
1227
1228(defarmarchmacro ccl::codevec-header-p (word)
1229  `(eql arm::subtag-code-vector
1230    (logand ,word arm::subtag-mask)))
1231
1232(defarmarchmacro ccl::immediate-p-macro (thing)
1233  (let* ((tag (gensym)))
1234    `(let* ((,tag (ccl::lisptag ,thing)))
1235      (declare (fixnum ,tag))
1236      (or (= ,tag arm::tag-fixnum)
1237       (= ,tag arm::tag-imm)))))
1238
1239(defarmarchmacro ccl::hashed-by-identity (thing)
1240  (let* ((typecode (gensym)))
1241    `(let* ((,typecode (ccl::typecode ,thing)))
1242      (declare (fixnum ,typecode))
1243      (or
1244       (= ,typecode arm::tag-fixnum)
1245       (= ,typecode arm::tag-imm)
1246       (= ,typecode arm::subtag-symbol)
1247       (= ,typecode arm::subtag-instance)))))
1248
1249;;;
1250(defarmarchmacro ccl::%get-kernel-global (name)
1251  `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value)
1252                        ,(%kernel-global
1253                          (if (ccl::quoted-form-p name)
1254                            (cadr name)
1255                            name)))))
1256
1257(defarmarchmacro ccl::%get-kernel-global-ptr (name dest)
1258  `(ccl::%setf-macptr
1259    ,dest
1260    (ccl::%fixnum-ref-macptr 0 (+ ,(ccl::target-nil-value)
1261                                ,(%kernel-global
1262                                  (if (ccl::quoted-form-p name)
1263                                    (cadr name)
1264                                    name))))))
1265
1266(defarmarchmacro ccl::%target-kernel-global (name)
1267  `(arm::%kernel-global ,name))
1268
1269(defarmarchmacro ccl::lfun-vector (fun)
1270  fun)
1271
1272(defarmarchmacro ccl::lfun-vector-lfun (lfv)
1273  lfv)
1274
1275(defarmarchmacro ccl::area-code ()
1276  area.code)
1277
1278(defarmarchmacro ccl::area-succ ()
1279  area.succ)
1280
1281(defarmarchmacro ccl::nth-immediate (f i)
1282  `(ccl::%svref ,f ,i))
1283
1284(defarmarchmacro ccl::set-nth-immediate (f i new)
1285  `(setf (ccl::%svref ,f ,i) ,new))
1286
1287(defarmarchmacro ccl::symptr->symvector (s)
1288  s)
1289
1290(defarmarchmacro ccl::symvector->symptr (s)
1291  s)
1292
1293(defarmarchmacro ccl::function-to-function-vector (f)
1294  f)
1295
1296(defarmarchmacro ccl::function-vector-to-function (v)
1297  v)
1298
1299(defarmarchmacro ccl::with-ffcall-results ((buf) &body body)
1300  (let* ((size (+ (* 8 4) (* 31 8))))
1301    `(%stack-block ((,buf ,size))
1302      ,@body)))
1303
1304(defconstant arg-check-trap-pc-limit 8)
1305
1306;;; UUO encoding
1307(defconstant uuo-format-nullary 0)      ; 12 bits of code
1308(defconstant uuo-format-unary 1)        ; 8 bits of info - NOT type info - 4-bit reg
1309(defconstant uuo-format-error-lisptag 2) ; 2 bits of lisptag info, 4-bit reg
1310(defconstant uuo-format-error-fulltag 3) ; 3 bits of fulltag info, 4 bit reg
1311
1312(defconstant uuo-format-error-xtype 4)  ; 8 bits of extended type/subtag info, 4 bit reg
1313(defconstant uuo-format-cerror-lisptag 10) ; continuable, lisptag, reg
1314(defconstant uuo-format-cerror-fulltag 11) ; continuable, fulltag, reg
1315(defconstant uuo-format-cerror-xtype 12) ; continuable, xtype, reg         
1316(defconstant uuo-format-binary 15)      ;  4 bits of code, r1, r0
1317
1318;;; xtypes: 8-bit integers used to report type errors for types that can't
1319;;; be represented via tags.
1320
1321(defconstant xtype-unsigned-byte-24  252)
1322(defconstant xtype-array2d  248)
1323(defconstant xtype-array3d  244)
1324(defconstant xtype-integer  4)
1325(defconstant xtype-s64  8)
1326(defconstant xtype-u64  12)
1327(defconstant xtype-s32  16)
1328(defconstant xtype-u32  20)
1329(defconstant xtype-s16  24)
1330(defconstant xtype-u16  28)
1331(defconstant xtype-s8  32)
1332(defconstant xtype-u8  36)
1333(defconstant xtype-bit  40)
1334(defconstant xtype-rational 44)
1335(defconstant xtype-real 48)
1336(defconstant xtype-number 52)
1337(defconstant xtype-char-code 56)
1338
1339;;; Condition field values.
1340(ccl::defenum (:prefix "ARM-COND-")
1341  eq
1342  ne
1343  hs
1344  lo
1345  mi
1346  pl
1347  vs
1348  vc
1349  hi
1350  ls
1351  ge
1352  lt
1353  gt
1354  le
1355  al)
1356
1357 
1358(provide "ARM-ARCH")
Note: See TracBrowser for help on using the repository browser.