X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=a7e276206826001ad27f9a19512b5113211c6e87;hb=HEAD;hp=6b9a43aaaac49e4abef570e68dcff6c0b7f567ed;hpb=dfa4d1c572e3a8d2836a462c107d95c5a1796e07;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 6b9a43a..a7e2762 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -87,11 +87,6 @@ ;;;; ;;;; 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. ;;;; list collection macrology @@ -103,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 @@ -281,18 +276,10 @@ code to be loaded. 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. @@ -300,8 +287,7 @@ code to be loaded. (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) @@ -314,8 +300,6 @@ code to be loaded. :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) @@ -365,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)))) @@ -513,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 @@ -916,23 +715,35 @@ code to be loaded. ;;;; loop types (defun loop-typed-init (data-type &optional step-var-p) - (when (and data-type (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)))))) + (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. @@ -1027,16 +838,15 @@ code to be loaded. (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))) @@ -1055,16 +865,18 @@ code to be loaded. (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) @@ -1166,7 +978,6 @@ code to be loaded. (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)))) @@ -1174,9 +985,8 @@ code to be loaded. (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)) @@ -1382,16 +1192,7 @@ code to be loaded. *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". ;;;; main iteration drivers @@ -1934,7 +1735,7 @@ code to be loaded. ;;;; 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)) @@ -1995,8 +1796,7 @@ code to be loaded. 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 @@ -2025,7 +1825,7 @@ code to be loaded. 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)))