;;; appropriate.)
;;;
;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV
-;;; combination, which may change the succesor of the call to be the
+;;; combination, which may change the successor of the call to be the
;;; called function, and if so, checks if the call can become an
;;; assignment. If we convert to an assignment, we abort, since the
;;; RETURN has been deleted.
(setf (lvar-reoptimize arg) nil)))
(check-important-result node info)
(let ((fun (fun-info-destroyed-constant-args info)))
- (when fun
+ (when (and fun
+ ;; If somebody is really sure that they want to modify
+ ;; constants, let them.
+ (policy node (> safety 0)))
(let ((destroyed-constant-args (funcall fun args)))
(when destroyed-constant-args
(let ((*compiler-error-context* node))
(let ((fun (fun-info-optimizer info)))
(unless (and fun (funcall fun node))
- (dolist (x (fun-info-transforms info))
- #!+sb-show
- (when *show-transforms-p*
- (let* ((lvar (basic-combination-fun node))
- (fname (lvar-fun-name lvar t)))
- (/show "trying transform" x (transform-function x) "for" fname)))
- (unless (ir1-transform node x)
- #!+sb-show
- (when *show-transforms-p*
- (/show "quitting because IR1-TRANSFORM result was NIL"))
- (return))))))))
+ ;; First give the VM a peek at the call
+ (multiple-value-bind (style transform)
+ (combination-implementation-style node)
+ (ecase style
+ (:direct
+ ;; The VM knows how to handle this.
+ )
+ (:transform
+ ;; The VM mostly knows how to handle this. We need
+ ;; to massage the call slightly, though.
+ (transform-call node transform (combination-fun-source-name node)))
+ (:default
+ ;; Let transforms have a crack at it.
+ (dolist (x (fun-info-transforms info))
+ #!+sb-show
+ (when *show-transforms-p*
+ (let* ((lvar (basic-combination-fun node))
+ (fname (lvar-fun-name lvar t)))
+ (/show "trying transform" x (transform-function x) "for" fname)))
+ (unless (ir1-transform node x)
+ #!+sb-show
+ (when *show-transforms-p*
+ (/show "quitting because IR1-TRANSFORM result was NIL"))
+ (return)))))))))))
(values))
(:inline t)
(:no-chance nil)
((nil :maybe-inline) (policy call (zerop space))))
+ ;; FIXME & KLUDGE: This LET-CONVERSION check was added as a
+ ;; half-assed workaround for the bug for which the test
+ ;; case :HIGH-DEBUG-KNOWN-FUNCTION-INLINING checks in
+ ;; compiler.pure.lisp. The _real_ culprit seems to be
+ ;; the insertion of BIND/UNBIND-SENTINEL vops.
+ (policy call (plusp let-conversion))
(defined-fun-p leaf)
(defined-fun-inline-expansion leaf)
(let ((fun (defined-fun-functional leaf)))
;; called semi-inlining? A more descriptive name would
;; be nice. -- WHN 2002-01-07
(frob ()
- (let ((res (let ((*allow-instrumenting* t))
- (ir1-convert-lambda-for-defun
- (defined-fun-inline-expansion leaf)
- leaf t
- #'ir1-convert-inline-lambda))))
+ (let* ((name (leaf-source-name leaf))
+ (res (ir1-convert-inline-expansion
+ name
+ (defined-fun-inline-expansion leaf)
+ leaf
+ inlinep
+ (info :function :info name))))
+ ;; allow backward references to this function from
+ ;; following top level forms
(setf (defined-fun-functional leaf) res)
(change-ref-leaf ref res))))
(if ir1-converting-not-optimizing-p
(aver (and (legal-fun-name-p source-name)
(not (eql source-name '.anonymous.))))
(node-ends-block call)
+ ;; The internal variables of a transform are not going to be
+ ;; interesting to the debugger, so there's no sense in
+ ;; suppressing the substitution of variables with only one use
+ ;; (the extra variables can slow down constraint propagation).
+ ;;
+ ;; This needs to be done before the WITH-IR1-ENVIRONMENT-FROM-NODE,
+ ;; so that it will bind *LEXENV* to the right environment.
+ (setf (combination-lexenv call)
+ (make-lexenv :default (combination-lexenv call)
+ :policy (process-optimize-decl
+ '(optimize
+ (preserve-single-use-debug-variables 0))
+ (lexenv-policy
+ (combination-lexenv call)))))
(with-ir1-environment-from-node call
(with-component-last-block (*current-component*
(block-next (node-block call)))
+
(let ((new-fun (ir1-convert-inline-lambda
res
- :debug-name (debug-name 'lambda-inlined source-name)))
+ :debug-name (debug-name 'lambda-inlined source-name)
+ :system-lambda t))
(ref (lvar-use (combination-fun call))))
(change-ref-leaf ref new-fun)
(setf (combination-kind call) :full)
leaf var)))
t)))))
((and (null (rest (leaf-refs var)))
+ ;; Don't substitute single-ref variables on high-debug /
+ ;; low speed, to improve the debugging experience.
+ (policy call (< preserve-single-use-debug-variables 3))
(substitute-single-use-lvar arg var)))
(t
(propagate-to-refs var (lvar-type arg))))))
;;; TODO:
;;; - CAST chains;
+(defun delete-cast (cast)
+ (declare (type cast cast))
+ (let ((value (cast-value cast))
+ (lvar (node-lvar cast)))
+ (delete-filter cast lvar value)
+ (when lvar
+ (reoptimize-lvar lvar)
+ (when (lvar-single-value-p lvar)
+ (note-single-valuified-lvar lvar)))
+ (values)))
+
(defun ir1-optimize-cast (cast &optional do-not-optimize)
(declare (type cast cast))
(let ((value (cast-value cast))
(let ((lvar (node-lvar cast)))
(when (values-subtypep (lvar-derived-type value)
(cast-asserted-type cast))
- (delete-filter cast lvar value)
- (when lvar
- (reoptimize-lvar lvar)
- (when (lvar-single-value-p lvar)
- (note-single-valuified-lvar lvar)))
+ (delete-cast cast)
(return-from ir1-optimize-cast t))
(when (and (listp (lvar-uses value))
(unless do-not-optimize
(setf (node-reoptimize cast) nil)))
+
+(deftransform make-symbol ((string) (simple-string))
+ `(%make-symbol string))