From 5ab1e566e2b7b6b096a332f5abe1a2267125ae44 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Sat, 13 Mar 2010 15:47:17 -0800 Subject: [PATCH] Fixup sequences, simplify some code, rewrite conditionals whose predicates are sequences. --- src/sf/object.scm | 38 +++++++++++++++++------ src/sf/subst.scm | 78 +++++++++++++++++++++++------------------------ src/sf/usiexp.scm | 28 ++++++----------- src/sf/xform.scm | 8 +++-- 4 files changed, 82 insertions(+), 70 deletions(-) diff --git a/src/sf/object.scm b/src/sf/object.scm index e8bf9f27e..bfc6440a0 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -215,7 +215,7 @@ USA. (define-simple-type open-block #f (block variables values actions)) (define-simple-type procedure #f (block name required optional rest body)) (define-simple-type quotation #f (block expression)) -(define-simple-type sequence #f (actions)) +(define-simple-type sequence sequence/%make (actions)) (define-simple-type the-environment #f (block)) ;;; Helpers for expressions @@ -444,11 +444,9 @@ USA. #f (procedure/body operator)) new-operand-list)))) - (if (null? other-operands) - result-body - (sequence/make - (and expression (object/scode expression)) - (append other-operands (list result-body)))))))) + (sequence/make + (and expression (object/scode expression)) + (append other-operands (list result-body))))))) (else (combination/%make (and expression (object/scode expression)) block operator operands)))) @@ -528,9 +526,7 @@ USA. ;; If the consequent and alternative are the same, just make a sequence. ((expressions/equal? consequent alternative) - (if (expression/effect-free? predicate) - consequent - (sequence/make scode (list predicate consequent)))) + (sequence/make scode (list predicate consequent))) (else (conditional/%make scode predicate consequent alternative)))) @@ -549,6 +545,30 @@ USA. (else (disjunction/%make scode predicate alternative)))) +;;; Sequence + +;; Ensure that sequences are always flat. +(define (sequence/make scode actions) + (define (sequence/collect-actions collected actions) + (fold-left (lambda (reversed action) + (if (sequence? action) + (sequence/collect-actions reversed (sequence/actions action)) + (cons action reversed))) + collected + actions)) + (let ((filtered-actions + (fold-left (lambda (filtered action) + (if (expression/effect-free? action) + (if (null? filtered) + (list action) + filtered) + (cons action filtered))) + '() + (sequence/collect-actions '() actions)))) + (if (null? (cdr filtered-actions)) + (car filtered-actions) + (sequence/%make scode filtered-actions)))) + ;; Done specially so we can tweak the print method. ;; This makes debugging an awful lot easier. (define-structure (reference diff --git a/src/sf/subst.scm b/src/sf/subst.scm index 4b9714117..b9ee3a349 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -193,19 +193,15 @@ USA. alternative) (cond ((and (expression/never-false? integrated-predicate) (noisy-test sf:enable-conditional-folding? "Fold constant true conditional")) - (let ((integrated-consequent (integrate/expression operations environment consequent))) - (if (expression/effect-free? integrated-predicate) - integrated-consequent - (sequence/make (and expression (conditional/scode expression)) - (list integrated-predicate integrated-consequent))))) + (sequence/make (and expression (conditional/scode expression)) + (list integrated-predicate + (integrate/expression operations environment consequent)))) ((and (expression/always-false? integrated-predicate) (noisy-test sf:enable-conditional-folding? "Fold constant false conditional")) - (let ((integrated-alternative (integrate/expression operations environment alternative))) - (if (expression/effect-free? integrated-predicate) - integrated-alternative - (sequence/make (and expression (conditional/scode expression)) - (list integrated-predicate integrated-alternative))))) + (sequence/make (and expression (conditional/scode expression)) + (list integrated-predicate + (integrate/expression operations environment alternative)))) ((and (expression/call-to-not? integrated-predicate) (noisy-test sf:enable-conditional-inversion? "Invert conditional")) @@ -224,6 +220,14 @@ USA. operations environment expression integrated-predicate consequent alternative)) + ((sequence? integrated-predicate) + (sequence/make (and expression (object/scode expression)) + (append (except-last-pair (sequence/actions integrated-predicate)) + (list (integrate/conditional operations environment #f + (last (sequence/actions integrated-predicate)) + consequent + alternative))))) + (else (let ((integrated-consequent (integrate/expression operations environment consequent))) (if (or (and (expressions/equal? integrated-predicate integrated-consequent) @@ -234,13 +238,12 @@ USA. (noisy-test sf:enable-elide-conditional-canonicalization? "Eliding conditional canonicalization"))) (integrate/disjunction operations environment expression integrated-predicate alternative) - (let ((integrated-alternative (integrate/expression - (operations/prepare-false-branch operations integrated-predicate) - environment alternative))) - (conditional/make (and expression (conditional/scode expression)) - integrated-predicate - integrated-consequent - integrated-alternative))))))) + (conditional/make (and expression (conditional/scode expression)) + integrated-predicate + integrated-consequent + (integrate/expression + (operations/prepare-false-branch operations integrated-predicate) + environment alternative))))))) (define sf:enable-rewrite-disjunction-in-conditional? #t) ;; If #t, move disjunctions out of the predicate if possible. @@ -305,7 +308,7 @@ USA. (cond ((expression/never-false? e2) (if (and (expression/always-false? e3) (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (1)")) - ;; (if e1 (begin e2 e4) (begin e3 e5)) case 1, e2 never false, e3 always false + ;; (if e1 (begin e2 e4) (begin e3 e5)) case 1, e2 never false, e3 always false (integrate/conditional operations environment expression e1 (sequence/make #f (list e2 consequent)) @@ -313,7 +316,7 @@ USA. (let ((e4 (integrate/expression context-CC environment consequent))) (if (and (expression/can-duplicate? e4) (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (2)")) - ;; (if e1 (begin e2 e4) (if e3 e4 e5)) case 2, e2 never false, e4 can be duplicated + ;; (if e1 (begin e2 e4) (if e3 e4 e5)) case 2, e2 never false, e4 can be duplicated (integrate/conditional operations environment expression e1 (sequence/make #f (list e2 consequent)) @@ -327,13 +330,13 @@ USA. (let ((e5 (integrate/expression operations environment alternative))) (cond ((and (expression/never-false? e3) (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (3)")) - ;; (if e1 (begin e2 e5) (begin e3 e4)) case 3, e2 always false, e3 never false + ;; (if e1 (begin e2 e5) (begin e3 e4)) case 3, e2 always false, e3 never false (conditional/make (and expression (object/scode expression)) integrated-predicate e4a e5)) ((and (expression/can-duplicate? e5) (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (4)")) - ;; (if e1 (begin e2 e5) (if e3 e4 e5)) case 4, e2 always false, e5 can be duplicated + ;; (if e1 (begin e2 e5) (if e3 e4 e5)) case 4, e2 always false, e5 can be duplicated (integrate/conditional operations environment expression e1 (sequence/make #f (list e2 e5)) @@ -348,7 +351,7 @@ USA. (let ((e4 (integrate/expression operations environment consequent))) (if (and (expression/can-duplicate? e4) (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (5)")) - ;; (if e1 (if e2 e4 e5) (begin e3 e4)) case 5, e3 never false, e4 can be duplicated + ;; (if e1 (if e2 e4 e5) (begin e3 e4)) case 5, e3 never false, e4 can be duplicated (integrate/conditional operations environment expression e1 (conditional/make #f e2 e4 alternative) @@ -378,7 +381,7 @@ USA. (if (and (expression/can-duplicate? e4) (expression/can-duplicate? e5) (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (7)")) - ;; (if e1 (if e2 e4 e5) (if e3 e4 e5)) case 7, e4 and e5 can be duplicated + ;; (if e1 (if e2 e4 e5) (if e3 e4 e5)) case 7, e4 and e5 can be duplicated (integrate/conditional operations environment expression e1 (conditional/make #f e2 e4 e5) @@ -449,12 +452,9 @@ USA. ((and (expression/always-false? integrated-predicate) (noisy-test sf:enable-disjunction-folding? "Folding constant false disjunction")) ;; (or ) => (begin ) if is always false - (let ((integrated-alternative (integrate/expression operations environment alternative))) - (if (expression/effect-free? integrated-predicate) - integrated-alternative - (sequence/make (and expression (object/scode expression)) - (list integrated-predicate - integrated-alternative))))) + (sequence/make (and expression (object/scode expression)) + (list integrated-predicate + (integrate/expression operations environment alternative)))) ((and (conditional? integrated-predicate) (noisy-test sf:enable-rewrite-conditional-in-disjunction? @@ -470,6 +470,13 @@ USA. (disjunction/predicate integrated-predicate) (disjunction/make #f (disjunction/alternative integrated-predicate) alternative))) + ((sequence? integrated-predicate) + (sequence/make (and expression (object/scode expression)) + (append (except-last-pair (sequence/actions integrated-predicate)) + (list (integrate/disjunction operations environment #f + (last (sequence/actions integrated-predicate)) + alternative))))) + (else (disjunction/make (and expression (object/scode expression)) integrated-predicate @@ -606,10 +613,8 @@ USA. ;;; 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 + (sequence/make + (and expression (object/scode expression)) (integrate/actions operations environment (sequence/actions expression))))) @@ -1181,13 +1186,6 @@ USA. (or (reference? expression) (non-side-effecting-in-sequence? expression))) -(define (sequence/optimizing-make expression actions) - (let ((actions (remove-non-side-effecting actions))) - (if (null? (cdr actions)) - (car actions) - (sequence/make (and expression (object/scode expression)) - actions)))) - (define (remove-non-side-effecting actions) ;; Do not remove references from sequences, because they have ;; meaning as declarations. The output code generator will take diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm index 1b3ed1624..593d1ae45 100644 --- a/src/sf/usiexp.scm +++ b/src/sf/usiexp.scm @@ -469,17 +469,13 @@ USA. ;; Convert (eq? #f) and (eq? #f ) to (not ) ;; Conditional inversion will remove the call to not. (cond ((expression/always-false? (first operands)) - (if (expression/effect-free? (first operands)) - (make-combination expr block (ucode-primitive not) (cdr operands)) - (sequence/make (and expr (object/scode expr)) - (list (first operands) - (make-combination #f block (ucode-primitive not) (cdr operands)))))) + (sequence/make (and expr (object/scode expr)) + (list (first operands) + (make-combination #f block (ucode-primitive not) (cdr operands))))) ((expression/always-false? (second operands)) - (if (expression/effect-free? (second operands)) - (make-combination expr block (ucode-primitive not) (list (car operands))) - (sequence/make (and expr (object/scode expr)) - (list (second operands) - (make-combination #f block (ucode-primitive not) (list (car operands))))))) + (sequence/make (and expr (object/scode expr)) + (list (second operands) + (make-combination #f block (ucode-primitive not) (list (car operands)))))) (else (make-combination expr block (ucode-primitive eq?) operands))) #f)) @@ -495,15 +491,11 @@ USA. (if (and (pair? operands) (null? (cdr operands))) (cond ((expression/always-false? (first operands)) - (if (expression/effect-free? (first operands)) - (constant/make (and expr (object/scode expr)) #t) - (sequence/make (and expr (object/scode expr)) - (list (first operands) (constant/make #f #t))))) + (sequence/make (and expr (object/scode expr)) + (list (first operands) (constant/make #f #t)))) ((expression/never-false? (first operands)) - (if (expression/effect-free? (first operands)) - (constant/make (and expr (object/scode expr)) #f) - (sequence/make (and expr (object/scode expr)) - (list (first operands) (constant/make #f #f))))) + (sequence/make (and expr (object/scode expr)) + (list (first operands) (constant/make #f #f)))) (else (make-combination expr block (ucode-primitive not) operands))) #f)) diff --git a/src/sf/xform.scm b/src/sf/xform.scm index 47519ba78..ffcac1f84 100644 --- a/src/sf/xform.scm +++ b/src/sf/xform.scm @@ -182,7 +182,7 @@ USA. (let ((block (block/make block true '()))) (call-with-values (lambda () - (let ((name->variable + (let ((name->variable (lambda (name) (variable/make&bind! block name)))) (values (map name->variable required) (map name->variable optional) @@ -209,7 +209,7 @@ USA. expression block name required optional rest (if (null? ignores) final-body - (declaration/make #f (declarations/parse block `((ignore ,@ignores))) + (declaration/make #f (declarations/parse block `((ignore ,@ignores))) final-body)))))) (procedure/make expression block name required optional rest @@ -302,7 +302,9 @@ USA. (quotation/make expression block expression**)))) (define (transform/sequence block environment expression) - (sequence/make + ;; Don't remove references from sequences here. We want them + ;; to signal ignored variables. + (sequence/%make expression (transform/expressions block environment (sequence-actions expression)))) -- 2.25.1