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

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

The point of the checkpoint in the last commit: change nil_value on ARM
from #x10000005 to #x04000001. That obviously means that we invert
arm::fulltag-cons and arm::fulltag-nil, and change a few things (the link-
inverting marker, the LISTP compiler-macro) that were more sensitive to
that than they probably should have been.

OTOH, we get ~192M more address space to play with.

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