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

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

Lots of changes and additions. Seems to work, as far as it goes: still
some missing functionality and likely some bugs, but I don't think that
either of those issues will require massive redesign to address.

File size: 47.0 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 tstack; they point to a minimal lisp-frame
661;;; on the cstack.  (The catch/unwind-protect PC is on the cstack, where
662;;; the GC expects to find it.)
663(define-fixedsized-object catch-frame
664  catch-tag                             ; #<unbound> -> unwind-protect, else catch
665  link                                  ; tagged pointer to next older catch frame
666  mvflag                                ; 0 if single-value, 1 if uwp or multiple-value
667  db-link                               ; value of dynamic-binding link on thread entry.
668  xframe                                ; exception-frame link
669
670)
671
672(define-fixedsized-object lock
673  _value                                ;finalizable pointer to kernel object
674  kind                                  ; '0 = recursive-lock, '1 = rwlock
675  writer                                ;tcr of owning thread or 0
676  name
677  whostate
678  whostate-2
679  )
680
681
682
683(define-fixedsized-object symbol
684  pname
685  vcell
686  fcell
687  package-predicate
688  flags
689  plist
690  binding-index
691)
692
693(define-fixedsized-object function
694  entrypoint
695  codevector
696  )
697
698
699
700
701(defconstant nilsym-offset (+ t-offset symbol.size))
702
703
704(define-fixedsized-object vectorH
705  logsize                               ; fillpointer if it has one, physsize otherwise
706  physsize                              ; total size of (possibly displaced) data vector
707  data-vector                           ; object this header describes
708  displacement                          ; true displacement or 0
709  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
710)
711
712(define-lisp-object arrayH fulltag-misc
713  header                                ; subtag = subtag-arrayH
714  rank                                  ; NEVER 1
715  physsize                              ; total size of (possibly displaced) data vector
716  data-vector                           ; object this header describes
717  displacement                          ; true displacement or 0 
718  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
719 ;; Dimensions follow
720)
721
722(defconstant arrayH.rank-cell 0)
723(defconstant arrayH.physsize-cell 1)
724(defconstant arrayH.data-vector-cell 2)
725(defconstant arrayH.displacement-cell 3)
726(defconstant arrayH.flags-cell 4)
727(defconstant arrayH.dim0-cell 5)
728
729(defconstant arrayH.flags-cell-bits-byte (byte 8 0))
730(defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
731
732
733(define-fixedsized-object value-cell
734  value)
735
736;;; The kernel uses these (rather generically named) structures
737;;; to keep track of various memory regions it (or the lisp) is
738;;; interested in.
739;;; The gc-area record definition in "ccl:interfaces;mcl-records.lisp"
740;;; matches this.
741
742(define-storage-layout area 0
743  pred                                  ; pointer to preceding area in DLL
744  succ                                  ; pointer to next area in DLL
745  low                                   ; low bound on area addresses
746  high                                  ; high bound on area addresses.
747  active                                ; low limit on stacks, high limit on heaps
748  softlimit                             ; overflow bound
749  hardlimit                             ; another one
750  code                                  ; an area-code; see below
751  markbits                              ; bit vector for GC
752  ndnodes                               ; "active" size of dynamic area or stack
753  older                                 ; in EGC sense
754  younger                               ; also for EGC
755  h                                     ; Handle or null pointer
756  softprot                              ; protected_area structure pointer
757  hardprot                              ; another one.
758  owner                                 ; fragment (library) which "owns" the area
759  refbits                               ; bitvector for intergenerational refernces
760  threshold                             ; for egc
761  gc-count                              ; generational gc count.
762  static-dnodes                         ; for honsing, etc.
763  static-used                           ; bitvector
764)
765
766
767(define-storage-layout protected-area 0
768  next
769  start                                 ; first byte (page-aligned) that might be protected
770  end                                   ; last byte (page-aligned) that could be protected
771  nprot                                 ; Might be 0
772  protsize                              ; number of bytes to protect
773  why)
774
775(defconstant tcr-bias 0)
776
777(define-storage-layout tcr (- tcr-bias)
778  prev                                  ; in doubly-linked list
779  next                                  ; in doubly-linked list
780  lisp-fpscr-high
781  lisp-fpscr-low
782  db-link                               ; special binding chain head
783  catch-top                             ; top catch frame
784  save-vsp                              ; VSP when in foreign code
785  save-tsp                              ; TSP when in foreign code
786  cs-area                               ; cstack area pointer
787  vs-area                               ; vstack area pointer
788  ts-area                               ; tstack area pointer
789  cs-limit                              ; cstack overflow limit
790  total-bytes-allocated-high
791  total-bytes-allocated-low
792  log2-allocation-quantum               ; unboxed
793  interrupt-pending                     ; fixnum
794  xframe                                ; exception frame linked list
795  errno-loc                             ; thread-private, maybe
796  ffi-exception                         ; fpscr bits from ff-call.
797  osid                                  ; OS thread id
798  valence                               ; odd when in foreign code
799  foreign-exception-status
800  native-thread-info
801  native-thread-id
802  last-allocptr
803  save-allocptr
804  save-allocbase
805  reset-completion
806  activate
807  suspend-count
808  suspend-context
809  pending-exception-context
810  suspend                               ; semaphore for suspension notify
811  resume                                ; sempahore for resumption notify
812  flags                                 ; foreign, being reset, ...
813  gc-context
814  termination-semaphore
815  unwinding
816  tlb-limit
817  tlb-pointer
818  shutdown-count
819  safe-ref-address
820)
821
822(defconstant interrupt-level-binding-index (ash 1 fixnumshift))
823
824(define-storage-layout lockptr 0
825  avail
826  owner
827  count
828  signal
829  waiting
830  malloced-ptr
831  spinlock)
832
833(define-storage-layout rwlock 0
834  spin
835  state
836  blocked-writers
837  blocked-readers
838  writer
839  reader-signal
840  writer-signal
841  malloced-ptr
842  )
843
844
845
846(arm::define-storage-layout lisp-frame 0
847  backlink
848  savefn
849  savelr
850  savevsp
851)
852
853
854
855
856(defmacro define-header (name element-count subtag)
857  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
858
859(define-header single-float-header single-float.element-count subtag-single-float)
860(define-header double-float-header double-float.element-count subtag-double-float)
861(define-header one-digit-bignum-header 1 subtag-bignum)
862(define-header two-digit-bignum-header 2 subtag-bignum)
863(define-header three-digit-bignum-header 3 subtag-bignum)
864(define-header symbol-header symbol.element-count subtag-symbol)
865(define-header value-cell-header value-cell.element-count subtag-value-cell)
866(define-header macptr-header macptr.element-count subtag-macptr)
867
868
869)
870
871
872
873
874(defun %kernel-global (sym)
875  ;; Returns index relative to (- nil-value fulltag-nil)
876  (let* ((pos (position sym arm::*arm-kernel-globals* :test #'string=)))
877    (if pos
878      (- (* (1+ pos) 4))
879      (error "Unknown kernel global : ~s ." sym))))
880
881(defmacro kernel-global (sym)
882  (let* ((pos (position sym arm::*arm-kernel-globals* :test #'string=)))
883    (if pos
884      (- (* (1+ pos) 4))
885      (error "Unknown kernel global : ~s ." sym))))
886
887;;; The kernel imports things that are defined in various other
888;;; libraries for us.  The objects in question are generally
889;;; fixnum-tagged; the entries in the "kernel-imports" vector are 4
890;;; bytes apart.
891(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step 4)
892  fd-setsize-bytes
893  do-fd-set
894  do-fd-clr
895  do-fd-is-set
896  do-fd-zero
897  MakeDataExecutable
898  GetSharedLibrary
899  FindSymbol
900  malloc
901  free
902  jvm-init
903  tcr-frame-ptr
904  register-xmacptr-dispose-function
905  open-debug-output
906  get-r-debug
907  restore-soft-stack-limit
908  egc-control
909  lisp-bug
910  NewThread
911  YieldToThread
912  DisposeThread
913  ThreadCurrentStackSpace
914  usage-exit
915  save-fp-context
916  restore-fp-context
917  put-altivec-registers
918  get-altivec-registers
919  new-semaphore
920  wait-on-semaphore
921  signal-semaphore
922  destroy-semaphore
923  new-recursive-lock
924  lock-recursive-lock
925  unlock-recursive-lock
926  destroy-recursive-lock
927  suspend-other-threads
928  resume-other-threads
929  suspend-tcr
930  resume-tcr
931  rwlock-new
932  rwlock-destroy
933  rwlock-rlock
934  rwlock-wlock
935  rwlock-unlock
936  recursive-lock-trylock
937  foreign-name-and-offset
938  lisp-read
939  lisp-write
940  lisp-open
941  lisp-fchmod
942  lisp-lseek
943  lisp-close
944  lisp-ftruncate
945  lisp-stat
946  lisp-fstat
947  lisp-futex
948  lisp-opendir
949  lisp-readdir
950  lisp-closedir
951  lisp-pipe
952  lisp-gettimeofday
953  lisp-sigexit
954)
955
956(defmacro nrs-offset (name)
957  (let* ((pos (position name arm::*arm-nilreg-relative-symbols* :test #'eq)))
958    (if pos (+ t-offset (* pos symbol.size)))))
959
960
961
962
963
964(defmacro with-stack-short-floats (specs &body body)
965  (ccl::collect ((binds)
966                 (inits)
967                 (names))
968                (dolist (spec specs)
969                  (let ((name (first spec)))
970                    (binds `(,name (ccl::%make-sfloat)))
971                    (names name)
972                    (let ((init (second spec)))
973                      (when init
974                        (inits `(ccl::%short-float ,init ,name))))))
975                `(let* ,(binds)
976                  (declare (dynamic-extent ,@(names))
977                           (short-float ,@(names)))
978                  ,@(inits)
979                  ,@body)))
980
981(defparameter *arm-target-uvector-subtags*
982  `((:bignum . ,subtag-bignum)
983    (:ratio . ,subtag-ratio)
984    (:single-float . ,subtag-single-float)
985    (:double-float . ,subtag-double-float)
986    (:complex . ,subtag-complex  )
987    (:symbol . ,subtag-symbol)
988    (:function . ,subtag-function )
989    (:code-vector . ,subtag-code-vector)
990    (:xcode-vector . ,subtag-xcode-vector)
991    (:macptr . ,subtag-macptr )
992    (:catch-frame . ,subtag-catch-frame)
993    (:struct . ,subtag-struct )   
994    (:istruct . ,subtag-istruct )
995    (:pool . ,subtag-pool )
996    (:population . ,subtag-weak )
997    (:hash-vector . ,subtag-hash-vector )
998    (:package . ,subtag-package )
999    (:value-cell . ,subtag-value-cell)
1000    (:instance . ,subtag-instance )
1001    (:lock . ,subtag-lock )
1002    (:slot-vector . ,subtag-slot-vector)
1003    (:basic-stream . ,subtag-basic-stream)
1004    (:simple-string . ,subtag-simple-base-string )
1005    (:bit-vector . ,subtag-bit-vector )
1006    (:signed-8-bit-vector . ,subtag-s8-vector )
1007    (:unsigned-8-bit-vector . ,subtag-u8-vector )
1008    (:signed-16-bit-vector . ,subtag-s16-vector )
1009    (:unsigned-16-bit-vector . ,subtag-u16-vector )
1010    (:signed-32-bit-vector . ,subtag-s32-vector )
1011    (:fixnum-vector . ,subtag-fixnum-vector)
1012    (:unsigned-32-bit-vector . ,subtag-u32-vector )
1013    (:single-float-vector . ,subtag-single-float-vector)
1014    (:double-float-vector . ,subtag-double-float-vector )
1015    (:simple-vector . ,subtag-simple-vector )
1016    (:vector-header . ,subtag-vectorH)
1017    (:array-header . ,subtag-arrayH)))
1018
1019
1020;;; This should return NIL unless it's sure of how the indicated
1021;;; type would be represented (in particular, it should return
1022;;; NIL if the element type is unknown or unspecified at compile-time.
1023(defun arm-array-type-name-from-ctype (ctype)
1024  (when (typep ctype 'ccl::array-ctype)
1025    (let* ((element-type (ccl::array-ctype-element-type ctype)))
1026      (typecase element-type
1027        (ccl::class-ctype
1028         (let* ((class (ccl::class-ctype-class element-type)))
1029           (if (or (eq class ccl::*character-class*)
1030                   (eq class ccl::*base-char-class*)
1031                   (eq class ccl::*standard-char-class*))
1032             :simple-string
1033             :simple-vector)))
1034        (ccl::numeric-ctype
1035         (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
1036           :simple-vector
1037           (case (ccl::numeric-ctype-class element-type)
1038             (integer
1039              (let* ((low (ccl::numeric-ctype-low element-type))
1040                     (high (ccl::numeric-ctype-high element-type)))
1041                (cond ((or (null low) (null high)) :simple-vector)
1042                      ((and (>= low 0) (<= high 1) :bit-vector))
1043                      ((and (>= low 0) (<= high 255)) :unsigned-8-bit-vector)
1044                      ((and (>= low 0) (<= high 65535)) :unsigned-16-bit-vector)
1045                      ((and (>= low 0) (<= high #xffffffff) :unsigned-32-bit-vector))
1046                      ((and (>= low -128) (<= high 127)) :signed-8-bit-vector)
1047                      ((and (>= low -32768) (<= high 32767) :signed-16-bit-vector))
1048                      ((and (>= low target-most-negative-fixnum)
1049                            (<= high target-most-positive-fixnum))
1050                       :fixnum-vector)
1051                      ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
1052                       :signed-32-bit-vector)
1053                      (t :simple-vector))))
1054             (float
1055              (case (ccl::numeric-ctype-format element-type)
1056                ((double-float long-float) :double-float-vector)
1057                ((single-float short-float) :single-float-vector)
1058                (t :simple-vector)))
1059             (t :simple-vector))))
1060        (ccl::unknown-ctype)
1061        (ccl::named-ctype
1062         (if (eq element-type ccl::*universal-type*)
1063           :simple-vector))
1064        (t nil)))))
1065       
1066(defun arm-misc-byte-count (subtag element-count)
1067  (declare (fixnum subtag))
1068  (if (or (= fulltag-nodeheader (logand subtag fulltagmask))
1069          (<= subtag max-32-bit-ivector-subtag))
1070    (ash element-count 2)
1071    (if (<= subtag max-8-bit-ivector-subtag)
1072      element-count
1073      (if (<= subtag max-16-bit-ivector-subtag)
1074        (ash element-count 1)
1075        (if (= subtag subtag-bit-vector)
1076          (ash (+ element-count 7) -3)
1077          (+ 4 (ash element-count 3)))))))
1078
1079(defparameter *arm-target-arch*
1080  (arch::make-target-arch :name :arm
1081                          :lisp-node-size 4
1082                          :nil-value canonical-nil-value
1083                          :fixnum-shift fixnumshift
1084                          :most-positive-fixnum (1- (ash 1 (1- (- 32 fixnumshift))))
1085                          :most-negative-fixnum (- (ash 1 (1- (- 32 fixnumshift))))
1086                          :misc-data-offset misc-data-offset
1087                          :misc-dfloat-offset misc-dfloat-offset
1088                          :nbits-in-word 32
1089                          :ntagbits 3
1090                          :nlisptagbits 2
1091                          :uvector-subtags *arm-target-uvector-subtags*
1092                          :max-64-bit-constant-index max-64-bit-constant-index
1093                          :max-32-bit-constant-index max-32-bit-constant-index
1094                          :max-16-bit-constant-index max-16-bit-constant-index
1095                          :max-8-bit-constant-index max-8-bit-constant-index
1096                          :max-1-bit-constant-index max-1-bit-constant-index
1097                          :word-shift 2
1098                          :code-vector-prefix ()
1099                          :gvector-types '(:ratio :complex :symbol :function
1100                                           :catch-frame :struct :istruct
1101                                           :pool :population :hash-vector
1102                                           :package :value-cell :instance
1103                                           :lock :slot-vector
1104                                           :simple-vector)
1105                          :1-bit-ivector-types '(:bit-vector)
1106                          :8-bit-ivector-types '(:signed-8-bit-vector
1107                                                 :unsigned-8-bit-vector)
1108                          :16-bit-ivector-types '(:signed-16-bit-vector
1109                                                  :unsigned-16-bit-vector)
1110                          :32-bit-ivector-types '(:signed-32-bit-vector
1111                                                  :unsigned-32-bit-vector
1112                                                  :single-float-vector
1113                                                  :fixnum-vector
1114                                                  :single-float
1115                                                  :double-float
1116                                                  :bignum
1117                                                  :simple-string)
1118                          :64-bit-ivector-types '(:double-float-vector)
1119                          :array-type-name-from-ctype-function
1120                          #'arm-array-type-name-from-ctype
1121                          :package-name "ARM"
1122                          :t-offset t-offset
1123                          :array-data-size-function #'arm-misc-byte-count
1124                          :numeric-type-name-to-typecode-function
1125                          #'(lambda (type-name)
1126                              (ecase type-name
1127                                (fixnum tag-fixnum)
1128                                (bignum subtag-bignum)
1129                                ((short-float single-float) subtag-single-float)
1130                                ((long-float double-float) subtag-double-float)
1131                                (ratio subtag-ratio)
1132                                (complex subtag-complex)))
1133                          :subprims-base arm::*arm-subprims-base*
1134                          :subprims-shift arm::*arm-subprims-shift*
1135                          :subprims-table arm::*arm-subprims*
1136                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus arm::*arm-subprims*)))
1137                          :unbound-marker-value unbound-marker
1138                          :slot-unbound-marker-value slot-unbound-marker
1139                          :fixnum-tag tag-fixnum
1140                          :single-float-tag subtag-single-float
1141                          :single-float-tag-is-subtag t
1142                          :double-float-tag subtag-double-float
1143                          :cons-tag fulltag-cons
1144                          :null-tag fulltag-nil
1145                          :symbol-tag subtag-symbol
1146                          :symbol-tag-is-subtag t
1147                          :function-tag subtag-function
1148                          :function-tag-is-subtag t
1149                          :big-endian t
1150                          :misc-subtag-offset misc-subtag-offset
1151                          :car-offset cons.car
1152                          :cdr-offset cons.cdr
1153                          :subtag-char subtag-character
1154                          :charcode-shift charcode-shift
1155                          :fulltagmask fulltagmask
1156                          :fulltag-misc fulltag-misc
1157                          :char-code-limit #x110000
1158                          ))
1159
1160;;; arch macros
1161(defmacro defarmarchmacro (name lambda-list &body body)
1162  `(arch::defarchmacro :arm ,name ,lambda-list ,@body))
1163
1164(defarmarchmacro ccl::%make-sfloat ()
1165  `(ccl::%alloc-misc arm::single-float.element-count arm::subtag-single-float))
1166
1167(defarmarchmacro ccl::%make-dfloat ()
1168  `(ccl::%alloc-misc arm::double-float.element-count arm::subtag-double-float))
1169
1170(defarmarchmacro ccl::%numerator (x)
1171  `(ccl::%svref ,x arm::ratio.numer-cell))
1172
1173(defarmarchmacro ccl::%denominator (x)
1174  `(ccl::%svref ,x arm::ratio.denom-cell))
1175
1176(defarmarchmacro ccl::%realpart (x)
1177  `(ccl::%svref ,x arm::complex.realpart-cell))
1178                   
1179(defarmarchmacro ccl::%imagpart (x)
1180  `(ccl::%svref ,x arm::complex.imagpart-cell))
1181
1182;;;
1183(defarmarchmacro ccl::%get-single-float-from-double-ptr (ptr offset)
1184 `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)
1185   (ccl::%alloc-misc 1 arm::subtag-single-float)))
1186
1187(defarmarchmacro ccl::codevec-header-p (word)
1188  `(eql arm::subtag-code-vector
1189    (logand ,word arm::subtag-mask)))
1190
1191(defarmarchmacro ccl::immediate-p-macro (thing)
1192  (let* ((tag (gensym)))
1193    `(let* ((,tag (ccl::lisptag ,thing)))
1194      (declare (fixnum ,tag))
1195      (or (= ,tag arm::tag-fixnum)
1196       (= ,tag arm::tag-imm)))))
1197
1198(defarmarchmacro ccl::hashed-by-identity (thing)
1199  (let* ((typecode (gensym)))
1200    `(let* ((,typecode (ccl::typecode ,thing)))
1201      (declare (fixnum ,typecode))
1202      (or
1203       (= ,typecode arm::tag-fixnum)
1204       (= ,typecode arm::tag-imm)
1205       (= ,typecode arm::subtag-symbol)
1206       (= ,typecode arm::subtag-instance)))))
1207
1208;;;
1209(defarmarchmacro ccl::%get-kernel-global (name)
1210  `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value)
1211                        ,(%kernel-global
1212                          (if (ccl::quoted-form-p name)
1213                            (cadr name)
1214                            name)))))
1215
1216(defarmarchmacro ccl::%get-kernel-global-ptr (name dest)
1217  `(ccl::%setf-macptr
1218    ,dest
1219    (ccl::%fixnum-ref-macptr 0 (+ ,(ccl::target-nil-value)
1220                                ,(%kernel-global
1221                                  (if (ccl::quoted-form-p name)
1222                                    (cadr name)
1223                                    name))))))
1224
1225(defarmarchmacro ccl::%target-kernel-global (name)
1226  `(arm::%kernel-global ,name))
1227
1228(defarmarchmacro ccl::lfun-vector (fun)
1229  fun)
1230
1231(defarmarchmacro ccl::lfun-vector-lfun (lfv)
1232  lfv)
1233
1234(defarmarchmacro ccl::area-code ()
1235  area.code)
1236
1237(defarmarchmacro ccl::area-succ ()
1238  area.succ)
1239
1240(defarmarchmacro ccl::nth-immediate (f i)
1241  `(ccl::%svref ,f ,i))
1242
1243(defarmarchmacro ccl::set-nth-immediate (f i new)
1244  `(setf (ccl::%svref ,f ,i) ,new))
1245
1246(defarmarchmacro ccl::symptr->symvector (s)
1247  s)
1248
1249(defarmarchmacro ccl::symvector->symptr (s)
1250  s)
1251
1252(defarmarchmacro ccl::function-to-function-vector (f)
1253  f)
1254
1255(defarmarchmacro ccl::function-vector-to-function (v)
1256  v)
1257
1258(defarmarchmacro ccl::with-ffcall-results ((buf) &body body)
1259  (let* ((size (+ (* 8 4) (* 31 8))))
1260    `(%stack-block ((,buf ,size))
1261      ,@body)))
1262
1263(defconstant arg-check-trap-pc-limit 8)
1264
1265;;; UUO encoding
1266(defconstant uuo-format-nullary 0)      ; 12 bits of code
1267(defconstant uuo-format-unary 1)        ; 8 bits of info - NOT type info - 4-bit reg
1268(defconstant uuo-format-error-lisptag 2) ; 2 bits of lisptag info, 4-bit reg
1269(defconstant uuo-format-error-fulltag 3) ; 3 bits of fulltag info, 4 bit reg
1270
1271(defconstant uuo-format-error-xtype 4)  ; 8 bits of extended type/subtag info, 4 bit reg
1272(defconstant uuo-format-cerror-lisptag 10) ; continuable, lisptag, reg
1273(defconstant uuo-format-cerror-fulltag 11) ; continuable, fulltag, reg
1274(defconstant uuo-format-cerror-xtype 12) ; continuable, xtype, reg         
1275(defconstant uuo-format-binary 15)      ;  4 bits of code, r1, r0
1276
1277;;; xtypes: 8-bit integers used to report type errors for types that can't
1278;;; be represented via tags.
1279
1280(defconstant xtype-unsigned-byte-24  252)
1281(defconstant xtype-array2d  248)
1282(defconstant xtype-array3d  244)
1283(defconstant xtype-integer  4)
1284(defconstant xtype-s64  8)
1285(defconstant xtype-u64  12)
1286(defconstant xtype-s32  16)
1287(defconstant xtype-u32  20)
1288(defconstant xtype-s16  24)
1289(defconstant xtype-u16  28)
1290(defconstant xtype-s8  32)
1291(defconstant xtype-u8  36)
1292(defconstant xtype-bit  40)                               
1293
1294 
1295(provide "ARM-ARCH")
Note: See TracBrowser for help on using the repository browser.