X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=3e38ef773ea3eee3d80c55a9787491a5a852d47e;hb=9627f5a03e642fa950e1557fef17c506dfd386a6;hp=15ac812a880e39aa4724e7af0a12fea198982994;hpb=037f06f836c2ed1206bf29cfe3bc40e74b83723b;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 15ac812..3e38ef7 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -14,15 +14,40 @@ (declaim (special *compiler-error-bailout*)) +;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the +;;; form number to associate with a source path. This should be bound +;;; to an initial value of 0 before the processing of each truly +;;; top level form. +(declaim (type index *current-form-number*)) +(defvar *current-form-number*) + ;;; *SOURCE-PATHS* is a hashtable from source code forms to the path ;;; taken through the source to reach the form. This provides a way to ;;; keep track of the location of original source forms, even when ;;; macroexpansions and other arbitary permutations of the code ;;; happen. This table is initialized by calling FIND-SOURCE-PATHS on ;;; the original source. +;;; +;;; It is fairly useless to store symbols, characters, or fixnums in +;;; this table, as 42 is EQ to 42 no matter where in the source it +;;; appears. GET-SOURCE-PATH and NOTE-SOURCE-PATH functions should be +;;; always used to access this table. (declaim (hash-table *source-paths*)) (defvar *source-paths*) +(declaim (inline source-form-has-path-p)) +(defun source-form-has-path-p (form) + (not (typep form '(or symbol fixnum character)))) + +(defun get-source-path (form) + (when (source-form-has-path-p form) + (gethash form *source-paths*))) + +(defun note-source-path (form &rest arguments) + (when (source-form-has-path-p form) + (setf (gethash form *source-paths*) + (apply #'list* 'original-source-start *current-form-number* arguments)))) + ;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link ;;; blocks into as we generate them. This just serves to glue the ;;; emitted blocks together until local call analysis and flow graph @@ -216,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 @@ -231,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)) @@ -288,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 @@ -304,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 @@ -410,13 +436,6 @@ (functional-kind res) :toplevel) res))) -;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the -;;; form number to associate with a source path. This should be bound -;;; to an initial value of 0 before the processing of each truly -;;; top level form. -(declaim (type index *current-form-number*)) -(defvar *current-form-number*) - ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to ;;; find the paths in, and TLF-NUM is the top level form number of the @@ -430,9 +449,8 @@ (sub-find-source-paths form (list tlf-num))) (values)) (defun sub-find-source-paths (form path) - (unless (gethash form *source-paths*) - (setf (gethash form *source-paths*) - (list* 'original-source-start *current-form-number* path)) + (unless (get-source-path form) + (note-source-path form path) (incf *current-form-number*) (let ((pos 0) (subform form) @@ -448,11 +466,7 @@ ;; Otherwise store the containing form. It's ;; not perfect, but better than nothing. (unless (zerop pos) - (setf (gethash subform *source-paths*) - (list* 'original-source-start - *current-form-number* - pos - path)))) + (note-source-path subform pos path))) (incf pos)) (setq subform (cdr subform)) (when (eq subform trail) (return))))) @@ -494,7 +508,7 @@ ;; namespace. (defun ir1-convert (start next result form) (ir1-error-bailout (start next result form) - (let* ((*current-path* (or (gethash form *source-paths*) + (let* ((*current-path* (or (get-source-path form) (cons form *current-path*))) (start (instrument-coverage start nil form))) (cond ((atom form) @@ -509,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 @@ -553,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)) @@ -577,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) @@ -619,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 @@ -737,7 +746,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)" @@ -821,7 +830,7 @@ ;;; Check the policy for whether we should generate code coverage ;;; instrumentation. If not, just return the original START -;;; ctran. Otherwise ninsert code coverage instrumentation after +;;; ctran. Otherwise insert code coverage instrumentation after ;;; START, and return the new ctran. (defun instrument-coverage (start mode form) ;; We don't actually use FORM for anything, it's just convenient to @@ -844,7 +853,7 @@ ;; each instrument for the same block. (or (gethash path *code-coverage-records*) (setf (gethash path *code-coverage-records*) - (cons path nil)))) + (cons path +code-coverage-unmarked+)))) (next (make-ctran)) (*allow-instrumenting* nil)) (push (ctran-block start) @@ -854,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. @@ -871,8 +881,8 @@ ;;; EQness of the conses. (defun maybe-instrument-progn-like (start forms form) (or (when (and *allow-instrumenting* - (not (gethash form *source-paths*))) - (let ((*current-path* (gethash forms *source-paths*))) + (not (get-source-path form))) + (let ((*current-path* (get-source-path forms))) (when *current-path* (instrument-coverage start nil form)))) start)) @@ -887,9 +897,15 @@ (maphash (lambda (info cc) (declare (ignore info)) (dolist (cc-entry cc) - (setf (cdr cc-entry) nil))) + (setf (cdr cc-entry) +code-coverage-unmarked+))) *code-coverage-info*)) +(defun code-coverage-record-marked (record) + (aver (consp record)) + (ecase (cdr record) + ((#.+code-coverage-unmarked+) nil) + ((t) t))) + ;;;; converting combinations