From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- csys/dump-cse.scm | 182 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) create mode 100644 csys/dump-cse.scm (limited to 'csys/dump-cse.scm') 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))))) + + -- cgit v1.2.3