X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=3e38ef773ea3eee3d80c55a9787491a5a852d47e;hb=5d04a95274c9ddaebbcd6ddffc5d646e2c25598c;hp=96423682aa52339a375426664f8e346b48cd8046;hpb=cc32d78e47dfcad7634e26e69797094ed683a888;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 9642368..3e38ef7 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,20 @@ (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))) + (let ((value (symbol-value name))) + ;; Override the values of standard symbols in XC, + ;; since we can't redefine them. + #+sb-xc-host + (when (eql (find-symbol (symbol-name name) :cl) name) + (multiple-value-bind (xc-value foundp) + (info :variable :xc-constant-value name) + (cond (foundp + (setf value xc-value)) + ((not (eq value name)) + (compiler-warn + "Using cross-compilation host's definition of ~S: ~A~%" + name (symbol-value name)))))) + (find-constant value name))) (t (make-global-var :kind kind :%source-name name @@ -256,43 +265,24 @@ ;;; 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,12 +303,15 @@ ((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 structure!object #-sb-xc-host instance + ;; 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? (when (emit-make-load-form value) (dotimes (i (- (%instance-length value) #+sb-xc-host 0 @@ -329,7 +322,15 @@ (compiler-error "Objects of type ~S can't be dumped into fasl files." (type-of value))))))) - (grovel constant))) + ;; Dump all non-trivial named constants using the name. + (if (and namep (not (typep constant '(or symbol character + ;; FIXME: Cold init breaks if we + ;; try to reference FP constants + ;; thru their names. + #+sb-xc-host number + #-sb-xc-host fixnum)))) + (emit-make-load-form constant name) + (grovel constant)))) (values)) ;;;; some flow-graph hacking utilities @@ -522,21 +523,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 +562,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 +586,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 +628,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 @@ -832,15 +828,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 +863,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.