x)) thing))
(any-lowers
;; all lowercase, becomes all upper case
- (diddle-with #'(lambda (x) (if (stringp x)
- (string-upcase x)
- x)) thing))
+ (diddle-with (lambda (x) (if (stringp x)
+ (string-upcase x)
+ x)) thing))
(t
;; no letters? I guess just leave it.
thing))))
;;; (Must be known values return...)
(defun compute-debug-returns (fun)
(coerce-to-smallest-eltype
- (mapcar #'(lambda (loc)
- (tn-sc-offset loc))
+ (mapcar (lambda (loc)
+ (tn-sc-offset loc))
(return-info-locations (tail-set-info (lambda-tail-set fun))))))
\f
;;;; debug functions
((null (block-next block)))
(check-block-consistency block)))
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (unless (or (constant-p v)
- (and (global-var-p v)
- (member (global-var-kind v)
- '(:global :special))))
- (barf "strange *FREE-VARIABLES* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n))
- (when (basic-var-p v)
- (dolist (n (basic-var-sets v))
- (check-node-reached n))))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (unless (or (constant-p v)
+ (and (global-var-p v)
+ (member (global-var-kind v)
+ '(:global :special))))
+ (barf "strange *FREE-VARIABLES* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n))
+ (when (basic-var-p v)
+ (dolist (n (basic-var-sets v))
+ (check-node-reached n))))
*free-variables*)
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (unless (constant-p v)
- (barf "strange *CONSTANTS* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n)))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (unless (constant-p v)
+ (barf "strange *CONSTANTS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n)))
*constants*)
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (unless (or (functional-p v)
- (and (global-var-p v)
- (eq (global-var-kind v) :global-function)))
- (barf "strange *FREE-FUNCTIONS* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n)))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (unless (or (functional-p v)
+ (and (global-var-p v)
+ (eq (global-var-kind v) :global-function)))
+ (barf "strange *FREE-FUNCTIONS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n)))
*free-functions*)
(clrhash *seen-functions*)
(clrhash *seen-blocks*)
(atypes (template-arg-types info))
(rtypes (template-result-types info)))
(check-tn-refs (vop-args vop) vop nil
- (count-if-not #'(lambda (x)
- (and (consp x)
- (eq (car x) :constant)))
+ (count-if-not (lambda (x)
+ (and (consp x)
+ (eq (car x) :constant)))
atypes)
(template-more-args-type info) "args")
(check-tn-refs (vop-results vop) vop t
(let ((succ (block-succ block)))
(format t "successors~{ c~D~}~%"
- (mapcar #'(lambda (x) (cont-num (block-start x))) succ)))
+ (mapcar (lambda (x) (cont-num (block-start x))) succ)))
(values))
;;; Print a useful representation of a TN. If the TN has a leaf, then do a
;;; Make a list out of all of the recorded conflicts.
(defun listify-conflicts-table ()
(collect ((res))
- (maphash #'(lambda (k v)
- (declare (ignore v))
- (when k
- (res k)))
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (when k
+ (res k)))
*list-conflicts-table*)
(clrhash *list-conflicts-table*)
(res)))
(parse-defmacro arglist whole body name 'deftype :default-default ''*)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(%compiler-deftype ',name
- #'(lambda (,whole)
- ,@local-decs
- (block ,name ,body))
+ (lambda (,whole)
+ ,@local-decs
+ (block ,name ,body))
,@(when doc `(,doc)))))))
(%make-funstate :args args))
(defun funstate-compatible-p (funstate args)
- (every #'(lambda (this-arg-temps)
- (let* ((old-arg (car this-arg-temps))
- (new-arg (find (arg-name old-arg) args :key #'arg-name)))
- (and new-arg
- (every #'(lambda (this-kind-temps)
- (funcall (find-arg-form-checker
- (car this-kind-temps))
- new-arg
- old-arg))
- (cdr this-arg-temps)))))
+ (every (lambda (this-arg-temps)
+ (let* ((old-arg (car this-arg-temps))
+ (new-arg (find (arg-name old-arg) args :key #'arg-name)))
+ (and new-arg
+ (every (lambda (this-kind-temps)
+ (funcall (find-arg-form-checker
+ (car this-kind-temps))
+ new-arg
+ old-arg))
+ (cdr this-arg-temps)))))
(funstate-arg-temps funstate)))
(defun arg-or-lose (name funstate)
(values wrapper-name `(defparameter ,wrapper-name ,form)))))
(defun filter-overrides (overrides evalp)
- (mapcar #'(lambda (override)
- (list* (car override) (cadr override)
- (munge-fun-refs (cddr override) evalp)))
+ (mapcar (lambda (override)
+ (list* (car override) (cadr override)
+ (munge-fun-refs (cddr override) evalp)))
overrides))
(defparameter *arg-function-params*
(defun gen-args-def-form (overrides format-form &optional (evalp t))
(let ((args-var (gensym)))
`(let ((,args-var (copy-list (format-args ,format-form))))
- ,@(mapcar #'(lambda (override)
- (update-args-form args-var
- `',(car override)
- (and (cdr override)
- (cons :value (cdr override)))
- evalp))
+ ,@(mapcar (lambda (override)
+ (update-args-form args-var
+ `',(car override)
+ (and (cdr override)
+ (cons :value (cdr override)))
+ evalp))
overrides)
,args-var)))
:args ,args-var))
(eval
`(progn
- ,@(mapcar #'(lambda (arg)
- (when (arg-fields arg)
- (gen-arg-access-macro-def-form
- arg ,args-var ',name)))
+ ,@(mapcar (lambda (arg)
+ (when (arg-fields arg)
+ (gen-arg-access-macro-def-form
+ arg ,args-var ',name)))
,args-var))))))))))
;;; FIXME: probably needed only at build-the-system time, not in
can't specify fields except using DEFINE-INSTRUCTION-FORMAT~:>"
arg-name))
(setf (arg-fields arg)
- (mapcar #'(lambda (bytespec)
- (when (> (+ (byte-position bytespec)
- (byte-size bytespec))
- format-length)
- (error "~@<in arg ~S: ~3I~:_~
+ (mapcar (lambda (bytespec)
+ (when (> (+ (byte-position bytespec)
+ (byte-size bytespec))
+ format-length)
+ (error "~@<in arg ~S: ~3I~:_~
The field ~S doesn't fit in an ~
instruction-format ~W bits wide.~:>"
- arg-name
- bytespec
- format-length))
- (correct-dchunk-bytespec-for-endianness
- bytespec
- format-length
- sb!c:*backend-byte-order*))
+ arg-name
+ bytespec
+ format-length))
+ (correct-dchunk-bytespec-for-endianness
+ bytespec
+ format-length
+ sb!c:*backend-byte-order*))
fields)))
args))
((atom (cadr atk))
(push `(,(cadr atk) ,(cddr atk)) bindings))
(t
- (mapc #'(lambda (var form)
- (push `(,var ,form) bindings))
+ (mapc (lambda (var form)
+ (push `(,var ,form) bindings))
(cadr atk)
(cddr atk))))))
bindings))
\f
(defmacro def-arg-form-kind ((&rest names) &rest inits)
`(let ((kind (make-arg-form-kind :names ',names ,@inits)))
- ,@(mapcar #'(lambda (name)
- `(setf (getf *arg-form-kinds* ',name) kind))
+ ,@(mapcar (lambda (name)
+ `(setf (getf *arg-form-kinds* ',name) kind))
names)))
(def-arg-form-kind (:raw)
- :producer #'(lambda (arg funstate)
- (declare (ignore funstate))
- (mapcar #'(lambda (bytespec)
- `(the (unsigned-byte ,(byte-size bytespec))
- (local-extract ',bytespec)))
- (arg-fields arg)))
- :checker #'(lambda (new-arg old-arg)
- (equal (arg-fields new-arg)
- (arg-fields old-arg))))
+ :producer (lambda (arg funstate)
+ (declare (ignore funstate))
+ (mapcar (lambda (bytespec)
+ `(the (unsigned-byte ,(byte-size bytespec))
+ (local-extract ',bytespec)))
+ (arg-fields arg)))
+ :checker (lambda (new-arg old-arg)
+ (equal (arg-fields new-arg)
+ (arg-fields old-arg))))
(def-arg-form-kind (:sign-extended :unfiltered)
- :producer #'(lambda (arg funstate)
- (let ((raw-forms (gen-arg-forms arg :raw funstate)))
- (if (and (arg-sign-extend-p arg) (listp raw-forms))
- (mapcar #'(lambda (form field)
- `(the (signed-byte ,(byte-size field))
- (sign-extend ,form
- ,(byte-size field))))
- raw-forms
- (arg-fields arg))
- raw-forms)))
- :checker #'(lambda (new-arg old-arg)
- (equal (arg-sign-extend-p new-arg)
- (arg-sign-extend-p old-arg))))
+ :producer (lambda (arg funstate)
+ (let ((raw-forms (gen-arg-forms arg :raw funstate)))
+ (if (and (arg-sign-extend-p arg) (listp raw-forms))
+ (mapcar (lambda (form field)
+ `(the (signed-byte ,(byte-size field))
+ (sign-extend ,form
+ ,(byte-size field))))
+ raw-forms
+ (arg-fields arg))
+ raw-forms)))
+ :checker (lambda (new-arg old-arg)
+ (equal (arg-sign-extend-p new-arg)
+ (arg-sign-extend-p old-arg))))
(defun valsrc-equal (f1 f2)
(if (null f1)
(value-or-source f2))))
(def-arg-form-kind (:filtering)
- :producer #'(lambda (arg funstate)
- (let ((sign-extended-forms
- (gen-arg-forms arg :sign-extended funstate))
- (pf (arg-prefilter arg)))
- (if pf
- (values
- `(local-filter ,(maybe-listify sign-extended-forms)
- ,(source-form pf))
- t)
- (values sign-extended-forms nil))))
- :checker #'(lambda (new-arg old-arg)
- (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
+ :producer (lambda (arg funstate)
+ (let ((sign-extended-forms
+ (gen-arg-forms arg :sign-extended funstate))
+ (pf (arg-prefilter arg)))
+ (if pf
+ (values
+ `(local-filter ,(maybe-listify sign-extended-forms)
+ ,(source-form pf))
+ t)
+ (values sign-extended-forms nil))))
+ :checker (lambda (new-arg old-arg)
+ (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
(def-arg-form-kind (:filtered :unadjusted)
- :producer #'(lambda (arg funstate)
- (let ((pf (arg-prefilter arg)))
- (if pf
- (values `(local-filtered-value ,(arg-position arg)) t)
- (gen-arg-forms arg :sign-extended funstate))))
- :checker #'(lambda (new-arg old-arg)
- (let ((pf1 (arg-prefilter new-arg))
- (pf2 (arg-prefilter old-arg)))
- (if (null pf1)
- (null pf2)
- (= (arg-position new-arg)
- (arg-position old-arg))))))
+ :producer (lambda (arg funstate)
+ (let ((pf (arg-prefilter arg)))
+ (if pf
+ (values `(local-filtered-value ,(arg-position arg)) t)
+ (gen-arg-forms arg :sign-extended funstate))))
+ :checker (lambda (new-arg old-arg)
+ (let ((pf1 (arg-prefilter new-arg))
+ (pf2 (arg-prefilter old-arg)))
+ (if (null pf1)
+ (null pf2)
+ (= (arg-position new-arg)
+ (arg-position old-arg))))))
(def-arg-form-kind (:adjusted :numeric :unlabelled)
- :producer #'(lambda (arg funstate)
- (let ((filtered-forms (gen-arg-forms arg :filtered funstate))
- (use-label (arg-use-label arg)))
- (if (and use-label (not (eq use-label t)))
- (list
- `(adjust-label ,(maybe-listify filtered-forms)
- ,(source-form use-label)))
- filtered-forms)))
- :checker #'(lambda (new-arg old-arg)
- (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
+ :producer (lambda (arg funstate)
+ (let ((filtered-forms (gen-arg-forms arg :filtered funstate))
+ (use-label (arg-use-label arg)))
+ (if (and use-label (not (eq use-label t)))
+ (list
+ `(adjust-label ,(maybe-listify filtered-forms)
+ ,(source-form use-label)))
+ filtered-forms)))
+ :checker (lambda (new-arg old-arg)
+ (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
(def-arg-form-kind (:labelled :final)
- :producer #'(lambda (arg funstate)
- (let ((adjusted-forms
- (gen-arg-forms arg :adjusted funstate))
- (use-label (arg-use-label arg)))
- (if use-label
- (let ((form (maybe-listify adjusted-forms)))
- (if (and (not (eq use-label t))
- (not (atom adjusted-forms))
- (/= (Length adjusted-forms) 1))
- (pd-error
- "cannot label a multiple-field argument ~
+ :producer (lambda (arg funstate)
+ (let ((adjusted-forms
+ (gen-arg-forms arg :adjusted funstate))
+ (use-label (arg-use-label arg)))
+ (if use-label
+ (let ((form (maybe-listify adjusted-forms)))
+ (if (and (not (eq use-label t))
+ (not (atom adjusted-forms))
+ (/= (Length adjusted-forms) 1))
+ (pd-error
+ "cannot label a multiple-field argument ~
unless using a function: ~S" arg)
- `((lookup-label ,form))))
- adjusted-forms)))
- :checker #'(lambda (new-arg old-arg)
- (let ((lf1 (arg-use-label new-arg))
- (lf2 (arg-use-label old-arg)))
- (if (null lf1) (null lf2) t))))
+ `((lookup-label ,form))))
+ adjusted-forms)))
+ :checker (lambda (new-arg old-arg)
+ (let ((lf1 (arg-use-label new-arg))
+ (lf2 (arg-use-label old-arg)))
+ (if (null lf1) (null lf2) t))))
;;; This is a bogus kind that's just used to ensure that printers are
;;; compatible...
(def-arg-form-kind (:printed)
- :producer #'(lambda (&rest noise)
- (declare (ignore noise))
- (pd-error "bogus! can't use the :printed value of an arg!"))
- :checker #'(lambda (new-arg old-arg)
- (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
+ :producer (lambda (&rest noise)
+ (declare (ignore noise))
+ (pd-error "bogus! can't use the :printed value of an arg!"))
+ :checker (lambda (new-arg old-arg)
+ (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
(defun remember-printer-use (arg funstate)
(set-arg-temps nil nil arg :printed funstate))
test
key
(sharing-mapcar
- #'(lambda (sub-test)
- (preprocess-test subj sub-test args))
+ (lambda (sub-test)
+ (preprocess-test subj sub-test args))
body))))
(t form)))))
printer
:cond
(sharing-mapcar
- #'(lambda (clause)
- (let ((filtered-body
- (sharing-mapcar
- #'(lambda (sub-printer)
- (preprocess-conditionals sub-printer args))
- (cdr clause))))
- (sharing-cons
- clause
- (preprocess-test (find-first-field-name filtered-body)
- (car clause)
- args)
- filtered-body)))
+ (lambda (clause)
+ (let ((filtered-body
+ (sharing-mapcar
+ (lambda (sub-printer)
+ (preprocess-conditionals sub-printer args))
+ (cdr clause))))
+ (sharing-cons
+ clause
+ (preprocess-test (find-first-field-name filtered-body)
+ (car clause)
+ args)
+ filtered-body)))
(cdr printer))))
(quote printer)
(t
(sharing-mapcar
- #'(lambda (sub-printer)
- (preprocess-conditionals sub-printer args))
+ (lambda (sub-printer)
+ (preprocess-conditionals sub-printer args))
printer)))))
;;; Return a version of the disassembly-template PRINTER with
((eq (car printer) :choose)
(pick-printer-choice (cdr printer) args))
(t
- (sharing-mapcar #'(lambda (sub) (preprocess-chooses sub args))
+ (sharing-mapcar (lambda (sub) (preprocess-chooses sub args))
printer))))
\f
;;;; some simple functions that help avoid consing when we're just
((symbolp printer)
(find printer args :key #'arg-name))
((listp printer)
- (every #'(lambda (x) (all-arg-refs-relevant-p x args))
+ (every (lambda (x) (all-arg-refs-relevant-p x args))
printer))
(t t)))
((eq (car source) 'function)
`(local-call-global-printer ,source))
((eq (car source) :cond)
- `(cond ,@(mapcar #'(lambda (clause)
- `(,(compile-test (find-first-field-name
- (cdr clause))
- (car clause)
- funstate)
- ,@(compile-printer-list (cdr clause)
- funstate)))
+ `(cond ,@(mapcar (lambda (clause)
+ `(,(compile-test (find-first-field-name
+ (cdr clause))
+ (car clause)
+ funstate)
+ ,@(compile-printer-list (cdr clause)
+ funstate)))
(cdr source))))
;; :IF, :UNLESS, and :WHEN are replaced by :COND during preprocessing
(t
`(equal ,(listify-fields val-form-1)
,(listify-fields val-form-2)))
(t
- `(and ,@(mapcar #'(lambda (v1 v2) `(= ,v1 ,v2))
+ `(and ,@(mapcar (lambda (v1 v2) `(= ,v1 ,v2))
val-form-1 val-form-2))))))
(defun compile-test (subj test funstate)
(arg2 (arg-or-lose (car body) funstate)))
(unless (and (= (length (arg-fields arg1))
(length (arg-fields arg2)))
- (every #'(lambda (bs1 bs2)
- (= (byte-size bs1) (byte-size bs2)))
+ (every (lambda (bs1 bs2)
+ (= (byte-size bs1) (byte-size bs2)))
(arg-fields arg1)
(arg-fields arg2)))
(pd-error "can't compare differently sized fields: ~
(compare-fields-form (gen-arg-forms arg1 :numeric funstate)
(gen-arg-forms arg2 :numeric funstate))))
((eq key :or)
- `(or ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
+ `(or ,@(mapcar (lambda (sub) (compile-test subj sub funstate))
body)))
((eq key :and)
- `(and ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
+ `(and ,@(mapcar (lambda (sub) (compile-test subj sub funstate))
body)))
((eq key :not)
`(not ,(compile-test subj (car body) funstate)))
(defun ,aux-name (num)
;; When converting a number to a float, the limits are
;; the same.
- (let* ((lo (bound-func #'(lambda (x)
- (coerce x ',type))
+ (let* ((lo (bound-func (lambda (x)
+ (coerce x ',type))
(numeric-type-low num)))
- (hi (bound-func #'(lambda (x)
- (coerce x ',type))
+ (hi (bound-func (lambda (x)
+ (coerce x ',type))
(numeric-type-high num))))
(specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
`(defoptimizer (,name derive-type) ((,num))
(one-arg-derive-type
,num
- #'(lambda (arg)
- (elfun-derive-type-simple arg #',name
- ,domain-low ,domain-high
- ,def-low-bnd ,def-high-bnd
- ,increasingp))
+ (lambda (arg)
+ (elfun-derive-type-simple arg #',name
+ ,domain-low ,domain-high
+ ,def-low-bnd ,def-high-bnd
+ ,increasingp))
#',name)))))
;; These functions are easy because they are defined for the whole
;; real line.
(defoptimizer (cis derive-type) ((num))
(one-arg-derive-type num
- #'(lambda (arg)
- (sb!c::specifier-type
- `(complex ,(or (numeric-type-format arg) 'float))))
+ (lambda (arg)
+ (sb!c::specifier-type
+ `(complex ,(or (numeric-type-format arg) 'float))))
#'cis))
) ; PROGN
(maphash #'note-failed-optimization
(component-failed-optimizations component))
- (maphash #'(lambda (k v)
- (note-assumed-types component k v))
+ (maphash (lambda (k v)
+ (note-assumed-types component k v))
*free-functions*)
(values))
call
`(lambda ,dummies
(declare (ignore ,@dummies))
- (values ,@(mapcar #'(lambda (x) `',x) values))))))))
+ (values ,@(mapcar (lambda (x) `',x) values))))))))
(values))
\f
(propagate-to-refs var (continuation-type arg))
(let ((use-component (node-component use)))
(substitute-leaf-if
- #'(lambda (ref)
- (cond ((eq (node-component ref) use-component)
- t)
- (t
- (aver (lambda-toplevelish-p (lambda-home fun)))
- nil)))
+ (lambda (ref)
+ (cond ((eq (node-component ref) use-component)
+ t)
+ (t
+ (aver (lambda-toplevelish-p (lambda-home fun)))
+ nil)))
leaf var))
t)))))
((and (null (rest (leaf-refs var)))
(unless (or (functional-entry-fun fun)
(lambda-optional-dispatch fun))
(let* ((vars (lambda-vars fun))
- (union (mapcar #'(lambda (arg var)
- (when (and arg
- (continuation-reoptimize arg)
- (null (basic-var-sets var)))
- (continuation-type arg)))
+ (union (mapcar (lambda (arg var)
+ (when (and arg
+ (continuation-reoptimize arg)
+ (null (basic-var-sets var)))
+ (continuation-type arg)))
(basic-combination-args call)
vars))
(this-ref (continuation-use (basic-combination-fun call))))
(let ((dest (continuation-dest (node-cont ref))))
(unless (or (eq ref this-ref) (not dest))
(setq union
- (mapcar #'(lambda (this-arg old)
- (when old
- (setf (continuation-reoptimize this-arg) nil)
- (type-union (continuation-type this-arg) old)))
+ (mapcar (lambda (this-arg old)
+ (when old
+ (setf (continuation-reoptimize this-arg) nil)
+ (type-union (continuation-type this-arg) old)))
(basic-combination-args dest)
union)))))
- (mapc #'(lambda (var type)
- (when type
- (propagate-to-refs var type)))
+ (mapc (lambda (var type)
+ (when type
+ (propagate-to-refs var type)))
vars union)))
(values))
(multiple-value-bind (types nvals)
(values-types (continuation-derived-type arg))
(unless (eq nvals :unknown)
- (mapc #'(lambda (var type)
- (if (basic-var-sets var)
- (propagate-from-sets var type)
- (propagate-to-refs var type)))
- vars
+ (mapc (lambda (var type)
+ (if (basic-var-sets var)
+ (propagate-from-sets var type)
+ (propagate-to-refs var type)))
+ vars
(append types
(make-list (max (- (length vars) nvals) 0)
:initial-element (specifier-type 'null))))))
list of subforms suitable for a \"~{~S ~}\" format string."
(let ((n-whole (gensym)))
`(setf (gethash ',name *source-context-methods*)
- #'(lambda (,n-whole)
- (destructuring-bind ,lambda-list ,n-whole ,@body)))))
+ (lambda (,n-whole)
+ (destructuring-bind ,lambda-list ,n-whole ,@body)))))
(defmacro def-source-context (&rest rest)
(deprecation-warning 'def-source-context 'define-source-context)
(cond ((atom form) nil)
((>= (length form) 2)
(funcall (gethash (first form) *source-context-methods*
- #'(lambda (x)
- (declare (ignore x))
- (list (first form) (second form))))
+ (lambda (x)
+ (declare (ignore x))
+ (list (first form) (second form))))
(rest form)))
(t
form)))
((or (atom opname) (not (eq (car opname) 'lambda)))
(compiler-error "illegal function call"))
(t
- ;; implicitly #'(LAMBDA ..) because the LAMBDA
+ ;; implicitly (LAMBDA ..) because the LAMBDA
;; expression is the CAR of an executed form
(ir1-convert-combination start
cont
(not (eq pkg (symbol-package :end))))))
(not (member first *deletion-ignored-objects*))
(not (typep first '(or fixnum character)))
- (every #'(lambda (x)
- (present-in-form first x 0))
+ (every (lambda (x)
+ (present-in-form first x 0))
(source-path-forms path))
(present-in-form first (find-original-source path)
0)))
(multiple-value-bind (check types) (continuation-check-types cont)
(aver (eq check :simple))
(let ((ntypes (length types)))
- (mapcar #'(lambda (from to-type assertion)
- (let ((temp (make-normal-tn to-type)))
- (if assertion
- (emit-type-check node block from temp assertion)
- (emit-move node block from temp))
- temp))
+ (mapcar (lambda (from to-type assertion)
+ (let ((temp (make-normal-tn to-type)))
+ (if assertion
+ (emit-type-check node block from temp assertion)
+ (emit-move node block from temp))
+ temp))
locs ptypes
(if (< ntypes nlocs)
(append types (make-list (- nlocs ntypes)
:initial-element nil))
types))))
- (mapcar #'(lambda (from to-type)
- (if (eq (tn-primitive-type from) to-type)
- from
- (let ((temp (make-normal-tn to-type)))
- (emit-move node block from temp)
- temp)))
+ (mapcar (lambda (from to-type)
+ (if (eq (tn-primitive-type from) to-type)
+ from
+ (let ((temp (make-normal-tn to-type)))
+ (emit-move node block from temp)
+ temp)))
locs
ptypes))))
\f
(unless (eq (tn-primitive-type (car loc)) (car type))
(return nil))))
locs
- (mapcar #'(lambda (loc type)
- (if (eq (tn-primitive-type loc) type)
- loc
- (make-normal-tn type)))
+ (mapcar (lambda (loc type)
+ (if (eq (tn-primitive-type loc) type)
+ loc
+ (make-normal-tn type)))
(if (< nlocs ntypes)
(append locs
(mapcar #'make-normal-tn
(declare (type node node) (type ir2-block block) (list src dest))
(let ((nsrc (length src))
(ndest (length dest)))
- (mapc #'(lambda (from to)
- (unless (eq from to)
- (emit-move node block from to)))
+ (mapc (lambda (from to)
+ (unless (eq from to)
+ (emit-move node block from to)))
(if (> ndest nsrc)
(append src (make-list (- ndest nsrc)
:initial-element (emit-constant nil)))
;;; this.
(defun ir2-convert-let (node block fun)
(declare (type combination node) (type ir2-block block) (type clambda fun))
- (mapc #'(lambda (var arg)
- (when arg
- (let ((src (continuation-tn node block arg))
- (dest (leaf-info var)))
- (if (lambda-var-indirect var)
- (do-make-value-cell node block src dest)
- (emit-move node block src dest)))))
+ (mapc (lambda (var arg)
+ (when arg
+ (let ((src (continuation-tn node block arg))
+ (dest (leaf-info var)))
+ (if (lambda-var-indirect var)
+ (do-make-value-cell node block src dest)
+ (emit-move node block src dest)))))
(lambda-vars fun) (basic-combination-args node))
(values))
(type (or tn null) old-fp))
(let* ((called-env (physenv-info (lambda-physenv fun)))
(this-1env (node-physenv node))
- (actuals (mapcar #'(lambda (x)
- (when x
- (continuation-tn node block x)))
- (combination-args node))))
+ (actuals (mapcar (lambda (x)
+ (when x
+ (continuation-tn node block x)))
+ (combination-args node))))
(collect ((temps)
(locs))
(dolist (var (lambda-vars fun))
(multiple-value-bind (temps locs)
(emit-psetq-moves node block fun (ir2-physenv-old-fp this-env))
- (mapc #'(lambda (temp loc)
- (emit-move node block temp loc))
+ (mapc (lambda (temp loc)
+ (emit-move node block temp loc))
temps locs))
(emit-move node block
(declare (type combination node) (type ir2-block block) (type clambda fun))
(multiple-value-bind (temps locs) (emit-psetq-moves node block fun nil)
- (mapc #'(lambda (temp loc)
- (emit-move node block temp loc))
+ (mapc (lambda (temp loc)
+ (emit-move node block temp loc))
temps locs))
(values))
(cont-locs (continuation-tns node block cont types))
(nvals (length cont-locs))
(locs (make-standard-value-tns nvals)))
- (mapc #'(lambda (val loc)
- (emit-move node block val loc))
+ (mapc (lambda (val loc)
+ (emit-move node block val loc))
cont-locs
locs)
(if (= nvals 1)
(fun (ref-leaf (continuation-use (basic-combination-fun node))))
(vars (lambda-vars fun)))
(aver (eq (functional-kind fun) :mv-let))
- (mapc #'(lambda (src var)
- (when (leaf-refs var)
- (let ((dest (leaf-info var)))
- (if (lambda-var-indirect var)
- (do-make-value-cell node block src dest)
- (emit-move node block src dest)))))
+ (mapc (lambda (src var)
+ (when (leaf-refs var)
+ (let ((dest (leaf-info var)))
+ (if (lambda-var-indirect var)
+ (do-make-value-cell node block src dest)
+ (emit-move node block src dest)))))
(continuation-tns node block cont
- (mapcar #'(lambda (x)
- (primitive-type (leaf-type x)))
+ (mapcar (lambda (x)
+ (primitive-type (leaf-type x)))
vars))
vars))
(values))
;;; Deliver the values TNs to CONT using MOVE-CONTINUATION-RESULT.
(defoptimizer (values ir2-convert) ((&rest values) node block)
- (let ((tns (mapcar #'(lambda (x)
- (continuation-tn node block x))
+ (let ((tns (mapcar (lambda (x)
+ (continuation-tn node block x))
values)))
(move-continuation-result node block tns (node-cont node))))
(once-only ((n-save-bs '(%primitive current-binding-pointer)))
`(unwind-protect
(progn
- (mapc #'(lambda (var val)
- (%primitive bind val var))
+ (mapc (lambda (var val)
+ (%primitive bind val var))
,vars
,vals)
,@body)
;;; argument. If arg is a list, result is a list. If arg is a vector, result
;;; is a vector with the same element type.
(defun sequence-result-nth-arg (n)
- #'(lambda (call)
- (declare (type combination call))
- (let ((cont (nth (1- n) (combination-args call))))
- (when cont
- (let ((type (continuation-type cont)))
- (if (array-type-p type)
- (specifier-type
- `(vector ,(type-specifier (array-type-element-type type))))
- (let ((ltype (specifier-type 'list)))
- (when (csubtypep type ltype)
- ltype))))))))
+ (lambda (call)
+ (declare (type combination call))
+ (let ((cont (nth (1- n) (combination-args call))))
+ (when cont
+ (let ((type (continuation-type cont)))
+ (if (array-type-p type)
+ (specifier-type
+ `(vector ,(type-specifier (array-type-element-type type))))
+ (let ((ltype (specifier-type 'list)))
+ (when (csubtypep type ltype)
+ ltype))))))))
;;; Derive the type to be the type specifier which is the N'th arg.
(defun result-type-specifier-nth-arg (n)
(let ((res (make-ir2-continuation nil)))
(if (member (continuation-type-check cont) '(:deleted nil))
(setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
- (let* ((proven (mapcar #'(lambda (x)
- (make-normal-tn (primitive-type x)))
+ (let* ((proven (mapcar (lambda (x)
+ (make-normal-tn (primitive-type x)))
(values-types
(continuation-proven-type cont))))
(num-proven (length proven))
(:arg-types
(funcall frob "argument types invalid")
(funcall frob "argument primitive types:~% ~S"
- (mapcar #'(lambda (x)
- (primitive-type-name
- (continuation-ptype x)))
+ (mapcar (lambda (x)
+ (primitive-type-name
+ (continuation-ptype x)))
(combination-args call)))
(funcall frob "argument type assertions:~% ~S"
- (mapcar #'(lambda (x)
- (if (atom x)
- x
- (ecase (car x)
- (:or `(:or .,(mapcar #'primitive-type-name
- (cdr x))))
- (:constant `(:constant ,(third x))))))
+ (mapcar (lambda (x)
+ (if (atom x)
+ x
+ (ecase (car x)
+ (:or `(:or .,(mapcar #'primitive-type-name
+ (cdr x))))
+ (:constant `(:constant ,(third x))))))
(template-arg-types template))))
(:conditional
(funcall frob "conditional in a non-conditional context"))
;;; those in Attr2.
(defmacro attributes-union (&rest attributes)
`(the attributes
- (logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
+ (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))
(defmacro attributes-intersection (&rest attributes)
`(the attributes
- (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
+ (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))
(declaim (ftype (function (attributes attributes) boolean) attributes=))
#!-sb-fluid (declaim (inline attributes=))
(defun attributes= (attr1 attr2)
,(if eval-name
``(function ,,arg-types ,,result-type)
`'(function ,arg-types ,result-type))
- #'(lambda ,@stuff)
+ (lambda ,@stuff)
,doc
,(if important t nil)
,when)))))))
(declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics))
(defun event-statistics (&optional (min-count 1) (stream *standard-output*))
(collect ((info))
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (when (>= (event-info-count v) min-count)
- (info v)))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (when (>= (event-info-count v) min-count)
+ (info v)))
*event-info*)
(dolist (event (sort (info) #'> :key #'event-info-count))
(format stream "~6D: ~A~%" (event-info-count event)
(declaim (ftype (function nil (values)) clear-event-statistics))
(defun clear-event-statistics ()
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (setf (event-info-count v) 0))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (setf (event-info-count v) 0))
*event-info*)
(values))
\f
(warning #'compiler-warning-handler))
(let ((undefs (sort *undefined-warnings* #'string<
- :key #'(lambda (x)
- (let ((x (undefined-warning-name x)))
- (if (symbolp x)
- (symbol-name x)
- (prin1-to-string x)))))))
+ :key (lambda (x)
+ (let ((x (undefined-warning-name x)))
+ (if (symbolp x)
+ (symbol-name x)
+ (prin1-to-string x)))))))
(dolist (undef undefs)
(let ((name (undefined-warning-name undef))
(kind (undefined-warning-kind undef))
;;; slots, since they are used to keep track of functions across
;;; component boundaries.
(defun clear-constant-info ()
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (setf (leaf-info v) nil))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (setf (leaf-info v) nil))
*constants*)
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (when (constant-p v)
- (setf (leaf-info v) nil)))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (when (constant-p v)
+ (setf (leaf-info v) nil)))
*free-variables*)
(values))
(defun clear-ir1-info (component)
(declare (type component component))
(labels ((blast (x)
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (when (leaf-p v)
- (setf (leaf-refs v)
- (delete-if #'here-p (leaf-refs v)))
- (when (basic-var-p v)
- (setf (basic-var-sets v)
- (delete-if #'here-p (basic-var-sets v))))))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (when (leaf-p v)
+ (setf (leaf-refs v)
+ (delete-if #'here-p (leaf-refs v)))
+ (when (basic-var-p v)
+ (setf (basic-var-sets v)
+ (delete-if #'here-p (basic-var-sets v))))))
x))
(here-p (x)
(eq (node-component x) component)))
(if (or (eq sb-name 'non-descriptor-stack)
(find 'non-descriptor-stack
(mapcar #'meta-sc-or-lose alternate-scs)
- :key #'(lambda (x)
- (sb-name (sc-sb x)))))
+ :key (lambda (x)
+ (sb-name (sc-sb x)))))
t nil)))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(n-type (gensym)))
`(let ((,n-vop (template-or-lose ',vop)))
,@(mapcar
- #'(lambda (type)
- `(let ((,n-type (primitive-type-or-lose ',type)))
- ,@(mapcar
- #'(lambda (kind)
- (let ((slot (or (cdr (assoc kind
- *primitive-type-slot-alist*))
- (error "unknown kind: ~S" kind))))
- `(setf (,slot ,n-type) ,n-vop)))
- kinds)))
+ (lambda (type)
+ `(let ((,n-type (primitive-type-or-lose ',type)))
+ ,@(mapcar
+ (lambda (kind)
+ (let ((slot (or (cdr (assoc kind
+ *primitive-type-slot-alist*))
+ (error "unknown kind: ~S" kind))))
+ `(setf (,slot ,n-type) ,n-vop)))
+ kinds)))
types)
nil)))
(refs (cons (cons born t) index))))
(incf index)))
(let* ((sorted (sort (refs)
- #'(lambda (x y)
- (let ((x-time (car x))
- (y-time (car y)))
- (if (time-spec-order x-time y-time)
- (if (time-spec-order y-time x-time)
- (and (not (cdr x)) (cdr y))
- nil)
- t)))
+ (lambda (x y)
+ (let ((x-time (car x))
+ (y-time (car y)))
+ (if (time-spec-order x-time y-time)
+ (if (time-spec-order y-time x-time)
+ (and (not (cdr x)) (cdr y))
+ nil)
+ t)))
:key #'car))
(oe-type '(mod #.max-vop-tn-refs)) ; :REF-ORDERING element type
(te-type '(mod #.(* max-vop-tn-refs 2))) ; :TARGETS element type
(setf (vop-parse-vop-var parse) (gensym))))
(form (if (rest funs)
`(sc-case ,tn
- ,@(mapcar #'(lambda (x)
- `(,(mapcar #'sc-name (car x))
- ,(if load-p
- `(,(cdr x) ,n-vop ,tn
- ,load-tn)
- `(,(cdr x) ,n-vop ,load-tn
- ,tn))))
+ ,@(mapcar (lambda (x)
+ `(,(mapcar #'sc-name (car x))
+ ,(if load-p
+ `(,(cdr x) ,n-vop ,tn
+ ,load-tn)
+ `(,(cdr x) ,n-vop ,load-tn
+ ,tn))))
funs))
(if load-p
`(,(cdr (first funs)) ,n-vop ,tn ,load-tn)
(tn-ref-tn ,(operand-parse-temp op)))))
((:more-argument :more-result))))
- `#'(lambda (,n-vop)
- (let* (,@(access-operands (vop-parse-args parse)
- (vop-parse-more-args parse)
- `(vop-args ,n-vop))
+ `(lambda (,n-vop)
+ (let* (,@(access-operands (vop-parse-args parse)
+ (vop-parse-more-args parse)
+ `(vop-args ,n-vop))
,@(access-operands (vop-parse-results parse)
(vop-parse-more-results parse)
`(vop-results ,n-vop))
,@(when (vop-parse-node-var parse)
`((,(vop-parse-node-var parse) (vop-node ,n-vop))))
,@(binds))
- (declare (ignore ,@(vop-parse-ignores parse)))
- ,@(loads)
- (sb!assem:assemble (*code-segment* ,n-vop)
- ,@(vop-parse-body parse))
- ,@(saves))))))
+ (declare (ignore ,@(vop-parse-ignores parse)))
+ ,@(loads)
+ (sb!assem:assemble (*code-segment* ,n-vop)
+ ,@(vop-parse-body parse))
+ ,@(saves))))))
\f
;;; Given a list of operand specifications as given to DEFINE-VOP,
;;; return a list of OPERAND-PARSE structures describing the fixed
(macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
`(progn
,@(mapcar
- #'(lambda (suffix cost signed)
- `(define-vop (;; FIXME: These could be done more
- ;; cleanly with SYMBOLICATE.
- ,(intern (format nil "~:@(FAST-IF-~A~A~)"
- tran suffix))
- ,(intern
- (format nil "~:@(FAST-CONDITIONAL~A~)"
- suffix)))
- (:translate ,tran)
- (:generator ,cost
- (inst cmp x
- ,(if (eq suffix '-c/fixnum)
- '(fixnumize y)
- 'y))
- (inst jmp (if not-p
- ,(if signed
- not-cond
- not-unsigned)
- ,(if signed
- cond
- unsigned))
- target))))
+ (lambda (suffix cost signed)
+ `(define-vop (;; FIXME: These could be done more
+ ;; cleanly with SYMBOLICATE.
+ ,(intern (format nil "~:@(FAST-IF-~A~A~)"
+ tran suffix))
+ ,(intern
+ (format nil "~:@(FAST-CONDITIONAL~A~)"
+ suffix)))
+ (:translate ,tran)
+ (:generator ,cost
+ (inst cmp x
+ ,(if (eq suffix '-c/fixnum)
+ '(fixnumize y)
+ 'y))
+ (inst jmp (if not-p
+ ,(if signed
+ not-cond
+ not-unsigned)
+ ,(if signed
+ cond
+ unsigned))
+ target))))
'(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
'(4 3 6 5 6 5)
'(t t t t nil nil)))))
#+nil ;;pfw obsolete now?
(define-alien-type-method (values :result-tn) (type state)
- (mapcar #'(lambda (type)
- (invoke-alien-type-method :result-tn type state))
+ (mapcar (lambda (type)
+ (invoke-alien-type-method :result-tn type state))
(alien-values-type-values type)))
;;; pfw - from alpha
;; doing the call. Therefore, we have to tell the
;; lifetime stuff that we need to use them.
,@(when variable
- (mapcar #'(lambda (name offset)
- `(:temporary (:sc descriptor-reg
- :offset ,offset
- :from (:argument 0)
- :to :eval)
- ,name))
+ (mapcar (lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :from (:argument 0)
+ :to :eval)
+ ,name))
*register-arg-names* *register-arg-offsets*))
,@(when (eq return :tail)
,@(when translate
`((:policy :fast-safe)
(:translate ,translate)))
- (:args ,@(mapcar #'(lambda (arg)
- `(,arg :scs (any-reg descriptor-reg)))
+ (:args ,@(mapcar (lambda (arg)
+ `(,arg :scs (any-reg descriptor-reg)))
args))
(:vop-var vop)
(:save-p :compute-only)
(sb!disassem:define-argument-type displacement
:sign-extend t
:use-label #'offset-next
- :printer #'(lambda (value stream dstate)
- (sb!disassem:maybe-note-assembler-routine value nil dstate)
- (print-label value stream dstate)))
+ :printer (lambda (value stream dstate)
+ (sb!disassem:maybe-note-assembler-routine value nil dstate)
+ (print-label value stream dstate)))
(sb!disassem:define-argument-type accum
- :printer #'(lambda (value stream dstate)
- (declare (ignore value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
- (print-reg 0 stream dstate))
- )
+ :printer (lambda (value stream dstate)
+ (declare (ignore value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-reg 0 stream dstate)))
(sb!disassem:define-argument-type word-accum
- :printer #'(lambda (value stream dstate)
- (declare (ignore value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
- (print-word-reg 0 stream dstate)))
+ :printer (lambda (value stream dstate)
+ (declare (ignore value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-word-reg 0 stream dstate)))
(sb!disassem:define-argument-type reg
:printer #'print-reg)
:printer #'print-label)
(sb!disassem:define-argument-type imm-data
- :prefilter #'(lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-suffix
- (width-bits (sb!disassem:dstate-get-prop dstate 'width))
- dstate))
- )
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix
+ (width-bits (sb!disassem:dstate-get-prop dstate 'width))
+ dstate)))
(sb!disassem:define-argument-type signed-imm-data
- :prefilter #'(lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
- (sb!disassem:read-signed-suffix (width-bits width) dstate)))
- )
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
+ (sb!disassem:read-signed-suffix (width-bits width) dstate))))
(sb!disassem:define-argument-type signed-imm-byte
- :prefilter #'(lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 8 dstate)))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 8 dstate)))
(sb!disassem:define-argument-type signed-imm-dword
- :prefilter #'(lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 32 dstate)))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate)))
(sb!disassem:define-argument-type imm-word
- :prefilter #'(lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (let ((width
- (or (sb!disassem:dstate-get-prop dstate 'word-width)
- +default-operand-size+)))
- (sb!disassem:read-suffix (width-bits width) dstate))))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (let ((width
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)))
+ (sb!disassem:read-suffix (width-bits width) dstate))))
;;; needed for the ret imm16 instruction
(sb!disassem:define-argument-type imm-word-16
- :prefilter #'(lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-suffix 16 dstate)))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix 16 dstate)))
(sb!disassem:define-argument-type reg/mem
:prefilter #'prefilter-reg/mem
(sb!disassem:define-argument-type width
:prefilter #'prefilter-width
- :printer #'(lambda (value stream dstate)
- (if ;; (zerop value)
- (or (null value)
- (and (numberp value) (zerop value))) ; zzz jrd
- (princ 'b stream)
- (let ((word-width
- ;; set by a prefix instruction
- (or (sb!disassem:dstate-get-prop dstate 'word-width)
- +default-operand-size+)))
- (princ (schar (symbol-name word-width) 0) stream)))))
+ :printer (lambda (value stream dstate)
+ (if;; (zerop value)
+ (or (null value)
+ (and (numberp value) (zerop value))) ; zzz jrd
+ (princ 'b stream)
+ (let ((word-width
+ ;; set by a prefix instruction
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)))
+ (princ (schar (symbol-name word-width) 0) stream)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *conditions*
;; The disassembler currently doesn't let you have an instruction > 32 bits
;; long, so we fake it by using a prefilter to read the offset.
(label :type 'displacement
- :prefilter #'(lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 32 dstate))))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate))))
(sb!disassem:define-instruction-format (near-jump 8
:default-printer '(:name :tab label))
;; The disassembler currently doesn't let you have an instruction > 32 bits
;; long, so we fake it by using a prefilter to read the address.
(label :type 'displacement
- :prefilter #'(lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 32 dstate))))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate))))
(sb!disassem:define-instruction-format (cond-set 24
(if (label-p offset)
(emit-back-patch segment
4 ; FIXME: sb!vm:n-word-bytes
- #'(lambda (segment posn)
- (declare (ignore posn))
- (emit-dword segment
- (- (+ (component-header-length)
- (or (label-position offset)
- 0))
- other-pointer-lowtag))))
+ (lambda (segment posn)
+ (declare (ignore posn))
+ (emit-dword segment
+ (- (+ (component-header-length)
+ (or (label-position offset)
+ 0))
+ other-pointer-lowtag))))
(emit-dword segment (or offset 0)))))
(defun emit-relative-fixup (segment fixup)
(emit-byte segment #b11101000)
(emit-back-patch segment
4
- #'(lambda (segment posn)
- (emit-dword segment
- (- (label-position where)
- (+ posn 4))))))
+ (lambda (segment posn)
+ (emit-dword segment
+ (- (label-position where)
+ (+ posn 4))))))
(fixup
(emit-byte segment #b11101000)
(emit-relative-fixup segment where))
(defun emit-byte-displacement-backpatch (segment target)
(emit-back-patch segment
1
- #'(lambda (segment posn)
- (let ((disp (- (label-position target) (1+ posn))))
- (aver (<= -128 disp 127))
- (emit-byte segment disp)))))
+ (lambda (segment posn)
+ (let ((disp (- (label-position target) (1+ posn))))
+ (aver (<= -128 disp 127))
+ (emit-byte segment disp)))))
(define-instruction jmp (segment cond &optional where)
;; conditional jumps
(cond (where
(emit-chooser
segment 6 2
- #'(lambda (segment posn delta-if-after)
- (let ((disp (- (label-position where posn delta-if-after)
- (+ posn 2))))
- (when (<= -128 disp 127)
- (emit-byte segment
- (dpb (conditional-opcode cond)
- (byte 4 0)
- #b01110000))
- (emit-byte-displacement-backpatch segment where)
- t)))
- #'(lambda (segment posn)
- (let ((disp (- (label-position where) (+ posn 6))))
- (emit-byte segment #b00001111)
+ (lambda (segment posn delta-if-after)
+ (let ((disp (- (label-position where posn delta-if-after)
+ (+ posn 2))))
+ (when (<= -128 disp 127)
(emit-byte segment
(dpb (conditional-opcode cond)
(byte 4 0)
- #b10000000))
- (emit-dword segment disp)))))
+ #b01110000))
+ (emit-byte-displacement-backpatch segment where)
+ t)))
+ (lambda (segment posn)
+ (let ((disp (- (label-position where) (+ posn 6))))
+ (emit-byte segment #b00001111)
+ (emit-byte segment
+ (dpb (conditional-opcode cond)
+ (byte 4 0)
+ #b10000000))
+ (emit-dword segment disp)))))
((label-p (setq where cond))
(emit-chooser
segment 5 0
- #'(lambda (segment posn delta-if-after)
- (let ((disp (- (label-position where posn delta-if-after)
- (+ posn 2))))
- (when (<= -128 disp 127)
- (emit-byte segment #b11101011)
- (emit-byte-displacement-backpatch segment where)
- t)))
- #'(lambda (segment posn)
- (let ((disp (- (label-position where) (+ posn 5))))
- (emit-byte segment #b11101001)
- (emit-dword segment disp))
- )))
+ (lambda (segment posn delta-if-after)
+ (let ((disp (- (label-position where posn delta-if-after)
+ (+ posn 2))))
+ (when (<= -128 disp 127)
+ (emit-byte segment #b11101011)
+ (emit-byte-displacement-backpatch segment where)
+ t)))
+ (lambda (segment posn)
+ (let ((disp (- (label-position where) (+ posn 5))))
+ (emit-byte segment #b11101001)
+ (emit-dword segment disp)))))
((fixup-p where)
(emit-byte segment #b11101001)
(emit-relative-fixup segment where))
(error "At least one type must be supplied for TEST-TYPE."))
(cond
(fixnump
- (when (remove-if #'(lambda (x)
- (or (= x even-fixnum-lowtag)
- (= x odd-fixnum-lowtag)))
+ (when (remove-if (lambda (x)
+ (or (= x even-fixnum-lowtag)
+ (= x odd-fixnum-lowtag)))
lowtags)
(error "can't mix fixnum testing with other lowtags"))
(when function-p
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.124"
+"0.pre7.125"
projects / sbcl.git / commitdiff