;;;;
;;;; KLUDGE: In SBCL, we only really use variant (1), and any generality
;;;; for the other variants is wasted. -- WHN 20000121
-
-;;;; FIXME: the STEP-FUNCTION stuff in the code seems to've been
-;;;; intended to support code which was conditionalized with
-;;;; LOOP-PREFER-POP (not true on CMU CL) and which has since been
-;;;; removed. Thus, STEP-FUNCTION stuff could probably be removed too.
\f
;;;; list collection macrology
(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
path-keywords ; hash table, value = (fn-name . extra-data)
type-symbols ; hash table of type SYMBOLS, test EQ,
; value = CL type specifier
- type-keywords ; hash table of type STRINGS, test EQUAL,
+ type-keywords) ; hash table of type STRINGS, test EQUAL,
; value = CL type spec
- ansi ; NIL, T, or :EXTENDED
- implicit-for-required) ; see loop-hack-iteration
(sb!int:def!method print-object ((u loop-universe) stream)
- (let ((string (case (loop-universe-ansi u)
- ((nil) "non-ANSI")
- ((t) "ANSI")
- (:extended "extended-ANSI")
- (t (loop-universe-ansi u)))))
- (print-unreadable-object (u stream :type t)
- (write-string string stream))))
+ (print-unreadable-object (u stream :type t :identity t)))
;;; This is the "current" loop context in use when we are expanding a
;;; loop. It gets bound on each invocation of LOOP.
(defun make-standard-loop-universe (&key keywords for-keywords
iteration-keywords path-keywords
- type-keywords type-symbols ansi)
- (declare (type (member nil t :extended) ansi))
+ type-keywords type-symbols)
(flet ((maketable (entries)
(let* ((size (length entries))
(ht (make-hash-table :size (if (< size 10) 10 size)
:for-keywords (maketable for-keywords)
:iteration-keywords (maketable iteration-keywords)
:path-keywords (maketable path-keywords)
- :ansi ansi
- :implicit-for-required (not (null ansi))
:type-keywords (maketable type-keywords)
:type-symbols (let* ((size (length type-symbols))
(ht (make-hash-table :size (if (< size 10) 10 size)
(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))))
(setq constantp nil value nil)))
(values form constantp value)))
\f
-;;;; 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)))))))
-\f
-(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))))
\f
;;;; loop errors
;;;; loop types
(defun loop-typed-init (data-type &optional step-var-p)
- (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)
- (coerce nil data-type))
- (t
- nil)))
+ (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))))))
+ ((sb!xc:typep #\x data-type)
+ #\x)
+ (t
+ nil)))
(defun loop-optional-type (&optional variable)
;; No variable specified implies that no destructuring is permissible.
(cond ((null name)
(setq name (gensym "LOOP-IGNORE-"))
(push (list name initialization) *loop-vars*)
- (if (null initialization)
- (push `(ignore ,name) *loop-declarations*)
- (loop-declare-var name dtype)))
+ (push `(ignore ,name) *loop-declarations*)
+ (loop-declare-var name dtype))
((atom name)
(when (or (assoc name *loop-vars*)
(loop-var-p name))
(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 (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
- `(or (member ,init) ,dtype)))))
+ (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)
(defun loop-get-collection-info (collector class default-type)
(let ((form (loop-get-form))
- (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type)))
(name (when (loop-tequal (car *loop-source-code*) 'into)
(loop-pop-source)
(loop-pop-source))))
(loop-error "The value accumulation recipient name, ~S, is not a symbol." name))
(unless name
(loop-disallow-aggregate-booleans))
- (unless dtype
- (setq dtype (or (loop-optional-type) default-type)))
- (let ((cruft (find (the symbol name) *loop-collection-cruft*
+ (let ((dtype (or (loop-optional-type) default-type))
+ (cruft (find (the symbol name) *loop-collection-cruft*
:key #'loop-collector-name)))
(cond ((not cruft)
(when (and name (loop-var-p name))
*loop-after-body*))
(loop-bind-block)
(return nil))
- (loop-pop-source) ; Flush the "AND".
- (when (and (not (loop-universe-implicit-for-required *loop-universe*))
- (setq tem
- (loop-lookup-keyword
- (car *loop-source-code*)
- (loop-universe-iteration-keywords *loop-universe*))))
- ;; The latest ANSI clarification is that the FOR/AS after the AND must
- ;; NOT be supplied.
- (loop-pop-source)
- (setq entry tem)))))
+ (loop-pop-source)))) ; Flush the "AND".
\f
;;;; main iteration drivers
\f
;;;; ANSI LOOP
-(defun make-ansi-loop-universe (extended-p)
+(defun make-ansi-loop-universe ()
(let ((w (make-standard-loop-universe
:keywords '((named (loop-do-named))
(initially (loop-do-initially))
simple-bit-vector simple-string simple-vector
single-float standard-char stream string
base-char symbol t vector)
- :type-keywords nil
- :ansi (if extended-p :extended t))))
+ :type-keywords nil)))
(add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w
:preposition-groups '((:of :in))
:inclusive-permitted nil
w))
(defparameter *loop-ansi-universe*
- (make-ansi-loop-universe nil))
+ (make-ansi-loop-universe))
(defun loop-standard-expansion (keywords-and-forms environment universe)
(if (and keywords-and-forms (symbolp (car keywords-and-forms)))
projects / sbcl.git / blobdiff