1.0.22.11: name *pcl-lock*

[sbcl.git] / src / code / loop.lisp

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 68f1741..6b9a43a 100644 (file)
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -503,27 +503,21 @@ code to be loaded.
 ;;;; code analysis stuff
 
 (defun loop-constant-fold-if-possible (form &optional expected-type)
 ;;;; code analysis stuff
 
 (defun loop-constant-fold-if-possible (form &optional expected-type)

-  (let ((new-form form) (constantp nil) (constant-value nil))
-    (when (setq constantp (constantp new-form))
-      (setq constant-value (eval new-form)))
+  (let* ((constantp (sb!xc:constantp form))
+         (value (and constantp (sb!int:constant-form-value form))))

     (when (and constantp expected-type)
     (when (and constantp expected-type)

-      (unless (sb!xc:typep constant-value expected-type)
+      (unless (sb!xc:typep value expected-type)

         (loop-warn "~@<The form ~S evaluated to ~S, which was not of ~
                     the anticipated type ~S.~:@>"
         (loop-warn "~@<The form ~S evaluated to ~S, which was not of ~
                     the anticipated type ~S.~:@>"

-                   form constant-value expected-type)
-        (setq constantp nil constant-value nil)))
-    (values new-form constantp constant-value)))
-
-(defun loop-constantp (form)
-  (constantp form))
+                   form value expected-type)
+        (setq constantp nil value nil)))
+    (values form constantp value)))

 \f
 ;;;; LOOP iteration optimization
 
 \f
 ;;;; LOOP iteration optimization
 

-(defvar *loop-duplicate-code*
-        nil)
+(defvar *loop-duplicate-code* nil)

 
 

-(defvar *loop-iteration-flag-var*
-        (make-symbol "LOOP-NOT-FIRST-TIME"))
+(defvar *loop-iteration-flag-var* (make-symbol "LOOP-NOT-FIRST-TIME"))

 
 (defun loop-code-duplication-threshold (env)
   (declare (ignore env))
 
 (defun loop-code-duplication-threshold (env)
   (declare (ignore env))

@@ -923,10 +917,22 @@ code to be loaded.
 
 (defun loop-typed-init (data-type &optional step-var-p)
   (when (and data-type (sb!xc:subtypep data-type 'number))
 
 (defun loop-typed-init (data-type &optional step-var-p)
   (when (and data-type (sb!xc:subtypep data-type 'number))

-    (if (or (sb!xc:subtypep data-type 'float)
-            (sb!xc:subtypep data-type '(complex float)))
-        (coerce (if step-var-p 1 0) data-type)
-        (if step-var-p 1 0))))
+    (let ((init (if step-var-p 1 0)))
+      (flet ((like (&rest types)
+               (coerce init (find-if (lambda (type)
+                                       (sb!xc:subtypep data-type type))
+                                     types))))
+        (cond ((sb!xc:subtypep data-type 'float)
+               (like 'single-float 'double-float
+                     'short-float 'long-float 'float))
+              ((sb!xc:subtypep data-type '(complex float))
+               (like '(complex single-float)
+                     '(complex double-float)
+                     '(complex short-float)
+                     '(complex long-float)
+                     '(complex float)))
+              (t
+               init))))))

 
 (defun loop-optional-type (&optional variable)
   ;; No variable specified implies that no destructuring is permissible.
 
 (defun loop-optional-type (&optional variable)
   ;; No variable specified implies that no destructuring is permissible.

@@ -1052,7 +1058,9 @@ code to be loaded.
 (defun loop-declare-var (name dtype &optional step-var-p)
   (cond ((or (null name) (null dtype) (eq dtype t)) nil)
         ((symbolp name)
 (defun loop-declare-var (name dtype &optional step-var-p)
   (cond ((or (null name) (null dtype) (eq dtype t)) nil)
         ((symbolp name)

-         (unless (sb!xc:subtypep t dtype)
+         (unless (or (sb!xc:subtypep t dtype)
+                     (and (eq (find-package :cl) (symbol-package name))
+                          (eq :special (sb!int:info :variable :kind name))))

            (let ((dtype (let ((init (loop-typed-init dtype step-var-p)))
                           (if (sb!xc:typep init dtype)
                               dtype
            (let ((dtype (let ((init (loop-typed-init dtype step-var-p)))
                           (if (sb!xc:typep init dtype)
                               dtype

@@ -1067,7 +1075,7 @@ code to be loaded.
         (t (error "invalid LOOP variable passed in: ~S" name))))
 
 (defun loop-maybe-bind-form (form data-type)
         (t (error "invalid LOOP variable passed in: ~S" name))))
 
 (defun loop-maybe-bind-form (form data-type)

-  (if (loop-constantp form)
+  (if (constantp form)

       form
       (loop-make-var (gensym "LOOP-BIND-") form data-type)))
 \f
       form
       (loop-make-var (gensym "LOOP-BIND-") form data-type)))
 \f

@@ -1726,7 +1734,8 @@ code to be loaded.
                                  `(and ,indexv-type real)))))
            (:by
             (multiple-value-setq (form stepby-constantp stepby)
                                  `(and ,indexv-type real)))))
            (:by
             (multiple-value-setq (form stepby-constantp stepby)

-              (loop-constant-fold-if-possible form `(and ,indexv-type (real (0)))))
+              (loop-constant-fold-if-possible form
+                                              `(and ,indexv-type (real (0)))))

             (unless stepby-constantp
               (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
                  form
             (unless stepby-constantp
               (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
                  form

@@ -1737,7 +1746,8 @@ code to be loaded.
               maybe invalid prepositions were specified in iteration path descriptor?"
                  prep)))
          (when (and odir dir (not (eq dir odir)))
               maybe invalid prepositions were specified in iteration path descriptor?"
                  prep)))
          (when (and odir dir (not (eq dir odir)))

-           (loop-error "conflicting stepping directions in LOOP sequencing path"))
+           (loop-error
+             "conflicting stepping directions in LOOP sequencing path"))

          (setq odir dir))
        (when (and sequence-variable (not sequencep))
          (loop-error "missing OF or IN phrase in sequence path"))
          (setq odir dir))
        (when (and sequence-variable (not sequencep))
          (loop-error "missing OF or IN phrase in sequence path"))

@@ -1755,8 +1765,9 @@ code to be loaded.
                                   :key #'type-declaration-of
                                   :from-end t)))
                  (sb!int:aver (eq decl %decl))
                                   :key #'type-declaration-of
                                   :from-end t)))
                  (sb!int:aver (eq decl %decl))

-                 (setf (cadr decl)
-                       `(and real ,(cadr decl))))))
+                 (when decl
+                   (setf (cadr decl)
+                         `(and real ,(cadr decl)))))))

            ;; default start
            ;; DUPLICATE KLUDGE: loop-make-var generates a temporary
            ;; symbol for indexv if it is NIL. See also the comment in
            ;; default start
            ;; DUPLICATE KLUDGE: loop-make-var generates a temporary
            ;; symbol for indexv if it is NIL. See also the comment in

@@ -1795,6 +1806,27 @@ code to be loaded.
          (setq step-hack
                `(,variable ,step-hack)))
        (let ((first-test test) (remaining-tests test))
          (setq step-hack
                `(,variable ,step-hack)))
        (let ((first-test test) (remaining-tests test))

+         ;; As far as I can tell, the effect of the following code is
+         ;; to detect cases where we know statically whether the first
+         ;; iteration of the loop will be executed. Depending on the
+         ;; situation, we can either:
+         ;;  a) save one jump and one comparison per loop (not per iteration)
+         ;;     when it will get executed
+         ;;  b) remove the loop body completely when it won't be executed
+         ;;
+         ;; Noble goals. However, the code generated in case a) will
+         ;; fool the loop induction variable detection, and cause
+         ;; code like (LOOP FOR I TO 10 ...) to use generic addition
+         ;; (bug #278a).
+         ;;
+         ;; Since the gain in case a) is rather minimal and Python is
+         ;; generally smart enough to handle b) without any extra
+         ;; support from the loop macro, I've disabled this code for
+         ;; now. The code and the comment left here in case somebody
+         ;; extends the induction variable bound detection to work
+         ;; with code where the stepping precedes the test.
+         ;; -- JES 2005-11-30
+         #+nil

          (when (and stepby-constantp start-constantp limit-constantp
                     (realp start-value) (realp limit-value))
            (when (setq first-test
          (when (and stepby-constantp start-constantp limit-constantp
                     (realp start-value) (realp limit-value))
            (when (setq first-test

@@ -1815,22 +1847,6 @@ code to be loaded.
     '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
     nil (list (list kwd val)))))
 
     '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
     nil (list (list kwd val)))))
 

-(defun loop-sequence-elements-path (variable data-type prep-phrases
-                                    &key
-                                    fetch-function
-                                    size-function
-                                    sequence-type
-                                    element-type)
-  (multiple-value-bind (indexv) (loop-named-var 'index)
-    (let ((sequencev (loop-named-var 'sequence)))
-      (list* nil nil                            ; dummy bindings and prologue
-             (loop-sequencer
-              indexv 'fixnum
-              variable (or data-type element-type)
-              sequencev sequence-type
-              `(,fetch-function ,sequencev ,indexv)
-              `(,size-function ,sequencev)
-              prep-phrases)))))

 \f
 ;;;; builtin LOOP iteration paths
 
 \f
 ;;;; builtin LOOP iteration paths