[Gcl-commits] gcl debianchangelog lsp/gcl_callhash.lsp cmpnew...

[Camm Maguire]

CVSROOT:        /cvsroot/gcl
Module name:    gcl
Changes by:     Camm Maguire <camm>     06/06/08 18:54:09

Modified files:
        debian         : changelog 
        lsp            : gcl_callhash.lsp 
        cmpnew         : gcl_cmptop.lsp 

Log message:
        first automatic state function for mutual recursion support

CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/gcl/debian/changelog?cvsroot=gcl&r1=1.1087&r2=1.1088
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_callhash.lsp?cvsroot=gcl&r1=1.2&r2=1.3
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmptop.lsp?cvsroot=gcl&r1=1.35&r2=1.36

Patches:
Index: debian/changelog
===================================================================
RCS file: /cvsroot/gcl/gcl/debian/changelog,v
retrieving revision 1.1087
retrieving revision 1.1088
diff -u -b -r1.1087 -r1.1088
--- debian/changelog    8 Jun 2006 18:40:08 -0000       1.1087
+++ debian/changelog    8 Jun 2006 18:54:08 -0000       1.1088
@@ -174,8 +174,9 @@
   * auto-recompilation support
   * fix read-char-no-hang
   * string comparison functions are not predicates
+  * first automatic state function for mutual recursion support
 
- -- Camm Maguire <address@hidden>  Thu,  8 Jun 2006 18:39:52 +0000
+ -- Camm Maguire <address@hidden>  Thu,  8 Jun 2006 18:53:52 +0000
 
 gclcvs (2.7.0-53) unstable; urgency=low
 

Index: lsp/gcl_callhash.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_callhash.lsp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -b -r1.2 -r1.3
--- lsp/gcl_callhash.lsp        6 Jun 2006 19:50:42 -0000       1.2
+++ lsp/gcl_callhash.lsp        8 Jun 2006 18:54:08 -0000       1.3
@@ -22,6 +22,7 @@
             (defvar *call-hash-table* (make-hash-table :test 'eq))
             (defvar *needs-recompile* (make-array 10 :fill-pointer 0 
:adjustable t))
             (defvar *ach* (make-hash-table :test 'eq))
+            (defvar *acr* (make-hash-table :test 'eq))
             (setq *boot* t)
             (mapc 'eval (nreverse *pahl*))
             (setq *pahl* nil))))
@@ -71,7 +72,7 @@
                    (setf (call-callees h) (call-callees new) (call-src h) 
(call-src new)))
                   ((setf (call-callees h) nil (call-src h) nil))))))))
 
-(defun add-recompile (fn why assumed-sig actual-sig)(when (and (eq 
(symbol-package why) (find-package "COMPILER")) (equal (symbol-name why) 
"VAR-KIND")) (break "~s ~s ~s ~s~%" fn why assumed-sig actual-sig))
+(defun add-recompile (fn why assumed-sig actual-sig)
   (unless (find fn *needs-recompile* :key 'car)
 ;    (format t "add-recompile ~s ~s ~s ~s~%" fn why assumed-sig actual-sig)
     (vector-push-extend (list fn why assumed-sig actual-sig) *needs-recompile*)
@@ -100,21 +101,34 @@
             (unless (intersection z y) (setf (gethash x *ach*) (set-difference 
r y)))
             r))))))
 
-;      (let* ((z (call-callees (gethash x *call-hash-table*))) 
-;           (r (union z y))
-;           (q (dolist (l (set-difference z y) r)
-;                (setq r (all-callees l r)))))
-;      (unless (intersection z y) (setf (gethash x *ach*) (set-difference q 
y)))
-;      q))))
+(defun all-callers (x y)
+  (let ((z (gethash x *acr*)))
+    (if z (union z y)
+      (let ((z (call-callers (gethash x *call-hash-table*))))
+       (do ((l (set-difference z y) (cdr l))
+            (r (union z y) (all-callers (car l) r)))
+           ((endp l) 
+            (unless (intersection z y) (setf (gethash x *acr*) (set-difference 
r y)))
+            r))))))
+
+(defun block-lambda (ll block body)
+  (let* ((z body)
+        (doc (when (and z (stringp (car z))) (list (pop z))))
+        (decls (let (d) (do nil ((or (not z) (not (consp (car z))) (not (eq 
(caar z) 'declare))) (nreverse d))
+                             (push (pop z) d))))
+        (rest z))
+  `(lambda ,ll ,@doc ,@decls (block ,block ,@rest))))
+       
 
 (defun function-lambda-expression (x) 
   (if (typep x 'interpreted-function) 
       (let* ((x (si::interpreted-function-lambda x)))
        (case (car x)
              (lambda (values x nil nil))
-             (lambda-block (values (cons 'lambda (cddr x))  nil (cadr x)))
+             (lambda-block (values (block-lambda (caddr x) (cadr x) (cdddr x)) 
nil (cadr x)))
              (lambda-closure (values (cons 'lambda (cddr (cddr x)))  (not (not 
(cadr x)))  nil))
-             (lambda-block-closure (values (cons 'lambda (cdr (cddr (cddr 
x))))  (not (not (cadr x))) (fifth x)))
+             (lambda-block-closure (values (block-lambda (caddr (cdddr x)) 
(cadr (cdddr x)) (cddr (cddr (cddr x)))) 
+                                    (not (not (cadr x))) (fifth x)))
              (otherwise (values nil t nil))))
     (values nil t nil)))
 
@@ -129,10 +143,37 @@
         out)))
    (and (fboundp sym) (typep (symbol-function sym) 'interpreted-function) 
(function-lambda-expression (symbol-function sym)))))
 
+(defun inlinef (n syms)
+  (let* ((fns (mapcar 'si::function-src syms))
+        (sts (let (sts) (dotimes (i (length syms) (nreverse sts)) (push i 
sts))))
+        (lsst (1- (length sts)))
+        (ll (cadr (car fns))))
+    `(defun ,n ,(append ll '(state))
+       (declare (fixnum state))
+       ,@(let (d (z (cddr (car fns)))) 
+          (when (stringp (car z)) (pop z))
+          (do nil ((or (not z) (not (consp (car z))) (not (eq (caar z) 
'declare))) (nreverse d)) (push (pop z) d)))
+       (macrolet ,(mapcan (lambda (x y z) `((,x ,(cadr y) `(,',n ,,@(cadr y) 
,,z)))) syms fns sts)
+        (case state
+          ,@(mapcar (lambda (x y) `(,(if (= x lsst) 'otherwise x) (funcall ,y 
,@ll))) sts fns))))))
+
+(defun convert-to-state (sym)
+  (let* ((n (intern (symbol-name (gensym (symbol-name sym))) (symbol-package 
sym)))
+        (syms (intersection (all-callees sym nil) (all-callers sym nil)))
+        (sts (let (sts) (dotimes (i (length syms) (nreverse sts)) (push i 
sts))))
+        (ns (inlinef n syms)))
+    (eval ns)
+    (mapc (lambda (x y) (let ((z (butlast (caddr ns)))) (eval `(defun ,x ,z 
(,n ,@z ,y))))) syms sts)
+    (dolist (l syms) (add-hash l nil (list (list n)) nil))
+    n))
+    
+    
+
 (defun do-recompile (&optional (pn "/tmp/recompile.lsp" pnp))
   (unless (or *disable-recompile* (= 0 (length *needs-recompile*)))
     (let ((*disable-recompile* t))
       (clrhash *ach*)
+      (clrhash *acr*)
       (setq *needs-recompile* 
            (sort *needs-recompile* ;FIXME
                  (lambda (x y) 

Index: cmpnew/gcl_cmptop.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmptop.lsp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -b -r1.35 -r1.36
--- cmpnew/gcl_cmptop.lsp       5 Jun 2006 22:02:45 -0000       1.35
+++ cmpnew/gcl_cmptop.lsp       8 Jun 2006 18:54:09 -0000       1.36
@@ -551,7 +551,9 @@
               (multiple-value-bind `(,(car form) ,(cadr form) 
,(portable-source (caddr form))
                                      ,@(let ((r (remove-if-not 'si::specialp 
(cadr form))))
                                          (when r `((declare (special ,@r)))))
-                                     ,@(ndbctxt (portable-source (cdddr form) 
t))))))
+                                     ,@(ndbctxt (portable-source (cdddr form) 
t))))
+              ((case ccase ecase) `(,(car form) ,(portable-source (cadr form))
+                                    ,@(mapcar (lambda (x) `(,(car x) 
,@(portable-source (cdr x) t))) (cddr form))))))
        ((let* ((fd (and (symbolp (car form)) (not (member (car form) *mlts*))
                         (or (get (car form) 'si::compiler-macro-prop) 
(macro-function (car form)))))
                (nf (if fd (cmp-expand-macro fd (car form) (cdr form)) form)))