;;;; 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)
- (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.~:@>"
- 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
-(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))
;;;; loop types
(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))))
+ (cond ((null data-type)
+ nil)
+ ((sb!xc:subtypep data-type 'number)
+ (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)))))
+ ((sb!xc:subtypep data-type 'vector)
+ (let ((ctype (sb!kernel:specifier-type data-type)))
+ (when (sb!kernel:array-type-p ctype)
+ (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))))))
+ (t
+ nil)))
(defun loop-optional-type (&optional variable)
;; No variable specified implies that no destructuring is permissible.
(loop-error "duplicated variable ~S in a LOOP binding" name))
(unless (symbolp name)
(loop-error "bad variable ~S somewhere in LOOP" name))
- (loop-declare-var name dtype step-var-p)
+ (loop-declare-var name dtype step-var-p initialization)
;; We use ASSOC on this list to check for duplications (above),
;; so don't optimize out this list:
(push (list name (or initialization (loop-typed-init dtype step-var-p)))
(loop-make-var (cdr name) nil tcdr))))
name)
-(defun loop-declare-var (name dtype &optional step-var-p)
+(defun loop-declare-var (name dtype &optional step-var-p initialization)
(cond ((or (null name) (null dtype) (eq dtype t)) nil)
((symbolp name)
- (unless (sb!xc:subtypep t dtype)
- (let ((dtype (let ((init (loop-typed-init dtype step-var-p)))
- (if (sb!xc:typep init dtype)
- dtype
- `(or (member ,init) ,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 (if initialization
+ dtype
+ (let ((init (loop-typed-init dtype step-var-p)))
+ (if (sb!xc:typep init dtype)
+ dtype
+ `(or ,(type-of init) ,dtype))))))
(push `(type ,dtype ,name) *loop-declarations*))))
((consp name)
(cond ((consp dtype)
(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
`(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
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"))
: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
(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
'((: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
projects / sbcl.git / blobdiff