status output.
#| -*-Scheme-*-
-$Id: asstop.scm,v 1.14 2003/02/14 18:28:01 cph Exp $
+$Id: asstop.scm,v 1.15 2006/10/25 05:42:13 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright 1992,1993,1994,2001,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(compiler-phase
"Assembly"
(lambda ()
- (with-values (lambda () (assemble *block-label* (last-reference *lap*)))
- (lambda (count code-vector labels bindings)
- (set! *code-vector* code-vector)
- (set! *entry-points* labels)
- (set! *label-bindings* bindings)
- (if compiler:show-phases?
- (begin
- (newline)
- (write-string *output-prefix*)
- (write-string " Branch tensioning done in ")
- (write (1+ count))
- (write-string
- (if (zero? count) " iteration." " iterations.")))))))))
+ (receive (count code-vector labels bindings)
+ (assemble *block-label* (last-reference *lap*))
+ (set! *code-vector* code-vector)
+ (set! *entry-points* labels)
+ (set! *label-bindings* bindings)
+ (if compiler:show-phases?
+ (write-notification-line
+ (lambda (port)
+ (write-string "Branch tensioning done in " port)
+ (write (+ count 1) port)
+ (write-string " iteration" port)
+ (if (> count 0) (write-string "s" port))
+ (write-string "." port))))))))
(define (phase/link)
(compiler-phase
;;; Various ways of dumping an info file
(define (compiler:dump-inf-file binf pathname)
- (fasdump binf pathname #t)
- (announce-info-files pathname))
+ (fasdump binf pathname))
(define (compiler:dump-bif/bsm-files binf pathname)
(let ((bif-path (pathname-new-type pathname "bif"))
(bsm-path (pathname-new-type pathname "bsm")))
(let ((bsm (split-inf-structure! binf bsm-path)))
- (fasdump binf bif-path #t)
- (fasdump bsm bsm-path #t))
- (announce-info-files bif-path bsm-path)))
+ (fasdump binf bif-path)
+ (fasdump bsm bsm-path))))
(define (compiler:dump-bci/bcs-files binf pathname)
(let ((bci-path (pathname-new-type pathname "bci"))
(bcs-path (pathname-new-type pathname "bcs")))
(let ((bsm (split-inf-structure! binf bcs-path)))
- (call-with-temporary-filename
- (lambda (bif-name)
- (fasdump binf bif-name #t)
- (compress bif-name bci-path)))
- (call-with-temporary-filename
- (lambda (bsm-name)
- (fasdump bsm bsm-name #t)
- (compress bsm-name bcs-path))))
- (announce-info-files bci-path bcs-path)))
-
+ (dump-compressed binf bci-path)
+ (dump-compressed bsm bcs-path))))
+
(define (compiler:dump-bci-file binf pathname)
(let ((bci-path (pathname-new-type pathname "bci")))
(split-inf-structure! binf #f)
- (call-with-temporary-filename
- (lambda (bif-name)
- (fasdump binf bif-name #t)
- (compress bif-name bci-path)))
- (announce-info-files bci-path)))
-
-(define (announce-info-files . files)
- (if compiler:noisy?
- (let ((port (nearest-cmdl/port)))
- (let loop ((files files))
- (if (null? files)
- unspecific
- (begin
- (fresh-line port)
- (write-string ";")
- (write (->namestring (car files)))
- (write-string " dumped ")
- (loop (cdr files))))))))
+ (dump-compressed binf bci-path)))
+
+(define (dump-compressed object path)
+ (with-notification (lambda (port)
+ (write-string "Dumping " port)
+ (write (enough-namestring path) port))
+ (lambda ()
+ (call-with-temporary-filename
+ (lambda (temp)
+ (fasdump object temp #t)
+ (compress temp path))))))
(define compiler:dump-info-file
compiler:dump-bci-file)
+
+(define (compile-data-from-file scode output-pathname)
+ scode output-pathname
+ (error "Illegal operation:" 'COMPILE-DATA-FROM-FILE))
\f
;;;; LAP->CODE
;;; Example of `lap->code' usage (MC68020):
#| -*-Scheme-*-
-$Id: toplev.scm,v 4.65 2006/09/16 11:19:09 gjr Exp $
+$Id: toplev.scm,v 4.66 2006/10/25 05:42:21 cph Exp $
-Copyright (c) 1988-2001, 2006 Massachusetts Institute of Technology
+Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
+Copyright 1993,1994,1997,1999,2000,2001 Massachusetts Institute of Technology
+Copyright 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(warn "Missing dependency:"
(->namestring dependency))
#f)))))))))
- (if (not (null? reasons))
+ (if (pair? reasons)
(begin
- (fresh-line)
- (write-string ";Generating ")
- (write (->namestring output-file))
- (write-string " because of:")
- (for-each (lambda (reason)
- (write-char #\space)
- (write (->namestring reason)))
- reasons)
- (newline)
+ (write-notification-line
+ (lambda (port)
+ (write-string ";Generating " port)
+ (write (->namestring output-file) port)
+ (write-string " because of:" port)
+ (for-each (lambda (reason)
+ (write-char #\space port)
+ (write (->namestring reason) port))
+ reasons)))
(doit)))))))
(set! compile-file
(if output-string
(merge-pathnames output-string output-pathname)
output-pathname))))
- (if compiler:noisy?
- (begin
- (fresh-line)
- (write-string "Compile File: ")
- (write (enough-namestring input-pathname))
- (write-string " => ")
- (write (enough-namestring output-pathname))
- (newline)))
- (compiler-file-output
- (transform input-pathname output-pathname)
- output-pathname)))))
+ (let ((do-it
+ (lambda ()
+ (compiler-file-output
+ (transform input-pathname output-pathname)
+ output-pathname))))
+ (if compiler:noisy?
+ (with-notification
+ (lambda (port)
+ (write-string ";Compile File: " port)
+ (write (enough-namestring input-pathname) port)
+ (write-string " => " port)
+ (write (enough-namestring output-pathname) port))
+ do-it)
+ (do-it)))))))
(kernel
(if compiler:batch-mode?
(batch-kernel core)
(if (not compiler:abort-handled?)
(error "Not set up to abort" value))
(fresh-line)
- (write-string "*** Aborting...")
+ (write-string ";*** Aborting...")
(newline)
(compiler:abort-continuation value))
;; Used by the compiler when it wants to compile subexpressions as
;; separate code-blocks.
;; The rtl output should be fixed.
- (let ((my-number *recursive-compilation-count*)
- (output?
- (and compiler:show-phases?
- (not compiler:show-procedures?))))
- (set! *recursive-compilation-count* (1+ my-number))
- (if output?
- (begin
- (fresh-line)
- (newline)
- (write-string *output-prefix*)
- (write-string "*** Recursive compilation ")
- (write my-number)
- (write-string " ***")
- (newline)))
- (let ((value
- ((let ((do-it
- (lambda ()
- (fluid-let ((*recursive-compilation-number* my-number)
- (compiler:package-optimization-level 'NONE)
- (*procedure-result?* procedure-result?))
- (compile-scode/internal
- scode
- (and *info-output-filename*
- (if (eq? *info-output-filename* 'KEEP)
- 'KEEP
- 'RECURSIVE))
- *rtl-output-port*
- *lap-output-port*
- bind-compiler-variables)))))
- (if procedure-result?
- (let ((do-it
- (lambda ()
- (let ((result (do-it)))
- (set! *remote-links*
- (cons (cdr result) *remote-links*))
- (car result)))))
- (if compiler:show-procedures?
- (lambda ()
- (compiler-phase/visible
- (string-append
- "Compiling procedure: "
- (write-to-string procedure-name))
- do-it))
- do-it))
- (lambda ()
- (fluid-let ((*remote-links* '()))
- (do-it))))))))
- (if output?
- (begin
- (fresh-line)
- (write-string *output-prefix*)
- (write-string "*** Done with recursive compilation ")
- (write my-number)
- (write-string " ***")
- (newline)
- (newline)))
- value)))
+ (let ((my-number *recursive-compilation-count*))
+ (set! *recursive-compilation-count* (+ my-number 1))
+ (let ((do-it
+ (lambda ()
+ (compile-recursively-1 scode
+ procedure-result?
+ procedure-name
+ my-number))))
+ (if (and compiler:show-phases?
+ (not compiler:show-procedures?))
+ (with-notification (lambda (port)
+ (write-string "*** Recursive compilation " port)
+ (write my-number port))
+ do-it)
+ (do-it)))))
+
+(define (compile-recursively-1 scode procedure-result? procedure-name
+ my-number)
+ (let ((do-it
+ (lambda ()
+ (fluid-let ((*recursive-compilation-number* my-number)
+ (compiler:package-optimization-level 'NONE)
+ (*procedure-result?* procedure-result?))
+ (compile-scode/internal
+ scode
+ (and *info-output-filename*
+ (if (eq? *info-output-filename* 'KEEP)
+ 'KEEP
+ 'RECURSIVE))
+ *rtl-output-port*
+ *lap-output-port*
+ bind-compiler-variables)))))
+ (if procedure-result?
+ (let ((do-it
+ (lambda ()
+ (let ((result (do-it)))
+ (set! *remote-links*
+ (cons (cdr result) *remote-links*))
+ (car result)))))
+ (if compiler:show-procedures?
+ (compiler-phase/visible
+ (call-with-output-string
+ (lambda (port)
+ (write-string "Compiling procedure: " port)
+ (write procedure-name port)))
+ do-it)
+ (do-it)))
+ (fluid-let ((*remote-links* '()))
+ (do-it)))))
\f
;;;; Global variables
(compiler-phase/invisible thunk)))
(define (compiler-phase/visible name thunk)
- (fluid-let ((*output-prefix* (string-append " " *output-prefix*)))
- (fresh-line)
- (write-string *output-prefix*)
- (write-string name)
- (write-string "...")
- (newline)
+ (let ((thunk
+ (lambda ()
+ (with-notification (lambda (port) (write-string name port))
+ thunk))))
(if compiler:show-time-reports?
(let ((process-start *process-time*)
(real-start *real-time*))
(let ((value (thunk)))
- (compiler-time-report " Time taken"
+ (compiler-time-report "Time taken"
(- *process-time* process-start)
(- *real-time* real-start))
value))
(thunk))))
-(define *output-prefix* "")
(define *phase-level* 0)
(define (compiler-phase/invisible thunk)
(do-it)))))
(define (compiler-time-report prefix process-time real-time)
- (write-string *output-prefix*)
- (write-string prefix)
- (write-string ": ")
- (write (/ (exact->inexact process-time) 1000))
- (write-string " (process time); ")
- (write (/ (exact->inexact real-time) 1000))
- (write-string " (real time)")
- (newline))
+ (write-notification-line
+ (lambda (port)
+ (write-string prefix port)
+ (write-string ": " port)
+ (write (/ (exact->inexact process-time) 1000) port)
+ (write-string " (process time); " port)
+ (write (/ (exact->inexact real-time) 1000) port)
+ (write-string " (real time)" port))))
\f
(define (phase/fg-generation)
(compiler-superphase "Flow Graph Generation"
(- (rgraph-n-registers rgraph)
number-of-machine-registers))
*rtl-graphs*)))
- (write-string *output-prefix*)
- (write-string " Registers used: ")
- (write (apply max n-registers))
- (write-string " max, ")
- (write (apply min n-registers))
- (write-string " min, ")
- (write
- (exact->inexact (/ (apply + n-registers) (length n-registers))))
- (write-string " mean")
- (newline))))))
+ (write-notification-line
+ (lambda (port)
+ (write-string "Registers used: " port)
+ (write (apply max n-registers) port)
+ (write-string " max, " port)
+ (write (apply min n-registers) port)
+ (write-string " min, " port)
+ (write (exact->inexact (/ (apply + n-registers)
+ (length n-registers)))
+ port)
+ (write-string " mean" port))))))))
(define (phase/rtl-optimization)
(compiler-superphase "RTL Optimization"
(write-string "RTL for object " port)
(write *recursive-compilation-number* port)
(newline port)
- (pp scode port #T 4)
+ (pp scode port #t 4)
(newline port)
(newline port)
(write-rtl-instructions (linearize-rtl *rtl-root*
(write-string "LAP for object ")
(write *recursive-compilation-number*)
(newline)
- (pp scode (current-output-port) #T 4)
+ (pp scode (current-output-port) #t 4)
(newline)
(newline)
(newline)
#| -*-Scheme-*-
-$Id: ctop.scm,v 1.18 2006/10/01 05:37:56 cph Exp $
+$Id: ctop.scm,v 1.19 2006/10/25 05:42:48 cph Exp $
Copyright 1993,2006 Massachusetts Institute of Technology
(define (compiler:dump-bci-file binf pathname)
(let ((bci-path (pathname-new-type pathname "bci")))
(split-inf-structure! binf false)
- (call-with-temporary-filename
- (lambda (bif-name)
- (fasdump binf bif-name true)
- (compress bif-name bci-path)))
- (announce-info-files bci-path)))
-
-(define (announce-info-files . files)
- (if compiler:noisy?
- (let ((port (nearest-cmdl/port)))
- (let loop ((files files))
- (if (null? files)
- unspecific
- (begin
- (fresh-line port)
- (write-string ";")
- (write (->namestring (car files)))
- (write-string " dumped ")
- (loop (cdr files))))))))
+ (dump-compressed binf bci-path)))
+
+(define (dump-compressed object path)
+ (with-notification (lambda (port)
+ (write-string "Dumping " port)
+ (write (enough-namestring path) port))
+ (lambda ()
+ (call-with-temporary-filename
+ (lambda (temp)
+ (fasdump object temp #t)
+ (compress temp path))))))
(define compiler:dump-info-file compiler:dump-bci-file)
\f
#| -*-Scheme-*-
-$Id: toplev.scm,v 4.27 2006/09/29 19:30:07 cph Exp $
+$Id: toplev.scm,v 4.28 2006/10/25 05:41:02 cph Exp $
Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
Copyright 1993,1995,1997,2000,2001,2002 Massachusetts Institute of Technology
(define (sf/internal input-pathname bin-pathname spec-pathname
environment declarations)
spec-pathname ;ignored
- (let ((start-date (get-decoded-time)))
+ (let ((do-it
+ (let ((start-date (get-decoded-time)))
+ (lambda ()
+ (fasdump (make-comment
+ `((SOURCE-FILE . ,(->namestring input-pathname))
+ (DATE ,(decoded-time/year start-date)
+ ,(decoded-time/month start-date)
+ ,(decoded-time/day start-date))
+ (TIME ,(decoded-time/hour start-date)
+ ,(decoded-time/minute start-date)
+ ,(decoded-time/second start-date)))
+ (sf/file->scode input-pathname bin-pathname
+ environment declarations))
+ bin-pathname)))))
(if sf:noisy?
- (let ((port (notification-output-port)))
- (fresh-line port)
- (write-string "Syntax file: " port)
- (write (enough-namestring input-pathname) port)
- (write-string " " port)
- (write (enough-namestring bin-pathname) port)
- (newline port)))
- (fasdump (make-comment
- `((SOURCE-FILE . ,(->namestring input-pathname))
- (DATE ,(decoded-time/year start-date)
- ,(decoded-time/month start-date)
- ,(decoded-time/day start-date))
- (TIME ,(decoded-time/hour start-date)
- ,(decoded-time/minute start-date)
- ,(decoded-time/second start-date)))
- (sf/file->scode input-pathname bin-pathname
- environment declarations))
- bin-pathname)))
+ (let ((message
+ (lambda (port)
+ (write-string "Syntax file: " port)
+ (write (enough-namestring input-pathname) port)
+ (write-string " " port)
+ (write (enough-namestring bin-pathname) port))))
+ (if (eq? sf:noisy? 'old-style)
+ (timed message do-it)
+ (with-notification message do-it)))
+ (do-it))))
(define (sf/file->scode input-pathname output-pathname
environment declarations)
expression))))
(define (integrate/kernel get-scode)
- (fluid-let ((previous-name #f)
- (previous-process-time #f)
- (previous-real-time #f))
- (receive (expression externs-block externs)
- (call-with-values
- (lambda ()
- (call-with-values (lambda () (phase:transform (get-scode)))
- phase:optimize))
- phase:generate-scode)
- (end-phase)
- (values expression externs-block externs))))
-\f
+ (receive (operations environment expression)
+ (receive (block expression) (phase:transform (get-scode))
+ (phase:optimize block expression))
+ (phase:generate-scode operations environment expression)))
+
(define (phase:read filename)
- (mark-phase "Read")
- (read-file filename))
+ (in-phase "Read" (lambda () (read-file filename))))
(define (phase:syntax s-expressions environment declarations)
- (mark-phase "Syntax")
- (syntax* (if (null? declarations)
- s-expressions
- (cons (cons (close-syntax 'DECLARE system-global-environment)
- declarations)
- s-expressions))
- environment))
+ (in-phase "Syntax"
+ (lambda ()
+ (syntax* (if (null? declarations)
+ s-expressions
+ (cons (cons (close-syntax 'DECLARE
+ system-global-environment)
+ declarations)
+ s-expressions))
+ environment))))
(define (phase:transform scode)
- (mark-phase "Transform")
- (transform/top-level scode sf/top-level-definitions))
+ (in-phase "Transform"
+ (lambda ()
+ (transform/top-level scode sf/top-level-definitions))))
(define (phase:optimize block expression)
- (mark-phase "Optimize")
- (integrate/top-level block expression))
+ (in-phase "Optimize" (lambda () (integrate/top-level block expression))))
(define (phase:generate-scode operations environment expression)
- (mark-phase "Generate SCode")
- (receive (externs-block externs)
- (operations->external operations environment)
- (values (cgen/external expression) externs-block externs)))
-
-(define previous-name)
-(define previous-process-time)
-(define previous-real-time)
-
-(define (mark-phase this-name)
- (end-phase)
- (if (eq? sf:noisy? 'old-style)
- (let ((port (notification-output-port)))
- (fresh-line port)
- (write-string " " port)
- (write-string this-name port)
- (write-string "..." port)
- (newline port)))
- (set! previous-name this-name)
- unspecific)
-
-(define (end-phase)
- (let ((this-process-time (process-time-clock))
- (this-real-time (real-time-clock)))
- (if previous-process-time
- (let ((delta-process-time (- this-process-time previous-process-time)))
- (time-report " Time taken"
- delta-process-time
- (- this-real-time previous-real-time))))
- (set! previous-process-time this-process-time)
- (set! previous-real-time this-real-time))
- unspecific)
+ (in-phase "Generate SCode"
+ (lambda ()
+ (receive (externs-block externs)
+ (operations->external operations environment)
+ (values (cgen/external expression) externs-block externs)))))
-;; Should match the compiler. We'll merge the two at some point.
-(define (time-report prefix process-time real-time)
+(define (in-phase name thunk)
(if (eq? sf:noisy? 'old-style)
- (let ((port (notification-output-port)))
- (fresh-line port)
- (write-string prefix port)
- (write-string ": " port)
- (write (/ (exact->inexact process-time) 1000) port)
- (write-string " (process time); " port)
- (write (/ (exact->inexact real-time) 1000) port)
- (write-string " (real time)" port)
- (newline port))))
\ No newline at end of file
+ (timed (lambda (port)
+ (write-string name port))
+ thunk)
+ (thunk)))
+
+(define (timed message thunk)
+ (let ((start-process-time (process-time-clock))
+ (start-real-time (real-time-clock)))
+ (let ((v (with-notification message thunk)))
+ (let ((process-time (- (process-time-clock) start-process-time))
+ (real-time (- (real-time-clock) start-real-time)))
+ (write-notification-line
+ (lambda (port)
+ (write-string "Time taken: " port)
+ (write (/ (exact->inexact process-time) 1000) port)
+ (write-string " (process time); " port)
+ (write (/ (exact->inexact real-time) 1000) port)
+ (write-string " (real time)" port))))
+ v)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff