#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.2 1987/12/30 06:44:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.3 1987/12/31 08:51:44 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(let ((inliner (combination/inliner combination)))
(let ((operands
(list-filter-indices (cdr subproblems) (inliner/operands inliner))))
- (set-inliner/operands! inliner (map subproblem-continuation operands))
+ (set-inliner/operands! inliner operands)
(order-subproblems/inline (car subproblems) operands))))
(define (order-subproblems/inline operator operands)
(lambda (simple complex)
(if (null? complex)
(begin
- (set-subproblem-types! simple continuation-type/value)
+ (inline-subproblem-types! simple continuation-type/register)
(return-2 (cons operator operands) (make-null-cfg)))
(let ((push-set (cdr complex))
(value-set (cons (car complex) simple)))
- (set-subproblem-types! push-set continuation-type/push)
- (set-subproblem-types! value-set continuation-type/register)
+ (inline-subproblem-types! push-set continuation-type/push)
+ (inline-subproblem-types! value-set continuation-type/register)
(return-2 (cons operator (append! push-set value-set))
(scfg*->scfg!
(reverse!
(map (lambda (subproblem)
(make-pop (subproblem-continuation subproblem)))
push-set)))))))))
+
+(define (inline-subproblem-types! subproblems continuation-type)
+ (for-each (lambda (subproblem)
+ (set-subproblem-type!
+ subproblem
+ (if (let ((rvalue (subproblem-rvalue subproblem)))
+ (or (rvalue-known-constant? rvalue)
+ (and (rvalue/reference? rvalue)
+ (not (variable/value-variable?
+ (reference-lvalue rvalue)))
+ (reference-to-known-location? rvalue))))
+ continuation-type/effect
+ continuation-type)))
+ subproblems))
\f
(define (order-subproblems/combination/out-of-line combination subproblems)
(let ((subproblems
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.1 1987/12/30 07:05:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.2 1987/12/31 08:51:22 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(ASSIGN (POST-INCREMENT (REGISTER 13) 1) (CONSTANT (? object)))
(LAP ,(load-constant object (INST-EA (@A+ 5)))))
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 13) 1)
+ (CONS-POINTER (CONSTANT (? type)) (CONSTANT (? datum))))
+ (LAP ,(load-non-pointer type datum (INST-EA (@A+ 5)))))
+
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 13) 1) (UNASSIGNED))
(LAP ,(load-non-pointer (ucode-type unassigned) 0 (INST-EA (@A+ 5)))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.2 1987/12/30 07:07:25 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.3 1987/12/31 08:50:36 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(scfg-append! (%make-assign target cdr)
(receiver temporary)))))))))))))))
+(define-expression-method 'TYPED-CONS:VECTOR
+ (lambda (receiver scfg-append! type . elements)
+ (let ((free (interpreter-free-pointer))
+ (header
+ (rtl:make-cons-pointer
+ (rtl:make-constant (ucode-type manifest-vector))
+ (rtl:make-constant (length elements)))))
+ (let ((target (rtl:make-post-increment free 1)))
+ (expression-simplify* type scfg-append!
+ (lambda (type)
+ (let loop ((elements elements) (simplified-elements '()))
+ (if (null? elements)
+ (assign-to-temporary (rtl:make-cons-pointer type free)
+ scfg-append!
+ (lambda (temporary)
+ (scfg-append!
+ (%make-assign target header)
+ (let loop ((elements (reverse! simplified-elements)))
+ (if (null? elements)
+ (receiver temporary)
+ (scfg-append! (%make-assign target (car elements))
+ (loop (cdr elements))))))))
+ (expression-simplify* (car elements) scfg-append!
+ (lambda (element)
+ (loop (cdr elements)
+ (cons element simplified-elements))))))))))))
+\f
(define (object-selector make-object-selector)
(lambda (receiver scfg-append! expression)
(expression-simplify* expression scfg-append!
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.1 1987/12/04 20:17:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.2 1987/12/31 08:50:47 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
INVOCATION:SPECIAL-PRIMITIVE
INVOCATION:UUO-LINK)))
-(define-integrable (rtl:trivial-expression? rtl)
- (memq (rtl:expression-type rtl)
- '(REGISTER
- CONSTANT
- ENTRY:CONTINUATION
- ENTRY:PROCEDURE
- UNASSIGNED
- VARIABLE-CACHE)))
+(define (rtl:trivial-expression? expression)
+ (if (memq (rtl:expression-type expression)
+ '(REGISTER
+ CONSTANT
+ ENTRY:CONTINUATION
+ ENTRY:PROCEDURE
+ UNASSIGNED
+ VARIABLE-CACHE))
+ true
+ (and (rtl:offset? expression)
+ (interpreter-stack-pointer? (rtl:offset-register expression)))))
(define (rtl:machine-register-expression? expression)
(and (rtl:register? expression)
(lambda (x)
(and (pair? x)
(predicate x))))))
-
+\f
(define (rtl:all-subexpressions? expression predicate)
(or (rtl:constant? expression)
(for-all? (cdr expression)
(lambda (x)
(or (not (pair? x))
(predicate x))))))
-\f
+
(define (rtl:reduce-subparts expression operator initial if-expression if-not)
(let ((remap
(if (rtl:constant? expression)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.1 1987/12/04 20:18:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.2 1987/12/31 08:50:53 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-integrable (rtl:make-typed-cons:pair type car cdr)
`(TYPED-CONS:PAIR ,type ,car ,cdr))
+(define-integrable (rtl:make-typed-cons:vector type elements)
+ `(TYPED-CONS:VECTOR ,type ,@elements))
+
;;; Linearizer Support
(define-integrable (rtl:make-jump-statement label)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.2 1987/12/30 07:09:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.3 1987/12/31 08:50:06 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(else
(if-cached (variable-name variable))))))))
+(define (find-known-variable block variable offset)
+ (find-variable block variable offset identity-procedure
+ (lambda (environment name)
+ (error "Known variable found in IC frame" name))
+ (lambda (name)
+ (error "Known variable found in IC frame" name))))
+
(define (find-closure-variable block variable offset)
(find-variable-internal block variable offset
identity-procedure
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.2 1987/12/30 07:09:53 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.3 1987/12/31 08:50:13 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
;;;; Code Generator
(define-export (combination/inline combination)
- (generate/return* (combination/block combination)
- (combination/continuation combination)
- (let ((inliner (combination/inliner combination)))
- (let ((handler (inliner/handler inliner))
- (generator (inliner/generator inliner))
- (expressions
- (map (lambda (continuation)
- (rtl:make-fetch
- (continuation*/register continuation)))
- (inliner/operands inliner))))
- (make-return-operand
- (lambda (offset)
- ((vector-ref handler 1) generator expressions))
- (lambda (offset finish)
- ((vector-ref handler 2) generator
- expressions
- finish))
- (lambda (offset finish)
- ((vector-ref handler 3) generator
- expressions
- finish))
- false)))
- (node/offset combination)))
-
+ (let ((offset (node/offset combination)))
+ (generate/return* (combination/block combination)
+ (combination/continuation combination)
+ (let ((inliner (combination/inliner combination)))
+ (let ((handler (inliner/handler inliner))
+ (generator (inliner/generator inliner))
+ (expressions
+ (map (subproblem->expression offset)
+ (inliner/operands inliner))))
+ (make-return-operand
+ (lambda (offset)
+ ((vector-ref handler 1) generator expressions))
+ (lambda (offset finish)
+ ((vector-ref handler 2) generator
+ expressions
+ finish))
+ (lambda (offset finish)
+ ((vector-ref handler 3) generator
+ expressions
+ finish))
+ false)))
+ offset)))
+
+(define (subproblem->expression offset)
+ (lambda (subproblem)
+ (let ((rvalue (subproblem-rvalue subproblem)))
+ (let ((value (rvalue-known-value rvalue)))
+ (cond ((and value (rvalue/constant? value))
+ (rtl:make-constant (constant-value value)))
+ ((and (rvalue/reference? rvalue)
+ (not (variable/value-variable? (reference-lvalue rvalue)))
+ (reference-to-known-location? rvalue))
+ (rtl:make-fetch
+ (find-known-variable (reference-block rvalue)
+ (reference-lvalue rvalue)
+ offset)))
+ (else
+ (rtl:make-fetch
+ (continuation*/register
+ (subproblem-continuation subproblem)))))))))
+\f
(define (invoke/effect->effect generator expressions)
(generator expressions false))
(filter/nonnegative-integer (car operands)
(lambda (type)
(return-2 (open-code/pair-cons type) '(1 2)))))))
+
+(define-open-coder/value 'VECTOR
+ (lambda (operands)
+ (and (< (length operands) 32)
+ (return-2 (lambda (expressions finish)
+ (finish
+ (rtl:make-typed-cons:vector
+ (rtl:make-constant (ucode-type vector))
+ expressions)))
+ (all-operand-indices operands)))))
+
+(define (all-operand-indices operands)
+ (let loop ((operands operands) (index 0))
+ (if (null? operands)
+ '()
+ (cons index (loop (cdr operands) (1+ index))))))
\f
(let ((open-code/memory-length
(lambda (index)
projects / mit-scheme.git / commitdiff