From f8841336df537830152819a8dd346f51a8a62869 Mon Sep 17 00:00:00 2001 From: Thiemo Seufer Date: Sat, 1 Sep 2007 18:11:11 +0000 Subject: [PATCH] 1.0.9.22: Dynamic-extent value-cells for MIPS. --- src/compiler/mips/alloc.lisp | 7 +++---- src/compiler/mips/float.lisp | 6 +++--- src/compiler/mips/macros.lisp | 33 ++++++++++++++++++++++++++------- src/compiler/mips/move.lisp | 2 +- src/compiler/mips/sap.lisp | 2 +- tests/dynamic-extent.impure.lisp | 2 +- version.lisp-expr | 2 +- 7 files changed, 36 insertions(+), 18 deletions(-) diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp index 8b1cff9..fdeb152 100644 --- a/src/compiler/mips/alloc.lisp +++ b/src/compiler/mips/alloc.lisp @@ -118,7 +118,7 @@ (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:results (result :scs (descriptor-reg) :from :argument)) (:generator 37 - (with-fixed-allocation (result pa-flag temp fdefn-widetag fdefn-size) + (with-fixed-allocation (result pa-flag temp fdefn-widetag fdefn-size nil) (inst li temp (make-fixup "undefined_tramp" :foreign)) (storew name result fdefn-name-slot other-pointer-lowtag) (storew null-tn result fdefn-fun-slot other-pointer-lowtag) @@ -153,12 +153,11 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:info stack-allocate-p) - (:ignore stack-allocate-p) (:results (result :scs (descriptor-reg))) (:generator 10 - (with-fixed-allocation (result pa-flag temp value-cell-header-widetag value-cell-size) + (with-fixed-allocation (result pa-flag temp value-cell-header-widetag + value-cell-size stack-allocate-p) (storew value result value-cell-value-slot other-pointer-lowtag)))) - ;;;; Automatic allocators for primitive objects. diff --git a/src/compiler/mips/float.lisp b/src/compiler/mips/float.lisp index 1f406c5..56323bb 100644 --- a/src/compiler/mips/float.lisp +++ b/src/compiler/mips/float.lisp @@ -78,7 +78,7 @@ (:variant-vars double-p size type data) (:note "float to pointer coercion") (:generator 13 - (with-fixed-allocation (y pa-flag ndescr type size) + (with-fixed-allocation (y pa-flag ndescr type size nil) (if double-p (str-double x y (- (* data n-word-bytes) other-pointer-lowtag)) (inst swc1 x y (- (* data n-word-bytes) other-pointer-lowtag)))))) @@ -259,7 +259,7 @@ (:note "complex single float to pointer coercion") (:generator 13 (with-fixed-allocation (y pa-flag ndescr complex-single-float-widetag - complex-single-float-size) + complex-single-float-size nil) (let ((real-tn (complex-single-reg-real-tn x))) (inst swc1 real-tn y (- (* complex-single-float-real-slot n-word-bytes) @@ -279,7 +279,7 @@ (:note "complex double float to pointer coercion") (:generator 13 (with-fixed-allocation (y pa-flag ndescr complex-double-float-widetag - complex-double-float-size) + complex-double-float-size nil) (let ((real-tn (complex-double-reg-real-tn x))) (str-double real-tn y (- (* complex-double-float-real-slot n-word-bytes) diff --git a/src/compiler/mips/macros.lisp b/src/compiler/mips/macros.lisp index 161f4fe..9c60db9 100644 --- a/src/compiler/mips/macros.lisp +++ b/src/compiler/mips/macros.lisp @@ -143,8 +143,11 @@ ;;;; Storage allocation: -(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size) +(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code + size dynamic-extent-p + &key (lowtag other-pointer-lowtag)) &body body) + #!+sb-doc "Do stuff to allocate an other-pointer object of fixed Size with a single word header having the specified Type-Code. The result is placed in Result-TN, Flag-Tn must be wired to NL4-OFFSET, and Temp-TN is a non- @@ -152,12 +155,28 @@ 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) (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))) + (once-only ((result-tn result-tn) (flag-tn flag-tn) (temp-tn temp-tn) + (type-code type-code) (size size) + (dynamic-extent-p dynamic-extent-p) + (lowtag lowtag)) + `(if ,dynamic-extent-p + (pseudo-atomic (,flag-tn) + (align-csp ,temp-tn) + (inst or ,result-tn csp-tn ,lowtag) + (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) + (inst addu csp-tn (pad-data-block ,size)) + (storew ,temp-tn ,result-tn 0 ,lowtag) + ,@body) + (pseudo-atomic (,flag-tn :extra (pad-data-block ,size)) + ;; The pseudo-atomic bit in alloc-tn is set. If the lowtag also + ;; has a 1 bit in the same position, we're all set. Otherwise, + ;; we need to subtract the pseudo-atomic bit. + (inst or ,result-tn alloc-tn ,lowtag) + (unless (logbitp (1- n-lowtag-bits) ,lowtag) + (inst sub ,result-tn 1)) + (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) + (storew ,temp-tn ,result-tn 0 ,lowtag) + ,@body)))) (defun align-csp (temp) ;; is used for stack allocation of dynamic-extent objects diff --git a/src/compiler/mips/move.lisp b/src/compiler/mips/move.lisp index dcaae73..b839199 100644 --- a/src/compiler/mips/move.lisp +++ b/src/compiler/mips/move.lisp @@ -210,7 +210,7 @@ (inst sll y x 2) (with-fixed-allocation - (y pa-flag temp bignum-widetag (1+ bignum-digits-offset)) + (y pa-flag temp bignum-widetag (1+ bignum-digits-offset) nil) (storew x y bignum-digits-offset other-pointer-lowtag)) (inst b done) (inst nop) diff --git a/src/compiler/mips/sap.lisp b/src/compiler/mips/sap.lisp index ad72a85..144e618 100644 --- a/src/compiler/mips/sap.lisp +++ b/src/compiler/mips/sap.lisp @@ -32,7 +32,7 @@ (:results (res :scs (descriptor-reg))) (:note "SAP to pointer coercion") (:generator 20 - (with-fixed-allocation (res pa-flag ndescr sap-widetag sap-size) + (with-fixed-allocation (res pa-flag ndescr sap-widetag sap-size nil) (storew sap res sap-pointer-slot other-pointer-lowtag)))) (define-move-vop move-from-sap :move diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 3ac193f..8579383 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -130,7 +130,7 @@ (defun-with-dx dx-value-cell (x) ;; Not implemented everywhere, yet. - #+(or x86 x86-64) + #+(or x86 x86-64 mips) (let ((cell x)) (declare (dynamic-extent cell)) (flet ((f () diff --git a/version.lisp-expr b/version.lisp-expr index bb36821..485c50d 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".) -"1.0.9.21" +"1.0.9.22" -- 1.7.10.4