From: Joe Marshall Date: Sat, 13 Feb 2010 21:08:53 +0000 (-0800) Subject: Reorganize procedures and use dispatch vector for handling combination operators. X-Git-Tag: 20100708-Gtk~168^2~1 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bbb2ce6b37060b1bb19511b9a304205221102d2b;p=mit-scheme.git Reorganize procedures and use dispatch vector for handling combination operators. --- diff --git a/src/sf/subst.scm b/src/sf/subst.scm index 3cb2c2613..616ba1e08 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -69,6 +69,23 @@ USA. (integrate/expression operations environment expression)) expressions)) +(define (integrate/actions operations environment actions) + (let ((action (car actions))) + (if (null? (cdr actions)) + (list (if (eq? action open-block/value-marker) + action + (integrate/expression operations environment action))) + (cons (cond ((reference? action) + ;; This clause lets you ignore a variable by + ;; mentioning it in a sequence. + (variable/may-ignore! (reference/variable action)) + action) + ((eq? action open-block/value-marker) + action) + (else + (integrate/expression operations environment action))) + (integrate/actions operations environment (cdr actions)))))) + (define (integrate/expression operations environment expression) ((expression/method dispatch-vector expression) operations environment expression)) @@ -79,8 +96,21 @@ USA. (define define-method/integrate (expression/make-method-definer dispatch-vector)) -;;;; Variables +;;;; ACCESS +(define-method/integrate 'ACCESS + (lambda (operations environment expression) + (let ((environment* (integrate/expression operations environment + (access/environment expression))) + (name (access/name expression))) + (cond ((and (constant/system-global-environment? environment*) + (assq name usual-integrations/constant-alist)) + => (lambda (entry) + (constant/make (access/scode expression) + (constant/value (cdr entry))))) + (else (access/make (access/scode expression) + environment* name)))))) +;;;; ASSIGNMENT (define-method/integrate 'ASSIGNMENT (lambda (operations environment assignment) (let ((variable (assignment/variable assignment))) @@ -92,9 +122,8 @@ USA. (warn "Attempt to assign integrated name" (variable/name variable))) (else (error "Unknown operation" operation)))) - (lambda () 'DONE)) - ;; The value of an assignment is the old value - ;; of the variable, hence, it is refernced. + false-procedure) + (variable/reference! variable) (assignment/make (assignment/scode assignment) (assignment/block assignment) @@ -103,6 +132,100 @@ USA. environment (assignment/value assignment)))))) +;;;; COMBINATION +(define-method/integrate 'COMBINATION + (lambda (operations environment combination) + (integrate/combination + combination operations environment + (combination/block combination) + (combination/operator combination) + (integrate/expressions operations + environment + (combination/operands combination))))) + +;;;; CONDITIONAL +(define-method/integrate 'CONDITIONAL + (lambda (operations environment expression) + (conditional/make + (conditional/scode expression) + (integrate/expression + operations environment + (conditional/predicate expression)) + (integrate/expression + operations environment + (conditional/consequent expression)) + (integrate/expression + operations environment + (conditional/alternative expression))))) + +;;; CONSTANT +(define-method/integrate 'CONSTANT + (lambda (operations environment expression) + (declare (ignore operations environment)) + expression)) + +;;; DECLARATION +(define-method/integrate 'DECLARATION + (lambda (operations environment declaration) + (let ((declarations (declaration/declarations declaration)) + (expression (declaration/expression declaration))) + (declaration/make + (declaration/scode declaration) + declarations + (integrate/expression (declarations/bind operations declarations) + environment + expression))))) + +;;; DELAY +(define-method/integrate 'DELAY + (lambda (operations environment expression) + (delay/make + (delay/scode expression) + (integrate/expression operations environment + (delay/expression expression))))) + + +;;; DISJUNCTION +(define-method/integrate 'DISJUNCTION + (lambda (operations environment expression) + (disjunction/make + (disjunction/scode expression) + (integrate/expression operations environment (disjunction/predicate expression)) + (integrate/expression operations environment (disjunction/alternative expression))))) + +;;; OPEN-BLOCK +(define-method/integrate 'OPEN-BLOCK + (lambda (operations environment expression) + (call-with-values + (lambda () (integrate/open-block operations environment expression)) + (lambda (operations environment expression) + (declare (ignore operations environment)) + expression)))) + +;;; PROCEDURE +(define-method/integrate 'PROCEDURE + (lambda (operations environment procedure) + (integrate/procedure operations + (simulate-unknown-application environment procedure) + procedure))) + +;;;; Quotation +(define-method/integrate 'QUOTATION + (lambda (operations environment expression) + (declare (ignore operations environment)) + (integrate/quotation expression))) + +(define (integrate/quotation quotation) + (call-with-values + (lambda () + (integrate/top-level* (quotation/scode quotation) + (quotation/block quotation) + (quotation/expression quotation))) + (lambda (operations environment expression) + operations environment ;ignore + expression))) + +;;;; Reference (define-method/integrate 'REFERENCE (lambda (operations environment expression) (let ((variable (reference/variable expression))) @@ -130,55 +253,46 @@ USA. (error "Unknown operation" operation)))) (lambda () (integration-failure))))))) - + (define (reassign expr object) (if (and expr (object/scode expr)) (with-new-scode (object/scode expr) object) object)) - -(define (integrate/reference-operator expression operations environment - block operator operands) - (let ((variable (reference/variable operator))) - (letrec ((mark-integrated! - (lambda () - (variable/integrated! variable))) - (integration-failure - (lambda () - (variable/reference! variable) - (combination/make expression block - operator operands))) - (integration-success - (lambda (operator) - (mark-integrated!) - (integrate/combination expression operations environment - block operator operands)))) - (operations/lookup operations variable - (lambda (operation info) - (case operation - ((#F) (integration-failure)) - - ((EXPAND) - (let ((new-expression (info expression operands (reference/block operator)))) - (if new-expression - (begin - (mark-integrated!) - (integrate/expression operations environment new-expression)) - (integration-failure)))) - - ((INTEGRATE INTEGRATE-OPERATOR) - (let ((new-expression (integrate/name expression - operator info environment))) - (if new-expression - (integration-success new-expression) - (integration-failure)))) - - (else - (error "Unknown operation" operation)))) - (lambda () - (integration-failure)))))) + +;;; SEQUENCE +(define-method/integrate 'SEQUENCE + (lambda (operations environment expression) + ;; Optimize (begin (foo)) => (foo) + ;; Optimize (begin a b (foo) 22 (bar)) => (begin (foo) (bar)) + (sequence/optimizing-make + expression + (integrate/actions operations environment + (sequence/actions expression))))) + +;;; THE-ENVIRONMENT +(define-method/integrate 'THE-ENVIRONMENT + (lambda (operations environment expression) + operations + environment + expression)) + ;;;; Binding +;;; If not #f, display the top-level procedure names as they are +;;; processed. Useful for debugging. +(define sf:display-top-level-procedure-names? #f) + +(define (maybe-displaying-name name thunk) + (if (and sf:display-top-level-procedure-names? + (null? *current-block-names*)) + (with-notification + (lambda (port) + (write-string "Integrating procedure " port) + (write name port)) + thunk) + (thunk))) + (define (integrate/open-block operations environment expression) (let ((variables (open-block/variables expression)) (block (open-block/block expression))) @@ -213,40 +327,12 @@ USA. block variables vals actions)))))))) -(define-method/integrate 'OPEN-BLOCK - (lambda (operations environment expression) - (call-with-values - (lambda () (integrate/open-block operations environment expression)) - (lambda (operations environment expression) - operations environment - expression)))) - (define (variable/unreferenced? variable) (and (not (variable/integrated variable)) (not (variable/referenced variable)) (not (variable/may-ignore? variable)) (not (variable/must-ignore? variable)))) -(define-method/integrate 'PROCEDURE - (lambda (operations environment procedure) - (integrate/procedure operations - (simulate-unknown-application environment procedure) - procedure))) - -;;; If not #f, display the top-level procedure names as they are -;;; processed. Useful for debugging. -(define sf:display-top-level-procedure-names? #f) - -(define (maybe-displaying-name name thunk) - (if (and sf:display-top-level-procedure-names? - (null? *current-block-names*)) - (with-notification - (lambda (port) - (write-string "Integrating procedure " port) - (write name port)) - thunk) - (thunk))) - (define (integrate/procedure operations environment procedure) (let ((block (procedure/block procedure)) (name (procedure/name procedure)) @@ -285,58 +371,132 @@ USA. rest body))))))) -(define-method/integrate 'COMBINATION - (lambda (operations environment combination) - (integrate/combination - combination operations environment - (combination/block combination) - (combination/operator combination) - (integrate/expressions operations - environment - (combination/operands combination))))) + +;;; INTEGRATE-COMBINATION +(define integrate-combination-dispatch-vector + (expression/make-dispatch-vector)) + +(define define-method/integrate-combination + (expression/make-method-definer integrate-combination-dispatch-vector)) (define (integrate/combination expression operations environment block operator operands) - (cond ((reference? operator) - (integrate/reference-operator expression operations environment - block operator operands)) - ((and (access? operator) - (constant/system-global-environment? - (integrate/expression operations environment (access/environment operator)))) - (integrate/access-operator expression operations environment - block operator operands)) - ((and (constant? operator) - (primitive-procedure? (constant/value operator))) - (let ((operands* - (and (eq? (constant/value operator) (ucode-primitive apply)) - (integrate/hack-apply? operands)))) - (if operands* - (integrate/combination expression operations environment - block (car operands*) (cdr operands*)) - (integrate/primitive-operator expression operations environment - block operator operands)))) - (else - (combination/make - expression - block - (let* ((integrate-procedure - (lambda (operator) - (integrate/procedure-operator operations environment - block operator operands))) - (operator - (if (procedure? operator) - (integrate-procedure operator) - (let ((operator - (integrate/expression operations - environment - operator))) - (if (procedure? operator) - (integrate-procedure operator) - operator))))) - (cond ((integrate/compound-operator operator operands) - => integrate-procedure) - (else operator))) - operands)))) + ((expression/method integrate-combination-dispatch-vector operator) + expression operations environment block operator operands)) + +;;;; access-operator +(define-method/integrate-combination 'ACCESS + (lambda (expression operations environment block operator operands) + (integrate/access-operator expression operations environment + block operator operands))) + +(define (integrate/access-operator expression operations environment block operator operands) + (let ((name (access/name operator)) + (environment* + (integrate/expression operations environment (access/environment operator)))) + + (define (dont-integrate) + (combination/make + expression block + (access/make (access/scode operator) environment* name) operands)) + + (if (not (constant/system-global-environment? environment*)) + (dont-integrate) + (operations/lookup-global + operations name + (lambda (operation info) + (case operation + ((#F) (dont-integrate)) + + ((EXPAND) + (cond ((info expression operands (reference/block operator)) + => (lambda (new-expression) + (integrate/expression operations environment new-expression))) + (else (dont-integrate)))) + + ((INTEGRATE INTEGRATE-OPERATOR) + (let ((new-operator + (reassign operator + (copy/expression/intern block (integration-info/expression info))))) + (integrate/combination expression operations environment block new-operator operands))) + + (else + (error "unknown operation" operation)))) + dont-integrate)))) + +;;; assignment-operator +(define-method/integrate-combination 'ASSIGNMENT + (lambda (expression operations environment block operator operands) + (warn "Value of assignment used as an operator.") + ;; We don't try to make sense of this, we just + ;; build the code and let the runtime raise an error. + (combination/make expression + block + (integrate/expression operations environment operator) + operands))) + +;;; combination-operator +(define-method/integrate-combination 'COMBINATION + (lambda (expression operations environment block operator operands) + (integrate-combination/default expression operations environment block operator operands))) + +;;; conditional-operator +(define-method/integrate-combination 'CONDITIONAL + (lambda (expression operations environment block operator operands) + (integrate-combination/default expression operations environment block operator operands))) + +;;; constant-operator +(define-method/integrate-combination 'CONSTANT + (lambda (expression operations environment block operator operands) + (if (primitive-procedure? (constant/value operator)) + (let ((operands* + (and (eq? (constant/value operator) (ucode-primitive apply)) + (integrate/hack-apply? operands)))) + (if operands* + (integrate/combination expression operations environment + block (car operands*) (cdr operands*)) + (integrate/primitive-operator expression operations environment + block operator operands))) + (begin + (warn "Application of constant value" (constant/value operator)) + (integrate-combination/default expression operations environment block operator operands))))) + +(define (integrate/primitive-operator expression operations environment + block operator operands) + (declare (ignore operations environment)) + (combination/make expression block operator operands)) + +;;; declaration-operator +(define-method/integrate-combination 'DECLARATION + (lambda (expression operations environment block operator operands) + (integrate-combination/default expression operations environment block operator operands))) + +;;; delay-operator +(define-method/integrate-combination 'DELAY + (lambda (expression operations environment block operator operands) + ;; Nonsense - generate a warning. + (warn "Delayed object in operator position. This will cause a runtime error.") + (combination/make expression + block + (integrate/expression operations environment operator) + operands))) + +;;; disjunction-operator +(define-method/integrate-combination 'DISJUNCTION + (lambda (expression operations environment block operator operands) + (integrate-combination/default expression operations environment block operator operands))) + +;;; open-block-operator +(define-method/integrate-combination 'OPEN-BLOCK + (lambda (expression operations environment block operator operands) + (declare (ignore expression operations environment block operator operands)) + ;; This shouldn't be possible. + (error "INTERNAL-ERROR: integrate-combination 'open-block"))) + +;;; procedure-operator (let) +(define-method/integrate-combination 'PROCEDURE + (lambda (expression operations environment block operator operands) + (integrate-combination/default expression operations environment block operator operands))) (define (integrate/procedure-operator operations environment block procedure operands) @@ -345,10 +505,122 @@ USA. procedure operands) procedure)) -(define (integrate/primitive-operator expression operations environment +;;; quotation-operator +(define-method/integrate-combination 'QUOTATION + (lambda (expression operations environment block operator operands) + (integrate-combination/default expression operations environment block operator operands))) + +;;; reference-operator +(define-method/integrate-combination 'REFERENCE + (lambda (expression operations environment block operator operands) + (integrate/reference-operator expression operations environment + block operator operands))) + +(define (integrate/reference-operator expression operations environment block operator operands) - (declare (ignore operations environment)) - (combination/make expression block operator operands)) + (let ((variable (reference/variable operator))) + (letrec ((mark-integrated! + (lambda () + (variable/integrated! variable))) + (integration-failure + (lambda () + (variable/reference! variable) + (combination/make expression block + operator operands))) + (integration-success + (lambda (operator) + (mark-integrated!) + (integrate/combination expression operations environment + block operator operands)))) + (operations/lookup operations variable + (lambda (operation info) + (case operation + ((#F) (integration-failure)) + + ((EXPAND) + (let ((new-expression (info expression operands (reference/block operator)))) + (if new-expression + (begin + (mark-integrated!) + (integrate/expression operations environment new-expression)) + (integration-failure)))) + + ((INTEGRATE INTEGRATE-OPERATOR) + (let ((new-expression (integrate/name expression + operator info environment))) + (if new-expression + (integration-success new-expression) + (integration-failure)))) + + (else + (error "Unknown operation" operation)))) + (lambda () + (integration-failure)))))) + +;;; sequence-operator +(define-method/integrate-combination 'SEQUENCE + (lambda (expression operations environment block operator operands) + (integrate-combination/default expression operations environment block operator operands))) + +;;; the-environment-operator +(define-method/integrate-combination 'THE-ENVIRONMENT + (lambda (expression operations environment block operator operands) + (warn "(THE-ENVIRONMENT) used as an operator. Will cause a runtime error.") + (combination/make expression block + (integrate/expression operations environment operator) + operands))) + +(define (integrate-combination/default expression operations environment + block operator operands) + (combination/make + expression + block + (let* ((integrate-procedure + (lambda (operator) + (integrate/procedure-operator operations environment + block operator operands))) + (operator + (if (procedure? operator) + (integrate-procedure operator) + (let ((operator + (integrate/expression operations + environment + operator))) + (if (procedure? operator) + (integrate-procedure operator) + operator))))) + (cond ((integrate/compound-operator operator operands) + => integrate-procedure) + (else operator))) + operands)) + +(define (integrate/hack-apply? operands) + (define (check operand) + (cond ((constant? operand) + (if (null? (constant/value operand)) + '() + 'FAIL)) + ((not (combination? operand)) + 'FAIL) + (else + (let ((rator (combination/operator operand))) + (if (or (and (constant? rator) + (eq? (ucode-primitive cons) + (constant/value rator))) + (eq? 'cons (global-ref? rator))) + (let* ((rands (combination/operands operand)) + (next (check (cadr rands)))) + (if (eq? next 'FAIL) + 'FAIL + (cons (car rands) next))) + 'FAIL))))) + + (and (not (null? operands)) + (let ((tail (check (car (last-pair operands))))) + (and (not (eq? tail 'FAIL)) + (append (except-last-pair operands) + tail))))) + ;;; ((let ((a (foo)) (b (bar))) ;;; (lambda (receiver) @@ -477,84 +749,6 @@ USA. (or (reference? expression) (non-side-effecting-in-sequence? expression))) -(define-method/integrate 'DECLARATION - (lambda (operations environment declaration) - (let ((declarations (declaration/declarations declaration)) - (expression (declaration/expression declaration))) - (declaration/make - (declaration/scode declaration) - declarations - (integrate/expression (declarations/bind operations declarations) - environment - expression))))) - -;;;; Easy Cases - -(define-method/integrate 'CONSTANT - (lambda (operations environment expression) - operations - environment - expression)) - -(define-method/integrate 'THE-ENVIRONMENT - (lambda (operations environment expression) - operations - environment - expression)) - -(define-method/integrate 'QUOTATION - (lambda (operations environment expression) - operations - environment - (integrate/quotation expression))) - -(define-method/integrate 'CONDITIONAL - (lambda (operations environment expression) - (conditional/make - (conditional/scode expression) - (integrate/expression - operations environment - (conditional/predicate expression)) - (integrate/expression - operations environment - (conditional/consequent expression)) - (integrate/expression - operations environment - (conditional/alternative expression))))) - -(define-method/integrate 'DISJUNCTION - (lambda (operations environment expression) - (disjunction/make - (disjunction/scode expression) - (integrate/expression operations environment (disjunction/predicate expression)) - (integrate/expression operations environment (disjunction/alternative expression))))) - -(define-method/integrate 'SEQUENCE - (lambda (operations environment expression) - ;; Optimize (begin (foo)) => (foo) - ;; Optimize (begin a b (foo) 22 (bar)) => (begin (foo) (bar)) - (sequence/optimizing-make - expression - (integrate/actions operations environment - (sequence/actions expression))))) - -(define (integrate/actions operations environment actions) - (let ((action (car actions))) - (if (null? (cdr actions)) - (list (if (eq? action open-block/value-marker) - action - (integrate/expression operations environment action))) - (cons (cond ((reference? action) - ;; This clause lets you ignore a variable by - ;; mentioning it in a sequence. - (variable/may-ignore! (reference/variable action)) - action) - ((eq? action open-block/value-marker) - action) - (else - (integrate/expression operations environment action))) - (integrate/actions operations environment (cdr actions)))))) - (define (sequence/optimizing-make expression actions) (let ((actions (remove-non-side-effecting actions))) (if (null? (cdr actions)) @@ -583,74 +777,10 @@ USA. (procedure? expression) (and (access? expression) (non-side-effecting-in-sequence? (access/environment expression))))) - -(define-method/integrate 'ACCESS - (lambda (operations environment expression) - (let ((environment* (integrate/expression operations environment - (access/environment expression))) - (name (access/name expression))) - (cond ((and (constant/system-global-environment? environment*) - (assq name usual-integrations/constant-alist)) - => (lambda (entry) - (constant/make (access/scode expression) - (constant/value (cdr entry))))) - (else (access/make (access/scode expression) - environment* name)))))) (define (constant/system-global-environment? expression) (and (constant? expression) (system-global-environment? (constant/value expression)))) - -(define-method/integrate 'DELAY - (lambda (operations environment expression) - (delay/make - (delay/scode expression) - (integrate/expression operations environment - (delay/expression expression))))) - -(define (integrate/quotation quotation) - (call-with-values - (lambda () - (integrate/top-level* (quotation/scode quotation) - (quotation/block quotation) - (quotation/expression quotation))) - (lambda (operations environment expression) - operations environment ;ignore - expression))) - -(define (integrate/access-operator expression operations environment block operator operands) - (let ((name (access/name operator)) - (environment* - (integrate/expression operations environment (access/environment operator)))) - - (define (dont-integrate) - (combination/make - expression block - (access/make (access/scode operator) environment* name) operands)) - - (if (not (constant/system-global-environment? environment*)) - (dont-integrate) - (operations/lookup-global - operations name - (lambda (operation info) - (case operation - ((#F) (dont-integrate)) - - ((EXPAND) - (cond ((info expression operands (reference/block operator)) - => (lambda (new-expression) - (integrate/expression operations environment new-expression))) - (else (dont-integrate)))) - - ((INTEGRATE INTEGRATE-OPERATOR) - (let ((new-operator - (reassign operator - (copy/expression/intern block (integration-info/expression info))))) - (integrate/combination expression operations environment block new-operator operands))) - - (else - (error "unknown operation" operation)))) - dont-integrate)))) ;;;; Environment @@ -703,34 +833,6 @@ USA. (if-not)))) -(define (integrate/hack-apply? operands) - (define (check operand) - (cond ((constant? operand) - (if (null? (constant/value operand)) - '() - 'FAIL)) - ((not (combination? operand)) - 'FAIL) - (else - (let ((rator (combination/operator operand))) - (if (or (and (constant? rator) - (eq? (ucode-primitive cons) - (constant/value rator))) - (eq? 'cons (global-ref? rator))) - (let* ((rands (combination/operands operand)) - (next (check (cadr rands)))) - (if (eq? next 'FAIL) - 'FAIL - (cons (car rands) next))) - 'FAIL))))) - - (and (not (null? operands)) - (let ((tail (check (car (last-pair operands))))) - (and (not (eq? tail 'FAIL)) - (append (except-last-pair operands) - tail))))) - - (define (delayed-integration/in-progress? delayed-integration) (eq? (delayed-integration/state delayed-integration) 'BEING-INTEGRATED))