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

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

Subprim juggling, double-float endianness.

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