[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Gcl-devel] Re: Profiling Lisp Code with GPROF under GGL
|
From: |
Camm Maguire |
|
Subject: |
[Gcl-devel] Re: Profiling Lisp Code with GPROF under GGL |
|
Date: |
20 Jul 2004 16:15:28 -0400 |
|
User-agent: |
Gnus/5.09 (Gnus v5.9.0) Emacs/21.2 |
Greetings! I had a feeling there would be a need for this soon. This
functionality was provided for in a compiler patch I worked up a few
months ago and was intending to commit to the unstable branch, as it
was too much for stable IMHO.
Matt Kaufmann had also mentioned how default gprof support with an
easy interface would be very desirable.
In case you would like to test it out, I've applied the patch and
built a new 2.6.4pre at your site. I'm also including the patch below
for those who might be interested on the devel list. I don't know of
anything that this breaks, but it may not be in an acceptable final
form nonetheless. Just to reiterate a previous remark -- I'm just
calling this 2.6.4pre for convenience -- I am not sure that this
justifies an official 2.6.4pre. The SGC memory allocation change
(also now slightly modified in your build) might come closer to doing
so.
This whole issue is quite broad as far as GCL is concerned, as it
pertains to the linker. GCL partially implements its own runtime
incremental linker which is used to load compiled objects into an
interactive session. Thus far, no profiling nor debugging
information, each kept in their own linker sections, are processed by
GCL's fasload. To get a user's compiled functions into the profiling
database used by gprof, therefore, one must currently build a new
image using (compiler::link...), which is basically a lisp interface
to ld.
The first argument to compiler::link is a list of namestrings to the
user's compiled objects. The second argument a namestring of the new
image. There are other optional arguments as described in the
documentation. If one has a complex load sequence in building an
application, one can generate the user object list semi-automatically
by making use of the special variables si::*collect-binary-modules*
and si::*binary-modules*. When the former is set to non-nil, the
latter will accumulate the load list in the proper order. We put this
in to facilitate the axiom build on 5 of the 12 Debian architectures
on which we have no native object relocation at all. It is not
documented as yet, as it is hopefully a temporary hack pending better
support in fasload.
A few other remarks:
1) gprof support no longer entails extra memory consumption, as our
default hole is big enough to handle the initial malloc called by
monstartup when any raw image is first executed. So perhaps it
should be on by default. This will no doubt raise portability
issues.
2) The images cannot be stripped, which means an extra meg or so.
3) There may be performance consequences to the -pg gcc switch.
4) Once you've made your new image, bracket whatever you'd like to
profile between (si::gprof-start) and (si::gprof-quit). The former
can also profile a subset of the memory in use.
5) What remains to make this a 'GCL killer app' is to find a way to
destructively merge in new profiler information on fasload.
Aurelien hopefully will have some ideas here, as he makes his own
linker section at runtime (I think).
Take care,
=============================================================================
diff -ru gcl-2.6.3.ori/cmpnew/gcl_cmpcall.lsp gcl-2.6.3/cmpnew/gcl_cmpcall.lsp
--- gcl-2.6.3.ori/cmpnew/gcl_cmpcall.lsp 2003-09-14 02:30:33.000000000
+0000
+++ gcl-2.6.3/cmpnew/gcl_cmpcall.lsp 2004-07-20 18:31:41.000000000 +0000
@@ -311,7 +311,7 @@
;;; Call to a function defined in the same file.
((setq fd (assoc fname *global-funs*))
(push-args args)
- (wt-nl "L" (cdr fd) "();")
+ (wt-nl (compiled-function-name "L" (cdr fd) fname) "();")
(unwind-exit 'fun-val nil fname)
)
((eql fname 'funcall-c)
Only in gcl-2.6.3/cmpnew: gcl_cmpcall.lsp~
diff -ru gcl-2.6.3.ori/cmpnew/gcl_cmpflet.lsp gcl-2.6.3/cmpnew/gcl_cmpflet.lsp
--- gcl-2.6.3.ori/cmpnew/gcl_cmpflet.lsp 2003-12-01 01:48:07.000000000
+0000
+++ gcl-2.6.3/cmpnew/gcl_cmpflet.lsp 2004-07-20 14:44:12.000000000 +0000
@@ -163,7 +163,7 @@
(setf (fun-ref fun) (vs-push))
(wt-nl)
(wt-vs (fun-ref fun))
- (wt "=make_cclosure_new(LC" (fun-cfun fun) ",Cnil,") (wt-clink)
+ (wt "=make_cclosure_new(" (compiled-function-name "LC" (fun-cfun fun)
(fun-name fun)) ",Cnil,") (wt-clink)
(wt ",Cdata);")
(wt-nl)
(wt-vs (fun-ref fun))
@@ -297,7 +297,7 @@
(push (car def) *closures*)
(wt-nl)
(wt-vs* (fun-ref (car def)))
- (wt "=make_cclosure_new(LC" (fun-cfun (car def)) ",Cnil,") (wt-clink)
+ (wt "=make_cclosure_new(" (compiled-function-name "LC" (fun-cfun (car
def)) (fun-name (car def))) ",Cnil,") (wt-clink)
(wt ",Cdata);")
)
@@ -393,7 +393,7 @@
(cmpnote "Tail-recursive call of ~s was replaced by iteration."
(fun-name (car fd))))
(t (push-args args)
- (wt-nl "L" (fun-cfun (car fd)) "(")
+ (wt-nl (compiled-function-name "L" (fun-cfun (car fd)) (fun-name (car
fd))) "(")
(dotimes** (n (fun-level (car fd))) (wt "base" n ","))
(wt "base")
(unless (= (fun-level (car fd)) *level*) (wt (fun-level (car fd))))
diff -ru gcl-2.6.3.ori/cmpnew/gcl_cmpspecial.lsp
gcl-2.6.3/cmpnew/gcl_cmpspecial.lsp
--- gcl-2.6.3.ori/cmpnew/gcl_cmpspecial.lsp 2003-09-14 02:30:33.000000000
+0000
+++ gcl-2.6.3/cmpnew/gcl_cmpspecial.lsp 2004-07-20 14:44:12.000000000 +0000
@@ -128,11 +128,11 @@
*local-funs*)
(push fun *closures*)
(cond (*clink*
- (unwind-exit (list 'make-cclosure (fun-cfun fun) *clink*)))
+ (unwind-exit (list 'make-cclosure (fun-cfun fun) *clink*
(fun-name fun))))
(t (push-data-incf nil)
(add-init `(si::setvv ,*next-vv*
- (si::mc nil ,(add-address "&LC"
-
(fun-cfun fun))))
+ (si::mc nil ,(add-address
+
(compiled-function-name "&LC" (fun-cfun fun) (fun-name fun)))))
t)
(unwind-exit (list 'vv *next-vv*)))))
))
@@ -146,8 +146,8 @@
(wt "symbol_function(VV[" vv "])")
(wt "(VV[" vv "]->s.s_gfdef)")))
-(defun wt-make-cclosure (cfun clink)
- (wt-nl "make_cclosure_new(LC" cfun ",Cnil,")
+(defun wt-make-cclosure (cfun clink fname)
+ (wt-nl "make_cclosure_new(" (compiled-function-name "LC" cfun fname)
",Cnil,")
(wt-clink clink)
(wt ",Cdata)"))
diff -ru gcl-2.6.3.ori/cmpnew/gcl_cmptop.lsp gcl-2.6.3/cmpnew/gcl_cmptop.lsp
--- gcl-2.6.3.ori/cmpnew/gcl_cmptop.lsp 2004-03-20 17:31:14.000000000 +0000
+++ gcl-2.6.3/cmpnew/gcl_cmptop.lsp 2004-07-20 18:37:45.000000000 +0000
@@ -179,7 +179,36 @@
`(let* ,usual ,@body)))
)
-
+(defun dash-to-underscore-int (str beg end)
+ (declare (string str) (fixnum beg end))
+ (unless (< beg end)
+ (return-from dash-to-underscore-int str))
+ (case (aref str beg)
+ ((the character #\-)
+ (setf (aref str beg) (the character #\_)))
+ ((the character #\/)
+ (setf (aref str beg) (the character #\_)))
+ ((the character #\.)
+ (setf (aref str beg) (the character #\_)))
+ ((the character #\!)
+ (setf (aref str beg) (the character #\E)))
+ ((the character #\*)
+ (setf (aref str beg) (the character #\A))))
+ (when (and (not (eql (the character #\_) (aref str beg))) (not
(alphanumericp (aref str beg))))
+ (setf (aref str beg) (the character #\$)))
+ (dash-to-underscore-int str (1+ beg) end))
+
+(defun dash-to-underscore (str)
+ (declare (string str))
+ (let ((new (copy-seq str)))
+ (dash-to-underscore-int new 0 (length new))))
+
+(defun compiled-function-name (prefix num fname)
+ (let ((fname (if (symbolp fname) (symbol-name fname))))
+ (if *compiler-input*
+ (format nil "~a~a__~a__~a" prefix num (dash-to-underscore fname)
+ (dash-to-underscore (namestring *compiler-input*)))
+ (format nil "~a~a__~a__anon" prefix num (dash-to-underscore fname)))))
(defun t1expr (form &aux (*current-form* form) (*first-error* t))
(catch *cmperr-tag*
@@ -286,7 +315,7 @@
(wt-nl1 "}"))
;;; Declarations in h-file.
- (dolist* (fun *closures*) (wt-h "static void LC" (fun-cfun fun) "();"))
+ (dolist* (fun *closures*) (wt-h "static void " (compiled-function-name "LC"
(fun-cfun fun) (fun-name fun)) "();"))
(dolist* (x *reservations*)
(wt-h "#define VM" (car x) " " (cdr x)))
@@ -311,7 +340,7 @@
(or *vaddress-list* (wt-h 0))
(do ((v (nreverse *Vaddress-List*) (cdr v)))
((null v) (wt-h "};"))
- (wt-h "(char *)(" (caar v) (cadar v) (if (cdr v) ")," ")")))
+ (wt-h "(char *)(" (caar v) (if (cdr v) ")," ")")))
(wt-h "#define VV ((object *)VVi)")
@@ -480,7 +509,7 @@
(get fname 'proclaimed-return-type)
(flags set ans)
(make-inline-string
- cfun (get fname 'proclaimed-arg-types)))
+ cfun (get fname 'proclaimed-arg-types) fname))
*inline-functions*))
((and ;(get fname 'proclaimed-function)
(eq (get fname 'proclaimed-return-type) t))
@@ -503,12 +532,12 @@
)))
-(defun make-inline-string (cfun args)
+(defun make-inline-string (cfun args fname)
(if (null args)
- (format nil "LI~d()" cfun)
+ (format nil (compiled-function-name "LI" cfun fname) "()")
(let ((o (make-array 100 :element-type 'string-char :fill-pointer 0
:adjustable t )))
- (format o "LI~d(" cfun)
+ (format o (compiled-function-name "LI" cfun fname ) "(")
(do ((l args (cdr l))
(n 0 (1+ n)))
((endp (cdr l))
@@ -549,10 +578,10 @@
(setq type (f-type (pop args))))))
-(defun wt-if-proclaimed (fname cfun lambda-expr)
+(defun wt-if-proclaimed (fname cfun lambda-expr)
(cond ((fast-link-proclaimed-type-p fname)
(cond ((assoc fname *inline-functions*)
- (add-init `(si::mfsfun ',fname ,(add-address "LI" cfun)
+ (add-init `(si::mfsfun ',fname ,(add-address
(compiled-function-name "LI" cfun fname))
,(proclaimed-argd (get fname
'proclaimed-arg-types)
(get fname
'proclaimed-return-type)
) )
@@ -616,10 +645,10 @@
-(defun add-address (a b)
+(defun add-address (a)
;; if need ampersand before function for address
;; (setq a (string-concatenate "&" a))
- (push (list a b) *vaddress-list*)
+ (push (list a) *vaddress-list*)
(prog1 *vind* (incf *vind*)))
(defun t2defun (fname cfun lambda-expr doc sp)
@@ -634,20 +663,20 @@
; (wt-h "static object LI" cfun "();")
(if keyp
(add-init `(si::mfvfun-key
- ',fname ,(add-address "LI" cfun)
+ ',fname ,(add-address (compiled-function-name "LI" cfun
fname))
,(vargd (length (car (lambda-list lambda-expr)))
(maxargs (lambda-list lambda-expr)))
- ,(add-address (format nil "&LI~akey" cfun) ""))
+ ,(add-address (format nil "&LI~akey" cfun)))
)
- (add-init `(si::mfvfun ',fname ,(add-address "LI" cfun)
+ (add-init `(si::mfvfun ',fname ,(add-address
(compiled-function-name "LI" cfun fname))
,(vargd (length (car (lambda-list lambda-expr)))
(maxargs (lambda-list lambda-expr))))
))))
((numberp cfun)
- (wt-h "static void L" cfun "();")
- (add-init `(si::mf ',fname ,(add-address "L" cfun)) ))
+ (wt-h "static void " (compiled-function-name "L" cfun fname) "();")
+ (add-init `(si::mf ',fname ,(add-address (compiled-function-name "L"
cfun fname))) ))
(t (wt-h cfun "();")
- (add-init `(si::mf ',fname ,(add-address "" cfun )) )))
+ (add-init `(si::mf ',fname ,(add-address (compiled-function-name ""
cfun fname) )) )))
(cond ((< *space* 2)
(setf (get fname 'debug-prop) t)
@@ -719,8 +748,8 @@
)
(setf (var-loc (car vl)) (next-cvar)))
(wt-comment "local entry for function " fname)
- (wt-h "static " (declaration-type (rep-type (caddr inline-info)))
"LI" cfun "();")
- (wt-nl1 "static " (declaration-type (rep-type (caddr inline-info)))
"LI" cfun "(")
+ (wt-h "static " (declaration-type (rep-type (caddr inline-info)))
(compiled-function-name "LI" cfun fname) "();")
+ (wt-nl1 "static " (declaration-type (rep-type (caddr inline-info)))
(compiled-function-name "LI" cfun fname) "(")
(wt-requireds requireds
(cadr inline-info))
;;; Now the body.
@@ -778,7 +807,7 @@
(wt-comment "local entry for function " fname)
(let ((tmp ""))
- (wt-nl1 "static object LI" cfun "(")
+ (wt-nl1 "static object " (compiled-function-name "LI" cfun fname) "(")
(when reqs
(do ((v reqs (cdr v)))
((null v))
@@ -793,7 +822,7 @@
(wt "object first,...")
(setq tmp (concatenate 'string tmp "object,...")))
(wt ")")
- (wt-h "static object LI" cfun "(" tmp ");"))
+ (wt-h "static object " (compiled-function-name "LI" cfun fname) "(" tmp
");"))
; (when reqs (wt-nl "object ")
@@ -993,7 +1022,7 @@
(wt "static struct { short n,allow_other_keys;"
"object *defaults;")
(wt-nl " KEYTYPE keys[" (max n 1) "];")
- (wt "} LI"cfun "key=")
+ (wt "} " "LI" cfun "key=")
(wt "{" (length (ll-keywords ll)) ","
(if (ll-allow-other-keys ll) 1 0)
@@ -1072,7 +1101,7 @@
(defun t3defun-normal (fname cfun lambda-expr sp)
(wt-comment "function definition for " fname)
(if (numberp cfun)
- (wt-nl1 "static void L" cfun "()")
+ (wt-nl1 "static void " (compiled-function-name "L" cfun fname)
"()")
(wt-nl1 cfun "()"))
(wt-nl1 "{" "register object *" *volatile*"base=vs_base;")
(assign-down-vars (cadr lambda-expr) cfun
@@ -1227,7 +1256,7 @@
(defun wt-global-entry (fname cfun arg-types return-type)
(cond ((get fname 'no-global-entry)(return-from wt-global-entry nil)))
(wt-comment "global entry for the function " fname)
- (wt-nl1 "static void L" cfun "()")
+ (wt-nl1 "static void " (compiled-function-name "L" cfun fname) "()")
(wt-nl1 "{ register object *base=vs_base;")
(when (or *safe-compile* *compiler-check-args*)
(wt-nl "check_arg(" (length arg-types) ");"))
@@ -1239,7 +1268,7 @@
(long-float "make_longfloat")
(short-float "make_shortfloat")
(otherwise ""))
- "(LI" cfun "(")
+ "(" (compiled-function-name "LI" cfun fname) "(")
(do ((types arg-types (cdr types))
(n 0 (1+ n)))
((endp types))
@@ -1293,8 +1322,8 @@
(when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation)
))
(when ppn
(add-init `(si::putprop ',fname ',ppn 'si::pretty-print-format) ))
- (wt-h "static void L" cfun "();")
- (add-init `(si::MM ',fname ,(add-address "L" cfun)) )
+ (wt-h "static void " (compiled-function-name "L" cfun fname) "();")
+ (add-init `(si::MM ',fname ,(add-address (compiled-function-name "L" cfun
fname))) )
)
(defun t3defmacro (fname cfun macro-lambda doc ppn sp
@@ -1304,7 +1333,7 @@
(let-pass3
((*exit* 'return))
(wt-comment "macro definition for " fname)
- (wt-nl1 "static void L" cfun "()")
+ (wt-nl1 "static void " (compiled-function-name "L" cfun fname) "()")
(wt-nl1 "{register object *" *volatile* "base=vs_base;")
(assign-down-vars (nth 4 macro-lambda) cfun ;*dm-info*
't3defun)
@@ -1474,9 +1503,9 @@
(cond ((setq fd (assoc (caar s) *global-funs*))
(cond (*compiler-push-events*
(wt-nl1 "ihs_push(VV[" (add-symbol (caar s)) "]);")
- (wt-nl1 "L" (cdr fd) "();")
+ (wt-nl1 (compiled-function-name "L" (cdr fd) (caar
s)) "();")
(wt-nl1 "ihs_pop();"))
- (t (wt-nl1 "L" (cdr fd) "();"))))
+ (t (wt-nl1 (compiled-function-name "L" (cdr fd)
(caar s)) "();"))))
(*compiler-push-events*
(wt-nl1 "super_funcall(VV[" (add-symbol (caar s)) "]);"))
(*safe-compile*
@@ -1543,13 +1572,13 @@
(defun t2defentry (fname cfun arg-types type cname)
(declare (ignore arg-types type cname))
- (wt-h "static void L" cfun "();")
- (add-init `(si::mf ',fname ,(add-address "L" cfun)) )
+ (wt-h "static void " (compiled-function-name "L" cfun fname) "();")
+ (add-init `(si::mf ',fname ,(add-address (compiled-function-name "L" cfun
fname))) )
)
(defun t3defentry (fname cfun arg-types type cname)
(wt-comment "function definition for " fname)
- (wt-nl1 "static void L" cfun "()")
+ (wt-nl1 "static void " (compiled-function-name "L" cfun fname) "()")
(wt-nl1 "{ object *old_base=vs_base;")
(case type
(void)
@@ -1624,7 +1653,7 @@
*downward-closures*
(requireds (caaddr lambda-expr)))
(wt-comment "local dc function " (if (fun-name fun) (fun-name fun) nil))
- (wt-nl1 "static void " (if closure-p "LC" "L") (fun-cfun fun) "(")
+ (wt-nl1 "static void " (compiled-function-name (if closure-p "LC" "L")
(fun-cfun fun) (fun-name fun)) "(")
(wt "base0" (if requireds "," ""))
(analyze-regs (cadr lambda-expr) 2)
(wt-requireds (caaddr lambda-expr) nil) ;;nil = arg types all t
@@ -1667,8 +1696,8 @@
(return-from t3local-fun
(t3local-dcfun closure-p clink ccb-vs fun lambda-expr
initial-ccb-vs)))
(wt-comment "local function " (if (fun-name fun) (fun-name fun) nil))
- (wt-h "static void " (if closure-p "LC" "L") (fun-cfun fun) "();")
- (wt-nl1 "static void " (if closure-p "LC" "L") (fun-cfun fun) "(")
+ (wt-h "static void " (compiled-function-name (if closure-p "LC" "L")
(fun-cfun fun) (fun-name fun)) "();")
+ (wt-nl1 "static void " (compiled-function-name (if closure-p "LC" "L")
(fun-cfun fun) (fun-name fun)) "(")
(dotimes* (n level (wt "base" n ")")) (wt "base" n ","))
(wt-nl1 "register object ")
(dotimes* (n level (wt "*"*volatile*"base" n ";"))
diff -ru gcl-2.6.3.ori/cmpnew/sys-proclaim.lisp
gcl-2.6.3/cmpnew/sys-proclaim.lisp
--- gcl-2.6.3.ori/cmpnew/sys-proclaim.lisp 2004-03-20 17:31:17.000000000
+0000
+++ gcl-2.6.3/cmpnew/sys-proclaim.lisp 2004-07-20 14:30:29.000000000 +0000
@@ -1,6 +1,8 @@
(IN-PACKAGE "COMPILER")
-
+(PROCLAIM '(FTYPE (FUNCTION (T FIXNUM FIXNUM) T) DASH-TO-UNDERSCORE-INT))
+(PROCLAIM '(FTYPE (FUNCTION (T) T) DASH-TO-UNDERSCORE))
+(PROCLAIM '(FTYPE (FUNCTION (T T T) T) COMPILED-FUNCTION-NAME))
(PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM) T) MLIN))
(PROCLAIM '(FTYPE (FUNCTION (T) T) COPY-ARRAY COPY-INFO))
(PROCLAIM '(FTYPE (FUNCTION (T T FIXNUM T) FIXNUM) PUSH-ARRAY))
@@ -17,7 +19,7 @@
C2APPLY-OPTIMIZE C2DM))
(PROCLAIM '(FTYPE (FUNCTION (T T *) *) T3DEFUN-AUX))
(PROCLAIM
- '(FTYPE (FUNCTION (T T T) T) CJT BOOLE3 WT-INLINE-COND
+ '(FTYPE (FUNCTION (T T T) T) WT-MAKE-CCLOSURE MAKE-INLINE-STRING CJT
BOOLE3 WT-INLINE-COND
WT-INLINE-FIXNUM WT-INLINE-INTEGER WT-INLINE-CHARACTER
WT-INLINE-LONG-FLOAT WT-INLINE-SHORT-FLOAT C1MAP-FUNCTIONS
C2MAPCAR C2MAPC C2MAPCAN FIX-DOWN-ARGS C2PROGV
@@ -63,7 +65,7 @@
WT-FIXNUM-LOC WT-CHARACTER-LOC WT-LONG-FLOAT-LOC
WT-SHORT-FLOAT-LOC))
(PROCLAIM
- '(FTYPE (FUNCTION (T) T) VAR-REP-LOC WT-VV WT-CAR WT-CDR DECLARATION-TYPE
+ '(FTYPE (FUNCTION (T) T) ADD-ADDRESS VAR-REP-LOC WT-VV WT-CAR WT-CDR
DECLARATION-TYPE
WT-CADR ADD-OBJECT VOLATILE C2BIND WT-VS-BASE C2FUNCALL-AUX
INFO-P C1FUNOB VAR-NAME VAR-REF WT-FUNCTION-LINK
VAR-REF-CCB WT-FUNCALL-C VAR-LOC VAR-TYPE SAVE-FUNOB
@@ -133,7 +135,7 @@
SHIFT>> SHIFT<< COMPILER-CLEAR-COMPILER-PROPERTIES
MAYBE-EVAL PUSH-CHANGED-VARS SET-JUMP-TRUE C2BLOCK-CCB
C2DM-BIND-VL C1CONSTANT-VALUE C2BLOCK-CLB CMPFIX-ARGS
- C1LAMBDA-FUN MAKE-INLINE-STRING CO1CONSTANT-FOLD
+ C1LAMBDA-FUN CO1CONSTANT-FOLD
C2LAMBDA-EXPR-WITH-KEY C1ARGS MULTIPLE-VALUE-CHECK
C2LAMBDA-EXPR-WITHOUT-KEY C2CATCH C2EXPR-TOP C1EXPR*
C2UNWIND-PROTECT C2RETURN-CCB ADD-DEBUG-INFO
@@ -141,8 +143,8 @@
C2MULTIPLE-VALUE-PROG1 WT-REQUIREDS C2DM-BIND-LOC C1FMLA
C2DM-BIND-INIT FAST-READ WT-V*-MACROS CFAST-WRITE
C2MULTIPLE-VALUE-SETQ WT-MAKE-DCLOSURE C2APPLY C2EXPR-TOP*
- C1PROGN* COMPILER-DEF-HOOK ADD-ADDRESS C2MEMBER!2
- T2SHARP-COMMA C2ASSOC!2 SYSTEM::ADD-DEBUG WT-MAKE-CCLOSURE
+ C1PROGN* COMPILER-DEF-HOOK C2MEMBER!2
+ T2SHARP-COMMA C2ASSOC!2 SYSTEM::ADD-DEBUG
C2LIST-NTH-IMMEDIATE SET-DBIND CONVERT-CASE-TO-SWITCH
PROCLAIM-VAR CO1LDB CO1EQL COERCE-LOC
ARGS-INFO-CHANGED-VARS CO1TYPEP JUMPS-TO-P CO1SCHAR CO1CONS
diff -ru gcl-2.6.3.ori/configure gcl-2.6.3/configure
--- gcl-2.6.3.ori/configure 2004-07-15 16:27:19.000000000 +0000
+++ gcl-2.6.3/configure 2004-07-20 18:47:28.000000000 +0000
@@ -1084,7 +1084,7 @@
enableval="$enable_gprof"
:
else
- enable_gprof="no"
+ enable_gprof="yes"
fi
# Check whether --enable-static or --disable-static was given.
diff -ru gcl-2.6.3.ori/configure.in gcl-2.6.3/configure.in
--- gcl-2.6.3.ori/configure.in 2004-07-15 16:27:09.000000000 +0000
+++ gcl-2.6.3/configure.in 2004-07-20 18:47:04.000000000 +0000
@@ -310,7 +310,7 @@
,,enable_debug="$def_debug")
AC_ARG_ENABLE(gprof,
[ --enable-gprof builds gcl with -pg in CFLAGS to enable profiling with
gprof ]
- ,,enable_gprof="no")
+ ,,enable_gprof="yes")
AC_ARG_ENABLE(static,[ --enable-static will link your GCL against static as
opposed to shared system libraries ] ,
[enable_static=$enableval],[enable_static="$def_static"])
AC_ARG_ENABLE(pic,
Only in gcl-2.6.3: configure.in~
diff -ru gcl-2.6.3.ori/h/att_ext.h gcl-2.6.3/h/att_ext.h
--- gcl-2.6.3.ori/h/att_ext.h 2003-11-06 16:16:49.000000000 +0000
+++ gcl-2.6.3/h/att_ext.h 2004-07-20 17:27:22.000000000 +0000
@@ -287,7 +287,7 @@
EXTER char *kcl_self;
#endif
#if !defined(IN_MAIN) || !defined(ATT)
-EXTER bool initflag;
+EXTER bool initflag,raw_image;
#endif
char *merge_system_directory();
diff -ru gcl-2.6.3.ori/h/object.h gcl-2.6.3/h/object.h
--- gcl-2.6.3.ori/h/object.h 2004-05-03 16:53:58.000000000 +0000
+++ gcl-2.6.3/h/object.h 2004-07-16 19:41:54.000000000 +0000
@@ -761,6 +761,7 @@
short tm_percent_free; /* percent which must be free after a gc for
this type */
short tm_distinct; /* pages of this type are distinct */
float tm_adjgbccnt;
+ long tm_opt_maxpage;
};
diff -ru gcl-2.6.3.ori/h/protoize.h gcl-2.6.3/h/protoize.h
--- gcl-2.6.3.ori/h/protoize.h 2004-05-26 02:03:03.000000000 +0000
+++ gcl-2.6.3/h/protoize.h 2004-07-20 14:30:29.000000000 +0000
@@ -1783,3 +1783,8 @@
int sigismember ( sigset_t *set, int n );
int sigprocmask ( int how, const sigset_t *set, sigset_t *oldset );
#endif
+
+#ifdef GCL_GPROF
+void
+gprof_cleanup(void);
+#endif
diff -ru gcl-2.6.3.ori/o/alloc.c gcl-2.6.3/o/alloc.c
--- gcl-2.6.3.ori/o/alloc.c 2004-06-23 19:25:16.000000000 +0000
+++ gcl-2.6.3/o/alloc.c 2004-07-20 17:43:06.000000000 +0000
@@ -304,6 +304,7 @@
z/=(1+x-0.9*my_tm->tm_adjgbccnt);
z*=(y-mmax_page)*mmax_page;
z=sqrt(z);
+ my_tm->tm_opt_maxpage=(long)z>my_tm->tm_opt_maxpage ? (long)z :
my_tm->tm_opt_maxpage;
if (z<=mmax_page)
return 0;
@@ -311,8 +312,8 @@
r=((x-my_tm->tm_adjgbccnt)+ my_tm->tm_adjgbccnt*mmax_page/z)*(y-mmax_page+z);
r/=x*y;
if (sSAnotify_optimize_maximum_pagesA->s.s_dbind!=sLnil)
- printf("[type %u max %lu(%lu) opt %u y %u(%lu) gbcrat %f sav %f]\n",
-
my_tm->tm_type,mmax_page,mro,(int)z,(int)y,tro,(my_tm->tm_adjgbccnt-1)/(1+x-0.9*my_tm->tm_adjgbccnt),r);
+ printf("[type %u max %lu(%lu) opt %lu y %lu(%lu) gbcrat %f sav %f]\n",
+
my_tm->tm_type,mmax_page,mro,(long)z,(long)y,tro,(my_tm->tm_adjgbccnt-1)/(1+x-0.9*my_tm->tm_adjgbccnt),r);
if (r<=0.95) {
my_tm->tm_adjgbccnt*=mmax_page/z;
if (my_tm->tm_type==t_relocatable)
@@ -783,6 +784,7 @@
tm_table[(int)t].tm_maxpage = maxpage;
tm_table[(int)t].tm_gbccount = 0;
tm_table[(int)t].tm_adjgbccnt = 0;
+ tm_table[(int)t].tm_opt_maxpage = 0;
tm_table[(int)t].tm_distinct=distinct;
#ifdef SGC
tm_table[(int)t].tm_sgc = sgc;
@@ -1206,18 +1208,55 @@
#ifdef GCL_GPROF
static unsigned long start,end,gprof_on;
+static void *initial_monstartup_pointer;
+
+void
+gprof_cleanup(void) {
+
+ extern void _mcleanup(void);
+
+ if (initial_monstartup_pointer) {
+ _mcleanup();
+ gprof_on=0;
+ }
+
+ if (gprof_on) {
+
+ char b[PATH_MAX],b1[PATH_MAX];
+
+ if (!getwd(b))
+ FEerror("Cannot get working directory", 0);
+ if (chdir(P_tmpdir))
+ FEerror("Cannot change directory to tmpdir", 0);
+ _mcleanup();
+ if (snprintf(b1,sizeof(b1),"gmon.out.%u",getpid())<=0)
+ FEerror("Cannot write temporary gmon filename", 0);
+ if (rename("gmon.out",b1))
+ FEerror("Cannot rename gmon.out",0);
+ if (chdir(b))
+ FEerror("Cannot restore working directory", 0);
+ gprof_on=0;
+
+ }
+
+}
+
DEFUN_NEW("GPROF-START",object,fSgprof_start,SI
,0,0,NONE,OO,OO,OO,OO,(void),"")
{
extern void monstartup(unsigned long,unsigned long);
extern void *_start;
+ static int n;
if (!gprof_on) {
start=start ? start : (unsigned long)&_start;
end=end ? end : (unsigned long)core_end;
monstartup(start,end);
gprof_on=1;
+ if (!n && atexit(gprof_cleanup))
+ FEerror("Cannot setup gprof_cleanup on exit", 0);
+ n=1;
}
return Cnil;
@@ -1408,7 +1447,7 @@
}
#else
if (GBC_enable==0) {
- if ( initflag ==0)
+ if ( initflag ==0)
gcl_init_alloc();
else {
#ifdef RECREATE_HEAP
@@ -1425,6 +1464,18 @@
malloc_list->c.c_car = alloc_simple_string(size);
malloc_list->c.c_car->st.st_self = alloc_contblock(size);
+
+#ifdef GCL_GPROF
+ {
+ extern void *_start;
+
+ if (!initflag && size > ((void *)&etext-(void *)&_start)
+ && !initial_monstartup_pointer)
+ initial_monstartup_pointer=malloc_list->c.c_car->st.st_self;
+
+ }
+#endif
+
#ifdef SGC
perm_writable(malloc_list->c.c_car->st.st_self,size);
#endif
@@ -1436,6 +1487,8 @@
void
free(void *ptr)
+
+
#ifndef NO_VOID_STAR
#else
@@ -1462,12 +1515,20 @@
#endif
(*p)->c.c_car->st.st_self = NULL;
*p = (*p)->c.c_cdr;
+#ifdef GCL_GPROF
+ if (initial_monstartup_pointer==ptr) {
+ initial_monstartup_pointer=NULL;
+ if (core_end-heap_end>=sizeof(ptr))
+ *(void **)heap_end=ptr;
+ }
+#endif
return ;
}
#ifdef NOFREE_ERR
return ;
#else
- FEerror("free(3) error.",0);
+ if (raw_image==FALSE || core_end-heap_end<sizeof(ptr) || ptr!=*(void
**)heap_end)
+ FEerror("free(3) error.",0);
return;
#endif
}
diff -ru gcl-2.6.3.ori/o/gbc.c gcl-2.6.3/o/gbc.c
--- gcl-2.6.3.ori/o/gbc.c 2004-07-14 20:48:23.000000000 +0000
+++ gcl-2.6.3/o/gbc.c 2004-07-16 19:43:06.000000000 +0000
@@ -1435,7 +1435,7 @@
check_arg(0);
for (i = 0; i < (int)t_other; i++)
- tm_table[i].tm_gbccount = tm_table[i].tm_adjgbccnt = 0;
+ tm_table[i].tm_gbccount = tm_table[i].tm_adjgbccnt =
tm_table[i].tm_opt_maxpage = 0;
}
/* copy S bytes starting at P to beyond rb_pointer1 (temporarily)
diff -ru gcl-2.6.3.ori/o/main.c gcl-2.6.3/o/main.c
--- gcl-2.6.3.ori/o/main.c 2004-05-03 21:35:58.000000000 +0000
+++ gcl-2.6.3/o/main.c 2004-07-20 17:40:23.000000000 +0000
@@ -82,6 +82,7 @@
int debug; /* debug switch */
int initflag = FALSE; /* initialized flag */
+int raw_image = FALSE; /* raw or saved image */
long real_maxpage;
object sSAlisp_maxpagesA;
@@ -325,6 +326,10 @@
#ifdef SGC
memprotect_test_reset();
#endif
+#ifdef GCL_GPROF
+ if (atexit(gprof_cleanup))
+ error("Cannot setup gprof_cleanup on exit");
+#endif
if (initflag) {
if (saving_system) {
@@ -400,6 +405,8 @@
interrupt_enable = TRUE;
+ raw_image=TRUE;
+
super_funcall(sStop_level);
return 0;
@@ -921,11 +928,15 @@
#ifdef DO_BEFORE_SAVE
DO_BEFORE_SAVE
#endif
-
+
saving_system = TRUE;
GBC(t_contiguous);
-
+#ifdef GCL_GPROF
+ gprof_cleanup();
+#endif
+
+
#if defined(BSD) || defined(ATT)
brk(core_end);
@@ -942,10 +953,10 @@
/* #endif */
- cbgbccount = tm_table[t_contiguous].tm_adjgbccnt = 0;
- rbgbccount = tm_table[t_relocatable].tm_adjgbccnt = 0;
+ cbgbccount = tm_table[t_contiguous].tm_adjgbccnt =
tm_table[t_contiguous].tm_opt_maxpage = 0;
+ rbgbccount = tm_table[t_relocatable].tm_adjgbccnt =
tm_table[t_relocatable].tm_opt_maxpage = 0;
for (i = 0; i < (int)t_end; i++)
- tm_table[i].tm_gbccount = tm_table[i].tm_adjgbccnt = 0;
+ tm_table[i].tm_gbccount = tm_table[i].tm_adjgbccnt =
tm_table[i].tm_opt_maxpage = 0;
Lsave();
saving_system = FALSE;
alloc_page(-(holepage+nrbpage));
diff -ru gcl-2.6.3.ori/o/save.c gcl-2.6.3/o/save.c
--- gcl-2.6.3.ori/o/save.c 2003-11-06 16:16:53.000000000 +0000
+++ gcl-2.6.3/o/save.c 2004-07-20 17:24:41.000000000 +0000
@@ -27,12 +27,24 @@
#endif
#endif
+ if (raw_image) {
+
+ raw_image=FALSE;
+#ifdef MEMORY_SAVE
+ MEMORY_SAVE(kcl_self,filename);
+#else
+ memory_save(kcl_self, filename);
+#endif
+ raw_image=TRUE;
+ exit(0);
+ } else {
#ifdef MEMORY_SAVE
- MEMORY_SAVE(kcl_self,filename);
+ MEMORY_SAVE(kcl_self,filename);
#else
- memory_save(kcl_self, filename);
+ memory_save(kcl_self, filename);
#endif
+ exit(0);
+ }
- exit(0);
/* no return */
}
diff -ru gcl-2.6.3.ori/o/sgbc.c gcl-2.6.3/o/sgbc.c
--- gcl-2.6.3.ori/o/sgbc.c 2004-05-26 02:26:25.000000000 +0000
+++ gcl-2.6.3/o/sgbc.c 2004-07-20 18:31:12.000000000 +0000
@@ -1192,6 +1192,10 @@
}
+#define MMIN(a,b) ({long _a=a,_b=b;_a<_b ? _a : _b;})
+#define MMAX(a,b) ({long _a=a,_b=b;_a>_b ? _a : _b;})
+#define WSGC(tm) ({long
_t;_t=MMIN(tm->tm_opt_maxpage,tm->tm_maxpage-tm->tm_npage+tm->tm_nfree/tm->tm_nppage);_t=MMAX(_t,tm->tm_sgc);_t;})
+
int
sgc_start(void) {
@@ -1254,7 +1258,7 @@
if (free_map[j] >= minfree) {
sgc_type_map[j] |= (SGC_PAGE_FLAG | SGC_TEMP_WRITABLE);
++count;
- if (count >= tm->tm_sgc_max)
+ if (count >= MMAX(WSGC(tm),tm->tm_sgc_max))
break;
}
}
@@ -1263,9 +1267,9 @@
if (saving_system)
continue;
- if (count < tm->tm_sgc) {
+ if (count < WSGC(tm)) {
/* try to get some more free pages of type i */
- long n = tm->tm_sgc - count;
+ long n = WSGC(tm) - count;
long again=0,nfree = tm->tm_nfree;
char *p=alloc_page(n);
if (tm->tm_nfree > nfree) again=1; /* gc freed some objects */
@@ -1273,6 +1277,7 @@
(sgc_enabled=1,add_page_to_freelist(p,tm),sgc_enabled=0);
p += PAGESIZE;
}
+ tm->tm_maxpage=MMAX(tm->tm_maxpage,tm->tm_npage);
if (again)
goto FIND_FREE_PAGES;
}
@@ -1315,7 +1320,8 @@
i=((*cbpp)->cb_size-k)/PAGESIZE;
count+=i;
}
- count=tm->tm_sgc>count ? tm->tm_sgc - count : 0;
+ i=WSGC(tm);
+ count=i>count ? i - count : 0;
if (count>0) {
/* SGC cont pages: allocate more if necessary, dumping possible
@@ -1402,7 +1408,7 @@
{
old_rb_start=rb_start;
if(!saving_system) {
- new=alloc_relblock(((unsigned long)tm->tm_sgc)*PAGESIZE);
+ new=alloc_relblock(((unsigned long)(WSGC(tm))*PAGESIZE));
/* the above may cause a gc, shifting the relblock */
old_rb_start=rb_start;
new= PAGE_ROUND_UP(new);
Only in gcl-2.6.3/unixport: gmon.out
=============================================================================
"Warren A. Hunt Jr." <address@hidden> writes:
> Hi Camm,
>
> We have been trying to use the "gprof" command to profile some Lisp
> code. We are quite intrigued with a message posting by you of May
> 6th, where you give the execution profile for soem ACL2 run. How do
> you make the GCL compiler emit the necessary information so the Lisp
> function names (along with their corresponding filenames) are included
> in such a way that "gprof" provides a meaningful report? It looks
> like the output that you receive is exactly what we want -- we just
> don't know how to make it work.
>
> Thanks,
>
> Warren
>
>
>
--
Camm Maguire address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens." -- Baha'u'llah
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Gcl-devel] Re: Profiling Lisp Code with GPROF under GGL,
Camm Maguire <=