From 02afc3779a467fd354d40db8b891f2d866f3d49a Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 3 Jul 2003 14:28:24 +0000 Subject: [PATCH] 0.8.1.21: Constant base-char compares for PPC ... also fix some problems revealed by OpenMCL: the initarg for SIMPLE-CONDITIONS is :FORMAT-CONTROL, not :FORMAT-STRING ... also fix something observed way back when by KingNato on #lisp IRC: in arch_get_bad_addr, change a bogus && to || --- src/code/early-extensions.lisp | 2 +- src/code/stream.lisp | 2 +- src/compiler/ir1report.lisp | 4 +-- src/compiler/ppc/char.lisp | 55 +++++++++++++++++++++++++++------------- src/runtime/ppc-arch.c | 2 +- version.lisp-expr | 2 +- 6 files changed, 44 insertions(+), 23 deletions(-) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 61c6404..ff5fb92 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -816,7 +816,7 @@ which can be found at .~:@>" (error 'simple-type-error ; maybe should be TYPE-BUG, subclass of BUG? :value value :expected-type type - :format-string "~@<~S ~_is not a ~_~S~:>" + :format-control "~@<~S ~_is not a ~_~S~:>" :format-arguments (list value type))) ;;; Return a function like FUN, but expecting its (two) arguments in diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 3e2c5ca..aa91999 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -185,7 +185,7 @@ ;; private predicate function..) is ugly and confusing, but ;; I can't see any other way. -- WHN 2001-04-14 :expected-type '(satisfies stream-associated-with-file-p) - :format-string + :format-control "~@" :format-arguments (list stream)))) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 4c1f514..f598a04 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -433,7 +433,7 @@ (policy *lexenv* (= inhibit-warnings 3))) (restart-case (signal (make-condition 'simple-compiler-note - :format-string format-string + :format-control format-string :format-arguments format-args)) (muffle-warning () (return-from compiler-notify (values)))) @@ -449,7 +449,7 @@ (progn (restart-case (signal (make-condition 'simple-compiler-note - :format-string (car rest) + :format-control (car rest) :format-arguments (cdr rest))) (muffle-warning () (return-from maybe-compiler-notify (values)))) diff --git a/src/compiler/ppc/char.lisp b/src/compiler/ppc/char.lisp index 308ddb0..04192de 100644 --- a/src/compiler/ppc/char.lisp +++ b/src/compiler/ppc/char.lisp @@ -1,29 +1,31 @@ -;;; -;;; Written by Rob MacLachlan -;;; Converted for the MIPS R2000 by Christopher Hoover. -;;; And then to the SPARC by William Lott. -;;; -(in-package "SB!VM") +;;;; the PPC VM definition of character operations +;;;; 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") ;;;; Moves and coercions: ;;; Move a tagged char to an untagged representation. -;;; (define-vop (move-to-base-char) (:args (x :scs (any-reg descriptor-reg))) (:results (y :scs (base-char-reg))) (:note "character untagging") (:generator 1 (inst srwi y x sb!vm:n-widetag-bits))) -;;; + (define-move-vop move-to-base-char :move (any-reg descriptor-reg) (base-char-reg)) ;;; Move an untagged char to a tagged representation. -;;; (define-vop (move-from-base-char) (:args (x :scs (base-char-reg))) (:results (y :scs (any-reg descriptor-reg))) @@ -31,12 +33,11 @@ (:generator 1 (inst slwi y x sb!vm:n-widetag-bits) (inst ori y y sb!vm:base-char-widetag))) -;;; + (define-move-vop move-from-base-char :move (base-char-reg) (any-reg descriptor-reg)) ;;; Move untagged base-char values. -;;; (define-vop (base-char-move) (:args (x :target y :scs (base-char-reg) @@ -48,13 +49,11 @@ (:affected) (:generator 0 (move y x))) -;;; + (define-move-vop base-char-move :move (base-char-reg) (base-char-reg)) - ;;; Move untagged base-char arguments/return-values. -;;; (define-vop (move-base-char-arg) (:args (x :target y :scs (base-char-reg)) @@ -68,14 +67,13 @@ (move y x)) (base-char-stack (storew x fp (tn-offset y)))))) -;;; + (define-move-vop move-base-char-arg :move-arg (any-reg base-char-reg) (base-char-reg)) ;;; Use standard MOVE-ARG + coercion to move an untagged base-char ;;; to a descriptor passing location. -;;; (define-move-vop move-arg :move-arg (base-char-reg) (any-reg descriptor-reg)) @@ -105,7 +103,6 @@ ;;; Comparison of base-chars. -;;; (define-vop (base-char-compare) (:args (x :scs (base-char-reg)) (y :scs (base-char-reg))) @@ -131,3 +128,27 @@ (:translate char>) (:variant :gt :le)) +(define-vop (base-char-compare/c) + (:args (x :scs (base-char-reg))) + (:arg-types base-char (:constant base-char)) + (:conditional) + (:info target not-p y) + (:policy :fast-safe) + (:note "inline comparison") + (:variant-vars condition not-condition) + (:generator 2 + (inst cmplwi x (sb!xc:char-code y)) + (inst b? (if not-p not-condition condition) target))) + +(define-vop (fast-char=/base-char/c base-char-compare/c) + (:translate char=) + (:variant :eq :ne)) + +(define-vop (fast-char/base-char/c base-char-compare/c) + (:translate char>) + (:variant :gt :le)) + diff --git a/src/runtime/ppc-arch.c b/src/runtime/ppc-arch.c index 84c3365..3d209e9 100644 --- a/src/runtime/ppc-arch.c +++ b/src/runtime/ppc-arch.c @@ -49,7 +49,7 @@ arch_get_bad_addr(int sig, siginfo_t *code, os_context_t *context) if ((((unsigned long)pc) & 3) != 0 || ((pc < READ_ONLY_SPACE_START || pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) && - ((lispobj *)pc < current_dynamic_space && + ((lispobj *)pc < current_dynamic_space || (lispobj *)pc >= current_dynamic_space + DYNAMIC_SPACE_SIZE))) return 0; diff --git a/version.lisp-expr b/version.lisp-expr index f9bf478..429f72e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.1.20" +"0.8.1.21" -- 1.7.10.4