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 / machines / C / ctop.scm < prev    next >
Text File  |  1999-01-02  |  16KB  |  534 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: ctop.scm,v 1.13 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1992-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. ;;;; C-output fake assembler and linker
  23. ;;; package: (compiler top-level)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Exports to the compiler
  28.  
  29. (define compiled-output-extension "c")
  30. (define compiler:invoke-c-compiler? true)
  31. (define compiler:c-compiler-name "cc")
  32. (define compiler:c-compiler-switches 'UNKNOWN)
  33. (define compiler:c-linker-name 'UNKNOWN)
  34. (define compiler:c-linker-switches 'UNKNOWN)
  35. (define compiler:c-linker-output-extension 'UNKNOWN)
  36.  
  37. (define (compiler-file-output object pathname)
  38.   (let ((pair (vector-ref object 1)))
  39.     (call-with-output-file pathname
  40.       (lambda (port)
  41.     (write-string (cdr pair) port)))
  42.     (if compiler:invoke-c-compiler? (c-compile pathname))))
  43.  
  44. (define (compiler-output->procedure compiler-output environment)
  45.   (finish-c-compilation
  46.    compiler-output
  47.    (lambda (shared-library-pathname)
  48.      (load shared-library-pathname environment))))
  49.  
  50. (define (compiler-output->compiled-expression compiler-output)
  51.   (finish-c-compilation
  52.    compiler-output
  53.    (lambda (pathname)
  54.      (let* ((handle ((ucode-primitive load-object-file 1)
  55.              (->namestring pathname)))
  56.         (cth ((ucode-primitive object-lookup-symbol 3)
  57.           handle "dload_initialize_file" 0)))
  58.        (if (not cth)
  59.        (error "compiler-output->compiled-expression:"
  60.           "Cannot find init procedure"
  61.           pathname))
  62.        ((ucode-primitive initialize-c-compiled-block 1)
  63.     ((ucode-primitive address-to-string 1)
  64.      ((ucode-primitive invoke-c-thunk 1)
  65.       cth)))))))
  66.  
  67. (define (compile-scode/internal/hook action)
  68.   (if (not (eq? *info-output-filename* 'KEEP))
  69.       (action)
  70.       (fluid-let ((*info-output-filename*
  71.            (pathname-new-type (compiler-temporary-file-pathname)
  72.                       "inf")))
  73.     (action))))
  74.  
  75. (define (cross-compile-bin-file input . more)
  76.   input more                ; ignored
  77.   (error "cross-compile-bin-file: Meaningless"))
  78.  
  79. (define (optimize-linear-lap lap-program)
  80.   lap-program)
  81.  
  82. (define (compiler-temporary-file-pathname)
  83.   (let ((pathname (temporary-file-pathname)))
  84.     (if (file-exists? pathname)
  85.     (delete-file pathname))
  86.     (if (pathname-type pathname)
  87.     (pathname-new-name
  88.      (pathname-new-type pathname false)
  89.      (string-append (pathname-name pathname)
  90.             "_"
  91.             (pathname-type pathname)))
  92.     pathname)))
  93.  
  94. (define (finish-c-compilation compiler-output action)
  95.   (let* ((file (compiler-temporary-file-pathname))
  96.      (filec (pathname-new-type file "c")))
  97.     (dynamic-wind
  98.      (lambda () false)
  99.      (lambda ()
  100.        (fluid-let ((compiler:invoke-c-compiler? true))
  101.      (compiler-file-output compiler-output filec)
  102.      (action (pathname-new-type file (c-output-extension)))))
  103.      (lambda ()
  104.        (for-each (lambda (type)
  105.            (let ((f (pathname-new-type file type)))
  106.              (if (file-exists? f)
  107.              (delete-file f))))
  108.          (list "c" "o"
  109.                ;; Can't delete this because it is mapped...
  110.                ;; (c-output-extension)
  111.                ))))))
  112.  
  113. (define (c-compile pathname)
  114.   ;; Some c compilers do not leave the output file in the same place.
  115.   (with-working-directory-pathname
  116.     (directory-pathname pathname)
  117.     (lambda ()
  118.       (fluid-let ((*call/cc-c-compiler* compiler:c-compiler-name)
  119.           (*call/cc-warn?* false))
  120.     (let ((source (enough-namestring pathname))
  121.           (object (enough-namestring (pathname-new-type pathname "o")))
  122.           (call/cc*
  123.            (lambda (l)
  124.          (let ((result (apply call/cc l)))
  125.            #|
  126.            ;; Some C compilers always fail
  127.            (if (not (zero? result))
  128.                (error "compiler: C compiler/linker failed"))
  129.            |#
  130.            result))))
  131.       (if compiler:noisy?
  132.           (begin
  133.         (newline)
  134.         (display ";Compiling ")
  135.         (display source)))
  136.       (call/cc* (append (c-compiler-switches) (list source)))
  137.       (set! *call/cc-c-compiler* (c-linker-name))
  138.       (if compiler:noisy?
  139.           (begin
  140.         (newline)
  141.         (display ";Linking ")
  142.         (display object)))
  143.       (call/cc* (append (list "-o")
  144.                 (list
  145.                  (enough-namestring
  146.                   (pathname-new-type pathname
  147.                          (c-output-extension))))
  148.                 (c-linker-switches)
  149.                 (list object)))
  150.       (delete-file object))))))
  151.  
  152. (define (c-output-extension)
  153.   (cond ((not (eq? compiler:c-linker-output-extension 'UNKNOWN))
  154.      compiler:c-linker-output-extension)
  155.     ((assoc microcode-id/operating-system-variant
  156.         c-compiler-switch-table)
  157.      => (lambda (place)
  158.           (set! compiler:c-linker-output-extension (cadr place))
  159.           (cadr place)))
  160.     (else
  161.      (error "c-output-extension: Unknown OS"
  162.         microcode-id/operating-system-variant))))
  163.  
  164. (define c-compiler-switch-table
  165.   `(("AIX"
  166.      "so"
  167.      ("-c" "-O" "-D_AIX")
  168.      ,(lambda (dir)
  169.     (list "-bM:SRE"
  170.           (string-append "-bE:"
  171.                  (->namestring (merge-pathnames dir "liarc.exp")))
  172.           (string-append "-bI:"
  173.                  (->namestring (merge-pathnames dir "scheme.imp")))
  174.           "-edload_initialize_file")))
  175.     ("HP-UX"
  176.      "sl"
  177.      ("-c" "+z" "-O" "-Ae" "-D_HPUX")
  178.      ("-b"))
  179.     ("OSF"
  180.      "so"
  181.      ("-c" "-std1" "-O")
  182.      ("-shared" "-expect_unresolved" "'*'"))
  183.     ("SunOS"
  184.      "so"
  185.      ("-c" "-pic" "-O" "-Dsun4" "-D_SUNOS4" "-w")
  186.      ())))
  187.  
  188. (define (c-compiler-switches)
  189.   (if (not (eq? compiler:c-compiler-switches 'UNKNOWN))
  190.       compiler:c-compiler-switches
  191.       (let ((place (assoc microcode-id/operating-system-variant
  192.               c-compiler-switch-table))
  193.         (dir (system-library-directory-pathname "include")))
  194.     (cond ((not place)
  195.            (error 'c-compiler-switches "Unknown OS"
  196.               microcode-id/operating-system-variant))
  197.           ((not dir)
  198.            (error 'c-compiler-switches
  199.               "Cannot find \"include\" directory"))
  200.           (else
  201.            (let ((result
  202.               (append
  203.                (caddr place)
  204.                (list
  205.             (string-append
  206.              "-I"
  207.              (->namestring
  208.               (directory-pathname-as-file dir)))))))
  209.          (set! compiler:c-compiler-switches result)
  210.          result))))))
  211.  
  212. (define (c-linker-name)
  213.   (if (not (eq? compiler:c-linker-name 'UNKNOWN))
  214.       compiler:c-linker-name
  215.       (let ((new (if (string=? "AIX" microcode-id/operating-system-variant)
  216.              "cc"
  217.              "ld")))
  218.     (set! compiler:c-linker-name new)
  219.     new)))
  220.  
  221. (define (c-linker-switches)
  222.   (cond ((not (eq? compiler:c-linker-switches 'UNKNOWN))
  223.      compiler:c-linker-switches)
  224.     ((assoc microcode-id/operating-system-variant c-compiler-switch-table)
  225.      => (lambda (place)
  226.           (let ((switches
  227.              (let ((switches (cadddr place)))
  228.                (if (not (scode/procedure? switches))
  229.                switches
  230.                (let ((dir (system-library-directory-pathname
  231.                        "include")))
  232.                  (if (not dir)
  233.                  (error 'c-linker-switches
  234.                     "Cannot find \"include\" directory"))
  235.                  (switches dir))))))
  236.         (set! compiler:c-linker-switches switches)
  237.         switches)))
  238.     (else
  239.      (error 'c-linker-switches "Unknown OS"
  240.         microcode-id/operating-system-variant))))
  241.  
  242. (define (recursive-compilation-results)
  243.   (sort *recursive-compilation-results*
  244.     (lambda (x y)
  245.       (< (vector-ref x 0)
  246.          (vector-ref y 0)))))
  247.  
  248. ;; Global variables for assembler and linker
  249.  
  250. (define *recursive-compilation-results*)
  251.  
  252. ;; First set: phase/rtl-generation
  253. ;; Last used: phase/link
  254. (define *block-label*)
  255. (define *disambiguator*)
  256.  
  257. (define *start-label*)
  258.  
  259. ;; First set: phase/lap-generation
  260. ;; Last used: phase/info-generation-2
  261. (define *external-labels*)
  262. (define *special-labels*)
  263.  
  264. ;; First set: phase/lap-generation
  265. ;; Last used: phase/output-generation ???
  266. (define *invoke-interface*)
  267. (define *used-invoke-primitive*)
  268. (define *use-jump-execute-chache*)
  269. (define *use-pop-return*)
  270. (define *purification-root-object*)
  271.  
  272. ;; First set: phase/assemble
  273. ;; Last used: phase/output-generation
  274. (define *C-code-name*)
  275. (define *C-data-name*)
  276. (define *ntags*)
  277. (define *labels*)
  278. (define *code*)
  279.  
  280. ;; First set: phase/output-generation
  281. (define *result*)
  282.  
  283. (define (assemble&link info-output-pathname)
  284.   (phase/assemble info-output-pathname)
  285.   (if info-output-pathname
  286.       (phase/info-generation-2 *labels* info-output-pathname))
  287.   (phase/output-generation)
  288.   *result*)
  289.  
  290. (define (wrap-lap entry-label some-lap)
  291.   (set! *start-label* entry-label)
  292.   (LAP ,@(if *procedure-result?*
  293.          (LAP)
  294.          (lap:make-entry-point entry-label *block-label*))
  295.        ,@some-lap))
  296.  
  297. (define (bind-assembler&linker-top-level-variables thunk)
  298.   (fluid-let ((*recursive-compilation-results* '()))
  299.     (thunk)))
  300.  
  301. (define (bind-assembler&linker-variables thunk)
  302.   (fluid-let ((current-register-list)
  303.           (free-assignments)
  304.           (free-references)
  305.           (free-uuo-links)
  306.           (global-uuo-links)
  307.           (label-num)
  308.           (labels)
  309.           (objects)
  310.           (permanent-register-list)
  311.           (*block-label*)
  312.           (*disambiguator*)
  313.           (*start-label*)
  314.           (*external-labels*)
  315.           (*special-labels*)
  316.           (*invoke-interface*)
  317.           (*used-invoke-primitive*)
  318.           (*use-jump-execute-chache*)
  319.           (*use-pop-return*)
  320.           (*purification-root-object*)
  321.           (*end-of-block-code*)
  322.           (*C-code-name*)
  323.           (*C-data-name*)
  324.           (*ntags*)
  325.           (*labels*)
  326.           (*code*))
  327.     (thunk)))
  328.  
  329. (define (assembler&linker-reset!)
  330.   (set! *recursive-compilation-results* '())
  331.   (set! current-register-list)
  332.   (set! free-assignments)
  333.   (set! free-references)
  334.   (set! free-uuo-links)
  335.   (set! global-uuo-links)
  336.   (set! label-num)
  337.   (set! labels)
  338.   (set! objects)
  339.   (set! permanent-register-list)
  340.   (set! *block-label*)
  341.   (set! *disambiguator*)
  342.   (set! *start-label*)
  343.   (set! *external-labels*)
  344.   (set! *special-labels*)
  345.   (set! *invoke-interface*)
  346.   (set! *used-invoke-primitive*)
  347.   (set! *use-jump-execute-chache*)
  348.   (set! *use-pop-return*)
  349.   (set! *purification-root-object*)
  350.   (set! *end-of-block-code*)
  351.   (set! *C-code-name*)
  352.   (set! *C-data-name*)
  353.   (set! *ntags*)
  354.   (set! *labels*)
  355.   (set! *code*)
  356.   unspecific)
  357.  
  358. (define (initialize-back-end!)
  359.   (set! current-register-list '())
  360.   (set! free-assignments (make-table))
  361.   (set! free-references (make-table))
  362.   (set! free-uuo-links (list 'FOO))
  363.   (set! global-uuo-links (list 'BAR))
  364.   (set! label-num 0)
  365.   (set! labels '())
  366.   (set! objects (make-table))
  367.   (set! permanent-register-list '())
  368.   (set! *block-label* (generate-label))
  369.   (set! *disambiguator*
  370.     (if (zero? *recursive-compilation-number*)
  371.         ""
  372.         (string-append (number->string *recursive-compilation-number*)
  373.                "_")))
  374.   (set! *external-labels* '())
  375.   (set! *special-labels* (make-special-labels))
  376.   (set! *invoke-interface* 'INFINITY)
  377.   (set! *used-invoke-primitive* false)
  378.   (set! *use-jump-execute-chache* false)
  379.   (set! *use-pop-return* false)
  380.   (set! *purification-root-object* false)
  381.   (set! *end-of-block-code* (LAP))
  382.   unspecific)
  383.  
  384. (define (phase/assemble pathname)
  385.   (compiler-phase
  386.    "Pseudo-Assembly"            ; garbage collection
  387.    (lambda ()
  388.      (with-values
  389.      (lambda ()
  390.        (stringify
  391.         (if (not (zero? *recursive-compilation-number*))
  392.         (string-append
  393.          "_"
  394.          (number->string *recursive-compilation-number*))
  395.         "")
  396.         (last-reference *start-label*)
  397.         (last-reference *lap*)
  398.         (cond ((eq? pathname 'RECURSIVE)
  399.            (cons *info-output-filename*
  400.              *recursive-compilation-number*))
  401.           ((eq? pathname 'KEEP)
  402.            (if (zero? *recursive-compilation-number*)
  403.                "foo.bar"
  404.                (cons "foo.bar" *recursive-compilation-number*)))
  405.           (else
  406.            pathname))))
  407.        (lambda (code-name data-name ntags labels code)
  408.      (set! *C-code-name* code-name)
  409.      (set! *C-data-name* data-name)
  410.      (set! *ntags* ntags)
  411.      (set! *labels* labels)
  412.      (set! *code* code)
  413.      unspecific)))))
  414.  
  415. (define (phase/output-generation)
  416.   (if (not (null? *ic-procedure-headers*))
  417.       (error "phase/output-generation: Can't hack IC procedures"))
  418.  
  419.   (set! *result*
  420.     (if *procedure-result?*
  421.         (let* ((linking-info *subprocedure-linking-info*)
  422.            (translate-label
  423.             (lambda (label)
  424.               (let ((place (assq label *labels*)))
  425.             (if (not place)
  426.                 (error "translate-label: Not found" label)
  427.                 (cdr place)))))
  428.            (translate-symbol
  429.             (lambda (index)
  430.               (translate-label (vector-ref linking-info index))))
  431.            (index *recursive-compilation-number*)
  432.            (name (fake-compiled-block-name index)))
  433.           (cons (make-fake-compiled-procedure
  434.              name
  435.              (translate-label *entry-label*))
  436.             (vector
  437.              (make-fake-compiled-block name
  438.                            *C-code-name*
  439.                            *C-data-name*
  440.                            *code*
  441.                            index
  442.                            *ntags*)
  443.              (translate-symbol 0)
  444.              (translate-symbol 1)
  445.              (translate-symbol 2))))
  446.         (cons *C-code-name*
  447.           *code*)))
  448.  
  449.   (if (not compiler:preserve-data-structures?)
  450.       (begin
  451.     (set! *subprocedure-linking-info*)
  452.     (set! *labels*)
  453.     (set! *block-label*)
  454.     (set! *entry-label*)
  455.     (set! *ic-procedure-headers*)
  456.     (set! *code*)
  457.     unspecific)))
  458.  
  459. (define (phase/info-generation-2 labels pathname)
  460.   (info-generation-2 labels pathname))
  461.  
  462. (define (info-generation-2 labels pathname)
  463.   (compiler-phase "Debugging Information Generation"
  464.     (lambda ()
  465.       (let ((info
  466.          (info-generation-phase-3
  467.           (last-reference *dbg-expression*)
  468.           (last-reference *dbg-procedures*)
  469.           (last-reference *dbg-continuations*)
  470.           labels
  471.           (last-reference *external-labels*))))
  472.     (cond ((eq? pathname 'KEEP)    ; for dynamic execution
  473.            info)
  474.           ((eq? pathname 'RECURSIVE) ; recursive compilation
  475.            (set! *recursive-compilation-results*
  476.              (cons (vector *recursive-compilation-number*
  477.                    info
  478.                    false)
  479.                *recursive-compilation-results*))
  480.            unspecific)
  481.           (else
  482.            (compiler:dump-info-file
  483.         (let ((others (recursive-compilation-results)))
  484.           (if (null? others)
  485.               info
  486.               (list->vector
  487.                (cons info
  488.                  (map (lambda (other) (vector-ref other 1))
  489.                   others)))))
  490.         pathname)
  491.            *info-output-filename*))))))
  492.  
  493. (define (compiler:dump-bci-file binf pathname)
  494.   (let ((bci-path (pathname-new-type pathname "bci")))
  495.     (split-inf-structure! binf false)
  496.     (call-with-temporary-filename
  497.       (lambda (bif-name)
  498.     (fasdump binf bif-name true)
  499.     (compress bif-name bci-path)))
  500.     (announce-info-files bci-path)))
  501.  
  502. (define (announce-info-files . files)
  503.   (if compiler:noisy?
  504.       (let ((port (nearest-cmdl/port)))
  505.     (let loop ((files files))
  506.       (if (null? files)
  507.           unspecific
  508.           (begin
  509.         (fresh-line port)
  510.         (write-string ";")
  511.         (write (->namestring (car files)))
  512.         (write-string " dumped ")
  513.         (loop (cdr files))))))))
  514.  
  515. (define compiler:dump-info-file compiler:dump-bci-file)
  516.  
  517. ;; This defintion exported to compiler to handle losing C name restrictions
  518.  
  519. (define (canonicalize-label-name prefix)
  520.   (if (string-null? prefix)
  521.       "empty_string"
  522.       (let* ((str (if (char-alphabetic? (string-ref prefix 0))
  523.               (string-copy prefix)
  524.               (string-append "Z_" prefix)))
  525.          (len (string-length str)))
  526.     (do ((i 0 (1+ i)))
  527.         ((>= i len) str)
  528.       (let ((char (string-ref str i)))
  529.         (if (not (char-alphanumeric? char))
  530.         (string-set! str i
  531.                  (case char
  532.                    ((#\?) #\P)
  533.                    ((#\!) #\B)
  534.                    (else #\_)))))))))