;;;; LAP Code Generation
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.20 1986/12/20 22:52:16 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.21 1986/12/20 23:48:34 cph Exp $
(declare (usual-integrations))
(using-syntax (access compiler-syntax-table compiler-package)
\f
+(define *block-start-label*)
(define *code-object-label*)
(define *code-object-entry*)
(define *current-rnode*)
(set! *code-object-entry* rnode)
(cgen-rnode rnode)))
+(define *cgen-rules*
+ '())
+
+(define (add-statement-rule! pattern result-procedure)
+ (set! *cgen-rules*
+ (cons (cons pattern result-procedure)
+ *cgen-rules*))
+ pattern)
+\f
(define (cgen-rnode rnode)
- (define (cgen-right-node next)
- (if (and next (not (node-marked? next)))
- (begin (if (node-previous>1? next)
- (let ((snode (statement->snode '(NOOP))))
- (set-rnode-lap! snode
- (clear-map-instructions
- (rnode-register-map rnode)))
- (node-mark! snode)
- (insert-snode-in-edge! rnode next snode)))
- (cgen-rnode next))))
+ (define (cgen-right-node edge)
+ (let ((next (edge-right-node edge)))
+ (if (and next (not (node-marked? next)))
+ (begin (if (node-previous>1? next)
+ (let ((snode (statement->snode '(NOOP))))
+ (set-rnode-lap! snode
+ (clear-map-instructions
+ (rnode-register-map rnode)))
+ (node-mark! snode)
+ (edge-insert-snode! edge snode)))
+ (cgen-rnode next)))))
(node-mark! rnode)
;; LOOP is for easy restart while debugging.
(let loop ()
(set-rnode-register-map! rnode *register-map*))
(begin (error "CGEN-RNODE: No matching rules" (rnode-rtl rnode))
(loop)))))
- ;; **** Works because of kludge in definition of RTL-SNODE.
- (cgen-right-node (pnode-consequent rnode))
- (cgen-right-node (pnode-alternative rnode)))
-
-(define *cgen-rules*
- '())
-
-(define (add-statement-rule! pattern result-procedure)
- (set! *cgen-rules*
- (cons (cons pattern result-procedure)
- *cgen-rules*))
- pattern)
+ (if (rtl-snode? rnode)
+ (cgen-right-node (snode-next-edge rnode))
+ (begin (cgen-right-node (pnode-consequent-edge rnode))
+ (cgen-right-node (pnode-alternative-edge rnode)))))
(define (rnode-input-register-map rnode)
(if (or (eq? rnode *code-object-entry*)
;;;; Control Flow Graph Abstraction
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.143 1986/12/20 22:51:15 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.144 1986/12/20 23:48:20 cph Exp $
(declare (usual-integrations))
(using-syntax (access compiler-syntax-table compiler-package)
;;;; Previous Connections
(define-integrable (node-previous=0? node)
- (edges=0? (node-previous node)))
+ (edges=0? (node-previous-edges node)))
(define (edges=0? edges)
(cond ((null? edges) true)
(else (edges=0? (cdr edges)))))
(define-integrable (node-previous>0? node)
- (edges>0? (node-previous node)))
+ (edges>0? (node-previous-edges node)))
(define (edges>0? edges)
(cond ((null? edges) false)
(else (edges>0? (cdr edges)))))
(define-integrable (node-previous=1? node)
- (edges=1? (node-previous node)))
+ (edges=1? (node-previous-edges node)))
(define (edges=1? edges)
(if (null? edges)
false
- ((if (entry-holder-hook? (car edges)) edges=1? edges=0?) (cdr edges))))
+ ((if (edge-left-node (car edges)) edges=0? edges=1?) (cdr edges))))
(define-integrable (node-previous>1? node)
- (edges>1? (node-previous node)))
+ (edges>1? (node-previous-edges node)))
(define (edges>1? edges)
(if (null? edges)
false
- ((if (entry-holder-hook? (car edges)) edges>1? edges>0?) (cdr edges))))
+ ((if (edge-left-node (car edges)) edges>0? edges>1?) (cdr edges))))
(define-integrable (node-previous-first node)
(edges-first-node (node-previous-edges node)))
\f
;;;; Noops
-(define noop-node-tag (make-vector-tag cfg-node-tag 'NOOP))
-(define-vector-slots noop-node 1 previous next)
+(define noop-node-tag (make-vector-tag snode-tag 'NOOP))
(define *noop-nodes*)
(define-integrable (make-noop-node)
- (let ((node (vector noop-node-tag '() false)))
+ (let ((node (make-snode noop-node-tag)))
(set! *noop-nodes* (cons node *noop-nodes*))
node))
(define (delete-noop-nodes!)
- (for-each noop-node-delete! *noop-nodes*)
+ (for-each snode-delete! *noop-nodes*)
(set! *noop-nodes* '()))
-(define (noop-node-delete! noop-node)
- (node-next-replace! noop-node
- noop-node-next
- (let ((previous (noop-node-previous noop-node)))
- (hooks-disconnect! previous noop-node)
- previous)))
+(define (constant->pcfg value)
+ ((if value make-true-pcfg make-false-pcfg)))
(define (make-false-pcfg)
(let ((node (make-noop-node)))
(make-pcfg node
'()
- (list (make-hook node set-noop-node-next!)))))
+ (list (make-hook node set-snode-next!)))))
(define (make-true-pcfg)
(let ((node (make-noop-node)))
(make-pcfg node
- (list (make-hook node set-noop-node-next!))
+ (list (make-hook node set-snode-next!))
'())))
-
-(define (constant->pcfg value)
- ((if value make-true-pcfg make-false-pcfg)))
\f
;;;; Miscellaneous
(define-integrable cfg-null? false?)
(define-integrable (snode->scfg snode)
- (node->scfg snode set-snode-next!))
+ (node->scfg snode set-snode-next-edge!))
(define (node->scfg node set-node-next!)
(make-scfg node
(define-integrable (pnode->pcfg pnode)
(node->pcfg pnode
- set-pnode-consequent!
- set-pnode-alternative!))
+ set-pnode-consequent-edge!
+ set-pnode-alternative-edge!))
(define (node->pcfg node set-node-consequent! set-node-alternative!)
(make-pcfg node
;;;; RTL Rules for 68020
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.141 1986/12/18 13:24:11 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.142 1986/12/20 23:49:41 cph Exp $
(declare (usual-integrations))
(using-syntax (access lap-generator-syntax-table compiler-package)
'())
`(,@(make-external-label internal-label)))))
-(define *block-start-label*)
-
(define (make-external-label label)
`((DC W (- ,label ,*block-start-label*))
(LABEL ,label)))
"cfg.bin" ;control flow graph
"ctypes.bin" ;CFG datatypes
"dtypes.bin" ;DFG datatypes
+ "bblock.bin" ;Basic block datatype
"dfg.bin" ;data flow graph
"rtl.bin" ;register transfer language
"emodel.bin" ;environment model
"dflow.bin" ;Dataflow analyzer
)
- (CALL-CONSTRUCTOR-PACKAGE
- "calls.bin" ;Call-sequence constructor
- )
-
(RTL-GENERATOR-PACKAGE
- "cgen.bin" ;RTL generator
+ "rtlgen.bin" ;RTL generator
+ "rgcomb.bin" ;RTL generator: combinations
"linear.bin" ;linearization
)
(define :version)
(define :modification)
- (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.9 1986/12/15 05:48:57 cph Exp $"
+ (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.10 1986/12/20 23:49:57 cph Exp $"
(lambda (filename version date time author state)
(set! :version (car version))
(set! :modification (cadr version))))))
;;;; RTL Generation: Combinations
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.1 1986/12/20 22:53:13 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.2 1986/12/20 23:48:42 cph Exp $
(declare (usual-integrations))
(using-syntax (access compiler-syntax-table compiler-package)
;;;; Reductions
(define (combination:reduction combination offset)
- (fluid-let ((*continuation* false))
- (let ((operator (combination-known-operator combination))
- (block (combination-block combination)))
- (define (choose-generator ic closure stack)
- ((cond ((ic-block? block) ic)
- ((closure-procedure-block? block) closure)
- ((stack-procedure-block? block) stack)
- (else (error "Unknown caller type" block)))
- combination offset))
- (cond ((normal-primitive-constant? operator)
- (choose-generator reduction:ic->primitive
- reduction:closure->primitive
- reduction:stack->primitive))
- ((or (not operator)
- (not (procedure? operator)))
- (choose-generator reduction:ic->unknown
- reduction:closure->unknown
- reduction:stack->unknown))
- ((ic-procedure? operator)
- (choose-generator reduction:ic->ic
- reduction:closure->ic
- reduction:stack->ic))
- ((closure-procedure? operator)
- (choose-generator reduction:ic->closure
- reduction:closure->closure
- reduction:stack->closure))
- ((stack-procedure? operator)
- (choose-generator reduction:ic->stack
- reduction:closure->stack
- (let ((block* (procedure-block operator)))
- (cond ((block-child? block block*)
- reduction:stack->child)
- ((block-sibling? block block*)
- reduction:stack->sibling)
- (else
- reduction:stack->ancestor)))))
- (else (error "Unknown callee type" operator))))))
+ (let ((operator (combination-known-operator combination))
+ (block (combination-block combination)))
+ (define (choose-generator ic closure stack)
+ ((cond ((ic-block? block) ic)
+ ((closure-procedure-block? block) closure)
+ ((stack-procedure-block? block) stack)
+ (else (error "Unknown caller type" block)))
+ combination offset))
+ (cond ((normal-primitive-constant? operator)
+ (choose-generator reduction:ic->primitive
+ reduction:closure->primitive
+ reduction:stack->primitive))
+ ((or (not operator)
+ (not (procedure? operator)))
+ (choose-generator reduction:ic->unknown
+ reduction:closure->unknown
+ reduction:stack->unknown))
+ ((ic-procedure? operator)
+ (choose-generator reduction:ic->ic
+ reduction:closure->ic
+ reduction:stack->ic))
+ ((closure-procedure? operator)
+ (choose-generator reduction:ic->closure
+ reduction:closure->closure
+ reduction:stack->closure))
+ ((stack-procedure? operator)
+ (choose-generator reduction:ic->stack
+ reduction:closure->stack
+ (let ((block* (procedure-block operator)))
+ (cond ((block-child? block block*)
+ reduction:stack->child)
+ ((block-sibling? block block*)
+ reduction:stack->sibling)
+ (else
+ reduction:stack->ancestor)))))
+ (else (error "Unknown callee type" operator)))))
(define (reduction:ic->unknown combination offset)
(make-call:unknown combination offset invocation-prefix:null false))
;;;; RTL Register Lifetime Analysis
;;; Based on the GNU C Compiler
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.53 1986/12/20 22:53:21 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.54 1986/12/20 23:48:53 cph Exp $
(declare (usual-integrations))
(using-syntax (access compiler-syntax-table compiler-package)
(if (rtl:invocation? rtl)
(for-each-regset-member old register-crosses-call!))
(if (instruction-dead? rtl old)
- (rtl-snode-delete! rnode)
+ (snode-delete! rnode)
(begin (update-live-registers! old dead live rtl rnode)
(for-each-regset-member old
increment-register-live-length!))))))
(let ((register (rtl:register-number address)))
(and (pseudo-register? register)
(not (regset-member? needed register))))))))
-
-(define (rtl-snode-delete! rnode)
- (let ((previous (node-previous rnode))
- (next (snode-next rnode))
- (bblock (node-bblock rnode)))
- (snode-delete! rnode)
- (if (eq? rnode (bblock-entry bblock))
- (if (eq? rnode (bblock-exit bblock))
- (set! *bblocks* (delq! bblock *bblocks*))
- (set-bblock-entry! bblock next))
- (if (eq? rnode (bblock-exit bblock))
- (set-bblock-exit! bblock (hook-node (car previous)))))))
\f
(define (mark-set-registers! needed dead rtl rnode)
;; **** This code safely ignores PRE-INCREMENT and POST-INCREMENT
(= (rtl:register-number expression)
register))
(set-expression! (rtl:assign-expression rtl)))))
- (rtl-snode-delete! rnode)
+ (snode-delete! rnode)
(reset-register-n-refs! register)
(reset-register-n-deaths! register)
(reset-register-live-length! register)
projects / mit-scheme.git / commitdiff