From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 21 Mar 2000 04:16:22 +0000 (+0000)
Subject: Initial registration with CVS.
X-Git-Tag: 20090517-FFI~4188
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e74c2a80d24dc0e4122ef529f7b052b9f2803bff;p=mit-scheme.git

Initial registration with CVS.
---

diff --git a/v7/src/compiler/improvements/comcon.scm b/v7/src/compiler/improvements/comcon.scm
new file mode 100644
index 000000000..723b2f47a
--- /dev/null
+++ b/v7/src/compiler/improvements/comcon.scm
@@ -0,0 +1,70 @@
+;;; 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
diff --git a/v7/src/compiler/improvements/gasn.scm b/v7/src/compiler/improvements/gasn.scm
new file mode 100644
index 000000000..0d70beadf
--- /dev/null
+++ b/v7/src/compiler/improvements/gasn.scm
@@ -0,0 +1,161 @@
+;;; 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 '() '()))
+
+(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))
+
+;;; 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
diff --git a/v7/src/compiler/improvements/rewsub.scm b/v7/src/compiler/improvements/rewsub.scm
new file mode 100644
index 000000000..307452188
--- /dev/null
+++ b/v7/src/compiler/improvements/rewsub.scm
@@ -0,0 +1,37 @@
+;;; 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
diff --git a/v7/src/microcode/os2utl/bch.ico b/v7/src/microcode/os2utl/bch.ico
new file mode 100644
index 000000000..f49a34cc8
Binary files /dev/null and b/v7/src/microcode/os2utl/bch.ico differ
diff --git a/v7/src/microcode/os2utl/coffee.ico b/v7/src/microcode/os2utl/coffee.ico
new file mode 100644
index 000000000..500d82074
Binary files /dev/null and b/v7/src/microcode/os2utl/coffee.ico differ
diff --git a/v7/src/microcode/os2utl/conses.ico b/v7/src/microcode/os2utl/conses.ico
new file mode 100644
index 000000000..9e6919ea4
Binary files /dev/null and b/v7/src/microcode/os2utl/conses.ico differ
diff --git a/v7/src/microcode/os2utl/edwin.ico b/v7/src/microcode/os2utl/edwin.ico
new file mode 100644
index 000000000..5e9a5e468
Binary files /dev/null and b/v7/src/microcode/os2utl/edwin.ico differ
diff --git a/v7/src/microcode/os2utl/envir1.ico b/v7/src/microcode/os2utl/envir1.ico
new file mode 100644
index 000000000..8c5c3f6a3
Binary files /dev/null and b/v7/src/microcode/os2utl/envir1.ico differ
diff --git a/v7/src/microcode/os2utl/graphics.ico b/v7/src/microcode/os2utl/graphics.ico
new file mode 100644
index 000000000..4b7af5c66
Binary files /dev/null and b/v7/src/microcode/os2utl/graphics.ico differ
diff --git a/v7/src/microcode/os2utl/lambda.ico b/v7/src/microcode/os2utl/lambda.ico
new file mode 100644
index 000000000..d8ae97b61
Binary files /dev/null and b/v7/src/microcode/os2utl/lambda.ico differ
diff --git a/v7/src/microcode/os2utl/lambda2.ico b/v7/src/microcode/os2utl/lambda2.ico
new file mode 100644
index 000000000..8a046e364
Binary files /dev/null and b/v7/src/microcode/os2utl/lambda2.ico differ
diff --git a/v7/src/microcode/os2utl/liar1.ico b/v7/src/microcode/os2utl/liar1.ico
new file mode 100644
index 000000000..d1b952295
Binary files /dev/null and b/v7/src/microcode/os2utl/liar1.ico differ
diff --git a/v7/src/microcode/os2utl/liar2.ico b/v7/src/microcode/os2utl/liar2.ico
new file mode 100644
index 000000000..8645d9fa1
Binary files /dev/null and b/v7/src/microcode/os2utl/liar2.ico differ
diff --git a/v7/src/microcode/os2utl/liar3.ico b/v7/src/microcode/os2utl/liar3.ico
new file mode 100644
index 000000000..7bb96c400
Binary files /dev/null and b/v7/src/microcode/os2utl/liar3.ico differ
diff --git a/v7/src/microcode/os2utl/mincer.ico b/v7/src/microcode/os2utl/mincer.ico
new file mode 100644
index 000000000..c2af5035f
Binary files /dev/null and b/v7/src/microcode/os2utl/mincer.ico differ
diff --git a/v7/src/microcode/os2utl/shield1.ico b/v7/src/microcode/os2utl/shield1.ico
new file mode 100644
index 000000000..8aab31824
Binary files /dev/null and b/v7/src/microcode/os2utl/shield1.ico differ
diff --git a/v7/src/microcode/os2utl/shield2.ico b/v7/src/microcode/os2utl/shield2.ico
new file mode 100644
index 000000000..2f78db898
Binary files /dev/null and b/v7/src/microcode/os2utl/shield2.ico differ
diff --git a/v7/src/microcode/os2utl/shield3.ico b/v7/src/microcode/os2utl/shield3.ico
new file mode 100644
index 000000000..a5be9644f
Binary files /dev/null and b/v7/src/microcode/os2utl/shield3.ico differ
diff --git a/v7/src/microcode/os2utl/shield4.ico b/v7/src/microcode/os2utl/shield4.ico
new file mode 100644
index 000000000..bc1f1e9c7
Binary files /dev/null and b/v7/src/microcode/os2utl/shield4.ico differ