From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 20 Jul 1992 22:12:22 +0000 (+0000)
Subject: Fix support for assembly-labels files so that compiler can properly
X-Git-Tag: 20090517-FFI~9218
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1b85bcd7707fd142e1ef35eeee3ff6867a683386;p=mit-scheme.git

Fix support for assembly-labels files so that compiler can properly
generate disassemblies.
---

diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm
index 5f91e95dc..63d62ff44 100644
--- a/v7/src/compiler/base/toplev.scm
+++ b/v7/src/compiler/base/toplev.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.43 1992/06/12 01:43:14 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.44 1992/07/20 22:12:22 cph Exp $
 
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -1124,55 +1124,61 @@ MIT in each case. |#
 
 ;;; Various ways of dumping an info file
 
-(define (announce-info-files . files)
-  (if compiler:noisy?
-      (let ((port (nearest-cmdl/port)))
-	(let loop ((files files))
-	  (if (null? files)
-	      unspecific
-	      (begin
-		(fresh-line port)
-		(write-string ";")
-		(write (->namestring (car files)))
-		(write-string " dumped ")
-		(loop (cdr files))))))))
-
 (define (compiler:dump-inf-file binf pathname)
   (fasdump binf pathname true)
   (announce-info-files pathname))
-  
+
 (define (compiler:dump-bif/bsm-files binf pathname)
   (let ((bif-path (pathname-new-type pathname "bif"))
 	(bsm-path (pathname-new-type pathname "bsm")))
-    (inf-structure->bif/bsm binf bif-path bsm-path)
+    (let ((bsm (split-inf-structure! binf bsm-path)))
+      (fasdump binf bif-path true)
+      (fasdump bsm bsm-path true))
     (announce-info-files bif-path bsm-path)))
   
 (define (compiler:dump-bci/bcs-files binf pathname)
+  (load-option 'COMPRESS)
   (let ((bci-path (pathname-new-type pathname "bci"))
 	(bcs-path (pathname-new-type pathname "bcs")))
-    (load-option 'COMPRESS)
-    (call-with-temporary-filename
-      (lambda (bif-name)
-	(let ((bif-path (merge-pathnames bif-name)))
-	  (call-with-temporary-filename
-            (lambda (bsm-name)
-	      (let ((bsm-path (merge-pathnames bsm-name)))
-		(inf-structure->bif/bsm binf bif-path bsm-path)
-		(compress bif-path bci-path)
-		(compress bsm-path bcs-path)
-		(announce-info-files bci-path bcs-path)))))))))
-
+    (let ((bsm (split-inf-structure! binf bcs-path)))
+      (call-with-temporary-filename
+	(lambda (bif-name)
+	  (let ((bif-path (merge-pathnames bif-name bci-path)))
+	    (fasdump binf bif-path true)
+	    (compress bif-path bci-path))))
+      (call-with-temporary-filename
+	(lambda (bsm-name)
+	  (let ((bsm-path (merge-pathnames bsm-name bcs-path)))
+	    (fasdump bsm bsm-path true)
+	    (compress bsm-path bcs-path)))))
+    (announce-info-files bci-path bcs-path)))
+  
 (define (compiler:dump-bci-file binf pathname)
+  (load-option 'COMPRESS)
   (let ((bci-path (pathname-new-type pathname "bci")))
-    (load-option 'COMPRESS)
+    (split-inf-structure! binf false)
     (call-with-temporary-filename
       (lambda (bif-name)
-	(let ((bif-path (merge-pathnames bif-name)))
-	  (inf-structure->bif/bsm binf bif-path false)
-	  (compress bif-path bci-path)
-	  (announce-info-files bci-path))))))
+	(let ((bif-path (merge-pathnames bif-name bci-path)))
+	  (fasdump binf bif-path true)
+	  (compress bif-path bci-path))))
+    (announce-info-files bci-path)))
+
+(define (announce-info-files . files)
+  (if compiler:noisy?
+      (let ((port (nearest-cmdl/port)))
+	(let loop ((files files))
+	  (if (null? files)
+	      unspecific
+	      (begin
+		(fresh-line port)
+		(write-string ";")
+		(write (->namestring (car files)))
+		(write-string " dumped ")
+		(loop (cdr files))))))))
 
-(define compiler:dump-info-file compiler:dump-bci-file)
+(define compiler:dump-info-file
+  compiler:dump-bci-file)
 
 (define (phase/link)
   (compiler-phase "Linkification"
diff --git a/v7/src/compiler/machines/spectrum/compiler.pkg b/v7/src/compiler/machines/spectrum/compiler.pkg
index 38d66c47f..530db5de9 100644
--- a/v7/src/compiler/machines/spectrum/compiler.pkg
+++ b/v7/src/compiler/machines/spectrum/compiler.pkg
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/compiler.pkg,v 1.35 1992/05/26 20:21:42 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/compiler.pkg,v 1.36 1992/07/20 22:11:58 cph Exp $
 $MC68020-Header: /scheme/compiler/bobcat/RCS/comp.pkg,v 1.32 1991/05/06 23:09:24 jinx Exp $
 
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -159,6 +159,11 @@ MIT in each case. |#
 	  compile-bin-file
 	  compile-procedure
 	  compile-scode
+	  compiler:dump-bci-file
+	  compiler:dump-bci/bcs-files
+	  compiler:dump-bif/bsm-files
+	  compiler:dump-inf-file
+	  compiler:dump-info-file
 	  compiler:reset!
 	  cross-compile-bin-file
 	  cross-compile-bin-file-end)
@@ -180,7 +185,7 @@ MIT in each case. |#
 	  *rtl-graphs*)
   (import (runtime compiler-info)
 	  make-dbg-info-vector
-	  inf-structure->bif/bsm)
+	  split-inf-structure!)
   (import (runtime unparser)
 	  *unparse-uninterned-symbols-by-name?*))
 
diff --git a/v7/src/compiler/machines/spectrum/dassm1.scm b/v7/src/compiler/machines/spectrum/dassm1.scm
index a7a9a08ac..3042f2859 100644
--- a/v7/src/compiler/machines/spectrum/dassm1.scm
+++ b/v7/src/compiler/machines/spectrum/dassm1.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/dassm1.scm,v 4.15 1990/07/22 18:50:59 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/dassm1.scm,v 4.16 1992/07/20 22:12:09 cph Exp $
 $MC68020-Header: dassm1.scm,v 4.15 90/07/12 16:42:39 GMT jinx Exp $
 
-Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -48,49 +48,36 @@ MIT in each case. |#
 ;;;; Top level entries
 
 (define (compiler:write-lap-file filename #!optional symbol-table?)
-  (let ((pathname (->pathname filename)))
+  (let ((pathname (->pathname filename))
+	(symbol-table?
+	 (if (default-object? symbol-table?) true symbol-table?)))
     (with-output-to-file (pathname-new-type pathname "lap")
       (lambda ()
 	(let ((com-file (pathname-new-type pathname "com")))
-	  (let ((object (fasload com-file))
-		(info
-		 (let ((pathname (pathname-new-type pathname "binf")))
-		   (and (if (default-object? symbol-table?)
-			    (file-exists? pathname)
-			    symbol-table?)
-			(fasload pathname)))))
+	  (let ((object (fasload com-file)))
 	    (if (compiled-code-address? object)
-		(disassembler/write-compiled-code-block
-		 (compiled-code-address->block object)
-		 info)
+		(let ((block (compiled-code-address->block object)))
+		  (disassembler/write-compiled-code-block
+		   block
+		   (compiled-code-block/dbg-info block symbol-table?)))
 		(begin
 		  (if (not
 		       (and (scode/comment? object)
 			    (dbg-info-vector? (scode/comment-text object))))
 		      (error "Not a compiled file" com-file))
-		  (let ((items
+		  (let ((blocks
 			 (vector->list
 			  (dbg-info-vector/blocks-vector
 			   (scode/comment-text object)))))
-		    (if (not (null? items))
-			(if (false? info)
-			    (let loop ((items items))
-			      (disassembler/write-compiled-code-block
-			       (car items)
-			       false)
-			      (if (not (null? (cdr items)))
-				  (begin
-				    (write-char #\page)
-				    (loop (cdr items)))))
-			    (let loop
-				((items items) (info (vector->list info)))
-			      (disassembler/write-compiled-code-block
-			       (car items)
-			       (car info))
-			      (if (not (null? (cdr items)))
-				  (begin
-				    (write-char #\page)
-				    (loop (cdr items) (cdr info))))))))))))))))
+		    (if (not (null? blocks))
+			(do ((blocks blocks (cdr blocks)))
+			    ((null? blocks) unspecific)
+			  (disassembler/write-compiled-code-block
+			   (car blocks)
+			   (compiled-code-block/dbg-info (car blocks)
+							 symbol-table?))
+			  (if (not (null? (cdr blocks)))
+			      (write-char #\page)))))))))))))
 
 (define disassembler/base-address)
 
diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index c848805fb..4f3db5f89 100644
--- a/v7/src/runtime/infutl.scm
+++ b/v7/src/runtime/infutl.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.41 1992/05/28 22:59:09 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.42 1992/07/20 22:09:28 cph Exp $
 
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -386,17 +386,27 @@ MIT in each case. |#
 	 false)))
 
 (define (read-bsm-file name)
-  (let ((pathname (merge-pathnames (process-bsym-filename name))))
-    (if (file-exists? pathname)
-	(fasload-loader pathname)
-	(find-alternate-file-type pathname
-				  `(("bsm" . ,fasload-loader)
-				    ("bcs" . ,compressed-loader))))))
+  (let ((pathname
+	 (let ((pathname (merge-pathnames (process-bsym-filename name))))
+	   (if (file-exists? pathname)
+	       pathname
+	       (let loop ((types '("bsm" "bcs")))
+		 (and (not (null? types))
+		      (let ((pathname
+			     (pathname-new-type pathname (car types))))
+			(if (file-exists? pathname)
+			    pathname
+			    (loop (cdr types))))))))))
+    (and pathname
+	 (if (equal? "bcs" (pathname-type pathname))
+	     (compressed-loader pathname)
+	     (fasload-loader pathname)))))
 
 (define (process-bsym-filename name)
   (rewrite-directory (merge-pathnames name)))
 
-;;; The conversion hack.
+
+;;;; Splitting of info structures
 
 (define (inf->bif/bsm inffile)
   (let* ((infpath (merge-pathnames inffile))
@@ -406,34 +416,36 @@ MIT in each case. |#
       (inf-structure->bif/bsm binf bifpath bsmpath))))
 
 (define (inf-structure->bif/bsm binf bifpath bsmpath)
-  (let* ((bifpath (merge-pathnames bifpath))
-	 (bsmpath (and bsmpath (merge-pathnames bsmpath)))
-	 (bsmname (and bsmpath (->namestring bsmpath))))
+  (let ((bifpath (merge-pathnames bifpath))
+	(bsmpath (and bsmpath (merge-pathnames bsmpath))))
+    (let ((bsm (split-inf-structure! binf bsmpath)))
+      (fasdump binf bifpath true)
+      (if bsmpath
+	  (fasdump bsm bsmpath true)))))
+
+(define (split-inf-structure! binf bsmpath)
+  (let ((bsmname (and bsmpath (->namestring bsmpath))))
     (cond ((dbg-info? binf)
 	   (let ((labels (dbg-info/labels/desc binf)))
 	     (set-dbg-info/labels/desc! binf bsmname)
-	     (fasdump binf bifpath true)
-	     (if bsmpath
-		 (fasdump labels bsmpath true))))
+	     labels))
 	  ((vector? binf)
-	   (let ((bsm (make-vector (vector-length binf))))
-	     (let loop ((pos 0))
-	       (if (fix:= pos (vector-length bsm))
-		   (begin
-		     (fasdump binf bifpath true)
-		     (if bsmpath
-			 (fasdump bsm bsmpath true)))
-		   (let ((dbg-info (vector-ref binf pos)))
-		     (let ((labels (dbg-info/labels/desc dbg-info)))
-		       (vector-set! bsm pos labels)
-		       (set-dbg-info/labels/desc!
-			dbg-info
-			(and bsmname (cons bsmname pos)))
-		       (loop (fix:1+ pos))))))))
+	   (let ((n (vector-length binf)))
+	     (let ((bsm (make-vector n)))
+	       (do ((i 0 (fix:+ i 1)))
+		   ((fix:= i n))
+		 (let ((dbg-info (vector-ref binf i)))
+		   (let ((labels (dbg-info/labels/desc dbg-info)))
+		     (vector-set! bsm i labels)
+		     (set-dbg-info/labels/desc!
+		      dbg-info
+		      (and bsmname (cons bsmname i))))))
+	       bsm)))
 	  (else 
-	   (error "Unknown inf format" binf)))))
-
-;;; UNCOMPRESS: A simple extractor for compressed binary info files.
+	   (error "Unknown inf format:" binf)))))
+
+;;;; UNCOMPRESS
+;;;  A simple extractor for compressed binary info files.
 
 (define (uncompress-ports input-port output-port #!optional buffer-size)
   (define-integrable window-size 4096)
diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm
index cc5b04768..ce2a5fb0b 100644
--- a/v8/src/runtime/infutl.scm
+++ b/v8/src/runtime/infutl.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.41 1992/05/28 22:59:09 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.42 1992/07/20 22:09:28 cph Exp $
 
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -386,17 +386,27 @@ MIT in each case. |#
 	 false)))
 
 (define (read-bsm-file name)
-  (let ((pathname (merge-pathnames (process-bsym-filename name))))
-    (if (file-exists? pathname)
-	(fasload-loader pathname)
-	(find-alternate-file-type pathname
-				  `(("bsm" . ,fasload-loader)
-				    ("bcs" . ,compressed-loader))))))
+  (let ((pathname
+	 (let ((pathname (merge-pathnames (process-bsym-filename name))))
+	   (if (file-exists? pathname)
+	       pathname
+	       (let loop ((types '("bsm" "bcs")))
+		 (and (not (null? types))
+		      (let ((pathname
+			     (pathname-new-type pathname (car types))))
+			(if (file-exists? pathname)
+			    pathname
+			    (loop (cdr types))))))))))
+    (and pathname
+	 (if (equal? "bcs" (pathname-type pathname))
+	     (compressed-loader pathname)
+	     (fasload-loader pathname)))))
 
 (define (process-bsym-filename name)
   (rewrite-directory (merge-pathnames name)))
 
-;;; The conversion hack.
+
+;;;; Splitting of info structures
 
 (define (inf->bif/bsm inffile)
   (let* ((infpath (merge-pathnames inffile))
@@ -406,34 +416,36 @@ MIT in each case. |#
       (inf-structure->bif/bsm binf bifpath bsmpath))))
 
 (define (inf-structure->bif/bsm binf bifpath bsmpath)
-  (let* ((bifpath (merge-pathnames bifpath))
-	 (bsmpath (and bsmpath (merge-pathnames bsmpath)))
-	 (bsmname (and bsmpath (->namestring bsmpath))))
+  (let ((bifpath (merge-pathnames bifpath))
+	(bsmpath (and bsmpath (merge-pathnames bsmpath))))
+    (let ((bsm (split-inf-structure! binf bsmpath)))
+      (fasdump binf bifpath true)
+      (if bsmpath
+	  (fasdump bsm bsmpath true)))))
+
+(define (split-inf-structure! binf bsmpath)
+  (let ((bsmname (and bsmpath (->namestring bsmpath))))
     (cond ((dbg-info? binf)
 	   (let ((labels (dbg-info/labels/desc binf)))
 	     (set-dbg-info/labels/desc! binf bsmname)
-	     (fasdump binf bifpath true)
-	     (if bsmpath
-		 (fasdump labels bsmpath true))))
+	     labels))
 	  ((vector? binf)
-	   (let ((bsm (make-vector (vector-length binf))))
-	     (let loop ((pos 0))
-	       (if (fix:= pos (vector-length bsm))
-		   (begin
-		     (fasdump binf bifpath true)
-		     (if bsmpath
-			 (fasdump bsm bsmpath true)))
-		   (let ((dbg-info (vector-ref binf pos)))
-		     (let ((labels (dbg-info/labels/desc dbg-info)))
-		       (vector-set! bsm pos labels)
-		       (set-dbg-info/labels/desc!
-			dbg-info
-			(and bsmname (cons bsmname pos)))
-		       (loop (fix:1+ pos))))))))
+	   (let ((n (vector-length binf)))
+	     (let ((bsm (make-vector n)))
+	       (do ((i 0 (fix:+ i 1)))
+		   ((fix:= i n))
+		 (let ((dbg-info (vector-ref binf i)))
+		   (let ((labels (dbg-info/labels/desc dbg-info)))
+		     (vector-set! bsm i labels)
+		     (set-dbg-info/labels/desc!
+		      dbg-info
+		      (and bsmname (cons bsmname i))))))
+	       bsm)))
 	  (else 
-	   (error "Unknown inf format" binf)))))
-
-;;; UNCOMPRESS: A simple extractor for compressed binary info files.
+	   (error "Unknown inf format:" binf)))))
+
+;;;; UNCOMPRESS
+;;;  A simple extractor for compressed binary info files.
 
 (define (uncompress-ports input-port output-port #!optional buffer-size)
   (define-integrable window-size 4096)