Forgot your password?
Document Actions
DMP: Print formatted storage dump.
DMP: Print formatted storage dump. stldmp.opl
1 .=member intro
2$ ssssssss eeeeeeeeee tttttttttt ll
3$ ssssssssss eeeeeeeeee tttttttttt ll
4$ ss ss ee tt ll
5$ ss ee tt ll
6$ sssssssss eeeeee tt ll
7$ sssssssss eeeeee tt ll
8$ ss ee tt ll
9$ ss ss ee tt ll
10$ ssssssssss eeeeeeeee tt llllllllll
11$ ssssssss eeeeeeeeee tt llllllllll
12$
13$
14$ ddddddddd mm mm ppppppppp
15$ dddddddddd mmm mmm pppppppppp
16$ dd dd mmmm mmmm pp pp
17$ dd dd mm mmmm mm pp pp
18$ dd dd mm mm mm pppppppppp
19$ dd dd mm mm mm ppppppppp
20$ dd dd mm mm pp
21$ dd dd mm mm pp
22$ dddddddddd mm mm pp
23$ ddddddddd mm mm pp
24$
25$
26$ this software is part of the setl programming system
27$ address queries and comments to
28$
29$ setl project
30$ department of computer science
31$ new york university
32$ courant institute of mathematical sciences
33$ 251 mercer street
34$ new york, ny 10012
35$
1 .=member mods
2
3
4$ program revision history
5$ ------------------------
6
7$ this section contains a description of each revision to the program.
8$ these descriptions have the following format:
9$
10$ mm-dd-yy jdate author(s)
11$
12$ 1.............15........25............................................
13$
14$ where mm-dd-yy are the month, day, and year, and jdate is the julian
15$ date.
16$
17$ each time a revision is installed, the author should insert a
18$ description after line 'mods.21', and change the macro 'prog_level'
19$ to the current julian date.
20$
21$ ......................................................................
stra 1
stra 2
stra 3$ 07/24/84 84206 d. shields and s. freudenberger
stra 4$
stra 5$ 1. support short character strings.
stra 6$ module affected: dspec.
asca 1
asca 2
asca 3$ 03/05/84 84065 s. freudenberger
asca 4$
asca 5$ 1. for s37, add option ascii=0/1 such that ascii=1 causes the
asca 6$ library to maintain strings within the heap in ascii. this
asca 7$ feature is needed to support the nyu ada/ed ada compiler. this
asca 8$ mod is conditioned by ascebc, which should be enabled for s37.
asca 9$ modules affected: stldmp and dumpblk.
suna 1
suna 2
suna 3$ 02/05/84 84065 s. freudenberger
suna 4$
suna 5$ 1. support motorola mc68000 microprocessor on sun workstation.
suna 6$ module affected: stldmp.
smfb 1
smfb 2
smfb 3$ 08/08/83 83220 s. freudenberger
smfb 4$
smfb 5$ 1. a bug in the unix envdsl forces the inclusion of an upper limit on
smfb 6$ the heap size.
smfb 7$ module affected: stldmp.
smfb 8$ 2. before dumping a tuple(untyped real) data block, check whether all
smfb 9$ components are zero.
smfb 10$ module affected: dumpblk.
smfa 1
smfa 2
smfa 3$ 12/16/82 82350 s. freudenberger
smfa 4$
smfa 5$ 1. the data words for long character blocks are printed in a more
smfa 6$ compressed format.
smfa 7$ module affected: dumpblk.
22
23
24$ 08/12/82 82224 s. freudenberger
25$
26$ 1. the q2 definitions have been moved into a separate subroutine
27$ stlini, whose definition should correspond to the definition of
28$ libpl.stlini. this enables us to link dmp against stlshr on s32.
29$ variable declarations global to dmp have been placed into the
30$ nameset nsdmp, and access statements added as needed.
31$ modules affected: stldmp, dmpds, and dmpblk.
32$ module added: stlini.
33$ 2. the form table dump routine has been updated to reflect the form
34$ table change.
35$ module affected: fmdump.
36$ 3. the variable timestr is initialised before it is used to print the
37$ phase header.
38$ module affected: stldmp.
39
40
41$ 06/01/82 82152 s. freudenberger
42$
43$ 1. the form table dump routine has been modified, to (a) reflect
44$ the elimination of the ft_nonzero field; and to (b) dump the
45$ mixed-tuple table.
46$ module affected: fmdump. (for simplicity has been replaced)
47
48
49$ 03/16/82 82075 s. freudenberger
50$
51$ 1. we introduced several new program parameters, to allow us to dump
52$ portions of the q2 file selectively:
53$ fdump=1/1 dump the form table (new feature)
54$ hdump=1/1 dump the heap proper and the stack
55$ sdump=1/1 dump the symbol table
56$ modules affected: stldmp and dumpds.
57$ module added: fmdump.
58$ 2. we slightly changed the layout of the environment block.
59$ module affected: stldmp and dumpds.
60$ 3. use r32 conditional symbol for standard 32-bit fields. this
61$ replaces the field definitions for s32, s37, and s47.
62$ module affected: stldmp.
63
64
65$ 01/15/82 82015 s. freudenberger
66$
67$ 1. stldmp has been modified to print the phase header to the terminal
68$ whenever the new control card parameter 'termh=0/1' is set.
69$ new control card parameter:
70$ termh=0/1 print phase header on the terminal file
71$ module affected: stldmp.
72
73
74$ 11/29/81 81333 d.shields
75$
76$ 1. support s47: amdahl uts (universal timesharing system).
77$ this implementation runs on s37 architecture using an operating
78$ system very close to unix (v7), and uses the ascii character set.
79
80
81$ 10/27/81 81300 s. freudenberger
82$
83$ 1. for the dec vax vms version we now allocate the heap dynamically.
84$ the heap is now read by the setl library routine rdheap.
85$ module affected: stldmp.
86
87
88$ 06/04/81 81155 s. freudenberger
89$
90$ 1. we accounted for the q2 file format change.
91$ 2. we accounted for the new la_form field for long atom data blocks.
92
93
94$ 04/07/91 81090 s. tihor
95$
96$ 1. changing q2 format
97
98
99$ 12/05/80 80340 s. tihor
100$
101$ 1. changing q2 file format
102
103
104$ 11/05/80 80310 s. freudenberger
105$
106$ 1. the dstr routine has been corrected to print the last
107$ character of the word it dumps.
108$ 2. the delblk routine has been modified to reflect the
109$ changes to the storage layout in base element blocks.
110
111
112$ 08/16/80 80231 s. freudenberger
113$
114$ 1. the little do statement requires that a negative increment is
115$ parsed with a minus sign. consequently, the dstr routine had
116$ to be modified to account for the possible negative value of
117$ chinc.
118
119
120$ 08/01/80 80214 s. freudenberger
121$
122$ 1. the new conditional assembly member of compl replaces the
123$ corresponding section in member stldmp.
124$ 2. the code pointer (codep) has been included into the nameset
125$ nsgparam. consequently no declaration is needed in member
126$ stldmp anymore.
127
128
129$ 07/10/80 80192 s. freudenberger
130$
131$ 1. for the .+gt - version, calls to checkptr have been made
132$ dependent on the gtrace flag.
133$ 2. the delblk routine has been modified to dump local sets, too.
134
135
136$ 06/20/80 80172 s. freudenberger
137$
138$ 1. a bug related to the global string specifiers has been corrected.
139$ 2. the page requirements for dumps have been further reduced.
140
141
142$ 05/27/80 80148 s. freudenberger
143$
144$ 1. the stldmp utility has been revised. the new version uses
145$ less paper per dump. in the authours opinion, it also produces
146$ more readable dumps.
147
148
149$ 05/09/80 80130 s. freudenberger
150$
151$ 1. the is_ebfree flag has been eliminated.
152$ 2. the q2_query and q2_isprim opcodes have been eliminated.
153
154
155$ 04/16/80 80107 s. freudenberger
156$
157$ provide a dummy snap routine to suppress the load of most of stllib
158$ when stldmp is linked.
159
160
161$ 04/11/80 80102 d. shields, m. fulk
162$
163$ 1. revise to reflect recent change to heap format.
164$ this requires new code to read in heap image, and also
165$ slight change to code to name entries in symbol table.
166
167
168$ 04/09/80 80100 s. freudenberger
169$
170$ the loop to dump the symbol table has been given the proper
171$ bounds.
172
173
174$ 02/04/80 80035 s. freudenberger
175$
176$ 1. the sizing of 'dump_title' has been corrected.
177$
178$ 2. the global 'cdump' has been dropped from the global nameset defined
179$ in cmnpl.q2macs, and instead hes been defined global to stldmp.
180
181
182$ 01/21/80 80021 s. freudenberger
183$
184$ 1. the form table limit has been increased for the s32.
185$
186$ 2. blk_size has been renamed blksz. modules affected: dumpds and
187$ dumpblk.
188
189
190$ 01/17/80 80017 s. freudenberger
191$
192$ the layout of the heap has been changed: snames has been integrated
193$ into the heap at the low core end, and the run-time symbol table has
194$ been allocated between the run-time names and the constant part of
195$ the heap.
196
197
198$ 11/30/79 79334 s. freudenberger
199$
200$ the dump file format has been changed to the q2 file format.
201
202
1 .=member stlini
2 subr stlini;
3
4 .+set part1
5 .+set part2
6 .+set part3
7 .+set part4
8
9 .=include cndasm $ conditional assembly symbols
10 .=include sysmac $ machine parameters
11
12 .=include formtab $ form table
13
14 .=include q2flds $ q2 field definitions to access heap
15 .=include q2opcd $ q2 opcodes
16 .=include q2macs $ (general) q2 macros
17 .=include q2vars $ q2 variables
18
19 end subr stlini;
1 .=member stldmp
2 prog stldmp;
3
4$ this program produces a formatted dump of the setl run time
5$ environment. its input is a file which is written out by the
6$ run time library whenever it aborts or encounters a
7$ 'debug rdmp;' statement.
8
9 +* prog_level =
stra 7 'dmp(84206) '
11 **
12
13 nameset nsdmp; $ nameset with variables for dmp phase
14
15 size dumpno(ps); $ dump number
16 data dumpno = 0;
17
18 +* dump_file = 3 ** $ number of dump file
19
20 size dump_title(.sds. filenamlen); $ title of dump file
21
22 size cur_dim(ws); $ current heap dimension
23 size max_dim(ws); $ maximum heap dimension
smfb 12 size mh_lim(ps); $ maximum value for h_lim
24 size timestr(.sds. 30); $ current time
25 size termh_flag(1); $ print phase header on the terminal
26
27 size cdump(1); $ code dump request
28 size fdump(1); $ form table dump requested
29 size hdump(1); $ heap dump requested
30 size sdump(1); $ symbol table dump requested
31 size skipn(ps); $ skip first n dumps
32 size dumpn(ps); $ dump only n'th dump
33
34 end nameset nsdmp;
35
36
37 call stlini; $ initialise the q2 tables.
38
39 monitor noentry;
40
41
42 .+s66 call getspp(dump_title, 'dump=dump/dump');
43 .+s37 call getspp(dump_title, 'dump=dump/dump');
44 .+s47 call getspp(dump_title, 'dump=dump/dump');
45 .+s32 call getspp(dump_title, 'dump=dump.dat/');
46 .+s10 call getspp(dump_title, 'dump=dump/dump');
47 .+s20 call getspp(dump_title, 'dump=dump/dump');
suna 8 .+s68 call getspp(dump_title, 'dump=dump/');
smfb 13
smfb 14 call getipp(mh_lim, 'max_heap=0/0'); $ maximum heap length
smfb 15 if (0 < mh_lim & mh_lim < 1024) mh_lim = mh_lim * 1024;
48
49 call getipp(cdump, 'cdump=0/1');
50 call getipp(fdump, 'fdump=1/1');
51 call getipp(hdump, 'hdump=1/1');
52 call getipp(sdump, 'sdump=1/1');
53 call getipp(skipn, 'skip=0/0');
54 call getipp(dumpn, 'dumpn=0/0');
55 .+gt call getipp(gtrace, 'gtrace=0/1');
56 call getipp(termh_flag, 'termh=0/1'); $ print phase header
asca 10
asca 11 .+ascebc.
asca 12 call getipp(ascebc_flag, 'ascii=0/1'); $ ebcdic-to-ascii conv
asca 13 if (ascebc_flag) call aeinit; $ initialise conversion tables
asca 14 ..ascebc
57
58 call lstime(timestr); $ get current time
59
60 if termh_flag then
61 $ the following line is printed on the terminal file only
62 call contlpr(26, no); call contlpr(27, yes);
63 put ,' cims.setl.' ,prog_level :timestr ,a ,skip;
64 call contlpr(26, yes); call contlpr(27, no);
65 end if;
66
67
68 file dump_file access = read, title = dump_title;
69
70 .+s66 rewind dump_file;
71
72
suna 9 .+mhl_dynamic.
75 $ initially allocate a zero-length heap to set up address
76 $ registers.
77
78 $ first inquire how many words can be allocated.
79 call envmhl(1, cur_dim, max_dim);
80
smfb 16 if (0 < mh_lim & mh_lim < max_dim) max_dim = mh_lim;
smfb 17
suna 10 .+s32v.
81 $ since no more files will be opened in this phase, we can
82 $ allocate the remaining program (p0) region for the heap.
83 $ this should guarantee that we can read any heap image.
suna 11 ..s32v
84 call envmhl(2, cur_dim, max_dim);
suna 12 ..mhl_dynamic
87
88 runtime_flag = yes;
suna 13 can_collect = no;
89$
90$ open the q2 file and check its format
91$
92 while 1;
93 dumpno = dumpno + 1; $ increment then print title
94 call dmpttl(dumpno);
95
96 read dump_file, check_word; $ is this a q2 file ?
97 put ,'file check word: ' :check_word ,i ,skip;
98
99 read dump_file, date_stamp; $ q2 format date
100 put ,'file format date: ' :date_stamp ,i ,skip(3);
101
102 call rdheap(dump_file);
103
104 $ check for end-of-file
105 if (filestat(dump_file, end)) quit while 1;
106
107 if (dumpno > skipn & dumpn = 0) ! (dumpno = dumpn) then
108 call dmpds;
109 end if;
110 end while;
111
112
113 end prog stldmp;
1 .=member dmpttl
2 subr dmpttl(n);
3
4$ print title 'dump no. n'
5
6 size n(ps); $ dump number
7
8 size nn(ps), $ copy of n
9 j(ps), $ loop index
10 str(.sds. 5); $ string for n
11
12 nn = n;
13
14 str = ' ';
15
16 do j = 5 to 1 by -1;
17 .ch. j, str = mod(nn, 10) + 1r0;
18 nn = nn/10;
19
20 if (nn = 0) quit;
21 end do;
22
23 call stltitle(yes, 'dynamic storage dump no. ' .cc. str);
24
25
26 end subr dmpttl;
1 .=member dumpds
2 subr dmpds;
3
4$ this routine prints a formatted dump of the heap.
5$ as we scan the heap, we also check all pointers for validity
6$ and issue appropriate diagnostics.
7
8
9 size j(ps), $ loop index
10 len(ps); $ block length
11
12 size blksz(ps); $ function called
13
14 access nsdmp; $ access variables global to dmp
15
16
17 .+tr monitor noentry; $ disable entry trace
18
19
20$ print main header
21 put, x(10), 's t o r a g e d u m p', skip;
22 put, x(10), '-----------------------', skip(2);
23
24$ print basic environment parameters
25$
26 put ,'environment parameters:' ,skip
27 ,skip
28 ,'sym_org: ' :sym_org ,i(8) ,x(4)
29 ,'sym_end: ' :sym_end ,i(8) ,x(4) ,skip
30 ,'ca_org: ' :ca_org ,i(8) ,x(4)
31 ,'h_org: ' :h_org ,i(8) ,x(4)
32 ,'h: ' :h ,i(8) ,x(4) ,skip
33 ,'t: ' :t ,i(8) ,x(4)
34 ,'savet: ' :savet ,i(8) ,x(4)
35 ,'h_lim: ' :h_lim ,i(8) ,x(4) ,skip
36 ,'codep: ' :codep ,i(8) ,x(4) ,skip
37 ,skip(2);
38$
39$ dump the symbol table, if requested
40$
41 if sdump then
42
43 put, x(14), 's y m b o l t a b l e', skip;
44 put, x(14), '-----------------------', skip(2);
45
46
47$ the symbol table dump works in two modes:
48$
49$ len = 0: dump specifiers
50$ len ^= 0: dump untyped data
51$
52$ when we encounter a skip word we set len to the number of untyped
53$ data words; when we dump an untyped word we decrement len.
54
55 len = 0;
56
57 do j = sym_org to sym_end;
58 if len = 0 then $ dump specifier
59 call dloc(j); call dspec(j);
60 if (type(j) = t_skip) len = value(j) - 1;
61
62 else
63 call dloc(j); call dword(j);
64 len = len - 1;
65 end if;
66 end do;
67
68 put, skip(3);
69
70 end if;
71
72 if (fdump) call fmdump;
73
74 if hdump then
75
76 $ next dump stack
77 put, x(19), 's t a c k', skip;
78 put, x(19), '---------', skip(2);
79
80 do j = t to h_lim;
81 call dloc(j); call dspec(j);
82 end do;
83
84 put, skip(3);
85
86 $ dump heap
87 put, x(19), 'h e a p', skip;
88 put, x(19), '-------', skip(2);
89
90 j = ca_org;
91 while j < h;
92 call dumpblk(j);
93
94 len = blksz(j);
95 if (len > h_lim) quit;
96
97 j = j + len;
98 end while;
99
100 end if;
101
102
103 end subr dmpds;
1 .=member fmdump
2 subr fmdump;
3$
4$ this routine dumps the form table.
5$
6 size fm(ps); $ loop index
7 size lines(ps); $ number of lines since last heading
8 size mc(.sds. 5); $ map code name
9 size j1(ps), j2(ps); $ loop indices
10
11 +* lines_max = 20 ** $ number of lines between headings
12
13 +* ftname(tp) = a_ftname(tp+1) ** $ array of form type names
14
15 size a_ftname(.sds. 7);
16 dims a_ftname(f_max+1);
17
18 data ftname(f_gen) = 'gen':
19 ftname(f_sint) = 'sint':
20 ftname(f_sstring) = 'sstring':
21 ftname(f_atom) = 'atom':
22 ftname(f_latom) = 'latom':
23 ftname(f_elmt) = 'elmt':
24 ftname(f_int) = 'int':
25 ftname(f_string) = 'string':
26 ftname(f_real) = 'real':
27 ftname(f_uint) = 'uint':
28 ftname(f_ureal) = 'ureal':
29 ftname(f_ituple) = 'ituple':
30 ftname(f_rtuple) = 'rtuple':
31 ftname(f_mtuple) = 'mtuple':
32 ftname(f_ptuple) = 'ptuple':
33 ftname(f_tuple) = 'tuple':
34 ftname(f_uset) = 'uset':
35 ftname(f_lset) = 'lset':
36 ftname(f_rset) = 'rset':
37 ftname(f_umap) = 'umap':
38 ftname(f_lmap) = 'lmap':
39 ftname(f_rmap) = 'rmap':
40 ftname(f_lpmap) = 'lpmap':
41 ftname(f_limap) = 'limap':
42 ftname(f_lrmap) = 'lrmap':
43 ftname(f_rpmap) = 'rpmap':
44 ftname(f_rimap) = 'rimap':
45 ftname(f_rrmap) = 'rrmap':
46 ftname(f_base) = 'base':
47 ftname(f_pbase) = 'pbase':
48 ftname(f_uimap) = 'uimap':
49 ftname(f_urmap) = 'urmap':
50 ftname(f_error) = 'error':
51 ftname(f_proc) = 'proc':
52 ftname(f_memb) = 'memb':
53 ftname(f_lab) = 'lab';
54
55 size mname(.sds. 4); $ array of ft_mapc names
56 dims mname(ft_max);
57
58 data mname(ft_map) = 'map':
59 mname(ft_smap) = 'smap':
60 mname(ft_mmap) = 'mmap';
61
62
63 put ,x(10) ,'f o r m t a b l e' ,skip
64 ,x(10) ,'-------------------' ,skip(2);
65
66 lines = lines_max; $ set to force new heading
67
68 do fm = 0 to formtabp;
69
70 lines = lines + 1;
71
72 if lines > lines_max then $ print heading
73 put ,skip(2)
74 ,'index type mapc elmt dom im imset '
75 ,'base deref low lim hsh nlt samp'
76 ,skip
77 ,'-------------------------------------------'
78 ,'-------------------------------------'
79 ,skip;
80
81 lines = 1;
82 end if;
83
84 put ,column(01) :fm ,i
85 ,column(07) :ftname(ft_type(fm)) ,a;
86
87 if (is_fmap(fm)) put ,column(15) :mname(ft_mapc(fm)) ,a;
88
89 put ,column(20) :ft_elmt(fm) ,i
90 ,column(26) :ft_dom(fm) ,i
91 ,column(32) :ft_im(fm) ,i
92 ,column(38) :ft_imset(fm) ,i
93 ,column(44) :ft_base(fm) ,i
94 ,column(50) :ft_deref(fm) ,i;
95
96 put ,column(56);
97 if (ft_type(fm) = f_sint) put :ft_low(fm) ,i;
98 if (is_floc(fm) ! is_fbase(fm)) put :ft_bit(fm) ,i;
99
100 put ,column(62);
101 if (ft_type(fm) = f_sint) put :ft_lim(fm) ,i;
102 if (ft_type(fm) = f_proc) put :ft_lim(fm) ,i;
103 if (is_ftup(fm) ! is_fbase(fm)) put :ft_lim(fm) ,i;
104 if (is_floc(fm)) put :ft_pos(fm) ,i;
105 if (is_frem(fm) & is_fmap(fm)) put :ft_tup(fm) ,i;
106
107 put ,column(68);
108 if (is_ftup(fm) ! is_fset(fm)) put :ft_hashok(fm) ,i;
109
110 put ,column(72);
111 if (is_ftup(fm) ! is_fset(fm)) put :ft_neltok(fm) ,i;
112
113 put ,column(76) :ft_samp(fm) ,i;
114
115 if is_fbase(fm) then
116 put ,column(86);
117 do j1 = f_lset to f_lpmap; if ( ^ is_floc(j1)) cont do j1;
118 put :ft_num(fm, j1) ,i(5);
119 end do;
120 end if;
121
122 put ,skip;
123 end do;
124
125 put ,skip;
126
127 lines = lines_max; $ set to force new heading
128
129 do j1 = 0 to (mttabp+9)/10;
130 lines = lines + 1;
131 if lines > lines_max then
132 put ,skip(2)
133 ,'index ...0 ...1 ...2 ...3 ...4'
134 ,' ...5 ...6 ...7 ...8 ...9'
135 ,skip
136 ,'-------------------------------------------'
137 ,'-----------------------------------'
138 ,skip;
139 lines = 1;
140 end if;
141
142 put :j1 ,i(5) ,'. ';
143
144 do j2 = 0 to 9; if (j1*10+j2 > mttabp) quit do j1;
145 if j1*10+j2 = 0 then put ,x(7); cont do j2; end if;
146 put :mttab(j1*10+j2) ,i(6) ,x;
147 end do;
148
149 put ,skip;
150
151 end do;
152
153 put ,skip(3);
154
155
156 end subr fmdump;
1 .=member dloc
2 subr dloc(p);
3
4$ this routine prints a standard header for dumping a heap word.
5$ we print the address of the word followed by a period and a
6$ space. if the word is in the symbol table we also print its name.
7
8$ if 'p' is in the symbol table, the final cursor position is
9$ column 30; otherwise it is column 16.
10
11
12 size p(ps); $ heap pointer
13
14 size var_id(sds_sz);
15
16
17 if sym_org <= p & p <= sym_end then
18 put, column(07): p, i,
19 column(16): var_id(p, 10), a(10),
20 column(30);
21 elseif t <= p & p <= h_lim then
22 put, column(07): p, i,
23 column(16);
24 else
25 put: p, i;
26 end if;
27
28
29 end subr dloc;
1 .=member dspec
2 subr dspec(p);
3
4 $ print symbolic dump of specifier at heap location -p-
5
6$ if p is a long type we not only dump it, but check its
7$ pointer for validity.
8
9
10 size p(ps); $ pointer to specifier to be dumped
11
12 size j(ps); $ loop index
13
14$ tnames maps type codes ti their names.
15 defzero(tnames, a_tnames);
16
17 size a_tnames(.sds. 8);
18 dims a_tnames(t_max+1);
19
20 data tnames(t_int) = 'int': $ short int
21 tnames(t_string) = 'string': $ short chars
22 tnames(t_atom) = 'atom': $ short atom
23 tnames(t_error) = 'error': $ error
24 tnames(t_proc) = 'proc': $ proc
25 tnames(t_lab) = 'lab': $ label
26 tnames(t_latom) = 'latom': $ 'long' atom
27 tnames(t_elmt) = 'elmt': $ compressed element
28 tnames(t_lint) = 'lint': $ long integer
29 tnames(t_istring) = 'istring': $ long chars
30 tnames(t_real) = 'real': $ real
31 tnames(t_tuple) = 'tuple': $ standard tuple
32 tnames(t_stuple) = 'stuple': $ packed or untyped tuple
33 tnames(t_set) = 'set': $ set
34 tnames(t_map) = 'map': $ map
35 tnames(t_skip) = 'skip': $ skip word
36 tnames(t_oint) = 'oint': $ om short int
37 tnames(t_ostring) = 'ostring': $ om short chars
38 tnames(t_oatom) = 'oatom': $ om short atom
39 tnames(t_oerror) = 'oerror': $ om error
40 tnames(t_oproc) = 'oproc': $ om procedure
41 tnames(t_olab) = 'olab': $ om label
42 tnames(t_olatom) = 'olatom': $ om 'long' atom
43 tnames(t_oelmt) = 'oelmt': $ om compressed element
44 tnames(t_olint) = 'olint': $ om long integer
45 tnames(t_oistring)= 'oistring': $ om long chars
46 tnames(t_oreal) = 'oreal': $ om real
47 tnames(t_otuple) = 'otuple': $ om standard tuple
48 tnames(t_ostuple) = 'ostuple': $ om packed or untyped tu
49 tnames(t_oset) = 'oset': $ om set
50 tnames(t_omap) = 'omap': $ om map
51 tnames(t_oskip) = 'oskip'; $ skip word
52
53
54 if otype(p) > t_max then $ junk in jeap
55 put: heap(p), bl, skip;
56 return;
57 end if;
58
59
60 put: tnames(otype(p)), a(8), x(2):
61 is_shared(p), b(1, 1), x(2):
62 is_multi(p), b(1, 1), x(2);
63
64 go to case(type(p)) in t_min to t_lmax;
65
66 /case(t_int)/
67
68 /case(t_atom)/
69
70/case(t_error)/
71
72 put: value(p), i, skip;
73 return;
74
75 /case(t_string)/
76
77 do j = 1 to sc_nchars(p);
stra 8 put :scchar(heap(p), j),r; $ print character value
79 end do;
80
stra 9 put ,skip;
82
83 return;
84
85/case(t_proc)/ $ procs
86
87/case(t_lab)/ $ labels
88
89 put: value(p), i, skip;
90 return;
91
92
93 /case(t_istring)/
94
95 .+ssi.
96
97 put: value(p), i, skip;
98
99 .-gt if (heap_valid) call checkptr(p, h_istring);
100 .+gt if (heap_valid & gtrace) call checkptr(p, h_istring);
101
102 return;
103
104 ..ssi
105
106 .-ssi.
107 put: ic_ptr(p), i, x(1):
108 ic_ofs(p), i, x(1):
109 ic_len(p), i, skip;
110
111 .-gt if (heap_valid) call checkptr(p, h_lstring);
112 .+gt if (heap_valid & gtrace) call checkptr(p, h_lstring);
113
114 return;
115
116 ..ssi
117
118 /case(t_latom)/
119
120/case(t_elmt)/
121
122/case(t_lint)/
123
124/case(t_real)/
125
126/case(t_tuple)/
127
128/case(t_stuple)/
129
130/case(t_set)/
131
132/case(t_map)/
133
134$ check that the value is a valid pointer
135 .-gt if (heap_valid) call checkptr(p+off_value, 0);
136 .+gt if (heap_valid & gtrace) call checkptr(p+off_value, 0);
137
138 put: value(p), i, skip;
139
140 return;
141
142
143/case(t_skip)/
144
145 put: value(p), i, skip;
146 return;
147
148 end subr dspec;
1 .=member dword
2 subr dword(p);
3
4$ this routine dumps untyped data at heap(p) in the same format as
5$ dspec.
6
7
8 size p(ps); $ pointer to untyped data
9
10
11 put: heap(p), bl, skip;
12
13
14 end subr dword;
1 .=member dstr
2 subr dstr(p);
3
4$ this routine dumps a word of a long string data block.
5$ this would be trivial except that we must cope with
6$ the so-called 64 character set on the cdc 6600. this
7$ requires changing the word from zero to blank fill.
8
9
10 size p(ps); $ heap pointer
11
12 size j(ps), $ loop index
13 ch(chsiz); $ character from string
14
15
16 j = chorg;
17 until j > chlst;
18 ch = .f. j, chsiz, heap(p);
19 .+s66 if (ch = 0) quit;
20 put: ch, r(1);
21
22 j = j + chinc;
23 end until;
24
25 put, skip;
26
27 end subr dstr;
1 .=member dreal
2 subr dreal(p);
3
4$ dump real data word
5
6
7 size p(ps); $ pointer to data word
8
9
10 if heap(p) = om_real then
11 put: heap(p), bl, skip;
12 else
13 put: heap(p), e, skip;
14 end if;
15
16
17 end subr dreal;
1 .=member dumpblk
2 subr dumpblk(p);
3
4$ this routine dumps the heap block pointed to by p.
5$ we assume that p is a valid pointer, but check all
6$ pointers in the block it points to.
7
8
9 size p(ps); $ pointer to block to be dumped
10
11 size j(ps), $ loop index
12 ht(ps), $ hedrtype of block
13 bform(ps), $ base form
14 p1(ps), $ extra pointer
15 n(ps); $ number of typed local maps
smfa 9 size word(ps); $ word offset into long character block
smfa 10 size offs(ps); $ character origin in current word
smfa 11 size ch(chsiz); $ current character
smfb 18 size flag(1); $ boolean used in quantifier
16
smfa 12$ hnames maps headrtypes to their names.
18 size hnames(.sds. 7);
19 dims hnames(h_max);
20
21 data hnames(h_latom) = 'latom': $ long atom
22 hnames(h_real) = 'real': $ real
23 hnames(h_lint) = 'lint': $ long integer
24 hnames(h_istring) = 'istring': $ long chars
25 hnames(h_lstring) = 'lstring': $ long chars
26 hnames(h_tuple) = 'tuple': $ standard tuple
27 hnames(h_ptuple) = 'ptuple': $ packed tuple
28 hnames(h_ituple) = 'ituple': $ integer tuple
29 hnames(h_rtuple) = 'rtuple': $ real tuple
30 hnames(h_uset) = 'uset': $ standard set
31 hnames(h_lset) = 'lset': $ local set
32 hnames(h_rset) = 'rset': $ remote set
33 hnames(h_rmap) = 'rmap': $ remote map
34 hnames(h_rpmap) = 'rpmap': $ remote packed map
35 hnames(h_rimap) = 'rimap': $ remote integer map
36 hnames(h_rrmap) = 'rrmap': $ remote real map
37 hnames(h_umap) = 'umap': $ unbased map
38 hnames(h_lmap) = 'lmap': $ local map
39 hnames(h_lpmap) = 'lpmap': $ local packed map
40 hnames(h_limap) = 'limap': $ local integer map
41 hnames(h_lrmap) = 'lrmap': $ local real map
42 hnames(h_base) = 'base': $ base
43 hnames(h_ebs) = 'ebs': $ set element block
44 hnames(h_ebm) = 'ebm': $ map element block
45 hnames(h_ebb) = 'ebb': $ base element block
46 hnames(h_ht) = 'ht': $ hash table header
47 hnames(h_htb) = 'htb': $ hash table block
48 hnames(h_code) = 'code'; $ code
49
50 size blksz(ps); $ returns size of block
asca 15 .+ascebc size ebchar(cs); $ ascii-to-ebcdic conversion function
51
52 access nsdmp; $ access variables global to dmp
53
54
55 /begin/ $ begin execution
56
57 call dloc(p);
58
59 ht = htype(p);
60 if ( ^ (h_min <= ht & ht <= h_max)) go to fail;
61
62$ print standard heading then jump on type.
63 put, column(11): hnames(ht), a,
64 column(20), 'hlink: ': hlink(p), i;
65
66
67 go to case(ht) in h_min to h_max;
68
69
70 /case(h_latom)/
71
72 put, column(40), 'la_value: ': la_value(p), i,
73 column(60), 'la_form: ': la_form(p), i, skip,
74 column(20), 'la_nlmaps: ': la_nlmaps(p), i,
75 column(40), 'la_nwords: ': la_nwords(p), i, skip;
76
77 if la_nlmaps(p) ^= 0 then $ dump typed maps
78 put, column(20), 'typed local maps:', skip;
79
80 do j = 1 to la_nlmaps(p);
81 put, column(24): j, i, ':', column(31);
82 call dspec(p + atomoffs(j));
83 end do;
84 end if;
85
86 if la_nwords(p) > hl_latom + la_nlmaps(p) then $ dump untyped map
87 put, column(20), 'untyped local maps:', skip;
88
89 do j = atomoffs(la_nlmaps(p))+1 to la_nwords(p)-1;
90 put, column(24): j, i, ':', column(31);
91 call dword(p+j);
92 end do;
93 end if;
94
95 go to esac;
96
97
98/case(h_real)/ $ reals
99
100 put, column(40), 'rval: ': rval(p), e, skip;
101
102 go to esac;
103
104
105/case(h_lint)/ $ long int
106
107 put, column(40), 'li_nwords: ': li_nwords(p), i, skip;
108
109 put, column(20), 'data words:', skip;
110
111 do j = hl_lint to li_nwords(p)-1;
112 put, column(24): j-hl_lint+1, i, ':', column(31);
113 call dword(p+j);
114 end do;
115
116 go to esac;
117
118
119 /case(h_istring)/
120
121 .-ssi go to fail;
122
123 .+ssi.
124 put, column(40), 'ic_ofs: ': ic_ofs(p), i,
125 column(60), 'ic_len: ': ic_len(p), i,
126 column(80), 'ic_ptr: ': ic_ptr(p), i, skip;
127 ..ssi
128
129 .-gt if (heap_valid) call checkptr(p+off_ic_ptr, h_lstring);
130 .+gt if (heap_valid & gtrace) call checkptr(p+off_ic_ptr, h_lstring);
131
132 go to esac;
133
134 /case(h_lstring)/
135
136 put, column(40), 'lc_nwords: ': lc_nwords(p), i, skip;
137
138 if lc_nwords(p) > hl_lchars then
139 put, column(20), 'data words:', skip;
140
smfa 13 word = hl_lchars; offs = chorg;
smfa 14 while word < lc_nwords(p);
smfa 15 put ,column(24) :word-hl_lchars+1,i ,':' ,column(31);
smfa 16 n = 0;
smfa 17 while n < 40 & word < lc_nwords(p);
smfa 18 do j = 1 to chpw;
smfa 19 ch = .f. offs, chsiz, heap(p+word);
smfa 20 .+s66 if (ch = 0) quit do;
asca 16 .+ascebc if (ascebc_flag) ch = ebchar(ch);
smfa 21 put :ch,r(1); n = n + 1;
smfa 22 offs = offs + chinc;
smfa 23 end do;
smfa 24 put ,' '; word = word + 1; offs = chorg;
smfa 25 end while;
smfa 26 put ,skip;
smfa 27 end while;
145 end if;
146
147 go to esac;
148
149 /case(h_tuple)/
150
151 call dtup(p); $ dump header
152
153 put, column(20), 'template: '; call dspec(p + compoffs(0));
154
155 if maxindx(p) > 0 then
156 put, column(20), 'components:', skip;
157
158 do j = 1 to maxindx(p);
159 put, column(24): j, i, ':', column(31);
160 call dspec(p + compoffs(j));
161 end do;
162 end if;
163
164 go to esac;
165
166 /case(h_ptuple)/
167
168 call dtup(p); $ dump header
169
170 if ptuplen(p) > hl_ptuple then
171 put, column(20), 'data words:', skip;
172
173 do j = hl_ptuple to ptuplen(p)-1;
174 put, column(24): j-hl_ptuple+1, i, ':', column(31);
175 call dword(p+j);
176 end do;
177 end if;
178
179 go to esac;
180
181
182 /case(h_ituple)/
183
184 call dtup(p); $ dump header
185
186 put, column(20), 'template: '; call dword(p + compoffs(0));
187
188 if maxindx(p) > 0 then
189 put, column(20), 'components:', skip;
190
191 do j = 1 to maxindx(p);
192 put, column(24): j, i, ':', column(31);
193 call dword(p + compoffs(j));
194 end do;
195 end if;
196
197 go to esac;
198
199
200 /case(h_rtuple)/
201
202$ there is one special case where we would like to avoid dumping
203$ an untyped real tuple:
204
205$ the compiler usually winds up with a block of unused space at the
206$ base of the heap. it formats this block into a giant untyped
207$ real tuple so that it can be processed by the garbage collector.
208$ after the first garbage collection this block disappears, and the
209$ first heap block is always the sample value for tuple(untyped int).
210
211$ this means that if there is an untyped real tuple at heap(h_org)
212$ if must be the giant tuple created by the compiler. in this case
213$ we do not dump its components.
214
215 call dtup(p); $ dump header
216
smfb 19 flag = yes; $ assume that all components are zero
smfb 20 do j = 1 to maxindx(p);
smfb 21 if heap(p + compoffs(j)) ^= 0 then flag = no; quit; end;
smfb 22 end do;
smfb 23
smfb 24 if flag then
218 put, skip, column(20), 'all components zero', skip(2);
219 return;
220 end if;
221
222 put, column(20), 'template: '; call dreal(p + compoffs(0));
223
224 if maxindx(p) > 0 then
225 put, column(20), 'components:', skip;
226
227 do j = 1 to maxindx(p);
228 put, column(24): j, i, ':', column(31);
229 call dreal(p + compoffs(j));
230 end do;
231 end if;
232
233
234 go to esac;
235
236
237 /case(h_uset)/
238
239 /case(h_umap)/
240
241 /case(h_base)/
242
243 /case(h_lset)/
244
245 /case(h_lmap)/
246
247 /case(h_limap)/
248
249 /case(h_lrmap)/
250
251 /case(h_lpmap)/
252
253 call dset(p); $ print header fields
254
255 go to esac;
256
257
258 /case(h_rset)/ $remote set
259
260 call dset(p);
261
262 if rswords(p) > 0 then
263 put, column(20), 'data words:', skip;
264
265 do j = 0 to rswords(p)-1;
266 put, column(24): j, i, ':', column(31);
267 call dword(p + hl_rset + j);
268 end do;
269 end if;
270
271 go to esac;
272
273
274 /case(h_rmap)/
275
276 /case(h_rimap)/
277
278 /case(h_rrmap)/
279
280 /case(h_rpmap)/
281
282 call dset(p);
283
284 p = p + hl_rmap;
285 go to begin;
286
287
288 /case(h_ebs)/ $ element heap blocks
289
290 /case(h_ebm)/
291
292 /case(h_ebb)/
293
294
295 call delblk(p);
296
297 go to esac;
298
299 /case(h_ht)/
300
301 put, column(40), 'neb: ': neb(p), i,
302 column(60), 'lognhedrs: ': lognhedrs(p), i, skip;
303
304 go to esac;
305
306
307/case(h_htb)/ $ hash table header block
308
309 put, column(40), 'is_ebhedr: ': is_ebhedr(p), i,
310 column(60), 'is_ebtemp: ': is_ebtemp(p), i,
311 column(80), 'eblink: ': eblink(p), i, skip;
312
313 go to esac;
314
315 /case(h_code)/
316
317 put, column(40), 'codenw: ': codenw(p), i, skip;
318
319$ only dump the code block if requested
320 if cdump then
321 put, skip;
322
323 p1 = p + hl_code;
324
325 while p1 < p + codenw(p);
326 call dinst(p1);
327 p1 = p1 + inst_nw;
328 end while;
329 end if;
330
331 go to esac;
332
333/fail/ $ ill-formed block
334
335 put, column(11), '*******',
336 column(20); call dword(p);
337
338 go to esac;
339
340/esac/
341
342 put, skip;
343
344 end subr dumpblk;
1 .=member dtup
2 subr dtup(p);
3
4$ dump tuple header at heap(p).
5
6 size p(ps); $ pointer to header block
7
8 put, column(40), 'hform: ': hform(p), i,
9 column(60), 'maxindx: ': maxindx(p), i,
10 column(80), 'is_range: ': is_range(p), i, skip;
11
12 put, column(20), 'is_neltok: ': is_neltok(p), i,
13 column(40), 'nelt: ': nelt(p), i,
14 column(60), 'is_hashok: ': is_hashok(p), i,
15 column(80), 'hash: ': hash(p), i, skip;
16
17 if htype(p) = h_ptuple then
18 put, column(20), 'ptvals: ': ptvals(p), i,
19 column(40), 'ptbits: ': ptbits(p), i,
20 column(60), 'ptkey: '; call dspec(p + off_ptkey);
21 end if;
22
23
24 end subr dtup;
1 .=member dset
2 subr dset(p);
3
4$ this routine dumps the set header at heap(p).
5
6
7 size p(ps); $ pointer to set
8
9
10 put, column(40), 'hform: ': hform(p), i,
11 column(60), 'is_elset: ': is_elset(p), i,
12 column(80), 'is_based: ': is_based(p), i, skip;
13
14 put, column(20), 'is_neltok: ': is_neltok(p), i,
15 column(40), 'nelt: ': nelt(p), i,
16 column(60), 'is_hashok: ': is_hashok(p), i,
17 column(80), 'hash: ': hash(p), i, skip;
18
19 put, column(20), 'is_map: ': is_map(p), i,
20 column(40), 'is_smap: ': is_smap(p), i,
21 column(60), 'is_mmap: ': is_mmap(p), i,
22 column(80), 'hashtb: ': hashtb(p), i, skip;
23
24 go to case(htype(p)) in h_uset to h_base;
25
26
27 /case(h_uset)/
28
29 go to esac;
30
31
32 /case(h_rset)/
33
34 put, column(20), 'rs_maxi: ': rs_maxi(p), i, skip;
35
36 go to esac;
37
38
39 /case(h_rmap)/
40
41 /case(h_rpmap)/
42
43 /case(h_rimap)/
44
45 /case(h_rrmap)/
46
47 /case(h_umap)/
48
49 go to esac;
50
51
52 /case(h_lset)/
53
54 /case(h_lmap)/
55
56 /case(h_lpmap)/
57
58 /case(h_limap)/
59
60 /case(h_lrmap)/
61
62 put, column(20), 'ls_word: ': ls_word(p), i,
63 column(40), 'ls_bit: ': ls_bit(p), i;
64
65 if htype(p) = h_lpmap then
66 put, column(60), 'ls_bits: ': ls_bits(p), i,
67 column(80), 'ls_key: '; call dspec(p + off_ls_key);
68 end if;
69
70 put, skip;
71
72 go to esac;
73
74
75 /case(h_base)/
76
77 put, column(20), 'nlmaps: ': nlmaps(p), i, skip;
78
79 go to esac;
80
81
82/esac/
83
84 .-gt if (heap_valid) call checkptr(p+off_hashtb, h_ht);
85 .+gt if (heap_valid & gtrace) call checkptr(p+off_hashtb, h_ht);
86
87
88 end subr dset;
1 .=member delblk
2 subr delblk(p);
3$
4$ this routine dumps the element data block at p.
5$
6 size p(ps); $ pointer to element block
7
8 size bform(ps); $ base form
9 size m(ps); $ number of untyped local maps on base
10 size n(ps); $ number of typed local maps on base
11 size j(ps); $ loop index
12
13 size blksz(ps); $ returns the size of block p
14
15
16 put, skip;
17
18 put, column(20), 'is_ebhedr: ': is_ebhedr(p), i,
19 column(40), 'is_ebtemp: ': is_ebtemp(p), i,
20 column(60), 'ebsize: ': ebsize(p), i,
21 column(80), 'eblink: ': eblink(p), i, skip;
22
23 if htype(p) = h_ebb then
24 bform = ebform(p);
25
26 put, column(20), 'ebform: ': bform, i,
27 column(40), 'ebhash: ': ebhash(p), i,
28 column(60), 'ebindx: ': ebindx(p), i,
29 column(80), 'is_eblive: ': is_eblive(p), i, skip;
30
31 put, column(20), 'base: ': value(ft_samp(bform)), i,
32 skip;
33 end if;
34
35 put, column(20), 'ebspec: '; call dspec(p + off_ebspec);
36
37 if htype(p) = h_ebm then
38 put, column(20), 'ebimag: '; call dspec(p + off_ebimag);
39 end if;
40
41 if htype(p) ^= h_ebb then return; end if;
42
43 n = ft_num(bform, f_lmap);
44
45 if n > 0 then
46 put, column(20), 'typed local maps:', skip;
47
48 do j = 1 to n;
49 put, column(24): j, i, ':', column(31);
50 call dspec(p + localoffs(j));
51 end do;
52 end if;
53
54 m = 0;
55
56 do j = f_limap to f_lrmap;
57 m = m + ft_num(bform, j);
58 end do;
59
60 if m > 0 then
61 put, column(20), 'untyped local maps:', skip;
62
63 do j = 1 to m;
64 put, column(24): j, i, ':', column(31);
65 call dword(p+localoffs(n+j));
66 end do;
67 end if;
68
69 if localoffs(n+m)+1 < blksz(p) then
70 put, column(20), 'local sets and packed local maps:', skip;
71
72 do j = 1 to blksz(p)-(localoffs(m+n)+1);
73 put, column(24): j, i, ':', column(31);
74 call dword(p+localoffs(m+n+j));
75 end do;
76 end if;
77
78
79 end subr delblk;
1 .=member snap
2 subr snap;
3$
4$ this is a dummy routine to suppress the load of the normal snap
5$ routine found in stllib.
6$
7 end subr snap;