Changeset 13822

Timestamp:

Jun 14, 2010, 10:15:29 AM (11 years ago)

Author:

gb

Message:

%WALK-DYNAMIC-AREA.

File:

• branches/arm/level-0/ARM/arm-utils.lisp (modified) (1 diff)

branches/arm/level-0/ARM/arm-utils.lisp

@@ -172 +172 @@
 ;;; (or at least preserves the relative order of objects in the heap.)
 
-#+notyet
 (defarmlapfunction %walk-dynamic-area ((a arg_y) (f arg_z))
-  (let ((fun save0)
-        (obj save1)
-        (sentinel save2)
+  (let ((fun temp0)
+        (obj temp1)
+        (sentinel temp2)
         (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 (- arm::fulltag-cons arm::cons.size) allocptr)
-    (twllt allocptr allocbase)
+        (subtag imm2))
+    (ref-global imm1 tenured-area)   
+    (build-lisp-frame)
+    (mov allocptr (:$ -8))
+    (str allocptr (:@ rcontext (:$ arm::tcr.save-allocbase)))
+    (cmp imm1 (:$ 0))
+    (mov fun f)
+    (movne a imm1)
+    (sub allocptr allocptr (:$ (- arm::cons.size arm::fulltag-cons)))
+    (ldr imm1 (:@ rcontext (:$ arm::tcr.save-allocbase)))
+    (cmp allocptr imm1)
+    (uuo-alloc-trap (:? lo))
     (mov sentinel allocptr)
-    (clrrwi allocptr allocptr arm::ntagbits)
-    (mov fun f)
-    (if :ne
-      (mov a imm0))    
-    (lwz imm5 (:@ a (:$ arm::area.low)))
+    (bic allocptr allocptr (:$ arm::fulltagmask))
+    (ldr obj (:@ a (:$ arm::area.low)))
+    (b @test)
     @loop
-    (lwz header (:@ imm5 (:$ 0)))
+    (ldr header (:@ obj (:$ 0)))
     (extract-fulltag tag header)
-    (cmpwi cr0 tag arm::fulltag-immheader)
-    (cmpwi cr1 tag arm::fulltag-nodeheader)
-    (beq cr0 @misc)
-    (beq cr1 @misc)
-    (la obj arm::fulltag-cons imm5)
-    (cmpw cr0 obj sentinel)
-    (mov arg_z obj)
+    (cmp tag (:$ arm::fulltag-immheader))    
+    (cmpne tag (:$ arm::fulltag-nodeheader))
+    (beq @misc)
+    (add arg_z obj (:$ arm::fulltag-cons))
+    (cmp arg_z sentinel)
+    (bhs @done)
     (set-nargs 1)
-    (mov temp0 fun)
-    (beq cr0 @done)
-    (bla .SPfuncall)
-    (la imm5 (- arm::cons.size arm::fulltag-cons) obj)
-    (b @loop)
+    (stmdb (:! vsp) (fun obj sentinel))
+    (mov nfn fun)
+    (bl .SPFuncall)
+    (ldmia (:! vsp) (fun obj sentinel))
+    (add obj obj (:$ arm::cons.size))
+    (b @test)
     @misc
-    (la obj arm::fulltag-misc imm5)
-    (mov arg_z obj)
+    (add arg_z obj (:$ arm::fulltag-misc))
+    (stmdb (:! vsp) (fun obj sentinel))
     (set-nargs 1)
-    (mov temp0 fun)
-    (bla .SPFuncall)
-    (getvheader header obj)
+    (mov nfn fun)
+    (bl .SPFuncall)
+    (ldmia (:! vsp) (fun obj sentinel))
+    (ldr header (:@ obj (:$ 0)))
     (extract-fulltag tag header)
-    (cmpwi cr1 tag arm::fulltag-nodeheader)
-    (cmpwi cr7 tag arm::fulltag-immheader)
-    (clrlwi subtag header (- 32 arm::num-subtag-bits))
-    (cmpwi cr2 subtag arm::max-32-bit-ivector-subtag)
-    (cmpwi cr3 subtag arm::max-8-bit-ivector-subtag)
-    (cmpwi cr4 subtag arm::max-16-bit-ivector-subtag)
-    (cmpwi cr5 subtag arm::subtag-double-float-vector)
-    (header-size elements header)
-    (slwi bytes elements 2)
-    (beq cr1 @bump)
-    (if (:cr7 :ne)
-      (twle 0 0))
-    (ble cr2 @bump)
-    (mov 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)
+    (cmp tag (:$ arm::fulltag-nodeheader))
+    (extract-lowbyte subtag header)
+    (bic header header (:$ arm::subtag-mask))
+    (mov header (:lsr header (:$ (- arm::num-subtag-bits arm::word-shift))))
+    (beq @bump)
+    (cmp subtag (:$ arm::max-32-bit-ivector-subtag))
+    (bls @bump)
+    (cmp subtag (:$ arm::max-8-bit-ivector-subtag))
+    (movls header (:lsr header (:$ 2)))
+    (bls @bump)
+    (cmp subtag (:$ arm::max-16-bit-ivector-subtag))
+    (movls header (:lsr header (:$ 1)))
+    (bls @bump)
+    (cmp subtag (:$ arm::subtag-double-float-vector))
+    (movls header (:lsl header (:$ 1)))
+    (bls @bump)
+    (mov header (:lsr header (:$ 2)))
+    (add header header (:$ 7))
+    (mov header (:lsr header (:$ 3)))
     @bump
-    (la bytes (+ 4 7) bytes)
-    (clrrwi bytes bytes 3)
-    (subi imm5 obj arm::fulltag-misc)
-    (add imm5 imm5 bytes)
-    (cmpw cr0 imm5  sentinel)
-    (blt cr0 @loop)
-    (uuo_interr 0 0)
-    (b @loop)
+    (add header header (:$ (+ 4 7)))
+    (bic header header (:$ arm::fulltagmask))
+    (add obj obj header)
+    @test
+    (cmp obj sentinel)
+    (blo @loop)
+    (uuo-debug-trap)
     @done
-    (li arg_z nil)
-    (vpop sentinel)
-    (vpop obj)
-    (vpop fun)
-    (restore-full-lisp-context)
-    (bx lr)))
+    (return-lisp-frame)))