Changeset 635

Timestamp:

Mar 7, 2004, 12:03:30 AM (21 years ago)

Author:

Gary Byers

Message:

Don't use dynamic block/go tags. Forget about event-polling, etc.

Location:

trunk/ccl/compiler

Files:

• nx0.lisp (modified) (5 diffs)
• nx1.lisp (modified) (10 diffs)

trunk/ccl/compiler/nx0.lisp

@@ -44 +44 @@
 (defvar *nx-cur-func-name* nil)
 (defvar *nx-form-type* t)
-(defvar *nx-nlexit-count* 0)
-(defvar *nx-event-checking-call-count* 0)
 ;(defvar *nx-proclaimed-inline* nil)
 ;(defvar *nx-proclaimed-inline* (make-hash-table :size 400 :test #'eq))
@@ -1068 +1066 @@
          (*nx1-fcells* nil)
          (*nx1-vcells* nil)
-         (*nx-nlexit-count* 0)
          (*nx-inline-expansions* nil)
-         (*nx-event-checking-call-count* 0)
          (*nx-parsing-lambda-decls* nil)
          (*nx-next-method-var* (if q *nx-next-method-var*))
@@ -1668 +1664 @@
                      `(,(if (eql spread-p 0) 'applyv 'apply) ,sym ,args)
                      `(funcall ,sym ,@args))))
-                (let* ((nlexits *nx-nlexit-count*)
-                       (val (nx1-call-form sym afunc args spread-p)))
+                (let* ((val (nx1-call-form sym afunc args spread-p)))
                     (when afunc
                       (let ((callers (afunc-callers afunc))
@@ -1675 +1670 @@
                         (unless (or (eq self afunc) (memq self callers))
                           (setf (afunc-callers afunc) (cons self callers)))))
-                    (unless (neq nlexits *nx-nlexit-count*)
-                      (setq *nx-event-checking-call-count* (%i+ *nx-event-checking-call-count* 1)))
                     (if (and (null afunc) (memq sym *nx-never-tail-call*))
                       (make-acode (%nx1-operator values) (list val))
@@ -1696 +1689 @@
   (let* ((stkforms nil)
          (regforms nil)
-         (nstkargs (%i- (length args) nregargs))
-         called
-         exited
-         calls
-         exits)
+         (nstkargs (%i- (length args) nregargs)))
     (declare (fixnum nstkargs))
-    (let* ((*nx-event-checking-call-count* *nx-event-checking-call-count*)
-           (*nx-nlexit-count* *nx-nlexit-count*))
       (list
-       (dotimes (i nstkargs stkforms)
+       (dotimes (i nstkargs (nreverse stkforms))
          (declare (fixnum i))
-         (setq calls *nx-event-checking-call-count*
-               exits *nx-nlexit-count*)
          (push (nx1-form (%car args)) stkforms)
-        (unless called
-          (unless (eq exits (setq exits *nx-nlexit-count*))
-            (setq exited exits)))
-        (unless exited
-          (unless (eq calls (setq calls *nx-event-checking-call-count*))
-            (setq called calls)))
          (setq args (%cdr args)))
        (dolist (arg args regforms)
-         (push (nx1-form arg) regforms)
-        (unless called
-          (unless (eq exits (setq exits *nx-nlexit-count*))
-            (setq exited exits)))
-        (unless exited
-          (unless (eq calls (setq calls *nx-event-checking-call-count*))
-            (setq called calls))))))
-    (list (nreverse stkforms) regforms)))
-
-; Bind "event-checking-call" and "non-local-exit" counts, setq at most
-; one of them to an incremented value (depending on which happened first.)
-(defun nx1-formlist (args &aux a exited called)
-  (let* ((*nx-event-checking-call-count* *nx-event-checking-call-count*)
-         (*nx-nlexit-count* *nx-nlexit-count*))
+         (push (nx1-form arg) regforms)))))
+
+(defun nx1-formlist (args)
+  (let* ((a nil))
     (dolist (arg args)
-      (let ((calls *nx-event-checking-call-count*)
-            (exits *nx-nlexit-count*))
-        (push (nx1-form arg) a)
-        (unless called
-          (unless (eq exits (setq exits *nx-nlexit-count*))
-            (setq exited exits)))
-        (unless exited
-          (unless (eq calls (setq calls *nx-event-checking-call-count*))
-            (setq called calls))))))
-  (if called
-    (setq *nx-event-checking-call-count* called)
-    (if exited
-      (setq *nx-nlexit-count* exited)))
-  (nreverse a))
+      (push (nx1-form arg) a))
+    (nreverse a)))
 
 (defun nx1-verify-length (forms min max &aux (len (list-length forms)))

trunk/ccl/compiler/nx1.lisp

@@ -401 +401 @@
 
 (defnx1 nx1-throw (throw) (tag valuesform)
-  (setq *nx-nlexit-count* (%i+ *nx-nlexit-count* 1))
   (make-acode (%nx1-operator throw) (nx1-form tag) (nx1-form valuesform)))
 
@@ -850 +849 @@
       (return-from nx1-if (nx1-form `(progn ,test nil)))
       (psetq test `(not ,test) true false false true)))
-  (let ((testform nil)
-        (trueform nil)
-        (falseform nil)
-        (called-in-test nil)
-        (called-in-true)
-        (called-in-false)
-        (exited nil))
-    (let* ((*nx-event-checking-call-count* *nx-event-checking-call-count*)
-           (*nx-nlexit-count* *nx-nlexit-count*)
-           (calls *nx-event-checking-call-count*)
-           (exits *nx-nlexit-count*))
-      (setq testform (nx1-form test))
-      (if (neq calls (setq calls *nx-event-checking-call-count*))
-        (setq called-in-test calls)
-        (if (neq exits (setq exits *nx-nlexit-count*))
-          (setq exited exits)))
-      (setq trueform (nx1-form true))
-      (unless (or called-in-test exited)
-        (if (neq calls (setq calls *nx-event-checking-call-count*))
-          (setq called-in-true calls)
-          (if (neq exits (setq exits *nx-nlexit-count*))
-            (setq exited exits))))
-      (setq falseform (nx1-form false))
-      (unless (or called-in-test exited)
-        (if (neq calls (setq calls *nx-event-checking-call-count*))
-          (setq called-in-false calls)
-          (if (neq exits (setq exits *nx-nlexit-count*))
-            (setq exited exits)))))
-    (if exited 
-      (setq *nx-nlexit-count* exited)
-      (if (setq called-in-test (or called-in-test (and called-in-true called-in-false)))
-        (setq *nx-event-checking-call-count* called-in-test)))  
-    (make-acode (%nx1-operator if) testform trueform falseform)))
+  (make-acode (%nx1-operator if)  (nx1-form test) (nx1-form true) (nx1-form false)))
 
 (defnx1 nx1-%debug-trap dbg (&optional arg)
@@ -1145 +1112 @@
     (dolist (tag (setq newtags (nreverse newtags)))
       (push tag *nx-tags*))
-    (let* ((body nil) 
-           (nlexit-count *nx-nlexit-count*)
-           (call-count *nx-event-checking-call-count*))
+    (let* ((body nil))
       (dolist (form args (setq body (nreverse body)))
         (push 
@@ -1154 +1119 @@
              (%rplaca (%cdr (%cdr (%cdr (%cdr info)))) t)
              (cons (%nx1-operator tag-label) info))
-           (progn
-             (setq form (nx1-form form))
-             ; These are supposed to just be hints - pass 2 can (theoretically)
-             ; walk the acode itself ...
-             (if (neq call-count (setq call-count *nx-event-checking-call-count*))
-               (setq form (make-acode (%nx1-operator embedded-call) form)))
-             (if (neq nlexit-count (setq nlexit-count *nx-nlexit-count*))
-               (setq form (make-acode (%nx1-operator embedded-nlexit) form)))
-             form))
+           (nx1-form form))
          body))
       (if (eq 0 (%car counter))
         (make-acode (%nx1-operator local-tagbody) newtags body)
         (progn
+          (nx-set-var-bits catchvar (logior (nx-var-bits catchvar)
+                                            (%ilsl $vbitdynamicextent 1)))
           (nx-inhibit-register-allocation)   ; There are alternatives ...
           (dolist (tag (reverse newtags))
@@ -1176 +1135 @@
            (%nx1-operator let*)
            (list catchvar indexvar)
-           (list *nx-nil* *nx-nil*)
+           (list (make-acode (%nx1-operator cons) *nx-nil* *nx-nil*) *nx-nil*)
            (make-acode
             (%nx1-operator local-tagbody)
@@ -1189 +1148 @@
                (make-acode 
                 (%nx1-operator catch)
-                (nx1-form `(setq ,(var-name catchvar) (%newgotag)))  ;(make-acode (%nx1-operator newgotag))
+                (nx1-form (var-name catchvar)) 
                 (make-acode
                  (%nx1-operator local-tagbody)
@@ -1208 +1167 @@
       (let ((defnbackref (cdr (cdr (cdr (cdr info))))))
         (if (car defnbackref) 
-          (rplaca (cdr defnbackref) t)
-          (setq *nx-nlexit-count* (%i+ *nx-nlexit-count* 1)))
+          (rplaca (cdr defnbackref) t))
         (make-acode (%nx1-operator local-go) info))
       (progn
-        (setq *nx-nlexit-count* (%i+ *nx-nlexit-count* 1))
+
         (make-acode
          (%nx1-operator throw) (nx1-symbol (var-name (cadddr info))) (nx1-form closed))))))
@@ -1298 +1256 @@
           body)
         (progn
+          (nx-set-var-bits tagvar (%ilogior (%ilsl $vbitdynamicextent 1) tagbits))
           (nx-inhibit-register-allocation)   ; Could also set $vbitnoreg in all setqed vars, or keep track better
           (make-acode
@@ -1305 +1264 @@
             (%nx1-operator let)
             (list tagvar)
-            (list (make-acode (%nx1-operator newblocktag)))
+            (list (make-acode (%nx1-operator cons) (nx1-form nil) (nx1-form nil)))
             (make-acode
              (%nx1-operator catch)
-             (list (%nx1-operator lexical-reference) tagvar)
+             (make-acode (%nx1-operator lexical-reference) tagvar)
              body)
             0)))))))
@@ -1317 +1276 @@
     (unless info (nx-error "Can't RETURN-FROM block : ~S." blockname))
     (unless closed (nx-adjust-ref-count (cdr info)))
-    (setq *nx-nlexit-count* (%i+ *nx-nlexit-count* 1))
     (make-acode 
      (if closed