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

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

arm-arch.lisp: get ARM::MAX-64-BIT-CONSTANT-INDEX right for the

(relatively) new order.

arm2.lisp: arm2-vref1,arm2-vset1: use 255 for max constant index for

single-float-vector

arm2-reg-for-form: make sure that single-/double-float-zero is a
register-spec

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