From: Joe Marshall Date: Wed, 10 Feb 2010 02:42:52 +0000 (-0800) Subject: Move combination rewriting to combination constructor. Import constant folding opera... X-Git-Tag: 20100708-Gtk~168^2~9 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a33e5753c59ae8033af2a2ab7905706f7e758733;p=mit-scheme.git Move combination rewriting to combination constructor. Import constant folding operators from runtime. --- diff --git a/src/sf/object.scm b/src/sf/object.scm index 633cf885b..c6e0c7fab 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -31,7 +31,7 @@ USA. ;;;; Enumerations (define (enumeration/make names) - (let ((enumerands + (let ((enumerands (let loop ((names names) (index 0)) (if (pair? names) (cons (vector #f (car names) index) @@ -189,7 +189,7 @@ USA. (conc-name variable/) (constructor variable/make (block name flags)) (print-procedure - (standard-unparser-method + (standard-unparser-method 'variable (lambda (var port) (write-string " " port) @@ -228,11 +228,225 @@ USA. (1+ (variable/invocation-count variable))))) (combination/%%make scode block operator operands)) +;; When constucting a combination, we may discover that we +;; can reduce the combination through constant folding. +(define sf:enable-constant-folding? #t) + +;; If we have a LET expression, and an argument has been integrated, +;; then we can remove it from the lambda binding and the argument +;; list. This could lead to the combination disappearing altogether. +(define sf:enable-argument-deletion? #t) + +;; If we apply a primitive to a conditional, rewrite such that +;; the primitive is applied to the arms of the conditional. +;; (This usually occurs with an (not (if foo ))) +(define sf:enable-distribute-primitives? #t) + +;; Foldable operators primitives that are members of +;; combination/constant-folding-operators + +(define (foldable-combination? operator operands) + (and (constant? operator) + (let ((operator-value (constant/value operator))) + (and (primitive-procedure? operator-value) + (procedure-arity-valid? operator-value (length operands)) + (memq operator-value combination/constant-folding-operators))) + ;; Check that the arguments are constant. + (for-all? operands constant?))) + +;; An operator is reducable if we can safely rewrite its argument list. +(define (reducable-operator? operator) + (and (procedure? operator) + ;; if the block is not safe, then random code can be + ;; injected and it will expect to see all the arguments. + (block/safe? (procedure/block operator)) + ;; if there are declarations we don't understand, we + ;; should leave things alone. + (for-all? (declarations/original + (block/declarations (procedure/block operator))) + declarations/known?) + ;; Unintegrated optionals are tricky and rare. Punt. + (for-all? (procedure/optional operator) variable/integrated) + ;; Unintegrated rest arguments are tricky and rare. Punt. + (let ((rest-arg (procedure/rest operator))) + (or (not rest-arg) (variable/integrated rest-arg))))) + (define (combination/make expression block operator operands) - (combination/%make expression block operator operands)) + (cond ((and (foldable-combination? operator operands) + (noisy-test sf:enable-constant-folding? "fold constants")) + (combination/fold-constant expression + (constant/value operator) + (map constant/value operands))) + + ((and (constant? operator) + (primitive-procedure? (constant/value operator)) + (= (length operands) 1) + (conditional? (car operands)) + (noisy-test sf:enable-distribute-primitives? + "Distribute primitives over conditionals")) + (conditional/make (and expression (object/scode expression)) + (conditional/predicate (car operands)) + (combination/make #f + block + (constant/make #f (constant/value operator)) + (list (conditional/consequent (car operands)))) + (combination/make #f + block + (constant/make #f (constant/value operator)) + (list (conditional/alternative (car operands)))))) + + ((and (reducable-operator? operator) + (noisy-test sf:enable-argument-deletion? "argument deletion")) + (call-with-values (lambda () (partition-operands operator operands)) + (lambda (new-argument-list new-operand-list other-operands) + ;; The new-argument-list has the remaining arguments + ;; after reduction. The new-operand-list is the remaining + ;; operands after reduction. The other-operands are a + ;; list of operands that must be evaluated (for effect) + ;; but whose value is discarded. + (let ((result-body + (if (and (null? new-argument-list) + ;; need to avoid things like this + ;; (foo bar (let () (define (baz) ..) ..)) + ;; optimizing into + ;; (foo bar (define (baz) ..) ..) + (not (open-block? (procedure/body operator)))) + (procedure/body operator) + (combination/%make + (and expression (object/scode expression)) + block + (procedure/make + (procedure/scode operator) + (procedure/block operator) + (procedure/name operator) + new-argument-list + '() + #f + (procedure/body operator)) + new-operand-list)))) + (if (null? other-operands) + result-body + (sequence/make + expression + (append other-operands (list form)))))))) + (else + (combination/%make (and expression (object/scode expression)) block operator operands)))) + +(define (combination/fold-constant expression operator operands) + (if (not (eq? sf:enable-constant-folding? #t)) + (begin + (newline) + (display "; Folding (") + (display operator) + (for-each (lambda (operand) (display " ") (write operand)) operands))) + (let ((result (apply operator operands))) + (if (not (eq? sf:enable-constant-folding? #t)) + (begin + (display ") => ") + (write result))) + (constant/make (and expression (object/scode expression)) result))) + +(define-integrable (partition-operands operator operands) + (let ((free-in-body (free/expression (procedure/body operator)))) + (let loop ((parameters (append (procedure/required operator) + (procedure/optional operator))) + (operands operands) + (required-parameters '()) + (referenced-operands '()) + (unreferenced-operands '())) + (cond ((null? parameters) + (if (or (procedure/rest operator) (null? operands)) + (values (reverse required-parameters) ; preserve order + (reverse referenced-operands) + (if (or (null? operands) + (variable/integrated (procedure/rest operator))) + unreferenced-operands + (append operands unreferenced-operands))) + (error "Argument mismatch" operands))) + ((null? operands) + (error "Argument mismatch" parameters)) + (else + (let ((this-parameter (car parameters)) + (this-operand (car operands))) + (cond ((memq this-parameter free-in-body) + (loop (cdr parameters) + (cdr operands) + (cons this-parameter required-parameters) + (cons this-operand referenced-operands) + unreferenced-operands)) + ((variable/integrated this-parameter) + (loop (cdr parameters) + (cdr operands) + required-parameters + referenced-operands + unreferenced-operands)) + (else + (loop (cdr parameters) + (cdr operands) + required-parameters + referenced-operands + (cons this-operand + unreferenced-operands)))))))))) + +;;; Conditional +(define sf:enable-conditional->disjunction? #t) +(define sf:enable-conditional-folding? #t) +(define sf:enable-conditional-inversion? #t) +(define sf:enable-conjunction-linearization? #t) +(define sf:enable-disjunction-distribution? #t) (define (conditional/make scode predicate consequent alternative) - (conditional/%make scode predicate consequent alternative)) + (cond ((and (constant? predicate) + (noisy-test sf:enable-conditional-folding? "folding conditional")) + (if (constant/value predicate) + consequent + alternative)) + + ;; (if foo foo ...) => (or foo ...) + ((and (reference? predicate) + (reference? consequent) + (eq? (reference/variable predicate) + (reference/variable consequent)) + (noisy-test sf:enable-conditional->disjunction? "Conditional to disjunction")) + (disjunction/make scode predicate alternative)) + + ;; (if (not e) c a) => (if e a c) + ((and (combination? predicate) + (constant? (combination/operator predicate)) + (eq? (constant/value (combination/operator predicate)) (ucode-primitive not)) + (= (length (combination/operands predicate)) 1) + (noisy-test sf:enable-conditional-inversion? "Conditional inversion")) + (conditional/make scode (first (combination/operands predicate)) + alternative + consequent)) + + ;; (if (if e1 e2 #f) K) => (if e1 (if e2 K) K) + ((and (conditional? predicate) + (constant? (conditional/alternative predicate)) + (not (constant/value (conditional/alternative predicate))) + (constant? alternative) + (noisy-test sf:enable-conjunction-linearization? "Conjunction linearization")) + (conditional/make scode + (conditional/predicate predicate) + (conditional/make #f + (conditional/consequent predicate) + consequent + alternative) + alternative)) + + ;; (if (or e1 e2) K ) => (if e1 K (if e2 K )) + ((and (disjunction? predicate) + (constant? consequent) + (noisy-test sf:enable-disjunction-distribution? "Disjunction distribution")) + (conditional/make scode + (disjunction/predicate predicate) + consequent + (conditional/make #f + (disjunction/alternative predicate) + consequent + alternative))) + (else + (conditional/%make scode predicate consequent alternative)))) ;;; Disjunction (define sf:enable-disjunction-folding? #t) @@ -284,7 +498,7 @@ USA. (conc-name reference/) (constructor reference/make) (print-procedure - (standard-unparser-method + (standard-unparser-method 'reference (lambda (ref port) (write-string " to " port) diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg index c9049b6b8..dd9a86c6f 100644 --- a/src/sf/sf.pkg +++ b/src/sf/sf.pkg @@ -35,11 +35,22 @@ USA. "usicon" "tables") (parent ()) + (import (runtime scode-combinator) + combination/constant-folding-operators) (export () + sf:enable-argument-deletion? + sf:enable-conditional->disjunction? + sf:enable-conditional-folding? + sf:enable-conditional-inversion? + sf:enable-conjunction-linearization? + sf:enable-constant-folding? + sf:enable-disjunction-distribution? sf:enable-disjunction-folding? sf:enable-disjunction-inversion? sf:enable-disjunction-linearization? - sf:enable-disjunction-simplification?)) + sf:enable-disjunction-simplification? + sf:enable-distribute-primitives? + )) (define-package (scode-optimizer global-imports) (files "gimprt") diff --git a/src/sf/subst.scm b/src/sf/subst.scm index 947737a88..80eae5148 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -142,7 +142,7 @@ USA. (integration-failure (lambda () (variable/reference! variable) - (combination/optimizing-make expression block + (combination/make expression block operator operands))) (integration-success (lambda (operator) @@ -308,7 +308,7 @@ USA. (integrate/primitive-operator expression operations environment block operator operands)))) (else - (combination/optimizing-make + (combination/make expression block (let* ((integrate-procedure @@ -340,7 +340,7 @@ USA. (define (integrate/primitive-operator expression operations environment block operator operands) (declare (ignore operations environment)) - (combination/optimizing-make expression block operator operands)) + (combination/make expression block operator operands)) ;;; ((let ((a (foo)) (b (bar))) ;;; (lambda (receiver) @@ -429,7 +429,7 @@ USA. (scan-operator operator (lambda (body) body)))) (define (combination-with-operator combination operator) - (combination/make (combination/scode combination) + (combination/make combination (combination/block combination) operator (combination/operands combination))) @@ -500,46 +500,19 @@ USA. environment (integrate/quotation expression))) -;; Optimize (if #f a b) => b; (if #t a b) => a -;; (if (let (...) t) a b) => (let (...) (if t a b)) -;; (if (begin ... t) a b) => (begin ... (if t a b)) - (define-method/integrate 'CONDITIONAL (lambda (operations environment expression) - (let ((predicate (integrate/expression - operations environment - (conditional/predicate expression))) - (consequent (integrate/expression - operations environment - (conditional/consequent expression))) - (alternative (integrate/expression - operations environment - (conditional/alternative expression)))) - (let loop ((predicate predicate)) - (cond ((constant? predicate) - (if (constant/value predicate) - consequent - alternative)) - ((sequence? predicate) - (sequence-with-actions - predicate - (let ((actions (reverse (sequence/actions predicate)))) - (reverse - (cons (loop (car actions)) - (cdr actions)))))) - ((and (combination? predicate) - (procedure? (combination/operator predicate)) - (not - (open-block? - (procedure/body (combination/operator predicate))))) - (combination-with-operator - predicate - (procedure-with-body - (combination/operator predicate) - (loop (procedure/body (combination/operator predicate)))))) - (else - (conditional/make (conditional/scode expression) - predicate consequent alternative))))))) + (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) @@ -643,7 +616,7 @@ USA. (dont-integrate (lambda () (combination/make - (and expression (object/scode expression)) + expression block (integrate/expression operations environment operator) (integrate/expressions operations environment operands))))) @@ -770,163 +743,4 @@ USA. (else (error "Delayed integration has unknown state" delayed-integration))) - (delayed-integration/value delayed-integration)) - -;;;; Optimizations - -#| -Simple LET-like combination. Delete any unreferenced -parameters. If no parameters remain, delete the -combination and lambda. Values bound to the unreferenced -parameters are pulled out of the combination. But integrated -forms are simply removed. - -(define (foo a) - (let ((a (+ a 3)) - (b (bar a)) - (c (baz a))) - (declare (integrate c)) - (+ c a))) - - || - \/ - -(define (foo a) - (bar a) - (let ((a (+ a 3))) - (+ (baz a) a))) - -|# - -(define (foldable-constant? thing) - (constant? thing)) - -(define (foldable-constants? list) - (or (null? list) - (and (foldable-constant? (car list)) - (foldable-constants? (cdr list))))) - -(define (foldable-constant-value thing) - (cond ((constant? thing) - (constant/value thing)) - (else - (error "foldable-constant-value: can't happen" thing)))) - -(define *foldable-primitive-procedures - (map make-primitive-procedure - '(OBJECT-TYPE OBJECT-TYPE? - NOT EQ? NULL? PAIR? ZERO? POSITIVE? NEGATIVE? - &= &< &> &+ &- &* &/ 1+ -1+))) - -(define (foldable-operator? operator) - (and (constant? operator) - (primitive-procedure? (constant/value operator)) - (memq (constant/value operator) *foldable-primitive-procedures))) - -;;; deal with (let () (define ...)) -;;; deal with (let ((x 7)) (let ((y 4)) ...)) => (let ((x 7) (y 4)) ...) -;;; Actually, we really don't want to hack with these for various -;;; reasons - -(define (combination/optimizing-make expression block operator operands) - (cond ( - ;; fold constants - (and (foldable-operator? operator) - (foldable-constants? operands)) - (constant/make (and expression (object/scode expression)) - (apply (constant/value operator) - (map foldable-constant-value operands)))) - - ( - ;; (force (delay x)) ==> x - (and (constant? operator) - (eq? (constant/value operator) force) - (= (length operands) 1) - (delay? (car operands))) - (delay/expression (car operands))) - - ((and (procedure? operator) - (block/safe? (procedure/block operator)) - (for-all? (declarations/original - (block/declarations (procedure/block operator))) - declarations/known?) - (for-all? (procedure/optional operator) - variable/integrated) - (or (not (procedure/rest operator)) - (variable/integrated (procedure/rest operator)))) - (delete-unreferenced-parameters - (append (procedure/required operator) - (procedure/optional operator)) - (procedure/rest operator) - (procedure/body operator) - operands - (lambda (required referenced-operands unreferenced-operands) - (let ((form - (if (and (null? required) - ;; need to avoid things like this - ;; (foo bar (let () (define (baz) ..) ..)) - ;; optimizing into - ;; (foo bar (define (baz) ..) ..) - (not (open-block? (procedure/body operator)))) - (reassign expression (procedure/body operator)) - (combination/make - (and expression (object/scode expression)) - block - (procedure/make - (procedure/scode operator) - (procedure/block operator) - (procedure/name operator) - required - '() - #f - (procedure/body operator)) - referenced-operands)))) - (if (null? unreferenced-operands) - form - (sequence/optimizing-make - expression - (append unreferenced-operands (list form)))))))) - (else - (combination/make (and expression (object/scode expression)) - block operator operands)))) - -(define (delete-unreferenced-parameters parameters rest body operands receiver) - (let ((free-in-body (free/expression body))) - (let loop ((parameters parameters) - (operands operands) - (required-parameters '()) - (referenced-operands '()) - (unreferenced-operands '())) - (cond ((null? parameters) - (if (or rest (null? operands)) - (receiver (reverse required-parameters) ; preserve order - (reverse referenced-operands) - (if (or (null? operands) - (variable/integrated rest)) - unreferenced-operands - (append operands unreferenced-operands))) - (error "Argument mismatch" operands))) - ((null? operands) - (error "Argument mismatch" parameters)) - (else - (let ((this-parameter (car parameters)) - (this-operand (car operands))) - (cond ((memq this-parameter free-in-body) - (loop (cdr parameters) - (cdr operands) - (cons this-parameter required-parameters) - (cons this-operand referenced-operands) - unreferenced-operands)) - ((variable/integrated this-parameter) - (loop (cdr parameters) - (cdr operands) - required-parameters - referenced-operands - unreferenced-operands)) - (else - (loop (cdr parameters) - (cdr operands) - required-parameters - referenced-operands - (cons this-operand - unreferenced-operands)))))))))) \ No newline at end of file + (delayed-integration/value delayed-integration)) \ No newline at end of file diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm index 95d9668d9..60c298997 100644 --- a/src/sf/usiexp.scm +++ b/src/sf/usiexp.scm @@ -32,13 +32,13 @@ USA. ;;;; Fixed-arity arithmetic primitives (define (make-combination expression block primitive operands) - (combination/make (and expression (object/scode expression)) + (combination/make expression block (constant/make #f primitive) operands)) (define (make-operand-binding expression block operand make-body) - (combination/make (and expression (object/scode expression)) + (combination/make expression block (let ((block (block/make block #t '())) (name (string->uninterned-symbol "operand"))) @@ -319,7 +319,7 @@ USA. (if (< 1 (length operands) 10) (if-expanded (combination/make - (and expr (object/scode expr)) + expr block (global-ref/make 'APPLY) (list (car operands) @@ -364,7 +364,7 @@ USA. (string-append "value-" (number->string position))))) (iota (length operands))))) (combination/make - (and expr (object/scode expr)) + expr block (procedure/make #f @@ -393,7 +393,7 @@ USA. (pair? (cdr operands)) (null? (cddr operands))) (if-expanded - (combination/make (and expr (object/scode expr)) + (combination/make expr block (combination/make #f block (car operands) '()) (cdr operands)))