source: trunk/source/compiler/ARM/arm-arch.lisp @ 15196

Last change on this file since 15196 was 15196, checked in by gb, 8 years ago

Rename a couple of (unused) nil-relative-symbols. No bootstrapping issues
(yet, modulo any typos), but there may be when we start to use them.

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