1: \ count execution of control-flow edges
2:
3: \ Copyright (C) 2004 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation; either version 2
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program; if not, write to the Free Software
19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
21:
22: \ relies on some Gforth internals
23:
24: \ !! assumption: each file is included only once; otherwise you get
25: \ the counts for just one of the instances of the file. This can be
26: \ fixed by making sure that every source position occurs only once as
27: \ a profile point.
28:
29: struct
30: cell% field profile-next
31: cell% 2* field profile-count
32: cell% 2* field profile-sourcepos
33: cell% field profile-char \ character position in line
34: end-struct profile% \ profile point
35:
36: variable profile-points \ linked list of profile%
37: 0 profile-points !
38:
39: : new-profile-point ( -- addr )
40: profile% %alloc >r
41: 0. r@ profile-count 2!
42: current-sourcepos r@ profile-sourcepos 2!
43: >in @ r@ profile-char !
44: profile-points @ r@ profile-next !
45: r@ profile-points !
46: r> ;
47:
48: : dinc ( d-addr -- )
49: \ increment double pointed to by d-addr
50: dup 2@ 1. d+ rot 2! ;
51:
52: : profile-this ( -- )
53: new-profile-point profile-count POSTPONE literal POSTPONE dinc ;
54:
55: : profile-:-hook ( -- )
56: defers :-hook profile-this ;
57:
58: : print-profile ( -- )
59: profile-points @ begin
60: dup while
61: dup >r
62: r@ profile-sourcepos 2@ .sourcepos ." :"
63: r@ profile-char @ 0 .r ." : "
64: r@ profile-count 2@ 0 d.r cr
65: r> profile-next @
66: repeat
67: drop ;
68:
69: ' profile-:-hook is :-hook
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>