From e27b120bd5afbf3891fd238cb6e053325a10dfa8 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 8 Nov 1988 06:56:06 +0000 Subject: [PATCH] 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. --- v7/src/runtime/udata.scm | 34 ++++++++------- v7/src/runtime/unpars.scm | 85 +++++++++++++++++--------------------- v7/src/runtime/version.scm | 4 +- 3 files changed, 59 insertions(+), 64 deletions(-) diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm index dade23d4e..bcc7f4dd0 100644 --- 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 a3a85e6e8..106fff7cc 100644 --- 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))) ;;;; 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 5660177e2..1401442bd 100644 --- 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) -- 2.25.1