X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=d1170ebafe5fe6d71203e77fb3e8aa860dc36c82;hb=ba38798a5ca26b90647a1993f348806cb32f2d1b;hp=f560f9c76a111e82085291b3f0ba86f56a2484af;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index f560f9c..d1170eb 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -100,7 +100,7 @@ ;;; 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)) @@ -124,23 +124,6 @@ ,@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))))) ;;;; boolean attribute utilities ;;;; @@ -256,10 +239,10 @@ ;;; 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) @@ -403,13 +386,10 @@ ;;; 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")) @@ -448,10 +428,9 @@ ,(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)))))))) ;;;; DEFKNOWN and DEFOPTIMIZER @@ -564,8 +543,8 @@ ,(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))))))) ;;;; IR groveling macros @@ -674,7 +653,7 @@ `(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)) @@ -691,23 +670,28 @@ (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) @@ -827,10 +811,10 @@ (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) @@ -840,9 +824,9 @@ (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))