Change COMPILE-SCODE/INTERNAL/HOOK into three separate hooks:

COMPILE-SCODE/FILE/HOOK, COMPILE-SCODE/NO-FILE/HOOK, and
COMPILE-SCODE/RECURSIVE/HOOK.  Use this in the C back end to fix
compilation of scode not from files.  Handle temporary files more
carefully in the C back end.  Remove vestiges of support for keeping
debugging info in the C back end, which depends on such operations as
SET-COMPILED-CODE-BLOCK/DEBUGGING-INFO! not available in the C code
generator.  The info should perhaps be returned in the compiler
output, and applied in FINISH-C-COMPILATION to the compiled code
block, but this is trickier than it sounds.  For now we'll just not
pretend to support keeping debugging info.

diff --git a/v7/src/compiler/base/asstop.scm b/v7/src/compiler/base/asstop.scm
index f42b4e19256b2cce49712dd678493597c537a5b0..666a60141e0693f6d05b454978cc30c0083badfd 100644 (file)
--- a/v7/src/compiler/base/asstop.scm
+++ b/v7/src/compiler/base/asstop.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: asstop.scm,v 1.21 2008/01/30 20:01:42 cph Exp $
+$Id: asstop.scm,v 1.22 2008/09/10 15:12:07 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -44,7 +44,14 @@ USA.
 (define (compiler-output->compiled-expression cexp)
   cexp)
 
-(define (compile-scode/internal/hook action)
+(define (compile-scode/file/hook input-pathname output-pathname action)
+  input-pathname output-pathname
+  (action))
+
+(define (compile-scode/no-file/hook action)
+  (action))
+
+(define (compile-scode/recursive/hook action)
   (action))
 
 ;;; Global variables for the assembler and linker

diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm
index 8d52f62aab3d0c6d38ad738e53426a89b784d35b..c82d0c23f6b9f4fc24fdaaf5525771287d66ed14 100644 (file)
--- a/v7/src/compiler/base/toplev.scm
+++ b/v7/src/compiler/base/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: toplev.scm,v 4.77 2008/01/30 20:01:43 cph Exp $
+$Id: toplev.scm,v 4.78 2008/09/10 15:12:07 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -152,13 +152,17 @@ USA.
                 (lambda (lap-output-port)
                   (fluid-let ((*debugging-key*
                                (random-byte-vector 32)))
-                    (compile-scode/internal
-                     scode
-                     (pathname-new-type
-                      output-pathname
-                      (compiler:compiled-inf-pathname-type))
-                     rtl-output-port
-                     lap-output-port)))))))))))
+                    (compile-scode/file/hook
+                     input-pathname
+                     output-pathname
+                     (lambda ()
+                       (compile-scode/internal
+                        scode
+                        (pathname-new-type
+                         output-pathname
+                         (compiler:compiled-inf-pathname-type))
+                        rtl-output-port
+                        lap-output-port)))))))))))))
   unspecific)
 
 (define *debugging-key*)
@@ -252,7 +256,7 @@ USA.
 (define (compile-scode/no-file scode keep-debugging-info?)
   (fluid-let ((compiler:noisy? #f)
              (*info-output-filename* keep-debugging-info?))
-    (compile-scode/internal/hook
+    (compile-scode/no-file/hook
      (lambda ()
        (compile-scode/internal scode keep-debugging-info?)))))
 
@@ -319,15 +323,17 @@ USA.
           (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)))))
+            (compile-scode/recursive/hook
+             (lambda ()
+               (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 ()

diff --git a/v7/src/compiler/machines/C/compiler.pkg b/v7/src/compiler/machines/C/compiler.pkg
index 02bd6bb9c5c43cb4f41eb5969a1de6e33fad1d0a..9a071e97bb3eaee8b54c6423dd70209051876c8b 100644 (file)
--- a/v7/src/compiler/machines/C/compiler.pkg
+++ b/v7/src/compiler/machines/C/compiler.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: compiler.pkg,v 1.30 2008/01/30 20:01:45 cph Exp $
+$Id: compiler.pkg,v 1.31 2008/09/10 15:12:07 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -262,16 +262,17 @@ USA.
          *rtl-procedures*)
   (export (compiler lap-syntaxer)
          *block-label*
+         default-file-handle
          *disambiguator*
          *external-labels*
-         *shared-namestring*
-         *special-labels*
          label->object
          *invoke-interface*
+         *purification-root-object*
+         *shared-namestring*
+         *special-labels*
          *used-invoke-primitive*
          *use-jump-execute-chache*
-         *use-pop-return*
-         *purification-root-object*)
+         *use-pop-return*)
   (export (compiler debug)
          *root-expression*
          *rtl-procedures*

diff --git a/v7/src/compiler/machines/C/cout.scm b/v7/src/compiler/machines/C/cout.scm
index 8f153f6d477863543c8cb1ae89b1e619599264d0..ca427b92d0fa72fb82b9e418d9845e479514d479 100644 (file)
--- a/v7/src/compiler/machines/C/cout.scm
+++ b/v7/src/compiler/machines/C/cout.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: cout.scm,v 1.45 2008/08/28 19:28:29 riastradh Exp $
+$Id: cout.scm,v 1.46 2008/09/10 15:12:07 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -103,14 +103,6 @@ USA.
   (c:group (c:data-section (declare-object handle proc))
           (c:line)
           (declare-dynamic-object-initialization handle)))
-
-(define (default-file-handle)
-  (file-namestring
-   (pathname-new-type *compiler-output-pathname*
-                     (let ((t (pathname-type *compiler-input-pathname*)))
-                       (if (equal? t "bin")
-                           (c-output-extension)
-                           t)))))
 \f
 (define (stringify suffix initial-label lap-code info-output-pathname)
   ;; returns <code-name data-name ntags symbol-table code proxy>

diff --git a/v7/src/compiler/machines/C/ctop.scm b/v7/src/compiler/machines/C/ctop.scm
index 8d37d7c60851b4a94c9804140a551836766871ba..5eb8296ba78fe698d049e5e3ada63e9542857071 100644 (file)
--- a/v7/src/compiler/machines/C/ctop.scm
+++ b/v7/src/compiler/machines/C/ctop.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: ctop.scm,v 1.32 2008/01/30 20:01:46 cph Exp $
+$Id: ctop.scm,v 1.33 2008/09/10 15:12:07 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -36,73 +36,83 @@ USA.
 (define compiler:invoke-c-compiler? #t)
 (define compiler:invoke-verbose? #t)
 
-(define (compiler-file-output object pathname)
-  (let ((pair (vector-ref object 1)))
+(define (compiler-file-output compiler-output pathname)
+  (let ((code (cdr (vector-ref compiler-output 1))))
     (call-with-output-file pathname
       (lambda (port)
-       (c:write-group (cdr pair) port)))
-    (if compiler:invoke-c-compiler? (c-compile pathname))))
-
-(define (compile-data-from-file obj pathname)
-  (let ((res (stringify-data obj (merge-pathnames pathname))))
+       (c:write-group code port)))
+    (if compiler:invoke-c-compiler?
+       (c-compile pathname
+                  (pathname-new-type pathname "o")
+                  (pathname-new-type pathname (c-output-extension))))))
+
+(define (compile-data-from-file object pathname)
+  (let ((result (stringify-data object (merge-pathnames pathname))))
     ;; Make output palatable to compiler-file-output
-    (vector #f (cons #f res))))
+    (vector #f (cons #f result))))
 
 (define (compiler-output->procedure compiler-output environment)
   (finish-c-compilation
    compiler-output
-   (lambda (shared-library-pathname)
-     (load shared-library-pathname environment))))
+   (lambda (output-pathname)
+     (load output-pathname environment))))
 
 (define (compiler-output->compiled-expression compiler-output)
   (finish-c-compilation compiler-output fasload-object-file))
 
-(define (compile-scode/internal/hook action)
-  (if (not (eq? *info-output-filename* 'KEEP))
-      (action)
-      (fluid-let ((*info-output-filename*
-                  (pathname-new-type (compiler-temporary-file-pathname)
-                                     "inf")))
-       (action))))
+(define (compile-scode/file/hook input-pathname output-pathname action)
+  (fluid-let ((*compiler-file-handle*
+              (file-namestring
+               (pathname-new-type output-pathname
+                                  (let ((t (pathname-type input-pathname)))
+                                    (if (equal? t "bin")
+                                        (c-output-extension)
+                                        t))))))
+    (action)))
+
+(define (compile-scode/no-file/hook action)
+  (fluid-let ((*compiler-file-handle*
+              (string-append
+               "(anonymous scode "
+               (vector-8b->hexadecimal (random-byte-vector 8))
+               ")")))
+    (action)))
+
+(define (compile-scode/recursive/hook action)
+  (compile-scode/no-file/hook action))
 
 (define (optimize-linear-lap lap-program)
   lap-program)
 
-(define (compiler-temporary-file-pathname)
-  (let ((pathname (temporary-file-pathname)))
-    (if (file-exists? pathname)
-       (delete-file pathname))
-    (if (pathname-type pathname)
-       (pathname-new-name
-        (pathname-new-type pathname #f)
-        (string-append (pathname-name pathname)
-                       "_"
-                       (pathname-type pathname)))
-       pathname)))
+(define *compiler-file-handle*)
+
+(define (default-file-handle)
+  *compiler-file-handle*)
 \f
 (define (finish-c-compilation compiler-output action)
-  (let* ((file (compiler-temporary-file-pathname))
-        (filec (pathname-new-type file "c")))
-    (dynamic-wind
-     (lambda () #f)
-     (lambda ()
-       (fluid-let ((compiler:invoke-c-compiler? #t))
-        (compiler-file-output compiler-output filec)
-        (action (pathname-new-type file (c-output-extension)))))
-     (lambda ()
-       (for-each (lambda (type)
-                  (let ((f (pathname-new-type file type)))
-                    (if (file-exists? f)
-                        (delete-file f))))
-                (list "c" "o"
-                      ;; Can't delete this because it is mapped...
-                      ;; (c-output-extension)
-                      ))))))
-
-(define (c-compile pathname)
+  (let ((typifier
+        (lambda (type)
+          (lambda (pathname) (pathname-new-type pathname type)))))
+    (let ((c-pathname (temporary-file-pathname #f (typifier "c")))
+         (o-pathname (temporary-file-pathname #f (typifier "o")))
+         (output-pathname
+          (temporary-file-pathname #f (typifier (c-output-extension)))))
+      (dynamic-wind
+       (lambda () unspecific)
+       (lambda ()
+        (fluid-let ((compiler:invoke-c-compiler? #f))
+          (compiler-file-output compiler-output c-pathname))
+        (c-compile c-pathname o-pathname output-pathname)
+        (action output-pathname))
+       (lambda ()
+        (deallocate-temporary-file c-pathname)
+        (deallocate-temporary-file o-pathname)
+        (deallocate-temporary-file output-pathname))))))
+
+(define (c-compile c-pathname o-pathname output-pathname)
   (run-compiler (system-library-pathname "liarc-cc")
-               (pathname-new-type pathname "o")
-               pathname
+               o-pathname
+               c-pathname
                "-DENABLE_LIARC_FILE_INIT"
                (string-append
                 "-I"
@@ -111,8 +121,8 @@ USA.
                   (or (system-library-directory-pathname "include")
                       (error "Unable to find C include directory."))))))
   (run-compiler (system-library-pathname "liarc-ld")
-               (pathname-new-type pathname (c-output-extension))
-               (pathname-new-type pathname "o")))
+               output-pathname
+               o-pathname))
 
 (define (run-compiler program . arguments)
   (let ((port (open-output-string)))
@@ -310,9 +320,7 @@ USA.
                   (cons *info-output-filename*
                         *recursive-compilation-number*))
                  ((eq? pathname 'KEEP)
-                  (if (zero? *recursive-compilation-number*)
-                      "foo.bar"
-                      (cons "foo.bar" *recursive-compilation-number*)))
+                  #f)
                  (else
                   pathname))))
        (lambda (code-name data-name ntags labels code proxy)
@@ -347,7 +355,7 @@ USA.
                                               *C-code-name* ; tag
                                               *C-code-name* ; c-proc
                                               *C-data-name* ; d-proc
-                                              *code*        ; c-code
+                                              *code* ; c-code
                                               index
                                               *ntags*
                                               *proxy*))
@@ -386,7 +394,8 @@ USA.
              labels
              (last-reference *external-labels*))))
        (cond ((eq? pathname 'KEEP)     ; for dynamic execution
-              info)
+              ;; (warn "C back end cannot keep debugging info in memory")
+              unspecific)
              ((eq? pathname 'RECURSIVE) ; recursive compilation
               (set! *recursive-compilation-results*
                     (cons (vector *recursive-compilation-number*
@@ -403,8 +412,7 @@ USA.
                       (cons info
                             (map (lambda (other) (vector-ref other 1))
                                  others)))))
-               pathname)
-              *info-output-filename*))))))
+               pathname)))))))
 
 (define (compiler:dump-bci-file binf pathname)
   (let ((bci-path (pathname-new-type pathname "bci")))