;;; If the desirability of the transformation depends on the current
;;; OPTIMIZE parameters, then the POLICY macro should be used to
;;; determine when to pass.
-(defmacro def-source-transform (name lambda-list &body body)
+(defmacro define-source-transform (name lambda-list &body body)
(let ((fn-name
(if (listp name)
(collect ((pieces))
,@decls
,body))
(setf (info :function :source-transform ',name) #',fn-name)))))
-
-;;; Define a function that converts a use of (%PRIMITIVE NAME ..)
-;;; into Lisp code. LAMBDA-LIST is a DEFMACRO-style lambda list.
-(defmacro def-primitive-translator (name lambda-list &body body)
- (let ((fn-name (symbolicate "PRIMITIVE-TRANSLATE-" name))
- (n-form (gensym))
- (n-env (gensym)))
- (multiple-value-bind (body decls)
- (parse-defmacro lambda-list n-form body name "%primitive"
- :environment n-env
- :error-fun 'convert-condition-into-compiler-error)
- `(progn
- (defun ,fn-name (,n-form)
- (let ((,n-env *lexenv*))
- ,@decls
- ,body))
- (setf (gethash ',name *primitive-translators*) ',fn-name)))))
\f
;;;; boolean attribute utilities
;;;;
;;; 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)
;;; which means efficiency notes will be generated when this
;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if
;;; INHIBIT-WARNINGS>SPEED).
-;;; :WHEN {:NATIVE | :BYTE | :BOTH}
-;;; - Indicates whether this transform applies to native code,
-;;; byte-code or both (default :native.)
(defmacro deftransform (name (lambda-list &optional (arg-types '*)
(result-type '*)
&key result policy node defun-only
- eval-name important (when :native))
+ eval-name important)
&body body-decls-doc)
(when (and eval-name defun-only)
(error "can't specify both DEFUN-ONLY and EVAL-NAME"))
,(if eval-name
``(function ,,arg-types ,,result-type)
`'(function ,arg-types ,result-type))
- #'(lambda ,@stuff)
+ (lambda ,@stuff)
,doc
- ,(if important t nil)
- ,when)))))))
+ ,(if important t nil))))))))
\f
;;;; DEFKNOWN and DEFOPTIMIZER
,(parse-deftransform lambda-list body n-args
`(return-from ,name nil))))
,@(when (consp what)
- `((setf (,(symbolicate "FUNCTION-INFO-" (second what))
- (function-info-or-lose ',(first what)))
+ `((setf (,(symbolicate "FUN-INFO-" (second what))
+ (fun-info-or-lose ',(first what)))
#',name)))))))
\f
;;;; IR groveling macros
`(eq ,node-var (block-last ,n-block))
`(eq ,cont-var ,n-last-cont))
(return nil))))))
-;;; like Do-Nodes, only iterating in reverse order
+;;; like DO-NODES, only iterating in reverse order
(defmacro do-nodes-backwards ((node-var cont-var block) &body body)
(let ((n-block (gensym))
(n-start (gensym))
(when (eq ,n-next ,n-start)
(return nil))))))
-;;; Bind the IR1 context variables so that IR1 conversion can be done
-;;; after the main conversion pass has finished.
-;;;
-;;; The lexical environment is presumably already null...
-(defmacro with-ir1-environment (node &rest forms)
- (let ((n-node (gensym)))
- `(let* ((,n-node ,node)
- (*current-component* (block-component (node-block ,n-node)))
- (*lexenv* (node-lexenv ,n-node))
- (*current-path* (node-source-path ,n-node)))
- ,@forms)))
+;;; Bind the IR1 context variables to the values associated with NODE,
+;;; so that new, extra IR1 conversion related to NODE can be done
+;;; after the original conversion pass has finished.
+(defmacro with-ir1-environment-from-node (node &rest forms)
+ `(flet ((closure-needing-ir1-environment-from-node ()
+ ,@forms))
+ (%with-ir1-environment-from-node
+ ,node
+ #'closure-needing-ir1-environment-from-node)))
+(defun %with-ir1-environment-from-node (node fun)
+ (declare (type node node) (type function fun))
+ (let ((*current-component* (node-component node))
+ (*lexenv* (node-lexenv node))
+ (*current-path* (node-source-path node)))
+ (aver-live-component *current-component*)
+ (funcall fun)))
;;; Bind the hashtables used for keeping track of global variables,
-;;; functions, &c. Also establish condition handlers.
+;;; functions, etc. Also establish condition handlers.
(defmacro with-ir1-namespace (&body forms)
- `(let ((*free-variables* (make-hash-table :test 'eq))
- (*free-functions* (make-hash-table :test 'equal))
+ `(let ((*free-vars* (make-hash-table :test 'eq))
+ (*free-funs* (make-hash-table :test 'equal))
(*constants* (make-hash-table :test 'equal))
(*source-paths* (make-hash-table :test 'eq)))
(handler-bind ((compiler-error #'compiler-error-handler)
(defstruct (event-info (:copier nil))
;; The name of this event.
- (name (required-argument) :type symbol)
+ (name (missing-arg) :type symbol)
;; The string rescribing this event.
- (description (required-argument) :type string)
+ (description (missing-arg) :type string)
;; The name of the variable we stash this in.
- (var (required-argument) :type symbol)
+ (var (missing-arg) :type symbol)
;; The number of times this event has happened.
(count 0 :type fixnum)
;; The level of significance of this event.
- (level (required-argument) :type unsigned-byte)
+ (level (missing-arg) :type unsigned-byte)
;; If true, a function that gets called with the node that the event
;; happened to.
(action nil :type (or function null)))
(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