Commit [7892f5] Maximize Restore History

0.7.7.23:

Merge backend_cleanup_1_branch
... I hope this is right :-)

Christophe Rhodes Christophe Rhodes 2002-09-13

1 2 > >> (Page 1 of 2)
added src/compiler/generic/late-type-vops.lisp
changed src/compiler/alpha/macros.lisp
changed src/compiler/alpha/type-vops.lisp
changed src/compiler/generic/utils.lisp
changed src/compiler/hppa/macros.lisp
changed src/compiler/hppa/type-vops.lisp
changed src/compiler/mips/macros.lisp
changed src/compiler/mips/type-vops.lisp
changed src/compiler/ppc/macros.lisp
changed src/compiler/ppc/subprim.lisp
changed src/compiler/ppc/type-vops.lisp
changed src/compiler/ppc/values.lisp
changed src/compiler/sparc/macros.lisp
changed src/compiler/sparc/subprim.lisp
changed src/compiler/sparc/type-vops.lisp
changed src/compiler/sparc/values.lisp
changed src/compiler/x86/macros.lisp
changed src/compiler/x86/type-vops.lisp
changed build-order.lisp-expr
changed version.lisp-expr
changed doc/sbcl.1
changed src/code/condition.lisp
changed src/code/debug.lisp
copied src/assembly/ppc/foo.lisp -> src/compiler/generic/early-type-vops.lisp
src/compiler/generic/late-type-vops.lisp Diff Switch to side-by-side view
Loading...
src/compiler/alpha/macros.lisp Diff Switch to side-by-side view
Loading...
src/compiler/alpha/type-vops.lisp Diff Switch to side-by-side view
Loading...
src/compiler/generic/utils.lisp Diff Switch to side-by-side view
Loading...
src/compiler/hppa/macros.lisp Diff Switch to side-by-side view
Loading...
src/compiler/hppa/type-vops.lisp Diff Switch to side-by-side view
Loading...
src/compiler/mips/macros.lisp Diff Switch to side-by-side view
Loading...
src/compiler/mips/type-vops.lisp Diff Switch to side-by-side view
Loading...
src/compiler/ppc/macros.lisp Diff Switch to side-by-side view
Loading...
src/compiler/ppc/subprim.lisp Diff Switch to side-by-side view
Loading...
src/compiler/ppc/type-vops.lisp Diff Switch to side-by-side view
Loading...
src/compiler/ppc/values.lisp Diff Switch to side-by-side view
Loading...
src/compiler/sparc/macros.lisp Diff Switch to side-by-side view
Loading...
src/compiler/sparc/subprim.lisp Diff Switch to side-by-side view
Loading...
src/compiler/sparc/type-vops.lisp Diff Switch to side-by-side view
Loading...
src/compiler/sparc/values.lisp Diff Switch to side-by-side view
Loading...
src/compiler/x86/macros.lisp Diff Switch to side-by-side view
Loading...
src/compiler/x86/type-vops.lisp Diff Switch to side-by-side view
Loading...
build-order.lisp-expr Diff Switch to side-by-side view
Loading...
version.lisp-expr Diff Switch to side-by-side view
Loading...
doc/sbcl.1 Diff Switch to side-by-side view
Loading...
src/code/condition.lisp Diff Switch to side-by-side view
Loading...
src/code/debug.lisp Diff Switch to side-by-side view
Loading...
src/assembly/ppc/foo.lisp to src/compiler/generic/early-type-vops.lisp
--- a/src/assembly/ppc/foo.lisp
+++ b/src/compiler/generic/early-type-vops.lisp
@@ -1,210 +1,107 @@
+;;;; generic type testing and checking apparatus
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
 (in-package "SB!VM")
+
+(defparameter *immediate-types*
+  (list unbound-marker-widetag base-char-widetag))
 
-
-;;;; Return-multiple with other than one value
+(defparameter *fun-header-widetags*
+  (list funcallable-instance-header-widetag
+	simple-fun-header-widetag
+	closure-fun-header-widetag
+	closure-header-widetag))
 
-(define-assembly-routine
-    (return-multiple
-     (:return-style :none))
+(defun canonicalize-headers (headers)
+  (collect ((results))
+    (let ((start nil)
+	  (prev nil)
+	  (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
+      (flet ((emit-test ()
+	       (results (if (= start prev)
+			    start
+			    (cons start prev)))))
+	(dolist (header (sort headers #'<))
+	  (cond ((null start)
+		 (setf start header)
+		 (setf prev header))
+		((= header (+ prev delta))
+		 (setf prev header))
+		(t
+		 (emit-test)
+		 (setf start header)
+		 (setf prev header))))
+	(emit-test)))
+    (results)))
 
-     ;; These four are really arguments.
-    ((:temp nvals any-reg nargs-offset)
-     (:temp vals any-reg nl0-offset)
-     (:temp ocfp any-reg nl1-offset)
-     (:temp lra descriptor-reg lra-offset)
+(defmacro test-type (value target not-p
+		     (&rest type-codes)
+		     &rest other-args
+		     &key &allow-other-keys)
+  ;; Determine what interesting combinations we need to test for.
+  (let* ((type-codes (mapcar #'eval type-codes))
+	 (fixnump (and (member even-fixnum-lowtag type-codes)
+		       (member odd-fixnum-lowtag type-codes)
+		       t))
+	 (lowtags (remove lowtag-limit type-codes :test #'<))
+	 (extended (remove lowtag-limit type-codes :test #'>))
+	 (immediates (intersection extended *immediate-types* :test #'eql))
+	 (headers (set-difference extended *immediate-types* :test #'eql))
+	 (function-p (if (intersection headers *fun-header-widetags*)
+			 (if (subsetp headers *fun-header-widetags*)
+			     t
+			     (error "can't test for mix of function subtypes ~
+				     and normal header types"))
+			 nil)))
+    (unless type-codes
+      (error "At least one type must be supplied for TEST-TYPE."))
+    (cond
+      (fixnump
+       (when (remove-if (lambda (x)
+			  (or (= x even-fixnum-lowtag)
+			      (= x odd-fixnum-lowtag)))
+			lowtags)
+	 (error "can't mix fixnum testing with other lowtags"))
+       (when function-p
+	 (error "can't mix fixnum testing with function subtype testing"))
+       (when immediates
+	 (error "can't mix fixnum testing with other immediates"))
+       (if headers
+	   `(%test-fixnum-and-headers ,value ,target ,not-p
+	     ',(canonicalize-headers headers)
+	     ,@other-args)
+	   `(%test-fixnum ,value ,target ,not-p
+	     ,@other-args)))
+      (immediates
+       (when headers
+	 (error "can't mix testing of immediates with testing of headers"))
+       (when lowtags
+	 (error "can't mix testing of immediates with testing of lowtags"))
+       (when (cdr immediates)
+	 (error "can't test multiple immediates at the same time"))
+       `(%test-immediate ,value ,target ,not-p ,(car immediates)
+	 ,@other-args))
+      (lowtags
+       (when (cdr lowtags)
+	 (error "can't test multiple lowtags at the same time"))
+       (if headers
+	   `(%test-lowtag-and-headers
+	     ,value ,target ,not-p ,(car lowtags)
+	     ,function-p ',(canonicalize-headers headers)
+	     ,@other-args)
+	   `(%test-lowtag ,value ,target ,not-p ,(car lowtags)
+	     ,@other-args)))
+      (headers
+       `(%test-headers ,value ,target ,not-p ,function-p
+	 ',(canonicalize-headers headers)
+	 ,@other-args))
+      (t
+       (error "nothing to test?")))))
 
-     ;; These are just needed to facilitate the transfer
-     (:temp lip interior-reg lip-offset)
-     (:temp count any-reg nl2-offset)
-     (:temp src any-reg nl3-offset)
-     (:temp dst any-reg cfunc-offset)
-     (:temp temp descriptor-reg l0-offset)
-
-     
-     ;; These are needed so we can get at the register args.
-     (:temp a0 descriptor-reg a0-offset)
-     (:temp a1 descriptor-reg a1-offset)
-     (:temp a2 descriptor-reg a2-offset)
-     (:temp a3 descriptor-reg a3-offset))
-
-  ;; Note, because of the way the return-multiple vop is written, we can
-  ;; assume that we are never called with nvals == 1 and that a0 has already
-  ;; been loaded.
-  (inst cmpwi nvals 0))
-#|
-  (inst ble default-a0-and-on)
-  (inst cmpwi nvals (fixnumize 2))
-  (inst lwz a1 vals (* 1 n-word-bytes))
-  (inst ble default-a2-and-on)
-  (inst cmpwi nvals (fixnumize 3))
-  (inst lwz a2 vals (* 2 n-word-bytes))
-  (inst ble default-a3-and-on)
-  (inst cmpwi nvals (fixnumize 4))
-  (inst lwz a3 vals (* 3 n-word-bytes))
-  (inst ble done)
-
-  ;; Copy the remaining args to the top of the stack.
-  (inst addi src vals (* 4 n-word-bytes))
-  (inst addi dst cfp-tn (* 4 n-word-bytes))
-  (inst addic. count nvals (- (fixnumize 4)))
-
-  LOOP
-  (inst subic. count count (fixnumize 1))
-  (inst lwz temp src 0)
-  (inst addi src src n-word-bytes)
-  (inst stw temp dst 0)
-  (inst addi dst dst n-word-bytes)
-  (inst bge loop)
-		
-  (inst b done)
-
-  DEFAULT-A0-AND-ON
-  (inst mr a0 null-tn)
-  (inst mr a1 null-tn)
-  DEFAULT-A2-AND-ON
-  (inst mr a2 null-tn)
-  DEFAULT-A3-AND-ON
-  (inst mr a3 null-tn)
-  DONE
-  
-  ;; Clear the stack.
-  (move ocfp-tn cfp-tn)
-  (move cfp-tn ocfp)
-  (inst add csp-tn ocfp-tn nvals)
-  
-  ;; Return.
-  (lisp-return lra lip))
-
-
-;;;; tail-call-variable.
-
-#+sb-assembling ;; no vop for this one either.
-(define-assembly-routine
-    (tail-call-variable
-     (:return-style :none))
-
-    ;; These are really args.
-    ((:temp args any-reg nl0-offset)
-     (:temp lexenv descriptor-reg lexenv-offset)
-
-     ;; We need to compute this
-     (:temp nargs any-reg nargs-offset)
-
-     ;; These are needed by the blitting code.
-     (:temp src any-reg nl1-offset)
-     (:temp dst any-reg nl2-offset)
-     (:temp count any-reg nl3-offset)
-     (:temp temp descriptor-reg l0-offset)
-     (:temp lip interior-reg lip-offset)
-
-     ;; These are needed so we can get at the register args.
-     (:temp a0 descriptor-reg a0-offset)
-     (:temp a1 descriptor-reg a1-offset)
-     (:temp a2 descriptor-reg a2-offset)
-     (:temp a3 descriptor-reg a3-offset))
-
-
-  ;; Calculate NARGS (as a fixnum)
-  (inst sub nargs csp-tn args)
-     
-  ;; Load the argument regs (must do this now, 'cause the blt might
-  ;; trash these locations)
-  (inst lwz a0 args (* 0 n-word-bytes))
-  (inst lwz a1 args (* 1 n-word-bytes))
-  (inst lwz a2 args (* 2 n-word-bytes))
-  (inst lwz a3 args (* 3 n-word-bytes))
-
-  ;; Calc SRC, DST, and COUNT
-  (inst addic. count nargs (fixnumize (- register-arg-count)))
-  (inst addi src args (* n-word-bytes register-arg-count))
-  (inst ble done)
-  (inst addi dst cfp-tn (* n-word-bytes register-arg-count))
-	
-  LOOP
-  ;; Copy one arg.
-  (inst lwz temp src 0)
-  (inst addi src src n-word-bytes)
-  (inst stw temp dst 0)
-  (inst addic. count count (fixnumize -1))
-  (inst addi dst dst n-word-bytes)
-  (inst bgt loop)
-	
-  DONE
-  ;; We are done.  Do the jump.
-  (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
-  (lisp-jump temp lip))
-
-
-
-;;;; Non-local exit noise.
-
-(define-assembly-routine (unwind
-			  (:return-style :none)
-			  (:translate %continue-unwind)
-			  (:policy :fast-safe))
-			 ((:arg block (any-reg descriptor-reg) a0-offset)
-			  (:arg start (any-reg descriptor-reg) ocfp-offset)
-			  (:arg count (any-reg descriptor-reg) nargs-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp cur-uwp any-reg nl0-offset)
-			  (:temp next-uwp any-reg nl1-offset)
-			  (:temp target-uwp any-reg nl2-offset))
-  (declare (ignore start count))
-
-  (let ((error (generate-error-code nil invalid-unwind-error)))
-    (inst cmpwi block 0)
-    (inst beq error))
-  
-  (load-symbol-value cur-uwp *current-unwind-protect-block*)
-  (loadw target-uwp block unwind-block-current-uwp-slot)
-  (inst cmpw cur-uwp target-uwp)
-  (inst bne do-uwp)
-      
-  (move cur-uwp block)
-
-  DO-EXIT
-      
-  (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
-  (loadw code-tn cur-uwp unwind-block-current-code-slot)
-  (loadw lra cur-uwp unwind-block-entry-pc-slot)
-  (lisp-return lra lip :frob-code nil)
-
-  DO-UWP
-
-  (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
-  (store-symbol-value next-uwp *current-unwind-protect-block*)
-  (inst b do-exit))
-
-(define-assembly-routine (throw
-			  (:return-style :none))
-			 ((:arg target descriptor-reg a0-offset)
-			  (:arg start any-reg ocfp-offset)
-			  (:arg count any-reg nargs-offset)
-			  (:temp catch any-reg a1-offset)
-			  (:temp tag descriptor-reg a2-offset))		  
-  
-  (declare (ignore start count))
-
-  (load-symbol-value catch *current-catch-block*)
-  
-  loop
-  
-  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
-    (inst cmpwi catch 0)
-    (inst beq error))
-  
-  (loadw tag catch catch-block-tag-slot)
-  (inst cmpw tag target)
-  (inst beq exit)
-  (loadw catch catch catch-block-previous-catch-slot)
-  (inst b loop)
-  
-  exit
-  
-  (move target catch)
-  (inst ba (make-fixup 'unwind :assembly-routine)))
-
-
-
-|#
1 2 > >> (Page 1 of 2)