Index: anches/arm/level-0/ARM/arm-utils.lisp
===================================================================
--- /branches/arm/level-0/ARM/arm-utils.lisp	(revision 13786)
+++ 	(revision )
@@ -1,526 +1,0 @@
-;;; -*- Mode: Lisp; Package: CCL; -*-
-;;;
-;;;   Copyright (C) 2010 Clozure Associates
-;;;   This file is part of Clozure CL.  
-;;;
-;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
-;;;   License , known as the LLGPL and distributed with Clozure CL as the
-;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
-;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
-;;;   conflict, the preamble takes precedence.  
-;;;
-;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
-;;;
-;;;   The LLGPL is also available online at
-;;;   http://opensource.franz.com/preamble.html
-
-
-(in-package "CCL")
-
-(defppclapfunction %address-of ((arg arg_z))
-  ;; %address-of a fixnum is a fixnum, just for spite.
-  ;; %address-of anything else is the address of that thing as an integer.
-  (clrlwi. imm0 arg (- 32 ppc32::nlisptagbits))
-  (beqlr cr0)
-  (mr imm0 arg_z)
-  ;; set cr0_eq if result fits in a fixnum
-  (clrrwi. imm1 imm0 (- ppc32::least-significant-bit ppc32::nfixnumtagbits))
-  (box-fixnum arg_z imm0)               ; assume it did
-  (beqlr+ cr0)                          ; else arg_z tagged ok, but missing bits
-  (ba .SPmakeu32)         ; put all bits in bignum.
-)
-
-
-
-;;; "areas" are fixnum-tagged and, for the most part, so are their
-;;; contents.
-
-;;; The nilreg-relative global all-areas is a doubly-linked-list header
-;;; that describes nothing.  Its successor describes the current/active
-;;; dynamic heap.  Return a fixnum which "points to" that area, after
-;;; ensuring that the "active" pointers associated with the current thread's
-;;; stacks are correct.
-
-
-
-(defppclapfunction %normalize-areas ()
-  (let ((address imm0)
-        (temp imm2))
-
-    ; update active pointer for tsp area.
-    (ldr address target::tcr.ts-area target::rcontext)
-    (str tsp target::area.active address)
-    
-    ;; Update active pointer for vsp area.
-    (ldr address target::tcr.vs-area target::rcontext)
-    (str vsp target::area.active address)
-    
-    ; Update active pointer for SP area
-    (ldr arg_z target::tcr.cs-area target::rcontext)
-    (str sp target::area.active arg_z)
-
-
-    (ref-global arg_z all-areas)
-    (ldr arg_z target::area.succ arg_z)
-
-    (blr)))
-
-(defppclapfunction %active-dynamic-area ()
-  (ref-global arg_z all-areas)
-  (ldr arg_z target::area.succ arg_z)
-  (blr))
-
-  
-(defppclapfunction %object-in-stack-area-p ((object arg_y) (area arg_z))
-  (ldr imm0 target::area.active area)
-  (cmplr cr0 object imm0)
-  (ldr imm1 target::area.high area)
-  (cmplr cr1 object imm1)
-  (li arg_z nil)
-  (bltlr cr0)
-  (bgelr cr1)
-  (la arg_z target::t-offset arg_z)
-  (blr))
-
-(defppclapfunction %object-in-heap-area-p ((object arg_y) (area arg_z))
-  (ldr imm0 target::area.low area)
-  (cmplr cr0 object imm0)
-  (ldr imm1 target::area.active area)
-  (cmplr cr1 object imm1)
-  (li arg_z nil)
-  (bltlr cr0)
-  (bgelr cr1)
-  (la arg_z target::t-offset arg_z)
-  (blr))
-
-
-#+ppc32-target
-(defppclapfunction walk-static-area ((a arg_y) (f arg_z))
-  (let ((fun save0)
-        (obj save1)
-        (limit save2)
-        (header imm0)
-        (tag imm1)
-        (subtag imm2)
-        (bytes imm3)
-        (elements imm0))
-    (save-lisp-context)
-    (:regsave limit 0)
-    (vpush fun)
-    (vpush obj)
-    (vpush limit)
-    (mr fun f)
-    (lwz limit ppc32::area.active a)
-    (lwz obj ppc32::area.low a)
-    (b @test)
-    @loop
-    (lwz header 0 obj)
-    (extract-fulltag tag header)
-    (cmpwi cr0 tag ppc32::fulltag-immheader)
-    (cmpwi cr1 tag ppc32::fulltag-nodeheader)
-    (beq cr0 @misc)
-    (beq cr1 @misc)
-    (la arg_z ppc32::fulltag-cons obj)
-    (set-nargs 1)
-    (mr temp0 fun)
-    (bla .SPFuncall)
-    (la obj ppc32::cons.size obj)
-    (b @test)
-    @misc
-    (la arg_z ppc32::fulltag-misc obj)
-    (set-nargs 1)
-    (mr temp0 fun)
-    (bla .SPFuncall)
-    (lwz header 0 obj)
-    (extract-fulltag tag header)
-    (cmpwi cr1 tag ppc32::fulltag-nodeheader)
-    (clrlwi subtag header (- 32 ppc32::num-subtag-bits))
-    (cmpwi cr2 subtag ppc32::max-32-bit-ivector-subtag)
-    (cmpwi cr3 subtag ppc32::max-8-bit-ivector-subtag)
-    (cmpwi cr4 subtag ppc32::max-16-bit-ivector-subtag)
-    (cmpwi cr5 subtag ppc32::subtag-double-float-vector)
-    (header-size elements header)
-    (slwi bytes elements 2)
-    (beq cr1 @bump)
-    (ble cr2 @bump)
-    (mr bytes elements)
-    (ble cr3 @bump)
-    (slwi bytes elements 1)
-    (ble cr4 @bump)
-    (slwi bytes elements 3)
-    (beq cr5 @bump)
-    (la elements 7 elements)
-    (srwi bytes elements 3)
-    @bump
-    (la bytes (+ 4 7) bytes)
-    (clrrwi bytes bytes 3)
-    (add obj obj bytes)
-    @test
-    (cmplw :cr0 obj limit)
-    (blt cr0 @loop)
-    (vpop limit)
-    (vpop obj)
-    (vpop fun)
-    (restore-full-lisp-context)
-    (blr)))
-
-
-
-;;; This walks the active "dynamic" area.  Objects might be moving around
-;;; while we're doing this, so we have to be a lot more careful than we 
-;;; are when walking a static area.
-;;; There's the vague notion that we can't take an interrupt when
-;;; "initptr" doesn't equal "freeptr", though what kind of hooks into a
-;;; preemptive scheduler we'd need to enforce this is unclear.  We use
-;;; initptr as an untagged pointer here (and set it to freeptr when we've
-;;; got a tagged pointer to the current object.)
-;;; There are a couple of approaches to termination:
-;;;  a) Allocate a "sentinel" cons, and terminate when we run into it.
-;;;  b) Check the area limit (which is changing if we're consing) and
-;;;     terminate when we hit it.
-;;; (b) loses if the function conses.  (a) conses.  I can't think of anything
-;;; better than (a).
-;;; This, of course, assumes that any GC we're doing does in-place compaction
-;;; (or at least preserves the relative order of objects in the heap.)
-
-#+ppc32-target
-(defppclapfunction %walk-dynamic-area ((a arg_y) (f arg_z))
-  (let ((fun save0)
-        (obj save1)
-        (sentinel save2)
-        (header imm0)
-        (tag imm1)
-        (subtag imm2)
-        (bytes imm3)
-        (elements imm4))
-    (save-lisp-context)
-    (:regsave sentinel 0)
-    (vpush fun)
-    (vpush obj)
-    (vpush sentinel)
-    (ref-global imm0 tenured-area)
-    (cmpwi cr0 imm0 0)
-    (li allocbase #xfff8)
-    (la allocptr (- ppc32::fulltag-cons ppc32::cons.size) allocptr)
-    (twllt allocptr allocbase)
-    (mr sentinel allocptr)
-    (clrrwi allocptr allocptr ppc32::ntagbits)
-    (mr fun f)
-    (if :ne
-      (mr a imm0))    
-    (lwz imm5 ppc32::area.low a)
-    @loop
-    (lwz header 0 imm5)
-    (extract-fulltag tag header)
-    (cmpwi cr0 tag ppc32::fulltag-immheader)
-    (cmpwi cr1 tag ppc32::fulltag-nodeheader)
-    (beq cr0 @misc)
-    (beq cr1 @misc)
-    (la obj ppc32::fulltag-cons imm5)
-    (cmpw cr0 obj sentinel)
-    (mr arg_z obj)
-    (set-nargs 1)
-    (mr temp0 fun)
-    (beq cr0 @done)
-    (bla .SPfuncall)
-    (la imm5 (- ppc32::cons.size ppc32::fulltag-cons) obj)
-    (b @loop)
-    @misc
-    (la obj ppc32::fulltag-misc imm5)
-    (mr arg_z obj)
-    (set-nargs 1)
-    (mr temp0 fun)
-    (bla .SPFuncall)
-    (getvheader header obj)
-    (extract-fulltag tag header)
-    (cmpwi cr1 tag ppc32::fulltag-nodeheader)
-    (cmpwi cr7 tag ppc32::fulltag-immheader)
-    (clrlwi subtag header (- 32 ppc32::num-subtag-bits))
-    (cmpwi cr2 subtag ppc32::max-32-bit-ivector-subtag)
-    (cmpwi cr3 subtag ppc32::max-8-bit-ivector-subtag)
-    (cmpwi cr4 subtag ppc32::max-16-bit-ivector-subtag)
-    (cmpwi cr5 subtag ppc32::subtag-double-float-vector)
-    (header-size elements header)
-    (slwi bytes elements 2)
-    (beq cr1 @bump)
-    (if (:cr7 :ne)
-      (twle 0 0))
-    (ble cr2 @bump)
-    (mr bytes elements)
-    (ble cr3 @bump)
-    (slwi bytes elements 1)
-    (ble cr4 @bump)
-    (slwi bytes elements 3)
-    (beq cr5 @bump)
-    (la elements 7 elements)
-    (srwi bytes elements 3)
-    @bump
-    (la bytes (+ 4 7) bytes)
-    (clrrwi bytes bytes 3)
-    (subi imm5 obj ppc32::fulltag-misc)
-    (add imm5 imm5 bytes)
-    (cmpw cr0 imm5  sentinel)
-    (blt cr0 @loop)
-    (uuo_interr 0 0)
-    (b @loop)
-    @done
-    (li arg_z nil)
-    (vpop sentinel)
-    (vpop obj)
-    (vpop fun)
-    (restore-full-lisp-context)
-    (blr)))
-
-
-
-(defun walk-dynamic-area (area func)
-  (with-other-threads-suspended
-      (%walk-dynamic-area area func)))
-
-
-
-(defppclapfunction %class-of-instance ((i arg_z))
-  (svref arg_z instance.class-wrapper i)
-  (svref arg_z %wrapper-class arg_z)
-  (blr))
-
-(defppclapfunction class-of ((x arg_z))
-  (check-nargs 1)
-  (extract-fulltag imm0 x)
-  (cmpri imm0 target::fulltag-misc)
-  (beq @misc)
-  (extract-lowbyte imm0 x)
-  (b @done)
-  @misc
-  (extract-subtag imm0 x)
-  @done
-  (slri imm0 imm0 target::word-shift)
-  (ldr temp1 '*class-table* nfn)
-  (addi imm0 imm0 target::misc-data-offset)
-  (ldr temp1 target::symbol.vcell temp1)
-  (ldrx temp0 temp1 imm0) ; get entry from table
-  (cmpri cr0 temp0 nil)
-  (beq @bad)
-  ;; functionp?
-  (extract-typecode imm1 temp0)
-  (cmpri imm1 target::subtag-function)
-  (bne @ret)  ; not function - return entry
-  ;; else jump to the fn
-  (mr nfn temp0)
-  (ldr temp0 target::misc-data-offset temp0)
-  (SET-NARGS 1)
-  (mtctr temp0)
-  (bctr)
-  @bad
-  (ldr fname 'no-class-error nfn)
-  (ba .spjmpsym)
-  @ret
-  (mr arg_z temp0)  ; return frob from table
-  (blr))
-
-(defppclapfunction full-gccount ()
-  (ref-global arg_z tenured-area)
-  (cmpri cr0 arg_z 0)
-  (if :eq
-    (ref-global arg_z gc-count)
-    (ldr arg_z target::area.gc-count arg_z))
-  (blr))
-
-
-(defppclapfunction gc ()
-  (check-nargs 0)
-  (li imm0 arch::gc-trap-function-gc)
-  (trlgei allocptr 0)
-  (li arg_z (target-nil-value))
-  (blr))
-
-
-(defppclapfunction egc ((arg arg_z))
-  "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return
-the previous enabled status. Although this function is thread-safe (in
-the sense that calls to it are serialized), it doesn't make a whole lot
-of sense to be turning the EGC on and off from multiple threads ..."
-  (check-nargs 1)
-  (subi imm1 arg nil)
-  (li imm0 arch::gc-trap-function-egc-control)
-  (trlgei allocptr 0)
-  (blr))
-
-
-
-(defppclapfunction %configure-egc ((e0size arg_x)
-				   (e1size arg_y)
-				   (e2size arg_z))
-  (check-nargs 3)
-  (li imm0 arch::gc-trap-function-configure-egc)
-  (trlgei allocptr 0)
-  (blr))
-
-(defppclapfunction purify ()
-  (li imm0 arch::gc-trap-function-purify)
-  (trlgei allocptr 0)
-  (li arg_z nil)
-  (blr))
-
-
-(defppclapfunction impurify ()
-  (li imm0 arch::gc-trap-function-impurify)
-  (trlgei allocptr 0)
-  (li arg_z nil)
-  (blr))
-
-(defppclapfunction lisp-heap-gc-threshold ()
-  "Return the value of the kernel variable that specifies the amount
-of free space to leave in the heap after full GC."
-  (check-nargs 0)
-  (li imm0 arch::gc-trap-function-get-lisp-heap-threshold)
-  (trlgei allocptr 0)
-  #+ppc32-target
-  (ba .SPmakeu32)
-  #+ppc64-target
-  (ba .SPmakeu64))
-
-(defppclapfunction set-lisp-heap-gc-threshold ((new arg_z))
-  "Set the value of the kernel variable that specifies the amount of free
-space to leave in the heap after full GC to new-value, which should be a
-non-negative fixnum. Returns the value of that kernel variable (which may
-be somewhat larger than what was specified)."
-  (check-nargs 1)
-  (mflr loc-pc)
-  #+ppc32-target
-  (bla .SPgetu32)
-  #+ppc64-target
-  (bla .SPgetu64)
-  (mtlr loc-pc)
-  (mr imm1 imm0)
-  (li imm0 arch::gc-trap-function-set-lisp-heap-threshold)
-  (trlgei allocptr 0)
-  #+ppc32-target
-  (ba .SPmakeu32)
-  #+ppc64-target
-  (ba .SPmakeu64))
-
-
-(defppclapfunction use-lisp-heap-gc-threshold ()
-  "Try to grow or shrink lisp's heap space, so that the free space is(approximately) equal to the current heap threshold. Return NIL"
-  (check-nargs 0) 
-  (li imm0 arch::gc-trap-function-use-lisp-heap-threshold)
-  (trlgei allocptr 0)
-  (li arg_z nil)
-  (blr))
-
-
-(defppclapfunction freeze ()
-  "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable."
-  (check-nargs 0)
-  (li imm0 arch::gc-trap-function-freeze)
-  (trlgei allocptr 0)
-  #+64-bit-target
-  (ba .SPmakeu64)
-  #+32-bit-target
-  (ba .SPmakeu32))
-
-(defppclapfunction flash-freeze ()
-  "Like FREEZE, but don't GC first."
-  (check-nargs 0)
-  (li imm0 arch::gc-trap-function-flash-freeze)
-  (trlgei allocptr 0)
-  #+64-bit-target
-  (ba .SPmakeu64)
-  #+32-bit-target
-  (ba .SPmakeu32))
-
-(defun %watch (uvector)
-  (declare (ignore uvector))
-  (error "watching objects not supported on PPC yet"))
-
-(defun %unwatch (watched new)
-  (declare (ignore watched new))
-  (error "watching objects not supported on PPC yet"))
-
-;;; Make a list.  This can be faster than doing so by doing CONS
-;;; repeatedly, since the latter strategy might triger the GC several
-;;; times if N is large.
-(defppclapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
-  (check-nargs 2)
-  (save-lisp-context)
-  (uuo_interr arch::error-allocate-list rzero)
-  (vpush arg_z)
-  (vpush arg_y)
-  (set-nargs 2)
-  (ba .SPnvalret))
-  
-(defppclapfunction %ensure-static-conses ()
-  (check-nargs 0)
-  (li imm0 arch::gc-trap-function-ensure-static-conses)
-  (trlgei allocptr 0)
-  (li arg_z nil)
-  (blr))
-
-;;; offset is a fixnum, one of the target::kernel-import-xxx constants.
-;;; Returns that kernel import, a fixnum.
-(defppclapfunction %kernel-import ((offset arg_z))
-  (ref-global imm0 kernel-imports)
-  (unbox-fixnum imm1 arg_z)
-  (ldrx arg_z imm0 imm1)
-  (blr))
-
-(defppclapfunction %get-unboxed-ptr ((macptr arg_z))
-  (macptr-ptr imm0 arg_z)
-  (ldr arg_z 0 imm0)
-  (blr))
-
-
-(defppclapfunction %revive-macptr ((p arg_z))
-  (li imm0 target::subtag-macptr)
-  (stb imm0 target::misc-subtag-offset p)
-  (blr))
-
-(defppclapfunction %macptr-type ((p arg_z))
-  (check-nargs 1)
-  (trap-unless-typecode= p target::subtag-macptr)
-  (svref imm0 target::macptr.type-cell p)
-  (box-fixnum arg_z imm0)
-  (blr))
-  
-(defppclapfunction %macptr-domain ((p arg_z))
-  (check-nargs 1)
-  (trap-unless-typecode= p target::subtag-macptr)
-  (svref imm0 target::macptr.domain-cell p)
-  (box-fixnum arg_z imm0)
-  (blr))
-
-(defppclapfunction %set-macptr-type ((p arg_y) (new arg_z))
-  (check-nargs 2)
-  (unbox-fixnum imm1 new)
-  (trap-unless-typecode= p target::subtag-macptr)
-  (svset imm1 target::macptr.type-cell p)
-  (blr))
-
-(defppclapfunction %set-macptr-domain ((p arg_y) (new arg_z))
-  (check-nargs 2)
-  (unbox-fixnum imm1 new)
-  (trap-unless-typecode= p target::subtag-macptr)
-  (svset imm1 target::macptr.domain-cell p)
-  (blr))
-
-(defppclapfunction true ()
-  (cmplri nargs '3)
-  (li arg_z t)
-  (blelr)
-  (subi imm0 nargs '3)
-  (add vsp vsp imm0)
-  (blr))
-
-(defppclapfunction false ()
-  (cmplri nargs '3)
-  (li arg_z nil)
-  (blelr)
-  (subi imm0 nargs '3)
-  (add vsp vsp imm0)
-  (blr))
-
-(lfun-bits #'true #.(encode-lambda-list '(&lap &rest ignore)))
-(lfun-bits #'false #.(encode-lambda-list '(&lap &rest ignore)))
-
-;;; end