From: Chris Hanson Date: Tue, 19 May 1987 13:38:56 +0000 (+0000) Subject: Change shallow FLUID-LET not to use side-effect for value. This X-Git-Tag: 20090517-FFI~13499 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e2212d5ba141c0fb403d653bfb998c403811e9c1;p=mit-scheme.git Change shallow FLUID-LET not to use side-effect for value. This improves the performance of compiled code. Also change one-armed IF and COND without ELSE to use new constant marker for the unused branch. --- diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index c37fcef09..d37bed313 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.44 1987/04/03 00:52:43 jinx Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.45 1987/05/19 13:38:56 cph Exp $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -321,7 +321,7 @@ (define syntax-SET!-form (spread-arguments (lambda (name . rest) - ((syntax-extended-assignment name) + ((invert-expression (syntax-expression name)) (expand-binding-value rest))))) (define syntax-DEFINE-form @@ -373,13 +373,22 @@ (lambda (predicate consequent . rest) (make-conditional (syntax-expression predicate) (syntax-expression consequent) - (cond ((null? rest) - false) + (cond ((null? rest) undefined-conditional-branch) ((null? (cdr rest)) (syntax-expression (car rest))) (else (syntax-error "Too many forms" (cdr rest)))))))) +(define syntax-CONJUNCTION-form + (spread-arguments + (lambda forms + (expand-conjunction forms)))) + +(define syntax-DISJUNCTION-form + (spread-arguments + (lambda forms + (expand-disjunction forms)))) + (define syntax-COND-form (let () (define (process-cond-clauses clause rest) @@ -387,48 +396,37 @@ (if (null? rest) (syntax-sequence (cdr clause)) (syntax-error "ELSE not last clause" rest))) - ((null? rest) - (if (cdr clause) - (make-conjunction (syntax-expression (car clause)) - (syntax-sequence (cdr clause))) - (syntax-expression (car clause)))) ((null? (cdr clause)) (make-disjunction (syntax-expression (car clause)) - (process-cond-clauses (car rest) - (cdr rest)))) + (if (null? rest) + undefined-conditional-branch + (process-cond-clauses (car rest) + (cdr rest))))) ((and (pair? (cdr clause)) (eq? (cadr clause) '=>)) (syntax-expression `((ACCESS COND-=>-HELPER SYNTAXER-PACKAGE '()) ,(car clause) - (DELAY ,@(cddr clause)) - (DELAY (COND ,@rest))))) + (LAMBDA () ,@(cddr clause)) + (LAMBDA () + ,(if (null? rest) + undefined-conditional-branch + `(COND ,@rest)))))) (else (make-conditional (syntax-expression (car clause)) (syntax-sequence (cdr clause)) - (process-cond-clauses (car rest) - (cdr rest)))))) + (if (null? rest) + undefined-conditional-branch + (process-cond-clauses (car rest) + (cdr rest))))))) (spread-arguments (lambda (clause . rest) (process-cond-clauses clause rest))))) (define (cond-=>-helper form1-result thunk2 thunk3) (if form1-result - ((force thunk2) form1-result) - (force thunk3))) - -(define (make-funcall name . args) - (make-combination (make-variable name) args)) - -(define syntax-CONJUNCTION-form - (spread-arguments - (lambda forms - (expand-conjunction forms)))) - -(define syntax-DISJUNCTION-form - (spread-arguments - (lambda forms - (expand-disjunction forms)))) + ((thunk2) form1-result) + (thunk3))) ;;;; Procedures @@ -561,20 +559,20 @@ (define (syntax-fluid-bindings bindings receiver) (if (null? bindings) - (receiver '() '() '() '()) + (receiver '() '() (list false) (list false)) (syntax-fluid-bindings (cdr bindings) (lambda (names values transfers-in transfers-out) (let ((binding (car bindings))) (if (pair? binding) - (let ((transfer - (let ((assignment - (syntax-extended-assignment (car binding)))) - (lambda (target source) - (make-assignment - target - (assignment - (make-assignment source - unassigned-object)))))) + (let ((transfer + (let ((reference (syntax-expression (car binding)))) + (let ((assignment (invert-expression reference))) + (lambda (target source) + (make-sequence* + (make-assignment target reference) + (assignment (make-variable source)) + (make-assignment source + unassigned-object)))))) (value (expand-binding-value (cdr binding))) (inside-name (string->uninterned-symbol "INSIDE-PLACEHOLDER")) @@ -679,9 +677,6 @@ ;;;; Extended Assignment Syntax -(define (syntax-extended-assignment expression) - (invert-expression (syntax-expression expression))) - (define (invert-expression target) (cond ((variable? target) (invert-variable (variable-name target))) @@ -1011,5 +1006,4 @@ )))) ;;; end SYNTAXER-PACKAGE -) ) \ No newline at end of file diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index 4c83c01a6..29b518dea 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.42 1987/03/17 18:54:23 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.43 1987/05/19 13:38:31 cph Exp $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -105,7 +105,10 @@ (define (unsyntax-ASSIGNMENT-object assignment) (assignment-components assignment (lambda (name value) - `(SET! ,name ,(unsyntax-object value))))) + `(SET! ,name + ,@(if (unassigned-object? value) + '() + `(,(unsyntax-object value))))))) (define ((definition-unexpander key lambda-key) name value) (if (lambda? value) @@ -164,10 +167,10 @@ (define (unsyntax-conditional predicate consequent alternative) (cond ((false? alternative) - (if (conditional? consequent) - `(AND ,@(unexpand-conjunction predicate consequent)) - `(IF ,(unsyntax-object predicate) - ,(unsyntax-object consequent)))) + `(AND ,@(unexpand-conjunction predicate consequent))) + ((eq? alternative undefined-conditional-branch) + `(IF ,(unsyntax-object predicate) + ,(unsyntax-object consequent))) ((conditional? alternative) `(COND ,@(unsyntax-cond-conditional predicate consequent @@ -186,7 +189,7 @@ ,@(unsyntax-cond-alternative alternative))) (define (unsyntax-cond-alternative alternative) - (cond ((false? alternative) '()) + (cond ((eq? alternative undefined-conditional-branch) '()) ((disjunction? alternative) (disjunction-components alternative unsyntax-cond-disjunction)) ((conditional? alternative) @@ -328,36 +331,21 @@ (combination-components body (lambda (operator operands) `(FLUID-LET ,(unsyntax-let-bindings - (map extract-transfer-var - (lambda-components** (car operands) - (lambda (name req opt rest body) - (sequence-actions body)))) - (every-other values)) + (extract-transfer-variables + (sequence-actions (lambda-body (car operands)))) + (let every-other ((values values)) + (if (null? values) + '() + (cons (car values) (every-other (cddr values)))))) ,@(lambda-components** (cadr operands) (lambda (name required optional rest body) (unsyntax-sequence body))))))) -(define (every-other list) - (if (null? list) - '() - (cons (car list) (every-other (cddr list))))) - -(define (extract-transfer-var assignment) - (assignment-components assignment - (lambda (name value) - (cond ((assignment? value) - (assignment-components value (lambda (name value) name))) - ((combination? value) - (combination-components value - (lambda (operator operands) - (cond ((eq? operator lexical-assignment) - `(ACCESS ,(cadr operands) - ,@(unexpand-access (car operands)))) - (else - (error "Unknown SCODE form" 'FLUID-LET - assignment)))))) - (else - (error "Unknown SCODE form" 'FLUID-LET assignment)))))) +(define (extract-transfer-variables actions) + (if (assignment? (car actions)) + (cons (unsyntax-object (assignment-value (car actions))) + (extract-transfer-variables (cdddr actions))) + '())) (define ((unsyntax-deep-or-common-FLUID-LET name prim) ignored-required ignored-operands body)