X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1tran.lisp;h=676ed9abf83e72c492ffad8a6a37b3a4939c9014;hb=b025fdbef7236941a6389fe6fa9d9903d2a5cab7;hp=2b0e38660249a254213121a0595c8d5e9b64a750;hpb=77a7ce93218e71f21268661611530a129002a8e6;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 2b0e386..676ed9a 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -35,7 +35,7 @@ (declaim (hash-table *source-paths*)) (defvar *source-paths*) -(declaim (inline source-form-hash-path-p)) +(declaim (inline source-form-has-path-p)) (defun source-form-has-path-p (form) (not (typep form '(or symbol fixnum character)))) @@ -241,11 +241,7 @@ (type (type-specifier (info :variable :type name)))) `(macro . (the ,type ,expansion)))) (:constant - (let ((value (info :variable :constant-value name))) - (make-constant :value value - :%source-name name - :type (ctype-of value) - :where-from where-from))) + (find-constant (symbol-value name) name)) (t (make-global-var :kind kind :%source-name name @@ -256,43 +252,23 @@ ;;; processed with MAKE-LOAD-FORM. We have to be careful, because ;;; CONSTANT might be circular. We also check that the constant (and ;;; any subparts) are dumpable at all. -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD) - ;; below. -- AL 20010227 - (def!constant list-to-hash-table-threshold 32)) -(defun maybe-emit-make-load-forms (constant) - (let ((things-processed nil) - (count 0)) - ;; FIXME: Does this LIST-or-HASH-TABLE messiness give much benefit? - (declare (type (or list hash-table) things-processed) - (type (integer 0 #.(1+ list-to-hash-table-threshold)) count) - (inline member)) - (labels ((grovel (value) +(defun maybe-emit-make-load-forms (constant &optional (name nil namep)) + (let ((xset (alloc-xset))) + (labels ((trivialp (value) + (typep value + '(or #-sb-xc-host unboxed-array + #+sb-xc-host (simple-array (unsigned-byte 8) (*)) + symbol + number + character + string))) + (grovel (value) ;; Unless VALUE is an object which which obviously ;; can't contain other objects - (unless (typep value - '(or #-sb-xc-host unboxed-array - #+sb-xc-host (simple-array (unsigned-byte 8) (*)) - symbol - number - character - string)) - (etypecase things-processed - (list - (when (member value things-processed :test #'eq) - (return-from grovel nil)) - (push value things-processed) - (incf count) - (when (> count list-to-hash-table-threshold) - (let ((things things-processed)) - (setf things-processed - (make-hash-table :test 'eq)) - (dolist (thing things) - (setf (gethash thing things-processed) t))))) - (hash-table - (when (gethash value things-processed) - (return-from grovel nil)) - (setf (gethash value things-processed) t))) + (unless (trivialp value) + (if (xset-member-p value xset) + (return-from grovel nil) + (add-to-xset value xset)) (typecase value (cons (grovel (car value)) @@ -313,22 +289,30 @@ ((array t) (dotimes (i (array-total-size value)) (grovel (row-major-aref value i)))) - (;; In the target SBCL, we can dump any instance, - ;; but in the cross-compilation host, - ;; %INSTANCE-FOO functions don't work on general - ;; instances, only on STRUCTURE!OBJECTs. - #+sb-xc-host structure!object - #-sb-xc-host instance - (when (emit-make-load-form value) - (dotimes (i (- (%instance-length value) - #+sb-xc-host 0 - #-sb-xc-host (layout-n-untagged-slots - (%instance-ref value 0)))) - (grovel (%instance-ref value i))))) (t - (compiler-error - "Objects of type ~S can't be dumped into fasl files." - (type-of value))))))) + (if namep + ;; We can dump arbitrary named constant references by + ;; using the name. + (progn + (emit-make-load-form constant name) + (return-from maybe-emit-make-load-forms (values))) + ;; In the target SBCL, we can dump any instance, but + ;; in the cross-compilation host, %INSTANCE-FOO + ;; functions don't work on general instances, only on + ;; STRUCTURE!OBJECTs. + ;; + ;; FIXME: What about funcallable instances with user-defined + ;; MAKE-LOAD-FORM methods? + (if (typep value #+sb-xc-host 'structure!object #-sb-xc-host 'instance) + (when (emit-make-load-form value) + (dotimes (i (- (%instance-length value) + #+sb-xc-host 0 + #-sb-xc-host (layout-n-untagged-slots + (%instance-ref value 0)))) + (grovel (%instance-ref value i)))) + (compiler-error + "Objects of type ~S can't be dumped into fasl files." + (type-of value))))))))) (grovel constant))) (values)) @@ -522,21 +506,16 @@ (values)) ;; Generate a reference to a manifest constant, creating a new leaf - ;; if necessary. If we are producing a fasl file, make sure that - ;; MAKE-LOAD-FORM gets used on any parts of the constant that it - ;; needs to be. + ;; if necessary. (defun reference-constant (start next result value) (declare (type ctran start next) - (type (or lvar null) result) - (inline find-constant)) + (type (or lvar null) result)) (ir1-error-bailout (start next result value) - (when (producing-fasl-file) - (maybe-emit-make-load-forms value)) - (let* ((leaf (find-constant value)) - (res (make-ref leaf))) - (push res (leaf-refs leaf)) - (link-node-to-previous-ctran res start) - (use-continuation res next result))) + (let* ((leaf (find-constant value)) + (res (make-ref leaf))) + (push res (leaf-refs leaf)) + (link-node-to-previous-ctran res start) + (use-continuation res next result))) (values))) ;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's @@ -566,7 +545,7 @@ ;;; needed. If LEAF represents a defined function which has already ;;; been converted, and is not :NOTINLINE, then reference the ;;; functional instead. -(defun reference-leaf (start next result leaf) +(defun reference-leaf (start next result leaf &optional (name '.anonymous.)) (declare (type ctran start next) (type (or lvar null) result) (type leaf leaf)) (when (functional-p leaf) (assure-functional-live-p leaf)) @@ -590,7 +569,7 @@ '(nil :optional))) (maybe-reanalyze-functional leaf)) leaf)) - (ref (make-ref leaf))) + (ref (make-ref leaf name))) (push ref (leaf-refs leaf)) (setf (leaf-ever-used leaf) t) (link-node-to-previous-ctran ref start) @@ -632,7 +611,7 @@ ;; processing our own code, though. #+sb-xc-host (warn "reading an ignored variable: ~S" name))) - (reference-leaf start next result var)) + (reference-leaf start next result var name)) (cons (aver (eq (car var) 'macro)) ;; FIXME: [Free] type declarations. -- APD, 2002-01-26 @@ -750,7 +729,7 @@ (let ((*print-pretty* nil) ;; We rely on the printer to abbreviate FORM. (*print-length* 3) - (*print-level* 1)) + (*print-level* 3)) (format nil #-sb-xc-host "(in macroexpansion of ~S)" @@ -832,15 +811,6 @@ ;;;; code coverage -;;; Used as the CDR of the code coverage instrumentation records -;;; (instead of NIL) to ensure that any well-behaving user code will -;;; not have constants EQUAL to that record. This avoids problems with -;;; the records getting coalesced with non-record conses, which then -;;; get mutated when the instrumentation runs. Note that it's -;;; important for multiple records for the same location to be -;;; coalesced. -- JES, 2008-01-02 -(defconstant +code-coverage-unmarked+ '%code-coverage-unmarked%) - ;;; Check the policy for whether we should generate code coverage ;;; instrumentation. If not, just return the original START ;;; ctran. Otherwise insert code coverage instrumentation after @@ -876,7 +846,8 @@ `(locally (declare (optimize speed (safety 0) - (debug 0))) + (debug 0) + (check-constant-modification 0))) ;; We're being naughty here, and ;; modifying constant data. That's ok, ;; we know what we're doing.