From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 15 May 1987 19:51:47 +0000 (+0000)
Subject: Change all RTL constructs that contain pointers to compiler internal
X-Git-Tag: 20090517-FFI~13515
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=15a8df035db67493b3764f20681bec46f52d5875;p=mit-scheme.git
Change all RTL constructs that contain pointers to compiler internal
data structures so that they only point to symbolic structures. This
means that all occurrences of continuation and procedure objects have
been replaced by the corresponding label. There is now a fairly fast
map from the labels to their objects.
This was done to make it possible to change the debugging file output
routines so that they fasdump rather than writing their output.
---
diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm
index 9d7709261..94af280b6 100644
--- a/v7/src/compiler/back/lapgn1.scm
+++ b/v7/src/compiler/back/lapgn1.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.31 1987/05/14 10:56:30 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.32 1987/05/15 19:51:47 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
@@ -379,16 +379,17 @@ MIT in each case. |#
(guarantee-frame-pointer-offset!)
*frame-pointer-offset*)
-(define (record-continuation-frame-pointer-offset! continuation)
- (guarantee-frame-pointer-offset!)
- (if (continuation-frame-pointer-offset continuation)
- (if (not (= (continuation-frame-pointer-offset continuation)
- *frame-pointer-offset*))
- (error "Continuation frame-pointer offset mismatch" continuation
- *frame-pointer-offset*))
- (set-continuation-frame-pointer-offset! continuation
- *frame-pointer-offset*))
- (enqueue! *continuation-queue* continuation))
+(define (record-continuation-frame-pointer-offset! label)
+ (let ((continuation (label->continuation label)))
+ (guarantee-frame-pointer-offset!)
+ (if (continuation-frame-pointer-offset continuation)
+ (if (not (= (continuation-frame-pointer-offset continuation)
+ *frame-pointer-offset*))
+ (error "Continuation frame-pointer offset mismatch" continuation
+ *frame-pointer-offset*))
+ (set-continuation-frame-pointer-offset! continuation
+ *frame-pointer-offset*))
+ (enqueue! *continuation-queue* continuation)))
(define (record-rnode-frame-pointer-offset! rnode offset)
(if (rnode-frame-pointer-offset rnode)
diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm
index 58e6a8c94..34615c584 100644
--- a/v7/src/compiler/base/ctypes.scm
+++ b/v7/src/compiler/base/ctypes.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.46 1987/05/09 01:07:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.47 1987/05/15 19:49:56 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
@@ -101,6 +101,9 @@ MIT in each case. |#
(generate-label 'CONTINUATION)
false)))
(set! *continuations* (cons continuation *continuations*))
+ (symbol-hash-table/insert! *label->object*
+ (continuation-label continuation)
+ continuation)
continuation))
(define-integrable (continuation-rtl-entry continuation)
@@ -111,4 +114,7 @@ MIT in each case. |#
(define-unparser continuation-tag
(lambda (continuation)
+ (write (continuation-label continuation))))
+
+(define-integrable (label->continuation label)
(symbol-hash-table/lookup *label->object* label))
\ No newline at end of file
diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm
index 8fc820db0..8126e3892 100644
--- a/v7/src/compiler/base/utils.scm
+++ b/v7/src/compiler/base/utils.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.86 1987/05/07 00:12:20 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.87 1987/05/15 19:50:46 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
@@ -103,6 +103,27 @@ MIT in each case. |#
(let ((value (thunk)))
(write-line (- (runtime) start))
value)))
+
+(define (symbol-hash-table/make n-buckets)
+ (make-vector n-buckets '()))
+
+(define (symbol-hash-table/insert! table symbol item)
+ (let ((hash (string-hash-mod (symbol->string symbol) (vector-length table))))
+ (let ((bucket (vector-ref table hash)))
+ (let ((entry (assq symbol bucket)))
+ (if entry
+ (set-cdr! entry item)
+ (vector-set! table hash (cons (cons symbol item) bucket)))))))
+
+(define (symbol-hash-table/lookup table symbol)
+ (cdr (or (assq symbol
+ (vector-ref table
+ (string-hash-mod (symbol->string symbol)
+ (vector-length table))))
+ (error "Missing item" symbol))))
+
+(define-integrable string-hash-mod
+ (ucode-primitive string-hash-mod))
;;;; SCode Interface
diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm
index 7488935c4..9147588ab 100644
--- a/v7/src/compiler/machines/bobcat/lapgen.scm
+++ b/v7/src/compiler/machines/bobcat/lapgen.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.161 1987/05/13 11:00:33 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.162 1987/05/15 19:51:17 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
@@ -370,10 +370,11 @@ MIT in each case. |#
`((MOVE L ,(indirect-reference! r n) (@A+ 5))))
(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (ENTRY:PROCEDURE (? procedure)))
+ (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (ENTRY:PROCEDURE (? label)))
(let ((temporary
(register-reference (allocate-temporary-register! 'ADDRESS))))
- `((LEA (@PCR ,(procedure-external-label procedure)) ,temporary)
+ `((LEA (@PCR ,(procedure-external-label (label->procedure label)))
+ ,temporary)
(MOVE L ,temporary (@A+ 5))
(MOVE B (& ,type-code:return-address) (@AO 5 -4)))))
@@ -418,11 +419,10 @@ MIT in each case. |#
(MOVE B (& ,type-code:stack-environment) (@A 7)))))
(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (ENTRY:CONTINUATION (? continuation)))
- (record-continuation-frame-pointer-offset! continuation)
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (ENTRY:CONTINUATION (? label)))
+ (record-continuation-frame-pointer-offset! label)
(record-push!
- `((PEA (@PCR ,(continuation-label continuation)))
+ `((PEA (@PCR ,label))
(MOVE B (& ,type-code:return-address) (@A 7)))))
;;;; Predicates
@@ -573,36 +573,34 @@ MIT in each case. |#
(define-rule statement
(INVOCATION:JUMP (? n)
(APPLY-CLOSURE (? frame-size) (? receiver-offset))
- (? continuation) (? procedure))
+ (? continuation) (? label))
(disable-frame-pointer-offset!
`(,@(clear-map!)
- ,@(apply-closure-sequence frame-size receiver-offset
- (procedure-label procedure)))))
+ ,@(apply-closure-sequence frame-size receiver-offset label))))
(define-rule statement
(INVOCATION:JUMP (? n)
(APPLY-STACK (? frame-size) (? receiver-offset)
(? n-levels))
- (? continuation) (? procedure))
+ (? continuation) (? label))
(disable-frame-pointer-offset!
`(,@(clear-map!)
- ,@(apply-stack-sequence frame-size receiver-offset n-levels
- (procedure-label procedure)))))
+ ,@(apply-stack-sequence frame-size receiver-offset n-levels label))))
(define-rule statement
- (INVOCATION:JUMP (? number-pushed) (? prefix) (? continuation) (? procedure))
+ (INVOCATION:JUMP (? number-pushed) (? prefix) (? continuation) (? label))
(QUALIFIER (not (memq (car prefix) '(APPLY-CLOSURE APPLY-STACK))))
(disable-frame-pointer-offset!
`(,@(generate-invocation-prefix prefix)
- (BRA L (@PCR ,(procedure-label procedure))))))
+ (BRA L (@PCR ,label)))))
(define-rule statement
(INVOCATION:LEXPR (? number-pushed) (? prefix) (? continuation)
- (? procedure))
+ (? label))
(disable-frame-pointer-offset!
`(,@(generate-invocation-prefix prefix)
,(load-dnw number-pushed 0)
- (BRA L (@PCR ,(procedure-label procedure))))))
+ (BRA L (@PCR ,label)))))
(define-rule statement
(INVOCATION:LOOKUP (? number-pushed) (? prefix) (? continuation)
@@ -788,10 +786,10 @@ MIT in each case. |#
;;; appropriately.
(define-rule statement
- (PROCEDURE-HEAP-CHECK (? procedure))
+ (PROCEDURE-HEAP-CHECK (? label))
(disable-frame-pointer-offset!
(let ((gc-label (generate-label)))
- `(,@(procedure-header procedure gc-label)
+ `(,@(procedure-header (label->procedure label) gc-label)
(CMP L ,reg:compiled-memtop (A 5))
(B GE S (@PCR ,gc-label))))))
@@ -802,23 +800,23 @@ MIT in each case. |#
;;; or by examining the calling sequence.
(define-rule statement
- (SETUP-LEXPR (? procedure))
+ (SETUP-LEXPR (? label))
(disable-frame-pointer-offset!
- `(,@(procedure-header procedure false)
- (MOVE W
- (& ,(+ (length (procedure-required procedure))
- (length (procedure-optional procedure))
- (if (procedure/closure? procedure) 1 0)))
- (D 1))
- (MOVEQ (& ,(if (procedure-rest procedure) 1 0)) (D 2))
- (JSR , entry:compiler-setup-lexpr))))
-
-(define-rule statement
- (CONTINUATION-HEAP-CHECK (? continuation))
+ (let ((procedure (label->procedure label)))
+ `(,@(procedure-header label false)
+ (MOVE W
+ (& ,(+ (length (procedure-required procedure))
+ (length (procedure-optional procedure))
+ (if (procedure/closure? procedure) 1 0)))
+ (D 1))
+ (MOVEQ (& ,(if (procedure-rest procedure) 1 0)) (D 2))
+ (JSR , entry:compiler-setup-lexpr)))))
+
+(define-rule statement
+ (CONTINUATION-HEAP-CHECK (? internal-label))
(enable-frame-pointer-offset!
- (continuation-frame-pointer-offset continuation))
- (let ((gc-label (generate-label))
- (internal-label (continuation-label continuation)))
+ (continuation-frame-pointer-offset (label->continuation internal-label)))
+ (let ((gc-label (generate-label)))
`((LABEL ,gc-label)
(JSR ,entry:compiler-interrupt-continuation)
,@(make-external-label internal-label)
@@ -874,10 +872,10 @@ MIT in each case. |#
`((MOVE L (& ,(+ #x00100000 (* frame-size 4))) (@-A 7)))))
(define-rule statement
- (MESSAGE-RECEIVER:SUBPROBLEM (? continuation))
- (record-continuation-frame-pointer-offset! continuation)
+ (MESSAGE-RECEIVER:SUBPROBLEM (? label))
+ (record-continuation-frame-pointer-offset! label)
(increment-frame-pointer-offset! 2
- `((PEA (@PCR ,(continuation-label continuation)))
+ `((PEA (@PCR ,label))
(MOVE B (& ,type-code:return-address) (@A 7))
(MOVE L (& #x00200000) (@-A 7)))))
diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm
index 3760433d7..14c762bfa 100644
--- a/v7/src/compiler/rtlbase/rtlcon.scm
+++ b/v7/src/compiler/rtlbase/rtlcon.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 1.2 1987/05/07 00:10:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 1.3 1987/05/15 19:50:14 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
@@ -120,23 +120,47 @@ MIT in each case. |#
(define rtl:make-interpreter-call:unbound?
(interpreter-lookup-maker %make-interpreter-call:unbound?))
-
-;;; Invocations
-
-(define *jump-invocations*)
-
-(define (rtl:make-invocation:jump number-pushed prefix continuation procedure)
- (let ((scfg
- (%make-invocation:jump number-pushed prefix continuation procedure)))
- (set! *jump-invocations* (cons (cfg-entry-node scfg) *jump-invocations*))
- scfg))
-
-(define (rtl:make-invocation:lookup number-pushed prefix continuation
+
+;;;; Invocations
+
+(define (rtl:make-invocation:apply frame-size prefix contination)
+ (%make-invocation:apply frame-size
+ prefix
+ (and continuation
+ (continuation-label continuation))))
+
+(define (rtl:make-invocation:jump frame-size prefix continuation procedure)
+ (%make-invocation:jump frame-size
+ prefix
+ (and continuation
+ (continuation-label continuation))
+ (procedure-label procedure)))
+
+(define (rtl:make-invocation:lexpr frame-size prefix continuation procedure)
+ (%make-invocation:lexpr frame-size
+ prefix
+ (and continuation
+ (continuation-label continuation))
+ (procedure-label procedure)))
+
+(define (rtl:make-invocation:lookup frame-size prefix continuation
environment name)
(expression-simplify-for-statement environment
(lambda (environment)
- (%make-invocation:lookup number-pushed prefix continuation
- environment name))))
+ (%make-invocation:lookup frame-size
+ prefix
+ (and continuation
+ (continuation-label continuation))
+ environment
+ name))))
+
+(define (rtl:make-invocation:primitive frame-size prefix continuation
+ procedure)
+ (%make-invocation:primitive frame-size
+ prefix
+ (and continuation
+ (continuation-label continuation))
+ procedure))
;;;; Expression Simplification
diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm
index a2fa3aeb1..ac5af8f67 100644
--- a/v7/src/compiler/rtlbase/rtlty1.scm
+++ b/v7/src/compiler/rtlbase/rtlty1.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 1.3 1987/05/07 00:11:33 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 1.4 1987/05/15 19:50:24 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
@@ -46,8 +46,8 @@ MIT in each case. |#
(define-rtl-expression cons-pointer rtl: type datum)
(define-rtl-expression constant rtl: value)
-(define-rtl-expression entry:continuation rtl: continuation)
-(define-rtl-expression entry:procedure rtl: procedure)
+(define-rtl-expression entry:continuation % continuation)
+(define-rtl-expression entry:procedure % procedure)
(define-rtl-expression offset-address rtl: register number)
(define-rtl-expression unassigned rtl:)
@@ -57,10 +57,10 @@ MIT in each case. |#
(define-rtl-predicate unassigned-test % expression)
(define-rtl-statement assign % address expression)
-(define-rtl-statement continuation-heap-check rtl: continuation)
-(define-rtl-statement procedure-heap-check rtl: procedure)
+(define-rtl-statement continuation-heap-check % continuation)
+(define-rtl-statement procedure-heap-check % procedure)
(define-rtl-statement return rtl:)
-(define-rtl-statement setup-lexpr rtl: procedure)
+(define-rtl-statement setup-lexpr % procedure)
(define-rtl-statement interpreter-call:access % environment name)
(define-rtl-statement interpreter-call:define % environment name value)
@@ -70,19 +70,18 @@ MIT in each case. |#
(define-rtl-statement interpreter-call:unassigned? % environment name)
(define-rtl-statement interpreter-call:unbound? % environment name)
-(define-rtl-statement invocation:apply rtl: pushed prefix continuation)
+(define-rtl-statement invocation:apply % pushed prefix continuation)
(define-rtl-statement invocation:jump % pushed prefix continuation procedure)
-(define-rtl-statement invocation:lexpr rtl: pushed prefix continuation
- procedure)
+(define-rtl-statement invocation:lexpr % pushed prefix continuation procedure)
(define-rtl-statement invocation:lookup % pushed prefix continuation
environment name)
-(define-rtl-statement invocation:primitive rtl: pushed prefix continuation
+(define-rtl-statement invocation:primitive % pushed prefix continuation
procedure)
(define-rtl-statement message-sender:value rtl: size)
(define-rtl-statement message-receiver:closure rtl: size)
(define-rtl-statement message-receiver:stack rtl: size)
-(define-rtl-statement message-receiver:subproblem rtl: continuation)
+(define-rtl-statement message-receiver:subproblem % continuation)
(define-integrable rtl:expression-type first)
(define-integrable rtl:address-register second)
@@ -91,6 +90,24 @@ MIT in each case. |#
(define-integrable rtl:invocation-prefix third)
(define-integrable rtl:invocation-continuation fourth)
(define-integrable rtl:test-expression second)
+
+(define-integrable (rtl:make-entry:continuation continuation)
+ (%make-entry:continuation (continuation-label continuation)))
+
+(define-integrable (rtl:make-entry:procedure procedure)
+ (%make-entry:procedure (procedure-label procedure)))
+
+(define-integrable (rtl:make-continuation-heap-check continuation)
+ (%make-continuation-heap-check (continuation-label continuation)))
+
+(define-integrable (rtl:make-procedure-heap-check procedure)
+ (%make-procedure-heap-check (procedure-label procedure)))
+
+(define-integrable (rtl:make-setup-lexpr procedure)
+ (%make-setup-lexpr (procedure-label procedure)))
+
+(define-integrable (rtl:make-message-receiver:subproblem continuation)
+ (%make-message-receiver:subproblem (continuation-label continuation)))
;;;; Locatives