From: jrm <jmarshall@alum.mit.edu>
Date: Tue, 9 Feb 2010 16:51:31 +0000 (-0800)
Subject: Get rid of lsets and table.  Simplify emodel.
X-Git-Tag: 20100708-Gtk~168^2~22
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=97f35073db83eb141d7cef0a5a8c4161e1a894ac;p=mit-scheme.git

Get rid of lsets and table.  Simplify emodel.
---

diff --git a/src/sf/copy.scm b/src/sf/copy.scm
index aaf356574..b4c61b8b6 100644
--- a/src/sf/copy.scm
+++ b/src/sf/copy.scm
@@ -98,7 +98,7 @@ USA.
 
 (define (copy/block parent environment block)
   (let ((result (block/make parent (block/safe? block) '()))
-	(old-bound (block/bound-variables-list block)))
+	(old-bound (block/bound-variables block)))
     (let ((new-bound
 	   (map (lambda (variable)
 		  (let ((new
diff --git a/src/sf/emodel.scm b/src/sf/emodel.scm
index 157c51df5..d00b8f141 100644
--- a/src/sf/emodel.scm
+++ b/src/sf/emodel.scm
@@ -24,6 +24,7 @@ USA.
 |#
 
 ;;;; SCode Optimizer: Environment Model
+;;; package: (scode-optimizer)
 
 (declare (usual-integrations)
 	 (integrate-external "object"))
@@ -32,10 +33,7 @@ USA.
   (let ((block
 	 (%block/make parent
 		      safe?
-		      (let ((n-bound-variables (length bound-variables)))
-			(if (fix:<= n-bound-variables block-hash-table-limit)
-			    (cons n-bound-variables bound-variables)
-			    (make-hash-table bound-variables))))))
+		      bound-variables)))
     (if parent
 	(set-block/children! parent (cons block (block/children parent))))
     block))
@@ -45,22 +43,11 @@ USA.
       (%variable/make&bind! block name)))
 
 (define (%variable/make&bind! block name)
-  (let ((variable (variable/make block name '()))
-	(bound-variables (block/bound-variables block)))
-    (cond ((hash-table? bound-variables)
-	   (hash-table-store! bound-variables variable))
-	  ((fix:= (car bound-variables) block-hash-table-limit)
-	   (set-block/bound-variables!
-	    block
-	    (make-hash-table (cons variable (cdr bound-variables)))))
-	  (else
-	   (set-car! bound-variables (fix:+ (car bound-variables) 1))
-	   (set-cdr! bound-variables (cons variable (cdr bound-variables)))))
+  (let ((variable (variable/make block name '())))
+    (set-block/bound-variables! block
+				(cons variable (block/bound-variables block)))
     variable))
 
-(define-integrable block-hash-table-limit
-  20)
-
 (define (block/lookup-name block name intern?)
   (let search ((block block))
     (or (%block/lookup-name block name)
@@ -69,107 +56,16 @@ USA.
 	    (and intern? (%variable/make&bind! block name))))))
 
 (define (%block/lookup-name block name)
-  (let ((bound-variables (block/bound-variables block)))
-    (if (hash-table? bound-variables)
-	(hash-table-lookup bound-variables name)
-	(let loop ((variables (cdr bound-variables)))
-	  (and (not (null? variables))
-	       (if (eq? name (variable/name (car variables)))
-		   (car variables)
-		   (loop (cdr variables))))))))
+  (find-matching-item (block/bound-variables block)
+		      (lambda (variable)
+			(eq? (variable/name variable) name))))
 
 (define (block/limited-lookup block name limit)
   (let search ((block block))
     (and (not (eq? block limit))
-	 (let ((bound-variables (block/bound-variables block)))
-	   (if (hash-table? bound-variables)
-	       (or (hash-table-lookup bound-variables name)
-		   (and (block/parent block)
-			(search (block/parent block))))
-	       (let loop ((variables (cdr bound-variables)))
-		 (cond ((null? variables)
-			(and (block/parent block)
-			     (search (block/parent block))))
-		       ((eq? name (variable/name (car variables)))
-			(car variables))
-		       (else
-			(loop (cdr variables))))))))))
-
-(define-structure (hash-table
-		   (type vector)
-		   (named (string->symbol "#[(scode-optimizer)hash-table]"))
-		   (constructor %make-hash-table))
-  count
-  buckets)
-
-(define (make-hash-table variables)
-  (let ((count (length variables)))
-    (let ((buckets (make-hash-table-buckets (fix:+ count 1))))
-      (let ((table (%make-hash-table count buckets)))
-	(for-each (lambda (variable)
-		    (%hash-table-store! buckets variable))
-		  variables)
-	table))))
-
-(define (hash-table-store! table variable)
-  (let ((count (fix:+ (hash-table-count table) 1)))
-    (if (fix:= count (vector-length (hash-table-buckets table)))
-	(let ((old-buckets (hash-table-buckets table)))
-	  (let ((new-buckets (make-hash-table-buckets (fix:+ count count))))
-	    (do ((h 0 (fix:+ h 1)))
-		((fix:= h count))
-	      (let ((variable (vector-ref old-buckets h)))
-		(if variable
-		    (%hash-table-store! new-buckets variable))))
-	    (set-hash-table-buckets! table new-buckets))))
-    (set-hash-table-count! table count))
-  (%hash-table-store! (hash-table-buckets table) variable))
-
-(define (%hash-table-store! buckets variable)
-  (let ((k (symbol-hash (variable/name variable)))
-	(m (vector-length buckets)))
-    (let ((h1 (modulo k m)))
-      (if (not (vector-ref buckets h1))
-	  (vector-set! buckets h1 variable)
-	  (let ((h2 (fix:+ (modulo k (fix:- m 1)) 1)))
-	    (let loop ((h h1))
-	      (let ((h
-		     (let ((h (fix:+ h h2)))
-		       (if (fix:< h m)
-			   h
-			   (fix:- h m)))))
-		(if (not (vector-ref buckets h))
-		    (vector-set! buckets h variable)
-		    (loop h)))))))))
-
-(define (make-hash-table-buckets n)
-  (make-vector (let loop ((primes prime-numbers-stream))
-		 (if (<= n (car primes))
-		     (car primes)
-		     (loop (force (cdr primes)))))
-	       false))
-
-(define (hash-table-lookup table name)
-  (let ((buckets (hash-table-buckets table)))
-    (let ((k (symbol-hash name))
-	  (m (vector-length buckets)))
-      (let ((h1 (modulo k m)))
-	(let ((variable (vector-ref buckets h1)))
-	  (and variable
-	       (if (eq? name (variable/name variable))
-		   variable
-		   (let ((h2 (fix:+ (modulo k (fix:- m 1)) 1)))
-		     (let loop ((h h1))
-		       (let ((h
-			      (let ((h (fix:+ h h2)))
-				(if (fix:< h m)
-				    h
-				    (fix:- h m)))))
-			 (let ((variable (vector-ref buckets h)))
-			   (and variable
-				(if (eq? name (variable/name variable))
-				    variable
-				    (loop h))))))))))))))
+	 (or (%block/lookup-name block name)
+	     (and (block/parent block)
+		  (search (block/parent block)))))))
 
 (define (block/lookup-names block names intern?)
   (map (lambda (name)
@@ -177,29 +73,7 @@ USA.
        names))
 
 (define (block/for-each-bound-variable block procedure)
-  (let ((bound-variables (block/bound-variables block)))
-    (if (hash-table? bound-variables)
-	(let ((buckets (hash-table-buckets bound-variables)))
-	  (let ((m (vector-length buckets)))
-	    (do ((h 0 (fix:+ h 1)))
-		((fix:= h m))
-	      (if (vector-ref buckets h)
-		  (procedure (vector-ref buckets h))))))
-	(for-each procedure (cdr bound-variables)))))
-
-(define (block/bound-variables-list block)
-  (let ((bound-variables (block/bound-variables block)))
-    (if (hash-table? bound-variables)
-	(let ((buckets (hash-table-buckets bound-variables)))
-	  (let ((m (vector-length buckets)))
-	    (let loop ((h 0) (result '()))
-	      (if (fix:= h m)
-		  result
-		  (loop (fix:+ h 1)
-			(if (vector-ref buckets h)
-			    (cons (vector-ref buckets h) result)
-			    result))))))
-	(cdr bound-variables))))
+  (for-each procedure (block/bound-variables block)))
 
 (define (block/unsafe! block)
   (if (block/safe? block)
diff --git a/src/sf/free.scm b/src/sf/free.scm
index 4d98ea629..88ba7e5cd 100644
--- a/src/sf/free.scm
+++ b/src/sf/free.scm
@@ -23,34 +23,23 @@ USA.
 
 |#
 
-;;;; SCode Optimizer: Free Variable Analysis
+;;;; SCode Optimizer: Free Variable Computation
+;;; package: (scode-optimizer free)
 
 (declare (usual-integrations)
-	 (integrate-external "object" "lsets"))
+	 (integrate-external "object"))
 
-(declare (integrate-operator no-free-variables singleton-variable
-			     list->variable-set))
-
-(define (no-free-variables) 
-  (empty-set variable? eq?))
-
-(define (singleton-variable variable) 
-  (singleton-set variable? eq? variable))
-
-(define (list->variable-set variable-list)
-  (list->set variable? eq? variable-list))
-
-(define (free/expressions expressions)
-  (if (null? expressions)
-      (no-free-variables)
-      (set/union (free/expression (car expressions))
-		 (free/expressions (cdr expressions)))))
-
 (declare (integrate-operator free/expression))
 
 (define (free/expression expression)
   ((expression/method dispatch-vector expression) expression))
 
+(define (free/expressions expressions)
+  (fold-left (lambda (answer expression)
+	       (set/union answer (free/expression expression)))
+	     (no-free-variables)
+	     expressions))
+
 (define dispatch-vector
   (expression/make-dispatch-vector))
 
@@ -73,13 +62,14 @@ USA.
 
 (define-method/free 'CONDITIONAL
   (lambda (expression)
-    (set/union*
+    (set/union
      (free/expression (conditional/predicate expression))
-     (free/expression (conditional/consequent expression))
-     (free/expression (conditional/alternative expression)))))
+     (set/union
+      (free/expression (conditional/consequent expression))
+      (free/expression (conditional/alternative expression))))))
 
 (define-method/free 'CONSTANT
-  (lambda (expression) 
+  (lambda (expression)
     expression
     (no-free-variables)))
 
@@ -96,34 +86,29 @@ USA.
     (set/union (free/expression (disjunction/predicate expression))
 	       (free/expression (disjunction/alternative expression)))))
 
-(define-method/free 'PROCEDURE
+(define-method/free 'OPEN-BLOCK
   (lambda (expression)
-    (set/difference
-     (free/expression (procedure/body expression))
-     (list->variable-set
-      (block/bound-variables-list (procedure/block expression))))))
+    (let ((omit (block/bound-variables (open-block/block expression))))
+     (fold-left (lambda (variables action)
+		  (if (eq? action open-block/value-marker)
+		      variables
+		      (set/union variables (set/difference (free/expression action) omit))))
+		(set/difference (free/expressions (open-block/values expression)) omit)
+		(open-block/actions expression)))))
 
-(define-method/free 'OPEN-BLOCK
+(define-method/free 'PROCEDURE
   (lambda (expression)
     (set/difference
-     (set/union (free/expressions (open-block/values expression))
-		(let loop ((actions (open-block/actions expression)))
-		  (cond ((null? actions) (no-free-variables))
-			((eq? (car actions) open-block/value-marker)
-			 (loop (cdr actions)))
-			(else
-			 (set/union (free/expression (car actions))
-				    (loop (cdr actions)))))))
-     (list->variable-set 
-      (block/bound-variables-list (open-block/block expression))))))
+     (free/expression (procedure/body expression))
+     (block/bound-variables (procedure/block expression)))))
 
 (define-method/free 'QUOTATION
-  (lambda (expression) 
+  (lambda (expression)
     expression
     (no-free-variables)))
 
 (define-method/free 'REFERENCE
-  (lambda (expression) 
+  (lambda (expression)
     (singleton-variable (reference/variable expression))))
 
 (define-method/free 'SEQUENCE
@@ -131,6 +116,28 @@ USA.
     (free/expressions (sequence/actions expression))))
 
 (define-method/free 'THE-ENVIRONMENT
-  (lambda (expression) 
+  (lambda (expression)
     expression
-    (no-free-variables)))
\ No newline at end of file
+    (no-free-variables)))
+
+(define-integrable (no-free-variables)
+  '())
+
+(define-integrable (singleton-variable variable)
+  (list variable))
+
+(define (set/adjoin set element)
+  (if (memq element set)
+      set
+      (cons element set)))
+
+(define-integrable (set/union left right)
+  (fold-left set/adjoin left right))
+
+(define (set/difference original remove)
+  (fold-left (lambda (answer element)
+	       (if (memq element remove)
+		   answer
+		   (set/adjoin answer element)))
+	     '()
+	     original))
diff --git a/src/sf/lsets.scm b/src/sf/lsets.scm
deleted file mode 100644
index db664ea5c..000000000
--- a/src/sf/lsets.scm
+++ /dev/null
@@ -1,334 +0,0 @@
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
-    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Unordered Set abstraction
-
-(declare (usual-integrations)
-	 (automagic-integrations)
-	 (open-block-optimizations))
-
-#|
-
-Each set has an ELEMENT-TYPE which is a predicate that all elements of
-the set must satisfy.  Each set has a PREDICATE that is used to compare
-identity of the elements.  An element appears in a set only once.
-
-This code is bummed up the wazoo for speed.  It is derived from a SET
-abstraction based on streams written by JRM.  I would not recommend trying
-to figure out what is going on in this code.
-
-;; User functions.
-
-(define empty-set)
-(define singleton-set)
-(define list->set)
-(define stream->set)
-(define set-element-type)
-
-(define set/member?)
-(define set/adjoin)
-(define set/adjoin*)
-(define set/remove)
-(define set->stream)
-(define set->list)
-(define set/for-each)
-(define set/map)
-(define set/empty?)
-(define set/union)
-(define set/union*)
-(define set/intersection)
-(define set/intersection*)
-
-(define any-type?)
-
-|#
-
-(define-integrable (check-type element-type element)
-  element-type element			;ignore
-  true)
-
-(define-integrable (member-procedure predicate) 
-  predicate				;ignore
-  memq)
-
-(define-integrable (list-deletor predicate)
-  (letrec ((list-deletor-loop
-	    (lambda (list)
-	      (if (pair? list)
-		  (if (predicate (car list))
-		      (list-deletor-loop (cdr list))
-		      (cons (car list) (list-deletor-loop (cdr list))))
-		  '()))))
-    list-deletor-loop))
-
-(define-integrable (set? object)
-  object				;ignore
-  true)
-
-(define-integrable (%make-set element-type predicate elements)
-  element-type predicate		;ignore
-  elements)
-
-(define-integrable (%unsafe-set-element-type set)
-  set					;ignore
-  (lambda (object) 
-    (declare (integrate object))
-    object				;ignore
-    true))
-
-(define-integrable (%unsafe-set-predicate set) 
-  set					;ignore
-  eq?)
-
-(define-integrable (%unsafe-set-elements set)
-  set)
-
-(define-integrable (set-element-type set)
-  (%unsafe-set-element-type set))
-
-(define-integrable (adjoin-lists-without-duplicates predicate l1 l2)
-  predicate				;ignore
-  (let loop ((new-list l1) (old-list l2))
-    (cond ((null? old-list) new-list)
-	  ((memq (car old-list) new-list) (loop new-list (cdr old-list)))
-	  (else (loop (cons (car old-list) new-list) (cdr old-list))))))
-
-(define-integrable (invert-sense predicate)
-  (lambda (object)
-    (declare (integrate object))
-    (not (predicate object))))
-
-(define-integrable (%subset predicate list)
-  ((list-deletor (invert-sense predicate)) list))
-
-(define-integrable (remove-duplicates predicate list)
-  (adjoin-lists-without-duplicates predicate '() list))
-
-(define (empty-set element-type predicate)
-  (%make-set element-type predicate '()))
-
-(define (singleton-set element-type predicate element)
-  (check-type element-type element)
-  (%make-set element-type predicate (cons element '())))
-
-(define (list->set element-type predicate elements)
-  (%make-set element-type predicate
-	     (let loop ((elements (apply list elements)))
-	       (cond ((null? elements) '())
-		     ((check-type element-type (car elements))
-		      (remove-duplicates predicate 
-				         (cons (car elements)
-					       (loop (cdr elements)))))
-		     (else (error "Can't happen"))))))
-
-(define (stream->set element-type predicate stream)
-  (%make-set element-type predicate
-	     (let loop ((stream stream))
-	       (cond ((empty-stream? stream) '())
-		     ((check-type element-type (head stream))
-		      (remove-duplicates predicate
-					 (cons (head stream)
-					       (loop (tail stream)))))
-		     (else (error "Can't happen"))))))
-
-;;; End of speed hack.
-
-(declare (integrate-operator spread-set))
-(define (spread-set set receiver)
-  (declare (integrate receiver))
-  (if (not (set? set))
-      (error "Object not a set" set))
-  (receiver (%unsafe-set-element-type set)
-	    (%unsafe-set-predicate    set)
-	    (%unsafe-set-elements     set)))
-
-#|
-(define (spread-2-sets set1 set2 receiver)
-  (declare (integrate set1 set2 receiver))
-  (spread-set set1
-    (lambda (etype1 pred1 stream1)
-      (spread-set set2
-        (lambda (etype2 pred2 stream2)
-	  (declare (integrate etype2 pred2))
-	  (if (not (and (eq? etype1 etype2)
-			(eq? pred1  pred2)))
-	      (error "Set mismatch")
-	      (receiver etype1 pred1 stream1 stream2)))))))
-|#
-(define-integrable (spread-2-sets set1 set2 receiver)
-  (spread-set set1
-    (lambda (etype1 pred1 stream1)
-      (declare (integrate etype1 pred1))
-      (spread-set set2
-        (lambda (etype2 pred2 stream2)
-	  etype2 pred2 ; are ignored
-	  (receiver etype1 pred1 stream1 stream2))))))
-
-(define (set/member? set element)
-  (spread-set set
-    (lambda (element-type predicate list)
-      (declare (integrate element-type predicate stream))
-      (check-type element-type element)
-      ((member-procedure predicate) element list))))
-
-(declare (integrate-operator adjoin-element))
-(define (adjoin-element predicate element list)
-  (declare (integrate list))
-  predicate				;ignore
-  (if (memq element list)
-      list
-      (cons element list)))
-
-(define (set/adjoin set element)
-  (spread-set set
-    (lambda (element-type predicate list)
-      (declare (integrate list))
-      (check-type element-type element)
-      (%make-set element-type predicate
-		 (adjoin-element predicate element list)))))
-
-(define (set/adjoin* set element-list)
-  (if (null? element-list)
-      set
-      (set/adjoin (set/adjoin* set (cdr element-list)) (car element-list))))
-
-(define (set/remove set element)
-  (spread-set set
-    (lambda (element-type predicate list)
-      (declare (integrate list))
-      (check-type element-type element)
-      (%make-set element-type predicate (delq element list)))))
-
-(define (set/subset set subset-predicate)
-  (spread-set set
-    (lambda (element-type predicate list)
-      (declare (integrate element-type predicate list))
-      (%make-set element-type predicate
-		 (%subset subset-predicate list)))))
-
-(define (set->stream set)
-  (spread-set set
-    (lambda (element-type predicate list)
-      (declare (integrate list))
-      element-type predicate		;ignore
-      (list->stream list))))
-
-(define (list->stream list)
-  (if (null? list)
-      the-empty-stream
-      (cons-stream (car list) (list->stream (cdr list)))))
-
-(define (set->list set)
-  (spread-set set
-    (lambda (element-type predicate l)
-      (declare (integrate list))
-      element-type predicate		;ignore
-      (apply list l))))
-
-(define (set/for-each function set)
-  (spread-set set
-    (lambda (element-type predicate list)
-      (declare (integrate list))
-      element-type predicate		;ignore
-      (for-each function list))))
-
-#|
-(define (set/map new-element-type new-predicate function set)
-  (spread-set set
-    (lambda (element-type predicate list)
-      (declare (integrate list))
-      element-type predicate		;ignore
-      (%make-set new-element-type new-predicate
-		 (remove-duplicates
-		  new-predicate
-		  (map (lambda (element)
-			 (let ((new-element (function element)))
-			   (if (new-element-type new-element)
-			       new-element
-			       (error "Element of wrong type" new-element))))
-		       list))))))
-|#
-
-(define (set/map new-element-type new-predicate function set)
-  (spread-set set
-    (lambda (element-type predicate list)
-      (declare (integrate list))
-      element-type predicate		;ignore
-      (%make-set new-element-type new-predicate
-		 (remove-duplicates eq? (map function list))))))
-
-(define (set/empty? set)
-  (spread-set set
-    (lambda (element-type predicate list)
-      (declare (integrate list))
-      element-type predicate		;ignore
-      (null? list))))
-
-(define (interleave l1 l2)
-  (if (null? l1)
-      l2
-      (cons (car l1) (interleave l2 (cdr l1)))))
-
-(define (set/union s1 s2)
-  (spread-2-sets s1 s2
-    (lambda (etype pred list1 list2)
-      (declare (integrate etype list1 list2))
-      (%make-set
-       etype pred
-       (adjoin-lists-without-duplicates pred list1 list2)))))
-
-(define (set/union* . sets)
-  (cond ((null? sets) (error "Set/union* with no args"))
-	((null? (cdr sets)) (car sets))
-	(else (set/union (car sets) (apply set/union* (cdr sets))))))
-
-(define (set/intersection s1 s2)
-  (spread-2-sets s1 s2
-    (lambda (etype pred l1 l2)
-      (%make-set etype pred
-		 (let loop ((elements l1))
-		   (cond ((null? elements) '())
-			 (((member-procedure pred) (car elements) l2)
-			  (cons (car elements) (loop (cdr elements))))
-			 (else (loop (cdr elements)))))))))
-
-(define (set/intersection* . sets)
-  (cond ((null? sets) (error "set/intersection* with no args"))
-	((null? (cdr sets)) (car sets))
-	(else (set/intersection (car sets)
-				(apply set/intersection* (cdr sets))))))
-
-(define (set/difference set1 set2)
-  (spread-2-sets set1 set2
-    (lambda (etype pred l1 l2)
-      (declare (integrate etype l1 l2))
-      (%make-set etype pred
-		 (%subset (lambda (l1-element)
-			    (not ((member-procedure pred) l1-element l2)))
-			  l1)))))
-
-(define (any-type? element)
-  element				;ignore
-  true)
\ No newline at end of file
diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index ca1e19b50..1e05367d7 100644
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -28,9 +28,7 @@ USA.
 (global-definitions "../runtime/runtime")
 
 (define-package (scode-optimizer)
-  (files "lsets"
-	 "table"
-	 "pthmap"
+  (files "pthmap"
 	 "object"
 	 "emodel"
 	 "gconst"
diff --git a/src/sf/sf.sf b/src/sf/sf.sf
index 67e0bb410..620a02f30 100644
--- a/src/sf/sf.sf
+++ b/src/sf/sf.sf
@@ -39,7 +39,6 @@ USA.
 	       THE-ENVIRONMENT?
 	       VARIABLE?)))
   (sf-conditionally "object")
-  (sf-conditionally "lsets")
   (sf-directory "."))
 
 (load-option 'CREF)
diff --git a/src/sf/subst.scm b/src/sf/subst.scm
index 70ff16421..2c168a63e 100644
--- a/src/sf/subst.scm
+++ b/src/sf/subst.scm
@@ -27,7 +27,7 @@ USA.
 ;;; package: (scode-optimizer integrate)
 
 (declare (usual-integrations)
-	 (integrate-external "object" "lsets"))
+	 (integrate-external "object"))
 
 (define *top-level-block*)
 
@@ -1208,7 +1208,7 @@ forms are simply removed.
 	  (else
 	   (let ((this-parameter (car parameters))
 		 (this-operand   (car operands)))
-	     (cond ((set/member? free-in-body this-parameter)
+	     (cond ((memq this-parameter free-in-body)
 		    (loop (cdr parameters)
 			  (cdr operands)
 			  (cons this-parameter required-parameters)
@@ -1230,387 +1230,9 @@ forms are simply removed.
 
 (define *block-optimizing-switch #f)
 
-;; This is overly hairy, but if it works, no one need know.
-;; What we do is this:
-;; 1 Make a directed graph of the dependencies in an open
-;;    block.
-;; 2 Identify the circular dependencies and place them in
-;;    a open block.
-;; 3 Identify the bindings that can be made in parallel and
-;;    make LET type statements.
-;; 4 This deletes unused bindings in an open block and
-;;    compartmentalizes the environment.
-;; 5 Re-optimize the code in the body.  This can help if the
-;;    eta-substitution-switch is on.
-
 (define (open-block/optimizing-make expression block vars values
 				    actions operations environment)
-  (if (and *block-optimizing-switch
-	   (block/safe? block))
-      (let ((table:var->vals (associate-vars-and-vals vars values))
-	    (bound-variables (varlist->varset vars)))
-	(let ((table:vals->free
-	       (get-free-vars-in-bindings bound-variables values))
-	      (body-free (get-body-free-vars bound-variables actions)))
-	  ;; (write-string "Free vars in body")
-	  ;; (display (map variable/name body-free))
-	  (let ((graph (build-graph vars
-				    table:var->vals
-				    table:vals->free
-				    body-free)))
-	    (collapse-circularities! graph)
-	    ;; (print-graph graph)
-	    (label-node-depth! graph)
-	    (let ((template (linearize graph)))
-	      ;; (print-template template)
-	      (integrate/expression
-	       operations environment
-	       (build-new-code expression
-			       template
-			       (block/parent block)
-			       table:var->vals actions))))))
-      (open-block/make
-       (and expression (object/scode expression))
-       block vars values actions #t)))
-
-#|
-(define (print-template template)
-  (if (null? template)
-      '()
-      (let ((this (car template)))
-	(newline)
-	(display (car this))
-	(display (map variable/name (cdr this)))
-	(print-template (cdr template)))))
-|#
-
-(define (associate-vars-and-vals vars vals)
-  (let ((table (make-generic-eq?-table)))
-    (define (fill-table vars vals)
-      (cond ((null? vars) (if (null? vals) '() (error "Mismatch")))
-	    ((null? vals) (error "Mismatch"))
-	    (else (table-put! table (car vars) (car vals))
-		  (fill-table (cdr vars) (cdr vals)))))
-    (fill-table vars vals)
-    table))
-
-(declare (integrate varlist->varset nodelist->nodeset
-		    empty-nodeset singleton-nodeset
-		    empty-varset singleton-varset))
-
-(define (varlist->varset list)
-  (declare (integrate list))
-  (list->set variable? eq? list))
-
-(define (nodelist->nodeset list)
-  (declare (integrate list))
-  (list->set node? eq? list))
-
-(define (empty-nodeset)
-  (empty-set node? eq?))
-
-(define (singleton-nodeset node)
-  (declare (integrate node))
-  (singleton-set node? eq? node))
-
-(define (empty-varset)
-  (declare (integrate node))
-  (empty-set variable? eq?))
-
-(define (singleton-varset variable)
-  (declare (integrate variable))
-  (singleton-set variable? eq? variable))
-
-(define (get-free-vars-in-bindings bound-variables vals)
-  ;; find variables in bindings that are scoped to these
-  ;; bound variables
-  (let ((table (make-generic-eq?-table)))
-    (define (kernel val)
-      (let ((free-variables (free/expression val)))
-	(table-put! table val
-		    (set/intersection bound-variables free-variables))))
-    (for-each kernel vals)
-    table))
-
-(define (get-body-free-vars bound-variables actions)
-  (let ((body-forms (get-body actions)))
-    (let loop ((body-forms body-forms)
-	       (free (empty-varset)))
-      (if (null? body-forms)
-	  free
-	  (loop (cdr body-forms)
-		(set/union free
-			   (set/intersection bound-variables
-					     (free/expression
-					      (car body-forms)))))))))
-
-(define (get-body actions)
-  (cond ((null? actions) '())
-	((eq? (car actions) open-block/value-marker) (get-body (cdr actions)))
-	(else (cons (car actions) (get-body (cdr actions))))))
-
-;;; Graph structure for figuring out dependencies in a LETREC
-
-(define-structure (node
-		   (constructor %make-node (type vars))
-		   (conc-name %node-))
-  type
-  (vars #f read-only #t)
-  (needs (empty-nodeset))
-  (needed-by (empty-nodeset))
-  (depth #f))
-
-(define-integrable (make-base-node)
-  (%make-node 'BASE (empty-varset)))
-
-(define-integrable (variable->node variable)
-  (%make-node 'SETUP (singleton-varset variable)))
-
-(define-integrable (make-letrec-node variable-set)
-  (%make-node 'LETREC variable-set))
-
-(define-integrable (add-node-need! needer what-i-need)
-  (set-%node-needs! needer (set/adjoin (%node-needs needer) what-i-need)))
-
-(define-integrable (remove-node-need! needer what-i-no-longer-need)
-  (set-%node-needs! needer
-		    (set/remove (%node-needs needer) what-i-no-longer-need)))
-
-(define-integrable (add-node-needed-by! needee what-needs-me)
-  (set-%node-needed-by! needee
-			(set/adjoin (%node-needed-by needee) what-needs-me)))
-
-(define-integrable (remove-node-needed-by! needee what-needs-me)
-  (set-%node-needed-by! needee
-			(set/remove (%node-needed-by needee) what-needs-me)))
-
-(define (build-graph vars table:var->vals table:vals->free body-free)
-  (let ((table:variable->node (make-generic-eq?-table)))
-
-    (define (kernel variable)
-      (let ((node (variable->node variable)))
-	(table-put! table:variable->node variable node)))
-
-    (for-each kernel vars)
-
-    (link-nodes! body-free table:var->vals table:vals->free vars
-		 table:variable->node)))
-
-(define-integrable (link-2-nodes! from-node to-node)
-  (add-node-need! from-node to-node)
-  (add-node-needed-by! to-node from-node))
-
-(define (unlink-node! node)
-  (set/for-each (lambda (needer)
-		  (remove-node-needed-by! needer node))
-		(%node-needs node))
-  (set/for-each (lambda (needee)
-		  (remove-node-need! needee node))
-		(%node-needed-by node))
-  (set-%node-type! node 'UNLINKED))
-
-(define-integrable (unlink-nodes! nodelist)
-  (for-each unlink-node! nodelist))
-
-(define (link-nodes! body-free
-		    table:var->vals table:vals->free variables table:var->node)
-
-  (define (kernel variable)
-    (table-get table:var->node variable
-      (lambda (node)
-	(table-get-chain variable
-	  (lambda (free-vars)
-	    (set/for-each
-	      (lambda (needed-var)
-		(table-get table:var->node needed-var
-			   (lambda (needed-node)
-			     (link-2-nodes! node needed-node))
-			   (lambda ()
-			     (error "Broken analysis: can't get node"))))
-	      free-vars))
-	  (lambda () (error "Broken analysis: can't get free variable info"))
-	  table:var->vals table:vals->free))
-      (lambda () (error "Broken analysis: no node for variable"))))
-
-  (for-each kernel variables)
-
-  (let ((base-node (make-base-node)))
-    (set/for-each
-     (lambda (needed-var)
-       (table-get table:var->node needed-var
-		  (lambda (needed-node)
-		    (link-2-nodes! base-node needed-node))
-		  (lambda () (error "Broken analysis: free var"))))
-     body-free)
-    base-node))
-
-(define (collapse-circularities! graph)
-  ;; Search for a circularity:  if found, collapse it, and repeat
-  ;; until none are found.
-  (define (loop)
-    (find-circularity graph
-      (lambda (nodelist)
-	(collapse-nodelist! nodelist)
-	(loop))
-      (lambda () graph)))
-  (loop))
-
-(define (find-circularity graph if-found if-not)
-  ;; Walk the tree keeping track of nodes visited
-  ;; If a node is encountered more than once, there is
-  ;; a circularitiy.  NODES-VISITED is a list kept in
-  ;; base node first order.  If a node is found on the
-  ;; list, the tail of the list is the nodes in the
-  ;; circularity.
-
-  (define (fc this-node nodes-visited if-found if-not)
-    (if (null? this-node)
-	(if-not)
-	(let ((circularity (memq this-node nodes-visited)))
-	  (if circularity
-	      (if-found circularity)
-	      ;; Add this node to the visited list, and loop
-	      ;; over the needs of this node.
-	      (let ((new-visited (append nodes-visited (list this-node))))
-		(let loop ((needs (set->list (%node-needs this-node))))
-		  (if (null? needs)
-		      (if-not)
-		      (fc (car needs) new-visited if-found
-			  (lambda () (loop (cdr needs)))))))))))
-
-  (fc graph '() if-found if-not))
-
-(define (collapse-nodelist! nodelist)
-  ;; Replace the nodes in the nodelist with a single node that
-  ;; has all the variables in it.  This node will become a LETREC
-  ;; form.
-
-  ;; Error check:  make sure graph is consistant.
-  (for-each (lambda (node) (if (eq? (%node-type node) 'UNLINKED)
-			       (error "node not linked")))
-	    nodelist)
-
-  (let ((nodeset (nodelist->nodeset nodelist)))
-    (let ((varset (apply set/union* (map %node-vars nodelist)))
-	  (needs-set  (set/difference
-		       (apply set/union* (map %node-needs nodelist))
-		       nodeset))
-	  (needed-by (set/difference
-		      (apply set/union* (map %node-needed-by nodelist))
-		      nodeset)))
-
-    (let ((letrec-node (make-letrec-node varset)))
-      (set/for-each (lambda (need) (link-2-nodes! letrec-node need))
-		    needs-set)
-      (set/for-each
-       (lambda (needer) (link-2-nodes! needer letrec-node)) needed-by)
-      ;; now delete nodes in nodelist
-      (unlink-nodes! nodelist)))))
-
-(define (label-node-depth! graph)
-  (define (label-nodes! nodeset depth)
-    (if (set/empty? nodeset)
-	'()
-	(begin
-	  (set/for-each (lambda (node) (set-%node-depth! node depth)) nodeset)
-	  (label-nodes!
-	   (apply set/union* (map %node-needs (set->list nodeset)))
-	   (1+ depth)))))
-  (label-nodes! (singleton-nodeset graph) 0))
-
-#|
-(define (print-graph node)
-  (if (null? node)
-      '()
-      (begin
-	(newline)
-	(display (%node-depth node))
-	(display (%node-type node))
-	(set/for-each (lambda (variable)
-			(display " ")
-			(display (variable/name variable)))
-		      (%node-vars node))
-	(set/for-each print-graph (%node-needs node)))))
-|#
-
-(define (collapse-parallel-nodelist depth nodeset)
-  (if (set/empty? nodeset)
-      '()
-      (let loop ((nodestream      (set->list nodeset))
-		 (let-children    (empty-varset))
-		 (letrec-children (empty-varset))
-		 (children        (empty-nodeset)))
-	(if (null? nodestream)
-	    (let ((outer-contour
-		   (collapse-parallel-nodelist (1+ depth) children)))
-	      (append (if (set/empty? let-children)
-			  '()
-			  (list (cons 'LET (set->list let-children))))
-		      (if (set/empty? letrec-children)
-			  '()
-			  (list (cons 'LETREC (set->list letrec-children))))
-		      outer-contour))
-	    (let ((this-node (car nodestream)))
-	      (if (= (%node-depth this-node) (1+ depth))
-		  (if (eq? (%node-type this-node) 'LETREC)
-		      (loop (cdr nodestream)
-			    let-children
-			    (set/union (%node-vars this-node) letrec-children)
-			    (set/union (%node-needs this-node) children))
-		      (loop (cdr nodestream)
-			    (set/union (%node-vars this-node) let-children)
-			    letrec-children
-			    (set/union (%node-needs this-node) children)))
-		  ;; deeper nodes will be picked up later
-		  (loop (cdr nodestream)
-			let-children
-			letrec-children
-			children)))))))
-
-(define (linearize graph)
-  (collapse-parallel-nodelist 0 (%node-needs graph)))
-
-(define (build-new-code expression template parent vars->vals actions)
-  (let ((body (sequence/optimizing-make expression (get-body actions))))
-    (let loop ((template template)
-	       (block    parent)
-	       (code     body))
-      (if (null? template)
-	   code
-	   (let ((this (car template)))
-	     (let ((this-type (car this))
-		   (this-vars (cdr this)))
-	       (let ((this-vals
-		      (map (lambda (var)
-			     (table-get vars->vals var
-					(lambda (val) val)
-					(lambda () (error "broken"))))
-			   this-vars)))
-
-	       (if (eq? this-type 'LET)
-		   (let ((block (block/make block #t this-vars)))
-		     (loop (cdr template)
-			   block
-			   (combination/optimizing-make
-			    expression
-			    block
-			    (procedure/make
-			     #f
-			     block
-			     lambda-tag:let
-			     this-vars
-			     '()
-			     #f
-			     code)
-			    this-vals)))
-		   (let ((block (block/make block #t this-vars)))
-		     (loop (cdr template)
-			   block
-			   (open-block/make
-			    (and expression (object/scode expression))
-			    block this-vars this-vals
-			    (append (make-list
-				     (length this-vals)
-				     open-block/value-marker)
-				    (list code))
-			    #t)))))))))))
\ No newline at end of file
+  (declare (ignore operations environment))
+  (open-block/make
+   (and expression (object/scode expression))
+   block vars values actions #t))
diff --git a/src/sf/table.scm b/src/sf/table.scm
deleted file mode 100644
index 443523c4a..000000000
--- a/src/sf/table.scm
+++ /dev/null
@@ -1,125 +0,0 @@
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
-    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(declare (usual-integrations)
-	 (automagic-integrations)
-	 (open-block-optimizations)
-	 (eta-substitution))
-
-;;; simple table abstraction
-;;;
-;;; A table is a mutable mapping from key to value.  There is a
-;;; comparison function to determine whether two keys are the same
- 
-;;; A table is a 4 tuple consisting of a get-function, a put-function,
-;;; a remove-function, and a function to handle anything else.
-;;;
-
-;;; My big problem with this is that we have to go through the continuation
-;;; passing style get function whether we want to or not.
-
-(define-structure (table (conc-name %table-)
-			 (constructor %make-table))
-  (get-function false read-only true)
-  (put!-function false read-only true)
-  (remove!-function false read-only true)
-  (anything-else false read-only true))
-
-(define-integrable (table-get table key if-found if-not-found)
-  ((%table-get-function table) key if-found if-not-found))
-
-(define-integrable (table-put! table key value)
-  ((%table-put!-function table) key value))
-
-(define-integrable (table-remove! table key)
-  ((%table-remove!-function table) key))
-
-(define-integrable (table-function table operation arglist)
-  ((%table-anything-else table) operation arglist))
-
-(define (table-get-chain key1 if-found if-not-found . tables)
-  (let loop ((table-list tables)
-	     (key        key1))
-    (if (null? table-list)
-	(if-found key)
-	(table-get (car table-list) key
-	  (lambda (value) 
-	    (loop (cdr table-list) value))
-	  if-not-found))))
-
-(define (table-get-list table keylist)
-  (map (lambda (key)
-	 (table-get table key 
-		    identity-procedure
-		    (lambda () #f)))
-       keylist))
-
-;;; Returns a table
-
-(define (make-generic-eq?-table)
-  (let ((the-table '()))
-
-    (declare (integrate make-entry 
-			entry-value
-			set-entry-value!
-			lookup 
-			extend-table!))
-
-    (define make-entry cons)
-    (define entry-value cdr)
-    (define set-entry-value! set-cdr!)
-
-    (define (lookup key)
-      (declare (integrate key))
-      (assq key the-table))
-
-    (define (extend-table! entry)
-      (declare (integrate entry))
-      (set! the-table (cons entry the-table)))
-
-    ;; User functions
-
-    (define (get key if-found if-not-found)
-      (let ((entry (lookup key)))
-	(if (not entry)
-	    (if-not-found)
-	    (if-found (entry-value entry)))))
-
-    (define (put! key value)
-      (let ((entry (lookup key)))
-	(if (not entry)
-	    (extend-table! (make-entry key value))
-	    (set-entry-value! entry value))))
-
-    (define (remove! key)
-      (set! the-table (del-assq key the-table)))
-
-    (define (dispatch message args)
-      args
-      (case message
-	((predicate) eq?)
-	(else (error "Don't understand that message"))))
-
-    (%make-table get put! remove! dispatch)))
\ No newline at end of file
diff --git a/src/sf/xform.scm b/src/sf/xform.scm
index 1a4d4100c..73eca2e55 100644
--- a/src/sf/xform.scm
+++ b/src/sf/xform.scm
@@ -50,7 +50,7 @@ USA.
     (let ((environment
 	   (if top-level?
 	       (environment/bind (environment/make)
-				 (block/bound-variables-list block))
+				 (block/bound-variables block))
 	       (environment/make))))
       (if (scode-open-block? expression)
 	  (begin
@@ -190,7 +190,7 @@ USA.
 	  (lambda (required optional rest)
 	    (let ((environment
 		   (environment/bind environment
-				     (block/bound-variables-list block))))
+				     (block/bound-variables block))))
 	      (procedure/make
 	       expression block name required optional rest
 	       (transform/procedure-body block