From d09f30f49f9d2ba8bee0b216c2411c66c2df8f2b Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Sat, 3 Apr 2010 00:39:25 +0000 Subject: [PATCH] 1.0.37.25: Defer interning symbols to cold-core as long as possible. * Don't cold-intern symbols in cold-load-symbol. * Use host symbols NIL and T for fop-empty-list and fop-truth. * Do cold-intern symbols-as-value in write-wordindexed. * Warm-fun-name of a symbol is the symbol itself, modulo uncrossing packages (SB-XC -> COMMON-LISP). * Type declaration fixups to allow passing symbols as well as descriptors in some places. --- src/compiler/generic/genesis.lisp | 50 +++++++++++++++++++++---------------- version.lisp-expr | 2 +- 2 files changed, 30 insertions(+), 22 deletions(-) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 10ebc3d..b148cee 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -559,10 +559,12 @@ *current-reversed-cold-toplevels*) (values)) -(declaim (ftype (function (descriptor sb!vm:word descriptor)) write-wordindexed)) +(declaim (ftype (function (descriptor sb!vm:word (or descriptor symbol))) write-wordindexed)) (defun write-wordindexed (address index value) #!+sb-doc "Write VALUE displaced INDEX words from ADDRESS." + ;; If we're passed a symbol as a value then it needs to be interned. + (when (symbolp value) (setf value (cold-intern value))) (if (eql (descriptor-gspace value) :load-time-value) (note-load-time-value-reference address (- (ash index sb!vm:word-shift) @@ -575,7 +577,7 @@ (setf (bvref-word bytes byte-index) (descriptor-bits value))))) -(declaim (ftype (function (descriptor descriptor)) write-memory)) +(declaim (ftype (function (descriptor (or descriptor symbol))) write-memory)) (defun write-memory (address value) #!+sb-doc "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)." @@ -1443,27 +1445,33 @@ core and return a descriptor to it." ;;; Given a cold representation of a function name, return a warm ;;; representation. -(declaim (ftype (function (descriptor) (or symbol list)) warm-fun-name)) +(declaim (ftype (function ((or descriptor symbol)) (or symbol list)) warm-fun-name)) (defun warm-fun-name (des) (let ((result - (ecase (descriptor-lowtag des) - (#.sb!vm:list-pointer-lowtag - (aver (not (cold-null des))) ; function named NIL? please no.. - ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..). - (let* ((car-des (cold-car des)) - (cdr-des (cold-cdr des)) - (cadr-des (cold-car cdr-des)) - (cddr-des (cold-cdr cdr-des))) - (aver (cold-null cddr-des)) - (list (warm-symbol car-des) - (warm-symbol cadr-des)))) - (#.sb!vm:other-pointer-lowtag - (warm-symbol des))))) + (if (symbolp des) + ;; This parallels the logic at the start of COLD-INTERN + ;; which re-homes symbols in SB-XC to COMMON-LISP. + (if (eq (symbol-package des) (find-package "SB-XC")) + (intern (symbol-name des) *cl-package*) + des) + (ecase (descriptor-lowtag des) + (#.sb!vm:list-pointer-lowtag + (aver (not (cold-null des))) ; function named NIL? please no.. + ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..). + (let* ((car-des (cold-car des)) + (cdr-des (cold-cdr des)) + (cadr-des (cold-car cdr-des)) + (cddr-des (cold-cdr cdr-des))) + (aver (cold-null cddr-des)) + (list (warm-symbol car-des) + (warm-symbol cadr-des)))) + (#.sb!vm:other-pointer-lowtag + (warm-symbol des)))))) (legal-fun-name-or-type-error result) result)) (defun cold-fdefinition-object (cold-name &optional leave-fn-raw) - (declare (type descriptor cold-name)) + (declare (type (or descriptor symbol) cold-name)) (/show0 "/cold-fdefinition-object") (let ((warm-name (warm-fun-name cold-name))) (or (gethash warm-name *cold-fdefn-objects*) @@ -1487,7 +1495,7 @@ core and return a descriptor to it." ;;; Handle the at-cold-init-time, fset-for-static-linkage operation ;;; requested by FOP-FSET. (defun static-fset (cold-name defn) - (declare (type descriptor cold-name)) + (declare (type (or descriptor symbol) cold-name)) (let ((fdefn (cold-fdefinition-object cold-name t)) (type (logand (descriptor-low (read-memory defn)) sb!vm:widetag-mask))) (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn) @@ -1985,8 +1993,8 @@ core and return a descriptor to it." (define-cold-fop (fop-short-character) (make-character-descriptor (read-byte-arg))) -(define-cold-fop (fop-empty-list) *nil-descriptor*) -(define-cold-fop (fop-truth) (cold-intern t)) +(define-cold-fop (fop-empty-list) nil) +(define-cold-fop (fop-truth) t) (define-cold-fop (fop-normal-load :stackp nil) (setq *fop-funs* *normal-fop-funs*)) @@ -2094,7 +2102,7 @@ core and return a descriptor to it." (defun cold-load-symbol (size package) (let ((string (make-string size))) (read-string-as-bytes *fasl-input-stream* string) - (cold-intern (intern string package)))) + (intern string package))) (macrolet ((frob (name pname-len package-len) `(define-cold-fop (,name) diff --git a/version.lisp-expr b/version.lisp-expr index ee55441..7760b0a 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.37.24" +"1.0.37.25" -- 1.7.10.4