From 097126bb7cd1216938f54fe1c5510855d7da1cd1 Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Tue, 3 Feb 2009 04:17:47 +0000 Subject: [PATCH] 1.0.25.5: genesis descriptor-intuit-gspace cleanups Minor refactoring and major commentary updates to descriptor-intuit-gspace. --- src/compiler/generic/genesis.lisp | 43 +++++++++++++++++++++++-------------- version.lisp-expr | 2 +- 2 files changed, 28 insertions(+), 17 deletions(-) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 089f7b9..95be9b3 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -400,21 +400,31 @@ ;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE. (declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace)) (defun descriptor-intuit-gspace (des) - (if (descriptor-gspace des) - (descriptor-gspace des) - ;; KLUDGE: It's not completely clear to me what's going on here; - ;; this is a literal translation from of some rather mysterious - ;; code from CMU CL's DESCRIPTOR-SAP function. Some explanation - ;; would be nice. -- WHN 19990817 - (let ((lowtag (descriptor-lowtag des)) - (high (descriptor-high des)) - (low (descriptor-low des))) - (if (or (eql lowtag sb!vm:fun-pointer-lowtag) - (eql lowtag sb!vm:instance-pointer-lowtag) - (eql lowtag sb!vm:list-pointer-lowtag) - (eql lowtag sb!vm:other-pointer-lowtag)) + (or (descriptor-gspace des) + + ;; gspace wasn't set, now we have to search for it. + (let ((lowtag (descriptor-lowtag des)) + (high (descriptor-high des)) + (low (descriptor-low des))) + + ;; Non-pointer objects don't have a gspace. + (unless (or (eql lowtag sb!vm:fun-pointer-lowtag) + (eql lowtag sb!vm:instance-pointer-lowtag) + (eql lowtag sb!vm:list-pointer-lowtag) + (eql lowtag sb!vm:other-pointer-lowtag)) + (error "don't even know how to look for a GSPACE for ~S" des)) + (dolist (gspace (list *dynamic* *static* *read-only*) - (error "couldn't find a GSPACE for ~S" des)) + (error "couldn't find a GSPACE for ~S" des)) + ;; Bounds-check the descriptor against the allocated area + ;; within each gspace. + ;; + ;; Most of the faffing around in here involving ash and + ;; various computed shift counts is due to the high/low + ;; split representation of the descriptor bits and an + ;; apparent disinclination to create intermediate values + ;; larger than a target fixnum. + ;; ;; This code relies on the fact that GSPACEs are aligned ;; such that the descriptor-low-bits low bits are zero. (when (and (>= high (ash (gspace-word-address gspace) @@ -422,6 +432,8 @@ (<= high (ash (+ (gspace-word-address gspace) (gspace-free-word-index gspace)) (- sb!vm:word-shift descriptor-low-bits)))) + ;; Update the descriptor with the correct gspace and the + ;; offset within the gspace and return the gspace. (setf (descriptor-gspace des) gspace) (setf (descriptor-word-offset des) (+ (ash (- high (ash (gspace-word-address gspace) @@ -430,8 +442,7 @@ (- descriptor-low-bits sb!vm:word-shift)) (ash (logandc2 low sb!vm:lowtag-mask) (- sb!vm:word-shift)))) - (return gspace))) - (error "don't even know how to look for a GSPACE for ~S" des))))) + (return gspace)))))) (defun make-random-descriptor (value) (make-descriptor (logand (ash value (- descriptor-low-bits)) diff --git a/version.lisp-expr b/version.lisp-expr index 72e63a9..0bc23a5 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.25.4" +"1.0.25.5" -- 1.7.10.4