/usr/lib/gcl-2.6.10-prof/cmpnew/gcl_collectfn.lsp is in gcl 2.6.10-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;;;
;;; Copyright (c) 1989 by William Schelter,University of Texas ;;;;;
;;; All rights reserved ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; See the doc/DOC file for information on emit-fn and
;; make-all-proclaims. The basic idea is to utilize information gathered
;; by the compiler in a compile of a system of files in order to generate
;; better code on subsequent compiles of the system. To do this a file
;; sys-proclaim.lisp should be produced.
;; Additionally cross reference information about functions in the system is
;; collected.
(in-package 'compiler)
(import 'sloop::sloop)
(defstruct fn
name ;; name of THIS FUNCTION
def ;; defun, defmacro
value-type ;; If this function's body contained
;; (cond ((> a 3) 7)
;; ((> a 1) (foo)))
;; then the return type of 7 is known at compile time
;; and value-type would be fixnum. [see return-type]
fun-values ;; list of functions whose values are the values of THIS FN
;; (foo) in the previous example.
callees ;; list of all functions called by THIS FUNCTION
return-type ;; Store a return-type computed from the fun-values
;; and value-type field. This computation is done later.
arg-types ;; non optional arg types.
no-emit ;; if not nil don't emit declaration.
macros
)
(defvar *other-form* (make-fn))
(defvar *all-fns* nil)
(defvar *call-table* (make-hash-table))
(defvar *current-fn* nil)
(defun add-callee (fname)
(cond ((consp fname)
(or (eq (car fname) 'values)
(add-callee (car fname))))
((eq fname 'single-value))
(fname (pushnew fname (fn-callees (current-fn))))))
(defun add-macro-callee (fname)
(or
;; make sure the macro fname is not shadowed in the current environment.
(sloop::sloop for v in *funs*
when (and (consp v) (eq (car v) fname))
do (return t))
(pushnew fname (fn-macros (current-fn)))))
(defun clear-call-table ()
(setf *current-fn* nil)
(setq *all-fns* nil)
(setq *other-form* (make-fn :name 'other-form))
(clrhash *call-table*)
(setf (gethash 'other-form *call-table*) *other-form*)
)
(defun emit-fn (flag) (setq *record-call-info* flag))
(defun type-or (a b)
(if (eq b '*) '*
(case a
((nil) b)
((t inline) t)
((fixnum inline-fixnum fixnum-value) (if (eq b 'fixnum) 'fixnum
(type-or t b)))
(otherwise '*)
)))
(defun current-fn ()
(cond ((and (consp *current-form*)
(member (car *current-form*) '(defun defmacro))
(symbolp (second *current-form*))
(symbol-package (second *current-form*));;don't record gensym'd
)
(cond ((and *current-fn*
(equal (second *current-form*) (fn-name *current-fn*)))
*current-fn*)
(t
(unless
(setq *current-fn*
(gethash (second *current-form*) *call-table*))
(setq *current-fn* (make-fn :name (second *current-form*)
:def (car *current-form*)))
(setf (gethash (second *current-form*) *call-table*)
*current-fn*)
(setq *all-fns* (cons *current-fn* *all-fns*)))
*current-fn*)))
;; catch all for other top level forms
(t *other-form*)))
(defun who-calls (f)
(sloop for (ke val) in-table *call-table*
when (or (member f (fn-callees val))
(member f (fn-macros val)))
collect ke))
(defun add-value-type (x fn &aux (current-fn (current-fn)))
(cond (fn (pushnew fn
(fn-fun-values current-fn) :test 'equal))
(t
(setf (fn-value-type current-fn)
(type-or (fn-value-type current-fn) x)))))
(defun get-var-types (lis)
(sloop::sloop for v in lis collect (var-type v)))
(defun record-arg-info( lambda-list &aux (cf (current-fn)))
(setf (fn-arg-types cf) (get-var-types (car lambda-list)))
(when (sloop::sloop for v in (cdr lambda-list)
for w in '(&optional &rest &key
nil &allow-other-keys
)
when (and v w) do (return '*))
(setf (fn-arg-types cf) (nconc(fn-arg-types cf) (list '*)))
))
(defvar *depth* 0)
(defvar *called-from* nil)
(defun get-value-type (fname)
(cond ((member fname *called-from* :test 'eq) nil)
(t
(let ((tem (cons fname *called-from*)))
(declare (:dynamic-extent tem))
(let ((*called-from* tem))
(get-value-type1 fname))))))
(defun get-value-type1 (fname
&aux tem (*depth* (the fixnum (+ 1 (the fixnum
*depth* )))))
(cond ((> (the fixnum *depth*) 100) '*)
((setq tem (gethash fname *call-table*))
(or
(fn-return-type tem)
(sloop::sloop with typ = (fn-value-type tem)
for v in (fn-fun-values tem)
when (symbolp v)
do (setq typ (type-or typ (get-value-type v)))
else
when (and (consp v) (eq (car v) 'values))
do
(setq typ (type-or typ (if (eql (cdr v) 1) t '*)))
else do (error "unknown fun value ~a" v)
finally
;; if there is no visible return, then we can assume
;; one value.
(or typ (fn-value-type tem)
(fn-fun-values tem)
(setf typ t))
(setf (fn-return-type tem) typ)
(return typ)
)))
((get fname 'return-type))
((get fname 'proclaimed-return-type))
(t '*)))
(defun result-type-from-loc (x)
(cond ((consp x)
(case (car x)
((fixnum-value inline-fixnum) 'fixnum)
(var (var-type (second x)))
;; eventually separate out other inlines
(t (cond ((and (symbolp (car x))
(get (car x) 'wt-loc))
t)
(t (print (list 'type '* x)) '*)))))
((or (eq x t) (null x)) t)
(t (print (list 'type '*2 x)) '*)))
(defun small-all-t-p (args ret)
(and (eq ret t)
(< (length args) 10)
(sloop::sloop for v in args always (eq v t))))
;; Don't change return type but pretend all these are optional args.
(defun no-make-proclaims-hack ()
(sloop::sloop for (ke val) in-table *call-table*
do (progn ke) (setf (fn-no-emit val) 1)))
(defun make-proclaims ( &optional (st *standard-output*)
&aux (ht (make-hash-table :test 'equal))
*print-length* *print-level*
)
; (require "VLFUN"
; (concatenate 'string si::*system-directory*
; "../cmpnew/lfun_list.lsp"))
(print `(in-package ,(package-name *package*)) st)
(sloop::sloop with ret with at
for (ke val) in-table *call-table*
do
(cond ((or (eql 1 (fn-no-emit val))
(not (eq (fn-def val) 'defun))))
(t (setq ret (get-value-type ke))
(setq at (fn-arg-types val))
(push ke (gethash (list at ret) ht)))))
(sloop::sloop for (at fns) in-table ht
do
(print
`(proclaim '(ftype (function ,@ at) ,@ fns))
st)))
(defun setup-sys-proclaims()
(or (gethash 'si::call-test *call-table*)
(get 'si::call-test 'proclaimed-function)
(load (concatenate 'string si::*system-directory*
"../lsp/sys-proclaim.lisp"))
(no-make-proclaims-hack)
))
(defun make-all-proclaims (&rest files)
(setup-sys-proclaims)
(dolist (v files)
(mapcar 'load (directory v)))
(write-sys-proclaims))
(defun write-sys-proclaims ()
(with-open-file (st "sys-proclaim.lisp" :direction :output)
(make-proclaims st)))
(defvar *file-table* (make-hash-table :test 'eq))
(defun add-fn-data (lis &aux tem file)
(let ((file (and (setq file (si::fp-input-stream *standard-input*))
(truename file))))
(dolist (v lis)
(cond ((eql (fn-name v) 'other-form)
(setf (fn-name v) (intern
(concatenate 'string "OTHER-FORM-"
(namestring file))))
(setf (get (fn-name v) 'other-form) t)))
(setf (gethash (fn-name v) *call-table*) v)
(if (setq tem (gethash (fn-name v) *file-table*))
(or (equal tem file)
(format t "~% Warn ~a redefined in ~a. Originally in ~a."
(fn-name v) file tem)))
(setf (gethash (fn-name v) *file-table*)
file))))
(defun dump-fn-data (&optional (file "fn-data.lsp")
&aux (*package* (find-package "COMPILER"))
(*print-length* nil)
(*print-level* nil)
)
(with-open-file (st file :direction :output)
(format st "(in-package 'compiler)(init-fn)~%(~s '(" 'add-fn-data)
(sloop::sloop for (ke val) in-table *call-table*
do (progn ke) (print val st))
(princ "))" st)
(truename st)))
(defun record-call-info (loc fname)
(cond ((and fname (symbolp fname))
(add-callee fname)))
(cond ((eq loc 'record-call-info) (return-from record-call-info nil)))
(case *value-to-go*
(return
(if (eq loc 'fun-val)
(add-value-type nil (or fname 'unknown-values))
(add-value-type (result-type-from-loc loc) nil)))
(return-fixnum
(add-value-type 'fixnum nil))
(return-object
(add-value-type t nil))
(top (setq *top-data* (cons fname nil))
))
)
(defun list-undefined-functions (&aux undefs)
(sloop::sloop for (name fn) in-table *call-table*
declare (ignore name)
do (sloop for w in (fn-callees fn)
when (not (or (fboundp w)
(gethash w *call-table*)
(get w 'inline-always)
(get w 'inline-unsafe)
(get w 'other-form)
))
do (pushnew w undefs)))
undefs)
(dolist (v '(throw coerce single-value sort delete remove char-upcase
si::fset typep))
(si::putprop v t 'return-type))
(defun init-fn () nil)
(defun list-uncalled-functions ( )
(let* ((size (sloop::sloop for (ke v)
in-table *call-table* count t
do (progn ke v nil)))
(called (make-hash-table :test 'eq :size (+ 3 size))))
(sloop::sloop for (ke fn) in-table *call-table*
declare (ignore ke)
do (sloop::sloop for w in (fn-callees fn)
do
(setf (gethash w called) t))
(sloop::sloop for w in (fn-macros fn)
do
(setf (gethash w called) t))
)
(sloop::sloop for (ke fn) in-table *call-table*
when(and
(not (gethash ke called))
(member (fn-def fn) '(defun defmacro)
:test 'eq))
collect ke)))
;; redefine the stub in defstruct.lsp
(defun si::record-fn (name def arg-types return-type)
(if (null return-type) (setq return-type t))
(and *record-call-info*
*compiler-in-use*
(let ((fn (make-fn :name name
:def def
:return-type return-type
:arg-types arg-types)))
(push fn *all-fns*)
(setf (gethash name *call-table*) fn))))
(defun get-packages (&optional (st "sys-package.lisp") pass
&aux (si::*print-package* t))
(flet ((pr (x) (format st "~%~s" x)))
(cond ((null pass)
(with-open-file (st st :direction :output)
(get-packages st 'establish)
(get-packages st 'export)
(get-packages st 'shadow)
(format st "~2%")
(return-from get-packages nil))))
(dolist (p (list-all-packages))
(unless
(member (package-name p)
'("SLOOP"
"COMPILER" "SYSTEM" "KEYWORD" "LISP" "USER")
:test 'equal
)
(format st "~2%;;; Definitions for package ~a of type ~a"
(package-name p) pass)
(ecase pass
(establish
(let ((SYSTEM::*PRINT-PACKAGE* t))
(pr
`(in-package ,(package-name p) :use nil
,@ (if (package-nicknames p)
`(:nicknames ',(package-nicknames p)))))))
(export
(let ((SYSTEM::*PRINT-PACKAGE* t))
(pr
`(in-package ,(package-name p)
:use
'(,@
(mapcar 'package-name (package-use-list p)))
,@(if (package-nicknames p)
`(:nicknames ',(package-nicknames p))))))
(let (ext (*package* p)
imps)
(do-external-symbols (sym p) (push sym ext)
(or (eq (symbol-package sym) p)
(push sym imps)))
(pr `(import ',imps))
(pr `(export ',ext))))
(shadow
(let ((SYSTEM::*PRINT-PACKAGE* t))
(pr `(in-package ,(package-name p))))
(let (in out (*package* (find-package "LISP")))
(dolist (v (package-shadowing-symbols p))
(cond ((eq (symbol-package v) p)
(push v in))
(t (push v out))))
(pr `(shadow ',in))
(pr `(shadowing-import ',out))
(let (imp)
(do-symbols (v p)
(cond ((not (eq (symbol-package v) p))
(push v imp))))
(pr `(import ',imp))))))))))
|