X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=a7e276206826001ad27f9a19512b5113211c6e87;hb=HEAD;hp=969475a1defd08826f197a3e3b971fb4758643cf;hpb=c3bf5a0037aea195f13c14fb79d096b9677d0345;p=sbcl.git

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 969475a..a7e2762 100644
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -98,7 +98,7 @@
 
 (sb!int:defmacro-mundanely loop-collect-rplacd
     (&environment env (head-var tail-var &optional user-head-var) form)
-  (setq form (sb!xc:macroexpand form env))
+  (setq form (sb!int:%macroexpand form env))
   (flet ((cdr-wrap (form n)
            (declare (fixnum n))
            (do () ((<= n 4) (setq form `(,(case n
@@ -349,7 +349,7 @@ code to be loaded.
                                  (and (consp x)
                                       (or (not (eq (car x) 'car))
                                           (not (symbolp (cadr x)))
-                                          (not (symbolp (setq x (sb!xc:macroexpand x env)))))
+                                          (not (symbolp (setq x (sb!int:%macroexpand x env)))))
                                       (cons x nil)))
                                (cdr val))
                        `(,val))))
@@ -497,217 +497,32 @@ code to be loaded.
         (setq constantp nil value nil)))
     (values form constantp value)))
 
-;;;; LOOP iteration optimization
-
-(defvar *loop-duplicate-code* nil)
-
-(defvar *loop-iteration-flag-var* (make-symbol "LOOP-NOT-FIRST-TIME"))
-
-(defun loop-code-duplication-threshold (env)
-  (declare (ignore env))
-  (let (;; If we could read optimization declaration information (as
-        ;; with the DECLARATION-INFORMATION function (present in
-        ;; CLTL2, removed from ANSI standard) we could set these
-        ;; values flexibly. Without DECLARATION-INFORMATION, we have
-        ;; to set them to constants.
-        ;;
-        ;; except FIXME: we've lost all pretence of portability,
-        ;; considering this instead an internal implementation, so
-        ;; we're free to couple to our own representation of the
-        ;; environment.
-        (speed 1)
-        (space 1))
-    (+ 40 (* (- speed space) 10))))
-
-(sb!int:defmacro-mundanely loop-body (&environment env
-                                         prologue
-                                         before-loop
-                                         main-body
-                                         after-loop
-                                         epilogue
-                                         &aux rbefore rafter flagvar)
+(sb!int:defmacro-mundanely loop-body (prologue
+                                      before-loop
+                                      main-body
+                                      after-loop
+                                      epilogue)
   (unless (= (length before-loop) (length after-loop))
     (error "LOOP-BODY called with non-synched before- and after-loop lists"))
-  ;;All our work is done from these copies, working backwards from the end:
-  (setq rbefore (reverse before-loop) rafter (reverse after-loop))
-  (labels ((psimp (l)
-             (let ((ans nil))
-               (dolist (x l)
-                 (when x
-                   (push x ans)
-                   (when (and (consp x)
-                              (member (car x) '(go return return-from)))
-                     (return nil))))
-               (nreverse ans)))
-           (pify (l) (if (null (cdr l)) (car l) `(progn ,@l)))
-           (makebody ()
-             (let ((form `(tagbody
-                            ,@(psimp (append prologue (nreverse rbefore)))
-                         next-loop
-                            ,@(psimp (append main-body
-                                             (nreconc rafter
-                                                      `((go next-loop)))))
-                         end-loop
-                            ,@(psimp epilogue))))
-               (if flagvar `(let ((,flagvar nil)) ,form) form))))
-    (when (or *loop-duplicate-code* (not rbefore))
-      (return-from loop-body (makebody)))
-    ;; This outer loop iterates once for each not-first-time flag test
-    ;; generated plus once more for the forms that don't need a flag test.
-    (do ((threshold (loop-code-duplication-threshold env))) (nil)
-      (declare (fixnum threshold))
-      ;; Go backwards from the ends of before-loop and after-loop
-      ;; merging all the equivalent forms into the body.
-      (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter)))))
-        (push (pop rbefore) main-body)
-        (pop rafter))
-      (unless rbefore (return (makebody)))
-      ;; The first forms in RBEFORE & RAFTER (which are the
-      ;; chronologically last forms in the list) differ, therefore
-      ;; they cannot be moved into the main body. If everything that
-      ;; chronologically precedes them either differs or is equal but
-      ;; is okay to duplicate, we can just put all of rbefore in the
-      ;; prologue and all of rafter after the body. Otherwise, there
-      ;; is something that is not okay to duplicate, so it and
-      ;; everything chronologically after it in rbefore and rafter
-      ;; must go into the body, with a flag test to distinguish the
-      ;; first time around the loop from later times. What
-      ;; chronologically precedes the non-duplicatable form will be
-      ;; handled the next time around the outer loop.
-      (do ((bb rbefore (cdr bb))
-           (aa rafter (cdr aa))
-           (lastdiff nil)
-           (count 0)
-           (inc nil))
-          ((null bb) (return-from loop-body (makebody)))        ; Did it.
-        (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0))
-              ((or (not (setq inc (estimate-code-size (car bb) env)))
-                   (> (incf count inc) threshold))
-               ;; Ok, we have found a non-duplicatable piece of code.
-               ;; Everything chronologically after it must be in the
-               ;; central body. Everything chronologically at and
-               ;; after LASTDIFF goes into the central body under a
-               ;; flag test.
-               (let ((then nil) (else nil))
-                 (do () (nil)
-                   (push (pop rbefore) else)
-                   (push (pop rafter) then)
-                   (when (eq rbefore (cdr lastdiff)) (return)))
-                 (unless flagvar
-                   (push `(setq ,(setq flagvar *loop-iteration-flag-var*)
-                                t)
-                         else))
-                 (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else)))
-                       main-body))
-               ;; Everything chronologically before lastdiff until the
-               ;; non-duplicatable form (CAR BB) is the same in
-               ;; RBEFORE and RAFTER, so just copy it into the body.
-               (do () (nil)
-                 (pop rafter)
-                 (push (pop rbefore) main-body)
-                 (when (eq rbefore (cdr bb)) (return)))
-               (return)))))))
-
-(defun duplicatable-code-p (expr env)
-  (if (null expr) 0
-      (let ((ans (estimate-code-size expr env)))
-        (declare (fixnum ans))
-        ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to
-        ;; get an alist of optimize quantities back to help quantify
-        ;; how much code we are willing to duplicate.
-        ans)))
-
-(defvar *special-code-sizes*
-        '((return 0) (progn 0)
-          (null 1) (not 1) (eq 1) (car 1) (cdr 1)
-          (when 1) (unless 1) (if 1)
-          (caar 2) (cadr 2) (cdar 2) (cddr 2)
-          (caaar 3) (caadr 3) (cadar 3) (caddr 3)
-          (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3)
-          (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4)
-          (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4)
-          (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4)
-          (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4)))
-
-(defvar *estimate-code-size-punt*
-        '(block
-           do do* dolist
-           flet
-           labels lambda let let* locally
-           macrolet multiple-value-bind
-           prog prog*
-           symbol-macrolet
-           tagbody
-           unwind-protect
-           with-open-file))
-
-(defun destructuring-size (x)
-  (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n)))
-      ((atom x) (+ n (if (null x) 0 1)))))
-
-(defun estimate-code-size (x env)
-  (catch 'estimate-code-size
-    (estimate-code-size-1 x env)))
-
-(defun estimate-code-size-1 (x env)
-  (flet ((list-size (l)
-           (let ((n 0))
-             (declare (fixnum n))
-             (dolist (x l n) (incf n (estimate-code-size-1 x env))))))
-    ;;@@@@ ???? (declare (function list-size (list) fixnum))
-    (cond ((constantp x) 1)
-          ((symbolp x) (multiple-value-bind (new-form expanded-p)
-                           (sb!xc:macroexpand-1 x env)
-                         (if expanded-p
-                             (estimate-code-size-1 new-form env)
-                             1)))
-          ((atom x) 1) ;; ??? self-evaluating???
-          ((symbolp (car x))
-           (let ((fn (car x)) (tem nil) (n 0))
-             (declare (symbol fn) (fixnum n))
-             (macrolet ((f (overhead &optional (args nil args-p))
-                          `(the fixnum (+ (the fixnum ,overhead)
-                                          (the fixnum
-                                               (list-size ,(if args-p
-                                                               args
-                                                             '(cdr x))))))))
-               (cond ((setq tem (get fn 'estimate-code-size))
-                      (typecase tem
-                        (fixnum (f tem))
-                        (t (funcall tem x env))))
-                     ((setq tem (assoc fn *special-code-sizes*))
-                      (f (second tem)))
-                     ((eq fn 'cond)
-                      (dolist (clause (cdr x) n)
-                        (incf n (list-size clause)) (incf n)))
-                     ((eq fn 'desetq)
-                      (do ((l (cdr x) (cdr l))) ((null l) n)
-                        (setq n (+ n
-                                   (destructuring-size (car l))
-                                   (estimate-code-size-1 (cadr l) env)))))
-                     ((member fn '(setq psetq))
-                      (do ((l (cdr x) (cdr l))) ((null l) n)
-                        (setq n (+ n (estimate-code-size-1 (cadr l) env) 1))))
-                     ((eq fn 'go) 1)
-                     ((eq fn 'function)
-                      (if (sb!int:legal-fun-name-p (cadr x))
-                          1
-                          ;; FIXME: This tag appears not to be present
-                          ;; anywhere.
-                          (throw 'duplicatable-code-p nil)))
-                     ((eq fn 'multiple-value-setq)
-                      (f (length (second x)) (cddr x)))
-                     ((eq fn 'return-from)
-                      (1+ (estimate-code-size-1 (third x) env)))
-                     ((or (special-operator-p fn)
-                          (member fn *estimate-code-size-punt*))
-                      (throw 'estimate-code-size nil))
-                     (t (multiple-value-bind (new-form expanded-p)
-                            (sb!xc:macroexpand-1 x env)
-                          (if expanded-p
-                              (estimate-code-size-1 new-form env)
-                              (f 3))))))))
-          (t (throw 'estimate-code-size nil)))))
+  ;; All our work is done from these copies, working backwards from the end
+  (let ((rbefore (reverse before-loop))
+        (rafter (reverse after-loop)))
+    ;; Go backwards from the ends of before-loop and after-loop
+    ;; merging all the equivalent forms into the body.
+    (do ()
+        ((or (null rbefore)
+             (not (equal (car rbefore) (car rafter)))))
+      (push (pop rbefore) main-body)
+      (pop rafter))
+    `(tagbody
+        ,@(remove nil prologue)
+        ,@(nreverse (remove nil rbefore))
+      next-loop
+        ,@(remove nil main-body)
+        ,@(nreverse (remove nil rafter))
+        (go next-loop)
+      end-loop
+        ,@(remove nil epilogue))))
 
 ;;;; loop errors
 
@@ -925,6 +740,8 @@ code to be loaded.
              (let ((etype (sb!kernel:type-*-to-t
                            (sb!kernel:array-type-specialized-element-type ctype))))
                (make-array 0 :element-type (sb!kernel:type-specifier etype))))))
+        ((sb!xc:typep #\x data-type)
+         #\x)
         (t
          nil)))