home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / base / toplev.scm < prev    next >
Text File  |  2000-01-09  |  33KB  |  1,040 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: toplev.scm,v 4.59 2000/01/10 03:47:47 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Compiler Top Level
  23. ;;; package: (compiler top-level)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Incremental File Compiler
  28.  
  29. (define compile-file:override-usual-integrations '())
  30. (define compile-file:sf-only? #f)
  31. (define compile-file:force? #f)
  32. (define compile-file)
  33. (let ((scm-pathname (lambda (path) (pathname-new-type path "scm")))
  34.       (bin-pathname (lambda (path) (pathname-new-type path "bin")))
  35.       (ext-pathname (lambda (path) (pathname-new-type path "ext")))
  36.       (com-pathname (lambda (path) (pathname-new-type path "com"))))
  37.  
  38.   (define (process-file input-file output-file dependencies processor)
  39.     (let ((doit (lambda () (processor input-file output-file dependencies))))
  40.     (if compile-file:force?
  41.     (doit)
  42.     (let ((reasons
  43.            (let ((output-time (file-modification-time output-file)))
  44.          (if (not output-time)
  45.              (list input-file)
  46.              (list-transform-positive (cons input-file dependencies)
  47.                (lambda (dependency)
  48.              (let ((dep-time (file-modification-time dependency)))
  49.                (if dep-time
  50.                    (> dep-time output-time)
  51.                    (begin
  52.                  (warn "Missing dependency:"
  53.                        (->namestring dependency))
  54.                  #f)))))))))
  55.       (if (not (null? reasons))
  56.           (begin
  57.         (fresh-line)
  58.         (write-string ";Generating ")
  59.         (write (->namestring output-file))
  60.         (write-string " because of:")
  61.         (for-each (lambda (reason)
  62.                 (write-char #\space)
  63.                 (write (->namestring reason)))
  64.               reasons)
  65.         (newline)
  66.         (doit)))))))
  67.  
  68.   (set! compile-file
  69.     (named-lambda (compile-file file #!optional dependencies syntax-table)
  70.       (process-file (scm-pathname file)
  71.             (bin-pathname file)
  72.             (map ext-pathname
  73.                  (if (default-object? dependencies)
  74.                  '()
  75.                  dependencies))
  76.         (lambda (input-file output-file dependencies)
  77.           (fluid-let ((sf/default-syntax-table
  78.                (if (default-object? syntax-table)
  79.                    #f
  80.                    syntax-table))
  81.               (sf/default-declarations
  82.                `((USUAL-INTEGRATIONS
  83.                   ,@compile-file:override-usual-integrations)
  84.                  ,@(if (null? dependencies)
  85.                    '()
  86.                    `((INTEGRATE-EXTERNAL ,@dependencies))))))
  87.         (sf input-file output-file))))
  88.       (if (not compile-file:sf-only?)
  89.           (process-file (bin-pathname file)
  90.                 (com-pathname file)
  91.                 '()
  92.         (lambda (input-file output-file dependencies)
  93.           dependencies
  94.           (fluid-let ((compiler:coalescing-constant-warnings? #f))
  95.             (compile-bin-file input-file output-file))))))))
  96.  
  97. ;;;; Non-Incremental File Compiler
  98.  
  99. (define (cf input #!optional output)
  100.   (let ((kernel
  101.      (lambda (source-file)
  102.        (with-values
  103.            (lambda () (sf/pathname-defaulting source-file false false))
  104.          (lambda (source-pathname bin-pathname spec-pathname)
  105.            ;; Maybe this should be done only if scode-file
  106.            ;; does not exist or is older than source-file.
  107.            (sf source-pathname bin-pathname spec-pathname)
  108.            (if (default-object? output)
  109.            (compile-bin-file bin-pathname)
  110.            (compile-bin-file bin-pathname output)))))))
  111.     (if (pair? input)
  112.     (for-each kernel input)
  113.     (kernel input))))
  114.  
  115. (define (cbf input . rest)
  116.   (apply compile-bin-file input rest))
  117.  
  118. (define (compile-bin-file input-string #!optional output-string)
  119.   (if compiler:cross-compiling?
  120.       (apply cross-compile-bin-file
  121.          (cons input-string (if (default-object? output-string)
  122.                     '()
  123.                     (list output-string))))
  124.       (begin
  125.     (compiler-pathnames
  126.      input-string
  127.      (and (not (default-object? output-string)) output-string)
  128.      (make-pathname false false false false "bin" 'NEWEST)
  129.      (lambda (input-pathname output-pathname)
  130.        (maybe-open-file
  131.         compiler:generate-rtl-files?
  132.         (pathname-new-type output-pathname "rtl")
  133.         (lambda (rtl-output-port)
  134.           (maybe-open-file compiler:generate-lap-files?
  135.                    (pathname-new-type output-pathname "lap")
  136.                    (lambda (lap-output-port)
  137.                  (compile-scode/internal
  138.                   (compiler-fasload input-pathname)
  139.                   (pathname-new-type output-pathname "inf")
  140.                   rtl-output-port
  141.                   lap-output-port)))))))
  142.     unspecific)))
  143.  
  144. (define (maybe-open-file open? pathname receiver)
  145.   (if open?
  146.       (call-with-output-file pathname receiver)
  147.       (receiver false)))
  148.  
  149. (define (compiler-pathnames input-string output-string default transform)
  150.   (let* ((core
  151.       (lambda (input-string)
  152.         (let ((input-pathname (merge-pathnames input-string default)))
  153.           (let ((output-pathname
  154.              (let ((output-pathname
  155.                 (pathname-new-type input-pathname
  156.                            compiled-output-extension)))
  157.                (if output-string
  158.                (merge-pathnames output-string output-pathname)
  159.                output-pathname))))
  160.         (if compiler:noisy?
  161.             (begin
  162.               (fresh-line)
  163.               (write-string "Compile File: ")
  164.               (write (enough-namestring input-pathname))
  165.               (write-string " => ")
  166.               (write (enough-namestring output-pathname))
  167.               (newline)))
  168.         (compiler-file-output
  169.          (transform input-pathname output-pathname)
  170.                       output-pathname)))))
  171.      (kernel
  172.       (if compiler:batch-mode?
  173.           (batch-kernel core)
  174.           core)))
  175.     (if (pair? input-string)
  176.     (for-each kernel input-string)
  177.     (kernel input-string))))
  178.  
  179. (define (compiler-fasload pathname)
  180.   (let ((scode
  181.      (let ((scode (fasload pathname)))
  182.        (if (scode/comment? scode)
  183.            (scode/comment-expression scode)
  184.            scode))))
  185.     (if (scode/open-block? scode)
  186.     (scode/open-block-components scode
  187.       (lambda (names declarations body)
  188.         (if (null? names)
  189.         (scan-defines body
  190.           (lambda (names declarations* body)
  191.             (make-open-block names
  192.                      (append declarations declarations*)
  193.                      body)))
  194.         scode)))
  195.     (scan-defines scode make-open-block))))
  196.  
  197. ;;;; Alternate Entry Points
  198.  
  199. (define (compile-scode scode #!optional keep-debugging-info?)
  200.   (compiler-output->compiled-expression
  201.    (compile-scode/no-file
  202.     scode
  203.     (and (or (default-object? keep-debugging-info?)
  204.          keep-debugging-info?)
  205.      'KEEP))))
  206.  
  207. (define (compile-procedure procedure #!optional keep-debugging-info?)
  208.   (compiler-output->procedure
  209.    (compile-scode/no-file
  210.     (procedure-lambda procedure)
  211.     (and (or (default-object? keep-debugging-info?)
  212.          keep-debugging-info?)
  213.      'KEEP))
  214.    (procedure-environment procedure)))
  215.  
  216. (define (compile-scode/no-file scode keep-debugging-info?)
  217.   (fluid-let ((compiler:noisy? false)
  218.           (*info-output-filename* keep-debugging-info?))
  219.     (compile-scode/internal/hook
  220.      (lambda ()
  221.        (compile-scode/internal scode
  222.                    *info-output-filename*)))))
  223.  
  224. (define (compiler:batch-compile input #!optional output)
  225.   (fluid-let ((compiler:batch-mode? true))
  226.     (bind-condition-handler (list condition-type:error)
  227.     compiler:batch-error-handler
  228.       (lambda ()
  229.     (if (default-object? output)
  230.         (compile-bin-file input)
  231.         (compile-bin-file input output))))))
  232.  
  233. (define (compiler:batch-error-handler condition)
  234.   (let ((port (nearest-cmdl/port)))
  235.     (fresh-line port)
  236.     (write-condition-report condition port)
  237.     (newline port))
  238.   (compiler:abort false))
  239.  
  240. (define (compiler:abort value)
  241.   (if (not compiler:abort-handled?)
  242.       (error "Not set up to abort" value))
  243.   (fresh-line)
  244.   (write-string "*** Aborting...")
  245.   (newline)
  246.   (compiler:abort-continuation value))
  247.  
  248. (define (batch-kernel real-kernel)
  249.   (lambda (input-string)
  250.     (call-with-current-continuation
  251.      (lambda (abort-compilation)
  252.        (fluid-let ((compiler:abort-continuation abort-compilation)
  253.            (compiler:abort-handled? true))
  254.      (real-kernel input-string))))))
  255.  
  256. (define compiler:batch-mode? false)
  257. (define compiler:abort-handled? false)
  258. (define compiler:abort-continuation)
  259.  
  260. (define (compile-recursively scode procedure-result? procedure-name)
  261.   ;; Used by the compiler when it wants to compile subexpressions as
  262.   ;; separate code-blocks.
  263.   ;; The rtl output should be fixed.
  264.   (let ((my-number *recursive-compilation-count*)
  265.     (output?
  266.      (and compiler:show-phases?
  267.           (not compiler:show-procedures?))))
  268.     (set! *recursive-compilation-count* (1+ my-number))
  269.     (if output?
  270.     (begin
  271.       (fresh-line)
  272.       (newline)
  273.       (write-string *output-prefix*)
  274.       (write-string "*** Recursive compilation ")
  275.       (write my-number)
  276.       (write-string " ***")
  277.       (newline)))
  278.     (let ((value
  279.        ((let ((do-it
  280.            (lambda ()
  281.              (fluid-let ((*recursive-compilation-number* my-number)
  282.                  (compiler:package-optimization-level 'NONE)
  283.                  (*procedure-result?* procedure-result?))
  284.                (compile-scode/internal
  285.             scode
  286.             (and *info-output-filename*
  287.                  (if (eq? *info-output-filename* 'KEEP)
  288.                  'KEEP
  289.                  'RECURSIVE))
  290.             *rtl-output-port*
  291.             *lap-output-port*
  292.             bind-compiler-variables)))))
  293.           (if procedure-result?
  294.           (let ((do-it
  295.              (lambda ()
  296.                (let ((result (do-it)))
  297.                  (set! *remote-links*
  298.                    (cons (cdr result) *remote-links*))
  299.                  (car result)))))
  300.             (if compiler:show-procedures?
  301.             (lambda ()
  302.               (compiler-phase/visible
  303.                (string-append
  304.                 "Compiling procedure: "
  305.                 (write-to-string procedure-name))
  306.                do-it))
  307.             do-it))
  308.           (lambda ()
  309.             (fluid-let ((*remote-links* '()))
  310.               (do-it))))))))
  311.       (if output?
  312.       (begin
  313.         (fresh-line)
  314.         (write-string *output-prefix*)
  315.         (write-string "*** Done with recursive compilation ")
  316.         (write my-number)
  317.         (write-string " ***")
  318.         (newline)
  319.         (newline)))
  320.       value)))
  321.  
  322. ;;;; Global variables
  323.  
  324. (define *recursive-compilation-count*)
  325. (define *recursive-compilation-number*)
  326. (define *procedure-result?*)
  327. (define *remote-links*)
  328. (define *process-time*)
  329. (define *real-time*)
  330.  
  331. (define *info-output-filename* false)
  332. (define *rtl-output-port* false)
  333. (define *lap-output-port* false)
  334.  
  335. ;; First set: input to compilation
  336. ;; Last used: phase/canonicalize-scode
  337. (define *input-scode*)
  338.  
  339. ;; First set: phase/canonicalize-scode
  340. ;; Last used: phase/translate-scode
  341. (define *scode*)
  342.  
  343. ;; First set: phase/translate-scode
  344. ;; Last used: phase/fg-optimization-cleanup
  345. (define *root-block*)
  346.  
  347. ;; First set: phase/translate-scode
  348. ;; Last used: phase/rtl-generation
  349. (define *root-expression*)
  350. (define *root-procedure*)
  351.  
  352. ;; First set: phase/rtl-generation
  353. ;; Last used: phase/lap-linearization
  354. (define *rtl-expression*)
  355. (define *rtl-procedures*)
  356. (define *rtl-continuations*)
  357. (define *rtl-graphs*)
  358. (define label->object)
  359. (define *rtl-root*)
  360.  
  361. ;; First set: phase/rtl-generation
  362. ;; Last used: phase/link
  363. (define *ic-procedure-headers*)
  364. (define *entry-label*)
  365.  
  366. ;; First set: phase/lap-generation
  367. ;; Last used: phase/link
  368. (define *subprocedure-linking-info*)
  369.  
  370. ;; First set: phase/lap-linearization
  371. ;; Last used: phase/assemble
  372. (define *lap*)
  373.  
  374. ;; First set: phase/lap-linearization
  375. ;; Last used: phase/info-generation-2
  376. (define *dbg-expression*)
  377. (define *dbg-procedures*)
  378. (define *dbg-continuations*)
  379.  
  380. (define (in-compiler thunk)
  381.   (let ((run-compiler
  382.      (lambda ()
  383.        (let ((value
  384.           (let ((expression (thunk)))
  385.             (let ((others
  386.                (map (lambda (other) (vector-ref other 2))
  387.                 (recursive-compilation-results))))
  388.               (cond ((not (compiled-code-address? expression))
  389.                  (vector compiler:compile-by-procedures?
  390.                      expression
  391.                      others))
  392.                 ((null? others)
  393.                  expression)
  394.                 (else
  395.                  (scode/make-comment
  396.                   (make-dbg-info-vector
  397.                    (let ((all-blocks
  398.                       (list->vector
  399.                        (cons
  400.                     (compiled-code-address->block
  401.                      expression)
  402.                     others))))
  403.                  (if compiler:compile-by-procedures?
  404.                      (list 'COMPILED-BY-PROCEDURES
  405.                        all-blocks
  406.                        (list->vector others))
  407.                      all-blocks)))
  408.                   expression)))))))
  409.          (if compiler:show-time-reports?
  410.          (compiler-time-report "Total compilation time"
  411.                        *process-time*
  412.                        *real-time*))
  413.          value))))
  414.     (if compiler:preserve-data-structures?
  415.     (begin
  416.       (compiler:reset!)
  417.       (run-compiler))
  418.     (fluid-let ((*recursive-compilation-number* 0)
  419.             (*recursive-compilation-count* 1)
  420.             (*procedure-result?* false)
  421.             (*remote-links* '())
  422.             (*process-time* 0)
  423.             (*real-time* 0))
  424.       (bind-assembler&linker-top-level-variables
  425.        (lambda ()
  426.          (bind-compiler-variables run-compiler)))))))
  427.  
  428. (define (bind-compiler-variables thunk)
  429.   ;; Split this fluid-let because compiler was choking on it.
  430.   (fluid-let ((*ic-procedure-headers*)
  431.           (*current-label-number*)
  432.           (*dbg-expression*)
  433.           (*dbg-procedures*)
  434.           (*dbg-continuations*)
  435.           (*lap*)
  436.           (*constants*)
  437.           (*blocks*)
  438.           (*expressions*)
  439.           (*procedures*)
  440.           (*lvalues*))
  441.     (fluid-let ((*applications*)
  442.         (*parallels*)
  443.         (*input-scode*)
  444.         (*scode*)
  445.         (*root-expression*)
  446.         (*root-procedure*)
  447.         (*root-block*)
  448.         (*rtl-expression*)
  449.         (*rtl-procedures*)
  450.         (*rtl-continuations*)
  451.         (*rtl-graphs*)
  452.         (label->object)
  453.         (*rtl-root*)
  454.         (*machine-register-map*)
  455.         (*entry-label*)
  456.         (*subprocedure-linking-info*))
  457.       (bind-assembler&linker-variables thunk))))
  458.  
  459. (define (compiler:reset!)
  460.   (set! *recursive-compilation-number* 0)
  461.   (set! *recursive-compilation-count* 1)
  462.   (set! *procedure-result?* false)
  463.   (set! *remote-links* '())
  464.   (set! *process-time* 0)
  465.   (set! *real-time* 0)
  466.  
  467.   (set! *ic-procedure-headers*)
  468.   (set! *current-label-number*)
  469.   (set! *dbg-expression*)
  470.   (set! *dbg-procedures*)
  471.   (set! *dbg-continuations*)
  472.   (set! *lap*)
  473.   (set! *constants*)
  474.   (set! *blocks*)
  475.   (set! *expressions*)
  476.   (set! *procedures*)
  477.   (set! *lvalues*)
  478.   (set! *applications*)
  479.   (set! *parallels*)
  480.   (set! *input-scode*)
  481.   (set! *scode*)
  482.   (set! *root-expression*)
  483.   (set! *root-procedure*)
  484.   (set! *root-block*)
  485.   (set! *rtl-expression*)
  486.   (set! *rtl-procedures*)
  487.   (set! *rtl-continuations*)
  488.   (set! *rtl-graphs*)
  489.   (set! label->object)
  490.   (set! *rtl-root*)
  491.   (set! *machine-register-map*)
  492.   (set! *entry-label*)
  493.   (set! *subprocedure-linking-info*)
  494.   (assembler&linker-reset!))
  495.  
  496. ;;;; Main Entry Point
  497.  
  498. (define (compile-scode/internal scode
  499.                 #!optional
  500.                 info-output-pathname
  501.                 rtl-output-port
  502.                 lap-output-port
  503.                 wrapper)
  504.   (let ((info-output-pathname
  505.      (if (default-object? info-output-pathname)
  506.          false
  507.          info-output-pathname))
  508.     (rtl-output-port
  509.      (if (default-object? rtl-output-port) false rtl-output-port))
  510.     (lap-output-port
  511.      (if (default-object? lap-output-port) false lap-output-port))
  512.     (wrapper
  513.      (if (default-object? wrapper) in-compiler wrapper)))
  514.     (fluid-let ((*info-output-filename*
  515.          (if (pathname? info-output-pathname)
  516.              info-output-pathname
  517.              *info-output-filename*))
  518.         (*rtl-output-port* rtl-output-port)
  519.         (*lap-output-port* lap-output-port)
  520.         (compiler:show-phases?
  521.          (and compiler:noisy? compiler:show-phases?))
  522.         (compiler:show-subphases?
  523.          (and compiler:noisy? compiler:show-subphases?))
  524.         (compiler:show-time-reports?
  525.          (and compiler:noisy? compiler:show-time-reports?))
  526.         (compiler:show-procedures?
  527.          (and compiler:noisy? compiler:show-procedures?)))
  528.       (wrapper
  529.        (lambda ()
  530.      (set! *input-scode* scode)
  531.      (phase/fg-generation)
  532.      (phase/fg-optimization)
  533.      (phase/rtl-generation)
  534.      #|
  535.      ;; Current info-generation keeps state in-core.
  536.      (if info-output-pathname
  537.          (phase/info-generation-1 info-output-pathname))
  538.      |#
  539.      (phase/rtl-optimization)
  540.      (if rtl-output-port
  541.          (phase/rtl-file-output scode rtl-output-port))
  542.      (phase/lap-generation)
  543.      (phase/lap-linearization)
  544.      (if lap-output-port
  545.          (phase/lap-file-output scode lap-output-port))
  546.      (assemble&link info-output-pathname))))))
  547.  
  548. (define (compiler-phase name thunk)
  549.   (if compiler:show-phases?
  550.       (compiler-phase/visible name
  551.     (lambda ()
  552.       (compiler-phase/invisible thunk)))
  553.       (compiler-phase/invisible thunk)))
  554.  
  555. (define (compiler-superphase name thunk)
  556.   (if compiler:show-subphases?
  557.       (thunk)
  558.       (compiler-phase name thunk)))
  559.  
  560. (define (compiler-subphase name thunk)
  561.   (if compiler:show-subphases?
  562.       (compiler-phase name thunk)
  563.       (compiler-phase/invisible thunk)))
  564.  
  565. (define (compiler-phase/visible name thunk)
  566.   (fluid-let ((*output-prefix* (string-append "    " *output-prefix*)))
  567.     (fresh-line)
  568.     (write-string *output-prefix*)
  569.     (write-string name)
  570.     (write-string "...")
  571.     (newline)
  572.     (if compiler:show-time-reports?
  573.     (let ((process-start *process-time*)
  574.           (real-start *real-time*))
  575.       (let ((value (thunk)))
  576.         (compiler-time-report "  Time taken"
  577.                   (- *process-time* process-start)
  578.                   (- *real-time* real-start))
  579.         value))
  580.     (thunk))))
  581.  
  582. (define *output-prefix* "")
  583. (define *phase-level* 0)
  584.  
  585. (define (compiler-phase/invisible thunk)
  586.   (fluid-let ((*phase-level* (1+ *phase-level*)))
  587.     (let ((do-it
  588.        (if compiler:phase-wrapper
  589.            (lambda () (compiler:phase-wrapper thunk))
  590.            thunk)))
  591.       (if (= 1 *phase-level*)
  592.       (let ((process-start (process-time-clock))
  593.         (real-start (real-time-clock)))
  594.         (let ((value (do-it)))
  595.           (let ((process-delta (- (process-time-clock) process-start))
  596.             (real-delta (- (real-time-clock) real-start)))
  597.         (set! *process-time* (+ process-delta *process-time*))
  598.         (set! *real-time* (+ real-delta *real-time*)))
  599.           value))
  600.       (do-it)))))
  601.  
  602. (define (compiler-time-report prefix process-time real-time)
  603.   (write-string *output-prefix*)
  604.   (write-string prefix)
  605.   (write-string ": ")
  606.   (write (/ (exact->inexact process-time) 1000))
  607.   (write-string " (process time); ")
  608.   (write (/ (exact->inexact real-time) 1000))
  609.   (write-string " (real time)")
  610.   (newline))
  611.  
  612. (define (phase/fg-generation)
  613.   (compiler-superphase "Flow Graph Generation"
  614.     (lambda ()
  615.       (phase/canonicalize-scode)
  616.       (phase/translate-scode))))
  617.  
  618. (define (phase/canonicalize-scode)
  619.   (compiler-subphase "Scode Canonicalization"
  620.     (lambda ()
  621.       (set! *scode* (canonicalize/top-level (last-reference *input-scode*)))
  622.       unspecific)))
  623.  
  624. (define (phase/translate-scode)
  625.   (compiler-subphase "Translation of Scode into Flow Graph"
  626.     (lambda ()
  627.       (set! *current-label-number* 0)
  628.       (set! *constants* '())
  629.       (set! *blocks* '())
  630.       (set! *expressions* '())
  631.       (set! *procedures* '())
  632.       (set! *lvalues* '())
  633.       (set! *applications* '())
  634.       (set! *parallels* '())
  635.       (set! *root-expression* (construct-graph (last-reference *scode*)))
  636.       (if *procedure-result?*
  637.       (let ((node (expression-entry-node *root-expression*)))
  638.         (if (not (and (application? node)
  639.               (application/return? node)))
  640.         (error "Entry node of procedure compilation not return" node))
  641.         (let ((operand (return/operand node)))
  642.           (if (not (procedure? operand))
  643.           (error "Value of procedure compilation not procedure" node))
  644.           (set! *root-procedure* operand))))
  645.       (set! *root-block* (expression-block *root-expression*))
  646.       (if (or (null? *expressions*)
  647.           (not (null? (cdr *expressions*))))
  648.       (error "Multiple expressions"))
  649.       (set! *expressions*)
  650.       unspecific)))
  651.  
  652. (define (phase/fg-optimization)
  653.   (compiler-superphase "Flow Graph Optimization"
  654.     (lambda ()
  655.       (phase/simulate-application)
  656.       (phase/outer-analysis)
  657.       (phase/fold-constants)
  658.       (phase/open-coding-analysis)
  659.       (phase/operator-analysis)
  660.       (phase/environment-optimization)
  661.       (phase/identify-closure-limits)
  662.       (phase/setup-block-types)
  663.       (phase/variable-indirection)
  664.       (phase/compute-call-graph)
  665.       (phase/side-effect-analysis)
  666.       (phase/continuation-analysis)
  667.       (phase/subproblem-analysis)
  668.       (phase/delete-integrated-parameters)
  669.       (phase/subproblem-ordering)
  670.       (phase/delete-integrated-parameters)
  671.       (phase/design-environment-frames)
  672.       (phase/connectivity-analysis)
  673.       (phase/compute-node-offsets)
  674.       (phase/return-equivalencing)
  675.       (phase/info-generation-1)
  676.       (phase/fg-optimization-cleanup))))
  677.  
  678. (define (phase/simulate-application)
  679.   (compiler-subphase "Application Simulation"
  680.     (lambda ()
  681.       (simulate-application *lvalues* *applications*))))
  682.  
  683. (define (phase/outer-analysis)
  684.   (compiler-subphase "Outer Analysis"
  685.     (lambda ()
  686.       (outer-analysis *root-expression* *procedures* *applications*))))
  687.  
  688. (define (phase/fold-constants)
  689.   (compiler-subphase "Fold Constants"
  690.     (lambda ()
  691.       (fold-constants *lvalues* *applications*))))
  692.  
  693. (define (phase/open-coding-analysis)
  694.   (compiler-subphase "Open Coding Analysis"
  695.     (lambda ()
  696.       (open-coding-analysis *applications*))))
  697.  
  698. (define (phase/operator-analysis)
  699.   (compiler-subphase "Operator Analysis"
  700.     (lambda ()
  701.       (operator-analysis *procedures* *applications*))))
  702.  
  703. (define (phase/variable-indirection)
  704.   (compiler-subphase "Variable Indirection"
  705.     (lambda ()
  706.       (initialize-variable-indirections! *lvalues*))))
  707.  
  708. (define (phase/environment-optimization)
  709.   (compiler-subphase "Environment Optimization"
  710.     (lambda ()
  711.       (optimize-environments! *procedures*))))
  712.  
  713. (define (phase/identify-closure-limits)
  714.   (compiler-subphase "Closure Limit Identification"
  715.     (lambda ()
  716.       (identify-closure-limits! *procedures* *applications* *lvalues*)
  717.       (if (not compiler:preserve-data-structures?)
  718.       (for-each (lambda (procedure)
  719.               (if (not (procedure-continuation? procedure))
  720.               (begin
  721.                 (set-procedure-free-callees! procedure '())
  722.                 (set-procedure-free-callers! procedure '()))))
  723.             *procedures*)))))
  724.  
  725. (define (phase/setup-block-types)
  726.   (compiler-subphase "Block Type Determination"
  727.     (lambda ()
  728.       (setup-block-types! *root-block*)
  729.       (if (not compiler:preserve-data-structures?)
  730.       (for-each (lambda (procedure)
  731.               (if (not (procedure-continuation? procedure))
  732.               (set-procedure-variables! procedure '())))
  733.             *procedures*))
  734.       (setup-closure-contexts! *root-expression* *procedures*))))
  735.  
  736. (define (phase/compute-call-graph)
  737.   (compiler-subphase "Call Graph Computation"
  738.     (lambda ()
  739.       (compute-call-graph! *procedures*))))
  740.  
  741. (define (phase/side-effect-analysis)
  742.   (compiler-subphase "Side Effect Analysis"
  743.     (lambda ()
  744.       (side-effect-analysis *procedures* *applications*))))
  745.  
  746. (define (phase/continuation-analysis)
  747.   (compiler-subphase "Continuation Analysis"
  748.     (lambda ()
  749.       (continuation-analysis *blocks*)
  750.       (setup-frame-adjustments *applications*)
  751.       (setup-block-static-links! *blocks*))))
  752.  
  753. (define (phase/subproblem-analysis)
  754.   (compiler-subphase "Subproblem Analysis"
  755.     (lambda ()
  756.       (simplicity-analysis *parallels*)
  757.       (compute-subproblem-free-variables *parallels*))))
  758.  
  759. (define (phase/delete-integrated-parameters)
  760.   (compiler-subphase "Integrated Parameter Deletion"
  761.              (lambda ()
  762.                (delete-integrated-parameters *blocks*))))
  763.  
  764. (define (phase/subproblem-ordering)
  765.   (compiler-subphase "Subproblem Ordering"
  766.     (lambda ()
  767.       (subproblem-ordering *parallels*))))
  768.  
  769. (define (phase/connectivity-analysis)
  770.   (compiler-subphase "Connectivity Analysis"
  771.     (lambda ()
  772.       (connectivity-analysis *root-expression* *procedures*))))
  773.  
  774. (define (phase/design-environment-frames)
  775.   (compiler-subphase "Environment Frame Design"
  776.              (lambda ()
  777.                (design-environment-frames! *blocks*))))
  778.  
  779. (define (phase/compute-node-offsets)
  780.   (compiler-subphase "Stack Frame Offset Determination"
  781.     (lambda ()
  782.       (compute-node-offsets *root-expression*))))
  783.  
  784. (define (phase/return-equivalencing)
  785.   (compiler-subphase "Return Equivalencing"
  786.     (lambda ()
  787.       (find-equivalent-returns! *lvalues* *applications*))))
  788.  
  789. (define (phase/info-generation-1)
  790.   (compiler-subphase "Debugging Information Initialization"
  791.     (lambda ()
  792.       (info-generation-phase-1 *root-expression* *procedures*))))
  793.  
  794. (define (phase/fg-optimization-cleanup)
  795.   (compiler-subphase "Flow Graph Optimization Cleanup"
  796.     (lambda ()
  797.       (if (not compiler:preserve-data-structures?)
  798.       (begin
  799.         (clear-call-graph! *procedures*)
  800.         (set! *constants*)
  801.         (set! *blocks*)
  802.         (set! *procedures*)
  803.         (set! *lvalues*)
  804.         (set! *applications*)
  805.         (set! *parallels*)
  806.         (set! *root-block*)
  807.         unspecific)))))
  808.  
  809. (define (phase/rtl-generation)
  810.   (compiler-phase "RTL Generation"
  811.     (lambda ()
  812.       (set! *ic-procedure-headers* '())
  813.       (initialize-machine-register-map!)
  814.       (with-values
  815.       (lambda ()
  816.         (generate/top-level (last-reference *root-expression*)))
  817.     (lambda (expression procedures continuations rgraphs)
  818.       (set! *rtl-expression* expression)
  819.       (set! *rtl-procedures* procedures)
  820.       (set! *rtl-continuations* continuations)
  821.       (set! *rtl-graphs* rgraphs)
  822.       unspecific))
  823.       (if *procedure-result?*
  824.       (set! *rtl-expression* false))
  825.       (set! label->object
  826.         (make/label->object *rtl-expression*
  827.                 *rtl-procedures*
  828.                 *rtl-continuations*))
  829.       (set! *rtl-root*
  830.         (if *procedure-result?*
  831.         (label->object
  832.          (procedure-label (last-reference *root-procedure*)))
  833.         *rtl-expression*))
  834.       (for-each (lambda (entry)
  835.           (set-cdr! entry
  836.                 (rtl-procedure/external-label
  837.                  (label->object (cdr entry)))))
  838.         *ic-procedure-headers*)
  839.       (if compiler:show-phases?
  840.       (let ((n-registers
  841.          (map (lambda (rgraph)
  842.             (- (rgraph-n-registers rgraph)
  843.                number-of-machine-registers))
  844.               *rtl-graphs*)))
  845.         (write-string *output-prefix*)
  846.         (write-string "  Registers used: ")
  847.         (write (apply max n-registers))
  848.         (write-string " max, ")
  849.         (write (apply min n-registers))
  850.         (write-string " min, ")
  851.         (write
  852.          (exact->inexact (/ (apply + n-registers) (length n-registers))))
  853.         (write-string " mean")
  854.         (newline))))))
  855.  
  856. (define (phase/rtl-optimization)
  857.   (compiler-superphase "RTL Optimization"
  858.     (lambda ()
  859.       (phase/rtl-dataflow-analysis)
  860.       (phase/rtl-rewriting rtl-rewriting:pre-cse)
  861.       (if compiler:cse?
  862.       (phase/common-subexpression-elimination))
  863.       (phase/invertible-expression-elimination)
  864.       (phase/rtl-rewriting rtl-rewriting:post-cse)
  865.       (phase/common-suffix-merging)
  866.       (phase/lifetime-analysis)
  867.       (if compiler:code-compression?
  868.       (phase/code-compression))
  869.       (phase/linearization-analysis)
  870.       (phase/register-allocation)
  871.       (phase/rtl-optimization-cleanup))))
  872.  
  873. (define (phase/rtl-dataflow-analysis)
  874.   (compiler-subphase "RTL Dataflow Analysis"
  875.     (lambda ()
  876.       (rtl-dataflow-analysis *rtl-graphs*))))
  877.  
  878. (define (phase/rtl-rewriting rtl-rewriting)
  879.   (compiler-subphase "RTL Rewriting"
  880.     (lambda ()
  881.       (rtl-rewriting *rtl-graphs*))))
  882.  
  883. (define (phase/common-subexpression-elimination)
  884.   (compiler-subphase "Common Subexpression Elimination"
  885.     (lambda ()
  886.       (common-subexpression-elimination *rtl-graphs*))))
  887.  
  888. (define (phase/invertible-expression-elimination)
  889.   (compiler-subphase "Invertible Expression Elimination"
  890.     (lambda ()
  891.       (invertible-expression-elimination *rtl-graphs*))))
  892.  
  893. (define (phase/common-suffix-merging)
  894.   (compiler-subphase "Common Suffix Merging"
  895.     (lambda ()
  896.       (merge-common-suffixes! *rtl-graphs*))))
  897.  
  898. (define (phase/lifetime-analysis)
  899.   (compiler-subphase "Lifetime Analysis"
  900.     (lambda ()
  901.       (lifetime-analysis *rtl-graphs*))))
  902.  
  903. (define (phase/code-compression)
  904.   (compiler-subphase "Instruction Combination"
  905.     (lambda ()
  906.       (code-compression *rtl-graphs*))))
  907.  
  908. (define (phase/linearization-analysis)
  909.   (compiler-subphase "Linearization Analysis"
  910.     (lambda ()
  911.       (setup-bblock-continuations! *rtl-graphs*))))
  912.  
  913. (define (phase/register-allocation)
  914.   (compiler-subphase "Register Allocation"
  915.     (lambda ()
  916.       (register-allocation *rtl-graphs*))))
  917.  
  918. (define (phase/rtl-optimization-cleanup)
  919.   (if (not compiler:preserve-data-structures?)
  920.       (for-each (lambda (rgraph)
  921.           (set-rgraph-bblocks! rgraph false)
  922.           ;; **** this slot is reused. ****
  923.           ;;(set-rgraph-register-bblock! rgraph false)
  924.           (set-rgraph-register-crosses-call?! rgraph false)
  925.           (set-rgraph-register-n-deaths! rgraph false)
  926.           (set-rgraph-register-live-length! rgraph false)
  927.           (set-rgraph-register-n-refs! rgraph false)
  928.           (set-rgraph-register-known-values! rgraph false))
  929.         *rtl-graphs*)))
  930.  
  931. (define (phase/rtl-file-output scode port)
  932.   (compiler-phase "RTL File Output"
  933.     (lambda ()
  934.       (write-string "RTL for object " port)
  935.       (write *recursive-compilation-number* port)
  936.       (newline port)
  937.       (pp scode port #T 4)
  938.       (newline port)
  939.       (newline port)
  940.       (write-rtl-instructions (linearize-rtl *rtl-root*
  941.                          *rtl-procedures*
  942.                          *rtl-continuations*)
  943.                   port)
  944.       (if (not (zero? *recursive-compilation-number*))
  945.       (begin
  946.         (write-char #\page port)
  947.         (newline port)))
  948.       (output-port/flush-output port))))
  949.  
  950. (define (phase/lap-generation)
  951.   (compiler-phase "LAP Generation"
  952.     (lambda ()
  953.       (initialize-back-end!)
  954.       (if *procedure-result?*
  955.       (generate-lap *rtl-graphs* '()
  956.         (lambda (prefix environment-label free-ref-label n-sections)
  957.           (node-insert-snode! (rtl-procedure/entry-node *rtl-root*)
  958.                   (make-sblock prefix))
  959.           (set! *entry-label*
  960.             (rtl-procedure/external-label *rtl-root*))
  961.           (set! *subprocedure-linking-info*
  962.             (vector environment-label free-ref-label n-sections))
  963.           unspecific))
  964.       (begin
  965.         (let ((prefix (generate-lap *rtl-graphs* *remote-links* false)))
  966.           (node-insert-snode! (rtl-expr/entry-node *rtl-root*)
  967.                   (make-sblock prefix)))
  968.         (set! *entry-label* (rtl-expr/label *rtl-root*))
  969.         unspecific)))))
  970.  
  971. (define (phase/lap-linearization)
  972.   (compiler-phase "LAP Linearization"
  973.     (lambda ()
  974.       (set! *lap*
  975.         (optimize-linear-lap
  976.          (wrap-lap *entry-label*
  977.                (linearize-lap *rtl-root*
  978.                       *rtl-procedures*
  979.                       *rtl-continuations*))))
  980.       (with-values
  981.       (lambda ()
  982.         (info-generation-phase-2 *rtl-expression*
  983.                      *rtl-procedures*
  984.                      *rtl-continuations*))
  985.     (lambda (expression procedures continuations)
  986.       (set! *dbg-expression* expression)
  987.       (set! *dbg-procedures* procedures)
  988.       (set! *dbg-continuations* continuations)
  989.       unspecific))
  990.       (if (not compiler:preserve-data-structures?)
  991.       (begin
  992.         (set! *rtl-expression*)
  993.         (set! *rtl-procedures*)
  994.         (set! *rtl-continuations*)
  995.         (set! *rtl-graphs*)
  996.         (set! label->object)
  997.         (set! *rtl-root*)
  998.         unspecific)))))
  999.  
  1000. (define (phase/lap-file-output scode port)
  1001.   (compiler-phase "LAP File Output"
  1002.     (lambda ()
  1003.       (fluid-let ((*unparser-radix* 16)
  1004.           (*unparse-uninterned-symbols-by-name?* true))
  1005.     (with-output-to-port port
  1006.       (lambda ()
  1007.         (write-string "LAP for object ")
  1008.         (write *recursive-compilation-number*)
  1009.         (newline)
  1010.         (pp scode (current-output-port) #T 4)
  1011.         (newline)
  1012.         (newline)
  1013.         (newline)
  1014.         (for-each
  1015.         (lambda (instruction)
  1016.           (cond ((and (pair? instruction)
  1017.                   (eq? (car instruction) 'LABEL))
  1018.              (write (cadr instruction))
  1019.              (write-char #\:))
  1020.             ((and (pair? instruction)
  1021.                   (eq? (car instruction) 'COMMENT))
  1022.              (write-char #\tab)
  1023.              (write-string ";;")
  1024.              (for-each (lambda (frob)
  1025.                      (write-string " ")
  1026.                      (write (if (and (pair? frob)
  1027.                              (eq? (car frob) 'RTL))
  1028.                         (cadr frob)
  1029.                         frob)))
  1030.                (cdr instruction)))
  1031.             (else
  1032.              (write-char #\tab)
  1033.              (write instruction)))
  1034.           (newline))
  1035.           *lap*)
  1036.         (if (not (zero? *recursive-compilation-number*))
  1037.         (begin
  1038.           (write-char #\page)
  1039.           (newline)))
  1040.         (output-port/flush-output port)))))))