1 files changed, 182 insertions, 0 deletions
diff --git a/csys/dump-cse.scm b/csys/dump-cse.scm
new file mode 100644
index 0000000..38ec020
--- /dev/null
+++ b/csys/dump-cse.scm
@@ -0,0 +1,182 @@
+;;; This file handles common subexpressions in the interface file.
+;;; Common subexpressions are detected in two places: gtypes and strictness
+;;; properties.
+
+;;; Compressing strictness signatures
+
+;;; A strictness is represented by a list of booleans.  We do two things to
+;;; compress strictnesses: all lists less than *pre-defined-strictness-size*
+;;; are pre-computed in a vector and the first *pre-defined-strictness-vars*
+;;; vector elements are cached in global vars.  The strictness will dump as
+;;; as either a global or as a vector reference into the vector.
+
+(define (initialize-strictness-table)
+  (setf (dynamic *pre-defined-strictness-table*)
+	(make-vector (expt 2 (1+ (dynamic *pre-defined-strictness-size*)))))
+  (setf (vector-ref *pre-defined-strictness-table* 1) '())
+  (do ((i 1 (1+ i))
+       (j 1 (* j 2))
+       (k 2 (* k 2)))
+      ((> i *pre-defined-strictness-size*))
+    (do ((l 0 (1+ l)))
+	((>= l j))
+      (setf (vector-ref *pre-defined-strictness-table* (+ k l))
+	    (cons '#f (vector-ref *pre-defined-strictness-table* (+ j l))))
+      (setf (vector-ref *pre-defined-strictness-table* (+ k j l))
+	    (cons '#t (vector-ref *pre-defined-strictness-table* (+ j l))))))
+  (set-strictness-vars))
+
+(define (strictness-table-ref x)
+  (vector-ref (dynamic *pre-defined-strictness-table*) x))
+
+(define (dump-strictness s)
+  (if (null? s)
+      ''()
+      (dump-strictness-1 s s 0 0)))
+
+(define (dump-strictness-1 s s1 n size)
+  (if (null? s1)
+      (if (> size *pre-defined-strictness-size*)
+	  (dump-big-strictness (- size *pre-defined-strictness-size*) s)
+	  (let ((k (+ n (expt 2 size))))
+	    (if (< k *pre-defined-strictness-vars*)
+		`(dynamic ,(vector-ref *pre-defined-strictness-names* k))
+		`(strictness-table-ref ,k))))
+      (dump-strictness-1 s (cdr s1) (+ (* 2 n) (if (car s1) 1 0)) (1+ size))))
+
+(define (dump-big-strictness k s)
+  (if (= k 0)
+      (dump-strictness s)
+      `(cons ',(car s)
+	     ,(dump-big-strictness (1- k) (cdr s)))))
+
+;;; This routine handles saving type signatures (gtypes).  
+;;; common subexpressions are detected in two places: the type body
+;;; and the the contexts.
+
+(define (init-predefined-gtyvars)
+  (setf *saved-gtyvars* (make-vector *num-saved-gtyvars*))
+  (dotimes (i *num-saved-gtyvars*)
+     (setf (vector-ref *saved-gtyvars* i) (**gtyvar i)))
+  (setup-gtyvar-vars))
+
+(define (init-cse-structs)
+  (initialize-strictness-table)
+  (init-predefined-gtyvars))
+
+(define (save-cse-value v)
+  (setf (vector-ref (dynamic *saved-cse-values*) (dynamic *cse-value-num*)) v)
+  (incf (dynamic *cse-value-num*)))
+
+(define (cse-init-code)
+  (let* ((n (length *cse-objects*))
+	 (init-code '()))
+    (do ((i (1- n) (1- i))
+	 (init *cse-objects* (cdr init)))
+	((null? init))
+      (push `(save-cse-value ,(car init)) init-code))
+    `((setf *saved-cse-values* (make-vector ,n))
+      (setf *cse-value-num* 0)
+      ,@init-code)))
+
+(define (remember-dumped-object init-code)
+  (push init-code *cse-objects*)
+  (incf *cse-object-num*)
+  *cse-object-num*)
+
+(define (cse-value-ref x)
+  (vector-ref (dynamic *saved-cse-values*) x))
+
+(define (cse-ref-code n)
+  (cond ((eqv? n 0)
+	 ''())
+	((<= n *num-saved-gtyvars*)
+	 `(dynamic ,(vector-ref *saved-gtyvar-varnames* (1- n))))
+	(else
+	 `(cse-value-ref ,(- n *num-saved-gtyvars* 1)))))
+
+(define (dump-gtyvar g)
+  (let ((n (gtyvar-varnum g)))
+    (if (< n *num-saved-gtyvars*)
+	(1+ n)
+	(remember-dumped-object `(**gtyvar ,n)))))
+
+(define (dump-context-list contexts)
+  (if (null? contexts)
+      0
+      (let* ((rest (dump-context-list (cdr contexts)))
+	     (classes (dump-class-list (car contexts)))
+	     (t1 (assq/insert-l classes *gtype-class-index*))
+	     (res (assq/insert rest (cdr t1))))
+	  (if (eq? (cdr res) '#f)
+	      (let ((z (remember-dumped-object
+			`(cons ,(cse-ref-code classes) ,(cse-ref-code rest)))))
+		(setf (cdr res) z)
+		z)
+	      (cdr res)))))
+
+(define (dump-class-list classes)
+  (if (null? classes)
+      0
+      (let* ((rest (dump-class-list (cdr classes)))
+	     (class (dump-class/n (car classes)))
+	     (t1 (assq/insert-l class *context-class-index*))
+	     (res (assq/insert rest (cdr t1))))
+	  (if (eq? (cdr res) '#f)
+	      (let ((z (remember-dumped-object
+			`(cons ,class ,(cse-ref-code rest)))))
+		(setf (cdr res) z)
+		z)
+	      (cdr res)))))
+	
+(define (dump-gtype-1 g)
+  (cond ((gtyvar? g)
+	 (dump-gtyvar g))
+	((ntyvar? g)
+	 (dump-gtype-1 (prune g)))
+	(else
+	 (dump-gtycon g))))
+
+(define (dump-gtycon g)
+  (let* ((ty (ntycon-tycon g))
+	 (tycon (if (algdata? ty) (dump-algdata/n ty) (dump-synonym/n ty)))
+	 (l (dump-gtype-list (ntycon-args g)))
+	 (t1 (assq/insert-l tycon *gtype-tycon-index*))
+	 (res (assq/insert l (cdr t1))))
+    (if (eq? (cdr res) '#f)
+	(let ((z (remember-dumped-object
+		  `(**ntycon ,tycon ,(cse-ref-code l)))))
+	  (setf (cdr res) z)
+	  z)
+	(cdr res))))
+
+(define (dump-gtype-list l)
+  (if (null? l)
+      0
+      (let* ((g (dump-gtype-1 (car l)))
+	     (rest (dump-gtype-list (cdr l)))
+	     (t1 (assq/insert-l g *gtype-list-index*))
+	     (res (assq/insert rest (cdr t1))))
+	(if (eq? (cdr res) '#f)
+	    (let ((z (remember-dumped-object
+		      `(cons ,(cse-ref-code g)
+			     ,(cse-ref-code rest)))))
+	      (setf (cdr res) z)
+	      z)
+	    (cdr res)))))
+
+(define (dump-gtype/cse g)
+ (cse-ref-code
+  (let* ((context (dump-context-list (gtype-context g)))
+	 (type (dump-gtype-1 (gtype-type g)))
+	 (t1 (assq/insert-l type *gtype-index*))
+	 (res (assq/insert context (cdr t1))))
+    (if (eq? (cdr res) '#f)
+	(let ((z (remember-dumped-object
+		      `(**gtype ,(cse-ref-code context)
+				,(cse-ref-code type)))))
+	      (setf (cdr res) z)
+	      z)
+	(cdr res)))))
+
+