introduced in runtime system version 14.31.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.2 1988/04/15 02:08:43 jinx Exp $
+$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 $
Copyright (c) 1988 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Debugging information output.
+;;;; Debugging Information
(declare (usual-integrations))
\f
-(define (generation-phase2 label-bindings external-labels)
- (make-compiler-info
- '()
- '()
- (list->vector
- (sort (map (lambda (association)
- (make-label-info
- (symbol->string (car association))
- (cdr association)
- (let loop ((external-labels external-labels))
- (cond ((null? external-labels) false)
- ((eq? (car association) (car external-labels)) true)
- (else (loop (cdr external-labels)))))))
- label-bindings)
- (lambda (x y)
- (< (label-info-offset x) (label-info-offset y)))))))
-
-(define (generate-vector top-level selector others)
- (let* ((last (length others))
- (v (make-vector (1+ last) '())))
- (vector-set! v 0 top-level)
- (let loop ((l others))
- (if (null? l)
- v
- (let ((desc (car l)))
- (vector-set! v (car desc) (selector desc))
- (loop (cdr l)))))))
-
-(define (generate-top-level-info top-level others)
- (if (null? others)
- top-level
- (generate-vector top-level cadr others)))
-
-(define (generate-top-level-object top-level others)
- (if (null? others)
- top-level
- (scode/make-comment
- (list compiler-entries-tag
- (generate-vector (compiled-code-address->block top-level)
- caddr others))
- top-level)))
\ No newline at end of file
+(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))
+
+(define (block->dbg-block block)
+ (and block
+ (or (block-debugging-info block)
+ (let ((dbg-block
+ (enumeration-case block-type (block-type block)
+ ((STACK) (stack-block->dbg-block block))
+ ((CONTINUATION) (continuation-block->dbg-block block))
+ ((CLOSURE) (closure-block->dbg-block block))
+ ((IC) (ic-block->dbg-block block))
+ (else
+ (error "BLOCK->DBG-BLOCK: Illegal block type" block)))))
+ (set-block-debugging-info! block dbg-block)
+ dbg-block))))
+
+(define (stack-block->dbg-block block)
+ (let ((parent (block-parent block))
+ (frame-size (block-frame-size block))
+ (procedure (block-procedure block)))
+ (let ((layout (make-layout frame-size)))
+ (for-each (lambda (variable)
+ (if (not (continuation-variable? variable))
+ (layout-set! layout
+ (variable-normal-offset variable)
+ (variable->dbg-name variable))))
+ (block-bound-variables block))
+ (if (procedure/closure? procedure)
+ (if (closure-procedure-needs-operator? procedure)
+ (layout-set! layout
+ (procedure-closure-offset procedure)
+ dbg-block-name/normal-closure))
+ (if (stack-block/static-link? block)
+ (layout-set! layout
+ (-1+ frame-size)
+ dbg-block-name/static-link)))
+ (make-dbg-block 'STACK
+ (block->dbg-block parent)
+ layout
+ (block->dbg-block (block-stack-link block))))))
+\f
+(define (continuation-block->dbg-block block)
+ (make-dbg-block/continuation
+ (block-parent block)
+ (continuation/always-known-operator? (block-procedure block))))
+
+(define (make-dbg-block/continuation parent always-known?)
+ (let ((dbg-parent (block->dbg-block parent)))
+ (make-dbg-block
+ 'CONTINUATION
+ dbg-parent
+ (let ((names
+ (append (if always-known?
+ '()
+ (list dbg-block-name/return-address))
+ (if (block/dynamic-link? parent)
+ (list dbg-block-name/dynamic-link)
+ '())
+ (if (ic-block? parent)
+ (list dbg-block-name/ic-parent)
+ '()))))
+ (let ((layout (make-layout (length names))))
+ (do ((names names (cdr names))
+ (index 0 (1+ index)))
+ ((null? names))
+ (layout-set! layout index (car names)))
+ layout))
+ dbg-parent)))
+
+(define (closure-block->dbg-block block)
+ (let ((parent (block-parent block))
+ (offsets
+ (map (lambda (offset)
+ (cons (car offset)
+ (- (cdr offset) closure-block-first-offset)))
+ (block-closure-offsets block))))
+ (let ((layout (make-layout (1+ (apply max (map cdr offsets))))))
+ (for-each (lambda (offset)
+ (layout-set! layout
+ (cdr offset)
+ (variable->dbg-name (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))))
+
+(define (ic-block->dbg-block block)
+ (make-dbg-block 'IC (block->dbg-block (block-parent block)) false false))
+
+(define-integrable (make-layout length)
+ (make-vector length false))
+
+(define (layout-set! layout index name)
+ (let ((name* (vector-ref layout index)))
+ (if name* (error "LAYOUT-SET!: reusing layout slot" name* name)))
+ (vector-set! layout index name)
+ unspecific)
+
+(define-integrable (variable->dbg-name variable)
+ (symbol->dbg-name (variable-name variable)))
+
+(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)))
+\f
+(define (info-generation-phase-2 expression procedures continuations)
+ (let ((debug-info
+ (lambda (selector object)
+ (or (selector object)
+ (error "Missing debugging info" object)))))
+ (values
+ (debug-info rtl-expr/debugging-info expression)
+ (map (lambda (procedure)
+ (let ((info (debug-info rtl-procedure/debugging-info procedure)))
+ (set-dbg-procedure/external-label!
+ info
+ (rtl-procedure/%external-label procedure))
+ info))
+ procedures)
+ (map (lambda (continuation)
+ (debug-info rtl-continuation/debugging-info continuation))
+ continuations))))
+
+(define (info-generation-phase-3 expression procedures continuations
+ label-bindings external-labels)
+ (let ((dbg-labels (labels->dbg-labels label-bindings)))
+ (let ((labels (make-btree)))
+ (for-each (lambda (dbg-label)
+ (for-each (lambda (name)
+ (btree-insert! labels string<? car name
+ (lambda (name)
+ (cons name dbg-label))
+ (lambda (association)
+ (error "redefining label" association))
+ (lambda (association)
+ association
+ unspecific)))
+ (dbg-label/names dbg-label)))
+ dbg-labels)
+ (let ((map-label
+ (lambda (label)
+ (btree-lookup labels string<? car (system-pair-car label)
+ cdr
+ (lambda (name)
+ (error "Missing label" name))))))
+ (for-each (lambda (label)
+ (set-dbg-label/external?! (map-label label) true))
+ external-labels)
+ (set-dbg-expression/label!
+ expression
+ (map-label (dbg-expression/label expression))) (for-each
+ (lambda (procedure)
+ (set-dbg-procedure/label!
+ procedure
+ (map-label (dbg-procedure/label procedure)))
+ (let ((label (dbg-procedure/external-label procedure)))
+ (if label
+ (set-dbg-procedure/external-label! procedure
+ (map-label label)))))
+ procedures)
+ (for-each
+ (lambda (continuation)
+ (set-dbg-continuation/label!
+ continuation
+ (map-label (dbg-continuation/label continuation))))
+ continuations)))
+ (make-dbg-info
+ expression
+ (list->vector (sort procedures dbg-procedure<?))
+ (list->vector (sort continuations dbg-continuation<?))
+ (list->vector dbg-labels))))
+\f
+(define (labels->dbg-labels label-bindings)
+ (let ((dbg-labels
+ (let ((labels (make-btree)))
+ (for-each
+ (lambda (binding)
+ (let ((name (system-pair-car (car binding))))
+ (btree-insert! labels < dbg-label/offset (cdr binding)
+ (lambda (offset)
+ (make-dbg-label name offset))
+ (lambda (dbg-label)
+ (set-dbg-label/names!
+ dbg-label
+ (cons name (dbg-label/names dbg-label))))
+ (lambda (dbg-label)
+ dbg-label
+ unspecific))))
+ label-bindings)
+ (btree-fringe labels))))
+ (for-each (lambda (dbg-label)
+ (set-dbg-label/name!
+ dbg-label
+ (choose-distinguished-label (dbg-label/names dbg-label))))
+ dbg-labels)
+ dbg-labels))
+
+(define (choose-distinguished-label names)
+ (if (null? (cdr names))
+ (car names)
+ (let ((distinguished
+ (list-transform-negative names
+ (lambda (name)
+ (or (standard-name? name "label")
+ (standard-name? name "end-label"))))))
+ (cond ((null? distinguished)
+ (min-suffix names))
+ ((null? (cdr distinguished))
+ (car distinguished))
+ (else
+ (min-suffix distinguished))))))
+
+(define (min-suffix names)
+ (let ((suffix-number
+ (lambda (name)
+ (let ((index (string-find-previous-char name #\-)))
+ (if (not index)
+ (error "Illegal label name" name))
+ (let ((suffix (string-tail name (1+ index))))
+ (let ((result (string->number suffix)))
+ (if (not result)
+ (error "Illegal label suffix" suffix))
+ result))))))
+ (car (sort names (lambda (x y) (< (suffix-number x) (suffix-number y)))))))
+
+(define (standard-name? string prefix)
+ (let ((index (string-match-forward-ci string prefix))
+ (end (string-length string)))
+ (and (= index (string-length prefix))
+ (>= (- end index) 2)
+ (char=? #\- (string-ref string index))
+ (let loop ((index (1+ index)))
+ (or (= index end)
+ (and (char-numeric? (string-ref string index))
+ (loop (1+ index))))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.13 1988/12/13 13:02:39 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.14 1988/12/30 07:02:55 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define *rtl-continuations*)
(define *rtl-graphs*)
(define label->object)
+(define *dbg-expression*)
+(define *dbg-procedures*)
+(define *dbg-continuations*)
;;; These variable names mistakenly use the format "compiler:..."
;;; instead of the correct format, which is "*...*". Fix it sometime.
(set! *lvalues*)
(set! *applications*)
(set! *parallels*)
- ;; (set! *assignments*)
(set! *ic-procedure-headers*)
(set! *root-expression*)
(set! *root-block*)
(set! *rtl-continuations*)
(set! *rtl-graphs*)
(set! label->object)
+ (set! *dbg-expression*)
+ (set! *dbg-procedures*)
+ (set! *dbg-continuations*)
(set! *machine-register-map*)
(set! compiler:external-labels)
(set! compiler:label-bindings)
(*lvalues*)
(*applications*)
(*parallels*)
- ;; (*assignments*)
(*ic-procedure-headers*)
(*root-expression*)
(*root-block*))
(*rtl-continuations*)
(*rtl-graphs*)
(label->object)
+ (*dbg-expression*)
+ (*dbg-procedures*)
+ (*dbg-continuations*)
(*machine-register-map*)
(compiler:external-labels)
(compiler:label-bindings)
(fluid-let ((compiler:process-time 0)
(compiler:real-time 0))
(compiler:reset!)
- (let* ((topl (thunk))
- (value
- (generate-top-level-object topl *recursive-compilation-results*)))
+ (let ((value
+ (let ((expression (thunk)))
+ (let ((others (recursive-compilation-results)))
+ (if (null? others)
+ expression
+ (scode/make-comment
+ (make-dbg-info-vector
+ (list->vector
+ (cons (compiled-code-address->block expression)
+ (map (lambda (other) (vector-ref other 2))
+ others))))
+ expression))))))
(if (not compiler:preserve-data-structures?)
(compiler:reset!))
(compiler-time-report "Total compilation time"
compiler:process-time
compiler:real-time)
value)))
+
+(define (recursive-compilation-results)
+ (sort *recursive-compilation-results* (lambda (x y) (< (car x) (car y)))))
\f
;;;; The file compiler, its usual mode.
(write-string " (real time)"))
(define-macro (last-reference name)
- `(IF COMPILER:PRESERVE-DATA-STRUCTURES?
- ,name
- (SET! ,name)))
+ (let ((x (generate-uninterned-symbol)))
+ `(IF COMPILER:PRESERVE-DATA-STRUCTURES?
+ ,name
+ (LET ((,x ,name))
+ (SET! ,name)
+ ,x))))
\f
(define (phase/fg-generation)
(compiler-superphase "Flow Graph Generation"
(set! *lvalues* '())
(set! *applications* '())
(set! *parallels* '())
- ;; (set! *assignments* '())
(set! *root-expression* (construct-graph (last-reference *scode*)))
(set! *root-block* (expression-block *root-expression*))
(if (or (null? *expressions*)
(not (null? (cdr *expressions*))))
(error "Multiple expressions"))
(set! *expressions*))))
-\f
+
(define (phase/fg-optimization)
(compiler-superphase "Flow Graph Optimization"
(lambda ()
(phase/subproblem-ordering)
(phase/connectivity-analysis)
(phase/compute-node-offsets)
+ (phase/info-generation-1)
(phase/fg-optimization-cleanup))))
(define (phase/simulate-application)
(define (phase/environment-optimization)
(compiler-subphase "Environment Optimization"
- (lambda ()
- (optimize-environments! *procedures*))))
+ (lambda ()
+ (optimize-environments! *procedures*))))
(define (phase/identify-closure-limits)
(compiler-subphase "Closure Limit Identification"
(setup-closure-contexts! *root-expression* *procedures*))))
(define (phase/compute-call-graph)
- (compiler-subphase
- "Call Graph Computation"
- (lambda ()
- (compute-call-graph! *procedures*))))
+ (compiler-subphase "Call Graph Computation"
+ (lambda ()
+ (compute-call-graph! *procedures*))))
(define (phase/side-effect-analysis)
- (compiler-subphase
- "Side Effect Analysis"
- (lambda ()
- (side-effect-analysis *procedures* *applications*))))
+ (compiler-subphase "Side Effect Analysis"
+ (lambda ()
+ (side-effect-analysis *procedures* *applications*))))
(define (phase/continuation-analysis)
(compiler-subphase "Continuation Analysis"
(lambda ()
(compute-node-offsets *root-expression*))))
+(define (phase/info-generation-1)
+ (compiler-subphase "Debugging Information Initialization"
+ (lambda ()
+ (info-generation-phase-1 *root-expression* *procedures*))))
+
(define (phase/fg-optimization-cleanup)
(compiler-subphase "Flow Graph Optimization Cleanup"
(lambda ()
(set! *lvalues*)
(set! *applications*)
(set! *parallels*)
- ;; (set! *assignments*)
(set! *root-block*))))))
\f
(define (phase/rtl-generation)
(linearize-bits *rtl-expression*
*rtl-procedures*
*rtl-continuations*)))
+ (with-values
+ (lambda ()
+ (info-generation-phase-2 *rtl-expression*
+ *rtl-procedures*
+ *rtl-continuations*))
+ (lambda (expression procedures continuations)
+ (set! *dbg-expression* expression)
+ (set! *dbg-procedures* procedures)
+ (set! *dbg-continuations* continuations)))
(if (not compiler:preserve-data-structures?)
(begin (set! label->object)
(set! *rtl-expression*)
(define (phase/assemble)
(compiler-phase "Assembly"
(lambda ()
- (if compiler:preserve-data-structures?
- (assemble compiler:block-label compiler:bits phase/assemble-finish)
- (assemble (set! compiler:block-label)
- (set! compiler:bits)
- phase/assemble-finish)))))
-
-(define (phase/assemble-finish count code-vector labels bindings linkage-info)
- linkage-info ;; ignored
- (set! compiler:code-vector code-vector)
- (set! compiler:entry-points labels)
- (set! compiler:label-bindings bindings)
- (newline)
- (display " Branch tensioning done in ")
- (write (1+ count))
- (if (zero? count)
- (display " iteration.")
- (display " iterations.")))
+ (assemble (last-reference compiler:block-label)
+ (last-reference compiler:bits)
+ (lambda (count code-vector labels bindings linkage-info)
+ linkage-info ; ignored
+ (set! compiler:code-vector code-vector)
+ (set! compiler:entry-points labels)
+ (set! compiler:label-bindings bindings)
+ (newline)
+ (display " Branch tensioning done in ")
+ (write (1+ count))
+ (if (zero? count)
+ (display " iteration.")
+ (display " iterations.")))))))
(define (phase/info-generation-2 pathname)
(compiler-phase "Debugging Information Generation"
- (lambda ()
- (let ((info
- (generation-phase2 compiler:label-bindings
- (last-reference compiler:external-labels))))
-
- (if (eq? pathname true) ; recursive compilation
- (begin
- (set! *recursive-compilation-results*
- (cons (list *recursive-compilation-number*
- info
- compiler:code-vector)
- *recursive-compilation-results*))
- (set-compiled-code-block/debugging-info!
- compiler:code-vector
- (cons (pathname->string *info-output-pathname*)
- *recursive-compilation-number*)))
- (begin
- (fasdump
- (generate-top-level-info info *recursive-compilation-results*)
- pathname)
- (set-compiled-code-block/debugging-info!
- compiler:code-vector
- (pathname->string pathname))))))))
+ (lambda ()
+ (set-compiled-code-block/debugging-info!
+ compiler:code-vector
+ (let ((info
+ (info-generation-phase-3
+ (last-reference *dbg-expression*)
+ (last-reference *dbg-procedures*)
+ (last-reference *dbg-continuations*)
+ compiler:label-bindings
+ (last-reference compiler:external-labels))))
+ (if (eq? pathname true) ; recursive compilation
+ (begin
+ (set! *recursive-compilation-results*
+ (cons (vector *recursive-compilation-number*
+ info
+ compiler:code-vector)
+ *recursive-compilation-results*))
+ (cons (pathname->string *info-output-pathname*)
+ *recursive-compilation-number*))
+ (begin
+ (fasdump (let ((others (recursive-compilation-results)))
+ (if (null? others)
+ info
+ (list->vector
+ (cons info
+ (map (lambda (other) (vector-ref other 1))
+ others)))))
+ pathname)
+ (pathname->string pathname))))))))
\f
(define (phase/link)
(compiler-phase "Linkification"
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.15 1988/12/19 20:23:55 cph Exp $
+$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 $
Copyright (c) 1988 Massachusetts Institute of Technology
"rtlbase/rtlobj" ;RTL: CFG objects
"rtlbase/regset" ;RTL: register sets
- #|
- ;;; Now in runtime system (I hope) ~JRM
- "base/infutl" ;utilities for info generation, shared
- |#
-
"back/insseq" ;LAP instruction sequences
)
(parent ())
reference-context?
set-reference-context/offset!))
+(define-package (compiler balanced-binary-tree)
+ (files "base/btree")
+ (parent (compiler))
+ (export (compiler)
+ btree-delete!
+ btree-fringe
+ btree-insert!
+ btree-lookup
+ make-btree))
+
(define-package (compiler macros)
(files "base/macros")
(parent ())
(export (compiler debug)
*root-expression*
*rtl-procedures*
- *rtl-graphs*))
+ *rtl-graphs*)
+ (import (runtime compiler-info)
+ make-dbg-info-vector))
\f
(define-package (compiler debug)
(files "base/debug")
make-database-transformer
make-symbol-transformer
make-bit-mask-transformer))
-
+\f
+(define-package (compiler debugging-information)
+ (files "base/infnew")
+ (parent (compiler))
+ (export (compiler top-level)
+ info-generation-phase-1
+ info-generation-phase-2
+ info-generation-phase-3)
+ (export (compiler rtl-generator)
+ generated-dbg-continuation)
+ (import (runtime compiler-info)
+ make-dbg-info
+
+ make-dbg-expression
+ dbg-expression/block
+ dbg-expression/label
+ set-dbg-expression/label!
+
+ make-dbg-procedure
+ dbg-procedure/block
+ dbg-procedure/label
+ set-dbg-procedure/label!
+ dbg-procedure/name
+ dbg-procedure/required
+ dbg-procedure/optional
+ dbg-procedure/rest
+ dbg-procedure/auxiliary
+ dbg-procedure/external-label
+ set-dbg-procedure/external-label!
+ dbg-procedure<?
+
+ make-dbg-continuation
+ dbg-continuation/block
+ dbg-continuation/label
+ set-dbg-continuation/label!
+ dbg-continuation<?
+
+ make-dbg-block
+ dbg-block/parent
+ dbg-block/layout
+ dbg-block/stack-link
+ set-dbg-block/procedure!
+
+ dbg-block-name/dynamic-link
+ dbg-block-name/ic-parent
+ dbg-block-name/normal-closure
+ dbg-block-name/return-address
+ dbg-block-name/static-link
+
+ make-dbg-label
+ dbg-label/names
+ set-dbg-label/names!
+ dbg-label/offset
+ set-dbg-label/name!
+ set-dbg-label/external?!
+
+ symbol->dbg-name
+ ))
+\f
(define-package (compiler fg-generator)
(files "fggen/canon" ;SCode canonicalizer
"fggen/fggen" ;SCode->flow-graph converter
(export (compiler top-level)
canonicalize/top-level
construct-graph))
-\f
+
(define-package (compiler fg-optimizer)
(files "fgopt/outer" ;outer analysis
"fgopt/operan" ;operator analysis
(files "fgopt/offset")
(parent (compiler fg-optimizer))
(export (compiler top-level) compute-node-offsets))
-
+\f
(define-package (compiler fg-optimizer connectivity-analysis)
(files "fgopt/conect")
(parent (compiler fg-optimizer))
\f
(define-package (compiler rtl-generator)
(files "rtlgen/rtlgen" ;RTL generator
- "rtlgen/rgproc" ;procedure headers
"rtlgen/rgstmt" ;statements
"rtlgen/fndvar" ;find variables
"machines/bobcat/rgspcm" ;special close-coded primitives
(import (compiler top-level)
label->object))
+(define-package (compiler rtl-generator generate/procedure-header)
+ (files "rtlgen/rgproc")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator) generate/procedure-header))
+
(define-package (compiler rtl-generator combination/inline)
(files "rtlgen/opncod")
(parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- combination/inline)
- (export (compiler top-level)
- open-coding-analysis))
+ (export (compiler rtl-generator) combination/inline)
+ (export (compiler top-level) open-coding-analysis))
(define-package (compiler rtl-generator find-block)
(files "rtlgen/fndblk")
(parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- find-block))
+ (export (compiler rtl-generator) find-block))
(define-package (compiler rtl-generator generate/rvalue)
(files "rtlgen/rgrval")
(files "rtlopt/rdeath")
(parent (compiler rtl-optimizer))
(export (compiler top-level) code-compression))
-
-(define-package (compiler debugging-information)
- (files "base/infnew")
- (parent (compiler))
- (export (compiler top-level)
- generate-top-level-info
- generate-top-level-object
- generation-phase2)
- (import (runtime compiler-info)
- compiler-entries-tag))
\f
(define-package (compiler lap-syntaxer)
(files "back/lapgn1" ;LAP generator
compiler:write-lap-file
compiler:disassemble)
(import (runtime compiler-info)
- compiler-entries-tag))
\ No newline at end of file
+ compiled-code-block/dbg-info
+ dbg-info-vector/items dbg-info-vector?
+ dbg-info/labels
+ dbg-label/external?
+ dbg-label/name
+ dbg-labels/find-offset))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.9 1988/11/05 22:21:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.10 1988/12/30 07:05:04 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
object
(lambda (text expression)
expression ;; ignored
- (if (and (pair? text)
- (eq? (car text) compiler-entries-tag)
- (vector? (cadr text)))
- (for-each disassembler/write-compiled-code-block
- (vector->list (cadr text))
- (if (false? info)
- (make-list (vector-length (cadr text))
- false)
- (vector->list info)))
+ (if (dbg-info-vector? text)
+ (let ((items (dbg-info-vector/items text)))
+ (for-each disassembler/write-compiled-code-block
+ (vector->list items)
+ (if (false? info)
+ (make-list (vector-length items) false)
+ (vector->list info))))
(error "compiler:write-lap-file : Not a compiled file"
(pathname-new-type pathname "com"))))))))))))
(define disassembler/base-address)
(define (compiler:disassemble entry)
- (define (do-it the-block)
- (compiler-info/with-on-demand-loading ;force compiler info loading
- (lambda ()
- (compiled-code-block->compiler-info the-block
- (lambda (info)
- (fluid-let ((disassembler/write-offsets? true)
- (disassembler/write-addresses? true)
- (disassembler/base-address (object-datum the-block)))
- (newline)
- (newline)
- (disassembler/write-compiled-code-block the-block info)))
- (lambda () (error "No compiler info for entry" entry))))))
-
- (compiled-entry->block-and-offset entry
- (lambda (block offset) offset (do-it block))
- (lambda (manifest-block manifest-offset block offset)
- manifest-block manifest-offset offset
- (write-string "Writing MANIFEST-CLOSURE")
- (do-it block))
- (lambda () (error "Cannot disassemble entry" entry))))
+ (let ((block (compiled-entry/block entry)))
+ (let ((info (compiled-code-block/dbg-info block)))
+ (fluid-let ((disassembler/write-offsets? true)
+ (disassembler/write-addresses? true)
+ (disassembler/base-address (object-datum block)))
+ (newline)
+ (newline)
+ (disassembler/write-compiled-code-block block info)))))
\f
;;; Operations exported from the disassembler package
(write-string "]"))
(define (disassembler/write-compiled-code-block block info #!optional page?)
- (let ((symbol-table (compiler-info/symbol-table info)))
- (if (or (default-object? page?) page?)
+ (let ((symbol-table (dbg-info/labels info))) (if (or (default-object? page?) page?)
(begin
(write-char #\page)
(newline)))
(define (disassembler/write-instruction symbol-table offset write-instruction)
(if symbol-table
- (sorted-vector/for-each symbol-table offset
- (lambda (label)
- (write-char #\Tab)
- (write-string (string-downcase (label-info-name label)))
- (write-char #\:)
- (newline))))
+ (let ((label (dbg-labels/find-offset symbol-table offset)))
+ (if label
+ (begin
+ (write-char #\Tab)
+ (write-string (string-downcase (dbg-label/name label))) (write-char #\:)
+ (newline)))))
(if disassembler/write-addresses?
(begin
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.11 1988/12/12 22:11:35 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.12 1988/12/30 07:05:13 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(set! disassembler/lookup-symbol
(lambda (symbol-table offset)
(and symbol-table
- (let ((label (sorted-vector/find-element symbol-table offset)))
+ (let ((label (dbg-labels/find-offset symbol-table offset)))
(and label
- (label-info-name label))))))
+ (dbg-label/name label))))))
(define (external-label-marker? symbol-table offset state)
(if symbol-table
- (sorted-vector/there-exists? symbol-table
- (+ offset 4)
- label-info-external?)
+ (let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
+ (and label
+ (dbg-label/external? label)))
(and *block
(not (eq? state 'INSTRUCTION))
(let loop ((offset (+ offset 4)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.35 1988/12/19 20:56:18 cph Exp $
+$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 $
Copyright (c) 1988 Massachusetts Institute of Technology
((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
'((COMPILER MACROS)
(COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar" 4 35 '()))
\ No newline at end of file
+(add-system! (make-system "Liar" 4 36 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.14 1988/11/08 12:36:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.15 1988/12/30 07:05:20 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(+ (* #x100 min) max))
(define (make-procedure-code-word min max)
- (define (coerce val)
- (cond ((and (not (negative? val))
- (< val 128))
- val)
- ((and (negative? val)
- (> val -128))
- (+ 256 val))
- (else
- (error "make-procedure-code-word: Bad value" val))))
- (make-code-word (coerce min) (coerce max)))
+ ;; The "min" byte must be less than #x80; the "max" byte may not
+ ;; equal #x80 but can take on any other value.
+ (if (or (negative? min) (>= min #x80))
+ (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
+ (if (>= (abs max) #x80)
+ (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
+ (make-code-word min (if (negative? max) (+ #x100 max) max)))
(define expression-code-word
(make-code-word #xff #xff))
(define internal-entry-code-word
(make-code-word #xff #xfe))
-;; This is the same until information is encoded in them
-
-(define continuation-code-word
- (make-code-word #x80 #x80))
+(define (continuation-code-word label)
+ (let ((offset
+ (if label
+ (rtl-continuation/next-continuation-offset (label->object label))
+ 0)))
+ (cond ((not offset)
+ (make-code-word #xff #xfc))
+ ((< offset #x2000)
+ ;; This uses up through (#xff #xdf).
+ (let ((qr (integer-divide offset #x80)))
+ (make-code-word (+ #x80 (integer-divide-remainder qr))
+ (+ #x80 (integer-divide-quotient qr)))))
+ (else
+ (error "Unable to encode continuation offset" offset)))))
\f
;;;; Procedure headers
(define-rule statement
(CONTINUATION-ENTRY (? internal-label))
- (make-external-label continuation-code-word
+ (make-external-label (continuation-code-word internal-label)
internal-label))
(define-rule statement
(CONTINUATION-HEADER (? internal-label))
- (simple-procedure-header continuation-code-word
+ (simple-procedure-header (continuation-code-word internal-label)
internal-label
entry:compiler-interrupt-continuation))
(if (null? assignments) 0 1))
0)
(JSR ,entry:compiler-link)
- ,@(make-external-label continuation-code-word
+ ,@(make-external-label (continuation-code-word false)
(generate-label))))))))))
\f
;;; Local Variables: ***
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.4 1988/08/29 22:56:03 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.5 1988/12/30 07:05:28 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(LAP ,@set-environment
,@clear-map
,(load-constant name (INST-EA (A 1)))
- (JSR ,entry)
- ,@(make-external-label continuation-code-word (generate-label))))))
+ (JSR ,entry)))))
\f
(define-rule statement
(INTERPRETER-CALL:DEFINE (? environment) (? name) (? value))
,@set-value
,@clear-map
,(load-constant name (INST-EA (A 1)))
- (JSR ,entry)
- ,@(make-external-label continuation-code-word
- (generate-label)))))))
+ (JSR ,entry))))))
(define-rule statement
(INTERPRETER-CALL:DEFINE (? environment) (? name)
,@clear-map
(MOV L ,reg:temp (A 2))
,(load-constant name (INST-EA (A 1)))
- (JSR ,entry)
- ,@(make-external-label continuation-code-word
- (generate-label)))))))
+ (JSR ,entry))))))
(define-rule statement
(INTERPRETER-CALL:DEFINE (? environment) (? name)
(MOV B (& ,type) (@A 7))
(MOV L (@A+ 7) (A 2))
,(load-constant name (INST-EA (A 1)))
- (JSR ,entry)
- ,@(make-external-label continuation-code-word (generate-label)))))
+ (JSR ,entry))))
\f
(define-rule statement
(INTERPRETER-CALL:CACHE-REFERENCE (? extension) (? safe?))
,@clear-map
(JSR ,(if safe?
entry:compiler-safe-reference-trap
- entry:compiler-reference-trap))
- ,@(make-external-label continuation-code-word (generate-label))))))
+ entry:compiler-reference-trap))))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) (? value))
(LAP ,@set-extension
,@set-value
,@clear-map
- (JSR ,entry:compiler-assignment-trap)
- ,@(make-external-label continuation-code-word
- (generate-label)))))))
+ (JSR ,entry:compiler-assignment-trap))))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension)
(MOV B (& ,type) ,reg:temp)
,@clear-map
(MOV L ,reg:temp (A 1))
- (JSR ,entry:compiler-assignment-trap)
- ,@(make-external-label continuation-code-word
- (generate-label)))))))
+ (JSR ,entry:compiler-assignment-trap))))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT
,@(clear-map!)
(PEA (@PCR ,(rtl-procedure/external-label (label->object label))))
(MOV B (& ,type) (@A 7)) (MOV L (@A+ 7) (A 1))
- (JSR ,entry:compiler-assignment-trap)
- ,@(make-external-label continuation-code-word (generate-label)))))
+ (JSR ,entry:compiler-assignment-trap))))
(define-rule statement
(INTERPRETER-CALL:CACHE-UNASSIGNED? (? extension))
(let ((clear-map (clear-map!)))
(LAP ,@set-extension
,@clear-map
- (JSR ,entry:compiler-unassigned?-trap)
- ,@(make-external-label continuation-code-word (generate-label))))))
\ No newline at end of file
+ (JSR ,entry:compiler-unassigned?-trap)))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff