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 / asstop.scm next >
Text File  |  1999-01-02  |  11KB  |  363 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: asstop.scm,v 1.11 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 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. ;;;; Assembler and Linker top level
  23. ;;; package: (compiler top-level)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Exports to the compiler
  28.  
  29. (define compiled-output-extension "com")
  30.  
  31. (define (compiler-file-output object pathname)
  32.   (fasdump object pathname))
  33.  
  34. (define (compiler-output->procedure scode environment)
  35.   (scode-eval scode environment))
  36.  
  37. (define (compiler-output->compiled-expression cexp)
  38.   cexp)
  39.  
  40. (define (compile-scode/internal/hook action)
  41.   (action))
  42.  
  43. ;;; Global variables for the assembler and linker
  44.  
  45. (define *recursive-compilation-results*)
  46.  
  47. ;; First set: phase/rtl-generation
  48. ;; Last used: phase/link
  49. (define *block-label*)
  50.  
  51. ;; First set: phase/lap-generation
  52. ;; Last used: phase/info-generation-2
  53. (define *external-labels*)
  54.  
  55. ;; First set: phase/assemble
  56. ;; Last used: phase/link
  57. (define *label-bindings*)
  58. (define *code-vector*)
  59. (define *entry-points*)
  60.  
  61. ;; First set: phase/link
  62. ;; Last used: result of compilation
  63. (define *result*)
  64.  
  65. (define (assemble&link info-output-pathname)
  66.   (phase/assemble)
  67.   (if info-output-pathname
  68.       (phase/info-generation-2 info-output-pathname))
  69.   (phase/link)
  70.   *result*)
  71.  
  72. (define (wrap-lap entry-label some-lap)
  73.   (LAP ,@(if *procedure-result?*
  74.          (LAP (ENTRY-POINT ,entry-label))
  75.          (lap:make-entry-point entry-label *block-label*))
  76.        ,@some-lap))
  77.  
  78. (define (bind-assembler&linker-top-level-variables thunk)
  79.   (fluid-let ((*recursive-compilation-results* '()))
  80.     (thunk)))
  81.  
  82. (define (bind-assembler&linker-variables thunk)
  83.   (fluid-let ((*block-associations*)
  84.           (*block-label*)
  85.           (*external-labels*)
  86.           (*end-of-block-code*)
  87.           (*next-constant*)
  88.           (*interned-assignments*)
  89.           (*interned-constants*)
  90.           (*interned-global-links*)
  91.           (*interned-static-variables*)
  92.           (*interned-uuo-links*)
  93.           (*interned-variables*)
  94.           (*label-bindings*)
  95.           (*code-vector*)
  96.           (*entry-points*)
  97.           (*result*))
  98.     (thunk)))
  99.  
  100. (define (assembler&linker-reset!)
  101.   (set! *recursive-compilation-results* '())
  102.   (set! *block-associations*)
  103.   (set! *block-label*)
  104.   (set! *external-labels*)
  105.   (set! *end-of-block-code*)
  106.   (set! *next-constant*)
  107.   (set! *interned-assignments*)
  108.   (set! *interned-constants*)
  109.   (set! *interned-global-links*)
  110.   (set! *interned-static-variables*)
  111.   (set! *interned-uuo-links*)
  112.   (set! *interned-variables*)
  113.   (set! *label-bindings*)
  114.   (set! *code-vector*)
  115.   (set! *entry-points*)
  116.   (set! *result*)
  117.   unspecific)
  118.  
  119. (define (initialize-back-end!)
  120.   (set! *block-associations* '())
  121.   (set! *block-label* (generate-label))
  122.   (set! *external-labels* '())
  123.   (set! *end-of-block-code* '())
  124.   (set! *next-constant* 0)
  125.   (set! *interned-assignments* '())
  126.   (set! *interned-constants* '())
  127.   (set! *interned-global-links* '())
  128.   (set! *interned-static-variables* '())
  129.   (set! *interned-uuo-links* '())
  130.   (set! *interned-variables* '())
  131.   unspecific)
  132.  
  133. ;;;; Assembler and linker
  134.  
  135. (define (phase/assemble)
  136.   (compiler-phase
  137.    "Assembly"
  138.    (lambda ()
  139.      (with-values (lambda () (assemble *block-label* (last-reference *lap*)))
  140.        (lambda (count code-vector labels bindings)
  141.      (set! *code-vector* code-vector)
  142.      (set! *entry-points* labels)
  143.      (set! *label-bindings* bindings)
  144.      (if compiler:show-phases?
  145.          (begin
  146.            (newline)
  147.            (write-string *output-prefix*)
  148.            (write-string "  Branch tensioning done in ")
  149.            (write (1+ count))
  150.            (write-string
  151.         (if (zero? count) " iteration." " iterations.")))))))))
  152.  
  153. (define (phase/link)
  154.   (compiler-phase
  155.    "Linkification"
  156.    (lambda ()
  157.      ;; This has sections locked against GC to prevent relocation
  158.      ;; while computing addresses.
  159.      (let* ((label->offset
  160.          (lambda (label)
  161.            (cdr (or (assq label *label-bindings*)
  162.             (error "Missing entry point" label)))))
  163.         (bindings
  164.          (map (lambda (label)
  165.             (cons
  166.              label
  167.              (with-absolutely-no-interrupts
  168.                (lambda ()
  169.              ((ucode-primitive primitive-object-set-type)
  170.               type-code:compiled-entry
  171.               (make-non-pointer-object
  172.                (+ (label->offset label)
  173.                   (object-datum *code-vector*))))))))
  174.           *entry-points*))
  175.         (label->address
  176.          (lambda (label)
  177.            (cdr (or (assq label bindings)
  178.             (error "Label not defined as entry point"
  179.                    label))))))
  180.        (set! *result*
  181.          (if *procedure-result?*
  182.          (let ((linking-info *subprocedure-linking-info*))
  183.            (let ((compiled-procedure (label->address *entry-label*))
  184.              (translate-label
  185.               (let ((block-offset (label->offset *block-label*)))
  186.                 (lambda (index)
  187.                   (let ((label (vector-ref linking-info index)))
  188.                 (and label
  189.                      (- (label->offset label)
  190.                     block-offset)))))))
  191.              (cons compiled-procedure
  192.                (vector
  193.                 (compiled-code-address->block compiled-procedure)
  194.                 (translate-label 0)
  195.                 (translate-label 1)
  196.                 (vector-ref linking-info 2)))))
  197.          (label->address *entry-label*)))
  198.        (for-each (lambda (entry)
  199.            (set-lambda-body! (car entry)
  200.                      (label->address (cdr entry))))
  201.          *ic-procedure-headers*))
  202.      ((ucode-primitive declare-compiled-code-block 1) *code-vector*)
  203.      (if (not compiler:preserve-data-structures?)
  204.      (begin
  205.        (set! *code-vector*)
  206.        (set! *entry-points*)
  207.        (set! *subprocedure-linking-info*)
  208.        (set! *label-bindings*)
  209.        (set! *block-label*)
  210.        (set! *entry-label*)
  211.        (set! *ic-procedure-headers*)
  212.        unspecific)))))
  213.  
  214. ;;;; Dumping the assembler's symbol table to the debugging file...
  215.  
  216. (define (phase/info-generation-2 pathname)
  217.   (info-generation-2 pathname set-compiled-code-block/debugging-info!))
  218.  
  219. (define (info-generation-2 pathname set-debugging-info!)
  220.   (compiler-phase "Debugging Information Generation"
  221.     (lambda ()
  222.       (set-debugging-info!
  223.        *code-vector*
  224.        (let ((info
  225.           (info-generation-phase-3
  226.            (last-reference *dbg-expression*)
  227.            (last-reference *dbg-procedures*)
  228.            (last-reference *dbg-continuations*)
  229.            *label-bindings*
  230.            (last-reference *external-labels*))))
  231.      (cond ((eq? pathname 'KEEP)    ; for dynamic execution
  232.         info)
  233.            ((eq? pathname 'RECURSIVE) ; recursive compilation
  234.         (set! *recursive-compilation-results*
  235.               (cons (vector *recursive-compilation-number*
  236.                     info
  237.                     *code-vector*)
  238.                 *recursive-compilation-results*))
  239.         (cons *info-output-filename* *recursive-compilation-number*))
  240.            (else
  241.         (compiler:dump-info-file
  242.          (let ((others (recursive-compilation-results)))
  243.            (if (null? others)
  244.                info
  245.                (list->vector
  246.             (cons info
  247.                   (map (lambda (other) (vector-ref other 1))
  248.                    others)))))
  249.          pathname)
  250.         *info-output-filename*)))))))
  251.  
  252. (define (recursive-compilation-results)
  253.   (sort *recursive-compilation-results*
  254.     (lambda (x y)
  255.       (< (vector-ref x 0)
  256.          (vector-ref y 0)))))
  257.  
  258. ;;; Various ways of dumping an info file
  259.  
  260. (define (compiler:dump-inf-file binf pathname)
  261.   (fasdump binf pathname true)
  262.   (announce-info-files pathname))
  263.  
  264. (define (compiler:dump-bif/bsm-files binf pathname)
  265.   (let ((bif-path (pathname-new-type pathname "bif"))
  266.     (bsm-path (pathname-new-type pathname "bsm")))
  267.     (let ((bsm (split-inf-structure! binf bsm-path)))
  268.       (fasdump binf bif-path true)
  269.       (fasdump bsm bsm-path true))
  270.     (announce-info-files bif-path bsm-path)))
  271.   
  272. (define (compiler:dump-bci/bcs-files binf pathname)
  273.   (let ((bci-path (pathname-new-type pathname "bci"))
  274.     (bcs-path (pathname-new-type pathname "bcs")))
  275.     (let ((bsm (split-inf-structure! binf bcs-path)))
  276.       (call-with-temporary-filename
  277.     (lambda (bif-name)
  278.       (fasdump binf bif-name true)
  279.       (compress bif-name bci-path)))
  280.       (call-with-temporary-filename
  281.     (lambda (bsm-name)
  282.       (fasdump bsm bsm-name true)
  283.       (compress bsm-name bcs-path))))
  284.     (announce-info-files bci-path bcs-path)))
  285.   
  286. (define (compiler:dump-bci-file binf pathname)
  287.   (let ((bci-path (pathname-new-type pathname "bci")))
  288.     (split-inf-structure! binf false)
  289.     (call-with-temporary-filename
  290.       (lambda (bif-name)
  291.     (fasdump binf bif-name true)
  292.     (compress bif-name bci-path)))
  293.     (announce-info-files bci-path)))
  294.  
  295. (define (announce-info-files . files)
  296.   (if compiler:noisy?
  297.       (let ((port (nearest-cmdl/port)))
  298.     (let loop ((files files))
  299.       (if (null? files)
  300.           unspecific
  301.           (begin
  302.         (fresh-line port)
  303.         (write-string ";")
  304.         (write (->namestring (car files)))
  305.         (write-string " dumped ")
  306.         (loop (cdr files))))))))
  307.  
  308. (define compiler:dump-info-file
  309.   compiler:dump-bci-file)
  310.  
  311. ;;;; LAP->CODE
  312. ;;; Example of `lap->code' usage (MC68020):
  313.  
  314. #|
  315. (define bar
  316.   ;; defines bar to be a procedure that adds 1 to its argument
  317.   ;; with no type or range checks.
  318.   (scode-eval
  319.    (lap->code
  320.     'start
  321.     `((entry-point start)
  322.       (dc uw #xffff)
  323.       (block-offset start)
  324.       (label start)
  325.       (pea (@pcr proc))
  326.       (or b (& ,(* (microcode-type 'compiled-entry) 4)) (@a 7))
  327.       (mov l (@a+ 7) (@ao 6 8))
  328.       (and b (& #x3) (@a 7))
  329.       (rts)
  330.       (dc uw #x0202)
  331.       (block-offset proc)
  332.       (label proc)
  333.       (mov l (@a+ 7) (d 0))
  334.       (addq l (& 1) (d 0))
  335.       (mov l (d 0) (@ao 6 8))
  336.       (and b (& #x3) (@a 7))
  337.       (rts)))
  338.    '()))
  339. |#
  340.  
  341. (define (lap->code label instructions)
  342.   (in-compiler
  343.    (lambda ()
  344.      (set! *lap* instructions)
  345.      (set! *entry-label* label)
  346.      (set! *current-label-number* 0)
  347.      (set! *next-constant* 0)
  348.      (set! *interned-assignments* '())
  349.      (set! *interned-constants* '())
  350.      (set! *interned-global-links* '())
  351.      (set! *interned-static-variables* '())
  352.      (set! *interned-uuo-links* '())
  353.      (set! *interned-variables* '())
  354.      (set! *block-label* (generate-label))
  355.      (set! *external-labels* '())
  356.      (set! *ic-procedure-headers* '())
  357.      (phase/assemble)
  358.      (phase/link)
  359.      *result*)))
  360.  
  361. (define (canonicalize-label-name name)
  362.   ;; The Scheme assembler allows any Scheme symbol as a label
  363.   name)