From: Taylor R. Campbell Date: Wed, 10 Sep 2008 15:12:07 +0000 (+0000) Subject: Change COMPILE-SCODE/INTERNAL/HOOK into three separate hooks: X-Git-Tag: 20090517-FFI~160 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f1c45e9684e21fcfbdb10e72f8d1793ec91d15ed;p=mit-scheme.git 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 f42b4e192..666a60141 100644 --- 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 8d52f62aa..c82d0c23f 100644 --- 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 02bd6bb9c..9a071e97b 100644 --- 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 8f153f6d4..ca427b92d 100644 --- 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))))) (define (stringify suffix initial-label lap-code info-output-pathname) ;; returns diff --git a/v7/src/compiler/machines/C/ctop.scm b/v7/src/compiler/machines/C/ctop.scm index 8d37d7c60..5eb8296ba 100644 --- 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*) (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")))