--- /dev/null
+;;; This alternative version of `combination/constant!' attempts to
+;;; keep the data structures more consistent. It doesn't seem to be
+;;; needed yet.
+
+(define (combination/constant! combination rvalue)
+ (let ((continuation (combination/continuation combination)))
+ (for-each (lambda (continuation)
+ (set-continuation/combinations!
+ continuation
+ (delq! combination (continuation/combinations continuation)))
+ (set-continuation/returns!
+ continuation
+ (cons combination (continuation/returns continuation))))
+ (rvalue-values continuation))
+ (for-each (lambda (operator)
+ (if (rvalue/procedure? operator)
+ (delete-procedure-application! operator combination)))
+ (rvalue-values (combination/operator combination)))
+ (maybe-kill-application-procedure! combination)
+ (set-application-type! combination 'RETURN)
+ (set-application-operator! combination continuation)
+ (set-application-operands! combination (list rvalue))
+ (let ((push (combination/continuation-push combination)))
+ (if (and push (rvalue-known-value continuation))
+ (set-virtual-continuation/type! (virtual-return-operator push)
+ continuation-type/effect)))))
+
+(define (maybe-kill-application-procedure! application)
+ (let ((operator (rvalue-known-value (application-operator application))))
+ (if (and operator
+ (rvalue/procedure? operator)
+ (procedure-always-known-operator? operator)
+ (null? (procedure-applications operator)))
+ (kill-procedure! operator))))
+
+(define (kill-procedure! procedure)
+ (set! *procedures* (delq! procedure *procedures*))
+ (let ((block (procedure-block procedure)))
+ (set! *blocks* (delq! block *blocks*))
+ (let ((parent (block-parent block)))
+ (set-block-children! parent (delq! block (block-children parent))))
+ ;; This should probably be accomplished by a codewalk, but for
+ ;; current purposes it's adequate.
+ (for-each kill-application! (block-applications block))))
+
+(define (kill-application! application)
+ (set! *applications* (delq! application *applications*))
+ (for-each (lambda (operator)
+ (if (rvalue/procedure? operator)
+ (delete-procedure-application! operator application)))
+ (rvalue-values (application-operator application)))
+ (if (application/combination? application)
+ (for-each (lambda (continuation)
+ (delete-continuation/combination! continuation application))
+ (rvalue-values (combination/continuation application))))
+ (maybe-kill-application-procedure! application))
+
+(define (delete-procedure-application! procedure combination)
+ (let ((applications (delq! combination (procedure-applications procedure))))
+ (set-procedure-applications! procedure applications)
+ (if (null? applications)
+ (set-procedure-always-known-operator?! procedure false))))
+
+(define (delete-continuation/combination! continuation combination)
+ (let ((combinations
+ (delq! combination (continuation/combinations continuation))))
+ (set-continuation/combinations! continuation combinations)
+ (if (and (null? combinations)
+ (null? (continuation/returns continuation)))
+ (set-procedure-always-known-operator?! continuation false))))
\ No newline at end of file
--- /dev/null
+;;; This alternative version of the assignment generation code (for
+;;; "fgopt/reuse") attempts to pop things off the stack as soon as
+;;; possible.
+
+(define (generate-assignments nodes rest)
+ (define (make-assignments nodes pushed registers)
+ (if (null? nodes)
+ (begin
+ (if (not (and (null? pushed) (null? registers)))
+ (error "unprocessed pending assignments" pushed registers))
+ rest)
+ (let ((last-dependent (find-last-dependent (car nodes) (cdr nodes))))
+ (if last-dependent
+ (let ((entry (cons last-dependent (car nodes)))
+ (continue
+ (lambda (continuation-type pushed registers)
+ (linearize-subproblem!
+ continuation-type
+ (node-value (car nodes))
+ (deallocate-registers nodes pushed registers)))))
+ (if (nodes-simple? (cdr nodes))
+ (continue continuation-type/register
+ pushed
+ (cons entry registers))
+ (continue continuation-type/push
+ (cons entry pushed)
+ registers)))
+ (trivial-assignment
+ (car nodes)
+ (deallocate-registers nodes pushed registers))))))
+
+ (define (deallocate-registers nodes pushed registers)
+ (with-values
+ (lambda ()
+ (discriminate-items registers
+ (lambda (register)
+ (eq? (car register) (car nodes)))))
+ (lambda (deallocated-registers allocated-registers)
+ (let loop ((registers registers))
+ (if (null? registers)
+ (deallocate-pushed nodes pushed allocated-registers)
+ (let ((node (cdar registers)))
+ (overwrite node
+ (subproblem-continuation (node-value node))
+ (loop (cdr registers)))))))))
+
+ (define (deallocate-pushed nodes pushed registers)
+ (let loop ((pushed pushed))
+ (let ((continue
+ (lambda () (make-assignments (cdr nodes) pushed registers))))
+ (cond ((null? pushed)
+ (continue))
+ ((not (car pushed))
+ (let skip-empty ((pushed (cdr pushed)) (offset 1))
+ (if (or (null? pushed)
+ (car pushed))
+ (scfg*node->node! (make-stack-adjustment offset)
+ (loop pushed))
+ (skip-empty (cdr pushed) (1+ offset)))))
+ ((eq? (car nodes) (caar pushed))
+ (overwrite (cdar pushed) 0 (loop (cdr pushed))))
+ (else
+ (let loop ((pushed* (cdr pushed)) (index 1))
+ (if (null? pushed*)
+ (continue)
+ (let ((rest (lambda () (loop (cdr pushed*) (1+ index)))))
+ (if (and (car pushed*) (eq? (car nodes) (caar pushed*)))
+ (let ((node (cdar pushed*)))
+ (set-car! pushed* false)
+ (overwrite node index (rest)))
+ (rest))))))))))
+
+ (make-assignments nodes '() '()))
+\f
+(define (find-last-dependent node nodes)
+ (let ((target (node-target node)))
+ (let loop ((nodes nodes) (dependent false))
+ (if (null? nodes)
+ dependent
+ (loop (cdr nodes)
+ (let ((node (car nodes)))
+ (if (memq target (node-original-dependencies node))
+ node
+ dependent)))))))
+
+(define (nodes-simple? nodes)
+ (for-all? (cdr nodes)
+ (lambda (node) (subproblem-simple? (node-value node)))))
+
+(define (trivial-assignment node rest)
+ (if (node/noop? node)
+ rest
+ (let ((subproblem (node-value node)))
+ (linearize-subproblem! continuation-type/register
+ subproblem
+ (overwrite node
+ (subproblem-continuation subproblem)
+ rest)))))
+
+(define (overwrite node source rest)
+ (scfg*node->node!
+ (make-stack-overwrite (subproblem-context (node-value node))
+ (node-target node)
+ source)
+ rest))
+\f
+;;; base/ctypes
+
+(define-snode stack-adjustment
+ offset)
+
+(define (make-stack-adjustment offset)
+ (snode->scfg (make-snode stack-adjustment-tag offset)))
+
+(define-integrable (node/stack-adjustment? node)
+ (eq? (tagged-vector/tag node) stack-adjustment-tag))
+
+(define-snode stack-overwrite
+ context
+ target
+ source)
+
+(define (make-stack-overwrite block target source)
+ (snode->scfg (make-snode stack-overwrite-tag block target source)))
+
+(define-integrable (node/stack-overwrite? node)
+ (eq? (tagged-vector/tag node) stack-overwrite-tag))
+
+;;; base/subprb
+
+(define (continuation*? object)
+ (or (virtual-continuation? object)
+ (continuation? object)))
+
+;;; rtlgen/rgstmt
+
+(define (generate/stack-overwrite stack-overwrite)
+ (let ((target
+ (stack-overwrite-locative (stack-overwrite-context stack-overwrite)
+ (stack-overwrite-target stack-overwrite)))
+ (source (stack-overwrite-source stack-overwrite)))
+ (cond ((continuation*? source)
+ (rtl:make-assignment
+ target
+ (rtl:make-fetch (continuation*/register continuation))))
+ ((exact-nonnegative-integer? source)
+ (if (zero? source)
+ (rtl:make-pop target)
+ (rtl:make-assignment
+ target
+ (rtl:make-fetch
+ (stack-locative-offset (rtl:make-fetch stack-pointer)
+ source)))))
+ (else
+ (error "Illegal stack-overwrite source" source)))))
+
+(define (generate/stack-adjustment stack-adjustment)
+ (rtl:make-assignment
+ register:stack-pointer
+ (rtl:make-address
+ (stack-locative-offset (rtl:make-fetch stack-pointer) offset))))
\ No newline at end of file
--- /dev/null
+;;; This code should be incorporated in a separate pass. It finds
+;;; subproblems that contain combinations that have been rewritten as
+;;; returns (e.g. constant folding), and rewrites them so that they
+;;; reflect the new code.
+
+;;; This is a partial solution which works provided that "fgopt/order"
+;;; uses `new-subproblem-rvalue' instead of `subproblem-rvalue'. A
+;;; better solution is to rewrite the subproblems and replace them in
+;;; the parallel, then update the application's operator/operand slots
+;;; to reflect the new rvalues. Then everything will be consistent.
+
+(define (rewrite-parallel-subproblems parallel)
+ (let ((application (parallel-application parallel))
+ (subproblems (parallel-subproblems parallel)))
+ (if (application/combination? application)
+ (begin
+ (set-application-operator! application
+ (new-subproblem-rvalue (car subproblems)))
+ (set-application-operands!
+ application
+ (cons (car (application-operands application))
+ (map new-subproblem-rvalue (cdr subproblems))))))))
+
+(define (new-subproblem-rvalue subproblem)
+ (if (subproblem-simplified? subproblem)
+ (return/operand
+ (car (continuation/returns (subproblem-continuation subproblem))))
+ (subproblem-rvalue subproblem)))
+
+(define (subproblem-simplified? subproblem)
+ (and (subproblem-canonical? subproblem)
+ (let ((continuation (subproblem-continuation subproblem)))
+ (and (continuation/always-known-operator? continuation)
+ (let ((returns (continuation/returns continuation)))
+ (and (not (null? returns))
+ (null? (cdr returns))
+ (return/continuation-push (car returns))))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff