#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.3 1988/12/30 07:02:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.4 1989/01/06 20:50:21 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define (info-generation-phase-1 expression procedures)
- (set-expression-debugging-info!
- expression
- (make-dbg-expression (block->dbg-block (expression-block expression))
- (expression-label expression)))
- (for-each
- (lambda (procedure)
- (if (procedure-continuation? procedure)
- (set-continuation/debugging-info!
- procedure
- (let ((block (block->dbg-block (continuation/block procedure))))
- (let ((continuation
- (make-dbg-continuation block
- (continuation/label procedure)
- (enumeration/index->name
- continuation-types
- (continuation/type procedure))
- (continuation/offset procedure))))
- (set-dbg-block/procedure! block continuation)
- continuation)))
- (set-procedure-debugging-info!
- procedure
- (let ((block (block->dbg-block (procedure-block procedure))))
- (let ((procedure
- (make-dbg-procedure
- block
- (procedure-label procedure)
- (procedure/type procedure)
- (symbol->string (procedure-name procedure))
- (map variable->dbg-name
- (cdr (procedure-required procedure)))
- (map variable->dbg-name (procedure-optional procedure))
- (let ((rest (procedure-rest procedure)))
- (and rest (variable->dbg-name rest)))
- (map variable->dbg-name (procedure-names procedure)))))
- (set-dbg-block/procedure! block procedure)
- procedure)))))
- procedures))
+ (fluid-let ((*integrated-variables* '()))
+ (set-expression-debugging-info!
+ expression
+ (make-dbg-expression (block->dbg-block (expression-block expression))
+ (expression-label expression)))
+ (for-each
+ (lambda (procedure)
+ (if (procedure-continuation? procedure)
+ (set-continuation/debugging-info!
+ procedure
+ (let ((block (block->dbg-block (continuation/block procedure))))
+ (let ((continuation
+ (make-dbg-continuation
+ block
+ (continuation/label procedure)
+ (enumeration/index->name continuation-types
+ (continuation/type procedure))
+ (continuation/offset procedure)
+ (continuation/debugging-info procedure))))
+ (set-dbg-block/procedure! block continuation)
+ continuation)))
+ (set-procedure-debugging-info!
+ procedure
+ (let ((block (block->dbg-block (procedure-block procedure))))
+ (let ((procedure
+ (make-dbg-procedure
+ block
+ (procedure-label procedure)
+ (procedure/type procedure)
+ (procedure-name procedure)
+ (map variable->dbg-variable
+ (cdr (procedure-original-required procedure)))
+ (map variable->dbg-variable
+ (procedure-original-optional procedure))
+ (let ((rest (procedure-original-rest procedure)))
+ (and rest (variable->dbg-variable rest)))
+ (map variable->dbg-variable (procedure-names procedure))
+ (procedure-debugging-info procedure))))
+ (set-dbg-block/procedure! block procedure)
+ procedure)))))
+ procedures)
+ (for-each process-integrated-variable! *integrated-variables*)))
+(define (generated-dbg-continuation context label)
+ (let ((block
+ (make-dbg-block/continuation (reference-context/block context)
+ false)))
+ (let ((continuation
+ (make-dbg-continuation block
+ label
+ 'GENERATED
+ (reference-context/offset context)
+ false)))
+ (set-dbg-block/procedure! block continuation)
+ continuation)))
+\f
(define (block->dbg-block block)
(and block
(or (block-debugging-info block)
(if (not (continuation-variable? variable))
(layout-set! layout
(variable-normal-offset variable)
- (variable->dbg-name variable))))
+ (variable->dbg-variable variable))))
(block-bound-variables block))
(if (procedure/closure? procedure)
(if (closure-procedure-needs-operator? procedure)
dbg-block-name/static-link)))
(make-dbg-block 'STACK
(block->dbg-block parent)
+ (and (procedure/closure? procedure)
+ (block->dbg-block
+ (reference-context/block
+ (procedure-closure-context procedure))))
layout
(block->dbg-block (block-stack-link block))))))
-\f
+
(define (continuation-block->dbg-block block)
(make-dbg-block/continuation
(block-parent block)
(make-dbg-block
'CONTINUATION
dbg-parent
+ false
(let ((names
(append (if always-known?
'()
(layout-set! layout index (car names)))
layout))
dbg-parent)))
-
+\f
(define (closure-block->dbg-block block)
(let ((parent (block-parent block))
(offsets
(for-each (lambda (offset)
(layout-set! layout
(cdr offset)
- (variable->dbg-name (car offset))))
+ (variable->dbg-variable (car offset))))
offsets)
(if (and parent (ic-block/use-lookup? parent))
(layout-set! layout 0 dbg-block-name/ic-parent))
- (make-dbg-block 'CLOSURE (block->dbg-block parent) layout false))))
+ (make-dbg-block 'CLOSURE (block->dbg-block parent) false layout false))))
(define (ic-block->dbg-block block)
- (make-dbg-block 'IC (block->dbg-block (block-parent block)) false false))
+ (make-dbg-block 'IC (block->dbg-block (block-parent block))
+ false false false))
(define-integrable (make-layout length)
(make-vector length false))
(vector-set! layout index name)
unspecific)
-(define-integrable (variable->dbg-name variable)
- (symbol->dbg-name (variable-name variable)))
+(define *integrated-variables*)
-(define (generated-dbg-continuation context label)
- (let ((block
- (make-dbg-block/continuation (reference-context/block context)
- false)))
- (let ((continuation
- (make-dbg-continuation block
- label
- 'GENERATED
- (reference-context/offset context))))
- (set-dbg-block/procedure! block continuation)
- continuation)))
+(define (variable->dbg-variable variable)
+ (or (lvalue-get variable dbg-variable-tag)
+ (let ((integrated? (lvalue-integrated? variable)))
+ (let ((dbg-variable
+ (make-dbg-variable (variable-name variable)
+ (cond (integrated? 'INTEGRATED)
+ ((variable-in-cell? variable) 'CELL)
+ (else 'NORMAL))
+ (and integrated?
+ (lvalue-known-value variable))))) (if integrated?
+ (set! *integrated-variables*
+ (cons dbg-variable *integrated-variables*)))
+ (lvalue-put! variable dbg-variable-tag dbg-variable)
+ dbg-variable))))
+
+(define dbg-variable-tag
+ "dbg-variable-tag")
+
+(define (process-integrated-variable! variable)
+ (set-dbg-variable/value!
+ variable
+ (let ((rvalue (dbg-variable/value variable)))
+ (cond ((rvalue/constant? rvalue) (constant-value rvalue))
+ ((rvalue/procedure? rvalue) (procedure-debugging-info rvalue))
+ (else (error "Illegal variable value" rvalue))))))
\f
(define (info-generation-phase-2 expression procedures continuations)
(let ((debug-info
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/subprb.scm,v 4.5 1988/12/16 13:13:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/subprb.scm,v 4.6 1989/01/06 20:50:41 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
;;; have resided in the real continuation.
(define-structure (virtual-continuation
- (constructor virtual-continuation/%make
- (context parent type))
+ (constructor virtual-continuation/%make)
(conc-name virtual-continuation/)
(print-procedure
(standard-unparser "VIRTUAL-CONTINUATION" (lambda (state continuation)
type))))))))
context
parent
- type)
+ type
+ debugging)
(define-integrable (virtual-continuation/make block type)
;; Used exclusively after FG generation.
- (virtual-continuation/%make block false type))
+ (virtual-continuation/%make block false type false))
(define-integrable (virtual-continuation/reified? continuation)
(not (virtual-continuation/type continuation)))
(virtual-continuation/context continuation)
(virtual-continuation/parent continuation)
(virtual-continuation/type continuation))))
+ (set-continuation/debugging-info!
+ reification
+ (virtual-continuation/debugging continuation))
(set-virtual-continuation/context! continuation reification)
(set-virtual-continuation/parent! continuation false)
(set-virtual-continuation/type! continuation false)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.14 1988/12/19 20:31:25 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.15 1989/01/06 20:50:55 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(eq? (continuation/type continuation) type))
(else
(error "Illegal continuation" continuation))))
-\f
+
(define-integrable (continuation/effect? continuation)
(continuation/type? continuation continuation-type/effect))
\f
(define *virtual-continuations*)
-(define (virtual-continuation/make block parent type)
- (let ((continuation (virtual-continuation/%make block parent type)))
+(define (virtual-continuation/make block parent type debugging)
+ (let ((continuation
+ (virtual-continuation/%make block parent type debugging)))
(set! *virtual-continuations* (cons continuation *virtual-continuations*))
continuation))
(define (wrapper/subproblem type)
- (lambda (block continuation generator)
- (generator (virtual-continuation/make block continuation type))))
+ (lambda (block continuation debugging generator)
+ (generator (virtual-continuation/make block continuation type debugging))))
(define wrapper/subproblem/effect
(wrapper/subproblem continuation-type/effect))
(wrapper/subproblem continuation-type/value))
(define (generator/subproblem wrapper)
- (lambda (block continuation expression)
- (wrapper block continuation
+ (lambda (block continuation expression debugging)
+ (wrapper block continuation debugging
(lambda (continuation)
(generate/expression block continuation expression)))))
(optional (make-variables block optional))
(rest (and rest (make-variable block rest)))
(names (make-variables block names)))
- (define (kernel)
- (make-procedure
- continuation-type/procedure
- block name (cons continuation required) optional rest names
- (map
- (lambda (value)
- ;; The other parts of this subproblem are not
- ;; interesting since `value' is guaranteed to
- ;; be either a constant or a procedure.
- (subproblem-rvalue
- (generate/subproblem/value block continuation value)))
- values)
- (generate/body block continuation declarations body)))
(set-continuation-variable/type! continuation continuation-type)
(set-block-bound-variables! block
`(,continuation
,@optional
,@(if rest (list rest) '())
,@names))
- (if closure-block
- (let ((proc (kernel)))
- (set-procedure-closure-context! proc closure-block)
- proc)
- (kernel))))))))))
+ (let ((procedure
+ (make-procedure
+ continuation-type/procedure
+ block name (cons continuation required) optional rest
+ names
+ (map
+ (lambda (value)
+ ;; The other parts of this subproblem are not
+ ;; interesting since `value' is guaranteed to
+ ;; be either a constant or a procedure.
+ (subproblem-rvalue
+ (generate/subproblem/value block
+ continuation
+ value
+ false)))
+ values)
+ (generate/body block continuation declarations body))))
+ (if closure-block
+ (set-procedure-closure-context! procedure closure-block))
+ (set-procedure-debugging-info! procedure expression)
+ procedure)))))))))
\f
(define (parse-procedure-body auxiliary body)
(transmit-values
scfg*scfg->scfg!
scfg*pcfg->pcfg!
scfg*subproblem->subproblem!)))
- (let loop ((actions (scode/sequence-actions expression)))
- (if (null? (cdr actions))
- (generate/expression block continuation (car actions))
- (join (generate/subproblem/effect block continuation (car actions))
- (loop (cdr actions)))))))
+ (let ((do-action
+ (lambda (action continuation-type)
+ (generate/subproblem/effect block
+ continuation
+ action
+ (vector continuation-type
+ expression))))
+ (do-result
+ (lambda (expression)
+ (generate/expression block continuation expression))))
+ (cond ((object-type? (ucode-type sequence-2) expression)
+ (join (do-action (&pair-car expression) 'SEQUENCE-2-SECOND)
+ (do-result (&pair-cdr expression))))
+ ((object-type? (ucode-type sequence-3) expression)
+ (join
+ (do-action (&triple-first expression) 'SEQUENCE-3-SECOND)
+ (join
+ (do-action (&triple-second expression) 'SEQUENCE-3-THIRD)
+ (do-result (&triple-third expression)))))
+ (else
+ (error "Not a sequence" expression))))))
\f
(define (generate/conditional block continuation expression)
(scode/conditional-components expression
(lambda (predicate consequent alternative)
(let ((predicate
- (generate/subproblem/predicate block continuation predicate)))
+ (generate/subproblem/predicate
+ block
+ continuation
+ predicate
+ (vector 'CONDITIONAL-DECIDE expression))))
(let ((simple
(lambda (hooks branch)
((continuation/case continuation
(make-combination
block
(continuation-reference block continuation)
- (generate/operator block continuation operator)
- (map (lambda (expression)
- (generate/subproblem/value block
- continuation
- expression))
- operands)
+ (wrapper/subproblem/value
+ block
+ continuation
+ (vector 'COMBINATION-OPERAND expression 0)
+ (lambda (continuation*)
+ (if (scode/lambda? operator)
+ (generate/lambda* block
+ continuation*
+ operator
+ (continuation/known-type continuation)
+ false)
+ (generate/expression block
+ continuation*
+ operator))))
+ (let loop ((operands operands) (index 1))
+ (if (null? operands)
+ '()
+ (cons (generate/subproblem/value
+ block
+ continuation
+ (car operands)
+ (vector 'COMBINATION-OPERAND expression index))
+ (loop (cdr operands) (1+ index)))))
push))))
((continuation/case continuation
(lambda () (make-combination false continuation))
(make-subproblem/canonical
(make-combination push continuation)
continuation))))))))))
-
-(define (generate/operator block continuation operator)
- (wrapper/subproblem/value block continuation
- (lambda (continuation*)
- (if (scode/lambda? operator)
- (generate/lambda* block
- continuation*
- operator
- (continuation/known-type continuation)
- false)
- (generate/expression block
- continuation*
- operator)))))
\f
;;;; Assignments
-(define (generate/assignment* maker find-name block continuation name value)
- (let ((subproblem (generate/subproblem/value block continuation value)))
+(define (generate/assignment* maker find-name continuation-type
+ block continuation expression name value)
+ (let ((subproblem
+ (generate/subproblem/value
+ block
+ continuation
+ value
+ (vector continuation-type expression))))
(scfg-append!
(if (subproblem-canonical? subproblem)
(make-scfg
(scode/assignment-components expression
(lambda (name value)
(if (continuation/effect? continuation)
- (generate/assignment* make-assignment find-name
- block continuation name value)
+ (generate/assignment* make-assignment find-name 'ASSIGNMENT-CONTINUE
+ block continuation expression name value)
(generate/combination
block
continuation
(lambda (name value)
(if (continuation/effect? continuation)
(generate/assignment* make-definition make-definition-variable
- block continuation name
- (insert-letrec name value))
- (generate/sequence block
- continuation
- (scode/make-sequence
- (list (scode/make-definition name value)
- name)))))))
+ 'DEFINITION-CONTINUE block continuation
+ expression name (insert-letrec name value))
+ (generate/expression
+ block
+ continuation
+ (scode/make-sequence (list expression name)))))))
(define (make-definition-variable block name)
(let ((bound (block-bound-variables block)))
(generate/conditional
block
continuation
- (scode/make-conditional predicate (make-constant true) alternative)))))
+ (scode/make-conditional predicate true alternative)))))
(define (generate/disjunction/value block continuation expression)
(scode/disjunction-components expression
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.16 1988/12/30 07:01:53 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.17 1989/01/06 20:50:03 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
dbg-block/stack-link
set-dbg-block/procedure!
+ make-dbg-variable
+ dbg-variable/value
+ set-dbg-variable/value!
+
dbg-block-name/dynamic-link
dbg-block-name/ic-parent
dbg-block-name/normal-closure
set-dbg-label/names!
dbg-label/offset
set-dbg-label/name!
- set-dbg-label/external?!
-
- symbol->dbg-name
- ))
+ set-dbg-label/external?!))
\f
(define-package (compiler fg-generator)
(files "fggen/canon" ;SCode canonicalizer
(parent (compiler))
(export (compiler top-level)
canonicalize/top-level
- construct-graph))
+ construct-graph)
+ (import (runtime scode-data)
+ &pair-car
+ &pair-cdr
+ &triple-first
+ &triple-second
+ &triple-third))
(define-package (compiler fg-optimizer)
(files "fgopt/outer" ;outer analysis
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.36 1988/12/30 07:03:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.37 1989/01/06 20:51:12 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
'((COMPILER MACROS)
(COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar" 4 36 '()))
\ No newline at end of file
+(add-system! (make-system "Liar" 4 37 '()))
\ No newline at end of file
projects / mit-scheme.git / commitdiff