;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Base:10 -*-

(defconstant *dynamic-functions*
	     '((1326 PRINT-FIXNUM)
	       (1342 GET-MACRO-ARG-DESC-POINTER)
                     (1375 CONSTANTP)
                     (1386 FLATSIZE-STREAM)
                     (1402 EXPLODE-STREAM)
                     (1453 COMPILER::P1ARGC)
                     (1456 (:METHOD BASIC-BUFFERED-INPUT-STREAM :UNTYI))
                     (1540 (:METHOD EQ-HASH-TABLE :GET-HASH))
                     (1544 SIMPLE-MAKE-ARRAY)
                     (1552 STRING-EQUAL)
                     (1560 COMPILER::CONTAINS-LOAD-TIME-EVAL)
                     (1634 PRINT-RAW-FIXNUM)
                     (1668 COMPILER::INCPDLLVL)
                     (1737 COMPILER::GETARGDESC)
                     (1806 CURRENT-READTABLE)
                     (1806 PRINT-OBJECT)
                     (1876 FORMAT::FORMAT-CTL-OP)
                     (1911 COMPILER::QFIND-CONSTANTS-PAGE)
                     (1938 FORMAT::FORMAT-PARSE-COMMAND)
                     (2077 COMPILER::P2-SOURCE)
                     (2176 ARRAY-ELEMENT-SIZE)
                     (2183 (:METHOD EQL-HASH-TABLE :PUT-HASH))
                     (2183 COMPILER::FASD-TABLE-ADD)
                     (2197 COMPILER::P1V)
                     (2225 COMPILER::FASD-TABLE-NEXT-INDEX)
                     (2276 %CHAOS-SHARE-CSR)
                     (2308 ARRAY-TYPE)
                     (2348 XR-OPENPAREN-MACRO)
                     (2348 XR-READ-LIST)
                     (2366 MAPCAR)
                     (2496 CURRENT-PRINT-BASE)
                     (2534 COMPILER::P2F)
                     (2638 (:METHOD TV:TYPEOUT-WINDOW :COMBINED :STRING-OUT))
                     (2745 SPECIAL-FORM-P)
                     (2907 (:METHOD TV:SHEET :STRING-OUT))
                     (2978 INVOKE-READER-MACRO)
                     (3023 TV::%DRAW-STRING)
                     (3032 SUBLIS-1)
                     (3051 MACRO-FUNCTION)
                     (3087 COMPILER::OUTS)
                     (3109 REHASH-PUT)
                     (3124 (:METHOD EQL-HASH-TABLE :GET-HASH))
                     (3177 SELF-EVALUATING-P)
                     (3234 COMPILER::FLAG-ALREADY-OPTIMIZED)
                     (3491 COMPILER::LAP-ADR-P1)
                     (3492 COMPILER::LAP-WORD-EVAL)
                     (3494 COMPILER::COMPILER-MACROEXPAND-1)
                     (3549 COMPILER::OUTI)
                     (3582 COMPILER::CHECK-NUMBER-OF-ARGS)
                     (3588 COMPILER::FASD-TABLE-LOOKUP)
                     (3588 COMPILER::FASD-CONSTANT)
                     (3754 ARGLIST)
                     (3765 COMPILER::FASD-START-GROUP)
                     (3815 (:METHOD TV:BLINKER :DEFER-REAPPEARANCE))
                     (3861 COMPILER::P2)
                     (3954 COMPILER::LAP-OUTPUT-WORD)
                     (4087 COMPILER::PEEP-ONE-SPOT)
                     (4138 XR-READ-SYMBOL)
                     (4140 INTERN)
                     (4308 TV:OPEN-BLINKER)
                     (4531 MACROEXPAND-1)
                     (4645 COMPILER::ADRREFP)
                     (4653 XR-XRUNTYI)
                     (4869 NREVERSE)
                     (4908 COMPILER::QLP2-U)
                     (4929 CURRENT-PACKAGE)
                     (5069 COMPILER::LAP-FASD-NIBBLE)
                     (5095 NRECONC)
                     (5324 (:PROPERTY MACRO-CHAR STANDARD-READ-FUNCTION))
                     (5390 COMPILER::P1)
                     (5438 COMPILER::OUTF)
                     (5483 COMPILER::QLP1)
                     (5528 COPYLIST)
                     (5588 FDEFINITION)
                     (5588 DWIMIFY-ARG-PACKAGE)
                     (5594 VALIDATE-FUNCTION-SPEC)
                     (5659 DECLARED-DEFINITION)
                     (6003 COMPILER::QLEVAL)
                     (6471 (:METHOD TV:TYPEOUT-WINDOW :COMBINED :TYO))
                     (6474 (:METHOD TV:SHEET :TYO))
                     (6474 TV::SHEET-TYO)
                     (8037 LAMBDA-MACRO-EXPAND)
                     (8285 COMPILER::FSYMEVAL-IN-FUNCTION-ENVIRONMENT)
                     (8422 (:INTERNAL COMPILER::QADD 0))
                     (9563 TV::MAYBE-MOVE-BOTTOM-REACHED)
                     (9638 COMPILER::COMPILER-OPTIMIZE)
                     (9638 COMPILER::ALREADY-OPTIMIZED-P)
                     (9981 XR-READ-THING)
                     (10072 HASH-BLOCK-POINTER)
                     (11480 TV::SHEET-CAN-GET-LOCK-INTERNAL)
                     (11493 TV:SHEET-CAN-GET-LOCK)
                     (13410 (:INTERNAL (:INTERNAL COMPILER::QADD 0) 0))
                     (13753 (:INTERNAL COMPILER::LAP-QUOTE-ADR 0))
                     (14065 FDEFINEDP)
                     (14083 FSYMEVAL-IN-ENVIRONMENT)
                     (16403 TREE-EQUAL)
                     (16969 COMPILER::FASD-NIBBLE)
                     (17591 STORE-KEYWORD-ARG-VALUES)
                     (29792 STRING)
                     (32646 FEF-DEBUGGING-INFO)
                     (33891 DEBUGGING-INFO)
                     (42980 LAMBDA-MACRO-CALL-P)
                     (43455 TREE-EQUAL-1)
                     (46559 XR-XRTYI)
                     (47138 <=)
                     (61848 BASIC-BUFFERED-INPUT-STREAM-TYI)))

(defun fef-size (fef)
  (let ((header (%p-ldb-offset %%header-rest-field fef %fefhi-ipc))
	(header-type (%p-ldb-offset %%header-type-field fef %fefhi-ipc)))
    (select header-type
      (%header-type-fef -1)
      (%header-type-fast-fef-fixed-args-no-locals
       (ldb %%fefh-args-for-fanl header))
      (%header-type-fast-fef-var-args-no-locals
       (ldb %%fefh-max-args-for-vanl header))
      (%header-type-fast-fef-fixed-args-with-locals
       (+ (%p-ldb-offset %%fefh-args-for-fawl fef %fefhi-ipc)	   ;cdr-code
	  (ldb %%fefh-locals-for-fawl header)))
      (%header-type-fast-fef-var-args-with-locals
			 (+ (ldb %%fefh-max-args-for-vawl header)
			 (ldb %%fefh-locals-for-vawl header))))))

(defun new-fef-size (fef)
  (let ((info (args-info fef)))
    (+ (ldb %%arg-desc-max-args info)
       (%p-ldb-offset %%fefhi-ms-local-block-length fef %fefhi-misc))))

(defun new-fef-size (fef)
  (let ((n-locals 0))
    (dolist (local (cadr (assq 'compiler:local-map (debugging-info fef))))
      (when local
	(incf n-locals)))
    (+ n-locals (ldb %%arg-desc-max-args (args-info fef)))))

(defun count-slow-fefs (&aux (x 0))
  (dolist (fef *fef-list*)
    (when (= (%p-ldb %%header-type-field fef) %header-type-fef)
      (incf x)))
  x)

(defvar *size-alist* nil)

(defun find-fef-sizes ()
  (dolist (fef *fef-list*)
    (let ((size (new-fef-size fef)))
      (unless (= size -1)
	(push (list size fef) *size-alist*)))))
       

(defvar *size-array* (make-array 256. :initial-element 0))

(defun scan-fef-sizes ()
  (fillarray *size-array*)
  (dolist (size-record *size-alist*)
    (incf (aref *size-array* (first size-record)))))

(defvar *losing-fefs* nil)

(defun find-losing-fefs ()
  (dolist (fef *size-alist*)
    (when (> (first fef) 10.)
      (push (list (first fef) (function-name (second fef))) *losing-fefs*))))

(defun scan-used-fefs ()
  (array-initialize *size-array* 0)
  (dolist (f *dynamic-functions*)
    (incf (aref *size-array* (second (assoc (second f) *alist-size*))) (first f))))

;;; Stuff to check pdl depth and tail recursion.
(defun map-across-stack-frames (sg function)
  (do ((frame (eh:sg-innermost-active sg) (