- (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)))
+
+ (let ((fun (fun-info-destroyed-constant-args info)))
+ (when fun
+ (let ((destroyed-constant-args (funcall fun args)))
+ (when destroyed-constant-args
+ (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))
+ (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))))))))