96 lines (85 with data), 3.6 kB
* Routine for type propagation in function calls.
* Restore specialized function for FSET.
* Region-based computation of *VOLATILE* _after_ compiling the whole function.
* In SET-TRASH-LOC, we now consider that ALL function calls have side effects
We should be able to distinguish which ones do.
* Implement tail recursion optimization.
;;; Tail-recursion optimization for a function F is possible only if
;;; 1. F receives only required parameters, and
;;; 2. no required parameter of F is enclosed in a closure.
;;; A recursive call (F e1 ... en) may be replaced by a loop only if
;;; 1. F is not declared as NOTINLINE,
;;; 2. n is equal to the number of required parameters of F,
;;; 3. the form is a normal function call (i.e. args are not ARGS-PUSHED),
;;; 4. (F e1 ... en) is not surrounded by a form that causes dynamic
;;; binding (such as LET, LET*, PROGV),
;;; 5. (F e1 ... en) is not surrounded by a form that that pushes a frame
;;; onto the frame-stack (such as BLOCK and TAGBODY whose tags are
;;; enclosed in a closure, and CATCH),
* Only produce functions which are different from each other.
(defun new-defun (new &optional no-entry)
(unless (fun-exported new)
;; Check whether this function is similar to a previous one and
;; share code with it.
(dolist (old *global-funs*)
(when (similar (fun-lambda new) (fun-lambda old))
(cmpnote "Sharing code among functions ~A and ~A"
(fun-name new) (fun-name old))
(setf (fun-shares-with new) old
(fun-cfun new) (fun-cfun old)
(fun-minarg new) (fun-minarg old)
(fun-maxarg new) (fun-maxarg old))
(push new *global-funs*))
(defun similar (x y)
;; FIXME! This could be more accurate
(labels ((similar-ref (x y)
(and (equal (ref-ref-ccb x) (ref-ref-ccb y))
(equal (ref-ref-clb x) (ref-ref-clb y))
(equal (ref-ref x) (ref-ref y))))
(similar-var (x y)
(and (similar-ref x y)
(equal (var-name x) (var-name y))
(equal (var-kind x) (var-kind y))
(equal (var-loc x) (var-loc y))
(equal (var-type x) (var-type y))
(equal (var-index x) (var-index y))))
(similar-c1form (x y)
(and (equal (c1form-name x) (c1form-name y))
(similar (c1form-args x) (c1form-args y))
(similar (c1form-local-vars x) (c1form-local-vars y))
(eql (c1form-sp-change x) (c1form-sp-change y))
(eql (c1form-volatile x) (c1form-volatile y))))
(similar-fun (x y)
(and (similar-ref x y)
(eql (fun-global x) (fun-global y))
(eql (fun-exported x) (fun-exported y))
(eql (fun-closure x) (fun-closure y))
(similar (fun-var x) (fun-var y))
(similar (fun-lambda x) (fun-lambda y))
(= (fun-level x) (fun-level y))
(= (fun-env x) (fun-env y))
(= (fun-minarg x) (fun-minarg y))
(eql (fun-maxarg x) (fun-maxarg y))
(similar (fun-local-vars x) (fun-local-vars y))
(similar (fun-referred-vars x) (fun-referred-vars y))
(similar (fun-referred-funs x) (fun-referred-funs y))
(similar (fun-child-funs x) (fun-child-funs y)))))
(and (eql (type-of x) (type-of y))
(CONS (and (similar (car x) (car y))
(similar (cdr x) (cdr y))))
(VAR (similar-var x y))
(FUN (similar-fun x y))
(REF (similar-ref x y))
(C1FORM (similar-c1form x y))
(SEQUENCE (and (every #'similar x y)))
(T (equal x y))))))
* Better handle the type of read-only variables without the need for
* Restore handling of shared data.
* The arguments of a function, when declared to have an unboxed type, generate
inefficient CHECK-TYPE forms after that.