(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
(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
(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-get-collection-info (collector class default-type)
(let ((form (loop-get-form))
- (dtype (or (loop-optional-type) default-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))
- (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))
projects / sbcl.git / blobdiff