Add new primitive `compiled-closure->entry', and new predicate

`compiled-closure?'.  Change the unparser to print compiled code
entries differently, showing their offset and absolute address for
better debugging.  Closures show this information for their entry
point, and additionally show the address of the closure itself.

diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm
index dade23d4e04c89cb4ceac0191f69f82b1d54e047..bcc7f4dd0134908852ee3cb6ec550969c534d421 100644 (file)
--- a/v7/src/runtime/udata.scm
+++ b/v7/src/runtime/udata.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.4 1988/08/01 23:07:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.5 1988/11/08 06:55:53 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -77,14 +77,11 @@ MIT in each case. |#
                                     if-return-address
                                     if-expression
                                     if-other)
-  (if (not (compiled-code-address? object))
-      (error "DISCRIMINATE-COMPILED-ENTRY: bad compiled entry" object))
-  (let ((type (system-hunk3-cxr0
-              ((ucode-primitive compiled-entry-kind 1) object))))
-    (cond ((= type 0) (if-procedure))
-         ((= type 1) (if-return-address))
-         ((= type 2) (if-expression))
-         (else       (if-other)))))
+  (case (system-hunk3-cxr0 ((ucode-primitive compiled-entry-kind 1) object))
+    ((0) (if-procedure))
+    ((1) (if-return-address))
+    ((2) (if-expression))
+    (else (if-other))))
 
 (define (compiled-entry-type object)
   (discriminate-compiled-entry object
@@ -104,18 +101,19 @@ MIT in each case. |#
        (eq? (compiled-entry-type object) 'COMPILED-PROCEDURE)))
 
 (define (compiled-procedure-arity object)
-  (if (not (compiled-procedure? object))
-      (error "COMPILED-PROCEDURE-ARITY: bad compiled procedure" object))
   (let ((info ((ucode-primitive compiled-entry-kind 1) object)))
+    (if (not (= (system-hunk3-cxr0 info) 0))
+       (error "COMPILED-PROCEDURE-ARITY: bad compiled procedure" object))
     (cons (-1+ (system-hunk3-cxr1 info))
          (let ((max (system-hunk3-cxr2 info)))
            (and (not (negative? max))
                 (-1+ max))))))
-(define-integrable (compiled-code-block? object)
-  (object-type? (ucode-type compiled-code-block) object))
+(define (compiled-closure? object)
+  (and (compiled-procedure? object)
+       (compiled-code-block/manifest-closure?
+       (compiled-code-address->block object))))
 
-(define-integrable (compiled-code-block/read-file filename)
-  (compiled-code-address->block (fasload filename)))
+(define-primitives (compiled-closure->entry 1))
 
 ;;; These are now pretty useless.
 
@@ -150,6 +148,12 @@ that you cannot just vector-ref into.
 
 (define compiled-code-block/bytes-per-object)
 
+(define-integrable (compiled-code-block? object)
+  (object-type? (ucode-type compiled-code-block) object))
+
+(define-integrable (compiled-code-block/read-file filename)
+  (compiled-code-address->block (fasload filename)))
+
 (define (compiled-code-block/manifest-closure? block)
   (object-type? 
    (ucode-type manifest-closure)

diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index a3a85e6e85ad287288514dcb6bcbae99fe4b5426..106fff7ccf098b545c0078cfcc1d8fe5110e712e 100644 (file)
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.8 1988/11/02 21:43:53 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.9 1988/11/08 06:55:59 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -186,7 +186,10 @@ MIT in each case. |#
   (*unparse-string (substring string start end)))
 
 (define-integrable (*unparse-datum object)
-  (*unparse-string (number->string (object-datum object) 16)))
+  (*unparse-hex (object-datum object)))
+
+(define-integrable (*unparse-hex number)
+  (*unparse-string (number->string number 16)))
 
 (define-integrable (*unparse-hash object)
   (*unparse-string (number->string (hash object))))
@@ -443,48 +446,33 @@ MIT in each case. |#
 ;;;; Compiled entries
 
 (define (unparse/compiled-entry entry)
-  (discriminate-compiled-entry entry
-    (lambda () (unparse-compiled-procedure entry))
-    (lambda () (unparse-compiled-entry entry))
-    (lambda () (unparse-compiled-entry entry))
-    (lambda () (unparse-compiled-entry entry))))
-
-(define (unparse-compiled-procedure entry)
-  ;; Gross-out to make the "FASLoading" message not print out in the
-  ;; middle of the other stuff.
-  (let ((unparse-it
-        (lambda (thunk)
-          (*unparse-with-brackets 'COMPILED-PROCEDURE entry thunk))))
-    (compiled-entry->name entry
-      (lambda (string)
-       (unparse-it
-        (lambda ()
-          (*unparse-string (detach-suffix-number string)))))
-      (lambda ()
-       (compiled-entry->pathname entry
-         (lambda (pathname)
-           (unparse-it 
-            (lambda () 
-              (*unparse-string "from file ")
-              (*unparse-object (pathname-name pathname)))))
-         (lambda ()
-           (unparse-it
-            (lambda () 
-              (*unparse-datum entry)))))))))
-
-(define (unparse-compiled-entry entry)
-  (let ((unparse-it
-        (lambda (thunk)
-          (*unparse-with-brackets (compiled-entry-type entry) entry thunk))))
-    (compiled-entry->pathname entry
-      (lambda (pathname)
-       (unparse-it 
-        (lambda ()
-          (*unparse-string "from file ")
-          (*unparse-object (pathname-name pathname)))))
-      (lambda () 
-       (unparse-it 
-        (lambda () (*unparse-datum entry)))))))
+  (let* ((type (compiled-entry-type entry))
+        (closure?
+         (and (eq? type 'COMPILED-PROCEDURE)
+              (compiled-code-block/manifest-closure?
+               (compiled-code-address->block entry)))))
+    (*unparse-with-brackets
+     (if closure? 'COMPILED-CLOSURE type)
+     entry
+     (lambda ()
+       (let ((entry* (if closure? (compiled-closure->entry entry) entry)))
+        (*unparse-object
+         (or (and (eq? type 'COMPILED-PROCEDURE)
+                  (compiled-procedure/name entry*))
+             (compiled-entry/filename entry*)
+             '()))
+        (*unparse-char #\Space)
+        (*unparse-hex (compiled-code-address->offset entry*))
+        (*unparse-char #\Space)
+        (*unparse-datum entry*)
+        (if closure?
+            (begin (*unparse-char #\Space)
+                   (*unparse-datum entry))))))))
+
+(define (compiled-procedure/name entry)
+  (compiled-entry->name entry
+    (lambda (string) (string->symbol (detach-suffix-number string)))
+    (lambda () false)))
 
 ;;; Names in the symbol table are of the form "FOOBAR-127".  The 127
 ;;; is added by the compiler.  This procedure detaches the suffix
@@ -502,6 +490,11 @@ MIT in each case. |#
          ((char-numeric? (string-ref string index))
           (loop (-1+ index)))
          (else string))))
+
+(define (compiled-entry/filename entry)
+  (compiled-entry->pathname entry
+    (lambda (pathname) (list 'FILE (pathname-name pathname)))
+    (lambda () false)))
 \f
 ;;;; Miscellaneous
 
@@ -519,9 +512,7 @@ MIT in each case. |#
 (define (unparse/future future)
   (*unparse-with-brackets 'FUTURE false
     (lambda ()
-      (*unparse-string
-       (number->string ((ucode-primitive primitive-object-datum 1) future)
-                      16)))))
+      (*unparse-hex ((ucode-primitive primitive-object-datum 1) future)))))
 
 (define (unparse/entity entity)
   (*unparse-with-brackets (if (continuation? entity) 'CONTINUATION 'ENTITY)

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 5660177e2bb459bee367f7a919aa4709d86446ed..1401442bd25ed3151bd44413f82b2380b324a9df 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.27 1988/11/05 05:13:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.28 1988/11/08 06:56:06 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 27))
+  (add-identification! "Runtime" 14 28))
 
 (define microcode-system)