#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.2 1987/12/30 06:57:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.3 1988/06/14 08:31:26 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
block))
(define-vector-tag-unparser block-tag
- (lambda (block)
- (write-string "BLOCK")
- (let ((procedure (block-procedure block)))
- (if (and procedure (rvalue/procedure? procedure))
- (begin (write-string " ")
- (write (procedure-label procedure)))))))
+ (lambda (state block)
+ ((standard-unparser
+ "BLOCK" (and (let ((procedure (block-procedure block)))
+ (and procedure (rvalue/procedure? procedure)))
+ (lambda (state block)
+ (unparse-object state
+ (procedure-label (block-procedure block))))))
+ state block)))
(define-integrable (rvalue/block? rvalue)
(eq? (tagged-vector/tag rvalue) block-tag))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.2 1987/12/30 06:58:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.3 1988/06/14 08:31:35 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;; something other than PROCEDURE.
(define (make-continuation block continuation type)
+ continuation
(let ((block (make-block block 'CONTINUATION)))
(let ((required (list (make-value-variable block))))
(set-block-bound-variables! block required)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.2 1987/12/30 06:58:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.3 1988/06/14 08:31:42 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(make-scfg application '())))
(define-vector-tag-unparser application-tag
- (lambda (application)
- (let ((type (application-type application)))
- (cond ((eq? type 'COMBINATION)
- (write-string "COMBINATION"))
- ((eq? type 'RETURN)
- (write-string "RETURN ")
- (write (return/operand application)))
- (else
- (write-string "APPLICATION ")
- (write type))))))
+ (lambda (state application)
+ ((case (application-type application)
+ ((COMBINATION)
+ (standard-unparser "COMBINATION"))
+ ((RETURN)
+ (standard-unparser "RETURN"
+ (lambda (state return)
+ (unparse-object state (return/operand return)))))
+ (else
+ (standard-unparser "APPLICATION" (lambda (state application)
+ (unparse-object state (application-type application))))))
+ state application)))
(define-snode parallel
application-node
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.5 1988/06/03 14:50:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.6 1988/06/14 08:31:51 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(pathname-new-type input-path "brtl")))))
(let ((output-path
(let ((default (pathname-new-type input-path "rtl")))
- (if (unassigned? output-path)
+ (if (default-object? output-path)
default
(merge-pathnames (->pathname output-path) default)))))
(write-instructions
(lambda ()
(with-output-to-file (pathname-new-type (->pathname filename) "rtl")
(lambda ()
- (for-each show-rtl-instruction
- ((access linearize-rtl rtl-generator-package)
- *rtl-graphs*)))))))
+ (for-each show-rtl-instruction (linearize-rtl *rtl-graphs*)))))))
(define (show-rtl rtl)
(pp-instructions
(define (pp-instructions thunk)
(fluid-let ((*show-instruction* pp)
- ((access *pp-primitives-by-name* scheme-pretty-printer) false)
+ (*pp-primitives-by-name* false)
(*unparser-radix* 16))
(thunk)))
(newline))
(*show-instruction* rtl))
\f
-(package (show-fg show-fg-node)
-
(define *procedure-queue*)
(define *procedures*)
-(define-export (show-fg)
+(define (show-fg)
(fluid-let ((*procedure-queue* (make-queue))
(*procedures* '()))
(write-string "\n---------- Expression ----------")
(with-new-node-marks
(lambda ()
(fg/print-entry-node (expression-entry-node *root-expression*))
- (queue-map! *procedure-queue*
+ (queue-map!/unsafe *procedure-queue*
(lambda (procedure)
(if (procedure-continuation? procedure)
(write-string "\n\n---------- Continuation ----------")
(write-string "\n\n---------- Blocks ----------")
(fg/print-blocks (expression-block *root-expression*))))
-(define-export (show-fg-node node)
+(define (show-fg-node node)
(fluid-let ((*procedure-queue* false))
(with-new-node-marks
(lambda ()
(not (memq rvalue *procedures*)))
(begin
(set! *procedures* (cons rvalue *procedures*))
- (enqueue! *procedure-queue* rvalue))))))
+ (enqueue!/unsafe *procedure-queue* rvalue))))))
(define (fg/print-subproblem subproblem)
(fg/print-object subproblem)
(fg/print-rvalue (subproblem-continuation subproblem)))
(let ((prefix (subproblem-prefix subproblem)))
(if (not (cfg-null? prefix))
- (fg/print-node (cfg-entry-node prefix)))))
-
-;;; end SHOW-FG
-)
\ No newline at end of file
+ (fg/print-node (cfg-entry-node prefix)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/enumer.scm,v 4.1 1987/12/04 20:03:52 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/enumer.scm,v 4.2 1988/06/14 08:32:00 cph Rel $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-structure (enumerand
(conc-name enumerand/)
(print-procedure
- (standard-unparser 'ENUMERAND
- (lambda (enumerand)
- (write (enumerand/name enumerand))))))
+ (standard-unparser "ENUMERAND" (lambda (state enumerand)
+ (unparse-object state (enumerand/name enumerand))))))
(enumeration false read-only true)
(name false read-only true)
(index false read-only true))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.5 1988/04/15 02:09:04 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.6 1988/06/14 08:32:14 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(variable-normal-offset variable)))
(define-vector-tag-unparser variable-tag
- (lambda (variable)
- (write-string "VARIABLE ")
- (write (variable-name variable))))
+ (standard-unparser "VARIABLE" (lambda (state variable)
+ (unparse-object state (variable-name variable)))))
(define-integrable (lvalue/variable? lvalue)
(eq? (tagged-vector/tag lvalue) variable-tag))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.4 1987/12/31 10:43:40 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.5 1988/06/14 08:32:22 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
+(define (initialize-package!)
+ (for-each (lambda (entry)
+ (syntax-table-define compiler-syntax-table (car entry)
+ (cadr entry)))
+ `((CFG-NODE-CASE ,transform/cfg-node-case)
+ (DEFINE-ENUMERATION ,transform/define-enumeration)
+ (DEFINE-EXPORT ,transform/define-export)
+ (DEFINE-LVALUE ,transform/define-lvalue)
+ (DEFINE-PNODE ,transform/define-pnode)
+ (DEFINE-ROOT-TYPE ,transform/define-root-type)
+ (DEFINE-RTL-EXPRESSION ,transform/define-rtl-expression)
+ (DEFINE-RTL-PREDICATE ,transform/define-rtl-predicate)
+ (DEFINE-RTL-STATEMENT ,transform/define-rtl-statement)
+ (DEFINE-RULE ,transform/define-rule)
+ (DEFINE-RVALUE ,transform/define-rvalue)
+ (DEFINE-SNODE ,transform/define-snode)
+ (DEFINE-VECTOR-SLOTS ,transform/define-vector-slots)
+ (DESCRIPTOR-LIST ,transform/descriptor-list)
+ (ENUMERATION-CASE ,transform/enumeration-case)
+ (INST ,transform/inst)
+ (INST-EA ,transform/inst-ea)
+ (LAP ,transform/lap)
+ (MAKE-LVALUE ,transform/make-lvalue)
+ (MAKE-PNODE ,transform/make-pnode)
+ (MAKE-RVALUE ,transform/make-rvalue)
+ (MAKE-SNODE ,transform/make-snode)
+ (PACKAGE ,transform/package)))
+ (syntax-table-define lap-generator-syntax-table 'DEFINE-RULE
+ transform/define-rule))
+\f
(define compiler-syntax-table
- (make-syntax-table system-global-syntax-table))
+ (make-syntax-table syntax-table/system-internal))
(define lap-generator-syntax-table
(make-syntax-table compiler-syntax-table))
(define early-syntax-table
(make-syntax-table compiler-syntax-table))
-(syntax-table-define compiler-syntax-table 'PACKAGE
- (in-package system-global-environment
- (declare (usual-integrations))
- (lambda (expression)
- (apply (lambda (names . body)
- (make-sequence
- `(,@(map (lambda (name)
- (make-definition name (make-unassigned-object)))
- names)
- ,(make-combination
- (let ((block (syntax* body)))
- (if (open-block? block)
- (open-block-components block
- (lambda (names* declarations body)
- (make-lambda lambda-tag:let '() '() false
- (list-transform-negative names*
- (lambda (name)
- (memq name names)))
- declarations
- body)))
- (make-lambda lambda-tag:let '() '() false '()
- '() block)))
- '()))))
- (cdr expression)))))
-\f
-(let ()
-
-(define (parse-define-syntax pattern body if-variable if-lambda)
- (cond ((pair? pattern)
- (let loop ((pattern pattern) (body body))
- (cond ((pair? (car pattern))
- (loop (car pattern) `((LAMBDA ,(cdr pattern) ,@body))))
- ((symbol? (car pattern))
- (if-lambda pattern body))
- (else
- (error "Illegal name" (car pattern))))))
- ((symbol? pattern)
- (if-variable pattern body))
- (else
- (error "Illegal name" pattern))))
-
-(define lambda-list->bound-names
- (letrec ((lambda-list->bound-names
- (lambda (lambda-list)
- (cond ((null? lambda-list)
- '())
- ((pair? lambda-list)
- (if (eq? (car lambda-list)
- (access lambda-optional-tag lambda-package))
- (if (pair? (cdr lambda-list))
- (accumulate (cdr lambda-list))
- (error "Missing optional variable" lambda-list))
- (accumulate lambda-list)))
- ((symbol? lambda-list)
- (list lambda-list))
- (else
- (error "Illegal rest variable" lambda-list)))))
- (accumulate
- (lambda (lambda-list)
- (cons (let ((parameter (car lambda-list)))
- (if (pair? parameter) (car parameter) parameter))
- (lambda-list->bound-names (cdr lambda-list))))))
- lambda-list->bound-names))
-\f
-(syntax-table-define compiler-syntax-table 'DEFINE-EXPORT
+(define (transform/package names . body)
+ (make-syntax-closure
+ (make-sequence
+ `(,@(map (lambda (name)
+ (make-definition name (make-unassigned-reference-trap)))
+ names)
+ ,(make-combination
+ (let ((block (syntax* body)))
+ (if (open-block? block)
+ (open-block-components block
+ (lambda (names* declarations body)
+ (make-lambda lambda-tag:let '() '() false
+ (list-transform-negative names*
+ (lambda (name)
+ (memq name names)))
+ declarations
+ body)))
+ (make-lambda lambda-tag:let '() '() false '()
+ '() block)))
+ '())))))
+
+(define transform/define-export
(macro (pattern . body)
(parse-define-syntax pattern body
(lambda (name body)
+ name
`(SET! ,pattern ,@body))
(lambda (pattern body)
`(SET! ,(car pattern)
(NAMED-LAMBDA ,pattern ,@body))))))
-
-(syntax-table-define compiler-syntax-table 'DEFINE-INTEGRABLE
- (macro (pattern . body)
- (if compiler:enable-integration-declarations?
- (parse-define-syntax pattern body
- (lambda (name body)
- `(BEGIN (DECLARE (INTEGRATE ,pattern))
- (DEFINE ,pattern ,@body)))
- (lambda (pattern body)
- `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,(car pattern)))
- (DEFINE ,pattern
- ,@(if (list? (cdr pattern))
- `((DECLARE
- (INTEGRATE
- ,@(lambda-list->bound-names (cdr pattern)))))
- '())
- ,@body))))
- `(DEFINE ,pattern ,@body))))
-
-)
\f
-(syntax-table-define compiler-syntax-table 'DEFINE-VECTOR-SLOTS
+(define transform/define-vector-slots
(macro (class index . slots)
(define (loop slots n)
(if (null? slots)
'*THE-NON-PRINTING-OBJECT*
`(BEGIN ,@(loop slots index)))))
-(syntax-table-define compiler-syntax-table 'DEFINE-ROOT-TYPE
+(define transform/define-root-type
(macro (type . slots)
(let ((tag-name (symbol-append type '-TAG)))
`(BEGIN (DEFINE ,tag-name
(LAMBDA (,type)
(DESCRIPTOR-LIST ,type ,@slots)))))))
-(syntax-table-define compiler-syntax-table 'DESCRIPTOR-LIST
+(define transform/descriptor-list
(macro (type . slots)
(let ((ref-name (lambda (slot) (symbol-append type '- slot))))
`(LIST ,@(map (lambda (slot)
((define-type-definition
(macro (name reserved enumeration)
(let ((parent (symbol-append name '-TAG)))
- `(SYNTAX-TABLE-DEFINE COMPILER-SYNTAX-TABLE
- ',(symbol-append 'DEFINE- name)
+ `(DEFINE ,(symbol-append 'TRANSFORM/DEFINE- name)
(macro (type . slots)
(let ((tag-name (symbol-append type '-TAG)))
`(BEGIN (DEFINE ,tag-name
;;; Kludge to make these compile efficiently.
-(syntax-table-define compiler-syntax-table 'MAKE-SNODE
+(define transform/make-snode
(macro (tag . extra)
`((ACCESS VECTOR ,system-global-environment)
,tag FALSE '() '() FALSE ,@extra)))
-(syntax-table-define compiler-syntax-table 'MAKE-PNODE
+(define transform/make-pnode
(macro (tag . extra)
`((ACCESS VECTOR ,system-global-environment)
,tag FALSE '() '() FALSE FALSE ,@extra)))
-(syntax-table-define compiler-syntax-table 'MAKE-RVALUE
+(define transform/make-rvalue
(macro (tag . extra)
`((ACCESS VECTOR ,system-global-environment)
,tag FALSE ,@extra)))
-(syntax-table-define compiler-syntax-table 'MAKE-LVALUE
+(define transform/make-lvalue
(macro (tag . extra)
(let ((result (generate-uninterned-symbol)))
`(let ((,result
(SET! *LVALUES* (CONS ,result *LVALUES*))
,result))))
\f
+(define transform/define-rtl-expression)
+(define transform/define-rtl-statement)
+(define transform/define-rtl-predicate)
(let ((rtl-common
(lambda (type prefix components wrap-constructor)
`(BEGIN
,@(loop (cdr components)
(* ref-index 2)
(* set-index 2))))))))))
- (syntax-table-define compiler-syntax-table 'DEFINE-RTL-EXPRESSION
- (macro (type prefix . components)
- (rtl-common type prefix components identity-procedure)))
-
- (syntax-table-define compiler-syntax-table 'DEFINE-RTL-STATEMENT
- (macro (type prefix . components)
- (rtl-common type prefix components
- (lambda (expression) `(STATEMENT->SRTL ,expression)))))
-
- (syntax-table-define compiler-syntax-table 'DEFINE-RTL-PREDICATE
- (macro (type prefix . components)
- (rtl-common type prefix components
- (lambda (expression) `(PREDICATE->PRTL ,expression))))))
-\f
-(syntax-table-define compiler-syntax-table 'UCODE-TYPE
- (macro (name)
- (microcode-type name)))
+ (set! transform/define-rtl-expression
+ (macro (type prefix . components)
+ (rtl-common type prefix components identity-procedure)))
+
+ (set! transform/define-rtl-statement
+ (macro (type prefix . components)
+ (rtl-common type prefix components
+ (lambda (expression) `(STATEMENT->SRTL ,expression)))))
-(syntax-table-define compiler-syntax-table 'UCODE-PRIMITIVE
- (macro (name)
- (make-primitive-procedure name)))
+ (set! transform/define-rtl-predicate
+ (macro (type prefix . components)
+ (rtl-common type prefix components
+ (lambda (expression) `(PREDICATE->PRTL ,expression))))))
-(syntax-table-define lap-generator-syntax-table 'DEFINE-RULE
+(define transform/define-rule
(macro (type pattern . body)
(parse-rule pattern body
(lambda (pattern variables qualifier actions)
;; syntax-instruction actually returns a bit-level instruction sequence.
;; Kept separate for clarity and because it does not have to be like that.
-(syntax-table-define compiler-syntax-table 'LAP
+(define transform/lap
(macro some-instructions
(define (handle current remaining)
(let ((processed
`EMPTY-INSTRUCTION-SEQUENCE
(handle (car some-instructions) (cdr some-instructions)))))
-(syntax-table-define compiler-syntax-table 'INST
+(define transform/inst
(macro (the-instruction)
`(LAP:SYNTAX-INSTRUCTION
,(list 'QUASIQUOTE the-instruction))))
;; This is a NOP for now.
-(syntax-table-define compiler-syntax-table 'INST-EA
+(define transform/inst-ea
(macro (ea)
(list 'QUASIQUOTE ea)))
\f
-(syntax-table-define compiler-syntax-table 'DEFINE-ENUMERATION
+(define transform/define-enumeration
(macro (name elements)
(let ((enumeration (symbol-append name 'S)))
`(BEGIN (DEFINE ,enumeration
,body)
body)))))
-(syntax-table-define compiler-syntax-table 'ENUMERATION-CASE
+(define transform/enumeration-case
(macro (name expression . clauses)
(macros/case-macro expression
clauses
(lambda (expression element)
`(EQ? ,expression ,(symbol-append name '/ element)))
(lambda (expression)
+ expression
'()))))
-(syntax-table-define compiler-syntax-table 'CFG-NODE-CASE
+(define transform/cfg-node-case
(macro (expression . clauses)
(macros/case-macro expression
clauses
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.1 1987/12/04 20:04:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.2 1988/06/14 08:32:36 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(let ((root-tag (%make-vector-tag false 'OBJECT false)))
(set-vector-tag-%unparser!
root-tag
- (lambda (object)
- (write (vector-tag-name (tagged-vector/tag object)))))
+ (lambda (state object)
+ (unparse-object state (vector-tag-name (tagged-vector/tag object)))))
(named-lambda (make-vector-tag parent name enumeration)
(let ((tag
(%make-vector-tag (or parent root-tag)
(and enumeration
(enumeration/name->index enumeration
name)))))
- ((access add-unparser-special-object! unparser-package)
- tag
- tagged-vector/unparse)
+ (unparser/set-tagged-vector-method! tag tagged-vector/unparse)
tag))))
(define (define-vector-tag-unparser tag unparser)
(define (tagged-vector? object)
(and (vector? object)
(not (zero? (vector-length object)))
- (let ((tag (tagged-vector/tag object)))
- (or (vector-tag? tag)
- (type-object? tag)))))
+ (vector-tag? (tagged-vector/tag object))))
(define (->tagged-vector object)
- (let ((object (if (integer? object) (unhash object) object))) (and (tagged-vector? object) object)))
+ (let ((object (if (integer? object) (unhash object) object))) (and (or (tagged-vector? object)
+ (named-structure? object))
+ object)))
(define (tagged-vector/predicate tag)
(lambda (object)
(loop (vector-tag-parent tag*))))))))
(define (tagged-vector/description object)
- (if (tagged-vector? object)
- (let ((tag (tagged-vector/tag object)))
- (cond ((vector-tag? tag) (vector-tag-description tag))
- ((type-object? tag) (type-object-description tag))
- (else (error "Unknown vector tag" tag))))
- (error "Not a tagged vector" object)))
+ (cond ((named-structure? object)
+ (named-structure/description object))
+ ((tagged-vector? object)
+ (vector-tag-description (tagged-vector/tag object)))
+ (else
+ (error "Not a tagged vector" object))))
(define (type-object-description type-object)
(2d-get type-object type-object-description))
(2d-put! type-object type-object-description description))
\f
(define (standard-unparser name unparser)
- (lambda (object)
- (unparse-with-brackets
- (lambda ()
- (standard-unparser/prefix object)
- (write name)
- (if unparser
- (begin (write-string " ")
- (unparser object)))))))
-
-(define (tagged-vector/unparse vector)
- (unparse-with-brackets
- (lambda ()
- (standard-unparser/prefix vector)
- (fluid-let ((*unparser-radix* 16))
- ((tagged-vector/unparser vector) vector)))))
-
-(define (standard-unparser/prefix object)
- (if *tagged-vector-unparse-prefix-string*
- (begin (write-string *tagged-vector-unparse-prefix-string*)
- (write-string " ")))
- (if *tagged-vector-unparse-show-hash*
- (begin (write-string (number->string (hash object) 10))
- (write-string " "))))
-
-(define *tagged-vector-unparse-prefix-string* "LIAR")
-(define *tagged-vector-unparse-show-hash* true)
\ No newline at end of file
+ (let ((name (string-append "LIAR " name))) (if unparser
+ (unparser/standard-method name unparser)
+ (unparser/standard-method name))))
+
+(define (tagged-vector/unparse state vector)
+ (fluid-let ((*unparser-radix* 16))
+ ((tagged-vector/unparser vector) state vector)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmerly.scm,v 1.6 1987/08/25 02:18:38 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmerly.scm,v 1.7 1988/06/14 08:32:44 cph Rel $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;;; Very Simple Pattern Matcher: Early rule compilation and lookup
(declare (usual-integrations))
-
-;;; Exports
-
-(define early-parse-rule)
-(define early-pattern-lookup)
-(define early-make-rule)
-(define make-database-transformer)
-(define make-symbol-transformer)
-(define make-bit-mask-transformer)
-
-(let ()
\f
;;;; Database construction
-(define-export (early-make-rule pattern variables body)
+(define (early-make-rule pattern variables body)
(list pattern variables body))
-(define-export (early-parse-rule pattern receiver)
+(define (early-parse-rule pattern receiver)
(extract-variables pattern receiver))
(define (extract-variables pattern receiver)
\f
;;;; Early rule processing and code compilation
-(define-export (early-pattern-lookup
- rules instance #!optional transformers unparsed receiver limit)
- (if (unassigned? limit) (set! limit *rule-limit*))
- (if (or (unassigned? receiver) (null? receiver))
+(define (early-pattern-lookup rules instance #!optional transformers unparsed
+ receiver limit)
+ (if (default-object? limit) (set! limit *rule-limit*))
+ (if (or (default-object? receiver) (null? receiver))
(set! receiver
(lambda (result code)
(cond ((false? result)
(scode/make-block bindings '() program)
false)))
(fluid-let ((*rule-limit* limit)
- (*transformers* (if (unassigned? transformers)
+ (*transformers* (if (default-object? transformers)
'()
transformers)))
(try-rules rules expression
(scode/make-error-combination
"early-pattern-lookup: No pattern matches"
- (if (or (unassigned? unparsed) (null? unparsed))
+ (if (or (default-object? unparsed) (null? unparsed))
(scode/make-constant instance)
unparsed))
list))))))
((eq? result 'MAYBE)
(let ((var (make-variable-name 'TRY-NEXT-RULE-)))
(loop (cdr rules)
- (scode/make-combination (scode/make-variable var) '())
+ (scode/make-combination (scode/make-variable var)
+ '())
(cons (cons var code)
bindings)
(1+ nrules))))
(receiver 'MAYBE
(scode/make-letrec
(map (lambda (pair)
- (scode/make-binding (car pair)
- (scode/make-thunk (cdr pair))))
+ (scode/make-binding
+ (car pair)
+ (scode/make-thunk (cdr pair))))
bindings)
null-form)))))
(loop rules null-form '() 0))
(build-comparison (cdr evaluation)
(cdar evaluation)
(lambda (new-test new-bindings)
- (process-evaluations (cdr evaluations)
- (scode/merge-tests new-test test)
- (append new-bindings bindings)
- receiver))))))
+ (process-evaluations
+ (cdr evaluations)
+ (scode/merge-tests new-test test)
+ (append new-bindings bindings)
+ receiver))))))
\f
;;;; Early variable processing
(merge-path path expression))
(append car-bindings cdr-bindings))))))))))))))
- (walk pattern '() expression (lambda (pure? test bindings)
- (receiver test bindings))))
+ (walk pattern '() expression
+ (lambda (pure? test bindings)
+ pure?
+ (receiver test bindings))))
;;; car/cdr decomposition
(scode/merge-tests car-test cdr-test))
(combination-components car-test
(lambda (car-operator car-operands)
+ car-operator
(combination-components cdr-test
(lambda (cdr-operator cdr-operands)
+ cdr-operator
(scode/make-absolute-combination 'EQUAL?
(list
(scode/make-constant
(cond ((null? info)
(receiver step expression))
((null? (cadr info))
- (receiver step (scode/make-absolute-combination path (list expression))))
+ (receiver step
+ (scode/make-absolute-combination path (list expression))))
(else
(receiver (if (eq? step 'CAR) (caadr info) (cdadr info))
expression)))))
\f
;;;; Database transformers
-(define-export (make-database-transformer database)
+(define (make-database-transformer database)
(lambda (texp name rename exp receiver)
(let ((null-form
(scode/make-constant (generate-uninterned-symbol 'NOT-FOUND-))))
(scode/let-components
code
(lambda (names values decls body)
- (and (not (null? names))
- (let ((place (assq 'INTEGRATE decls)))
- (and (not (null? place))
- (let ((integrated (cdr place)))
- (let loop ((left names))
- (cond ((null? left)
- (can-integrate? body))
- ((memq (car left) integrated)
- (loop (cdr left)))
- (else false)))))))))))
+ values
+ (and (not (null? names))
+ (let ((place (assq 'INTEGRATE decls)))
+ (and (not (null? place))
+ (let ((integrated (cdr place)))
+ (let loop ((left names))
+ (cond ((null? left)
+ (can-integrate? body))
+ ((memq (car left) integrated)
+ (loop (cdr left)))
+ (else false)))))))))))
(define-integrable (make-simple-transformer-test name tag)
(scode/make-absolute-combination 'NOT
\f
;;;; Symbol transformers
-(define-export (make-symbol-transformer alist)
+(define (make-symbol-transformer alist)
(lambda (texp name rename exp receiver)
+ texp
(cond ((null? alist)
(receiver false false))
((symbol? exp)
\f
;;;; Accumulation transformers
-(define-export (make-bit-mask-transformer size alist)
+(define (make-bit-mask-transformer size alist)
(lambda (texp name rename exp receiver)
(cond ((null? alist)
(transformer-fail receiver))
(scode/combination-components
obj
(lambda (operator operands)
+ operands
(and (scode/lambda? operator)
(scode/lambda-components
operator
(lambda (name . ignore)
+ ignore
(eq? name lambda-tag:let))))))))
(define (scode/make-let names values declarations body)
(lambda (operator values)
(scode/lambda-components operator
(lambda (tag names opt rest aux decls body)
+ tag opt rest aux
(receiver names values decls body))))))
\f
;;;; Scode utilities (continued)
(scode/make-let
(map scode/binding-variable bindings)
(make-list (length bindings)
- (scode/make-unassigned-object))
+ (make-unassigned-reference-trap))
'()
(scode/make-sequence
(map* body
(cons evaluation-tag name))
(define-integrable (evaluation-expression exp)
- (cdr exp))
-
-;; End of early rule parsing package
-)
\ No newline at end of file
+ (cdr exp))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmlook.scm,v 1.5 1987/07/08 21:53:09 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmlook.scm,v 1.6 1988/06/14 08:32:58 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
-(define pattern-lookup)
-(define pattern-variables)
-(define make-pattern-variable)
-(define pattern-variable?)
-(define pattern-variable-name)
-
-(let ((pattern-variable-tag (make-named-tag "Pattern Variable")))
+(define pattern-variable-tag
+ (make-named-tag "Pattern Variable"))
;;; PATTERN-LOOKUP returns either false or a pair whose car is the
;;; item matched and whose cdr is the list of variable values. Use
;;; PATTERN-VARIABLES to get a list of names that is in the same order
;;; as the list of values.
-(set! pattern-lookup
- (named-lambda (pattern-lookup entries instance)
- (define (lookup-loop entries values)
- (define (match pattern instance)
- (if (pair? pattern)
- (if (eq? (car pattern) pattern-variable-tag)
- (let ((entry (memq (cdr pattern) values)))
- (if entry
- (eqv? (cdr entry) instance)
- (begin (set! values (cons instance values))
- true)))
- (and (pair? instance)
- (match (car pattern) (car instance))
- (match (cdr pattern) (cdr instance))))
- (eqv? pattern instance)))
- (and (not (null? entries))
- (or (and (match (caar entries) instance)
- (pattern-lookup/bind (cdar entries) values))
- (lookup-loop (cdr entries) '()))))
- (lookup-loop entries '())))
-
-(define (pattern-lookup/bind binder values)
+(define (pattern-lookup entries instance)
+ (define (lookup-loop entries values)
+ (define (match pattern instance)
+ (if (pair? pattern)
+ (if (eq? (car pattern) pattern-variable-tag)
+ (let ((entry (memq (cdr pattern) values)))
+ (if entry
+ (eqv? (cdr entry) instance)
+ (begin (set! values (cons instance values))
+ true)))
+ (and (pair? instance)
+ (match (car pattern) (car instance))
+ (match (cdr pattern) (cdr instance))))
+ (eqv? pattern instance)))
+ (and (not (null? entries))
+ (or (and (match (caar entries) instance)
+ (pattern-lookup/bind (cdar entries) values))
+ (lookup-loop (cdr entries) '()))))
+ (lookup-loop entries '()))
+
+(define-integrable (pattern-lookup/bind binder values)
(apply binder values))
-(set! pattern-variables
- (named-lambda (pattern-variables pattern)
- (let ((variables '()))
- (define (loop pattern)
- (if (pair? pattern)
- (if (eq? (car pattern) pattern-variable-tag)
- (if (not (memq (cdr pattern) variables))
- (set! variables (cons (cdr pattern) variables)))
- (begin (loop (car pattern))
- (loop (cdr pattern))))))
- (loop pattern)
- variables)))
-
-(set! make-pattern-variable
- (named-lambda (make-pattern-variable name)
- (cons pattern-variable-tag name)))
-
-(set! pattern-variable?
- (named-lambda (pattern-variable? obj)
- (and (pair? obj) (eq? (car obj) pattern-variable-tag))))
-
-(set! pattern-variable-name
- (named-lambda (pattern-variable-name var)
- (cdr var)))
-
-)
-
-;;; ALL-TRUE? is used to determine if splicing variables with
-;;; qualifiers satisfy the qualification.
-
-(define (all-true? values)
- (or (null? values)
- (and (car values)
- (all-true? (cdr values)))))
\ No newline at end of file
+(define (pattern-variables pattern)
+ (let ((variables '()))
+ (define (loop pattern)
+ (if (pair? pattern)
+ (if (eq? (car pattern) pattern-variable-tag)
+ (if (not (memq (cdr pattern) variables))
+ (set! variables (cons (cdr pattern) variables)))
+ (begin (loop (car pattern))
+ (loop (cdr pattern))))))
+ (loop pattern)
+ variables))
+
+(define-integrable (make-pattern-variable name)
+ (cons pattern-variable-tag name))
+
+(define (pattern-variable? object)
+ (and (pair? object)
+ (eq? (car object) pattern-variable-tag)))
+
+(define-integrable (pattern-variable-name var)
+ (cdr var))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmpars.scm,v 1.2 1987/07/08 21:53:25 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmpars.scm,v 1.3 1988/06/14 08:33:06 cph Rel $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;; arguments, will return either false, indicating that the
;;; qualifications failed, or the result of the body.
-(define rule-result-expression)
-(define parse-rule)
-
-(let ()
-\f
-(set! parse-rule
- (named-lambda (parse-rule pattern body receiver)
- (extract-variables
- pattern
- (lambda (pattern variables)
- (extract-qualifier
- body
- (lambda (qualifiers actions)
- (let ((names (pattern-variables pattern)))
- (receiver pattern
- (reorder-variables variables names)
- qualifiers
- actions))))))))
+(define (parse-rule pattern body receiver)
+ (extract-variables
+ pattern
+ (lambda (pattern variables)
+ (extract-qualifier
+ body
+ (lambda (qualifiers actions)
+ (let ((names (pattern-variables pattern)))
+ (receiver pattern
+ (reorder-variables variables names)
+ qualifiers
+ actions)))))))
(define (extract-variables pattern receiver)
(if (pair? pattern)
(cons (car x)
(merge-variables-lists (cdr x)
y)))))))
-
+\f
(define (extract-qualifier body receiver)
(if (and (pair? (car body))
(eq? (caar body) 'QUALIFIER))
(define (reorder-variables variables names)
(map (lambda (name) (assq name variables))
names))
-\f
-(set! rule-result-expression
- (named-lambda (rule-result-expression variables qualifiers body)
- (let ((body `(lambda () ,body)))
- (process-transformations variables
- (lambda (outer-vars inner-vars xforms xqualifiers)
- (if (null? inner-vars)
- `(lambda ,outer-vars
- ,(if (null? qualifiers)
- body
- `(and ,@qualifiers ,body)))
- `(lambda ,outer-vars
- (let ,(map list inner-vars xforms)
- (and ,@xqualifiers
- ,@qualifiers
- ,body)))))))))
+
+(define (rule-result-expression variables qualifiers body)
+ (let ((body `(lambda () ,body)))
+ (process-transformations variables
+ (lambda (outer-vars inner-vars xforms xqualifiers)
+ (if (null? inner-vars)
+ `(lambda ,outer-vars
+ ,(if (null? qualifiers)
+ body
+ `(and ,@qualifiers ,body)))
+ `(lambda ,outer-vars
+ (let ,(map list inner-vars xforms)
+ (and ,@xqualifiers
+ ,@qualifiers
+ ,body))))))))
(define (process-transformations variables receiver)
(if (null? variables)
(receiver '() '() '() '())
- (process-transformations
- (cdr variables)
- (lambda (outer inner xform qual)
- (let ((name (caar variables))
- (variable (cdar variables)))
- (cond ((null? variable)
- (receiver (cons name outer)
- inner
- xform
- qual))
- ((not (null? (cdr variable)))
- (error "process-trasformations: Multiple qualifiers"
- (car variables)))
- (else
- (let ((var (car variable)))
- (define (handle-xform rename)
- (if (eq? (car var) '?)
- (receiver (cons rename outer)
- (cons name inner)
- (cons `(,(cadr var) ,rename)
- xform)
- (cons name qual))
- (receiver (cons rename outer)
- (cons name inner)
- (cons `(MAP ,(cadr var) ,rename)
- xform)
- (cons `(ALL-TRUE? ,name) qual))))
- (handle-xform
- (if (null? (cddr var))
- name
- (caddr var)))))))))))
-
-;; End of PARSE-RULE environment.
-)
\ No newline at end of file
+ (process-transformations (cdr variables)
+ (lambda (outer inner xform qual)
+ (let ((name (caar variables))
+ (variable (cdar variables)))
+ (cond ((null? variable)
+ (receiver (cons name outer)
+ inner
+ xform
+ qual))
+ ((not (null? (cdr variable)))
+ (error "process-trasformations: Multiple qualifiers"
+ (car variables)))
+ (else
+ (let ((var (car variable)))
+ (define (handle-xform rename)
+ (if (eq? (car var) '?)
+ (receiver (cons rename outer)
+ (cons name inner)
+ (cons `(,(cadr var) ,rename)
+ xform)
+ (cons name qual))
+ (receiver (cons rename outer)
+ (cons name inner)
+ (cons `(MAP ,(cadr var) ,rename)
+ xform)
+ (cons `(APPLY BOOLEAN/AND ,name) qual))))
+ (handle-xform
+ (if (null? (cddr var))
+ name
+ (caddr var)))))))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.4 1988/04/15 02:09:17 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.5 1988/06/14 08:33:14 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
procedure))
(define-vector-tag-unparser procedure-tag
- (lambda (procedure)
- (let ((type
- (enumeration/index->name continuation-types
- (procedure-type procedure))))
- (if (eq? type 'PROCEDURE)
- (begin
- (write-string "PROCEDURE ")
- (write (procedure-label procedure)))
- (begin
- (write (procedure-label procedure))
- (write-string " ")
- (write type))))))
+ (lambda (state procedure)
+ ((let ((type
+ (enumeration/index->name continuation-types
+ (procedure-type procedure))))
+ (if (eq? type 'PROCEDURE)
+ (standard-unparser "PROCEDURE"
+ (lambda (state procedure)
+ (unparse-object state (procedure-label procedure))))
+ (standard-unparser (symbol->string (procedure-label procedure))
+ (lambda (state procedure)
+ procedure
+ (unparse-object state type)))))
+ state procedure)))
(define-integrable (rvalue/procedure? rvalue)
(eq? (tagged-vector/tag rvalue) procedure-tag))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 4.2 1987/12/31 10:01:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 4.3 1988/06/14 08:33:23 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
constant))))
(define-vector-tag-unparser constant-tag
- (lambda (constant)
- (write-string "CONSTANT ")
- (write (constant-value constant))))
+ (standard-unparser "CONSTANT"
+ (lambda (state constant)
+ (unparse-object state (constant-value constant)))))
(define-integrable (rvalue/constant? rvalue)
(eq? (tagged-vector/tag rvalue) constant-tag))
(make-rvalue reference-tag block lvalue safe?))
(define-vector-tag-unparser reference-tag
- (lambda (reference)
- (write-string "REFERENCE ")
- (write (variable-name (reference-lvalue reference)))))
+ (standard-unparser "REFERENCE"
+ (lambda (state reference)
+ (unparse-object state (variable-name (reference-lvalue reference))))))
(define-integrable (rvalue/reference? rvalue)
(eq? (tagged-vector/tag rvalue) reference-tag))
(make-rvalue unassigned-test-tag block lvalue))
(define-vector-tag-unparser unassigned-test-tag
- (lambda (unassigned-test)
- (write-string "UNASSIGNED-TEST ")
- (write (unassigned-test-lvalue unassigned-test))))
+ (standard-unparser "UNASSIGNED-TEST" (lambda (state unassigned-test)
+ (unparse-object state (unassigned-test-lvalue unassigned-test)))))
(define-integrable (rvalue/unassigned-test? rvalue)
(eq? (tagged-vector/tag rvalue) unassigned-test-tag))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.3 1988/04/15 02:09:29 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.4 1988/06/14 08:33:30 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
make-delay delay? delay-components
delay-expression
make-disjunction disjunction? disjunction-components
- conditional-predicate conditional-alternative
+ disjunction-predicate disjunction-alternative
make-in-package in-package? in-package-components
in-package-environment in-package-expression
make-lambda lambda? lambda-components
make-sequence sequence-actions sequence-components
symbol?
make-the-environment the-environment?
- make-unassigned-object unassigned-object?
make-unassigned? unassigned?? unassigned?-name
- make-unbound? unbound?? unbound?-name
make-variable variable? variable-components variable-name
))
\f
;;;; Absolute variables and combinations
-(define (scode/make-absolute-reference variable-name)
+(define-integrable (scode/make-absolute-reference variable-name)
(scode/make-access '() variable-name))
(define (scode/absolute-reference? object)
(and (scode/access? object)
(null? (scode/access-environment object))))
-(define (scode/absolute-reference-name reference)
+(define-integrable (scode/absolute-reference-name reference)
(scode/access-name reference))
-(define (scode/make-absolute-combination name operands)
+(define-integrable (scode/make-absolute-combination name operands)
(scode/make-combination (scode/make-absolute-reference name) operands))
(define (scode/absolute-combination? object)
(and (scode/combination? object)
(scode/absolute-reference? (scode/combination-operator object))))
+(define-integrable (scode/absolute-combination-name combination)
+ (scode/absolute-reference-name (scode/combination-operator combination)))
+
+(define-integrable (scode/absolute-combination-operands combination)
+ (scode/combination-operands combination))
+
(define (scode/absolute-combination-components combination receiver)
- (scode/combination-components combination
- (lambda (operator operands)
- (receiver (scode/absolute-reference-name operator) operands))))
+ (receiver (scode/absolute-combination-name combination)
+ (scode/absolute-combination-operands combination)))
-(define scode/error-combination?
- (type-object-predicate error-combination-type))
+(define (scode/error-combination? object)
+ (or (and (scode/combination? object)
+ (eq? (scode/combination-operator object) error-procedure))
+ (and (scode/absolute-combination? object)
+ (eq? (scode/absolute-combination-name object) 'ERROR-PROCEDURE))))
(define (scode/error-combination-components combination receiver)
(scode/combination-components combination
(lambda (operator operands)
- (receiver (car operands)
- (let ((irritant (cadr operands)))
- (cond ((scode/access? irritant) '())
- ((scode/absolute-combination? irritant)
- (scode/absolute-combination-components irritant
- (lambda (name operands)
- (if (eq? name 'LIST)
- operands
- (list irritant)))))
- (else (list irritant))))))))
+ operator
+ (receiver
+ (car operands)
+ (let loop ((irritants (cadr operands)))
+ (cond ((null? irritants) '())
+ ((and (scode/absolute-combination? irritants)
+ (eq? (scode/absolute-combination-name irritants) 'LIST))
+ (scode/absolute-combination-operands irritants))
+ ((and (scode/combination? irritants)
+ (eq? (scode/combination-operator irritants) cons))
+ (let ((operands (scode/combination-operands irritants)))
+ (cons (car operands)
+ (loop (cadr operands)))))
+ (else
+ (error "Illegal irritants" (cadr operands)))))))))
(define (scode/make-error-combination message operand)
(scode/make-absolute-combination
'ERROR-PROCEDURE
- (list message operand (scode/make-the-environment))))
\ No newline at end of file
+ (list message
+ (scode/make-combination cons (list operand '()))
+ (scode/make-the-environment))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/subprb.scm,v 4.2 1987/12/30 06:59:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/subprb.scm,v 4.3 1988/06/14 08:33:38 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(constructor virtual-continuation/%make (block parent type))
(conc-name virtual-continuation/)
(print-procedure
- (standard-unparser 'VIRTUAL-CONTINUATION
- (lambda (continuation)
+ (standard-unparser "VIRTUAL-CONTINUATION" (lambda (state continuation)
(let ((type (virtual-continuation/type continuation)))
(if type
- (write
+ (unparse-object
+ state
(enumeration/index->name continuation-types
type))))))))
block
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.4 1988/04/15 02:09:42 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.5 1988/06/14 08:33:44 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.6 1988/04/15 02:09:53 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.7 1988/06/14 08:33:51 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(compiler:reset!)
(let* ((topl (thunk))
(value
- ((access generate-top-level-object
- debugging-information-package)
- topl *recursive-compilation-results*)))
+ (generate-top-level-object topl *recursive-compilation-results*)))
(if (not compiler:preserve-data-structures?)
(compiler:reset!))
(compiler-time-report "Total compilation time"
(lambda (source-file)
(let ((scode-file
(merge-pathnames
- (make-pathname false false false "bin" false)
+ (make-pathname false false false false "bin" false)
(->pathname source-file))))
;; Maybe this should be done only if scode-file
;; does not exist or is older than source-file.
(sf source-file scode-file)
(newline)
- (if (unassigned? output)
+ (if (default-object? output)
(compile-bin-file scode-file)
(compile-bin-file scode-file output))))))
(if (pair? input)
(define (compile-bin-file input-string #!optional output-string)
(compiler-pathnames input-string
- (and (not (unassigned? output-string)) output-string)
- (make-pathname false false false "bin" 'NEWEST)
+ (and (not (default-object? output-string)) output-string)
+ (make-pathname false false false false "bin" 'NEWEST)
(lambda (input-pathname output-pathname)
(compile-scode (compiler-fasload input-pathname)
(and compiler:generate-rtl-files?
(define compiler:abort-continuation)
(define (compiler:batch-compile input #!optional output)
- (fluid-let ((compiler:batch-mode? true)
- ((access *error-hook* error-system)
- (lambda (env mesg irr subst?)
- (if compiler:abort-handled?
- (begin
- (newline)
- (newline)
- (display "*** Error: ")
- (display mesg)
- (display " ***")
- (newline)
- (display "Irritant: ")
- (write irr)
- (compiler:abort false))
- ((access standard-error-hook error-system)
- env mesg irr subst?)))))
- (if (unassigned? output)
- (compile-bin-file input)
- (compile-bin-file input output))))
+ (fluid-let ((compiler:batch-mode? true))
+ (bind-condition-handler '() compiler:batch-error-handler
+ (lambda ()
+ (if (default-object? output)
+ (compile-bin-file input)
+ (compile-bin-file input output))))))
+
+(define (compiler:batch-error-handler condition)
+ (and (condition/error? condition)
+ (begin (apply warn
+ (condition/message condition)
+ (condition/irritants condition))
+ (compiler:abort false))))
(define (compiler:abort value)
(if compiler:abort-handled?
info-output-pathname
wrapper)
- (if (unassigned? rtl-output-pathname)
+ (if (default-object? rtl-output-pathname)
(set! rtl-output-pathname false))
- (if (unassigned? info-output-pathname)
+ (if (default-object? info-output-pathname)
(set! info-output-pathname false))
(fluid-let ((*info-output-pathname*
(not (eq? rtl-output-pathname true)))
rtl-output-pathname
*rtl-output-pathname*)))
- ((if (unassigned? wrapper)
+ ((if (default-object? wrapper)
in-compiler
wrapper)
(lambda ()
(define (phase/canonicalize-scode)
(compiler-subphase "Canonicalizing Scode"
(lambda ()
- (set! *scode*
- ((access canonicalize/top-level fg-generator-package)
- (last-reference *input-scode*))))))
+ (set! *scode* (canonicalize/top-level (last-reference *input-scode*))))))
(define (phase/translate-scode)
(compiler-subphase "Translating Scode into Flow Graph"
(set! *applications* '())
(set! *parallels* '())
(set! *assignments* '())
- (set! *root-expression*
- ((access construct-graph fg-generator-package)
- (last-reference *scode*)))
+ (set! *root-expression* (construct-graph (last-reference *scode*)))
(set! *root-block* (expression-block *root-expression*))
(if (or (null? *expressions*)
(not (null? (cdr *expressions*))))
(define (phase/simulate-application)
(compiler-subphase "Simulating Applications"
(lambda ()
- ((access simulate-application fg-optimizer-package)
- *lvalues*
- *applications*))))
+ (simulate-application *lvalues* *applications*))))
\f
(define (phase/outer-analysis)
(compiler-subphase "Outer Analysis"
(lambda ()
- ((access outer-analysis fg-optimizer-package)
- *root-expression*
- *procedures*
- *applications*))))
+ (outer-analysis *root-expression* *procedures* *applications*))))
(define (phase/fold-constants)
(compiler-subphase "Constant Folding"
(lambda ()
- ((access fold-constants fg-optimizer-package)
- *lvalues*
- *applications*))))
+ (fold-constants *lvalues* *applications*))))
(define (phase/open-coding-analysis)
(compiler-subphase "Open Coding Analysis"
(lambda ()
- ((access open-coding-analysis rtl-generator-package)
- *applications*))))
+ (open-coding-analysis *applications*))))
(define (phase/operator-analysis)
(compiler-subphase "Operator Analysis"
(lambda ()
- ((access operator-analysis fg-optimizer-package)
- *procedures*
- *applications*))))
+ (operator-analysis *procedures* *applications*))))
(define (phase/identify-closure-limits)
(compiler-subphase "Identifying Closure Limits"
(lambda ()
- ((access identify-closure-limits! fg-optimizer-package)
- *procedures*
- *applications*
- *assignments*))))
+ (identify-closure-limits! *procedures* *applications* *assignments*))))
(define (phase/setup-block-types)
(compiler-subphase "Setting Up Block Types"
(lambda ()
- ((access setup-block-types! fg-optimizer-package)
- *root-block*))))
+ (setup-block-types! *root-block*))))
(define (phase/continuation-analysis)
(compiler-subphase "Continuation Analysis"
(lambda ()
- ((access continuation-analysis fg-optimizer-package)
- *blocks*))))
+ (continuation-analysis *blocks*))))
(define (phase/simplicity-analysis)
(compiler-subphase "Simplicity Analysis"
(lambda ()
- ((access simplicity-analysis fg-optimizer-package)
- *parallels*))))
+ (simplicity-analysis *parallels*))))
\f
(define (phase/subproblem-ordering)
(compiler-subphase "Ordering Subproblems"
(lambda ()
- ((access subproblem-ordering fg-optimizer-package)
- *parallels*))))
+ (subproblem-ordering *parallels*))))
(define (phase/connectivity-analysis)
(compiler-subphase "Connectivity Analysis"
(lambda ()
- ((access connectivity-analysis fg-optimizer-package)
- *root-expression*
- *procedures*))))
+ (connectivity-analysis *root-expression* *procedures*))))
(define (phase/design-environment-frames)
(compiler-subphase "Designing Environment Frames"
(lambda ()
- ((access design-environment-frames! fg-optimizer-package)
- *blocks*))))
+ (design-environment-frames! *blocks*))))
(define (phase/compute-node-offsets)
(compiler-subphase "Computing Node Offsets"
(lambda ()
- ((access compute-node-offsets fg-optimizer-package)
- *root-expression*))))
+ (compute-node-offsets *root-expression*))))
(define (phase/fg-optimization-cleanup)
(compiler-subphase "Cleaning Up After Flow Graph Optimization"
(set! *rtl-graphs* '())
(set! *ic-procedure-headers* '())
(initialize-machine-register-map!)
- ((access generate/top-level rtl-generator-package)
- (last-reference *root-expression*))
+ (generate/top-level (last-reference *root-expression*))
(set! label->object
(make/label->object *rtl-expression*
*rtl-procedures*
(define (phase/common-subexpression-elimination)
(compiler-subphase "Eliminating Common Subexpressions"
(lambda ()
- ((access common-subexpression-elimination rtl-cse-package)
- *rtl-graphs*))))
+ (common-subexpression-elimination *rtl-graphs*))))
\f(define (phase/lifetime-analysis)
(compiler-subphase "Lifetime Analysis"
(lambda ()
- ((access lifetime-analysis rtl-optimizer-package) *rtl-graphs*))))
+ (lifetime-analysis *rtl-graphs*))))
(define (phase/code-compression)
(compiler-subphase "Code Compression"
(lambda ()
- ((access code-compression rtl-optimizer-package) *rtl-graphs*))))
+ (code-compression *rtl-graphs*))))
(define (phase/rtl-file-output pathname)
(compiler-phase "RTL File Output"
(lambda ()
- (let ((lin ((access linearize-rtl rtl-generator-package) *rtl-graphs*)))
+ (let ((rtl (linearize-rtl *rtl-graphs*)))
(if (eq? pathname true)
;; recursive compilation
(set! *recursive-compilation-rtl-blocks*
- (cons (cons *recursive-compilation-number* lin)
+ (cons (cons *recursive-compilation-number* rtl)
*recursive-compilation-rtl-blocks*))
(fasdump (if (null? *recursive-compilation-rtl-blocks*)
- lin
+ rtl
(list->vector
- (cons (cons 0 lin) *recursive-compilation-rtl-blocks*)))
+ (cons (cons 0 rtl)
+ *recursive-compilation-rtl-blocks*)))
pathname))))))
(define (phase/register-allocation)
(compiler-subphase "Allocating Registers"
(lambda ()
- ((access register-allocation rtl-optimizer-package) *rtl-graphs*))))
+ (register-allocation *rtl-graphs*))))
(define (phase/rtl-optimization-cleanup)
(if (not compiler:preserve-data-structures?)
(compiler-phase "Generating BITs"
(lambda ()
(set! compiler:external-labels '())
- ((access generate-bits lap-syntax-package)
+ (generate-bits
*rtl-graphs*
(lambda (block-label prefix)
(set! compiler:block-label block-label)
(lambda ()
(set! compiler:bits
(append-instruction-sequences!
- (lap:make-entry-point compiler:entry-label
- compiler:block-label)
- ((access linearize-bits lap-syntax-package)
- (last-reference *rtl-graphs*)))))))
+ (lap:make-entry-point compiler:entry-label compiler:block-label)
+ (linearize-bits (last-reference *rtl-graphs*)))))))
(define (phase/assemble)
(compiler-phase "Assembling"
(lambda ()
(if compiler:preserve-data-structures?
- ((access assemble bit-package)
- compiler:block-label
- compiler:bits
- phase/assemble-finish)
- ((access assemble bit-package)
- (set! compiler:block-label)
- (set! compiler:bits)
- phase/assemble-finish)))))
+ (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
(compiler-phase "Generating Debugging Information (pass 2)"
(lambda ()
(let ((info
- ((access generation-phase2 debugging-information-package)
- compiler:label-bindings
- (last-reference compiler:external-labels))))
+ (generation-phase2 compiler:label-bindings
+ (last-reference compiler:external-labels))))
(if (eq? pathname true) ; recursive compilation
(begin
(cons (pathname->string *info-output-pathname*)
*recursive-compilation-number*)))
(begin
- (fasdump ((access generate-top-level-info
- debugging-information-package)
- info *recursive-compilation-results*)
- pathname)
+ (fasdump
+ (generate-top-level-info info *recursive-compilation-results*)
+ pathname)
(set-compiled-code-block/debugging-info!
compiler:code-vector
(pathname->string pathname))))))))
(map (lambda (label)
(cons
label
- (with-interrupt-mask interrupt-mask-none
- (lambda (old)
- old ;; ignored
- ((ucode-primitive &make-object)
- type-code:compiled-entry
- (make-non-pointer-object
- (+ (cdr (or (assq label compiler:label-bindings)
- (error "Missing entry point" label)))
- (primitive-datum compiler:code-vector))))))))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ ((ucode-primitive &make-object)
+ type-code:compiled-entry
+ (make-non-pointer-object
+ (+ (cdr (or (assq label compiler:label-bindings)
+ (error "Missing entry point" label)))
+ (object-datum compiler:code-vector))))))))
compiler:entry-points)))
(let ((label->expression
(lambda (label)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.4 1988/04/15 02:10:18 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.5 1988/06/14 08:34:06 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(loop (cdr items) passed (cons (car items) failed))))))
(define (generate-label #!optional prefix)
- (if (unassigned? prefix) (set! prefix 'LABEL))
+ (if (default-object? prefix) (set! prefix 'LABEL))
(string->symbol
(string-append
(symbol->string
(cond ((eq? prefix lambda-tag:unnamed) 'LAMBDA)
((eq? prefix lambda-tag:let) 'LET)
((eq? prefix lambda-tag:make-environment) 'MAKE-ENVIRONMENT)
- ((or (eq? prefix lambda-tag:shallow-fluid-let)
- (eq? prefix lambda-tag:deep-fluid-let)
- (eq? prefix lambda-tag:common-lisp-fluid-let))
- 'FLUID-LET)
+ ((eq? prefix lambda-tag:fluid-let) 'FLUID-LET)
(else prefix)))
"-"
(number->string (generate-label-number) 10))))
(set! *current-label-number* (1+ *current-label-number*))
number))
\f
-(define (copy-alist alist)
- (if (null? alist)
- '()
- (cons (cons (caar alist) (cdar alist))
- (copy-alist (cdr alist)))))
-
-(define (boolean=? x y)
- (if x y (not y)))
-
-(define (warn message . irritants)
- (newline)
- (write-string "Warning: ")
- (write-string message)
- (for-each (lambda (irritant)
- (write-string " ")
- (write irritant))
- irritants))
-
-(define (show-time thunk)
- (let ((process-start (process-time-clock))
- (real-start (real-time-clock)))
- (let ((value (thunk)))
- (let ((process-end (process-time-clock))
- (real-end (real-time-clock)))
- (newline)
- (write-string "process time: ")
- (write (- process-end process-start))
- (write-string "; real time: ")
- (write (- real-end real-start)))
- value)))
-
(define (list-filter-indices items indices)
(let loop ((items items) (indices indices) (index 0))
(cond ((null? indices) '())
(loop (cdr items) (cdr indices) (1+ index))))
(else
(loop (cdr items) indices (1+ index))))))
-\f
-(define (there-exists? items predicate)
- (let loop ((items items))
- (and (not (null? items))
- (or (predicate (car items))
- (loop (cdr items))))))
-
-(define (for-all? items predicate)
- (let loop ((items items))
- (or (null? items)
- (and (predicate (car items))
- (loop (cdr items))))))
(define (all-eq? items)
(if (null? items)
(for-all? (cdr items)
(let ((item (car items)))
(lambda (item*)
- (eq? item item))))))
+ (eq? item item*))))))
(define (all-eq-map? items map)
(if (null? items)
(let-syntax ((define-type-code
(macro (var-name #!optional type-name)
- (if (unassigned? type-name) (set! type-name var-name))
+ (if (default-object? type-name) (set! type-name var-name))
`(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: var-name)
',(microcode-type type-name)))))
(define-type-code lambda)
(define-type-code compiled-entry))
(define (scode/procedure-type-code *lambda)
- (cond ((primitive-type? type-code:lambda *lambda)
+ (cond ((object-type? type-code:lambda *lambda)
type-code:procedure)
- ((primitive-type? type-code:extended-lambda *lambda)
+ ((object-type? type-code:extended-lambda *lambda)
type-code:extended-procedure)
(else
(error "SCODE/PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda))))
(= arity argument-count)))))
(define (primitive-procedure-safe? object)
- (and (primitive-type? (ucode-type primitive) object)
+ (and (object-type? (ucode-type primitive) object)
(not (memq object unsafe-primitive-procedures))))
-\f
+
(define unsafe-primitive-procedures
(let-syntax ((primitives
(macro names
(make-named-tag "DELAY-LAMBDA"))
(define (non-pointer-object? object)
- (or (primitive-type? (ucode-type false) object)
- (primitive-type? (ucode-type true) object)
- (primitive-type? (ucode-type fixnum) object)
- (primitive-type? (ucode-type character) object)
- (primitive-type? (ucode-type unassigned) object)
- (primitive-type? (ucode-type the-environment) object)
- (primitive-type? (ucode-type manifest-nm-vector) object)
- (primitive-type? (ucode-type manifest-special-nm-vector) object)))
+ ;; Any reason not to use `object/non-pointer?' here? -- cph
+ (or (object-type? (ucode-type false) object)
+ (object-type? (ucode-type true) object)
+ (object-type? (ucode-type fixnum) object)
+ (object-type? (ucode-type character) object)
+ (object-type? (ucode-type unassigned) object)
+ (object-type? (ucode-type the-environment) object)
+ (object-type? (ucode-type manifest-nm-vector) object)
+ (object-type? (ucode-type manifest-special-nm-vector) object)))
(define (object-immutable? object)
(or (non-pointer-object? object)
(list-transform-positive
(map (lambda (name)
(lexical-reference system-global-environment name))
- '(PRIMITIVE-TYPE PRIMITIVE-TYPE?
+ '(OBJECT-TYPE OBJECT-TYPE?
EQ? NULL? PAIR? NUMBER? COMPLEX? REAL? RATIONAL? INTEGER?
ZERO? POSITIVE? NEGATIVE? ODD? EVEN? EXACT? INEXACT?
= < > <= >= MAX MIN
+ - * / 1+ -1+ ABS QUOTIENT REMAINDER MODULO INTEGER-DIVIDE
GCD LCM FLOOR CEILING TRUNCATE ROUND
EXP LOG EXPT SQRT SIN COS TAN ASIN ACOS ATAN))
- (access primitive-procedure? system-global-environment))
+ (lexical-reference system-global-environment 'PRIMITIVE-PROCEDURE?))
(list
(ucode-primitive &+) (ucode-primitive &-)
(ucode-primitive &*) (ucode-primitive &/)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.1 1988/04/15 02:07:16 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.2 1988/06/14 08:36:01 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
\f
;;;; More hairy expressions
-(define (canonicalize/definition expr bound context)
- (scode/definition-components
- expr
- (lambda (name old-value)
- (let ((value (canonicalize/expression old-value bound context)))
- (if (memq context '(ONCE-ONLY ARBITRARY))
- (error "canonicalize/definition: unscanned definition"
- definition)
- (make-canout
- (scode/make-combination
- (ucode-primitive LOCAL-ASSIGNMENT)
- (list (scode/make-variable environment-variable)
- name
- (canout-expr value)))
- (canout-safe? value) true false))))))
+(define (canonicalize/definition expression bound context)
+ (scode/definition-components expression
+ (lambda (name value)
+ (let ((value (canonicalize/expression value bound context)))
+ (if (memq context '(ONCE-ONLY ARBITRARY))
+ (error "canonicalize/definition: unscanned definition"
+ expression))
+ (make-canout (scode/make-combination
+ (ucode-primitive local-assignment)
+ (list (scode/make-variable environment-variable)
+ name
+ (canout-expr value)))
+ (canout-safe? value)
+ true
+ false)))))
(define (canonicalize/the-environment expr bound context)
expr bound context ;; ignored
(macro (value name)
`(or (eq? ,value (ucode-primitive ,name))
(and (scode/absolute-reference? ,value)
- (eq? (scode/absolute-reference-name ,value) ',name))))))
+ (eq? (scode/absolute-reference-name ,value)
+ ',name))))))
(define (canonicalize/combination expr bound context)
(scode/combination-components
(define canonicalize/expression
(let ((dispatch-vector
- (make-vector number-of-microcode-types canonicalize/constant)))
+ (make-vector (microcode-type/code-limit) canonicalize/constant)))
(let-syntax
((dispatch-entry
(dispatch-entries (lambda lexpr extended-lambda) canonicalize/lambda)
(dispatch-entries (sequence-2 sequence-3) canonicalize/sequence))
(named-lambda (canonicalize/expression expression bound context)
- ((vector-ref dispatch-vector (primitive-type expression))
+ ((vector-ref dispatch-vector (object-type expression))
expression bound context))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.5 1988/04/15 02:06:34 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.6 1988/06/14 08:36:12 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(map* actions scode/make-assignment names values)))
(map (lambda (name)
name ;; ignored
- (scode/make-unassigned-object))
+ (make-unassigned-reference-trap))
auxiliary)))))))
(define (parse-procedure-body* names actions)
(define generate/expression
(let ((dispatch-vector
- (make-vector number-of-microcode-types generate/constant))
+ (make-vector (microcode-type/code-limit) generate/constant))
(generate/combination
(lambda (block continuation expression)
(let ((operator (scode/combination-operator expression))
generate/combination)
(dispatch-entry comment generate/comment))
(named-lambda (generate/expression block continuation expression)
- ((vector-ref dispatch-vector (primitive-type expression))
+ ((vector-ref dispatch-vector (object-type expression))
block continuation expression))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.2 1988/01/02 16:45:01 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.3 1988/06/14 08:35:09 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(fluid-let ((*procedure-queue* (make-queue))
(*procedures* '()))
(walk-node (expression-entry-node root-expression) 0)
- (queue-map! *procedure-queue*
+ (queue-map!/unsafe *procedure-queue*
(lambda (procedure)
(if (procedure-continuation? procedure)
(walk-node (continuation/entry-node procedure)
(define (enqueue-procedure! procedure)
(set! *procedures* (cons procedure *procedures*))
- (enqueue! *procedure-queue* procedure))
+ (enqueue!/unsafe *procedure-queue* procedure))
(define (walk-return operator operand offset)
+ offset
(walk-rvalue operator)
(let ((continuation (rvalue-known-value operator)))
(if (not (and continuation
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.4 1988/03/14 20:51:42 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.5 1988/06/14 08:35:17 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
rest))
(define (push-unassigned block n rest)
- (let ((unassigned (make-constant (scode/make-unassigned-object))))
+ (let ((unassigned (make-constant (make-unassigned-reference-trap))))
(let loop ((n n) (rest rest))
(if (zero? n)
rest
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 4.2 1987/12/30 06:45:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 4.3 1988/06/14 08:35:26 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define process-application-methods
(make-method-table rvalue-types
(lambda (old operator apply-operator)
+ old apply-operator
(warn "Unapplicable operator" operator)
operator)))
"Primitive called with wrong number of arguments"
value
number-supplied)))
- ((not (scode/unassigned-object? value))
+ ((not (unassigned-reference-trap? value))
(warn "Inapplicable operator" value)))))
(else
(warn "Inapplicable operator" operator)))))))
(map lvalue-initial-values (cdr lvalues)))))
\f
(define (lvalue-unassigned! lvalue)
- (lvalue-connect! lvalue (make-constant (scode/make-unassigned-object))))
+ (lvalue-connect! lvalue (make-constant (make-unassigned-reference-trap))))
(define-integrable (lvalue-connect! lvalue rvalue)
(if (rvalue/reference? rvalue)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.33 1988/02/17 19:12:01 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.34 1988/06/14 08:46:27 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
-(declare
- (integrate addressing-granularity
- scheme-object-width
- endianness
- maximum-padding-length
- maximum-block-offset
- block-offset-width)
- (integrate-operator block-offset->bit-string
- instruction-initial-position
- instruction-insert!))
-
-(define addressing-granularity 8)
-(define scheme-object-width 32)
-(define endianness 'BIG)
+(define-integrable addressing-granularity 8)
+(define-integrable scheme-object-width 32)
+(define-integrable endianness 'BIG)
;; Instruction length is always a multiple of 16
;; Pad with ILLEGAL instructions
-(define maximum-padding-length 16)
+(define-integrable maximum-padding-length 16)
(define padding-string
(unsigned-integer->bit-string 16 #b0100101011111100))
;; Block offsets are always words
-(define maximum-block-offset (- (expt 2 16) 2))
-(define block-offset-width 16)
+(define-integrable maximum-block-offset (- (expt 2 16) 2))
+(define-integrable block-offset-width 16)
-(define (block-offset->bit-string offset start?)
- (declare (integrate offset start?))
+(define-integrable (block-offset->bit-string offset start?)
(unsigned-integer->bit-string block-offset-width
(+ offset
(if start? 0 1))))
(define (object->bit-string object)
(bit-string-append
- (unsigned-integer->bit-string 24 (primitive-datum object))
- (unsigned-integer->bit-string 8 (primitive-type object))))
-\f
+ (unsigned-integer->bit-string 24 (object-datum object))
+ (unsigned-integer->bit-string 8 (object-type object))))
+
;;; Machine dependent instruction order
-(define (instruction-initial-position block)
- (declare (integrate block))
+(define-integrable (instruction-initial-position block)
(bit-string-length block))
(define (instruction-insert! bits block position receiver)
- (declare (integrate block position receiver))
(let* ((l (bit-string-length bits))
(new-position (- position l)))
(bit-substring-move-right! bits 0 l block new-position)
(receiver new-position)))
-(set! instruction-append bit-string-append-reversed)
+(define instruction-append
+ bit-string-append-reversed)
\ 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.4 1988/04/15 02:15:37 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.5 1988/06/14 08:46:36 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(lambda ()
(let ((object (fasload (pathname-new-type pathname "com")))
(info (let ((pathname (pathname-new-type pathname "binf")))
- (and (if (unassigned? symbol-table?)
+ (and (if (default-object? symbol-table?)
(file-exists? pathname)
symbol-table?)
(fasload pathname)))))
(let ((the-block (compiled-code-address->block entry)))
(fluid-let ((disassembler/write-offsets? true)
(disassembler/write-addresses? true)
- (disassembler/base-address (primitive-datum the-block)))
+ (disassembler/base-address (object-datum the-block)))
(newline)
(newline)
(disassembler/write-compiled-code-block
the-block
(->compiler-info
(system-vector-ref the-block
- (- (system-vector-size the-block) 2)))))))
+ (- (system-vector-length the-block) 2)))))))
\f
;;; Operations exported from the disassembler package
(number->string (object-hash block) '(HEUR (RADIX D S))))
(write-string " ")
(write-string
- (number->string (primitive-datum block) '(HEUR (RADIX X E))))
+ (number->string (object-datum block) '(HEUR (RADIX X E))))
(write-string "]"))
(define (disassembler/write-compiled-code-block block info #!optional page?)
(let ((symbol-table (compiler-info/symbol-table info)))
- (if (or (unassigned? page?) page?)
+ (if (or (default-object? page?) page?)
(begin
(write-char #\page)
(newline)))
(procedure offset instruction)
(loop (instruction-stream)))))))
\f
-(define disassembler/write-constants-block)
-(let ()
-
-(set! disassembler/write-constants-block
- (named-lambda (disassembler/write-constants-block block symbol-table)
- (fluid-let ((*unparser-radix* 16))
- (let ((end (system-vector-size block)))
- (let loop ((index (compiled-code-block/constants-start block)))
- (if (< index end)
- (begin
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-constant block
- symbol-table
- (system-vector-ref block index))))
- (loop (1+ index)))))))))
+(define (disassembler/write-constants-block block symbol-table)
+ (fluid-let ((*unparser-radix* 16))
+ (let ((end (system-vector-length block)))
+ (let loop ((index (compiled-code-block/constants-start block)))
+ (if (< index end)
+ (begin
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (write-constant block
+ symbol-table
+ (system-vector-ref block index))))
+ (loop (1+ index))))))))
(define (write-constant block symbol-table constant)
(write-string (cdr (write-to-string constant 60)))
(begin
(write-string " (")
(let ((offset (compiled-code-address->offset expression)))
- (let ((label (disassembler/lookup-symbol symbol-table offset)))
+ (let ((label
+ (disassembler/lookup-symbol symbol-table offset)))
(if label
(write-string (string-downcase label))
(write offset))))
(write-string " in ")
(write-block (compiled-code-address->block constant))
(write-string ")"))
- (else false))))
+ (else false)))
\f
(define (disassembler/write-instruction symbol-table offset write-instruction)
(if symbol-table
(if disassembler/write-addresses?
(begin
(write-string
- ((access unparse-number-heuristically number-unparser-package)
- (+ offset disassembler/base-address) 16 false false))
+ (number->string (+ offset disassembler/base-address)
+ '(HEUR (RADIX X S))))
(write-char #\Tab)))
(if disassembler/write-offsets?
(begin
- (write-string
- ((access unparse-number-heuristically number-unparser-package)
- offset 16 false false))
- (write-char #\Tab)))
+ (write-string (number->string offset '(HEUR (RADIX X S)))) (write-char #\Tab)))
(if symbol-table
(write-string " "))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.6 1988/05/19 01:47:37 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.7 1988/06/14 08:46:44 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (read-bits offset size-in-bits)
(let ((word (bit-string-allocate size-in-bits)))
- (with-interrupt-mask interrupt-mask-none
- (lambda (old)
- old ; ignored
- (read-bits! (if *block
- (+ (primitive-datum *block) offset)
- offset)
- 0
- word)))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (read-bits! (if *block (+ (object-datum *block) offset) offset)
+ 0
+ word)))
word))
\f
;;;; Compiler specific information
(let ((entry (assq offset interpreter-register-assignments)))
(if entry
(cdr entry)
- (let ((entry (assq word-offset interpreter-register-assignments)))
- (and entry
- (if (= residue 0)
- (cdr entry)
- `(,@(cdr entry) (,residue)))))))))
-
-(define (with-aligned-offset offset receiver)
- (let ((q/r (integer-divide offset 4)))
- (receiver (* (car q/r) 4) (cdr q/r))))
-
+ (let ((qr (integer-divide offset 2)))
+ (let ((entry
+ (assq (integer-divide-quotient qr)
+ interpreter-register-assignments)))
+ (and entry
+ (if (= (integer-divide-quotient qr) 0)
+ (cdr entry)
+ `(,@(cdr entry)
+ (,(integer-divide-quotient qr)))))))))))
\f
(define interpreter-register-pointer
6)
interrupt-continuation interrupt-ic-procedure
interrupt-procedure interrupt-closure
lookup safe-lookup set! access unassigned? unbound? define
- reference-trap safe-reference-trap assignment-trap unassigned?-trap
+ reference-trap safe-reference-trap assignment-trap
+ unassigned?-trap
&+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?))))))
\f
(define (make-pc-relative thunk)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/inerly.scm,v 1.4 1987/07/30 07:08:36 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/inerly.scm,v 1.5 1988/06/14 08:46:53 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(mapcan (lambda (rule)
(apply
(lambda (pattern variables categories expression)
- (if (and (or (unassigned? modes) (eq-subset? modes categories))
- (or (unassigned? keywords) (not (memq (car pattern) keywords))))
+ (if (and (or (default-object? modes)
+ (eq-subset? modes categories))
+ (or (default-object? keywords)
+ (not (memq (car pattern) keywords))))
(list (early-make-rule pattern variables expression))
'()))
rule))
early-ea-database)))
-
(define (eq-subset? s1 s2)
(or (null? s1)
(and (memq (car s1) s2)
(syntax-table-define early-syntax-table 'DEFINE-EA-TRANSFORMER
(macro (name . restrictions)
- `(define-early-transformer ',name (apply make-ea-transformer ',restrictions))))
+ `(DEFINE-EARLY-TRANSFORMER ',name
+ (APPLY MAKE-EA-TRANSFORMER ',restrictions))))
(syntax-table-define early-syntax-table 'DEFINE-SYMBOL-TRANSFORMER
(macro (name . assoc)
- `(define-early-transformer ',name (make-symbol-transformer ',assoc))))
+ `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-SYMBOL-TRANSFORMER ',assoc))))
(syntax-table-define early-syntax-table 'DEFINE-REG-LIST-TRANSFORMER
(macro (name . assoc)
- `(define-early-transformer ',name (make-bit-mask-transformer 16 ',assoc))))
+ `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-BIT-MASK-TRANSFORMER 16 ',assoc))))
\f
;;;; Instruction and addressing mode macros
rules)))))
(define (make-ea-selector-expander late-name index)
- ((access scode->scode-expander package/expansion package/scode-optimizer)
+ (scode->scode-expander
(lambda (operands if-expanded if-not-expanded)
- (define (default)
- (if-expanded (scode/make-combination (scode/make-variable late-name)
- operands)))
-
- (let ((operand (car operands)))
+ if-not-expanded
+ (let ((default
+ (lambda ()
+ (if-expanded
+ (scode/make-combination
+ (scode/make-variable late-name)
+ operands))))
+ (operand (car operands)))
(if (not (scode/combination? operand))
(default)
(scode/combination-components operand
\f
;;;; Utilities
-(define (make-position-independent-early pattern categories mode register . extension)
+(define (make-position-independent-early pattern categories mode register
+ . extension)
(let ((keyword (car pattern)))
`(early-parse-rule
',pattern
,(integer-syntaxer register 'UNSIGNED 3)
(LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL)
(DECLARE (INTEGRATE IMMEDIATE-SIZE INSTRUCTION-TAIL))
+ IMMEDIATE-SIZE ;ignore if not referenced
,(if (null? extension)
'INSTRUCTION-TAIL
- `(CONS-SYNTAX ,(car extension)
- INSTRUCTION-TAIL)))
+ `(CONS-SYNTAX ,(car extension) INSTRUCTION-TAIL)))
',categories)))))))
(define (make-position-dependent-early pattern categories code-list)
,(process-ea-field register)
(LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL)
(DECLARE (INTEGRATE IMMEDIATE-SIZE INSTRUCTION-TAIL))
+ IMMEDIATE-SIZE ;ignore if not referenced
,(if (null? extension)
'INSTRUCTION-TAIL
`(CONS (LIST 'LABEL ,name)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.123 1987/07/30 07:08:55 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.124 1988/06/14 08:47:02 cph Rel $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
;;;; Effective addressing
-(define ea-database-name 'ea-database)
+(define ea-database-name
+ 'EA-DATABASE)
(syntax-table-define assembler-syntax-table 'DEFINE-EA-DATABASE
(macro rules
- `(define ,ea-database-name
+ `(DEFINE ,ea-database-name
,(compile-database rules
(lambda (pattern actions)
(if (null? (cddr actions))
,(integer-syntaxer mode 'UNSIGNED 3)
,(integer-syntaxer register 'UNSIGNED 3)
(LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL)
+ IMMEDIATE-SIZE ;ignore if not referenced
,(if (null? extension)
'INSTRUCTION-TAIL
`(CONS-SYNTAX ,(car extension) INSTRUCTION-TAIL)))
,(process-ea-field mode)
,(process-ea-field register)
(LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL)
+ IMMEDIATE-SIZE ;ignore if not referenced
,(if (null? extension)
'INSTRUCTION-TAIL
`(CONS (LIST 'LABEL ,name)
`(define (,name expression)
(let ((match-result (pattern-lookup ,ea-database-name expression)))
(and match-result
- ,(if (unassigned? categories)
+ ,(if (default-object? categories)
`(match-result)
`(let ((ea (match-result)))
(and ,@(filter categories
(lambda (cat exp) `(memq ',cat ,exp))
`(ea-categories ea))
- ,@(if (unassigned? keywords)
+ ,@(if (default-object? keywords)
`()
(filter keywords
- (lambda (key exp) `(not (eq? ',key ,exp)))
+ (lambda (key exp)
+ `(not (eq? ',key ,exp)))
`(ea-keyword ea)))
ea))))))))
(else
(error "PARSE-INSTRUCTION: unknown expression" expression))))
- (if (or (unassigned? early?) (not early?))
+ (if (not early?)
(with-normal-selectors kernel)
(with-early-selectors kernel)))
(cadr binding)
(map (lambda (clause)
(if (not (null? (cddr clause)))
- (error "PARSE-GROWING-WORD: Extension found in clause" clause))
+ (error "Extension found in clause" clause))
(expand-descriptors
(cdadr clause)
(lambda (instruction size src dst)
(if (not (zero? (remainder size 16)))
- (error "PARSE-GROWING-WORD: Instructions must be 16 bit multiples"
- size)
- `(,(collect-word instruction src dst '())
- ,size
- ,@(car clause)))))) ; Range
+ (error "Instructions must be 16 bit multiples" size))
+ `(,(collect-word instruction src dst '())
+ ,size
+ ,@(car clause))))) ; Range
(cddr expression))))))
\f
;;;; Fixed width instruction parsing
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr1.scm,v 1.65 1987/07/30 07:09:17 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr1.scm,v 1.66 1988/06/14 08:47:12 cph Rel $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;; Originally from GJS (who did the hard part).
(declare (usual-integrations))
-
+\f
;;; Effective Address description database
(define-ea-database
-\f
((D (? r)) (DATA ALTERABLE) #b000 r)
((A (? r)) (ALTERABLE) #b001 r)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.14 1987/07/30 07:09:49 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.15 1988/06/14 08:47:21 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(WORD (13 #b0100111001100)
(3 rx))))
\f
-;; MOV is a special case, separated for efficiency so there are less rules to try.
+;; MOV is a special case, separated for efficiency so there are less
+;; rules to try.
(define-instruction MOV
((B (? sea ea-all-A) (? dea ea-d&a))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.5 1987/07/30 07:10:09 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.6 1988/06/14 08:47:30 cph Rel $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
((POST)
(+ #b100 outer-displacement-size))
(else
- (error "bad memory indirection-type" memory-indirection-type)))))
+ (error "bad memory indirection-type"
+ memory-indirection-type)))))
(append-syntax!
(output-displacement base-displacement-size base-displacement)
(output-displacement outer-displacement-size outer-displacement))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.8 1988/05/19 18:37:36 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.9 1988/06/14 08:47:38 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-export byte-offset-reference
(make-offset-reference
(quotient 8 addressing-granularity)))
-;;; End PACKAGE
-)
+)
\f
(define (load-dnw n d)
(cond ((zero? n)
(define (load-constant constant target)
(if (non-pointer-object? constant)
- (load-non-pointer (primitive-type constant)
- (primitive-datum constant)
+ (load-non-pointer (object-type constant)
+ (object-datum constant)
target)
(INST (MOV L
(@PCR ,(constant->label constant))
(LAP (MOV L
(@PCR ,(constant->label constant))
,register-ref)
- ,(remove-type-from-fixmum register-ref))))
+ ,(remove-type-from-fixnum register-ref))))
(define (load-non-pointer type datum target)
(cond ((not (zero? type))
(define-integrable (register-effective-address? effective-address)
(memq (lap:ea-keyword effective-address) '(A D)))
\f
-
(package (indirect-reference! indirect-byte-reference!)
(define ((make-indirect-reference offset-reference) register offset)
(define-export indirect-reference!
(make-indirect-reference offset-reference))
+
(define-export indirect-byte-reference!
(make-indirect-reference byte-offset-reference))
-;;; End PACKAGE
+
)
(define (coerce->any register)
(let ((alias (register-alias register false)))
(if alias
(register-reference alias)
- (indirect-char/ascii-reference! regnum:regs-pointer
- (pseudo-register-offset register))))))
+ (indirect-char/ascii-reference!
+ regnum:regs-pointer
+ (pseudo-register-offset register))))))
(define (code-object-label-initialize code-object)
+ code-object
false)
(define (generate-n-times n limit instruction-gen with-counter)
(LAP ,(instruction-gen)
,@(loop (-1+ n)))))))
\f
-
-;;; this fixnum stuff will be moved to fixlap.scm after we can include
+;;; This fixnum stuff will be moved to fixlap.scm after we can include
;;; fixlap.scm's dependencies in decls.scm
(define (expression->fixnum-register! expression register)
-;;; inputs:
-;;; - an rtl expression
-;;; - a register into which the produced code should place the
-;;; result of evaluating the expression.
-;;; output: the lap code to move the expression into the register.
+ ;; inputs:
+ ;; - an rtl expression
+ ;; - a register into which the produced code should place the
+ ;; result of evaluating the expression.
+ ;; output: the lap code to move the expression into the register.
(let ((target (register-reference register)))
(case (rtl:expression-type expression)
((REGISTER)
((OFFSET)
(LAP
(MOV L
- ,(indirect-reference! (rtl:register-number (rtl:offset-register expression))
- (rtl:offset-number expression))
+ ,(indirect-reference!
+ (rtl:register-number (rtl:offset-register expression))
+ (rtl:offset-number expression))
,target)))
((CONSTANT)
- (LAP (MOV L (& ,(fixnum-constant (rtl:constant-value expression))) ,target)))
+ (LAP (MOV L (& ,(fixnum-constant (rtl:constant-value expression)))
+ ,target)))
((UNASSIGNED)
(LAP ,(load-non-pointer type-code:unassigned 0 target)))
(else
- (error "expression->fixnum-register!:Unknown expression type" (expression))))))
+ (error "EXPRESSION->FIXNUM-REGISTER!: Unknown expression type"
+ expression)))))
(define (remove-type-from-fixnum register-reference)
-;;; input: a register reference of a register containing some fixnum
-;;; with a type-code
-;;; output: the lap code to get rid of the type-code and sign extend
+ ;; input: a register reference of a register containing some fixnum
+ ;; with a type-code
+ ;; output: the lap code to get rid of the type-code and sign extend
(LAP (LS L L (& 8) ,register-reference)
(AS R L (& 8) ,register-reference)))
(define (put-type-in-ea type-code effective-address)
-;;; inputs:
-;;; - a type-code
-;;; - an effective address
-;;; output: the lap code to stick the type in the top byte of the register
+ ;; inputs:
+ ;; - a type-code
+ ;; - an effective address
+ ;; output: the lap code to stick the type in the top byte of the register
(if (register-effective-address? effective-address)
(LAP (AND L ,mask-reference ,effective-address)
(OR L (& ,(make-non-pointer-literal type-code 0))
- ,effective-address))
+ ,effective-address))
(INST (MOV B (& ,type-code) ,effective-address))))
-
+
(define (fixnum-constant x)
(if (<= (abs x) maximum-positive-fixnum)
x
(error "Not a fixnum" x)))
(define (fixnum-expression? expression)
-;;; input: an rtl expression
-;;; output: true, if the expression is of some fixnum type. false, otherwise
+ ;; input: an rtl expression
+ ;; output: true, if the expression is of some fixnum type. false, otherwise
(eq? (rtl:expression-type expression) 'FIXNUM))
(define (commutative-op? op)
-;;; input: An operator
-;;; output: True, if the op is commutative.
+ ;; input: An operator
+ ;; output: True, if the op is commutative.
(memq op '(PLUS-FIXNUM MULTIPLY-FIXNUM)))
-
+\f
(define (fixnum-do-2-args! operator operand-1 operand-2 register)
-;;; inputs:
-;;; - a fixnum operator
-;;; - an operand
-;;; - another operand
-;;; - the register into which the generated code should place the
-;;; result of the calculation
-;;; output: the lap code to calculate the fixnum expression
-;;;
-;;; Note that the final placement of the type-code in the result is
-;;; not done here. It must be done in the caller.
+ ;; inputs:
+ ;; - a fixnum operator
+ ;; - an operand
+ ;; - another operand
+ ;; - the register into which the generated code should place the
+ ;; result of the calculation
+ ;; output: the lap code to calculate the fixnum expression
+ ;;
+ ;; Note that the final placement of the type-code in the result is
+ ;; not done here. It must be done in the caller.
(let ((finish
- (lambda (operand-1 operand-2)
- (LAP ,(expression->fixnum-register! operand-1 register)
- ,((fixnum-code-gen operator) operand-2 register)))))
+ (lambda (operand-1 operand-2)
+ (LAP ,(expression->fixnum-register! operand-1 register)
+ ,((fixnum-code-gen operator) operand-2 register)))))
(if (and (commutative-op? operator)
(rtl:constant? operand-1))
(finish operand-2 operand-1)
(finish operand-1 operand-2))))
-
(define (fixnum-do-1-arg! operator operand register)
-;;; inputs:
-;;; - a fixnum operator
-;;; - an operand
-;;; - the register into which the generated code should place the
-;;; result of the calculation
-;;; output: the lap code to calculate the fixnum expression
-;;;
-;;; Note that the final placement of the type-code in the result is
-;;; not done here. It must be done in the caller.
+ ;; inputs:
+ ;; - a fixnum operator
+ ;; - an operand
+ ;; - the register into which the generated code should place the
+ ;; result of the calculation
+ ;; output: the lap code to calculate the fixnum expression
+ ;;
+ ;; Note that the final placement of the type-code in the result is
+ ;; not done here. It must be done in the caller.
(LAP ,(expression->fixnum-register! operand register)
,((fixnum-code-gen operator) register)))
+(define (fixnum-code-gen operator)
+ ;; input: a fixnum operator
+ ;; output: a procedure with the following behavior
+ ;; inputs:
+ ;; - an operand to a fixnum expression
+ ;; - a register which already should contain the other
+ ;; operand to the fixnum expression
+ ;; output: the lap code to apply the operator to the
+ ;; operand and register, putting the result in the register
+ (case operator
+ ((PLUS-FIXNUM) fixnum-plus-gen)
+ ((MULTIPLY-FIXNUM) fixnum-multiply-gen)
+ ((MINUS-FIXNUM) fixnum-minus-gen)
+ ((ONE-PLUS-FIXNUM) fixnum-one-plus-gen)
+ ((MINUS-ONE-PLUS-FIXNUM) fixnum-minus-one-plus-gen)
+ (else (error "Unknown operator" operator))))
+\f
(define fixnum-plus-gen
-;;; inputs:
-;;; - an rtl expression representing the addend
-;;; - a register to which the addend will be added
-;;; output: lap code to add the addend to the register
+ ;; inputs:
+ ;; - an rtl expression representing the addend
+ ;; - a register to which the addend will be added
+ ;; output: lap code to add the addend to the register
(lambda (addend register)
(let ((target (register-reference register)))
(case (rtl:expression-type addend)
(INST (ADD L ,(coerce->any (rtl:register-number addend)) ,target)))
((OFFSET)
(INST (ADD L
- ,(indirect-reference!
- (rtl:register-number (rtl:offset-register addend))
- (rtl:offset-number addend))
- ,target)))
+ ,(indirect-reference!
+ (rtl:register-number (rtl:offset-register addend))
+ (rtl:offset-number addend))
+ ,target)))
((CONSTANT)
(let ((constant (fixnum-constant (rtl:constant-value addend))))
(if (and (<= constant 8) (>= constant 1))
(error "fixnum-plus-gen: Unknown expression type" addend))))))
(define fixnum-multiply-gen
-;;; inputs:
-;;; - an rtl expression representing the multiplicand
-;;; - a register to which the multiplicand will be multiplied
-;;; output: lap code to add the multiplicand to the register
+ ;; inputs:
+ ;; - an rtl expression representing the multiplicand
+ ;; - a register to which the multiplicand will be multiplied
+ ;; output: lap code to add the multiplicand to the register
(lambda (multiplicand register)
(let ((target (register-reference register)))
(case (rtl:expression-type multiplicand)
((REGISTER)
- (INST (MUL S L ,(coerce->any (rtl:register-number multiplicand)) ,target)))
+ (INST (MUL S L ,(coerce->any (rtl:register-number multiplicand))
+ ,target)))
((OFFSET)
(INST (MUL S L
- ,(indirect-reference!
- (rtl:register-number (rtl:offset-register multiplicand))
- (rtl:offset-number multiplicand))
- ,target)))
+ ,(indirect-reference!
+ (rtl:register-number (rtl:offset-register multiplicand))
+ (rtl:offset-number multiplicand))
+ ,target)))
((CONSTANT)
(let* ((constant (fixnum-constant (rtl:constant-value multiplicand)))
- (power-of-2?
- (let loop ((power 1) (exponent 0))
- (cond ((< constant power) false)
- ((= constant power) exponent)
- (else (loop (* 2 power) (1+ exponent)))))))
+ (power-of-2?
+ (let loop ((power 1) (exponent 0))
+ (cond ((< constant power) false)
+ ((= constant power) exponent)
+ (else (loop (* 2 power) (1+ exponent)))))))
(if power-of-2?
(INST (AS L L (& ,power-of-2?) ,target))
(INST (MUL S L (& ,(fixnum-constant constant)) ,target)))))
((UNASSIGNED) ; this needs to be looked at
(LAP ,(load-non-pointer type-code:unassigned 0 target)))
(else
- (error "fixnum-multiply-gen: Unknown expression type" multiplicand))))))
-
+ (error "FIXNUM-MULTIPLY-GEN: Unknown expression type"
+ multiplicand))))))
+\f
(define fixnum-minus-gen
-;;; inputs:
-;;; - an rtl expression representing the subtrahend
-;;; - a register to which the subtrahend will be subtracted
-;;; output: lap code to add the subtrahend to the register
+ ;; inputs:
+ ;; - an rtl expression representing the subtrahend
+ ;; - a register to which the subtrahend will be subtracted
+ ;; output: lap code to add the subtrahend to the register
(lambda (subtrahend register)
(let ((target (register-reference register)))
(case (rtl:expression-type subtrahend)
((REGISTER)
- (INST (SUB L ,(coerce->any (rtl:register-number subtrahend)) ,target)))
+ (INST (SUB L ,(coerce->any (rtl:register-number subtrahend))
+ ,target)))
((OFFSET)
(INST (SUB L
- ,(indirect-reference!
- (rtl:register-number (rtl:offset-register subtrahend))
- (rtl:offset-number subtrahend))
- ,target)))
+ ,(indirect-reference!
+ (rtl:register-number (rtl:offset-register subtrahend))
+ (rtl:offset-number subtrahend))
+ ,target)))
((CONSTANT)
(let ((constant (fixnum-constant (rtl:constant-value subtrahend))))
(if (and (<= constant 8) (>= constant 1))
(error "fixnum-minus-gen: Unknown expression type" subtrahend))))))
(define fixnum-one-plus-gen
-;;; inputs:
-;;; - a register to be incremented
-;;; output: lap code to add one to the register
+ ;; inputs:
+ ;; - a register to be incremented
+ ;; output: lap code to add one to the register
(lambda (register)
(INST (ADDQ L (& 1) ,(register-reference register)))))
(define fixnum-minus-one-plus-gen
-;;; inputs:
-;;; - a register to be deccremented
-;;; output: lap code to subtract one from the register
+ ;; inputs:
+ ;; - a register to be deccremented
+ ;; output: lap code to subtract one from the register
(lambda (register)
(INST (SUBQ L (& 1) ,(register-reference register)))))
-
-(define (fixnum-code-gen operator)
-;;; input: a fixnum operator
-;;; output: a procedure with the following behavior
-;;; inputs:
-;;; - an operand to a fixnum expression
-;;; - a register which already should contain the other
-;;; operand to the fixnum expression
-;;; output: the lap code to apply the operator to the
-;;; operand and register, putting the result in the register
- (case operator
- ((PLUS-FIXNUM) fixnum-plus-gen)
- ((MULTIPLY-FIXNUM) fixnum-multiply-gen)
- ((MINUS-FIXNUM) fixnum-minus-gen)
- ((ONE-PLUS-FIXNUM) fixnum-one-plus-gen)
- ((MINUS-ONE-PLUS-FIXNUM) fixnum-minus-one-plus-gen)
- ))
\f
;;;; OBJECT->DATUM rules - Mhwu
;;; Similar to fixnum rules, but no sign extension
(define (load-constant-datum constant register-ref)
(if (non-pointer-object? constant)
- (INST (MOV L (& ,(primitive-datum constant)) ,register-ref))
+ (INST (MOV L (& ,(object-datum constant)) ,register-ref))
(LAP (MOV L
(@PCR ,(constant->label constant))
,register-ref)
(let ((ascii (char->ascii character)))
(if (< ascii 128) ascii (- ascii 256))))
-;;; This code uses a temporary register because right now the register
-;;; allocator thinks that it could use the same register for the target
-;;; and source, while what we want to happen is to first clear the target
-;;; and then move from source to target.
-;;; Optimal Code: (CLR L ,target-ref)
-;;; (MOV B ,source ,target)
-;;; source-register is passed in to check for this. Yuck.
(define (byte-offset->register source source-reg target)
+ ;; This code uses a temporary register because right now the register
+ ;; allocator thinks that it could use the same register for the target
+ ;; and source, while what we want to happen is to first clear the target
+ ;; and then move from source to target.
+ ;; Optimal Code: (CLR L ,target-ref)
+ ;; (MOV B ,source ,target)
+ ;; source-register is passed in to check for this. Yuck.
(delete-dead-registers!)
(let* ((temp-ref (register-reference (allocate-temporary-register! 'DATA)))
(target (allocate-alias-register! target 'DATA)))
register
(register-alias register false)))
\f
+;;;; Registers/Entries
+
(define-integrable (data-register? register)
(< register 8))
(define-integrable (lap:ea-keyword expression)
(car expression))
-(define-export (lap:make-label-statement label)
+(define (lap:make-label-statement label)
(INST (LABEL ,label)))
-(define-export (lap:make-unconditional-branch label)
+(define (lap:make-unconditional-branch label)
(INST (BRA (@PCR ,label))))
-(define-export (lap:make-entry-point label block-start-label)
+(define (lap:make-entry-point label block-start-label)
+ block-start-label
(LAP (ENTRY-POINT ,label)
,@(make-external-label expression-code-word label)))
-\f
-;;;; Registers/Entries
(let-syntax ((define-entries
(macro (start . names)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.9 1988/05/19 15:32:53 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.10 1988/06/14 08:48:01 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define closure-block-first-offset
2)
+(define (rtl:machine-register? rtl-register)
+ (case rtl-register
+ ((STACK-POINTER) (interpreter-stack-pointer))
+ ((DYNAMIC-LINK) (interpreter-dynamic-link))
+ ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access))
+ ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
+ (interpreter-register:cache-reference))
+ ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
+ (interpreter-register:cache-unassigned?))
+ ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup))
+ ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?))
+ ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?))
+ (else false)))
+
+(define (rtl:interpreter-register? rtl-register)
+ (case rtl-register
+ ((MEMORY-TOP) 0)
+ ((STACK-GUARD) 1)
+ ((VALUE) 2)
+ ((ENVIRONMENT) 3)
+ ((TEMPORARY) 4)
+ ((INTERPRETER-CALL-RESULT:ENCLOSE) 5)
+ (else false)))
+
+(define (rtl:interpreter-register->offset locative)
+ (or (rtl:interpreter-register? locative)
+ (error "Unknown register type" locative)))
+\f
(define (rtl:expression-cost expression)
;; Returns an estimate of the cost of evaluating the expression.
;; For simplicity, we try to estimate the actual number of cycles
;; move.l reg,reg = 3
;; sub.l reg,reg = 3
((MINUS-FIXNUM) 6)
- (else (error "rtl:expression-cost - unknown fixnum operator" expression))))
+ (else
+ (error "RTL:EXPRESSION-COST: unknown fixnum operator" expression))))
((FIXNUM-1-ARG)
(case (rtl:fixnum-1-arg-operator expression)
;; move.l reg,reg = 3
;; move.l reg,reg = 3
;; subq.l #1,reg = 3
((MINUS-ONE-PLUS-FIXNUM) 6)
- (else (error "rtl:expression-cost - unknown fixnum operator" expression))))
+ (else
+ (error "RTL:EXPRESSION-COST: unknown fixnum operator" expression))))
;; The following are preliminary. Check with Jinx (mhwu)
((CHAR->ASCII) 4)
((BYTE-OFFSET) 12)
(else (error "Unknown expression type" expression))))
\f
-(define (rtl:machine-register? rtl-register)
- (case rtl-register
- ((STACK-POINTER) (interpreter-stack-pointer))
- ((DYNAMIC-LINK) (interpreter-dynamic-link))
- ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access))
- ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
- (interpreter-register:cache-reference))
- ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
- (interpreter-register:cache-unassigned?))
- ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup))
- ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?))
- ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?))
- (else false)))
-
-(define (rtl:interpreter-register? rtl-register)
- (case rtl-register
- ((MEMORY-TOP) 0)
- ((STACK-GUARD) 1)
- ((VALUE) 2)
- ((ENVIRONMENT) 3)
- ((TEMPORARY) 4)
- ((INTERPRETER-CALL-RESULT:ENCLOSE) 5)
- (else false)))
-
-(define (rtl:interpreter-register->offset locative)
- (or (rtl:interpreter-register? locative)
- (error "Unknown register type" locative)))
-\f
(define-integrable d0 0)
(define-integrable d1 1)
(define-integrable d2 2)
(rtl:make-machine-register regnum:dynamic-link))
(define-integrable (interpreter-dynamic-link? register)
- (= (rtl:register-number register) regnum:dynamic-link))
-\f
-;;;; Exports from machines/lapgen
-
-(define lap:make-label-statement)
-(define lap:make-unconditional-branch)
-(define lap:make-entry-point)
\ No newline at end of file
+ (= (rtl:register-number register) regnum:dynamic-link))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.16 1988/06/03 15:14:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.17 1988/06/14 08:48:12 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Compiler Make File for MC68020
+;;;; Compiler: System Construction
(declare (usual-integrations))
-\f
-(load "base/pkging.bin" system-global-environment)
-
-(in-package compiler-package
-
- (define compiler-system
- (make-environment
- (define :name "Liar (Bobcat 68020)")
- (define :version 4)
- (define :modification 16)
- (define :files)
-
- (define :rcs-header
-
- "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.16 1988/06/03 15:14:13 cph Exp $"
-
- )
- (define :files-lists
- (list
- (cons system-global-environment
- '("base/pbs.bin" ;bit-string read/write syntax
- "etc/direct.bin" ;directory reader
- "etc/butils.bin" ;system building utilities
- ))
-
- (cons compiler-package
- '("base/switch.bin" ;compiler option switches
- "base/macros.bin" ;compiler syntax
- "base/hashtb.com" ;hash tables
- ))
-
- (cons decls-package
- '("base/decls.com" ;declarations
- ))
-
- (cons compiler-package
- '("base/object.com" ;tagged object support
- "base/enumer.com" ;enumerations
- "base/queue.com" ;queue abstraction
- "base/sets.com" ;set abstraction
- "base/mvalue.com" ;multiple-value support
- "base/scode.com" ;SCode abstraction
- "base/pmlook.com" ;pattern matcher: lookup
- "base/pmpars.com" ;pattern matcher: parser
-
- "machines/bobcat/machin.com" ;machine dependent stuff
- "base/toplev.com" ;top level
- "base/debug.com" ;debugging support
- "base/utils.com" ;odds and ends
-
- "base/cfg1.com" ;control flow graph
- "base/cfg2.com"
- "base/cfg3.com"
- "base/ctypes.com" ;CFG datatypes
-
- "base/rvalue.com" ;Right hand values
- "base/lvalue.com" ;Left hand values
- "base/blocks.com" ;rvalue: blocks
- "base/proced.com" ;rvalue: procedures
- "base/contin.com" ;rvalue: continuations
-
- "base/subprb.com" ;subproblem datatype
-
- "rtlbase/rgraph.com" ;program graph abstraction
- "rtlbase/rtlty1.com" ;RTL: type definitions
- "rtlbase/rtlty2.com" ;RTL: type definitions
- "rtlbase/rtlexp.com" ;RTL: expression operations
- "rtlbase/rtlcon.com" ;RTL: complex constructors
- "rtlbase/rtlreg.com" ;RTL: registers
- "rtlbase/rtlcfg.com" ;RTL: CFG types
- "rtlbase/rtlobj.com" ;RTL: CFG objects
- "rtlbase/regset.com" ;RTL: register sets
-
- "base/infutl.com" ;utilities for info generation, shared
- "back/insseq.com" ;LAP instruction sequences
- "machines/bobcat/dassm1.com" ;disassembler
- ))
-
- (cons disassembler-package
- '("machines/bobcat/dassm2.com" ;disassembler
- "machines/bobcat/dassm3.com"
- ))
-
- (cons fg-generator-package
- '("fggen/canon.com" ;SCode canonicalizer
- "fggen/fggen.com" ;SCode->flow-graph converter
- "fggen/declar.com" ;Declaration handling
- ))
-
- (cons fg-optimizer-package
- '("fgopt/simapp.com" ;simulate applications
- "fgopt/outer.com" ;outer analysis
- "fgopt/folcon.com" ;fold constants
- "fgopt/operan.com" ;operator analysis
- "fgopt/closan.com" ;closure analysis
- "fgopt/blktyp.com" ;environment type assignment
- "fgopt/contan.com" ;continuation analysis
- "fgopt/simple.com" ;simplicity analysis
- "fgopt/order.com" ;subproblem ordering
- "fgopt/conect.com" ;connectivity analysis
- "fgopt/desenv.com" ;environment design
- "fgopt/offset.com" ;compute node offsets
- ))
-
- (cons rtl-generator-package
- '("rtlgen/rtlgen.com" ;RTL generator
- "rtlgen/rgproc.com" ;procedure headers
- "rtlgen/rgstmt.com" ;statements
- "rtlgen/rgrval.com" ;rvalues
- "rtlgen/rgcomb.com" ;combinations
- "rtlgen/rgretn.com" ;returns
- "rtlgen/fndblk.com" ;find blocks and variables
- "rtlgen/opncod.com" ;open-coded primitives
- "machines/bobcat/rgspcm.com" ;special close-coded primitives
- "rtlbase/rtline.com" ;linearizer
- ))
-
- (cons rtl-cse-package
- '("rtlopt/rcse1.com" ;RTL common subexpression eliminator
- "rtlopt/rcse2.com"
- "rtlopt/rcseep.com" ;CSE expression predicates
- "rtlopt/rcseht.com" ;CSE hash table
- "rtlopt/rcserq.com" ;CSE register/quantity abstractions
- "rtlopt/rcsesr.com" ;CSE stack references
- ))
-
- (cons rtl-optimizer-package
- '("rtlopt/rlife.com" ;RTL register lifetime analyzer
- "rtlopt/rdeath.com" ;RTL code compression
- "rtlopt/rdebug.com" ;RTL optimizer debugging output
- "rtlopt/ralloc.com" ;RTL register allocation
- ))
-
- (cons debugging-information-package
- '("base/infnew.com" ;debugging information generation
- ))
-
- (cons lap-syntax-package
- '("back/lapgn1.com" ;LAP generator.
- "back/lapgn2.com"
- "back/lapgn3.com"
- "back/regmap.com" ;Hardware register allocator.
- "back/linear.com" ;LAP linearizer.
- "machines/bobcat/lapgen.com" ;code generation rules.
- "machines/bobcat/rules1.com"
- "machines/bobcat/rules2.com"
- "machines/bobcat/rules3.com"
- "machines/bobcat/rules4.com"
- "back/syntax.com" ;Generic syntax phase
- "machines/bobcat/coerce.com" ;Coercions: integer -> bit string
- "back/asmmac.com" ;Macros for hairy syntax
- "machines/bobcat/insmac.com" ;Macros for hairy syntax
- "machines/bobcat/insutl.com" ;Utilities for instructions
- "machines/bobcat/instr1.com" ;68000 Effective addressing
- "machines/bobcat/instr2.com" ;68000 Instructions
- "machines/bobcat/instr3.com" ; " "
- "machines/bobcat/instr4.com" ; " "
- ))
-
- (cons bit-package
- '("machines/bobcat/assmd.com" ;Machine dependent
- "back/symtab.com" ;Symbol tables
- "back/bitutl.com" ;Assembly blocks
- "back/bittop.com" ;Assembler top level
- ))
-
- ))
-
- ))
-
- (load-system! compiler-system))
+(package/system-loader "comp" '() 'QUERY)
(for-each (lambda (name)
- (local-assignment system-global-environment
- name
- (lexical-reference compiler-package name)))
- '(CF
- COMPILE-BIN-FILE
- COMPILE-PROCEDURE
- COMPILER:RESET!
- COMPILER:WRITE-LAP-FILE))
\ No newline at end of file
+ ((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
+ '((COMPILER MACROS)
+ (COMPILER DECLARATIONS)))
+(add-system! (make-system "Liar" 14 17 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.12 1988/05/28 04:11:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.13 1988/06/14 08:48:22 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(move-to-alias-register! source 'DATA target)
(LAP))
\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (QUALIFIER (pseudo-register? target))
+ (let ((target (move-to-alias-register! source 'DATA target)))
+ (LAP (RO L L (& 8) ,target))))
+
(define-rule statement
(ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (CONSTANT (? source))))
(QUALIFIER (pseudo-register? target))
(LAP (AND L ,mask-reference ,target))))
(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset))))
+ (ASSIGN (REGISTER (? target))
+ (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset))))
(QUALIFIER (pseudo-register? target))
(let ((source (indirect-reference! address offset)))
(delete-dead-registers!)
- (let ((target-ref (register-reference (allocate-alias-register! target 'DATA))))
+ (let ((target-ref
+ (register-reference (allocate-alias-register! target 'DATA))))
(LAP (MOV L ,source ,target-ref)))))
(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? datum))))
(QUALIFIER (pseudo-register? target))
- (let ((target (move-to-alias-register! source 'DATA target)))
- (LAP (RO L L (& 8) ,target))))
+ (delete-dead-registers!)
+ (let ((target-ref
+ (register-reference (allocate-alias-register! target 'DATA))))
+ (load-constant-datum datum target-ref)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
+ (QUALIFIER (pseudo-register? target))
+ (let ((target-ref (move-to-alias-register! source 'DATA target)))
+ (LAP ,(scheme-object->datum target-ref))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset))))
+ (QUALIFIER (pseudo-register? target))
+ (let ((source (indirect-reference! address offset)))
+ (delete-dead-registers!)
+ (let ((target-ref
+ (register-reference (allocate-alias-register! target 'DATA))))
+ (LAP (MOV L ,source ,target-ref)
+ ,(scheme-object->datum target-ref)))))
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? datum))))
+ (QUALIFIER (pseudo-register? target))
+ (delete-dead-registers!)
+ (let ((target-ref
+ (register-reference (allocate-alias-register! target 'DATA))))
+ (load-fixnum-constant datum target-ref)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
+ (QUALIFIER (pseudo-register? target))
+ (let ((target-ref (move-to-alias-register! source 'DATA target)))
+ (LAP ,(remove-type-from-fixnum target-ref))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset))))
+ (QUALIFIER (pseudo-register? target))
+ (let ((source (indirect-reference! address offset)))
+ (delete-dead-registers!)
+ (let ((target-ref
+ (register-reference (allocate-alias-register! target 'DATA))))
+ (LAP (MOV L ,source ,target-ref)
+ ,(remove-type-from-fixnum target-ref)))))
+\f
(define-rule statement
(ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
(QUALIFIER (pseudo-register? target))
(delete-dead-registers!)
(let ((target* (coerce->any target)))
(if (register-effective-address? target*)
- (LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label)))
- ,temp)
- (MOV L ,temp ,reg:temp)
- (MOV B (& ,type) ,reg:temp)
- (MOV L ,reg:temp ,target*))
- (LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label)))
- ,temp)
- (MOV L ,temp ,target*)
- (MOV B (& ,type) ,target*))))))
+ (LAP
+ (LEA (@PCR ,(rtl-procedure/external-label (label->object label)))
+ ,temp)
+ (MOV L ,temp ,reg:temp)
+ (MOV B (& ,type) ,reg:temp)
+ (MOV L ,reg:temp ,target*))
+ (LAP
+ (LEA (@PCR ,(rtl-procedure/external-label (label->object label)))
+ ,temp)
+ (MOV L ,temp ,target*)
+ (MOV B (& ,type) ,target*))))))
\f
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? datum))))
- (QUALIFIER (pseudo-register? target))
- (delete-dead-registers!)
- (let ((target-ref (register-reference (allocate-alias-register! target 'DATA))))
- (load-fixnum-constant datum target-ref)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (let ((target-ref (move-to-alias-register! source 'DATA target)))
- (LAP ,(remove-type-from-fixnum target-ref))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset))))
- (QUALIFIER (pseudo-register? target))
- (let ((source (indirect-reference! address offset)))
- (delete-dead-registers!)
- (let ((target-ref (register-reference (allocate-alias-register! target 'DATA))))
- (LAP (MOV L ,source ,target-ref)
- ,(remove-type-from-fixnum target-ref)))))
-
(define-rule statement
(ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
(QUALIFIER (pseudo-register? target))
(let ((temp-reg (allocate-temporary-register! 'DATA)))
(let ((operation
(LAP ,@(fixnum-do-2-args! operator operand1 operand2 temp-reg)
- ,@(put-type-in-ea (ucode fixnum) temp-reg))))
+ ,@(put-type-in-ea (ucode-type fixnum) temp-reg))))
(delete-dead-registers!)
(add-pseudo-register-alias! target temp-reg false)
operation)))
(let ((temp-reg (allocate-temporary-register! 'DATA)))
(let ((operation
(LAP ,@(fixnum-do-1-arg! operator operand temp-reg)
- ,@(put-type-in-ea (ucode fixnum) temp-reg))))
+ ,@(put-type-in-ea (ucode-type fixnum) temp-reg))))
(delete-dead-registers!)
(add-pseudo-register-alias! target temp-reg false)
operation)))
(add-pseudo-register-alias! target temp-reg false)
operation)))
\f
-;;;; OBJECT->DATUM rules. Assignment is always to a register.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? datum))))
- (QUALIFIER (pseudo-register? target))
- (delete-dead-registers!)
- (let ((target-ref
- (register-reference (allocate-alias-register! target 'DATA))))
- (load-constant-datum datum target-ref)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (let ((target-ref (move-to-alias-register! source 'DATA target)))
- (LAP ,(scheme-object->datum target-ref))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset))))
- (QUALIFIER (pseudo-register? target))
- (let ((source (indirect-reference! address offset)))
- (delete-dead-registers!)
- (let ((target-ref
- (register-reference (allocate-alias-register! target 'DATA))))
- (LAP (MOV L ,source ,target-ref)
- ,(scheme-object->datum target-ref)))))
-
-\f
;;;; CHAR->ASCII/BYTE-OFFSET
(define-rule statement
,(indirect-byte-reference! address offset))))
(define-rule statement
- (ASSIGN (REGISTER (? target)) (BYTE-OFFSET (REGISTER (? address)) (? offset)))
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET (REGISTER (? address)) (? offset)))
(QUALIFIER (pseudo-register? target))
(byte-offset->register (indirect-byte-reference! address offset)
(indirect-register address)
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
(UNASSIGNED))
- (LAP ,(load-non-pointer (ucode-type unassigned) 0 (indirect-reference! a n))))
+ (LAP ,(load-non-pointer (ucode-type unassigned)
+ 0
+ (indirect-reference! a n))))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.3 1988/04/22 16:21:29 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.4 1988/06/14 08:48:37 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(TYPE-TEST (REGISTER (? register)) (? type))
(QUALIFIER (pseudo-register? register))
(set-standard-branches! 'EQ)
- (LAP ,(test-byte type
- (register-reference (load-alias-register! register 'DATA)))))
+ (LAP ,(test-byte
+ type
+ (register-reference (load-alias-register! register 'DATA)))))
(define-rule predicate
(TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
(define (eq-test/constant*register constant register)
(set-standard-branches! 'EQ)
(if (non-pointer-object? constant)
- (LAP ,(test-non-pointer (primitive-type constant)
- (primitive-datum constant)
+ (LAP ,(test-non-pointer (object-type constant)
+ (object-datum constant)
(coerce->any register)))
(LAP (CMP L (@PCR ,(constant->label constant))
,(coerce->machine-register register)))))
(define (eq-test/constant*memory constant memory-reference)
(set-standard-branches! 'EQ)
(if (non-pointer-object? constant)
- (LAP ,(test-non-pointer (primitive-type constant)
- (primitive-datum constant)
+ (LAP ,(test-non-pointer (object-type constant)
+ (object-datum constant)
memory-reference))
(let ((temp (reference-temporary-register! false)))
(LAP (MOV L ,memory-reference ,temp)
(define (fixnum-pred/constant*register constant register cc)
(set-standard-branches! cc)
(if (non-pointer-object? constant)
- (LAP (CMPI L (& ,(primitive-datum constant)) ,(coerce->any register)))
+ (LAP (CMPI L (& ,(object-datum constant)) ,(coerce->any register)))
(LAP (CMP L (@PCR ,(constant->label constant))
,(coerce->machine-register register)))))
(define (fixnum-pred/constant*memory constant memory-reference cc)
(set-standard-branches! cc)
(if (non-pointer-object? constant)
- (LAP (CMPI L (& ,(primitive-datum constant)) ,memory-reference))
+ (LAP (CMPI L (& ,(object-datum constant)) ,memory-reference))
(let ((temp (reference-temporary-register! false)))
(LAP (MOV L ,memory-reference ,temp)
(CMP L (@PCR ,(constant->label constant))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
- (OFFSET (REGISTER (? register)) (? offset)) (CONSTANT (? constant)))
+ (OFFSET (REGISTER (? register)) (? offset))
+ (CONSTANT (? constant)))
(fixnum-pred/constant*memory constant (indirect-reference! register offset)
(fixnum-pred->cc predicate)))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
- (CONSTANT (? constant)) (OFFSET (REGISTER (? register)) (? offset)))
+ (CONSTANT (? constant))
+ (OFFSET (REGISTER (? register)) (? offset)))
(fixnum-pred/constant*memory constant (indirect-reference! register offset)
(invert-cc (fixnum-pred->cc predicate))))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
- (CONSTANT (? constant)) (POST-INCREMENT (REGISTER 15) 1))
+ (CONSTANT (? constant))
+ (POST-INCREMENT (REGISTER 15) 1))
(fixnum-pred/constant*memory constant (INST-EA (@A+ 7))
(invert-cc (fixnum-pred->cc predicate))))
(FIXNUM-PRED-1-ARG (? predicate) (CONSTANT (? constant)))
(set-standard-branches! (fixnum-pred->cc predicate))
(if (non-pointer-object? constant)
- (test-fixnum (INST-EA (& ,(primitive-datum constant))))
+ (test-fixnum (INST-EA (& ,(object-datum constant))))
(test-fixnum (INST-EA (@PCR ,(constant->label constant))))))
(define-rule predicate
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.8 1988/04/23 12:37:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.9 1988/06/14 08:48:47 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-rule statement
(INVOCATION:APPLY (? frame-size) (? continuation))
+ continuation
(LAP ,@(clear-map!)
,(load-dnw frame-size 0)
(JMP ,entry:compiler-apply)))
(define-rule statement
(INVOCATION:JUMP (? frame-size) (? continuation) (? label))
+ frame-size continuation
(LAP ,@(clear-map!)
(BRA (@PCR ,label))))
(define-rule statement
(INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
+ continuation
(LAP ,@(clear-map!)
,(load-dnw number-pushed 0)
(LEA (@PCR ,label) (A 0))
(define-rule statement
(INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
+ continuation
(LAP ,@(clear-map!)
;; The following assumes that at label there is
;; (JMP (L <entry>))
(define-rule statement
(INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension))
+ continuation
(let ((set-extension (expression->machine-register! extension a3)))
(delete-dead-registers!)
(LAP ,@set-extension
(define-rule statement
(INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name))
+ continuation
(let ((set-environment (expression->machine-register! environment d4)))
(delete-dead-registers!)
(LAP ,@set-environment
\f
(define-rule statement
(INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
+ continuation
(LAP ,@(clear-map!)
,@(if (eq? primitive compiled-error-procedure)
(LAP ,(load-dnw frame-size 0)
(? frame-size)
(? continuation)
,(make-primitive-procedure name true))
+ frame-size continuation
,(list 'LAP
(list 'UNQUOTE-SPLICING '(clear-map!))
(list 'JMP
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.2 1988/03/14 20:18:11 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.3 1988/06/14 08:48:58 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
,@clear-map
,(load-constant name (INST-EA (A 1)))
(JSR ,entry)
- ,@(make-external-label continuation-code-word (generate-label)))))))
+ ,@(make-external-label continuation-code-word
+ (generate-label)))))))
(define-rule statement
(INTERPRETER-CALL:DEFINE (? environment) (? name)
(MOV L ,reg:temp (A 2))
,(load-constant name (INST-EA (A 1)))
(JSR ,entry)
- ,@(make-external-label continuation-code-word (generate-label)))))))
+ ,@(make-external-label continuation-code-word
+ (generate-label)))))))
(define-rule statement
(INTERPRETER-CALL:DEFINE (? environment) (? name)
(CONS-POINTER (CONSTANT (? type))
(ENTRY:PROCEDURE (? label))))
- (assignment-call:cons-pointer entry:compiler-define environment name type
- label))
+ (assignment-call:cons-procedure entry:compiler-define environment name type
+ label))
(define-rule statement
(INTERPRETER-CALL:SET! (? environment) (? name)
(CONS-POINTER (CONSTANT (? type))
(ENTRY:PROCEDURE (? label))))
- (assignment-call:cons-pointer entry:compiler-set! environment name type
- label))
+ (assignment-call:cons-procedure entry:compiler-set! environment name type
+ label))
-(define (assignment-call:cons-pointer entry environment name type label)
+(define (assignment-call:cons-procedure entry environment name type label)
(let ((set-environment (expression->machine-register! environment a0)))
(LAP ,@set-environment
,@(clear-map!)
,@set-value
,@clear-map
(JSR ,entry:compiler-assignment-trap)
- ,@(make-external-label continuation-code-word (generate-label)))))))
+ ,@(make-external-label continuation-code-word
+ (generate-label)))))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension)
,@clear-map
(MOV L ,reg:temp (A 1))
(JSR ,entry:compiler-assignment-trap)
- ,@(make-external-label continuation-code-word (generate-label)))))))
+ ,@(make-external-label continuation-code-word
+ (generate-label)))))))
(define-rule statement
- (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension)
- (CONS-POINTER (CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
+ (INTERPRETER-CALL:CACHE-ASSIGNMENT
+ (? extension)
+ (CONS-POINTER (CONSTANT (? type))
+ (ENTRY:PROCEDURE (? label))))
(let ((set-extension (expression->machine-register! extension a0)))
(LAP ,@set-extension
,@(clear-map!)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/regset.scm,v 1.1 1987/06/26 02:21:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/regset.scm,v 1.2 1988/06/14 08:36:51 cph Rel $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
(define-integrable (make-regset n-registers)
+ n-registers
(list 'REGSET))
(define-integrable (regset-allocate n-registers)
+ n-registers
(list 'REGSET))
(define-integrable (for-each-regset-member regset procedure)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.8 1988/05/19 15:22:46 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.9 1988/06/14 08:37:00 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;; times, then all of those assignments should be
;; address valued expressions. This constraint is not
;; enforced.
- (add-rgraph-address-register! *current-rgraph*
- (rtl:register-number address)))
+ (add-rgraph-address-register!
+ *current-rgraph*
+ (rtl:register-number address)))
((rtl:fixnum-valued-expression? expression)
;; We don't know for sure that this register is assigned
;; only once. However, if it is assigned multiple
;; times, then all of those assignments should be
;; fixnum valued expressions. This constraint is not
;; enforced.
- (add-rgraph-fixnum-register! *current-rgraph*
- (rtl:register-number address)))))
+ (add-rgraph-fixnum-register!
+ *current-rgraph*
+ (rtl:register-number address)))))
(%make-assign address expression))))))
(define (rtl:make-eq-test expression-1 expression-2)
(lambda (register)
(receiver register offset granularity))
(lambda (register offset* granularity*)
- (receiver (make-offset register offset* granularity*) offset granularity))))
+ (receiver (make-offset register offset* granularity*)
+ offset
+ granularity))))
(define (guarantee-address expression scfg-append! receiver)
(if (rtl:address-valued-expression? expression)
(receiver expression)
(assign-to-temporary expression scfg-append! receiver)))
-(define (generate-offset-address expression offset granularity scfg-append! receiver)
+(define (generate-offset-address expression offset granularity scfg-append!
+ receiver)
(if (eq? granularity 'OBJECT)
(guarantee-address expression scfg-append!
(lambda (address)
(lambda (receiver scfg-append! locative)
(locative-dereference-1 locative scfg-append! locative-fetch-1
(lambda (register)
+ register
(error "Can't take ADDRESS of a register" locative))
(generator receiver scfg-append!))))
(define-expression-method 'TYPED-CONS:PROCEDURE
(lambda (receiver scfg-append! type entry min max size)
+ scfg-append!
(receiver (rtl:make-typed-cons:procedure type entry min max size))))
\f
(define (object-selector make-object-selector)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.2 1987/12/30 07:07:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.3 1988/06/14 08:37:09 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(else (bblock-linearize-rtl bblock))))
(define (linearize-pblock pblock predicate cn an)
+ pblock
(if (node-marked? cn)
(if (node-marked? an)
`(,(rtl:make-jumpc-statement predicate (bblock-label! cn))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.2 1987/12/30 07:07:44 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.3 1988/06/14 08:37:16 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(conc-name rtl-expr/)
(constructor make-rtl-expr (rgraph label entry-edge))
(print-procedure
- (standard-unparser 'RTL-EXPR
- (lambda (expression)
- (write (rtl-expr/label expression))))))
+ (standard-unparser "RTL-EXPR"
+ (lambda (state expression)
+ (unparse-object state (rtl-expr/label expression))))))
(rgraph false read-only true)
(label false read-only true)
(entry-edge false read-only true))
(rgraph label entry-edge name n-required
n-optional rest? closure? type))
(print-procedure
- (standard-unparser 'RTL-PROCEDURE
- (lambda (procedure)
- (write (rtl-procedure/label procedure))))))
+ (standard-unparser "RTL-PROCEDURE"
+ (lambda (state procedure)
+ (unparse-object state
+ (rtl-procedure/label procedure))))))
(rgraph false read-only true)
(label false read-only true)
(entry-edge false read-only true)
(constructor make-rtl-continuation
(rgraph label entry-edge))
(print-procedure
- (standard-unparser 'RTL-CONTINUATION
- (lambda (continuation)
- (write (rtl-continuation/label continuation))))))
+ (standard-unparser "RTL-CONTINUATION" (lambda (state continuation)
+ (unparse-object
+ state
+ (rtl-continuation/label continuation))))))
(rgraph false read-only true)
(label false read-only true)
(entry-edge false read-only true))
procedure))
procedures)
(for-each (lambda (continuation)
- (symbol-hash-table/insert! hash-table
- (rtl-continuation/label continuation)
- continuation))
+ (symbol-hash-table/insert!
+ hash-table
+ (rtl-continuation/label continuation)
+ continuation))
continuations)
(make/label->object* hash-table)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.4 1988/05/09 19:51:06 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.5 1988/06/14 08:37:23 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-integrable rtl:test-expression second)
(define (rtl:make-constant value)
- (if (scode/unassigned-object? value)
+ (if (unassigned-reference-trap? value)
(rtl:make-unassigned)
(%make-constant value)))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.6 1988/03/31 21:39:16 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.7 1988/06/14 08:42:14 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (find-known-variable block variable offset)
(find-variable block variable offset identity-procedure
(lambda (environment name)
+ environment
(error "Known variable found in IC frame" name))
(lambda (name)
(error "Known variable found in IC frame" name))))
(find-variable-internal block variable offset
identity-procedure
(lambda (block locative)
+ block locative
(error "Closure variable in IC frame" variable))))
(define (find-variable-internal block variable offset if-compiler if-ic)
(define (find-definition-variable block lvalue offset)
(find-block/variable block lvalue offset
(lambda (offset-locative)
+ offset-locative
(lambda (block locative)
+ block locative
(error "Definition of compiled variable" lvalue)))
(lambda (block locative)
+ block
(return-2 locative (variable-name lvalue)))))
(define (find-block/variable block variable offset if-known if-ic)
(transmit-values
(find-block/loop start-block (find-block/same-block? end-block) locative)
(lambda (end-block locative)
+ end-block
locative)))
\f
(define (internal-block/parent-locative block locative)
;; This value should make anyone trying to look at it crash.
(define (trivial-closure/bogus-locative block locative)
+ block locative
'TRIVIAL-CLOSURE-BOGUS-LOCATIVE)
(define (closure-block/parent-locative block locative)
+ block
(rtl:make-fetch
(rtl:locative-offset locative
closure-block-first-offset)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.7 1988/05/19 15:10:36 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.8 1988/06/14 08:42:24 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(inliner/operands inliner))))
(make-return-operand
(lambda (offset)
+ offset
((vector-ref handler 1) generator expressions))
(lambda (offset finish)
+ offset
((vector-ref handler 2) generator
expressions
finish))
(lambda (offset finish)
+ offset
((vector-ref handler 3) generator
expressions
finish))
(finish (rtl:make-fetch temporary)))))))
(define (invoke/value->effect generator expressions)
+ generator expressions
(make-null-cfg))
(define (invoke/value->predicate generator expressions finish)
(set! name->open-coders
(cons (cons name item) name->open-coders)))))))
(lambda (name handler)
- (if (pair? name)
+ (if (list? name)
(for-each (lambda (name)
(per-name name handler))
name)
(define-open-coder/predicate 'NULL?
(lambda (operands)
+ operands
(return-2 (lambda (expressions finish)
(finish (pcfg-invert (rtl:make-true-test (car expressions)))))
'(0))))
(lambda (name type)
(define-open-coder/predicate name
(lambda (operands)
+ operands
(return-2 (open-code/type-test type) '(0)))))))
(define/type-test 'PAIR? (ucode-type pair))
(define/type-test 'STRING? (ucode-type string))
(define/type-test 'BIT-STRING? (ucode-type vector-1b)))
- (define-open-coder/predicate 'PRIMITIVE-TYPE?
+ (define-open-coder/predicate 'OBJECT-TYPE?
(lambda (operands)
(filter/nonnegative-integer (car operands)
(lambda (type)
(finish (rtl:make-eq-test (car expressions) (cadr expressions))))))
(define-open-coder/predicate 'EQ?
(lambda (operands)
+ operands
(return-2 open-code/eq-test '(0 1)))))
\f
(let ((open-code/pair-cons
(define-open-coder/value 'CONS
(lambda (operands)
+ operands
(return-2 (open-code/pair-cons (ucode-type pair)) '(0 1))))
(define-open-coder/value 'SYSTEM-PAIR-CONS
(lambda (name index)
(define-open-coder/value name
(lambda (operands)
+ operands
(return-2 (open-code/memory-length index) '(0)))))))
(define/length '(VECTOR-LENGTH SYSTEM-VECTOR-SIZE) 0)
(define/length '(STRING-LENGTH BIT-STRING-LENGTH) 1)))
(lambda (name index)
(define-open-coder/value name
(lambda (operands)
+ operands
(return-2 (open-code/memory-ref/constant index) '(0)))))))
(define/ref '(CAR SYSTEM-PAIR-CAR CELL-CONTENTS SYSTEM-HUNK3-CXR0) 0)
(define/ref '(CDR SYSTEM-PAIR-CDR SYSTEM-HUNK3-CXR1) 1)
good-constant-index
(return-2 open-code/memory-ref/non-constant
'(0 1)))))))
-\f
+
(let ((open-code/general-car-cdr
(lambda (pattern)
(lambda (expressions finish)
(filter/positive-integer (cadr operands)
(lambda (pattern)
(return-2 (open-code/general-car-cdr pattern) '(0)))))))
-
+\f
(let ((open-code/memory-assignment
(lambda (index locative-generator)
(lambda (expressions finish)
lvalue-locative
index)))
(let ((assignment
- (rtl:make-assignment locative (car (last-pair expressions)))))
+ (rtl:make-assignment locative
+ (car (last-pair expressions)))))
(if finish
(let ((temporary (rtl:make-pseudo-register)))
(scfg-append!
- (rtl:make-assignment temporary (rtl:make-fetch locative))
+ (rtl:make-assignment temporary
+ (rtl:make-fetch locative))
assignment
(finish (rtl:make-fetch temporary))))
assignment)))))))))
+ ;; For now SYSTEM-XXXX side effect procedures are considered
+ ;; dangerous to the garbage collector's health. Some day we will
+ ;; again be able to enable them.
+
(let ((define/set!
(lambda (name index)
(define-open-coder/effect name
(lambda (operands)
+ operands
(return-2 (open-code/memory-assignment index
(lambda (exp finish)
(finish (car exp))))
'(0 1)))))))
-;;; For now SYSTEM-XXXX procedures with side effects are considered
-;;; dangerous to the garbage collectors health. Some day we will again
-;;; be able to do the following:
-;;; (define/set! '(SET-CAR! SYSTEM-PAIR-SET-CAR!
-;;; SET-CELL-CONTENTS!
-;;; SYSTEM-HUNK3-SET-CXR0!)
-;;; 0)
-;;; (define/set! '(SET-CDR! SYSTEM-PAIR-SET-CDR!
-;;; SYSTEM-HUNK3-SET-CXR1!) 1)
-;;; (define/set! 'SYSTEM-HUNK3-SET-CXR2!
-;;; 2))
- (define/set! '(SET-CAR! SET-CELL-CONTENTS!) 0)
- (define/set! '(SET-CDR!) 1))
-
-
-;;; For now SYSTEM-XXXX procedures with side effects are considered
-;;; dangerous to the garbage collectors health. Some day we will again
-;;; be able to do the following:
-;;; (define-open-coder-effect '(vECTOR-SET! SYSTEM-VECTOR-SET!)
-
- (define-open-coder/effect '(VECTOR-SET!)
+ (define/set! '(SET-CAR!
+ SET-CELL-CONTENTS!
+ #| SYSTEM-PAIR-SET-CAR! |#
+ #| SYSTEM-HUNK3-SET-CXR0! |#)
+ 0)
+ (define/set! '(SET-CDR!
+ #| SYSTEM-PAIR-SET-CDR! |#
+ #| SYSTEM-HUNK3-SET-CXR1! |#)
+ 1)
+ (define/set! '(#| SYSTEM-HUNK3-SET-CXR2! |#)
+ 2))
+
+ (define-open-coder/effect '(VECTOR-SET! #| SYSTEM-VECTOR-SET! |#)
(lambda (operands)
- (let ((good-constant-index
- (filter/nonnegative-integer (cadr operands)
- (lambda (index)
- (return-2 (open-code/memory-assignment
- (1+ index)
- (lambda (exp finish)
- (finish (car exp))))
- '(0 2))))))
- (if good-constant-index
- good-constant-index
- (return-2 (open-code/memory-assignment
- 1
- (lambda (expressions finish)
- (let ((temporary (rtl:make-pseudo-register)))
- (scfg-append!
- (rtl:make-assignment
- temporary
- (rtl:make-fixnum-2-args
- 'PLUS-FIXNUM
- (rtl:make-object->address (car expressions))
- (rtl:make-fixnum-2-args
- 'MULTIPLY-FIXNUM
- (rtl:make-object->fixnum
- (rtl:make-constant
- (quotient scheme-object-width
- addressing-granularity)))
- (rtl:make-object->fixnum
- (cadr expressions)))))
- (finish (rtl:make-fetch temporary))))))
- '(0 1 2)))))))
-
+ (or (filter/nonnegative-integer (cadr operands)
+ (lambda (index)
+ (return-2 (open-code/memory-assignment
+ (1+ index)
+ (lambda (exp finish)
+ (finish (car exp))))
+ '(0 2))))
+ (return-2 (open-code/memory-assignment
+ 1
+ (lambda (expressions finish)
+ (let ((temporary (rtl:make-pseudo-register)))
+ (scfg-append!
+ (rtl:make-assignment
+ temporary
+ (rtl:make-fixnum-2-args
+ 'PLUS-FIXNUM
+ (rtl:make-object->address (car expressions))
+ (rtl:make-fixnum-2-args
+ 'MULTIPLY-FIXNUM
+ (rtl:make-object->fixnum
+ (rtl:make-constant
+ (quotient scheme-object-width
+ addressing-granularity)))
+ (rtl:make-object->fixnum
+ (cadr expressions)))))
+ (finish (rtl:make-fetch temporary))))))
+ '(0 1 2))))))
+\f
(let ((define-fixnum-2-args
(lambda (fixnum-operator)
(define-open-coder/value fixnum-operator
(lambda (operands)
+ operands
(return-2
(lambda (expressions finish)
(finish (rtl:make-fixnum->object
(for-each
define-fixnum-2-args
'(PLUS-FIXNUM MINUS-FIXNUM MULTIPLY-FIXNUM
- ;; DIVIDE-FIXNUM GCD-FIXNUM
- )))
+ #| DIVIDE-FIXNUM GCD-FIXNUM |#)))
(let ((define-fixnum-1-arg
(lambda (fixnum-operator)
(define-open-coder/value fixnum-operator
(lambda (operand)
+ operand
(return-2
(lambda (expressions finish)
(finish (rtl:make-fixnum->object
(lambda (fixnum-pred)
(define-open-coder/predicate fixnum-pred
(lambda (operands)
+ operands
(return-2
(lambda (expressions finish)
(finish (rtl:make-fixnum-pred-2-args
(lambda (fixnum-pred)
(define-open-coder/predicate fixnum-pred
(lambda (operand)
+ operand
(return-2
(lambda (expressions finish)
(finish (rtl:make-fixnum-pred-1-arg
(lambda (character->fixnum rtl:coercion)
(define-open-coder/value character->fixnum
(lambda (operand)
+ operand
(return-2 (lambda (expressions finish)
(finish (rtl:make-cons-pointer
(rtl:make-constant (ucode-type fixnum))
(finish (rtl:make-cons-pointer
(rtl:make-constant (ucode-type character))
(rtl:make-fetch
- (rtl:locative-byte-offset (car expressions)
- (+ string-header-size index))))))
+ (rtl:locative-byte-offset
+ (car expressions)
+ (+ string-header-size index))))))
'(0))))))
(define-open-coder/effect 'STRING-SET!
(if finish
(let ((temporary (rtl:make-pseudo-register)))
(scfg-append!
- (rtl:make-assignment temporary
- (rtl:make-cons-pointer
- (rtl:make-constant (ucode-type character))
- (rtl:make-fetch locative)))
+ (rtl:make-assignment
+ temporary
+ (rtl:make-cons-pointer
+ (rtl:make-constant (ucode-type character))
+ (rtl:make-fetch locative)))
assignment
(finish (rtl:make-fetch temporary))))
assignment)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.4 1988/03/14 20:53:42 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.5 1988/06/14 08:42:37 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
((OPEN-EXTERNAL) (finish invocation/jump true))
((OPEN-INTERNAL) (finish invocation/jump false))
((CLOSURE)
- ;; *** For the time being, known lexpr closures are invoked through
- ;; apply. This makes the code simpler and probably does not matter
- ;; much. ***
+ ;; *** For the time being, known lexpr closures are
+ ;; invoked through apply. This makes the code
+ ;; simpler and probably does not matter much. ***
(if (procedure-rest callee)
(finish invocation/apply true)
(finish invocation/jump true)))
(procedure-label callee)))))))
(define (invocation/apply operator offset frame-size continuation prefix)
+ operator
(invocation/apply* offset frame-size continuation prefix))
(define (invocation/apply* offset frame-size continuation prefix)
(scfg*scfg->scfg! (prefix offset frame-size) (prefix* offset frame-size))))
(define (prefix/null offset frame-size)
+ offset frame-size
(make-null-cfg))
\f
(define (generate/link-prefix block callee continuation callee-external?)
(reduction-continuation/popping-limit continuation)))))
(define (link-prefix/subproblem offset frame-size)
+ offset
(rtl:make-assignment
register:dynamic-link
(rtl:make-address
(define (link-prefix/reduction block block*)
(lambda (offset frame-size)
+ frame-size
(rtl:make-assignment register:dynamic-link
(popping-limit/locative block offset block* 0))))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.2 1987/12/30 07:10:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.3 1988/06/14 08:42:48 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (trivial-return-operand operand)
(make-return-operand
(lambda (offset)
+ offset
(make-null-cfg))
(lambda (offset finish)
(generate/rvalue operand offset scfg*scfg->scfg!
d3 1
a4 1
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.6 1988/04/21 06:58:23 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.7 1988/06/14 08:42:56 cph Exp $
#| -*-Scheme-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.6 1988/04/21 06:58:23 jinx Exp $
+Copyright (c) 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.7 1988/06/14 08:42:56 cph Exp $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
(return-2 (scfg*scfg->scfg! prefix (rtl:make-assignment register result))
(rtl:make-fetch register))))
(values (scfg*scfg->scfg! prefix assignment) reference))
+#|
(define-integrable (expression-value/transform expression-value transform)
(transmit-values expression-value
(lambda (prefix expression)
(return-2 prefix (transform expression)))))
+|#
\f
result
(lambda (constant offset)
(loop (cdr entries)
(scfg*scfg->scfg!
(rtl:make-assignment
- (cond ;; This is a waste. It should be integrated.
+ (cond ;; This is a waste.
+ ;; It should be integrated.
((and value
(rvalue/procedure? value)
(procedure/closure? value)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.3 1988/03/14 20:55:03 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.4 1988/06/14 08:43:06 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(generate/rvalue operand offset scfg*scfg->scfg!
(lambda (expression)
(rtl:make-assignment register expression))))
-\f
+
(define (generate/continuation-cons block continuation)
+ block
(let ((closing-block (continuation/closing-block continuation)))
(scfg*scfg->scfg!
(if (ic-block? closing-block)
(generate/node consequent)
(generate/node alternative)))
((and (rvalue/constant? value)
- (scode/unassigned-object? (constant-value value)))
+ (unassigned-reference-trap? (constant-value value)))
(generate/node consequent))
(else
(generate/node alternative))))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.4 1988/03/14 20:55:24 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.5 1988/06/14 08:43:15 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(*queued-procedures* '())
(*queued-continuations* '()))
(set! *rtl-expression* (generate/expression expression))
- (queue-map! *generation-queue* (lambda (thunk) (thunk)))
+ (queue-map!/unsafe *generation-queue* (lambda (thunk) (thunk)))
(set! *rtl-graphs*
(list-transform-positive (reverse! *rtl-graphs*)
(lambda (rgraph)
(define (enqueue-procedure! procedure)
(if (not (memq procedure *queued-procedures*))
(begin
- (enqueue! *generation-queue*
- (lambda ()
- (set! *rtl-procedures*
- (cons (generate/procedure procedure)
- *rtl-procedures*))))
+ (enqueue!/unsafe *generation-queue*
+ (lambda ()
+ (set! *rtl-procedures*
+ (cons (generate/procedure procedure)
+ *rtl-procedures*))))
(set! *queued-procedures* (cons procedure *queued-procedures*)))))
(define (enqueue-continuation! continuation)
(if (not (memq continuation *queued-continuations*))
(begin
- (enqueue! *generation-queue*
- (lambda ()
- (set! *rtl-continuations*
- (cons (generate/continuation continuation)
- *rtl-continuations*))))
+ (enqueue!/unsafe *generation-queue*
+ (lambda ()
+ (set! *rtl-continuations*
+ (cons (generate/continuation continuation)
+ *rtl-continuations*))))
(set! *queued-continuations*
(cons continuation *queued-continuations*)))))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.14 1988/04/12 18:42:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.15 1988/06/14 08:43:53 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(let ((conflict-matrix
(make-initialized-vector next-renumber
(lambda (i)
+ i
(make-regset next-renumber)))))
(for-each (lambda (bblock)
(let ((live (make-regset next-renumber)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.4 1988/04/26 18:56:24 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.5 1988/06/14 08:44:38 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(for-each increment-register-live-length! dead)
(set-rinst-dead-registers!
next
- (eqv-set-union dead
- (delv! register
- (rinst-dead-registers next)))))
+ (eqv-set-union
+ dead
+ (delv! register (rinst-dead-registers next)))))
(for-each-regset-member live
- decrement-register-live-length!)
+ decrement-register-live-length!)
(rtl:modify-subexpressions
(rinst-rtl next)
(lambda (expression set-expression!)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.9 1988/06/03 23:54:57 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.10 1988/06/14 08:44:03 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(walk-bblock (cdr entry))))
((not (queue-empty? *initial-queue*))
(state/reset!)
- (walk-bblock (dequeue! *initial-queue*)))))
+ (walk-bblock (dequeue!/unsafe *initial-queue*)))))
(define-structure (state (type vector) (conc-name state/))
(register-tables false read-only true)
(if (walk-next? consequent)
(if (walk-next? alternative)
(if (node-previous>1? consequent)
- (begin (enqueue! *initial-queue* consequent)
+ (begin (enqueue!/unsafe *initial-queue* consequent)
(walk-next alternative))
(begin (if (node-previous>1? alternative)
- (enqueue! *initial-queue* alternative)
+ (enqueue!/unsafe *initial-queue* alternative)
(set! *branch-queue*
(cons (cons (state/get) alternative)
*branch-queue*)))
(let ((address (expression-canonicalize address)))
(rtl:set-assign-address! statement address)
(full-expression-hash address
- (lambda (hash volatile?* in-memory?*)
+ (lambda (hash volatile?* in-memory?)
+ in-memory?
(let ((memory-invalidate!
(cond ((stack-push/pop? address)
(lambda () 'DONE))
(memory-invalidate!)
(insert-memory-destination! address element false)))
|#
+ hash
(insert-source!)
(memory-invalidate!)
(mention-registers! address))
rtl:type-test-expression rtl:set-unassigned-test-expression!)
\f
(define (method/noop statement)
+ statement
'DONE)
(define-cse-method 'POP-RETURN method/noop)
(define-cse-method 'CONS-CLOSURE
(lambda (statement)
+ statement
(expression-invalidate! (interpreter-register:enclose))))
\f
(define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.7 1988/06/03 14:56:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.8 1988/06/14 08:44:13 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (expression-hash expression)
(full-expression-hash expression
(lambda (hash do-not-record? hash-arg-in-memory?)
+ do-not-record? hash-arg-in-memory?
hash)))
(define (full-expression-hash expression receiver)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.3 1988/06/03 14:58:15 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.4 1988/06/14 08:44:22 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-structure (element
(constructor %make-element)
(constructor make-element (expression))
- (print-procedure (standard-unparser 'ELEMENT false)))
- (expression false read-only true)
+ (print-procedure (standard-unparser "ELEMENT" false))) (expression false read-only true)
(cost false)
(in-memory? false)
(next-hash false)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 4.1 1987/12/08 13:55:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 4.2 1988/06/14 08:44:30 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
(define-structure (quantity
(copier quantity-copy)
- (print-procedure (standard-unparser 'QUANTITY false)))
- (number false read-only true)
+ (print-procedure (standard-unparser "QUANTITY" false))) (number false read-only true)
(first-register false)
(last-register false))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.58 1987/08/07 17:08:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.59 1988/06/14 08:44:45 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define (mark-set-registers! needed dead rtl bblock)
;; **** This code safely ignores PRE-INCREMENT and POST-INCREMENT
;; modes, since they are only used on the stack pointer.
+ needed
(if (rtl:assign? rtl)
(let ((address (rtl:assign-address rtl)))
(if (interesting-register? address)
projects / mit-scheme.git / commitdiff