#!+sb-show *compiler-trace-output*
*last-source-context* *last-original-source*
*last-source-form* *last-format-string* *last-format-args*
- *last-message-count* *lexenv* *fun-names-in-this-file*))
+ *last-message-count* *lexenv* *fun-names-in-this-file*
+ *allow-instrumenting*))
;;; Whether call of a function which cannot be defined causes a full
;;; warning.
(defvar *check-consistency* nil)
(defvar *all-components*)
+;;; Set to NIL to disable loop analysis for register allocation.
+(defvar *loop-analyze* t)
+
;;; Bind this to a stream to capture various internal debugging output.
(defvar *compiler-trace-output* nil)
is intended to be wrapped around the compilation of all files in the same
system. These keywords are defined:
:OVERRIDE Boolean-Form
- One of the effects of this form is to delay undefined warnings
- until the end of the form, instead of giving them at the end of each
- compilation. If OVERRIDE is NIL (the default), then the outermost
- WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
- OVERRIDE true causes that form to grab any enclosed warnings, even if
- it is enclosed by another WITH-COMPILATION-UNIT."
+ One of the effects of this form is to delay undefined warnings
+ until the end of the form, instead of giving them at the end of each
+ compilation. If OVERRIDE is NIL (the default), then the outermost
+ WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
+ OVERRIDE true causes that form to grab any enclosed warnings, even if
+ it is enclosed by another WITH-COMPILATION-UNIT."
`(%with-compilation-unit (lambda () ,@body) ,@options))
(defun %with-compilation-unit (fn &key override)
(when summary
(if (eq kind :variable)
(compiler-warn
- "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
- ~% ~{~<~% ~1:;~S~>~^ ~}"
+ "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
+ ~% ~{~<~% ~1:;~S~>~^ ~}"
(cdr summary) kind summary)
(compiler-style-warn
- "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
- ~% ~{~<~% ~1:;~S~>~^ ~}"
+ "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
+ ~% ~{~<~% ~1:;~S~>~^ ~}"
(cdr summary) kind summary))))))))
(unless (and (not abort-p)
(maybe-mumble "opt")
(event ir1-optimize-until-done)
(let ((count 0)
- (cleared-reanalyze nil))
+ (cleared-reanalyze nil)
+ (fastp nil))
(loop
(when (component-reanalyze component)
(setq count 0)
(setq cleared-reanalyze t)
(setf (component-reanalyze component) nil))
(setf (component-reoptimize component) nil)
- (ir1-optimize component)
+ (ir1-optimize component fastp)
(cond ((component-reoptimize component)
(incf count)
- (when (= count *max-optimize-iterations*)
+ (when (and (>= count *max-optimize-iterations*)
+ (not (component-reanalyze component))
+ (eq (component-reoptimize component) :maybe))
(maybe-mumble "*")
(cond ((retry-delayed-ir1-transforms :optimize)
(maybe-mumble "+")
(t
(maybe-mumble " ")
(return)))
- (maybe-mumble "."))
+ (setq fastp (>= count *max-optimize-iterations*))
+ (maybe-mumble (if fastp "-" ".")))
(when cleared-reanalyze
(setf (component-reanalyze component) t)))
(values))
(ir1-phases component)
+ (when *loop-analyze*
+ (dfo-as-needed component)
+ (find-dominators component)
+ (loop-analyze component))
+
+ #|
+ (when (and *loop-analyze* *compiler-trace-output*)
+ (labels ((print-blocks (block)
+ (format *compiler-trace-output* " ~A~%" block)
+ (when (block-loop-next block)
+ (print-blocks (block-loop-next block))))
+ (print-loop (loop)
+ (format *compiler-trace-output* "loop=~A~%" loop)
+ (print-blocks (loop-blocks loop))
+ (dolist (l (loop-inferiors loop))
+ (print-loop l))))
+ (print-loop (component-outer-loop component))))
+ |#
+
;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more?
(maybe-mumble "env ")
(physenv-analyze component)
(setf (component-name component)
(debug-namify "~S initial component" name))
(setf (component-kind component) :initial)
- (let* ((locall-fun (ir1-convert-lambdalike
- definition
- :debug-name (debug-namify "top level local call "
- name)
- ;; KLUDGE: we do this so that we get to have
- ;; nice debug returnness in functions defined
- ;; from the REPL
- :allow-debug-catch-tag t))
+ (let* ((locall-fun (let ((*allow-instrumenting* t))
+ (ir1-convert-lambdalike
+ definition
+ :debug-name (debug-namify "top level local call "
+ name))))
(fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
:source-name (or name '.anonymous.)
:debug-name (unless name
'(original-source-start 0 0)))
(when name
(legal-fun-name-or-type-error name))
- (let* ((*lexenv* (make-lexenv :policy *policy*
+ (let* (
+ (*lexenv* (make-lexenv :policy *policy*
:handled-conditions *handled-conditions*
:disabled-package-locks *disabled-package-locks*))
(fun (make-functional-from-toplevel-lambda lambda-expression
(*source-info* info)
(*toplevel-lambdas* ())
(*fun-names-in-this-file* ())
+ (*allow-instrumenting* nil)
(*compiler-error-bailout*
(lambda ()
(compiler-mumble "~2&; fatal error, aborting compilation~%")