#| -*-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
(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)
#| -*-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
(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)
(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
#| -*-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
(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))
\f
;;;; SCode Interface
#| -*-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
`((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)))))
\f
(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)))))
\f
;;;; Predicates
(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)))))
\f
(define-rule statement
(INVOCATION:LOOKUP (? number-pushed) (? prefix) (? continuation)
;;; 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))))))
;;; 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)
`((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)))))
#| -*-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
(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
+\f
+;;;; 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))
\f
;;;; Expression Simplification
#| -*-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
(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:)
(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)
(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)
\f
(define-integrable rtl:expression-type first)
(define-integrable rtl:address-register second)
(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)))
\f
;;;; Locatives
projects / mit-scheme.git / commitdiff