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

Last change on this file since 13832 was 13832, checked in by gb, 11 years ago

%GET-KERNEL-GLOBAL, %GET-KERNEL-GLOBAL-MACPTR changes. (Might be
able to ref from 0, but need to use (- arm::nil arm::fulltag-nil.)

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