- (when arg
- (setf (lvar-reoptimize arg) nil)))
-
- (let ((attr (fun-info-attributes kind)))
- (when (and (ir1-attributep attr foldable)
- ;; KLUDGE: The next test could be made more sensitive,
- ;; only suppressing constant-folding of functions with
- ;; CALL attributes when they're actually passed
- ;; function arguments. -- WHN 19990918
- (not (ir1-attributep attr call))
- (every #'constant-lvar-p args)
- (node-lvar node)
- ;; Even if the function is foldable in principle,
- ;; it might be one of our low-level
- ;; implementation-specific functions. Such
- ;; functions don't necessarily exist at runtime on
- ;; a plain vanilla ANSI Common Lisp
- ;; cross-compilation host, in which case the
- ;; cross-compiler can't fold it because the
- ;; cross-compiler doesn't know how to evaluate it.
- #+sb-xc-host
- (or (fboundp (combination-fun-source-name node))
- (progn (format t ";;; !!! Unbound fun: (~S~{ ~S~})~%"
- (combination-fun-source-name node)
- (mapcar #'lvar-value args))
- nil)))
- (constant-fold-call node)
- (return-from ir1-optimize-combination)))
-
- (let ((fun (fun-info-derive-type kind)))
- (when fun
- (let ((res (funcall fun node)))
- (when res
- (derive-node-type node (coerce-to-values res))
- (maybe-terminate-block node nil)))))
-
- (let ((fun (fun-info-optimizer kind)))
- (unless (and fun (funcall fun node))
- (dolist (x (fun-info-transforms kind))
- #!+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))))))))
+ (when arg
+ (setf (lvar-reoptimize arg) nil)))
+ (check-important-result node info)
+ (let ((fun (fun-info-destroyed-constant-args info)))
+ (when (and fun
+ ;; If somebody is really sure that they want to modify
+ ;; constants, let them.
+ (policy node (> check-constant-modification 0)))
+ (let ((destroyed-constant-args (funcall fun args)))
+ (when destroyed-constant-args
+ (let ((*compiler-error-context* node))
+ (warn 'constant-modified
+ :fun-name (lvar-fun-name
+ (basic-combination-fun node)))
+ (setf (basic-combination-kind node) :error)
+ (return-from ir1-optimize-combination))))))
+
+ (let ((attr (fun-info-attributes info)))
+ (when (and (ir1-attributep attr foldable)
+ ;; KLUDGE: The next test could be made more sensitive,
+ ;; only suppressing constant-folding of functions with
+ ;; CALL attributes when they're actually passed
+ ;; function arguments. -- WHN 19990918
+ (not (ir1-attributep attr call))
+ (every #'constant-lvar-p args)
+ (node-lvar node))
+ (constant-fold-call node)
+ (return-from ir1-optimize-combination)))
+
+ (let ((fun (fun-info-derive-type info)))
+ (when fun
+ (let ((res (funcall fun node)))
+ (when res
+ (derive-node-type node (coerce-to-values res))
+ (maybe-terminate-block node nil)))))
+
+ (let ((fun (fun-info-optimizer info)))
+ (unless (and fun (funcall fun node))
+ ;; 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)))))))))))