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

Last change on this file since 13715 was 13715, checked in by gb, 10 years ago

And we need to continue to tweak those mechanisms.

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