#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.27 1991/05/06 22:38:06 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.28 1991/06/14 21:19:42 cph Exp $
Copyright (c) 1988-1991 Massachusetts Institute of Technology
(define (generate/combination block continuation context expression)
(scode/combination-components expression
(lambda (operator operands)
- (if (eq? not operator)
- (generate/conditional block continuation context
- (scode/make-conditional (car operands) #F #T))
- (let ((make-combination
- (lambda (push continuation)
- (make-combination
- block
- (continuation-reference block continuation)
- (wrapper/subproblem/value
- block
- continuation
- (make-continuation-debugging-info 'COMBINATION-OPERAND
- expression
- 0)
- (lambda (continuation*)
- (cond ((scode/lambda? operator)
- (generate/lambda*
- block continuation*
- context (context/unconditional context)
- operator (continuation/known-type continuation)
- false))
- ((scode/absolute-reference? operator)
- (generate/global-variable block continuation*
- context operator))
- (else
- (generate/expression block continuation*
- context operator)))))
- (let loop ((operands operands) (index 1))
- (if (null? operands)
- '()
- (cons (generate/subproblem/value
- block continuation context
- (car operands) 'COMBINATION-OPERAND
- expression index)
- (loop (cdr operands) (1+ index)))))
- push))))
- ((continuation/case continuation
- (lambda () (make-combination false continuation))
- (lambda ()
- (if (variable? continuation)
- (make-combination false continuation)
- (with-reified-continuation block
- continuation
- scfg*scfg->scfg!
- (lambda (push continuation)
+ (cond ((eq? not operator)
+ (generate/conditional block continuation context
+ (scode/make-conditional (car operands)
+ #F #T)))
+ ((and (eq? general-car-cdr operator)
+ (let ((n (cadr operands)))
+ (and (exact-integer? n)
+ (positive? n))))
+ (generate/expression
+ block continuation context
+ (let loop ((expression (car operands)) (n (cadr operands)))
+ (if (= n 1)
+ expression
+ (loop (scode/make-combination
+ (if (= (remainder n 2) 1) car cdr)
+ (list expression))
+ (quotient n 2))))))
+ (else
+ (let ((make-combination
+ (lambda (push continuation)
+ (make-combination
+ block
+ (continuation-reference block continuation)
+ (wrapper/subproblem/value
+ block
+ continuation
+ (make-continuation-debugging-info 'COMBINATION-OPERAND
+ expression
+ 0)
+ (lambda (continuation*)
+ (cond ((scode/lambda? operator)
+ (generate/lambda*
+ block continuation*
+ context (context/unconditional context)
+ operator
+ (continuation/known-type continuation)
+ false))
+ ((scode/absolute-reference? operator)
+ (generate/global-variable block continuation*
+ context operator))
+ (else
+ (generate/expression block continuation*
+ context operator)))))
+ (let loop ((operands operands) (index 1))
+ (if (null? operands)
+ '()
+ (cons (generate/subproblem/value
+ block continuation context
+ (car operands) 'COMBINATION-OPERAND
+ expression index)
+ (loop (cdr operands) (1+ index)))))
+ push))))
+ ((continuation/case continuation
+ (lambda () (make-combination false continuation))
+ (lambda ()
+ (if (variable? continuation)
+ (make-combination false continuation)
+ (with-reified-continuation block
+ continuation
+ scfg*scfg->scfg!
+ (lambda (push continuation)
+ (make-scfg
+ (cfg-entry-node
+ (make-combination push continuation))
+ (continuation/next-hooks continuation))))))
+ (lambda ()
+ (with-reified-continuation block
+ continuation
+ scfg*pcfg->pcfg!
+ (lambda (push continuation)
+ (scfg*pcfg->pcfg!
(make-scfg
(cfg-entry-node (make-combination push continuation))
- (continuation/next-hooks continuation))))))
- (lambda ()
- (with-reified-continuation block
- continuation
- scfg*pcfg->pcfg!
- (lambda (push continuation)
- (scfg*pcfg->pcfg!
- (make-scfg
- (cfg-entry-node (make-combination push continuation))
- (continuation/next-hooks continuation))
- (make-true-test block
- (continuation/rvalue continuation))))))
- (lambda ()
- (with-reified-continuation block
- continuation
- scfg*subproblem->subproblem!
- (lambda (push continuation)
- (make-subproblem/canonical
- (make-combination push continuation)
- continuation)))))))))))
+ (continuation/next-hooks continuation))
+ (make-true-test
+ block
+ (continuation/rvalue continuation))))))
+ (lambda ()
+ (with-reified-continuation block
+ continuation
+ scfg*subproblem->subproblem!
+ (lambda (push continuation)
+ (make-subproblem/canonical
+ (make-combination push continuation)
+ continuation))))))))))))
\f
;;;; Assignments
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.43 1991/06/13 18:59:29 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.44 1991/06/14 21:19:58 cph Exp $
Copyright (c) 1988-1991 Massachusetts Institute of Technology
cleanup
(if error-finish
(error-finish (rtl:make-fetch register:value))
- (make-null-cfg))))))))
+ (make-null-cfg)))
+ #|
+ ;; This code is preferable to the above
+ ;; expression in some circumstances. It
+ ;; creates a continuation, but the continuation
+ ;; is left dangling instead of being hooked
+ ;; back into the subsequent code. This avoids
+ ;; a merge in the RTL and allows the CSE to do
+ ;; a better job -- but the cost is that it
+ ;; creates a continuation that, if invoked, has
+ ;; unpredictable behavior.
+ (let ((scfg
+ (scfg*scfg->scfg!
+ (generate-primitive primitive-name
+ expressions
+ setup
+ label)
+ cleanup)))
+ (make-scfg (cfg-entry-node scfg) '()))
+ |#
+ )))))
(let loop ((checks checks))
(if (null? checks)
non-error-cfg
(pcfg*scfg->scfg! (car checks)
- (loop (cdr checks)) error-cfg)))))))
+ (loop (cdr checks))
+ error-cfg)))))))
(define (generate-primitive name argument-expressions
continuation-setup continuation-label)
(system-ref 'SYSTEM-HUNK3-CXR0 rtl:make-fetch 0)
(system-ref 'SYSTEM-HUNK3-CXR1 rtl:make-fetch 1)
(system-ref 'SYSTEM-HUNK3-CXR2 rtl:make-fetch 2))
-
-(let ((make-fixed-ref
- (lambda (name index)
- (lambda (combination expressions finish)
- (let ((expression (car expressions)))
- (open-code:with-checks
- combination
- (list (open-code:type-check expression (ucode-type pair)))
- (finish (rtl:make-fetch (rtl:locative-offset expression index)))
- finish
- name
- expressions))))))
- (let ((car-ref (make-fixed-ref 'CAR 0))
- (cdr-ref (make-fixed-ref 'CDR 1)))
- (define-open-coder/value 'GENERAL-CAR-CDR
- (filter/positive-integer
- (lambda (pattern)
- (if (= pattern 1)
- (lambda (combination expressions finish)
- combination
- (finish (car expressions)))
- (lambda (combination expressions finish)
- (let loop ((pattern pattern)
- (expression (car expressions)))
- (let ((new-pattern (quotient pattern 2)))
- ((if (odd? pattern) car-ref cdr-ref)
- combination
- (list expression)
- (if (= new-pattern 1)
- finish
- (lambda (expression)
- (loop new-pattern expression)))))))))
- 1
- '(0)
- internal-close-coding-for-type-checks))))
\f
(let ((make-ref
(lambda (name type)
projects / mit-scheme.git / commitdiff