From: Nikodemus Siivola Date: Fri, 6 May 2005 18:58:34 +0000 (+0000) Subject: 0.9.0.22: more fixed allocation X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f4b46d15b6fe4ae78154c2940fb26459fb1d88a5;p=sbcl.git 0.9.0.22: more fixed allocation * fix remaining WITH-FIXED-ALLOCATIONS with empty bodies. NB: there seems to be some doubt whether this is actually the right thing to do, as CMUCL has at least in sparc/float.lisp in MOVE-FOO-FLOAT a commit message by William Lott indicating that this was intentional "to avoid handling a trap within P-A". Which trap that would be is unclear, but hopefully we will eventually rediscover the cases where this is intentional. * make WITH-FIXED-ALLOCATION signal a BUG if body is empty to catch this in the future. * sprinkle WITH-FIXED-ALLOCATION with FAIRY-D^WONCE-ONLY on platforms that didn't have it yet. --- diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp index a251501..b964659 100644 --- a/src/compiler/alpha/macros.lisp +++ b/src/compiler/alpha/macros.lisp @@ -169,11 +169,14 @@ ;;; presumably initializes the object. (defmacro with-fixed-allocation ((result-tn temp-tn widetag size) &body body) - `(pseudo-atomic (:extra (pad-data-block ,size)) - (inst bis alloc-tn other-pointer-lowtag ,result-tn) - (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn) - (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) - ,@body)) + (unless body + (bug "empty &body in WITH-FIXED-ALLOCATION")) + (once-only ((result-tn result-tn) (temp-tn temp-tn) (size size)) + `(pseudo-atomic (:extra (pad-data-block ,size)) + (inst bis alloc-tn other-pointer-lowtag ,result-tn) + (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn) + (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) + ,@body))) ;;;; error code (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/src/compiler/hppa/macros.lisp b/src/compiler/hppa/macros.lisp index d0bebfc..b0ceb5a 100644 --- a/src/compiler/hppa/macros.lisp +++ b/src/compiler/hppa/macros.lisp @@ -125,6 +125,8 @@ Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably initializes the object." + (unless body + (bug "empty &body in WITH-FIXED-ALLOCATION")) (once-only ((result-tn result-tn) (temp-tn temp-tn) (type-code type-code) (size size)) `(pseudo-atomic (:extra (pad-data-block ,size)) diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp index 784a469..9592288 100644 --- a/src/compiler/mips/alloc.lisp +++ b/src/compiler/mips/alloc.lisp @@ -129,9 +129,8 @@ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:results (result :scs (descriptor-reg))) (:generator 10 - (with-fixed-allocation - (result pa-flag temp value-cell-header-widetag value-cell-size)) - (storew value result value-cell-value-slot other-pointer-lowtag))) + (with-fixed-allocation (result pa-flag temp value-cell-header-widetag value-cell-size) + (storew value result value-cell-value-slot other-pointer-lowtag)))) ;;;; Automatic allocators for primitive objects. diff --git a/src/compiler/mips/macros.lisp b/src/compiler/mips/macros.lisp index 04d697f..e582930 100644 --- a/src/compiler/mips/macros.lisp +++ b/src/compiler/mips/macros.lisp @@ -142,12 +142,14 @@ Result-TN, Flag-Tn must be wired to NL4-OFFSET, and Temp-TN is a non- descriptor temp (which may be randomly used by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably initializes the object." - `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size)) - (inst or ,result-tn alloc-tn other-pointer-lowtag) - (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) - (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) - ,@body)) - + (unless body + (bug "empty &body in WITH-FIXED-ALLOCATION")) + (once-only ((result-tn result-tn) (temp-tn temp-tn) (size size)) + `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size)) + (inst or ,result-tn alloc-tn other-pointer-lowtag) + (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) + (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) + ,@body))) ;;;; Three Way Comparison diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp index 5bb91bf..713e6a3 100644 --- a/src/compiler/ppc/alloc.lisp +++ b/src/compiler/ppc/alloc.lisp @@ -133,9 +133,8 @@ (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:results (result :scs (descriptor-reg))) (:generator 10 - (with-fixed-allocation - (result pa-flag temp value-cell-header-widetag value-cell-size)) - (storew value result value-cell-value-slot other-pointer-lowtag))) + (with-fixed-allocation (result pa-flag temp value-cell-header-widetag value-cell-size) + (storew value result value-cell-value-slot other-pointer-lowtag)))) diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp index a4da8d3..a4293d2 100644 --- a/src/compiler/ppc/macros.lisp +++ b/src/compiler/ppc/macros.lisp @@ -139,6 +139,8 @@ Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably initializes the object." + (unless body + (bug "empty &body in WITH-FIXED-ALLOCATION")) (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn) (type-code type-code) (size size)) `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size)) diff --git a/src/compiler/sparc/macros.lisp b/src/compiler/sparc/macros.lisp index 70e1fbd..5ca6733 100644 --- a/src/compiler/sparc/macros.lisp +++ b/src/compiler/sparc/macros.lisp @@ -140,6 +140,8 @@ Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably initializes the object." + (unless body + (bug "empty &body in WITH-FIXED-ALLOCATION")) (once-only ((result-tn result-tn) (temp-tn temp-tn) (type-code type-code) (size size)) `(pseudo-atomic (:extra (pad-data-block ,size)) diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp index dc0247f..ff53bf9 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/src/compiler/x86-64/macros.lisp @@ -214,14 +214,17 @@ ;;; header having the specified WIDETAG value. The result is placed in ;;; RESULT-TN. (defmacro with-fixed-allocation ((result-tn widetag size &optional inline) - &rest forms) - `(pseudo-atomic - (allocation ,result-tn (pad-data-block ,size) ,inline) - (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag) - ,result-tn) - (inst lea ,result-tn - (make-ea :qword :base ,result-tn :disp other-pointer-lowtag)) - ,@forms)) + &body forms) + (unless forms + (bug "empty &body in WITH-FIXED-ALLOCATION")) + (once-only ((result-tn result-tn) (size size)) + `(pseudo-atomic + (allocation ,result-tn (pad-data-block ,size) ,inline) + (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag) + ,result-tn) + (inst lea ,result-tn + (make-ea :qword :base ,result-tn :disp other-pointer-lowtag)) + ,@forms))) ;;;; error code (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index d252203..378ba2d 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -240,14 +240,17 @@ ;;; header having the specified WIDETAG value. The result is placed in ;;; RESULT-TN. (defmacro with-fixed-allocation ((result-tn widetag size &optional inline) - &rest forms) - `(pseudo-atomic - (allocation ,result-tn (pad-data-block ,size) ,inline) - (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag) - ,result-tn) - (inst lea ,result-tn - (make-ea :byte :base ,result-tn :disp other-pointer-lowtag)) - ,@forms)) + &body forms) + (unless forms + (bug "empty &body in WITH-FIXED-ALLOCATION")) + (once-only ((result-tn result-tn) (size size)) + `(pseudo-atomic + (allocation ,result-tn (pad-data-block ,size) ,inline) + (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag) + ,result-tn) + (inst lea ,result-tn + (make-ea :byte :base ,result-tn :disp other-pointer-lowtag)) + ,@forms))) ;;;; error code (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) diff --git a/version.lisp-expr b/version.lisp-expr index 2010f31..0f2355c 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.9.0.21" +"0.9.0.22"