(dolist (lambda lambdas)
(setf (functional-allocator lambda) allocator)))))
-(defmacro with-fun-name-leaf ((leaf thing start) &body body)
- `(multiple-value-bind (,leaf allocate-p) (fun-name-leaf ,thing)
+(defmacro with-fun-name-leaf ((leaf thing start &key global) &body body)
+ `(multiple-value-bind (,leaf allocate-p)
+ (if ,global
+ (find-global-fun ,thing t)
+ (fun-name-leaf ,thing))
(if allocate-p
- (let ((.new-start. (make-ctran)))
- (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf))
- (let ((,start .new-start.))
- ,@body))
- (locally
- ,@body))))
+ (let ((.new-start. (make-ctran)))
+ (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf))
+ (let ((,start .new-start.))
+ ,@body))
+ (locally
+ ,@body))))
(def-ir1-translator function ((thing) start next result)
#!+sb-doc
be a lambda expression."
(with-fun-name-leaf (leaf thing start)
(reference-leaf start next result leaf)))
+
+;;; Like FUNCTION, but ignores local definitions and inline
+;;; expansions, and doesn't nag about undefined functions.
+;;; Used for optimizing things like (FUNCALL 'FOO).
+(def-ir1-translator global-function ((thing) start next result)
+ (with-fun-name-leaf (leaf thing start :global t)
+ (reference-leaf start next result leaf)))
+
+(defun constant-global-fun-name-p (thing)
+ ;; FIXME: Once we have a marginally better CONSTANTP and
+ ;; CONSTANT-VALUE we can use those instead.
+ (and (consp thing)
+ (eq 'quote (car thing))
+ (null (cddr thing))
+ (legal-fun-name-p (cadr thing))
+ t))
\f
;;;; FUNCALL
,@arg-names))))
(def-ir1-translator %funcall ((function &rest args) start next result)
- (if (and (consp function) (eq (car function) 'function))
- (with-fun-name-leaf (leaf (second function) start)
- (ir1-convert start next result `(,leaf ,@args)))
- (let ((ctran (make-ctran))
- (fun-lvar (make-lvar)))
- (ir1-convert start ctran fun-lvar `(the function ,function))
- (ir1-convert-combination-args fun-lvar ctran next result args))))
+ (cond ((and (consp function) (eq (car function) 'function))
+ (with-fun-name-leaf (leaf (second function) start)
+ (ir1-convert start next result `(,leaf ,@args))))
+ ((and (consp function) (eq (car function) 'global-function))
+ (with-fun-name-leaf (leaf (second function) start :global t)
+ (ir1-convert start next result `(,leaf ,@args))))
+ (t
+ (let ((ctran (make-ctran))
+ (fun-lvar (make-lvar)))
+ (ir1-convert start ctran fun-lvar `(the function ,function))
+ (ir1-convert-combination-args fun-lvar ctran next result args)))))
;;; This source transform exists to reduce the amount of work for the
;;; compiler. If the called function is a FUNCTION form, then convert
;;; directly to %FUNCALL, instead of waiting around for type
;;; inference.
(define-source-transform funcall (function &rest args)
- (if (and (consp function) (eq (car function) 'function))
- `(%funcall ,function ,@args)
- (values nil t)))
+ (cond ((and (consp function) (eq (car function) 'function))
+ `(%funcall ,function ,@args))
+ ((constant-global-fun-name-p function)
+ `(%funcall (global-function ,(second function)) ,@args))
+ (t
+ (values nil t))))
(deftransform %coerce-callable-to-fun ((thing) (function) *)
"optimize away possible call to FDEFINITION at runtime"
;; MV-COMBINATIONS.
(make-combination fun-lvar))))
(ir1-convert start ctran fun-lvar
- (if (and (consp fun) (eq (car fun) 'function))
- fun
- `(%coerce-callable-to-fun ,fun)))
+ (cond ((and (consp fun) (eq (car fun) 'function))
+ fun)
+ ((constant-global-fun-name-p fun)
+ `(global-function ,(second fun)))
+ (t
+ `(%coerce-callable-to-fun ,fun))))
(setf (lvar-dest fun-lvar) node)
(collect ((arg-lvars))
(let ((this-start ctran))
;;; Return a GLOBAL-VAR structure usable for referencing the global
;;; function NAME.
-(defun find-free-really-fun (name)
+(defun find-global-fun (name latep)
(unless (info :function :kind name)
(setf (info :function :kind name) :function)
(setf (info :function :where-from name) :assumed))
;; running Lisp. But at cross-compile time, the current
;; definedness of a function is irrelevant to the
;; definedness at runtime, which is what matters.
- #-sb-xc-host (not (fboundp name)))
+ #-sb-xc-host (not (fboundp name))
+ ;; LATEP is true when the user has indicated that
+ ;; late-late binding is desired by using eg. a quoted
+ ;; symbol -- in which case it makes little sense to
+ ;; complain about undefined functions.
+ (not latep))
(note-undefined-reference name :function))
(make-global-var
:kind :global-function
:%source-name name
- :type (if (or *derive-function-types*
- (eq where :declared)
- (and (member name *fun-names-in-this-file* :test #'equal)
- (not (fun-lexically-notinline-p name))))
+ :type (if (and (not latep)
+ (or *derive-function-types*
+ (eq where :declared)
+ (and (member name *fun-names-in-this-file*
+ :test #'equal)
+ (not (fun-lexically-notinline-p name)))))
(info :function :type name)
(specifier-type 'function))
:where-from where)))
:type (if (eq inlinep :notinline)
(specifier-type 'function)
(info :function :type name)))
- (find-free-really-fun name))))))))
+ (find-global-fun name nil))))))))
;;; Return the LEAF structure for the lexically apparent function
;;; definition of NAME.
(defined-fun-inline-expansion var))
(setf (defined-fun-functional res)
(defined-fun-functional var)))
+ ;; FIXME: Is this really right? Needs we not set the FUNCTIONAL
+ ;; to the original global-var?
res))
;;; Parse an inline/notinline declaration. If it's a local function we're
(setf (fill-pointer result) index)
(coerce result 'string)))))
+;;; Callign thru constant symbols
+(require :sb-introspect)
+
+(declaim (inline target-fun))
+(defun target-fun (arg0 arg1)
+ (+ arg0 arg1))
+(declaim (notinline target-fun))
+
+(defun test-target-fun-called (fun res)
+ (assert (member #'target-fun
+ (sb-introspect:find-function-callees #'caller-fun-1)))
+ (assert (equal (funcall fun) res)))
+
+(defun caller-fun-1 ()
+ (funcall 'target-fun 1 2))
+(test-target-fun-called #'caller-fun-1 3)
+
+(defun caller-fun-2 ()
+ (declare (inline target-fun))
+ (apply 'target-fun 1 '(3)))
+(test-target-fun-called #'caller-fun-2 4)
+
+(defun caller-fun-3 ()
+ (flet ((target-fun (a b)
+ (- a b)))
+ (list (funcall #'target-fun 1 4) (funcall 'target-fun 1 4))))
+(test-target-fun-called #'caller-fun-3 (list -3 5))
+
;;; success
projects / sbcl.git / commitdiff