Views
Document Actions
ASM: Code generation phase, specific to a particular target machine.
by
Paul McJones
—
last modified
2021-03-17 18:32
- History
-
Action Performed by Date and Time Comment Publish Paul McJones 2021-03-17 18:32 No comments.
ASM: Code generation phase, specific to a particular target machine. This version is for the Digital Equipment Corporation DECsystem-10. By Richard Kenner and David Shields, based on the LITTLE code generator for the IBM System/370 by Kenner.
1 .=member intro
2 .=list noauto,nodir
3 .=title 'dec-10 little code generator.'
4 .=title 'macros.'
5 .=list resume,nodir
6 $ !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
7 $ the above line contains, in order of ascii codes, the 56
8 $ characters of the little language, starting in column 7.
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 this software is part of the little programming system.
41 address queries and comments to
42
43 little project
44 department of computer science
45 new york university
46 courant institute of mathematical sciences
47 251 mercer street
48 new york, ny 10012
49
50 this program is the code generation (asm) phase for the
51 digital equipment corporation decsystem-10 (dec-10).
52 it was written by richard kenner and david shields of
53 the courant institute, and is based on the little code
54 generator for the ibm system/370 written by kenner.
55
56 dr. anthony p. mccann and nigel chapman of the university
57 of leeds have agreed to attempt to produce a resident little
58 compiler for the dec-10 based on this asm.
59
60
61 the program source contains two documentation sections
62 delimited by conditional symbols doct10 and docnote.
63 doct10 text contains specification of t10 target language.
64 docnote contains example little programs and the
65 generated t10 code; it also contains a preliminary version
66 of the macro-10 macros to translate t10 to macro-10.
67 the documentation sections are included here to make this
68 work more accessible to those interested in studying the
69 bootstrap t10 compiler.
70
71
72 */
1 .=member chars
2 /* little character set and ascii representation
3
4 !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
5 the above line contains, in order of ascii codes, the 56
6 characters of the little language, starting in column 7.
7
8 the little language requires 56 distinct characters.
9 these include the 26 upper case letters, the 10 digits,
10 and the following special characters:
11
12 blank
13 = equal sign, assignment symbol
14 + plus
15 - minus
16 * times, asterisk
17 / divide, slash
18 ( left parenthesis
19 ) right parenthesis
20 , comma
21 . period, point
22 ; semicolon
23 : colon
24 $ dollar sign, comment character
25 ^ not
26 & and
27 ! or
28 < less than
29 > greater than
30 ' apostrophe, string delimiter
31 _ underline, break character
32
33 the following table gives the standard ascii encoding
34 for the little character set.
35
36 little character ascii ascii ascii ascii character
37 (hex) (oct) (dec)
38
39 space 20 40 32 space
40 ! or 21 41 33 exclamation mark
41 $ dollar sign 24 44 36 dollar sign
42 & and 26 46 38 ampersand
43 ' apostrophe 27 47 39 apostrophe
44 ( left parenthesis 28 50 40 left parenthesis
45 ) right parenthesis 29 51 41 right parenthesis
46 * asterisk 2a 52 42 asterisk
47 + plus 2b 53 43 plus
48 , comma 2c 54 44 comma
49 - minus 2d 55 45 minus
50 . period 2e 56 46 period
51 / slash 2f 57 47 slant
52 0 digit 0 30 60 48 digit 0
53 1 digit 1 31 61 49 digit 1
54 2 digit 2 32 62 50 digit 2
55 3 digit 3 33 63 51 digit 3
56 4 digit 4 34 64 52 digit 4
57 5 digit 5 35 65 53 digit 5
58 6 digit 6 36 66 54 digit 6
59 7 digit 7 37 67 55 digit 7
60 8 digit 8 38 70 56 digit 8
61 9 digit 9 39 71 57 digit 9
62 : colon 3a 72 58 colon
63 ; semicolon 3b 73 59 semicolon
64 < less than 3c 74 60 less than
65 = equals 3d 75 61 equals
66 > greater than 3e 76 62 greater than
67 a letter a 41 101 65 letter a
68 b letter b 42 102 66 letter b
69 c letter c 43 103 67 letter c
70 d letter d 44 104 68 letter d
71 e letter e 45 105 69 letter e
72 f letter f 46 106 70 letter f
73 g letter g 47 107 71 letter g
74 h letter h 48 110 72 letter h
75 i letter i 49 111 73 letter i
76 j letter j 4a 112 74 letter j
77 k letter k 4b 113 75 letter k
78 l letter l 4c 114 76 letter l
79 m letter m 4d 115 77 letter m
80 n letter n 4e 116 78 letter n
81 o letter o 4f 117 79 letter o
82 p letter p 50 120 80 letter p
83 q letter q 51 121 81 letter q
84 r letter r 52 122 82 letter r
85 s letter s 53 123 83 letter s
86 t letter t 54 124 84 letter t
87 u letter u 55 125 85 letter u
88 v letter v 56 126 86 letter v
89 w letter w 57 127 87 letter w
90 x letter x 58 130 88 letter x
91 y letter y 59 131 89 letter y
92 z letter z 5a 132 90 letter z
93 ^ not 5e 136 94 circumflex
94 _ underline 5f 137 95 underline
95
96
97 the bootstrap dec-10 asm requires additional characters.
98 the at and quotation mark appear in the generated code.
99
100 @ at 40 100 64 at
101 " quotation mark 22 42 34 quotation mark
102
103 brackets are used to delimit meta-comments within the program
104 source. the meta-comments contain queries, comments and
105 suggestions about the code; they are to be examined and
106 dealt with as soon as possible.
107
108
109 [ left bracket 5b 133 91 left bracket
110 ] right bracket 5d 135 93 right bracket
111 */
112
1 .=member desc
2 .+doct10.
3 /* t 1 0 s p e c i f i c a t i o n s
4
5 t10 language level: 1.0
6 date of last language change: 07 jun 78
7 date of last t10 documentation change: 07 jun 78
8
9 this section defines the target language t10 of the bootstrap
10 little code generator for the dec-10.
11
12
13 statement format
14 ----------------
15
16 each line contains either a t10 operation or comment. a comment
17 instruction begins with a semicolon in column one, and the
18 rest of the line contains text. an operation has an opcode
19 beginning in column 9 and an operand field beginning in column 17.
20 the operands may be followed by a comment field, which begins with
21 a semicolon.
22
23 operand formats
24 ---------------
25
26 fnam an fnam is the name of an external file whose
27 extension 'unv' contains the macros for translating
28 t10 operations to valid dec-10 macro-10 assembler
29 code. the default for fnam is 't10mac'; other values
30 can be selected using the 'unv' compiler parameter.
31
32 enam an enam is the external name of a nameset or procedure
33 truncated to six characters if necessary.
34
35 bnam a bnam is the internal three-character blockname used
36 to reference the first word of a block of memory.
37 references to words in the block have the form
38 'bnam+n' where n is nonnegative integer constant.
39
40 bnam's in generated t10 code include the following:
41
42 bas this block contains parameter lists, label lists,
43 constants and other values generated by bootstrap
44 code generator.
45
46 con constant block which contains initial values
47 of program constants. this block can be placed
48 in read-only memory if possible (see dbr).
49
50 g-- global data areas (namesets) are referenced within
51 the code by a block name consisting of the letter
52 g followed by two digits. numeric codes begin with
53 10; first nameset is g10, etc.
54
55 lcl this block contains local variables.
56
57 tmp this block contains temporaries.
58
59 r a register name consists of the letter r followed by
60 a decimal number from zero to 15, and indicates the
61 corresponding word of memory. when register addressed
62 as memory, an attempt is made to use reg and not
63 just memory location value, i.e., 'r3' instead of '3'.
64
65 n indicates a nonnegative integer constant with size
66 at most 18 bits
67
68 acon address constant for dwa operation, has the form
69 bnam+n.
70
71 ccon character code constant for dwc operation, in the
72 form of a sixbit character string delimited by
73 apostrophes. apostrophes within the string are
74 doubled. the string is to be assembled right-
75 justified with zero fill on the left.
76
77 icon signed integer constant for dwi operation.
78
79 ocon octal constant for dwo operation.
80
81 rcon floating point constant for dwr operation. in same
82 form as in little source, except that internal blanks
83 are eliminated.
84
85 scon character string constant for dws operation. in
86 the form of a sixbit character string delimited by
87 quotation marks. quotation marks within the string
88 are doubled. the string is to be assembled left-
89 justified with blank fill.
90
91 plbl a program label consists of the letter l followed
92 by three decimal digits. a lab instruction indicates
93 the definition point of a plbl. plbl's may occur only
94 in branching operations.
95
96 ea an effective address which specifies the memory location
97 of an operand. the ea consists of four parts, as follows:
98
99 indirection indicated by letter at (@)
100 block name a bnam
101 block offset signed integer constant
102 index register register name enclosed in parentheses
103
104 all parts are optional, but specified parts must be given
105 in the order above. if no parts given, value of zero
106 is implied, although bootstrap asm will never produce
107 such a null ea.
108
109 the bnam is optional, but if it is given then the
110 offset must be nonnegative. if the offset is not given, an
111 offset of zero is implied, although bootstrap asm will
112 never produce such an ea.
113
114 the address is formed by first taking block name and
115 offset to determine address. if nonzero index
116 register specified, then contents of the index register
117 are added to address. the resulting value is the location
118 of the word containing the operand, unless indirection
119 is specified, in which case the word addressed contains
120 the location of the operand.
121
122 eai an eai is similar to an ea except that it admits the
123 possibility of specifying a short (up to 18 bit) value
124 using the ea field directly, without requiring a memory
125 access. the operand value is that of the ea itself, and
126 not the word addressed by ea. an instance of such an
127 operand, called 'immediate', is denoted by appending
128 i to the t10 opcode.
129
130 note that certain instructions have four letter opcodes
131 ending in i. such instructions have ea which is always
132 immediate value.
133
134 the following table lists the t10 opcodes in alphabetical order.
135 there follows a description of the opcodes according to their
136 function.
137
138
139 3.1 ban r,eai set (r) to (r) .and. (eai)
140 3.4 bfb r,ea set (r) to .fb. (ea)
141 3.5 bnb r,ea set (r) to .nb. (ea)
142 3.6 bno r,ea set (r) to .not.(ea)
143 3.2 bor r,eai set (r) to (r) .or. (eai)
144 3.3 bxo r,eai set (r) to (r) .exor. (eai)
145 7.3 cal enam,n1,bnam+n2 call procedure enam, n1 args at bnam+n2
146 6.2 ceq r,eai skip next instruction if (r) eq (eai)
147 6.5 cge r,eai skip next instruction if (r) ge (eai)
148 6.4 cgt r,eai skip next instruction if (r) gt (eai)
149 6.7 cle r,eai skip next instruction if (r) le (eai)
150 6.6 clt r,eai skip next instruction if (r) lt (eai)
151 6.3 cne r,eai skip next instruction if (r) ne (eai)
152 1.8 dbr bnam,n define read-only block bnam of n words
153 1.9 dbw bnam,n define writeable block bnam of n words
154 1.5 dec enam define end of code for procedure enam
155 1.3 dep enam define end of procedure enam
156 1.6 dna enam,bnam,n define access of nameset enam
157 1.7 dnd enam,bnam,n define nameset enam
158 1.4 dsc enam define start of code for procedure enam
159 1.2 dsp enam,n1,n2 define start of procedure enam
160 1.10 dwa bnam+n,acon define word with address
161 1.11 dwc bnam+n,ccon define word with character code
162 1.12 dwi bnam+n,icon define word with integer
163 1.13 dwo bnam+n,ocon define word with octal
164 1.14 dwr bnam+n,rcon define word with real
165 1.15 dws bnam+n,scon define word with character string
166 1.16 dwz bnam+n1,n2 define initial block of zeros
167 7.1 ent enam enter procedure enam
168 4.7 iab r,ea set (r) to iabs((ea))
169 4.1 iad r,eai integer add (eai) to (r)
170 4.9 iao r,ea integer add one: set (r) to (ea)+1
171 4.8 ico r,ea integer complement of (ea) to (r)
172 4.4 idi r,eai integer divide (r) by (eai)
173 4.12 idti r,n divide (r) by n-th power of two
174 4.13 ieq r,eai set (r) to 1 if (r) eq (eai), else 0
dsj 1 4.19 ifr r,ea set (r) to ifix((ea))
175 4.16 ige r,eai set (r) to 1 if (r) ge (eai), else 0
176 4.15 igt r,eai set (r) to 1 if (r) gt (eai), else 0
177 4.18 ile r,eai set (r) to 1 if (r) le (eai), else 0
178 4.17 ilt r,eai set (r) to 1 if (r) lt (eai), else 0
179 4.5 imo r,eai set (r) to mod((r),(eai))
180 4.11 imti r,n multiply (r) by n-th power of two
181 4.3 imu r,eai integer multiply (eai) by (r)
182 4.14 ine r,eai set (r) to 1 if (r) ne (eai), else 0
183 4.6 isi r,eai set (r) to isign((r),(eai))
184 4.10 iso r,ea integer subtract one: set (r) to (ea)-1
185 4.2 isu r,eai integer subtract (eai) from (r)
186 6.8 jeq r,plbl jump to plbl if (r) eq 0
187 6.11 jge r,plbl jump to plbl if (r) ge 0
188 6.10 jgt r,plbl jump to plbl if (r) gt 0
189 6.13 jle r,plbl jump to plbl if (r) le 0
190 6.12 jlt r,plbl jump to plbl if (r) lt 0
191 6.15 jmn r,plbl jump never to plbl
192 6.14 jmp r,plbl jump always to plbl
193 6.9 jne r,plbl jump to plbl if (r) ne 0
194 6.1 lab plbl define label plbl
195 2.2 lda r,ea set (r) to ea
196 2.6 ldf r,ea load (r) from byte pointer in (ea)
197 2.8 ldl r,ea set (r) to .f. 19,18,(ea)
198 2.9 ldr r,ea set (r) to .f. 1,18,(ea)
199 2.1 ldw r,eai set (r) to (eai)
eaa 1 .+t20.
eaa 2 3.14 lla r,ea set (r) to rh(ea) - for local address
eaa 3 (extended addressing only)
eaa 4 ..t20
200 2.4 lpr r,ea,n1,n2 set (r) to .f. n1+1,n2,(ea)
dsa 1 2.12 mvw r,ea,n move n words from ea to (r)
dsu 1 2.12 mvx r,ea,n move n words from (r) to ea
202 5.7 rab r,ea set (r) to abs((ea))
203 5.1 rad r,eai real add (eai) to (r)
204 5.8 rco r,eai real complement of (eai) to (r)
205 5.4 rdi r,eai real divide (r) by (eai)
206 5.9 req r,eai set (r) to 1 if (r)-(eai) eq 0.0, else 0
207 7.2 ret enam return from procedure enam
dsj 2 5.15 rfi r,eai set (r) to float((eai))
208 5.12 rge r,eai set (r) to 1 if (r)-(eai) ge 0.0, else 0
209 5.11 rgt r,eai set (r) to 1 if (r)-(eai) gt 0.0, else 0
210 5.14 rle r,eai set (r) to 1 if (r)-(eai) le 0.0, else 0
211 5.13 rlt r,eai set (r) to 1 if (r)-(eai) lt 0.0, else 0
212 5.5 rmo r,eai set (r) to amod((r),(eai))
213 5.3 rmu r,eai real multiply (r) by (eai)
214 5.10 rne r,eai set (r) to 1 if (r)-(eai) ne 0.0, else 0
215 5.6 rsi r,eai set (r) to sign((r),(eai))
216 5.2 rsu r,eai real subtract (eai) from (r)
dsj 3 5.16 rtr r,ea set (r) to aint((ea))
217 1.1 search fnam specify universal file for search
218 2.5 spr r,ea,n1,n2 set .f. n1+1,n2,(ea) to .f. 1,n2,(r)
219 2.7 stf r,ea store (r) to byte pointer in (ea)
220 2.10 stl r,ea set .f.19,18,(ea) to .f. 1,18,(r)
221 2.11 str r,ea set .f.1,18,(ea) to .f. 1,18,(r)
222 2.3 stw r,ea set (ea) to (r)
223 2.14 zebi r,n zeroize n words starting at (r)
224 2.13 zew r,ea set (ea) to zero
225
226
227 description of t10 operations
228 -----------------------------
229
230 -1- declaration and definition operations
231
232 these operations define the structure of a program and specify
233 the initial value of memory locations.
234 they are not executable.
235
236 1.1 search fnam specify universal file for search
237
238 the search operation specifies the file to be searched
239 for macro definitions to translate the t10 code into valid
240 dec-10 macro-10 instructions. if present, the search
241 instruction is the first t10 instruction in a procedure.
242
243 1.2 dsp enam,n1,n2 define start of procedure enam
244 1.3 dep enam define end of procedure enam
245
246 the dsp and dep instructions begin and end a procedure
247 definition, respectively. dsp and dep are required. dsp
248 is the first instruction in a procedure, unless a search
249 instruction is present, in which case the dsp immediately
250 follows the search instruction. the dep instruction is
251 the last instruction in a procedure.
252
253 the first argument of both dsp and dep is the external
254 name of the procedure. the second argument of a dsp gives
255 the number of arguments; the third argument gives the type
256 of the procedure, as follows:
257
258 0 subroutine (subr)
259 1 function (fnct)
260 2 program (prog)
261
262 1.4 dsc enam define start of code for procedure enam
263 1.5 dec enam define end of code for procedure enam
264
265 the dsc instruction indicates the start of the executable code
266 section for a procedure, the dec instruction indicates the end
267 of the code section. both are required, and all executable
268 instructions must occur in the code section. for the dec-10,
269 the dsc effects relocation to high segment, the dec returns
270 relocation to low segment.
271
272 1.6 dna enam,bnam,n define access of nameset enam
273 1.7 dnd enam,bnam,n define nameset enam
274
275 the dna and dnd instructions effect access and definition of
276 global data areas. enam is the external name of the block,
277 bnam is the internal name of the block used in t10 instructions,
278 and n is the length of the block in words. the dnd instruction
279 specifies that this procedure define the data area, and so may
280 contain data definition (dw-) instructions for words in the
281 data area.
282
283 1.8 dbr bnam,n define read-only block bnam of n words
284 1.9 dbw bnam,n define writeable block bnam of n words
285
286 the dbr and dbw instructions reserve blocks of working storage.
287 the words in a dbr block are never written, so that a dbr block
288 should be allocated in read-only memory if this is possible.
289
290 1.10 dwa bnam+n,acon define word with address
291 1.11 dwc bnam+n,ccon define word with character code
292 1.12 dwi bnam+n,icon define word with integer
293 1.13 dwo bnam+n,ocon define word with octal
294 1.14 dwr bnam+n,rcon define word with real
295 1.15 dws bnam+n,scon define word with character string
296
297 the dw operations define the initial value of a memory word.
298 the first operand specfies the location of the word to be
299 initialized and has the form bnam+n where bnam is a block
300 defined by dbr, dbw or dnd instruction, and n is the offset
301 within the block. the second operand specifies the value to
302 which the word is to be initialized, according to the
303 operation code.
304
305 1.16 dwz bnam+n1,n2 define initial block of zeros
306
307 a dwz instruction indicates that the n2 words beginning at
308 location bnam+n1 are to be initialized to zero.
309
310 -2- data transmission instructions
311
312 these instructions transmit data without operating upon it, and
313 are used to move parts of words, single words
314 and blocks of words.
315
316 2.1 ldw r,eai set (r) to (eai)
317 2.2 lda r,ea set (r) to ea
eaa 5 .+t20.
eaa 6 3.14 lla r,ea set (r) to rh(ea) (extended addressing)
eaa 7 ..t20
318 2.3 stw r,ea set (ea) to (r)
319
320 the ldw instruction moves the operand value to a register.
321 the lda instruction moves the operand location to a register,
322 and is equivalent to ldwi.
eaa 8 .+t20.
eaa 9 for extended addressing, this is an xmovei.
eaa 10 the lla instruction moves the right half of the operand
eaa 11 location to a register, and should be used whenever this will
eaa 12 be used in a local context. it is equivalent to ldri.
eaa 13 ..t20
323 the stw instruction stores the register contents at the
324 operand location.
325
326 2.4 lpr r,ea,n1,n2 set (r) to .f. n1+1,n2,(ea)
327 2.5 spr r,ea,n1,n2 set .f. n1+1,n2,(ea) to .f. 1,n2,(r)
328
329 the lpr and spr instructions operate on part of a word. the
330 constants n1 and n2 specify the starting point of the field and
331 the length of the field in bits, respectively. n1 is the little
332 field origin minus one. n2 is the field size.
333
334 2.6 ldf r,ea load (r) from byte pointer in (ea)
335 2.7 stf r,ea store (r) to byte pointer in (ea)
336
337 the ldf and stf instructions operate on part of a word, using a
338 byte pointer explicitly constructed using lpr and spr
339 operations.
340 such a byte pointer is always constructed in a register, and the
341 ea of the ldf and stf will usually, although not necessarily, be
342 a register.
343 the generated byte pointer has same format and interpretation
344 as a dec-10 byte pointer:
345
346 .f. 01, 24, - ea of word containing byte
347 .f. 25, 06, - byte length in bits
348 .f. 31, 06, - number of bits to right of rightmost bit in byte.
349
350 2.8 ldl r,ea set (r) to .f. 19,18,(ea)
351 2.9 ldr r,ea set (r) to .f. 1,18,(ea)
352 2.10 stl r,ea set .f.19,18,(ea) to .f. 1,18,(r)
353 2.11 str r,ea set .f.1,18,(ea) to .f. 1,18,(r)
354
355
356 the halfword ops transmit halfword values using the dec-10
357 halfword operations. they can be considered to be defined
358 by lpr and spr operations, as follows:
359
360 ldl r,ea <-> lpr r,ea,18,18
361 ldr r,ea <-> lpr r,ea,0,18
362 stl r,ea <-> spr r,ea,18,18
363 str r,ea <-> spr,r,ea,0,18
364
dsa 2 2.12 mvw r,ea,n move n words from ea to (r)
366
dsa 3 the mvw instruction moves a block of memory. ea specifies
dsa 4 the address of the first word to be moved, (r) contains the
369 address of the first word to which data is to be moved, and
370 n specifies the number of words to be moved.
dsu 2
dsu 3 mvx is like mvw, but moves from (r) to ea.
371
372 2.13 zew r,ea set (ea) to zero
373 2.14 zebi r,n zeroize n words starting at (r)
374
375 the zew instruction clears a memory location. the zebi
376 instruction clears the n words beginning at the
377 specified memory location.
378
379
380
381 -3- the boolean operations operate on full word values.
382
383 3.1 ban r,eai set (r) to (r) .and. (eai)
384 3.2 bor r,eai set (r) to (r) .or. (eai)
385 3.3 bxo r,eai set (r) to (r) .exor. (eai)
386
387 the binary operations combine the operand value and the register
388 contents, and store the result in the register.
389
390 3.4 bfb r,ea set (r) to .fb. (ea)
391 3.5 bnb r,ea set (r) to .nb. (ea)
392 3.6 bno r,ea set (r) to .not.(ea)
393
394 the bno instruction inverts a full word, so that correct
395 translation of the little not is effected by using lpr to
396 extract desired part of full-word value computed by bno.
397
398 -4- integer arithmetic operations
399
400 4.1 iad r,eai integer add (eai) to (r)
401 4.2 isu r,eai integer subtract (eai) from (r)
402 4.3 imu r,eai integer multiply (eai) by (r)
403 4.4 idi r,eai integer divide (r) by (eai)
404 4.5 imo r,eai set (r) to mod((r),(eai))
405 4.6 isi r,eai set (r) to isign((r),(eai))
406
407 the binary operations combine the operand value and the register
408 contents, and store the result in the register.
409
410 4.7 iab r,ea set (r) to iabs((ea))
411 4.8 ico r,ea integer complement of (ea) to (r)
dsj 4 4.19 ifr r,ea set (r) to ifix((ea))
412
413 the integer complement is the result of subtracting the operand
414 value from zero.
415
416 4.9 iao r,ea integer add one: set (r) to (ea)+1
417 4.10 iso r,ea integer subtract one: set (r) to (ea)-1
418
419 the operations iao and iso effect integer addition and
420 subtraction of the value one, respectively.
421
422 4.11 imti r,n multiply (r) by n-th power of two
423 4.12 idti r,n divide (r) by n-th power of two
424
425 the imti and idti instructions are special cases of the imu and
426 idi instructions where the divisor is a power of two. such
427 operations can be effected by appropriate arithmetic shift.
428 to avoid incorrect results for division of a negative number,
429 the idti instruction is never emitted if the dividend
430 has size ws.
431
432 4.13 ieq r,eai set (r) to 1 if (r) eq (eai), else 0
433 4.14 ine r,eai set (r) to 1 if (r) ne (eai), else 0
434 4.15 igt r,eai set (r) to 1 if (r) gt (eai), else 0
435 4.16 ige r,eai set (r) to 1 if (r) ge (eai), else 0
436 4.17 ilt r,eai set (r) to 1 if (r) lt (eai), else 0
437 4.18 ile r,eai set (r) to 1 if (r) le (eai), else 0
438
439 the integer comparison operations compare the register contents
440 and the operand value, setting the register to one if the
441 relation is true, or to zero if it is not.
442
443 -5- real (floating point) operations
444
445 5.1 rad r,eai real add (eai) to (r)
446 5.2 rsu r,eai real subtract (eai) from (r)
447 5.3 rmu r,eai real multiply (r) by (eai)
448 5.4 rdi r,eai real divide (r) by (eai)
449 5.5 rmo r,eai set (r) to amod((r),(eai))
450 5.6 rsi r,eai set (r) to sign((r),(eai))
451
452 the binary operations combine the operand value and the register
453 contents, and store the result in the register.
454 the memory operand may be immediate mode, although this should
455 not occur. the eai case results from the method in which these
456 operations are processed by the bootstrap asm.
457
458 5.7 rab r,ea set (r) to abs((ea))
459 5.8 rco r,eai real complement of (eai) to (r)
dsj 5 5.15 rfi r,eai set (r) to float((eai))
dsj 6 5.16 rtr r,ea set (r) to aint((ea))
460
461 5.9 req r,eai set (r) to 1 if (r)-(eai) eq 0.0, else 0
462 5.10 rne r,eai set (r) to 1 if (r)-(eai) ne 0.0, else 0
463 5.11 rgt r,eai set (r) to 1 if (r)-(eai) gt 0.0, else 0
464 5.12 rge r,eai set (r) to 1 if (r)-(eai) ge 0.0, else 0
465 5.13 rlt r,eai set (r) to 1 if (r)-(eai) lt 0.0, else 0
466 5.14 rle r,eai set (r) to 1 if (r)-(eai) le 0.0, else 0
467
468 the real comparison operations compare the register contents
469 and the operand value, setting the register to (integer) one if
470 the relation is true, or to (integer) zero if it is not.
471
472
473 -6- branching instructions
474
475 the branching instructions control program execution. a
476 program label is always defined in the code section by a
477 lab instruction.
478
479 6.1 lab plbl define label plbl
480
481 6.2 ceq r,eai skip next instruction if (r) eq (eai)
482 6.3 cne r,eai skip next instruction if (r) ne (eai)
483 6.4 cgt r,eai skip next instruction if (r) gt (eai)
484 6.5 cge r,eai skip next instruction if (r) ge (eai)
485 6.6 clt r,eai skip next instruction if (r) lt (eai)
486 6.7 cle r,eai skip next instruction if (r) le (eai)
487
488 the branch comparison instructions compare the register contents
489 and the operand value, and cause the next instruction to be
490 skipped if the relation is true.
491 these instructions do not alter the register contents.
492
493 6.8 jeq r,plbl jump to plbl if (r) eq 0
494 6.9 jne r,plbl jump to plbl if (r) ne 0
495 6.10 jgt r,plbl jump to plbl if (r) gt 0
496 6.11 jge r,plbl jump to plbl if (r) ge 0
497 6.12 jlt r,plbl jump to plbl if (r) lt 0
498 6.13 jle r,plbl jump to plbl if (r) le 0
499 6.14 jmp r,plbl jump always to plbl
500 6.15 jmn r,plbl jump never to plbl
501
502 the jump operations compare the register contents with zero
503 and cause a branch to the plbl if the relation is true.
504 the jmp instruction always causes a jump. the jmn instruction
505 never causes a jump, and is thus a no-op. the jmp and jmn
506 instructions always specify a register, usually r0, although the
507 contents of the register do not determine if the branch is
508 or is not taken.
509 these instructions do not alter the register contents.
510
511 -7- procedure linkage
512
513 ent is the first instruction executed on procedure invocation,
514 cal is used to invoke other procedures and ret is used to return
515 from a procedure invocation.
516
517 the bootstrap asm makes specific assumptions about register
518 usage but otherwise permits some freedom in implementation
519 of linkage.
520
521 the bootstrap asm allocates registers r0 through r11. r0 is
522 used to return the result of a function invocation. within a
523 procedure that has arguments r11 is used to address the
524 paramater list. a parameter list is a list of words containing
525 the addresses of the corresponding procedure arguments.
526 the bootstrap asm allocates parameter lists within
527 the base block (bnam 'bas').
528
529 the bootstrap asm requires that register contents be preserved
530 over a cal instruction. this requires that the called procedure
531 save the registers before beginning execution and restore them
532 before returning.
533
534 7.1 ent enam enter procedure enam
535
536 the ent is the first instruction executed in a procedure and
537 must occur within the code section. it immediately follows the
538 dsc instruction. the required register save action depends on
539 procedure type (which is given by third argument of dsp
540 instruction) as follows:
541 follows
542
543 0 (subr) registers r0 through r11 must be saved
544 1 (fnct) registers r1 through r11 must be saved. r0 need
545 not be saved, as it will be set to contain
546 function value
547 2 (prog) registers need not be saved, as a program never
548 returns to caller.
549
550 if the procedure has arguments, indicated by the second argument
551 of the dsp instruction having a value greater than zero, then
552 the third argument of the cal instruction contains the address
553 of the parameter list. after saving the registers, this
554 address is to be copied to r11.
555
556 on entry, the procedure can compare the number of arguments
557 given in the dsp instruction with the number actually supplied,
558 as indicated by the second argument of the cal instruction which
559 invoked the procedure.
560
561 7.2 ret enam return from procedure enam
562
563 a return instruction restores the registers and returns to
564 point of invocation. register restore done as follows,
565 according to procedure type indicated by third argument of
566 dsp instruction.
567
568 0 (subr) restore registers r0 through r11
569 1 (fnct) restore registers r1 through r11
570 2 (prog) a return within a prog is invalid and should be
571 treated as an error. the compiler should map
572 return's in a prog into calls to the standard
573 library termination routine ltlfin.
574
575 7.3 cal enam,n1,bnam+n2 call procedure enam, n1 args at bnam+n2
576
577 a cal instruction calls the named procedure. the second
578 argument gives the number of arguments. if it is zero,
579 indicating no arguments, the third argument of cal will be zero.
580 otherwise third argument of cal instruction will be address in
581 address in base block (bnam 'bas') of the start of the
582 parameter list.
583
584
585
586 */
587 ..doct10
1 .=member mods
2 $ ---all corrections are to insert self-description after mods.2---
pic 1
pic 2 $ pic d. shields 01-sep-82 level 82244
pic 3 $ r. kenner
pic 4 $
pic 5 $ 1. fix bug in asmlong re comparison of multi-word items.
pic 6 $ 2. generate position independent code for vax vms.
pic 7 $
dsw 1
dsw 2 $ dsw d. shields 15-jan-82 level 82015
dsw 3 $
dsw 4 $ avoid generating 'g--' symbols for s32u, as they are too much for
dsw 5 $ 'as' to deal with; generate full global block name instead.
dsw 6 $ decks affected - eminit, outdata, outcon.
dsw 7
dsv 1
dsv 2 $ dsv d. shields 20-nov-81 level 81324
dsv 3 $
dsv 4 $ 1. support t32h for unix (s32) also.
dsv 5 $ 2. for s32 nsheap, address the first word in nsheap (heap_addr)
dsv 6 $ directly, except within parameter lists.
dsv 7 $ decks affected - emitea, macros
dsv 8
dsu 4
dsu 5 $ dsu d. shields 02-oct-81 level 81278
dsu 6 $
dsu 7 $ 1. generate opcode mvx where needed. mwx is like mvw, except
dsu 8 $ operands in other order.
dsu 9 $ this affects all implementations.
dsu 10 $ 2. for s32, support program option 'nsheap=/nsheap', so that if
dsu 11 $ a nameset given, then that specified nameset will be addressed
dsu 12 $ indirectly. this permits dynamic allocation
dsu 13 $ of the setl heap, for example. the generated code asssumes the
dsu 14 $ first word in the nameset contains the dynamic address. this
dsu 15 $ value is loaded at the start of each procedure referencing the
dsu 16 $ nameset; thereafter, references are made using the dynamic
dsu 17 $ address which is kept in a register, together with the vax
dsu 18 $ 'indexed' addressing mode of the form '[r..]'.
dsu 19 $ code is conditioned by symbol t32h, and is currently enabled
dsu 20 $ for s32v (vax vms). new t32 ops include the following
dsu 21 $ lha rb,rw,loc load loc to rb
dsu 22 $ rb is register to get byte address, rw to get word address
dsu 23 $ sha var,ea store heap address of var in ea
dsu 24 $ decks affected - macros, start, asmini, setup, eminit, emitsub
dsu 25 $ storer, endsubr, emopr, emitea, emiteh (new)
dsu 26
eaa 14
eaa 15 $ eaa c. hedrick 29-aug-81 level 81243
eaa 16 $ d. shields
eaa 17 $
eaa 18 $ add support for t20, extended addressing extension of t10.
eaa 19 $ adds two parameters
eaa 20 $ nsheap=/nsheap name of nameset to be 'relocated'
eaa 21 $ nshorg=^o2000001/ extended address of nsheap nameset.
eaa 22 $ (section two)
eaa 23 $ if nsheap selected, all references to variables in the specified
eaa 24 $ nameset are done indirectly with efiw macro.
eaa 25 $ this nameset must contain only single-word variables and
eaa 26 $ variables in it cannot be initialized with data statements.
eaa 27 $ the new (t20) opcodes are hba, hbb, hbc, lla, and dha.
eaa 28 $ build this asm by compiling with 'iset=t20'.
eaa 29 $ decks affected - macros, start, asmini, eminit, asmfld, getword,
eaa 30 $ endsubr, emitea, emitex (new)
eaa 31
dst 1
dst 2 $ dst d. shields 17-jun-81 level 81168
dst 3 $
dst 4 $ 1. add option nspage=0/1 such that nspage=1 causes pnd and pna
dst 5 $ ops to be emitted instead of dnd and dna, respectively. this
dst 6 $ is principally for variant setl lib on vax where want in some
dst 7 $ cases to align namesets on page boundaries.
dst 8 $ 2. add measurement feature 'enp' consisting of two new
dst 9 $ options, enp=0/t.rep and enporg=0/0. if enp specified, the
dst 10 $ specified file must have been created using rep=p gen option
dst 11 $ the generated code will contain (new) opcode 'enp' with
dst 12 $ argument determined by the position of the procedure in the
dst 13 $ enp file,
dst 14 $ incremented by value of enporg parameter. this makes it
dst 15 $ possible at run-time to determine the active procedure.
dst 16 $ enp instructions are emitted at start of each procedure and
dst 17 $ after each call instruction within the generated code.
dst 18 $ this feature conditioned by symbol 'enp', which is set for s32
dst 19 $ decks affected - start, asmini, eminit, endsubr, eminit, asmexit.
dst 20
rke 1
rke 2 $ rke r. kenner 12-nov-80 level 80317
rke 3 $ d. shields
rke 4 $
rke 5 $ 1. fix problem (fr156) in handling of multi-word temporaries.
rke 6 $ 2. avoid sending abnormal termination dumps to terminal.
rke 7 $ decks affected - assign, aermey.
rke 8
rkd 1
rkd 2 $ rkd r. kenner 02-sep-80 level 80246
rkd 3 $
rkd 4 $ fix bug (fr150) that caused stores of live quantities to not be
rkd 5 $ done when same variable used in arithmetic operation where another
rkd 6 $ variable is both output and input, and where the live variable is
rkd 7 $ second argument. for example, in 'i=i+j', j was not stored.
rkd 8 $ deck affected - emitdop.
rkd 9
dss 1
dss 2 $ dss d. shields 08-aug-80 level 80217
dss 3 $
dss 4 $ modify t32u to cater to unix assembler (as) as follows:
dss 5 $ 1. generate unique names for local blocks (base, label, const,
dss 6 $ temp) by generating new name for each procedure. for example,
dss 7 $ base block identified as baa in first procedure, bab in second
dss 8 $ and so forth. the second and third characters of these names
dss 9 $ are generated in upper case.
dss 10 $ 2. also make label names unique, use five digit label.
dss 11 $ decks affected - setup, eminit, branchr, labdef, endsubr.
dss 12
dsr 1
dsr 2 $ dsr d. shields 30-jul-80 level 80212
dsr 3 $
dsr 4 $ 1. fix problem in listing ats option value.
dsr 5 $ 2. fix problem in representation of grave accent for t32u, as
dsr 6 $ this character not in s66 character set.
dsr 7 $ decks affected - macros, asmini, emitea.
dsr 8
dsq 1
dsq 2 $ dsq d. shields 21-jul-80 level 80203
dsq 3 $
dsq 4 $ 1. for t32, add option iv=0/1 such that iv=1 causes
dsq 5 $ integer overflow bit to be set in procedure entry
dsq 6 $ mask of all procedures compiled, so that integer
dsq 7 $ overflows can be trapped.
dsq 8 $ 2. if hmeqtm, generate tabs in generated code. this not
dsq 9 $ fully machine-independent, but all current machines
dsq 10 $ s10, s32 (both vms and unix) are dec and use same tab
dsq 11 $ conventions. this reduces size of generated code files,
dsq 12 $ by at least a third for most programs based on initial
dsq 13 $ test.
dsq 14 $ 3. delete 'no errors detected message'.
dsq 15 $ 4. add program parameter ats=1/0 such that ats=1 causes
dsq 16 $ generated code to include date of compilation. ats=0 meant
dsq 17 $ for use during replication to compare generated code files.
dsq 18 $ 5. begin work on bootstrapping to s32 unix. this requires
dsq 19 $ possibility of producing two t32 variants:
dsq 20 $ t32v - vms
dsq 21 $ t32u - unix.
dsq 22 $ nyu currently using vms, hence iset=unix required to
dsq 23 $ configure for unix. note that unix assembler (as)
dsq 24 $ does not support macros, so that a separate c processor
dsq 25 $ is required. hence, changes for t32u are initially as
dsq 26 $ small as possibile, and mainly reflect different unix
dsq 27 $ conventions for specifying indirection and literals.
dsq 28 $ no provision has been made for differing default file
dsq 29 $ names, etc.; this distinction can be introduced by
dsq 30 $ adding s32u/s32v conditional symbols later.
dsq 31 $
dsq 32 $ decks affected - macros, start, asmini, eminit,
dsq 33 $ endsubr, emitea, emopr, ocsput.
dsq 34
dsp 1
dsp 2 $ dsp d. shields 26-feb-80 level 80057
dsp 3 $
dsp 4 $ fix errors reported by chuck hedrick at rutgers relating
dsp 5 $ to s10/t10.
dsp 6 $ 1. missing comment character after mcs definition
dsp 7 $ 2. missing semicolon.
dsp 8 $ also fix error (fr2.3.131) in labfix that caused errors
dsp 9 $ in compiling some until loops.
dsp 10 $ also add new t10 option 'end=prg/seg' such if value other
dsp 11 $ than '0' specified, code file ended as follows
dsp 12 $ 1. end=prg places
dsp 13 $ extern z$strt
dsp 14 $ end z$strt
dsp 15 $ at end of code file.
dsp 16 $ 2. end=seg places
dsp 17 $ end
dsp 18 $ at end of code file.
dsp 19 $ 3. end=nam, where nam not prg or seg, places
dsp 20 $ endnam
dsp 21 $ at end of code file.
dsp 22 $ decks affected - macros, start, asmini, sdsnam, sdlnam,
dsp 23 $ labfix, asmexit.
dsp 24
dso 1
dso 2 $ dso d. shields 04-feb-80 level 80035
dso 3 $
dso 4 $ 1. increase ha dimension to 937.
dso 5 $ 2. fix error that caused looping in some cases
dso 6 $ while printing tables on abnormal termination.
dso 7 $ decks affected - macros, aermey
dso 8
dsn 1
dsn 2 $ dsn d. shields 14-dec-79 level 79348
dsn 3 $
dsn 4 $ 1. rewind voa file only for s66.
dsn 5 $ 2. support long filenames for s32.
dsn 6 $ 3. list actual parameter string.
dsn 7 $ 4. extend maximum permitted dimension for s10, s32 and s37 up
dsn 8 $ to 2**n-1 with n=17, 30 and 22, respectively. this involves
dsn 9 $ change to voa, nl, mba and xha, so that voa file format change
dsn 10 $ remaining changes apply to s10 version.
dsn 11 $ 5. change extent for code file from .t10 to .mac.
dsn 12 $ 6. correct miscellaneous bugs found in porting to
dsn 13 $ rutgers.
dsn 14 $ 7. change _ to $ in external names.
dsn 15 $ 8. change code file extent from .t10 to .mac for t10.
dsn 16 $ decks affected - macros, start, asmini, sdlnam, sdsnam, outcon.
dsn 17
vaxa 1
vaxa 2 $ vaxa r. kenner 11-sep-79 level 79254
vaxa 3 $
vaxa 4 $ extend to support generation of code for dec vax-11/780 (s32).
vaxa 5 $ source configured according to conditional assembly options.
vaxa 6 $ t10 - set to produce t10 code for s10.
vaxa 7 $ t32 - set to produce t32 code for s32.
vaxa 8 $ hmeqtm - set if host and target machine are the same.
vaxa 9 $ decks affected - most.
vaxa 10
rkc 1
rkc 2 $ rkc r. kenner 10-sep-79 level 79253
rkc 3 $
rkc 4 $ fix bug (fr2.3.122) that caused miscompilation of some expressions
rkc 5 $ involving .seq. and .sne. operators.
rkc 6 $ deck affected - emitdop.
rkc 7
rkb 1
rkb 2 $ rkb r. kenner 18-may-79 level 79138
rkb 3 $
rkb 4 $ fix bug (fr2.3.108) that was due to constants of size larger
rkb 5 $ than cval field in ditems being considered short. resolve this
rkb 6 $ by adding new parameter -scs- corresponding to size of cval field.
rkb 7 $ also do not consider arguments to be eligible for permanent
rkb 8 $ register allocation (this fixes fr2.3.109).
rkb 9
rkb 10 $ decks affected - setup, assign.
rkb 11
dsm 1
dsm 2 $ dsm d. shields 29 mar 79 level 79088
dsm 3 $
dsm 4 $ fix errors in s10, s37 field definitions (fr2.3.64, fr2.3.100).
dsm 5 $ these involve mb_chain for s10, vv_vbeg for s10 and s37.
dsm 6 $ deck affected - start.
dsm 7
rka 1
rka 2 $ rka r. kenner 21 feb 79 level 79052
rka 3 $
rka 4 $ fix bug (fr2.3.97) in dsk code in emitsub which assumes that
rka 5 $ all registers contain data.
rka 6 $ fix bug (fr2.3.98) that had error count wrong in -aermey-.
rka 7 $ decks affected - emitsub, aermey.
rka 8
dsl 1
dsl 2 $ dsl d. shields 01 feb 79 level 79032
dsl 3 $ r. kenner
dsl 4 $
dsl 5 $ 1. fix typo introduced by correction dsk.
dsl 6 $ 2. fix error (fr2.3.89) caused by wrongly removing 'if'
dsl 7 $ and 'ifnot' voa operations which branched to next operation.
dsl 8 $ decks affected - labfix, emitdop.
dsl 9
dsk 1 $ dsk d. shields 30 jan 79 level 79030
dsk 2 $ r. kenner
dsk 3 $
dsk 4 $ 1. fix bug in setting drop status of temporaries (fr2.3.80).
dsk 5 $ 2. add code to support .sne. op (fr2.3.82).
dsk 6 $ 3. add option 'fag=0/1' which needs be set nonzero if
dsk 7 $ functions may alter globals (this required for setl cod, lib
dsk 8 $ phases).
dsk 9 $ 4. fix error (fr2.3.87) that resulted in bad code if multi-word
dsk 10 $ items compared in if statement.
dsk 11 $ 5. increase table dimensions so can digest setl.
dsk 12 $ 6. add field definitions for s32.
dsk 13 $ decks affected - macros, start, asmini, setup, asmprog, emitdop,
dsk 14 $ asmif, emitsub.
dsk 15
dsj 7
dsj 8 $ dsj d. shields 27 dec 78 level 78361
dsj 9 $
dsj 10 $ 1. fix error (fr2.3.73) in emitsf that caused miscompilation
dsj 11 $ of lex.
dsj 12 $ 2. fix error (fr2.3.75) in sizing of last argument in
dsj 13 $ calls to getvar in some cases.
dsj 14 $ 3. expand operations aint, float, ifix, int (alias for ifix)
dsj 15 $ in-line. this involves adding t10 opcodes ifr, rfi and rtr.
dsj 16 $ 4. provide code to translate little -amod- to opcode rmo, as
dsj 17 $ existing code was incomplete.
dsj 18 $ decks affected - macros, start, asmprog, emitdop, emitun, emitsf.
dsj 19
dsi 1
dsi 2 $ dsi d. shields 20 dec 78 level 78354
dsi 3 $
dsi 4 $ 1. supply missing argument in -baseprober- call (fr2.3.69).
dsi 5 $ 2. supply missing argument in -ltlterm- call (fr2.3.70).
dsi 6 $ decks affected - macros, asmexit.
dsi 7
dsh 1
dsh 2 $ dsh d. shields 19 dec 78 level 78353
dsh 3 $
dsh 4 $ 1. fix error (fr2.3.67) in that too many args were
dsh 5 $ passed to -cextmw-.
dsh 6 $ 2. fix error (fr2.3.68) in specification of attributes
dsh 7 $ of .e. assignment that caused fatal error in some cases.
dsh 8 $ decks affected - asmprog, emitdop.
dsh 9
dsg 1
dsg 2 $ dsg d. shields 14 dec 78 level 78349
dsg 3 $ r. kenner
dsg 4 $
dsg 5 $ correct error (fr2.3.65) in translating assignment where
dsg 6 $ neither lastdrop set due to bug in -mover-.
dsg 7 $ deck affected - mover.
dsg 8
dsf 1
dsf 2 $ dsf d. shields 12 dec 78 level 78346
dsf 3 $
dsf 4 $ fix error (fr2.3.63) that incorrectly declared -imo- to
dsf 5 $ be commutative.
dsf 6 $ deck affected - emitbin.
dsf 7
dse 1
dse 2 $ dse d. shields 11 dec 78 level 78345
dse 3 $ r. kenner
dse 4 $
dse 5 $ 1. improve allocation of dead registers.
dse 6 $ 2. try once again to generate correct code for imt/idt (fr2.3.48)
dse 7 $ 3. fix bad code for some binary i/o (fr2.3.47)
dse 8 $ by moving -kill(dopir)- to correct place in asmprog.
dse 9 $ 4. correct error (fr2.3.61) in compiling .e. 1+e,3,mw(i) = 0,
dse 10 $ ie, .e. assign to indexed multiword where postion is expr.
dse 11 $ decks affected - asmprog, emitdop, emitbin, aermey.
dse 12
dsd 1
dsd 2 $ dsd d. shields 08 dec 78 level 78342
dsd 3 $
dsd 4 $ 1. respond to fr 2.3.53 (mistranslation of easimw in lib) by
dsd 5 $ correcting code in -mover-.
dsd 6 $ 2. provide field definitions for asmif -it- table for s10, s66.
dsd 7 $ 3. correct conval test in asmfld (fr 2.3.60).
dsd 8 $ decks affected - asmif, asmfld, mover.
dsd 9
dsc 1
dsc 2 $ dsc d. shields 27 nov 78 level 78331
dsc 3 $
dsc 4 $ 1. fix incorrect generation of imt to correct op imti.
dsc 5 $ 2. fix bug in emitbin which caused r-1 to be generated.
dsc 6 $ 3. fix bug in b$num call due to bad data statement.
dsc 7 $ decks affected - start, emitbin.
dsc 8
dsb 1
dsb 2 $ dsb d. shields 25 sep 78 level 78268
dsb 3 $
dsb 4 $ 1. fix error which gave extra zero in label in dwa op.
dsb 5 $ 2. correct wrong name 'nbit$m' to be 'bnum$m'.
dsb 6 $ 3. change so dimltl not set by default, and so obtain
dsb 7 $ full length arrays for production use.
dsb 8 $ 4. add s10 fields for -mba-.
dsb 9 $ decks affected - start, endsubr.
dsb 10
dsa 5
dsa 6 $ dsa d. shields 23 jun 78 level 78174
dsa 7 $
dsa 8 $ 1. correct error in documentation of -mvw- op.
dsa 9 $ 2. correct error in indexed multiword assignment that
dsa 10 $ caused bad translation of ltldoc.
dsa 11 $ decks affected - macros, asmxasi.
dsa 12
3
4 $ (none) r. kenner 07 jun 78 level 78158
5 $ d. shields
6 $
7 $ release initial version of dec-10 bootstrap compiler for
8 $ checkout at university of leeds.
9 $ little language level is 2.3; t10 target language level is 1.0.
10 $ decks affected - all.
11
12
1 .=member macros
2
3 .+set trace
4 .+set labopt
5 .+set ifopt
6 .+set defer
7
8 +* assemblerlevel = $ define level of code generator.
pic 8 'asm(82244)' $ 01-sep-82
10 **
11
dsvb 1 .+s32.
dsvb 2 .+set s32v $ assume vms.
dsvb 3 ..s32
dsvb 4
dsvb 5 .+s32u.
dsvb 6 .+s32.
dsvb 7 .-set s32v $ do not want vms.
dsvb 8 .+set s32u $ want unix os.
dsvb 9 ..s32
dsvb 10 .+set mcl $ want primary case to be lower.
dsvb 11 ..s32u
vaxa 12 .+s32.
vaxa 13 .+set t32
dst 22 .+set enp $ support enp for s32
dsv 10 .+set t32h
vaxa 14 ..s32
vaxa 15
vaxa 16
eaa 33
eaa 34 .+t20. $ if t20 initially set, select t10 (as t20 is extension of t10)
eaa 35 .+set t10
eaa 36 ..t20
eaa 37
vaxa 17 .+s10.
vaxa 18 .+set t10
vaxa 19 ..s10
vaxa 20
vaxa 21
vaxa 22 .-t32.
vaxa 23 .+set t10
vaxa 24 ..t32
vaxa 25
vaxa 26
vaxa 27 .+t10.
vaxa 28 .+s10.
vaxa 29 .+set hmeqtm $ host machine = target machine
vaxa 30 ..s10
vaxa 31 ..t10
vaxa 32
vaxa 33
vaxa 34 .+t32.
vaxa 35 .+s32.
vaxa 36 .+set hmeqtm
dsq 36 .+set t32v $ get vms format by default
vaxa 37 ..s32
vaxa 38 ..t32
vaxa 39
dsvb 12 .+s32u.
dsq 38 .-set t32v $ disable vms format
dsq 39 .+set t32u $ generate unix format t32
dsvb 13 ..s32u
dsq 41
dsu 28
dsu 29 .+t32v.
dsu 31 ..t32v
dsu 32
vaxa 40
12 $ general macros.
13
14 +* ws = .ws. ** $ machine word size.
15 +* ps = .ps. ** $ machine pointer size.
16 +* cs = .cs. ** $ machine character size.
17
18
19 $ target machine parameters.
vaxa 41 .+t10.
20 +* mws = 36 **
21 +* mps = 18 **
dsp 26 +* mcs = 09 ** $ 9 bit version
vaxa 42 +* msl = 18 **
vaxa 43 +* mso = 18 **
vaxa 44 ..t10
vaxa 45
eaa 38 .+t20 +* mps = 30 ** $ increase mps for extended addressing
eaa 39
eaa 40
vaxa 46
vaxa 47 .+t32.
vaxa 48 +* mws = 32 **
vaxa 49 +* mps = 30 **
vaxa 50 +* mcs = 8 **
vaxa 51 +* msl = 16 **
vaxa 52 +* mso = 16 **
vaxa 53 ..t32
vaxa 54
vaxa 55
23 +* mcpw = (mws/mcs) ** $ characters per word.
24
25 +* no = 0 ** $ logical false value.
26 +* yes = 1 ** $ logical true value.
27
28 +* namelen = 20 ** $ significant length of name.
dsn 20
dsn 21 +* filenamelen = 20 ** $ lengt of file name.
dsn 22 .+s32 +* filenamelen = 64 **
29
dsn 23 $ getapp_len is length of actual parameter string (cf. lexini).
dsn 24 +* getapp_len = 128 **
dsn 25 .+s32 +* getapp_len = 240 **
dsn 26
30 +* lstimelen = 30 ** $ length of lstime result.
31
32 +* slen = .len. ** $ length of self-defined string.
33 +* sorg = .f. .sl.+1, .so., ** $ origin of sds.
34
35 +* cpw = (.ws./.cs.) ** $ number of characters/word.
36
37 $ meta macros.
38 +* q3(a, b, c) = a b c **
39 +* macdef(a) = q3(+, *a*, *) **
40 +* macdrop(a) = macdef(a=) **
41 +* defc(a) = macdef(a=zzya) **
42 $ macros for -lcp- print package.
43 +* textl(s) = call textlr(s); ** $ print string.
44 +* charl(c) = call charlr(c); ** $ print character.
45 +* intl(i) = call intlr(i); ** $ print integer.
46 +* intlp(i, n) = call intlpr(i, n); ** $ print -i- in -n- cols.
47 +* hexlp(w, n) = call hexlpr(w, n); ** $ print -w- hex -n- cols.
48 +* tintl(s, i) = call tintlr(s, i); ** $ print string and int.
49 +* endl = call endlr; ** $ end current print line.
50 +* getlpos(n) = call contlpr(1, n); ** $ get current line pos.
51 +* setlpos(n) = call contlpr(2, n); ** $ set current line pos.
52 +* tabl(n) = call contlpr(4, n); ** $ tab to column -n-.
53 +* ejectl = call contlpr(5, 0); ** $ skip to new page.
54 +* ejectlp(n) = call contlpr(5, n); ** $ conditional eject.
55 +* listl(f) = call contlpr(26,f); ** $ set list file control.
56 +* terml(f) = call contlpr(27,f); ** $ set terminal file cntrl.
57 +* octl(i) = call octlr(i); ** $ print octal.
58 +* octlp(i, n) = call octlpr(i, n); ** $ print -i- in -n- cols.
59
60 $ values for io access codes.
61 +* access_get = 1 **
62 +* access_put = 3 **
63 +* access_read = 4 **
64 +* access_write = 6 **
65 $ file numbers.
66 +* voafile = 3 **
67 +* codefile = 4 ** $ generated source code file (macro 10)
68 +* ocsfile = 5 ** $ string file for output code.
dst 23 .+enp +* enpfile = 6 **
dst 24 .+enp +* enpmax = 500 ** $ max. num. of procedures
69
70 $ tmc-del macros give delimiters for output constants.
dsn 27 .+t10 +* tmccdel = 1r" **
vaxa 57 .+t32 +* tmccdel = 1r" **
72 +* tmcsdel = 1r" **
dsq 42 .+hmeqtm.
dsq 43 +* tmcctab = 9 ** $ tab character (assuming ascii).
dsq 44 ..hmeqtm
dsq 45 $ tmcscom is string giving comment character.
dsq 46 $ tmcsind is string giving 'indirection' character.
dsq 47 $ tmcslit is string giving 'constant literal character'.
dsq 48
dsq 49 +* tmcscom = ';' ** $ default comment character.
dsq 50 +* tmcsind = '@' ** $ default indirection character.
dsq 51 +* tmcslit = '#' ** $ default constant literal character.
dsq 52
dsq 53 .+t32u.
dsq 54 $ redefine codes for t32u assembler.
dsq 55 +* tmcscom = '#' ** $ comment character
dsq 56 +* tmcsind = '*' ** $ indirection character.
dsq 57 +* tmcslit = '$' ** $ constant literal character.
dsr 10 $ the s66 used to maintain source does not have grave
dsr 11 $ accent, so use ascii code.
dsr 12 +* tmccgra = 3b'140' ** $ grave accent (ascii octal 140)
dsq 58 ..t32u
73
74 $ mneg computes two complement value of negative offset.
vaxa 58 +* mneg(x) =
vaxa 59 .+t10 (3b'1000000' - (x))
vaxa 60 .+t32.
vaxa 61 .+hmeqtm (-(x))
vaxa 62 .-hmeqtm (4b'100000000' - (x))
vaxa 63 ..t32
vaxa 64 **
76
77 $ dimensions of tables.
78
79 $ select dimltl for small, test dimensions.
81 .-dimltl.
dso 10 +* hadim = 937 **
83 +* mbadim = 63 **
84 +* namesdim = 800 **
85 +* valdim = 1100 **
86 +* voadim = 1850 **
87 +* xargdim = 511 **
88
89 +* dopsdim = 32 **
dsk 17 +* ditemdim = 90 **
dsk 18 +* dworddim = 220 **
dsk 19 +* dregdim = 220 **
93 +* lablistdim = 400 **
dsk 20 +* pdlistdim = 500 **
95 +* pcaradim = 6 **
96 ..dimltl
97
98 .+dimltl.
dso 11 +* hadim = 937 **
100 +* mbadim = 63 **
101 +* namesdim = 300 **
102 +* valdim = 400 **
103 +* voadim = 500 **
104 +* xargdim = 200 **
105
106 +* dopsdim = 32 **
107 +* ditemdim = 40 **
108 +* dworddim = 50 **
109 +* dregdim = 50 **
110 +* lablistdim = 100 **
111 +* pdlistdim = 200 **
112 +* pcaradim = 6 **
113 ..dimltl
114
115
116 $ register numbers.
117
118 $ the following macros encode register numbers. the dec-10
119 $ contains 16 accumulators. this asm only uses some of the
120 $ registers, in the range r0 to rhi. the asm also requires
121 $ a 'spare' register, assumed to be rhi+1. the spare register
122 $ is used to construct parameter lists and to store values in
123 $ some situations.
124
vaxa 65 .+t10.
125 +* r0 = 1 ** $ first register, used for function value.
126 +* r1 = 2 ** $ first assignable register.
127 +* rlo = r1 ** $ first assignable register (ac 1).
128 +* rhi = 12 ** $ last assignable register (ac 11).
129 +* parmreg = rhi ** $ contains parameter list address.
130 +* sparereg = (rhi+1) ** $ spare register.
131 +* rhihi = 16 ** $ last machine register (ac 15).
vaxa 66 ..t10
vaxa 67
vaxa 68
vaxa 69 .+t32.
vaxa 70 +* r0 = 1 ** $ first register, used for function value.
vaxa 71 +* r2 = 3 ** $ first assignable register.
vaxa 72 +* rlo = r2 ** $ first assignable register
vaxa 73 +* rhi = 12 ** $ last assignable register
vaxa 74 +* parmreg = 13 ** $ contains parameter list address.
vaxa 75 +* sparereg = 2 ** $ spare register.
vaxa 76 +* rhihi = 16 ** $ last machine register
vaxa 77 ..t32
132
133 $ machine block types.
134
135 +* bl_abs = 0 ** $ absolute block.
136 +* bl_imm = 1 ** $ immediate constant block.
137 +* bl_base = 2 ** $ base block.
138 +* bl_const = 3 ** $ constant block.
139 +* bl_temp = 4 ** $ temporary block.
140 +* bl_local = 8 ** $ local variable blokck.
141 +* bl_global = 10 ** $ first global block.
142
143 +* num_bl = 4 ** $ number of special blocks.
144
145 $ -voa- operations.
146
147 +* vo_add = 1 ** +* vo_xload = 31 **
148 +* vo_sub = 2 ** +* vo_xasin = 32 **
149 +* vo_gt = 3 ** +* vo_xfasin = 33 **
150 +* vo_lt = 4 ** +* vo_ifnot = 34 **
151 +* vo_ge = 5 ** +* vo_ccat = 35 **
152 +* vo_le = 6 ** +* vo_in = 36 **
153 +* vo_eq = 7 ** +* vo_eext = 37 **
154 +* vo_ne = 8 ** +* vo_sext = 38 **
155 +* vo_mul = 9 ** +* vo_easin = 39 **
156 +* vo_div = 10 ** +* vo_sasin = 40 **
157 +* vo_or = 11 ** +* vo_xeasin = 41 **
158 +* vo_seq = 12 ** +* vo_xsasin = 42 **
159 +* vo_and = 13 ** +* vo_radd = 43 **
160 +* vo_exor = 14 ** +* vo_rsub = 44 **
161 +* vo_sne = 15 ** +* vo_rgt = 45 **
162 +* vo_nb = 16 ** +* vo_rlt = 46 **
163 +* vo_fb = 17 ** +* vo_rge = 47 **
164 +* vo_not = 18 ** +* vo_rle = 48 **
165 +* vo_fcall = 19 ** +* vo_req = 49 **
166 +* vo_scall = 20 ** +* vo_rne = 50 **
167 +* vo_asin = 21 ** +* vo_rmul = 51 **
168 +* vo_data = 22 ** +* vo_rdiv = 52 **
169 +* vo_fasin = 23 ** +* vo_rusub = 53 **
dsj 21 +* vo_float = 54 **
dsj 22 +* vo_ifix = 55 **
170 +* vo_io = 24 ** +* vo_abs = 56 **
171 +* vo_return = 25 ** +* vo_iabs = 57 **
dsj 23 +* vo_aint = 58 **
dsj 24 +* vo_int = 59 **
dsj 25 +* vo_amod = 60 **
172 +* vo_fext = 26 ** +* vo_mod = 61 **
173 +* vo_if = 27 ** +* vo_sign = 62 **
174 +* vo_lab = 28 ** +* vo_isign = 63 **
175 +* vo_goto = 29 ** +* vo_dim = 64 **
176 +* vo_goby = 30 ** +* vo_idim = 65 **
177
178 +* num_vo = 65 ** $ number of operations.
179
180 $ deferred operation codes.
181
182 .=zzyorg a
183 $ deferred operation codes
184
185 .=zzyorg a
186 defc(do_add)
187 defc(do_sub)
188 defc(do_lt)
189 defc(do_ge)
190 defc(do_eq)
191 defc(do_ne)
192 defc(do_mul)
193 defc(do_div)
194 defc(do_and)
195 defc(do_or)
196 defc(do_exor)
197 defc(do_fcall)
198 defc(do_nb)
199 defc(do_not)
200 defc(do_fb)
201 defc(do_scall)
202 defc(do_asin)
203 defc(do_fasin)
204 defc(do_return)
205 defc(do_fext)
206 defc(do_if)
207 defc(do_goto)
208 defc(do_xload)
209 defc(do_xasin)
210 defc(do_xfasin)
211 defc(do_ifnot)
212 defc(do_eext)
213 defc(do_easin)
214 defc(do_xeasin)
215 defc(do_xsasin)
216 defc(do_radd)
217 defc(do_rsub)
218 defc(do_rlt)
219 defc(do_rge)
220 defc(do_req)
221 defc(do_rne)
222 defc(do_rmul)
223 defc(do_rdiv)
224 defc(do_rusub)
225 defc(do_abs)
dsj 26 defc(do_float)
dsj 27 defc(do_ifix)
dsj 28 defc(do_aint)
dsj 29 defc(do_amod)
226 defc(do_iabs)
227 defc(do_mod)
228 defc(do_sign)
229 defc(do_isign)
230 defc(do_dim)
231 defc(do_idim)
232 defc(do_seq)
233 defc(do_sne)
234 defc(do_goby)
235
236 +* num_do = do_goby ** $ number of dops.
237
238 $ assembler operations.
239
240 .=zzyorg a
241
242 defc(ao_ban)
243 defc(ao_bor)
244 defc(ao_bxo)
245 defc(ao_idi)
246 defc(ao_idt)
247 defc(ao_ieq)
248 defc(ao_ige)
249 defc(ao_igt)
250 defc(ao_ile)
251 defc(ao_ilt)
252 defc(ao_imu)
253 defc(ao_imt)
254 defc(ao_isi)
255 defc(ao_ine)
256 defc(ao_isu)
257 defc(ao_iad)
258 defc(ao_imo)
259 defc(ao_rmo)
260 defc(ao_rad)
261 defc(ao_rdi)
262 defc(ao_req)
263 defc(ao_rge)
264 defc(ao_rgt)
265 defc(ao_rle)
266 defc(ao_rlt)
267 defc(ao_rmu)
268 defc(ao_rne)
269 defc(ao_rsi)
270 defc(ao_rsu)
271 defc(ao_bfb)
272 defc(ao_bnb)
273 defc(ao_bno)
274 defc(ao_iab)
275 defc(ao_iao)
276 defc(ao_ico)
dsj 30 defc(ao_ifr)
277 defc(ao_iso)
278 defc(ao_rab)
279 defc(ao_rco)
dsj 31 defc(ao_rfi)
dsj 32 defc(ao_rtr)
280 defc(ao_ldf)
281 defc(ao_lpr)
282 defc(ao_cal)
283 defc(ao_mvw)
284 defc(ao_zeb)
285 defc(ao_stf)
286 defc(ao_spr)
287
288 +* ao_fbo = ao_ban ** $ first binary op
289 +* ao_lbo = ao_rsu ** $ last binary op
290 +* ao_fuo = ao_bfb ** $ first unary op
291 +* ao_luo = ao_lpr ** $ last unary op
vaxa 78 +* num_ao = ao_spr ** $ number of ao operators
293
294
295 $ machine operation codes (listed in alphabetical order)
296
297 .=zzyorg a
298
299 defc(mo_ban)
300 defc(mo_bfb)
301 defc(mo_bnb)
302 defc(mo_bno)
303 defc(mo_bor)
304 defc(mo_bxo)
305 defc(mo_cal)
306 defc(mo_ceq)
307 defc(mo_cge)
308 defc(mo_cgt)
309 defc(mo_cle)
310 defc(mo_clt)
311 defc(mo_cne)
312 defc(mo_iab)
313 defc(mo_iad)
314 defc(mo_iao)
315 defc(mo_ico)
316 defc(mo_idi)
317 defc(mo_idt)
318 defc(mo_ieq)
dsj 33 defc(mo_ifr)
319 defc(mo_ige)
320 defc(mo_igt)
321 defc(mo_ile)
322 defc(mo_ilt)
323 defc(mo_imo)
324 defc(mo_imt)
325 defc(mo_imu)
326 defc(mo_ine)
327 defc(mo_isi)
328 defc(mo_iso)
329 defc(mo_isu)
330 defc(mo_jeq)
331 defc(mo_jge)
332 defc(mo_jgt)
333 defc(mo_jle)
334 defc(mo_jlt)
335 defc(mo_jmn)
336 defc(mo_jmp)
337 defc(mo_jne)
338 defc(mo_lda)
339 defc(mo_ldf)
340 defc(mo_ldl)
341 defc(mo_ldr)
342 defc(mo_ldw)
eaa 41 .+t20 defc(mo_lla)
343 defc(mo_lpr)
344 defc(mo_mvw)
dsu 33 defc(mo_mvx)
345 defc(mo_rab)
346 defc(mo_rad)
347 defc(mo_rco)
348 defc(mo_rdi)
349 defc(mo_req)
350 defc(mo_ret)
dsj 34 defc(mo_rfi)
351 defc(mo_rge)
352 defc(mo_rgt)
353 defc(mo_rle)
354 defc(mo_rlt)
355 defc(mo_rmo)
356 defc(mo_rmu)
357 defc(mo_rne)
358 defc(mo_rsi)
359 defc(mo_rsu)
dsj 35 defc(mo_rtr)
360 defc(mo_spr)
361 defc(mo_stf)
362 defc(mo_stl)
vaxa 79 .+t32 +* mo_xjm = mo_str ** $ add new opcode for t32.
363 defc(mo_str)
364 defc(mo_stw)
365 defc(mo_zeb)
eaa 42 .+t20 defc(mo_hba)
eaa 43 .+t20 defc(mo_hbb)
eaa 44 .+t20 defc(mo_hbc)
366 defc(mo_zew)
367
368 +* num_mo = mo_zew ** $ number of mo ops
369
370
371
372 $ mop attributes are given by following macros and fields.
373 +* moaimm(mop) = moa_imm moatab(mop) ** $ is immediate ok.
374 +* moaicb(mop) = mob_icb moatab(mop) ** $ basic instruction cod
375 +* moaici(mop) = moa_ici moatab(mop) ** $ immediate instr. code.
376 +* moaiwc(mop) = moa_iwc moatab(mop) ** $ instr. word count.
377
378 +* moa_imm = .f. 01, 1, ** $ on if immediate mode allowed.
379 +* moa_ici = .f. 04, 9, ** $ opcode if moa_imm set.
380 +* moa_icb = .f. 13, 9, ** $ basic instruction code.
381 +* moa_iwc = .f. 22, 3, ** $ instruction word count.
382
383
384 $ the following branch masks are used to select various types
385 $ of conditional branches. they are three bits long. each
386 $ bit means branch on <0, =0, or >0. therefore, all bits being
387 $ set is an unconditional branch. therefore, to negate a branch
388 $ mask, it must just be exclusive or'ed with the unconditional
389 $ mask. an extra branch mask is used to indicate the mask for
390 $ the 'testchar' test when the bits are on.
391 $ [these codes used in asmif, branchr.]
392
393 +* bm_zer = 1b'100' ** $ branch on zero.
394 +* bm_neg = 1b'010' ** $ branch on less than zero.
395 +* bm_pos = 1b'001' ** $ branch on greater than zero.
396 +* bm_all = 1b'111' ** $ unconditional branch.
397
398 +* binv(bm) = (bm .ex. bm_all) ** $ inverse branch mask.
399
400 +* bmswap(bm, t) = $ swap branch mask.
401 $ this is used when one wants to reverse the operands of
402 $ a comparison. it changes the positive and negative bits.
403 $ -bm- is the output and input mask and -t- is a temporary.
404 t = bm; .f. 1, 1, t = .f. 2, 1, bm;
405 .f. 2, 1, t = .f. 1, 1, bm; bm = t;
406 **
407
408
409 $ these macros are used to emit -asm- instructions to be
410 $ converted into dec-10 machine code. they are split up into
411 $ various types and each has its own macro. the operations
412 $ of that type all call that macro. note that not all
413 $ operations have macros because only those that are issue
414 $ explicitly (i.e., not from a table) have macros defined.
415
416
417 $ these macros are for the conditional operations. the first
418 $ parameter after the op-code is the dummy register to be tested
419 $ and the second parameter is the label to branch to if the
420 $ test is true.
421
422 +* if_op(op, in, lab) = call emitif(op, in, lab); **
423
424 +* ifspos_op(in, lab) = $ branch to -lab- if -in- is >0.
425 if_op(bm_pos, in, lab) **
426
427 +* ifpos_op(in, lab) = $ branch to -lab- if -in- is >=0.
428 if_op(binv(bm_neg), in, lab) **
429
430 +* goto_op(lab) = $ unconditional branch to -lab-.
431 branchop(bm_all, r0, lab) ** $ unconditional branch.
432
433
434 $ these next macros are for the long operations. these
435 $ operations are storage-storage operations. the first
436 $ parameter after the op-code is the address of the destination,
437 $ the second is the address of the target, and the last is the
438 $ length in words. the addresses are obtained via the -getaddr-
439 $ macro.
440
441 +* long_op(op, or, ir, l) =
442 call emitlong(op, or, ir, l); **
443
444 +* smove_op(or, ir, l) = $ move from input to output.
445 long_op(ao_mvw, or, ir, l); **
446
447 +* clear_op(r, l) = $ clear to zero.
448 long_op(ao_zeb, r, r, l); **
449
450 $ the clear op clears nw words of memory.
451
452
453 $ these macros are for unary operators. the first parameter
454 $ after the op-code is the output and the last parameter is the
455 $ input operand.
456
457 +* un_op(op, or, ir) = call emitun(op, or, ir); **
458
459 +* not_op(or, ir) = $ negate (not complement) register.
460 un_op(ao_bno, or, ir) **
461
462 +* neg_op(or, ir) = $ complement register (0-r).
463 un_op(ao_ico, or, ir) **
464
465 +* add1_op(or, ir) = $ add one to a register.
466 un_op(ao_iao, or, ir) **
467
468 +* sub1_op(or, ir) = $ subtract one from a register.
469 un_op(ao_iso, or, ir) **
470
471 $ the lpr and spr ops retrieve/store parts of registers.
472 $ lpr loads from ir to or, spr stores from or to ir, ie
473 $ lpr_op(r1,r2,c1,c2) <-> r1 = .f. c1+1, c2, r1
474 $ spr_op(r1,r2,c1,c2) <-> .f. c1+1, c2, r2 = r1
475
476 +* lpr_op(or, ir, fo, fl) = $ load part of word.
477 emopparm1 = fo; emopparm2 = fl; $ set extra parms.
478 un_op(ao_lpr, or, ir) ** $ do as unary op.
479
480 +* ldf_op(or, ir) = $ load -or- as pointed to by byte -ir-.
481 un_op(ao_ldf, or, ir) ** $ do as unary op.
482
483 $ macros for part word store operations.
484
485 +* sfld_op(op, ir, tr) = $ store -ir- into -tr-
486 call emitsfld(op, ir, tr); **
487
488 +* spr_op(ir, tr, fo, fl) = $ store part of word.
489 emopparm1 = fo; emopparm2 = fl; $ set extra parms.
490 sfld_op(ao_spr, ir, tr) ** $ do operation
491
492 +* stf_op(ir, tr) = $ store -ir- in byte pointed to by -tr-.
493 sfld_op(ao_stf, ir, tr) ** $ do operation
494
495
496 $ these macros are for the subroutine handling operations
497 $ such as call.
498
499 +* call_op = call emitsub; **
500
501
502 $ these macros are used to emit binary operations. the first
503 $ parameter after the op-code is the output and the last two
504 $ parameters are the inputs.
505
506 +* bin_op(op, out, in1, in2) = call emitbin(op, out, in1, in2);**
507
508 +* and_op(out, in1, in2) = $ logical -and-
509 bin_op(ao_ban, out, in1, in2) **
510
511 +* or_op(out, in1, in2) = $ logical -or-
512 bin_op(ao_bor, out, in1, in2) **
513
514 +* exor_op(out, in1, in2) = $ logical exclusive -or-.
515 bin_op(ao_bxo, out, in1, in2) **
516
517 +* add_op(out, in1, in2) = $ addition.
518 bin_op(ao_iad, out, in1, in2) **
519
520 +* sub_op(out, in1, in2) = $ subtraction.
521 bin_op(ao_isu, out, in1, in2) **
522
523 +* mul_op(out, in1, in2) = $ multiplication
524 bin_op(ao_imu, out, in1, in2) **
525
526 +* div_op(out, in1, in2) = $ division
527 bin_op(ao_idi, out, in1, in2) **
528
529 +* mul2_op(out, in1, in2) = $ multiplication by power of two
530 bin_op(ao_imt, out, in1, in2) **
531
532 +* div2_op(out, in1, in2) = $ division by power of two
533 bin_op(ao_idt, out, in1, in2) **
534
535 +* mod_op(out, in1, in2) = $ mod
536 bin_op(ao_imo, out, in1, in2) **
537
538
539 $ the next operation compares two inputs and branches
540 $ with a specified condition to a label.
541 +* cmp_op(bm, in1, in2, lab) =
542 call emitcmp(bm, in1, in2, lab); **
543
544
545 $ macro to assign dummy resister to -voa- operand
546
547 $ the -assign- macro has two operands. the first rs the
548 $ variable to receive the dummy register number and the
549 $ second is the encoded -voa- operand to obtain. the
550 $ encodings follow.
551
552 +* va_spec = 1 ** $ special value. use -voaep- as pointer.
553 +* va_fnct = 2 ** $ function return (voap=1)
554 +* va_inp1 = 3 ** $ input one of current operation
555 +* va_inp2 = 4 ** $ input two
556 +* va_inp3 = 5 ** $ input three
557 +* va_inp4 = 6 ** $ input four
558 +* va_oup = 7 ** $ output
559 +* va_xarg = 8 ** $ values above this indicate that arguments
560 $ come from the -xarg- entries pointed to by
561 $ the current operation. the difference
562 $ between the value and -va_xarg- is the
563 $ number of the desired parameter.
564
565
566 +* assign(reg, type) =
567 call assignr(type); $ call routine to get register.
568 reg = assignreg; ** $ copy assigned value.
569
570
571
572 $ macro to assign dummy register to constant.
573
574 $ the -assignconst- macro has two operands. the first is set
575 $ to the number of the dummy register assigned. the second
576 $ operand is the constant to be assigned to the register.
577 $ the flag -asconstspc- is used internally to alter the meaning
578 $ of the second operand. see routines -assignr- and -asconst-
579 $ for meaning of this usage.
580
581 +* assignconst(reg, const) = $ assign register to constant.
582 call asconst(const); $ pass constant to routine.
583 reg = asconstreg; ** $ get return value.
584
585
586 $ macro to get free dummy register.
587
588 $ the -getdreg- macro gets a dummy register to use as a
589 $ temporary result. it is set up as a one word variable
590 $ with standard form, offset, etc. this variable is set to
591 $ temporary type and, when actually used as core reference,
592 $ will be allocated to an actual temporary location, if needed.
593
594 +* getdreg(reg) = $ get dummy register.
595 call getdregr(reg); ** $ call routine.
596
597
598 $ macro to clear dummy register.
599
600 $ the -clear- macro resets the status of a dummy register so
601 $ that it can be assigned to. this involves dropping any
602 $ alternate forms and/or deferred operations from the previous
603 $ value of the register.
604
605 +* clear(reg) = call clearr(reg); ** $ call routine.
606
607
608
609 $ -getdesc- macro.
610
611 $ the -getdesc- macro gets a description of the variable
612 $ given to it. the description is given by three items. the
613
614 +* getdesc(dr, typ, ind, reg, off) =
615 call getdescr(dr, typ, ind, reg, off); ** $ call routine.
616
617
618
619 $ -getvar- macro
620
621 $ the -getvar- macro is similar to the -getdesc- macro in its
622 $ parameters. the difference is that -getvar- can be used oto
623 $ put the variable into the desired type of register. it
624 $ should be called when the type is anything other than
625 $ -gd_addr-.
626
627 +* getvar(dr, typ, mode, reg, off) =
628 call getvarr(dr, typ, mode, reg, off); **
629
630
631 $ types for -getdesc- and -getvar-
632
633 +* gd_addr = 1 ** $ just get address pointer.
634 +* gd_use = 2 ** $ want to use variable as general.
635 +* gd_reg = 3 ** $ force into register.
636 +* gd_intoreg = 4 ** $ want to load into specific register.
637 +* gd_inregnu = 5 ** $ want to load specific register, no upd.
638
639 +* num_gd = 5 ** $ number of types.
640
641 $ macro -countup-.
642
643 $ increment a pointer to an array and
644 $ to test for array overflow.
645
646 +* countup(p, max, name) =
647 p = p+1; $ increment pointer.
648 if (p > max) call countupr(name); $ error.
649 **
650
651 $ macro -lastuse-.
652
653 $ this macro is used to indicate that the next action done
654 $ by a generator on a dummy register will be its last.
655
656 +* lastuse(reg) =
657 di_luse ditem(dr_item dreg(reg)) = $ increment.
658 di_luse ditem(dr_item dreg(reg)) + 1;
659 **
660
661
662
663 $ macro -sdsname-.
664
665 $ this macro returns an sds containing the name of the item
666 $ whose -ha- pointer is given. (it must be a variable or
667 $ routine name.)
668 $ sdsname is used for names to appear in generated code file,
669 $ so that long names are truncated to six characters.
670
671 +* sdsname(str, ptr) =
672 call sdsnamr(str, ptr); $ call routine.
673 **
674
675 $ macro -sdlname-.
676
677 $ this macro returns an sds containing the name of the item
678 $ whose -ha- pointer is given. (it must be a variable or
679 $ routine name.)
680
681 +* sdlname(str, ptr) =
682 call sdlnamr(str, ptr); $ call routine.
683 **
684
685
686 .+defer.
687 $ -using- macro.
688
689 $ the -using- macro is used to indicate that an operand of
690 $ a previous deferred operation is going to be used even
691 $ though the operation may be freed. this is needed to
692 $ keep track of the count fields.
693
694 +* using(dr) = $ will use this register.
695 di_count ditem(dr_item dreg(dr)) = $ increment count.
696 di_count ditem(dr_item dreg(dr)) + 1;
697 **
698 ..defer
699
700
701
702 $ thdse are access macros for various fields in -ditem-.
703 $ they enable them to be accessed from the -dreg- pointer.
704
705 +* accss(fld, dr) = fld ditem(dr_item dreg(dr)) **
706
707 +* nwords(dr) = accss(di_nwords, dr) **
708
709 +* syze(dr) = accss(di_syze, dr) **
710
711 +* conval(dr) = accss(di_cval, dr) **
712
713 .+defer +* dout(dr) = accss(di_out, dr) **
714
715 +* isreal(dr) = accss(di_real, dr) **
716
717 +* ismw(dr) = accss(di_mw, dr) **
718
719 +* isvar(dr) = accss(di_var, dr) **
720
721 +* istemp(dr) = accss(di_temp, dr) **
722
723 +* isconst(dr) = accss(di_const, dr) **
724
725 +* isscon(dr) = accss(di_scon, dr) **
726
727 +* isind(dr) = (accss(di_anum, dr) ^= 0) **
728
729
730
731 $ macro -getwordc-.
732
733 $ this macro is called by a set of macros to address words or
734 $ parts of words. the first parameter of these macros is
735 $ the 'output' register, the second is the 'input' register,
736 $ the third is the word of character offst of the word or
737 $ character desired, and the fourth is the -dreg- number of an
738 $ optional index register.
739
740 $ ****** important note ******
741 $ [ds 11 apr ds will see kenner about this important note
742 $ and report back to mccann.]
743 $ the -getaddr- and -getword- calls return a form of
744 $ the input when there is no index. thus if the argument
745 $ is slated to be dropped, things will blow up. the solution
746 $ is not to drop the argument unless there is an index.
747 $ if ind is zero, then dritem(out) is same as dritem(in);
748 $ otherwise, a 'special' temporary is built. hennce can
749 $ cannot do lastuse(out) unless you mean lastuse(in) also.
750 +* getwordc(type, out, in, off, ind) = $ first parm. is type.
751 call getwordr(out, in, type, off, ind); ** $ call routine.
752
753
754 $ types for -getwordc-.
755
756 +* gw_word = 01 ** $ get word value.
757 +* gw_addr = 02 ** $ get word address.
758 +* gw_sword = 03 ** $ store word.
759
760 +* num_gw = 3 **
761
762 +* getword(out, in, off, ind) =
763 getwordc(gw_word, out, in, off, ind) **
764 +* getaddr(out, in, off, ind) =
765 getwordc(gw_addr, out, in, off, ind) **
766 +* storeword(out, in, off, ind) =
767 getwordc(gw_sword, out, in, off, ind) **
768
769
770 $ macro -branchop-.
771
772 $ this macro is used to generate a branch to a desired label.
773 $ the first parameter is the hardware condition code mask to
774 $ use for the branch and the second parameter is the label
775 $ number.
776
777 +* branchop(m, reg, lab) = call branchr(m, reg, lab); **
778
779
780 $ macros for emitting machine operations.
781
782 +* emop(op, oreg, imode, ireg, ioff) = $ emit basic machine op.
783 call emopr(op, oreg, imode, ireg, ioff); **
784
785
786 $ -move_op- macro.
787
788 $ this macro is used to move the contents of one dummy register
789 $ to another. the first operand is the output register and the
790 $ second is the input rwegister.
791
792 +* move_op(out, in) = call mover(out, in); **
793
794
795
796 $ -inzero- macro.
797
798 $ the macro is called to indicate that a value is present in
799 $ machine register zero. if the second operand is yes, the
800 $ address of the operand (assumed multi-word) is in reg zero.
801
802 +* inzero(dr, fl) = call inzeror(dr, fl); **
803
804
805 $ the mrcopy macros is used to copy one register to another.
806 +* mrcopy(a,b) = $ copy reg b to reg a.
807 if a^=b then $ copy only if regs differ.
808 emop(mo_ldw, a, am_reg, b, 0);
809 end if; **
810
811 $ the mrclear macro clears a register.
812 +* mrclear(a) = emop(mo_zew, a, am_reg, a, 0); **
813
814 $ -forcezero- macro.
815
816 $ this macro is used to force a variable into register zero,.
817 $ it is used in some function returns and for some special
818 $ calling sequences. the first parameter is the variable and
819 $ the second is a flag which is set if the address of the
820 $ variable is what is wanted in register zero.
821
822 +* forcezero(dr, fl) = call forcer(dr, fl); **
823
824
dss 14 +* labcol = 3 ** $ columns for label
dss 15 .+t32u +* labcol = 5 **
825
826 $ -labfree- macro.
827
828 $ this macro is used to release a label that was used
829 $ temporarily in a local fashion.
830
831 +* labfree(l) = $ free a label.
832 ; **
833
834
835
836 $ -labget- macro.
837
838 $ this macro gets a temporary label for local use.
839
840 +* labget(l) = $ get a temporary label.
841
842 countup(labluse, lablistdim, 'lablist');
843 l = labluse; $ set to gotten label.
844 lablist(l) = 0; $ clear label list entry.
845 **
846
847
848
849 $ -labdef- macro.
850
851 $ this macro is used to define the position of a label. the
852 $ first operand is the label number and the second operand is a
853 $ flag which is off when the label is only being used for
854 $ internal local purposes.
855
856 +* labdef(l, f) = call labdefr(l, f); **
857
858
859 $ -store- macro.
860
861 $ this macro is used to store the live data in the machine
862 $ register given by its first parameter into the dummy register
863 $ location indicated by its second parameter. status values
864 $ are reset appropriately.
865 $ see dropr, getwordr, storall, emitlong, emitsub, getdregr,
866 $ endsubr
867
868 +* store(mr, dr) = call storer(mr, dr); **
869
870
871
872 $ -getreg- macro.
873
874 $ this macro is used to obtain a register of a desired type.
875 $ the first parameter will contain the register obtained and
876 $ the second parameter is the type.
877 $ if no registers of
878 $ that type or lower are available, a value of zero will be
879 $ given for the register. specifying the type as a 'live'
880 $ type will ensure that a register will always be obtained.
881
882 +* getreg(mr, typ) = call getregr(typ); mr = gotreg;**
883
884
885
886 $ -lastdrop- macro.
887
888 $ this macro sees if this is last use of dummy register.
889
890 +* lastdrop(dr) =
891 ( (di_count ditem(dr_item dreg(dr))=1
892 & di_ldrop ditem(dr_item dreg(dr))
893 & di_luse ditem(dr_item dreg(dr)) ^= 0)
894 ! ismw(dr) ! isscon(dr) ) **
895
896
897 $ -dropform- macro.
898
899 $ this macro is used to drop a dummy register.
900
901 +* dropform(dr) =
902 if (dr_reg dreg(dr)) reglis(dr_reg dreg(dr)) = 0;
903
904 $ put this dummy register onto free list.
905 dreg(dr) = 0; $ clear out all status info.
906 dr_next dreg(dr) = dregfree; $ chain to rest of free list.
907 dregfree = dr; $ put onto free list.
908 **
909
910
911
912 $ -drop- macro.
913
914 $ this macro is used to drop an entire dummy register. it
915 $ drops all the forms in the chain and also, if there is one,
916 $ any deferred operations that this is the output of.
917
918 +* drop(dr) =
919 if (di_luse ditem(dr_item dreg(dr)) ^= 0) $ can drop.
920 call dropr(dr); $ call routine to drop.
921 **
922
923
924
925 $ -kill- macro.
926
927 $ this macro is the same as -drop- except that it does not
928 $ require that the generator have dropped the register. it
929 $ is used in place of -lastuse-, -drop- sequences.
930
931 +* kill(dr) = call dropr(dr); **
932
933
934
935 .+defer.
936 $ -dropdop- macro.
937
938 $ this macro drops a deferred operation. it will also drop any
939 $ registers that are inputs to that operation.
940
941 +* dropdop(dop) = dropdopflg = yes; call dropr(dop); **
942 ..defer
943
944
945
946 .+eab. $ put off until after bootstrap, no need for pairs now.
947 $ -getregpair- macro.
948
949 $ this macro is used to return a free even/odd pair of
950 $ registers. the even register is returned in the first
951 $ parameter. the other two parameters are registers that can
952 $ be used in the pair. both registers are freed and on hold
953 $ when returned and if either of the two registers matched one
954 $ of the registers that it was indicated can be used, that
955 $ register is dropped. note that no check is made for live
956 $ variable. this check is assumed to have been made previously.
957
958 +* getregpair(r, u1, u2) = $ get register pair.
959 call getrpair(u1, u2);
960 r = gotrpair; **
961 ..eab
962
963
964 $ -error- macro.
965
966 $ this macro is used by -outdata- to print error messages.
967 $ the first parameter is the error text and the second is the
968 $ -voa- pointer of the item referred to.
969
970 $ first, define error headings.
971 +* error_notice = ' ****error**** ' **
972 +* system_notice = '*system error* ' **
973
974 +* error(msg, ptr) =
975 terml(yes) textl(error_notice) textl(msg)
976 textl('. item = ') sdsname(dopsname, vv_naym voa(ptr))
977 textl(dopsname) endl terml(no)
978 errno = errno+1;
979 **
980
981 $ macro -baseprobe-.
982
983 $ these macros manipulate the base block. they will search
984 $ for an item in the base block and will put it there if it
985 $ is not already.
986
987 $ types for -baseprober-.
988
989 +* rp_normal = 1 ** $ normal search.
990 +* rp_addlab = 2 ** $ add to table with no search.
991 +* rp_nocomp = 3 ** $ no compare
992 +* rp_addbas = rp_addlab **
993 $ [ds 3 may addbas renamed addlab from s37 to s11.]
994
995 $ define codes for arrays to use for comparisons so that
996 $ the array need not be passed as a parameter.
997 +* ar_val = 1 ** $ constant value array.
998 +* ar_plist = 2 ** $ parameter array.
1000
1001 +* baseprobe(ptr, hcode, len, type, arrayp, array, arrmx) =
1002 rparrmx = arrmx; $ set global.
1003 call baseprober(rp_normal, ptr, hcode, len, type, arrayp,
1004 array); arrmx = rparrmx; ** $ call and reset global.
1005
1006 +* baseprobelab(ptr, addr) =
1007 call baseprober(rp_addlab, ptr, 0, 0, addr, 0, 0); **
1008
1009 +* baseprobenc(ptr, len, type, arrayp) = $ probe no compare
dsi 9 call baseprober(rp_nocomp, ptr, 0, len, type, arrayp ,0); **
1011
1012
1013
1014 +* rztok = 12 **
1015 +* qstok = 6 **
1016 +* sstok = 5 **
1017 +* dectok = 4 ** $ integer
1018 +* bittok = 8 ** $ bit
1019 +* realtok = 14 ** $ real
1020 +* strtok = 6 **
1021
1022 +* num_lt = 14 ** $ number of lexical types.
1023
1024 +* szmax = 2048 ** $ maximum size.
1025
1026 $ addressing modes
1027 +* am_reg = 0 ** $ ea is register number.
1028 +* am_rel = 1 ** $ ea is offset from index register
1029 +* am_mem = 2 ** $ ea is memory address.
1030 +* am_reli = 3 ** $ ea is indirect from offset in register
1031 +* num_am = 3 ** $ number of am modes.
1032
1033 $ fields of machine offste
vaxa 80 .+t10.
1034 +* mosize = 36 **
1035 +* mbo_off = .f. 01, 18, ** $ offset from block
1036 +* mbo_blk = .f. 19, 18, ** $ machine block.
vaxa 81 ..t10
vaxa 82 .+t32.
vaxa 83 +* mosize = 38 **
vaxa 84 +* mbo_off = .f. 1, 32, **
vaxa 85 +* mbo_blk = .f. 33, 6, **
vaxa 86 ..t32
1037
1038 /* t10 and dec10 addressing.
1039
1040 the am_ codes indicate addressing mode within this asm.
1041 address designated by triple
1042 where mode is one of the am_ modes, mreg is machine register,
1043 and moff is block and offset.
1044 mreg must always be specificed, to permit register tracking,
1045 even if actual register not needed to form address; this pseudo-
1046 register is the 'spare' register.
1047 moff consists of two fields, mbo_blk and mbo_blk, where mbo_blk
1048 is a 'machine block', and mbo_off specifies word offset in block.
1049 the am modes, and the ea obtained, are as follows:
1050
1051 am_reg ea is register mreg, moff ignored.
1052 am_rel ea is offset from index register - blk+off(mreg)
1053 am_mem ea is memory address: blk+off
1054 am_reli ea is indirect from offset of register: @blk+off(mreg)
1055
1056 short (1 to 18 bit) constants have am_mem, with mbo_blk of bl_imm
1057 and bl_off gives constant value.
1058
1059 the offset for multiword and array accesses may be negative, so
1060 that mbo_off and dw_madr may be negative.
1061 $ [ds 10 may need to elaborate this]
1062 */
1063 $ tmclt maps lexical types to desired conversion action
1064 +* tmc_i = 01 ** $ integer
1065 +* tmc_b = 02 ** $ bit
1066 +* tmc_c = 03 ** $ character (-r- type)
1067 +* tmc_r = 04 ** $ real token (not supported in bootstrap).
1068 +* tmc_s = 05 ** $ character string (-q- type)
1069
1070 +* num_tmc = 05 ** $ number of tmc codes.
1071
1072
1073 +* mblkname(i) = mblknames(i) **
1 .=member start
dsb 12 .+s10 prog start;
dsk 21 .+s32 prog start;
dsb 13 .+s66 subr start;
eaa 45
eaa 46 .+t20.
eaa 47 $ variables for extended addressing (t20).
eaa 48 size nsheap_opt(ws); $ nonzero if dynamic heap.
eaa 49 size nsheap_prm(.sds. filenamelen);
eaa 50 $ nsheap_this is nonzero if current procedure contains
eaa 51 $ to dynamic nameset. in this case nsheap_blk is mba index of the
eaa 52 $ dynamic nameset.
eaa 53 size nsheap_blk(ws);
eaa 54 size nsheap_this(1);
eaa 55 size nsheap_org(.sds. namelen); $ origin for nsheap (extended add
eaa 56 $ we need to consult 'getword' as an oracle to sort out indexed
eaa 57 $ dynamic heap assignments for extended addressing.
eaa 58 $ this is done using the following variables.
eaa 59 size asmflh_gwi(ps); $ input flag to getword
eaa 60 data asmflh_gwi = no;
eaa 61 size asmflh_gwo(ps); $ output from getword
eaa 62 size asmflh_mreg(ps); $ mreg from getword
eaa 63 size asmflh_moff(mosize); $ moff from getword
eaa 64 size asmflh_mode(ws); $ mode from getword
eaa 65 size asmflh_varext(ps); $ set if field assignment
eaa 66 ..t20
3 size asconstdb(1); $ drop bit for -asconst-.
4 size asconstreal(1); $ flags real constants for -asconst-.
5 size asconstreg(ps); $ output value from -asconst-.
6 size asconstspc(1); $ 'internal special case in -asconst-'
7 data asconstspc = no;
8 size asconstsz(ps); $ size of constant for -asconst-.
9 size assignreg(ps); $ output register from -assignr-.
dsq 59 size ats_opt(1); $ on to time stamp generated code
10 size baseblockfree(ps); $ last block in -baseblock- to be free.
11 size basefirst(ps); $ first block in -baseblock- chain.
12 size baselast(ps); $ last block in -baseblock- chain.
13 size baselastaddr(mps); $ highest address in -baseblock-.
14 size calldropgl(1); $ '-emitsub- should drop globals'
15 data calldropgl = no;
16 size callnodrop(1); $ '-emitsub- should not drop parms'
17 data callnodrop = no;
18 size codethis(ps); $ estimated code length.
19 size comptime(.sds. lstimelen); $ time of compilation.
20 data comptime = '' .pad. lstimelen;
21 size currsubname(.sds. namelen); $ current subroutine name
22 size ddblk(ps); $ data definition block.
23 size ddoff(mps); $ data definition offset.
24 $ dd variables used for declaration output.
25 size ddlt(ps); $ lexical type.
26 size ddnc(ps); $ length if character constant.
27 size ddnwds(ps); $ word count.
28 size ditemfree(ps); $ free list for -ditem-.
29 size doff(ps); $ offset for -asmxload- and others.
30 size dopcode(ps); $ operation code at deferring level.
31 size dopfbconst(1); $ 'first bit of extraction constant'
32 size dopfbm1(ps); $ -dreg- for first bit-1.
33 size dopfbm1val(ps); $ value of first bit - 1.
34 size dopfree(ps); $ free head for -dops-.
35 size dophasout(1); $ 'operation has output'
36 size dophold(ps); $ operation to re-issue is deferring.
37 size dopindx(ps); $ index register for .f.
38 size dopir(ps); $ first operand to -dop-.
39 size dopjr(ps); $ second operand to -dop-.
40 size dopkr(ps); $ third operand to -dop-.
41 size doplr(ps); $ fourth operand to -dop-.
42 size doplenconst(1); $ 'length operand of .f. is constant'
43 size doplenval(ps); $ value of length.
44 size dopnargs(ps); $ number of args for -dop-.
45 size dopnx(ps); $ number of extra arguments for -dop-.
46 size dopor(ps); $ output for -dop-.
47 size dopname(.sds. 6); dims dopname(num_do);
48 data
49 dopname(do_add) = 'add':
50 dopname(do_sub) = 'sub':
51 dopname(do_lt) = 'lt':
52 dopname(do_ge) = 'ge':
53 dopname(do_eq) = 'eq':
54 dopname(do_ne) = 'ne':
55 dopname(do_mul) = 'mul':
56 dopname(do_div) = 'div':
57 dopname(do_and) = 'and':
58 dopname(do_or) = 'or':
59 dopname(do_exor) = 'exor':
60 dopname(do_fcall) = 'fcall':
61 dopname(do_nb) = 'nb':
62 dopname(do_not) = 'not':
63 dopname(do_fb) = 'fb':
64 dopname(do_scall) = 'scall':
65 dopname(do_asin) = 'asin':
66 dopname(do_fasin) = 'fasin':
67 dopname(do_return) = 'return':
68 dopname(do_fext) = 'fext':
69 dopname(do_if) = 'if':
70 dopname(do_goto) = 'goto':
71 dopname(do_xload) = 'xload':
72 dopname(do_xasin) = 'xasin':
73 dopname(do_xfasin) = 'xfasin':
74 dopname(do_ifnot) = 'ifnot':
75 dopname(do_eext) = 'eext':
76 dopname(do_easin) = 'easin':
77 dopname(do_xeasin) = 'xeasin':
78 dopname(do_xsasin) = 'xsasin':
79 dopname(do_radd) = 'radd':
80 dopname(do_rsub) = 'rsub':
81 dopname(do_rlt) = 'rlt':
82 dopname(do_rge) = 'rge':
83 dopname(do_req) = 'req':
84 dopname(do_rne) = 'rne':
85 dopname(do_rmul) = 'rmul':
86 dopname(do_rdiv) = 'rdiv':
87 dopname(do_rusub) = 'rusub':
88 dopname(do_abs) = 'abs':
dsj 36 dopname(do_float) = 'rfi':
dsj 37 dopname(do_ifix) = 'ifr':
dsj 38 dopname(do_aint) = 'rtr':
dsj 39 dopname(do_amod) = 'rmo':
89 dopname(do_iabs) = 'iabs':
90 dopname(do_mod) = 'mod':
91 dopname(do_sign) = 'sign':
92 dopname(do_isign) = 'isign':
93 dopname(do_dim) = 'dim':
94 dopname(do_idim) = 'idim':
95 dopname(do_seq) = 'seq':
96 dopname(do_sne) = 'sne':
97 dopname(do_goby) = 'goby';
98 size dopsname(.sds. namelen); $ name of routine to call.
99 size doptr(ps); $ pointer to -dops-.
100 size dopvar(ps); $ extractor variable for .f.
101 size dopwork(ps); $ work register for -dop- level.
102 size dopxr(ps); $ extra arguments for -dop-.
103 dims dopxr(511); $ maximum number possible.
104 size dregfree(ps); $ head of -dreg- free list.
105 size dropdopflg(1); $ set for -dropr- to drop -dop-.
106 data dropdopflg = no;
107 size dwordfree(ps); $ free list for -dword-.
108 size emopparm1(ps), emopparm2(ps); $ extra parms. to -emopr-.
dst 25 .+enp.
dst 26 nameset nsenp;
dst 27 size enpara(.sds. 30); dims enpara(enpmax);
dst 28 size enptot(ws); data enptot = 0; $ total # of procs
dst 29 size enpopt(1); data enpopt=0;
dst 30 size enpfilename(.sds. filenamelen);
dst 31 size enpnotfound(ws); data enpnotfound = 0;
dst 32 size enpnum(ws); $ number of current procedure
dst 33 size enporg(ws); $ origin for assigned procedure numbers
dst 34 end nameset;
dst 35 ..enp
dsp 27 .+t10 size end_opt(.sds. namelen); $ end option
109 size errno(ps); $ number of detected errors.
110 data errno = 0;
111 size exitcode(ps); $ completion code for -asmexit-.
dsk 22 size fag_opt(ps); $ 'functions alter globals'
112 size gfoutr(ps); $ output from -getformr-.
113 size gotdreg(ps); $ return value from -getdregr-.
114 size gotreg(ps); $ return value from -getregr-.
115 size gotrpair(ps); $ return value from -getrpair-.
116 size iorc(ws); $ io return code.
117 size isinif(1); data isinif = no; $ -if- statement flag.
118 size isspecial(1); $ special case flag for -dop- level.
dsq 60 .+t32.
dsq 61 size iv_opt(ps); $ option for integer overflow trap.
dsq 62 ..t32
dss 16 .-t32u +* lablorg = 0 **
dss 17 .+t32u size lablorg(ps); data lablorg=0;
119 size labluse(ps); $ last used entry of -lablist-.
120 size lcs_opt(1); $ statistics listing option.
121 size loadlab(ps); $ maximum usage of -lablist- array.
122 data loadlab = 0;
123 size loadpd(ps); $ maximum usage of -pdlist- array.
124 data loadpd = 0;
125 size loadrlab(.sds. namelen); $ largest user of -lablist-.
126 data loadrlab = '';
127 size loadrpd(.sds. namelen); $ largest user of -pdlist-.
128 data loadrpd = '';
129 size loadrsub(.sds. namelen); $ largest user of -subname-.
130 data loadrsub = '';
131 size loadrval(.sds. namelen); $ routine which used most -val-.
132 data loadrval = '';
133 size loadsub(ps); $ maximum usage of -subname- array.
134 data loadsub = 0;
135 size loadval(ps); $ maximum usage of -val- array.
136 data loadval = 0;
137 size nextgfree(ps); $ next general register free.
dsu 34
dsu 35 $ nsheap_prm gives name of nameset to reference indirectly.
dsu 36 $ if null there is no dynamic indirection.
dsu 37 $ if indirection, nsheap_this is set if the current procedure
dsu 38 $ references the indirect nameset, and nsheap_blk is mba index
dsu 39 $ of the indirect nameset. nsheapreg_b is register reserved
dsu 40 $ to contain byte address of nameset, nsheapreg_w is register
dsu 41 $ reserved to contain word address.
dsu 42 $ generated code will generally use nsheapreg_w to address the
dsu 43 $ nameset since most instructions have longword context.
dsu 44 $ nsheap_byte is flag set when nsheapreg_b must be used.
dsu 45
dsu 46 .+t32h.
dsu 47 size nsheap_prm(.sds. filenamelen);
dsu 48 size nsheap_opt(ws);
dsu 49 size heapthis(ws); $ nonzero if heap references possible
dsu 50 size nsheap_blk(ws); $ nonzero if nsheap referenced in curr.
dsu 51 size nsheap_this(1); $ nonzero if dynamic refs possible
dsu 52 data nsheap_this = no;
dsu 53 size nsheap_byte(1); $ nonzero for byte addressing
dsu 54 data nsheap_byte = no;
dsu 55 size nsheapreg_w(ps); $ register with head address (word)
dsu 56 size nsheapreg_b(ps); $ register with heap address (byte address)
dsu 57 ..t32h
dst 36 size nspage_opt(ps);
138 size numcalls(ps); $ number of routine calls.
139 size ocs(.sds. 80); data ocs=''.pad.80;
140 size opt_d(1); $ 'do deferring optimization'
141 data opt_d = no; $ initially don't.
142 size opt_f(1); $ '-if- optimization in effect'
143 data opt_f = no; $ initially not.
144 size opt_l(1); $ 'label optimization in effect'
145 data opt_l = no; $ initially not.
146 size putcodei(ps); $ index for code output.
vaxa 87 .+t32 size regmask(rhihi); $ mask of registers used.
147 size reguseval(ps); $ for lru allocation of registers.
148 size reissuedop(1); $ 'issue current -dop- again'
149 size returnlab(ps); $ label for return operation.
150 size rparrsz(ws); $ size for base probe.
151 size rparrmx(ws); $ array maximum for base probe.
152 size spcdrop(1); $ 'special case in -dropr-'
153 data spcdrop = no; $ default is normal.
154 size strname(.sds. namelen); $ for temporary strings.
155 data strname = '';
156 size subrtype(ps); $ routine type (subr, fnct, or prog).
157 $ tmcval is used for constants in target machine form.
158 size tmctab(ps); dims tmctab(num_lt);
159 data tmctab(dectok) = tmc_i:
160 tmctab(bittok) = tmc_b:
161 tmctab(strtok) = tmc_s:
162 tmctab(rztok) = tmc_c:
163 tmctab(realtok)= tmc_r;
164
165 size tmcval(mws); dims tmcval(szmax/mws+1);
166 size tmcvalptr(ps); $ tmcval index.
167 size totglobs(ws); $ total length of globals.
168 size totlength(ws); $ total length of code.
169 size totns(ws); $ total number of namesets.
170 size totprocs(ws); $ total number of proceedures.
171 data totglobs = 0: totlength = 0:
172 totns = 0: totprocs = 0;
173 size trace_a(1); $ 'trace assembler ops'
174 size trace_any(1); $ set if some trace option is on.
175 size trace_c(1); $ 'trace generated code'
176 size trace_d(1); $ 'trace -dreg-s'
177 size trace_l(1); $ 'trace load cards'
178 size trace_o(1); $ 'trace -dop-s'
179 size trace_r(1); $ 'trace machine registers'
180 size trace_v(1); $ 'trace -voa-'
dsn 28 .+t10 size univfilename(.sds.filenamelen); $ universal file name.
dsn 29 .+t10 data univfilename = '' .pad.filenamelen;
183 size voaep(ps); $ current -voa- pointer.
184 size voahead(ps); $ list of -voa- operations.
185 size voalast(ps); $ last operation in chain.
186 size vopcode(ps); $ -voa- operation code.
187
188 $ definitions of tables defined passed by parser.
189
190 $ h a . hashed array.
191
192 $ all symbols
193 $ names, constants and expressions are entered in the ha, and
194 $ the ha index is main way item is referenced. the arglist
195 $ consists largely of ha indices.
196
197 $ the fields of the ha are as follows.
198 $ ep. the index of voa for this item.
199 $ var. 'is this a variable (ie. not operation) entry'.
200 $ hainuse. 'is this entry in use'
201 $ nayme. index in names array if variable name.
202 $ nchars. number of characters in name or constant.
203 $ labno. (for names only) lablist index if used as label.
204 $ namintern. 'is this a compiler generated name'
205 $ hascon. (for constants only) 'is this safe (short) constant'.
206 $ zerents. number of preceding empty ha entries (used to
207 $ pack ha when writing voa file).
208 $ varluse. last use in block of variable. (-voa- pointer)
209 $ tracef. 'is store trace in effect.'
210 $ chinxf. 'is check index option in effect.'
211
212 +* hasz = $ size of ha in bits
213 .+s66 60
dsk 23 .+s32 64
214 .+s37 64
215 .+s10 72
216 **
218 .+s66 nameset blank; $ keep in blank common on s66.
dso 12 size ha(hasz); dims ha(hadim);
220 .+s66 end nameset;
221
222 .+s66.
223 +* ha_ep = .f. 01, 12, **
224 +* ha_hascon = .f. 13, 01, **
225 +* ha_var = .f. 14, 01, **
226 +* ha_hainuse = .f. 15, 01, **
227 +* ha_nayme = .f. 16, 13, **
228 +* ha_labno = .f. 29, 10, **
229 +* ha_tracef = .f. 39, 01, **
230 +* ha_chinxf = .f. 40, 01, **
231 +* ha_namintern = .f. 41, 01, **
232 +* ha_zerents = .f. 42, 11, **
233 +* ha_varluse = .f. 42, 11, ** $ overlays -zerents-
234 +* ha_nchars = .f. 53, 08, **
235 ..s66
dsk 24 .+s32.
dsk 25 +* ha_hascon = .f. 1, 1, **
dsk 26 +* ha_var = .f. 2, 1, **
dsk 27 +* ha_tracef = .f. 3, 1, **
dsk 28 +* ha_chinxf = .f. 4, 1, **
dsk 29 +* ha_ep = .f. 5, 11, **
dsk 30 +* ha_namintern = .f. 16, 1, **
dsk 31 +* ha_zerents = .f. 17, 16, **
dsk 32 +* ha_varluse = .f. 17, 16, **
dsk 33 +* ha_nchars = .f. 33, 8, **
dsk 34 +* ha_labno = .f. 41, 9, **
dsk 35 +* ha_hainuse = .f. 50, 1, **
dsk 36 +* ha_nayme = .f. 54, 11, **
dsk 37 ..s32
236 .+s37.
237 +* ha_hascon = .f. 1, 1, **
238 +* ha_var = .f. 2, 1, **
239 +* ha_tracef = .f. 3, 1, **
240 +* ha_chinxf = .f. 4, 1, **
241 +* ha_ep = .f. 5, 11, **
242 +* ha_namintern = .f. 16, 1, **
243 +* ha_zerents = .f. 17, 16, **
244 +* ha_varluse = .f. 17, 16, **
245 +* ha_nchars = .f. 33, 8, **
246 +* ha_labno = .f. 41, 9, **
247 +* ha_hainuse = .f. 50, 1, **
248 +* ha_nayme = .f. 54, 11, **
249 ..s37
250 .+s10.
251 +* ha_ep = .f. 1, 18, **
252 +* ha_zerents = .f. 19, 18, **
253 +* ha_varluse = .f. 19, 18, **
254 +* ha_nayme = .f. 37, 11, **
255 +* ha_labno = .f. 48, 9, **
256 +* ha_nchars = .f. 57, 8, **
257 +* ha_hascon = .f. 65, 1, **
258 +* ha_var = .f. 66, 1, **
259 +* ha_tracef = .f. 67, 1, **
260 +* ha_chinxf = .f. 68, 1, **
261 +* ha_namintern = .f. 69, 1, **
262 +* ha_hainuse = .f. 70, 1, **
263 ..s10
264
265 size ha_0(ps); $ ha index of constant zero.
266 size ha_1(ps); $ ha index of constant one.
267
268
269 $ m b a . machine block array
270 size mbaptr(ps); data mbaptr=0; $ most recent entry in mba
271
272 +* mbasz = $ size of mba (m-achine b-lock a-rray)
273 .+s66 60
dsn 30 .+s32 96
dsn 31 .+s37 96
275 .+s10 72
276 **
277
278 size mba(mbasz); dims mba(mbadim); $ m-achine b-lock a-rray
279 data mba = 0(mbadim);
280
dsb 14 .+s10.
dsb 15 +* mb_len = .f. 1, 18, **
dsb 16 +* mb_org = .f. 19, 18, **
dsb 17 +* mb_ha = .f. 37, 18, **
dsm 9 +* mb_chain = .f. 55, 11, **
dsm 10 +* mb_used = .f. 66, 1, **
dsm 11 +* mb_def = .f. 67, 1, **
dsb 21 ..s10
dsk 39 .+s32.
dsk 40 +* mb_used = .f. 1, 1, ** $ 'block used in current routine'
dsk 41 +* mb_def = .f. 2, 1, ** $ 'block defined in this routine'
dsk 42 +* mb_ha = .f. 4, 11, ** $ -ha- index of block name.
dsn 32 +* mb_len = .f. 65, 32, ** $ length of block.
dsk 44 +* mb_org = .f. 33, 13, ** $ origin address of block.
dsk 45 +* mb_chain = .f. 46, 11, ** $ -voa- pointer to first var.
dsk 46 ..s32
dsk 47 .+s37.
dsk 48 +* mb_used = .f. 1, 1, ** $ 'block used in current routine'
dsk 49 +* mb_def = .f. 2, 1, ** $ 'block defined in this routine'
dsk 50 +* mb_ha = .f. 4, 11, ** $ -ha- index of block name.
dsn 33 +* mb_len = .f. 65, 32, ** $ length of block.
dsk 52 +* mb_org = .f. 33, 13, ** $ origin address of block.
dsk 53 +* mb_chain = .f. 46, 11, ** $ -voa- pointer to first var.
dsk 54 ..s37
281 .+s66.
282 +* mb_len = .f. 01, 20, **
283 +* mb_ha = .f. 21, 11, **
284 +* mb_used = .f. 32, 01, **
285 +* mb_org = .f. 33, 13, **
286 +* mb_def = .f. 46, 01, **
287 +* mb_chain = .f. 47, 11, **
288 ..s66
289
290 size mbanames(.sds. namelen);
291 dims mbanames(mbadim);
292 data mbanames(bl_base) = 'bas':
293 mbanames(bl_const)= 'con':
294 mbanames(bl_temp) = 'tmp':
dsq 63 .+t32u mbanames(bl_imm) = '$':
dsq 64 .+t32v mbanames(bl_imm) = '#':
295 mbanames(bl_local)= 'lcl';
296
297 size mblknames(.sds. namelen);
298 dims mblknames(mbadim);
299 data mblknames(bl_base) = 'bas':
300 mblknames(bl_const)= 'con':
301 mblknames(bl_temp) = 'tmp':
dsq 65 .+t32u mblknames(bl_imm) = '$':
dsq 66 .+t32v mblknames(bl_imm) = '#':
302 mblknames(bl_local)= 'lcl';
303
304
305 size moatab(ws); dims moatab(num_mo); $ mop attributes.
306 data
307 $ iw icb ici i
308 moatab(mo_ban) = 3b' 1 404 405 1':
309 moatab(mo_bfb) = 3b' 5 000 000 1':
310 moatab(mo_bnb) = 3b' 5 000 000 0':
311 moatab(mo_bno) = 3b' 1 000 000 0':
312 moatab(mo_bor) = 3b' 1 434 435 1':
313 moatab(mo_bxo) = 3b' 1 430 431 1':
314 moatab(mo_cal) = 3b' 3 000 000 0':
315 moatab(mo_ceq) = 3b' 1 000 000 1':
316 moatab(mo_cge) = 3b' 1 000 000 1':
317 moatab(mo_cgt) = 3b' 1 000 000 1':
318 moatab(mo_cle) = 3b' 1 000 000 1':
319 moatab(mo_clt) = 3b' 1 000 000 1':
320 moatab(mo_cne) = 3b' 1 000 000 1':
321 moatab(mo_iab) = 3b' 1 000 000 0':
322 moatab(mo_iad) = 3b' 1 270 271 1':
323 moatab(mo_iao) = 3b' 1 240 000 0':
324 moatab(mo_ico) = 3b' 1 210 000 0':
325 moatab(mo_idi) = 3b' 3 230 231 1':
326 moatab(mo_idt) = 3b' 1 000 000 1':
327 moatab(mo_ieq) = 3b' 4 000 000 1':
dsj 40 moatab(mo_ifr) = 3b' 1 000 000 0':
328 moatab(mo_ige) = 3b' 4 000 000 1':
329 moatab(mo_igt) = 3b' 4 000 000 1':
330 moatab(mo_ile) = 3b' 4 000 000 1':
331 moatab(mo_ilt) = 3b' 4 000 000 1':
332 moatab(mo_imo) = 3b' 3 000 000 1':
333 moatab(mo_imt) = 3b' 1 000 000 1':
334 moatab(mo_imu) = 3b' 1 220 221 1':
335 moatab(mo_ine) = 3b' 4 000 000 1':
336 moatab(mo_isi) = 3b' 4 000 000 1':
337 moatab(mo_iso) = 3b' 1 370 000 0':
338 moatab(mo_isu) = 3b' 1 274 275 1':
339 moatab(mo_jeq) = 3b' 1 000 000 0':
340 moatab(mo_jge) = 3b' 1 325 000 0':
341 moatab(mo_jgt) = 3b' 1 327 000 0':
342 moatab(mo_jle) = 3b' 1 323 000 0':
343 moatab(mo_jlt) = 3b' 1 321 000 0':
344 moatab(mo_jmn) = 3b' 1 320 000 0':
345 moatab(mo_jmp) = 3b' 1 324 000 0':
346 moatab(mo_jne) = 3b' 1 326 000 0':
347 moatab(mo_lda) = 3b' 1 000 000 0':
348 moatab(mo_ldf) = 3b' 1 000 000 0':
349 moatab(mo_ldl) = 3b' 1 534 555 0':
350 moatab(mo_ldr) = 3b' 2 550 551 0':
351 moatab(mo_ldw) = 3b' 1 200 201 1':
eaa 67 .+t20.
eaa 68 moatab(mo_lla) = 3b' 1 000 000 0':
eaa 69 ..t20
352 moatab(mo_lpr) = 3b' 2 000 000 0':
353 moatab(mo_mvw) = 3b' 5 000 000 0':
dsu 58 .+t32h.
dsu 59 moatab(mo_mvx) = 3b' 5 000 000 0':
dsu 60 ..t32h
354 moatab(mo_rab) = 3b' 1 000 000 0':
355 moatab(mo_rad) = 3b' 1 140 000 1':
356 moatab(mo_rco) = 3b' 1 210 000 0':
357 moatab(mo_rdi) = 3b' 2 170 000 1':
358 moatab(mo_req) = 3b' 4 000 000 1':
359 moatab(mo_ret) = 3b' 3 000 000 0':
dsj 41 moatab(mo_rfi) = 3b' 1 000 000 1':
360 moatab(mo_rge) = 3b' 4 000 000 1':
361 moatab(mo_rgt) = 3b' 4 000 000 1':
362 moatab(mo_rle) = 3b' 4 000 000 1':
363 moatab(mo_rlt) = 3b' 4 000 000 1':
364 moatab(mo_rmo) = 3b' 3 000 000 1':
365 moatab(mo_rmu) = 3b' 1 160 000 1':
366 moatab(mo_rne) = 3b' 4 000 000 1':
367 moatab(mo_rsi) = 3b' 1 000 000 1':
368 moatab(mo_rsu) = 3b' 1 150 000 1':
dsj 42 moatab(mo_rtr) = 3b' 1 000 000 0':
369 moatab(mo_spr) = 3b' 2 000 000 0':
370 moatab(mo_stf) = 3b' 1 000 000 0':
371 moatab(mo_stl) = 3b' 1 506 000 0':
372 moatab(mo_str) = 3b' 1 542 000 0':
373 moatab(mo_stw) = 3b' 1 202 000 0':
374 moatab(mo_zeb) = 3b' 4 251 000 1':
eaa 70 .+t20.
eaa 71 moatab(mo_hba) = 3b' 1 000 000 1':
eaa 72 moatab(mo_hbb) = 3b' 1 000 000 1':
eaa 73 moatab(mo_hbc) = 3b' 1 000 000 1':
eaa 74 ..t20
375 moatab(mo_zew) = 3b' 1 400 000 0';
376
377 size names(ws); dims names(namesdim); $ -names- array space.
378
379
380
381 size val(ws); dims val(valdim); $ -val- array space.
382 size valptr(ps); $ last index in -val-.
383
384 +* voafnct = 1 **
385 size voaptr(ps); $ pointer to last used item in -voa-.
386
387 +* voasz = $ size of voa entry.
388 .+s10 144
dsn 34 .+s32 192
dsn 35 .+s37 192
390 .+s66 120
391 **
392 .+s66 nameset blank;
393 size voa(voasz); dims voa(voadim);
394 .+s66 end nameset;
395
396 size voawrt(1); $ on if writing voa file
397 $ v o a f i e l d s
398
399 $ fields common to both -operation- and -quantity- operations
400
401 .+s66.
402 +* vv_deflev = .f. 1, 6, ** $ definition level
403 +* vv_keeb = .f. 7, 1, ** $ keep bit for holding till blkend
404 +* vv_naym = .f. 8, 10, ** $ ha ptr
405 +* vv_opb = .f. 18, 1, ** $ 'is this an operation'
406 +* vv_syze = .f. 19, 11, ** $ entry size in bits
407 +* vv_amode = .f. 118, 1, ** $ real or integer mode
408
409 $ voa field for -variable' or non-operation entries (opb = no)
410
411 +* vv_arb = .f. 30, 1, ** $ argument bit
412 +* vv_argno = .f. 31, 5, ** $ argument no of parameter
413 +* vv_const = .f. 36, 1, ** $ on if 'constant'
414 +* vv_dimn = .f. 37, 16, ** $ dimension of array (or 0 if no di
415 +* vv_vlen = .f. 55, 5, ** $ no of words in constant value
416 +* vv_temb = .f. 60, 1, ** $ on if 'temporary'
417 +* vv_voanl = .f. 61, 9, ** $ pointer to -nl- for global
418 +* vv_madr = .f. 70, 16, ** $ machine address of item
419 +* vv_mblk = .f. 86, 6, ** $ machine block of item
420 +* vv_type = .f. 92, 2, ** $ quantity type
421 +* vv_vbeg = .f. 94, 12, ** $ start of const val in -val- array
422 +* vv_signbit = .f.106,1, ** $ sign of constant (0=+, 1=-)
423 +* vv_lextype = .f. 107,5, ** $ lexical type of constant
424 +* vv_isafnct = .f. 113,1, ** $ set when name used as function n
425 +* vv_varnuse = .f. 114, 4, ** $ number of uses of var.
426 +* vv_varnusemax = 1b'1111' ** $ max of -varnuse- field
427 +* vv_isavar = .f. 119, 1, ** $ 'used as variable'
428 +* vv_frsdata = .f. 121, 11, ** $ pointer to first data op.
429 +* vv_ppdata = .f. 53, 1, ** $ possible permanent value
430 +* vv_inreg = .f. 61, 8, ** $ -dreg- containing item.
431
432 $ fields for operation type entries
433
434
435 +* vv_argbeg = .f. 30, 9, ** $ beginning of extra arguments
436 +* vv_arglen = .f. 39, 9, ** $ number of extra arguments
437 +* vv_db1 = .f. 49, 1, ** $ drop bit for input 1
438 +* vv_db2 = .f. 50, 1, ** $ drop bit for input 2
439 +* vv_db3 = .f. 51, 1, ** $ drop bit for input 3
440 +* vv_opcode = .f. 52, 7, **
441 +* vv_seblk = .f. 59, 1, ** $ indicates if scall ends block
442 +* vv_bytaln = .f. 60, 1, ** $ indicates char. extract or assign
443 +* vv_inp1 = .f. 61, 12, ** $ voa index of first input
444 +* vv_inp2 = .f. 73, 12, ** $ voa index of second input
445 +* vv_inp3 = .f. 85, 12, ** $ voa index of third input
446 +* vv_oup = .f. 97, 12, ** $ voa index of output
447 +* vv_lastuse = .f. 109, 9, **$ voa index of last use of op
448 +* vv_dboup = .e. 119, 01, ** $ drop bit if oup used as input.
449 ..s66
450
dsk 56 .+s32.
dsk 57 +* vv_amode = .f. 1, 1, ** $ arithmetic mode.
dsk 58 +* vv_keeb = .f. 2, 1, ** $ '-deflev- overflow'
dsk 59 +* vv_opb = .f. 3, 1, ** $ 'operation entry'
dsk 60 +* vv_naym = .f. 4, 10, ** $ -ha- index.
dsk 61 +* vv_syze = .f. 17, 16, ** $ size of item in bits.
dsk 62 +* vv_deflev = .f. 33, 6, ** $ definition level.
dsk 63
dsk 64 $ fields for variable operand entries.
dsk 65
dsk 66 +* vv_const = .f. 14, 1, ** $ 'operand is constant'
dsk 67 +* vv_temb = .f. 15, 1, ** $ 'operand is temporary'
dsk 68 +* vv_signbit = .f. 16, 1, ** $ sign bit.
dsk 69 +* vv_isafnct = .f. 39, 1, ** $ 'operand used as function'
dsk 70 +* vv_inreg = .f. 40, 8, ** $ -dreg- containing item.
dsk 71 +* vv_ppdata = .f. 48, 1, ** $ 'possible permanent value'
dsn 36 +* vv_dimn = .f. 129, 32, ** $ dimension of array.
dsk 73 +* vv_varnuse = .f. 65, 8, ** $ number of uses.
dsk 74 +* vv_mblk = .f. 73, 7, ** $ machine block number.
dsn 37 +* vv_madr = .f. 161, 32, ** $ machine address.
dsk 76 +* vv_frsdata = .f. 97, 12, ** $ pointer to first -data- op.
dsk 77 +* vv_vlen = .f. 97, 8, ** $ length in -val- array.
dsk 78 +* vv_lextype = .f. 105, 4, ** $ lexical type.
dsk 79 +* vv_argno = .f. 109, 5, ** $ argument number.
dsk 80 +* vv_arb = .f. 114, 1, ** $ 'operand is routine argument'
dsk 81 +* vv_type = .f. 115, 2, ** $ operand type.
dsk 82 +* vv_vbeg = .f. 117, 12, ** $ -val- pointer for constannts.
dsk 83
dsk 84 $ fields for operation entries.
dsk 85
dsk 86 +* vv_db1 = .f. 14, 1, ** $ 'last use of first operand'
dsk 87 +* vv_db2 = .f. 15, 1, ** $ 'last use of second operand'
dsk 88 +* vv_db3 = .f. 16, 1, ** $ 'last use of third operand'
dsk 89 +* vv_chain = .f. 17, 16, ** $ operation chain.
dsk 90 +* vv_arglen = .f. 39, 9, ** $ length of -xarg- entries.
dsk 91 +* vv_dboup = .f. 48, 1, ** $ 'last use of output'
dsk 92 +* vv_inp1 = .f. 49, 16, ** $ first input.
dsk 93 +* vv_inp2 = .f. 65, 11, ** $ second input.
dsk 94 +* vv_lastuse = .f. 76, 10, ** $ last use pointer.
dsk 95 +* vv_inp3 = .f. 86, 11, ** $ third input.
dsk 96 +* vv_opcode = .f. 97, 8, ** $ operation code.
dsk 97 +* vv_seblk = .f. 105, 1, ** $ 'call ends block'
dsk 98 +* vv_bytaln = .f. 106, 1, ** $ 'byte aligned'
dsk 99 +* vv_argbeg = .f. 107, 10, ** $ -xarg- pointer.
dsk 100 +* vv_oup = .f. 118, 11, ** $ output.
dsk 101 ..s32
dsk 102 .+s37.
dsk 103 +* vv_amode = .f. 1, 1, ** $ arithmetic mode.
dsk 104 +* vv_keeb = .f. 2, 1, ** $ '-deflev- overflow'
dsk 105 +* vv_opb = .f. 3, 1, ** $ 'operation entry'
dsk 106 +* vv_naym = .f. 4, 10, ** $ -ha- index.
dsk 107 +* vv_syze = .f. 17, 16, ** $ size of item in bits.
dsk 108 +* vv_deflev = .f. 33, 6, ** $ definition level.
dsk 109
dsk 110 $ fields for variable operand entries.
dsk 111
dsk 112 +* vv_const = .f. 14, 1, ** $ 'operand is constant'
dsk 113 +* vv_temb = .f. 15, 1, ** $ 'operand is temporary'
dsk 114 +* vv_signbit = .f. 16, 1, ** $ sign bit.
dsk 115 +* vv_isafnct = .f. 39, 1, ** $ 'operand used as function'
dsk 116 +* vv_inreg = .f. 40, 8, ** $ -dreg- containing item.
dsk 117 +* vv_ppdata = .f. 48, 1, ** $ 'possible permanent value'
dsn 38 +* vv_dimn = .f. 129, 32, ** $ dimension of array.
dsm 12 +* vv_varnuse = .f. 65, 8, ** $ number of uses.
dsm 13 +* vv_mblk = .f. 73, 7, ** $ machine block number.
dsn 39 +* vv_madr = .f. 161, 32, ** $ machine address.
dsm 15 +* vv_frsdata = .f. 97, 12, ** $ pointer to first -data- op.
dsm 16 +* vv_vlen = .f. 97, 8, ** $ length in -val- array.
dsm 17 +* vv_lextype = .f. 105, 4, ** $ lexical type.
dsm 18 +* vv_argno = .f. 109, 5, ** $ argument number.
dsm 19 +* vv_arb = .f. 114, 1, ** $ 'operand is routine argument'
dsm 20 +* vv_type = .f. 115, 2, ** $ operand type.
dsm 21 +* vv_vbeg = .f. 117, 12, ** $ -val- pointer for constannts.
dsk 129
dsk 130 $ fields for operation entries.
dsk 131
dsk 132 +* vv_db1 = .f. 14, 1, ** $ 'last use of first operand'
dsk 133 +* vv_db2 = .f. 15, 1, ** $ 'last use of second operand'
dsk 134 +* vv_db3 = .f. 16, 1, ** $ 'last use of third operand'
dsk 135 +* vv_chain = .f. 17, 16, ** $ operation chain.
dsk 136 +* vv_arglen = .f. 39, 9, ** $ length of -xarg- entries.
dsk 137 +* vv_dboup = .f. 48, 1, ** $ 'last use of output'
dsk 138 +* vv_inp1 = .f. 49, 16, ** $ first input.
dsk 139 +* vv_inp2 = .f. 65, 11, ** $ second input.
dsk 140 +* vv_lastuse = .f. 76, 10, ** $ last use pointer.
dsk 141 +* vv_inp3 = .f. 86, 11, ** $ third input.
dsk 142 +* vv_opcode = .f. 97, 8, ** $ operation code.
dsk 143 +* vv_seblk = .f. 105, 1, ** $ 'call ends block'
dsk 144 +* vv_bytaln = .f. 106, 1, ** $ 'byte aligned'
dsk 145 +* vv_argbeg = .f. 107, 10, ** $ -xarg- pointer.
dsk 146 +* vv_oup = .f. 118, 11, ** $ output.
dsk 147 ..s37
451 .+s37.
452 +* vv_amode = .f. 1, 1, **
453 +* vv_keeb = .f. 2, 1, **
454 +* vv_opb = .f. 3, 1, **
455 +* vv_naym = .f. 4, 10, **
456 +* vv_syze = .f. 17, 16, **
457 +* vv_deflev = .f. 33, 6, **
458
459 +* vv_const = .f. 14, 1, **
460 +* vv_temb = .f. 15, 1, **
461 +* vv_signbit = .f. 16, 1, **
462 +* vv_isafnct = .f. 39, 1, **
463 +* vv_voanl = .f. 40, 9, **
464 +* vv_dimn = .f. 49, 16, **
465 +* vv_type = .f. 65, 2, **
466 +* vv_vbeg = .f. 67, 12, **
467 +* vv_lextype = .f. 79, 5, **
468 +* vv_arb = .f. 84, 1, **
469 +* vv_isavar = .f. 85, 1, **
470 +* vv_vlen = .f. 89, 8, **
471 +* vv_madr = .f. 97, 16, **
472 +* vv_mblk = .f. 113, 8, **
473 +* vv_varnuse = .f. 121, 8, **
474 +* vv_varnusemax = 4b'ff' **
475
476 +* vv_db1 = .f. 14, 1, **
477 +* vv_db2 = .f. 15, 1, **
478 +* vv_db3 = .f. 16, 1, **
479 +* vv_arglen = .f. 39, 9, **
480 +* vv_dboup = .f. 48, 1, **
481 +* vv_inp1 = .f. 49, 16, **
482 +* vv_inp2 = .f. 65, 11, **
483 +* vv_lastuse = .f. 76, 10, **
484 +* vv_inp3 = .f. 86, 11, **
485 +* vv_opcode = .f. 97, 8, **
486 +* vv_seblk = .f. 105, 1, **
487 +* vv_bytaln = .f. 106, 1, **
488 +* vv_argbeg = .f. 107, 10, **
489 +* vv_oup = .f. 118, 11, **
490 ..s37
dsb 22 .+s10.
dsb 23 +* vv_amode = .f. 1, 1, **
dsb 24 +* vv_keeb = .f. 2, 1, **
dsb 25 +* vv_opb = .f. 3, 1, **
dsb 26 +* vv_naym = .f. 4, 10, **
dsb 27 +* vv_syze = .f. 17, 11, **
dsb 28 +* vv_deflev = .f. 28, 6, **
dsb 29
dsb 30 +* vv_const = .f. 14, 1, **
dsb 31 +* vv_temb = .f. 15, 1, **
dsb 32 +* vv_signbit = .f. 16, 1, **
dsb 33 +* vv_isafnct = .f. 37, 1, **
dsb 34 +* vv_inreg = .f. 38, 8, **
dsb 35 +* vv_ppdata = .f. 46, 1, **
dsb 36 +* vv_voanl = .f. 38, 9, **
dsb 37 +* vv_vlen = .f. 47, 8, **
dsb 38 +* vv_lextype = .f. 55, 4, **
dsb 39 +* vv_frsdata = .f. 47, 12, **
dsb 40 +* vv_argno = .f. 59, 5, **
dsb 41 +* vv_mblk = .f. 64, 6, **
dsb 42 +* vv_arb = .f. 70, 1, **
dsb 43 +* vv_isavar = .f. 71, 1, **
dsb 44 +* vv_type = .f. 73, 2, **
dsn 40 +* vv_dimn = .f. 75, 17, **
dsn 41 +* vv_madr = .f. 92, 17, **
dsm 22 +* vv_vbeg = .f. 109, 12, **
dsm 23 +* vv_varnuse = .f. 121, 8, **
dsb 49 +* varnusemax = 4b'ff' **
dsb 50
dsb 51 +* vv_db1 = .f. 14, 1, **
dsb 52 +* vv_db2 = .f. 15, 1, **
dsb 53 +* vv_db3 = .f. 16, 1, **
dsb 54 +* vv_arglen = .f. 37, 9, **
dsb 55 +* vv_dboup = .f. 46, 1, **
dsb 56 +* vv_inp1 = .f. 47, 11, **
dsb 57 +* vv_inp2 = .f. 58, 11, **
dsb 58 +* vv_seblk = .f. 69, 1, **
dsb 59 +* vv_bytaln = .f. 70, 1, **
dsb 60 +* vv_inp3 = .f. 73, 11, **
dsb 61 +* vv_lastuse = .f. 84, 10, **
dsb 62 +* vv_oup = .f. 94, 11, **
dsb 63 +* vv_opcode = .f. 109, 7, **
dsb 64 +* vv_argbeg = .f. 116, 10, **
dsb 65 ..s10
532
533 +* vv_chain = vv_syze ** $ used for operations.
534
535 $ to keep voa at two words for s66 bootstrap, the vv field
536 $ vv_frsdata is kept in separate array.
537 $ the conditional symbol vvfrs is on for separate frsdata.
538 .+s10.
539 .-set vvfrs
540 ..s10
541 .+s66.
542 .+set vvfrs
543 ..s66
544 .+vvfrs.
545 +* vv_frsdata = ** $ drop prior definition
546 +* vvfrsdata(i) =
547 .f. 1 + 16*((i) - 4*((i)/4)), 12, frsdataara(1+(i)/4) **
548 size frsdataara(ws); dims frsdataara((voadim)/4+2);
549 ..vvfrs
550 size voafilename(ws); $ name of voa file
551 $ v o a f i l e m a c r o s
552
553 +* vf_level = .e. 17, 16, ** $ julian date of last change
554 $ relative to 1 jan 1976 (ie, juliandate - 76000).
555 $ *** when change array size or fields, update version no. ***
556
557 $ codes for items in voa-file
558 +* vh_eof = 0 ** $ marks end of file
559 +* vh_hdr = 1 ** $ file header code
560 +* vh_asm = 2 ** $ routine header code
561 +* vh_voa = 3 ** $ voa
562 +* vh_ha = 4** $ ha
563 +* vh_names = 5 ** $ names array
564 +* vh_xarg = 6 ** $ xarg array
565 +* vh_val = 7 ** $ val array
566 +* vh_mba = 8 ** $ m-achine b-lock a-rray (mba)
567 +* vh_eos = 9 ** $ code for end of subprogram
568
569 +* num_vh = 9 **
570
dsk 148 .+s32.
dsk 149 $ first, fields common to all header entries
dsk 150 +* vf_code = .e. 1,16, ** $ code of item
dsk 151 +* vf_lo = .e.49,16, ** $ lo entry of array
dsk 152 $ for debugging
dsk 153 +* vf_hi = .e.65,16, ** $ high entry of array
dsk 154 +* vf_listcode = .e. 81, 01, ** $ on to list generated code.
dsk 155 $ to format of any item written to voa.
dsk 156 +* vf_hamax = .e. 97,16, ** $ hamax in gen
dsk 157 $ bits 113...128 reserved for future expansion
dsk 158
dsk 159 $ fields used to pass non/array args to assembler
dsk 160 +* vf_asmarg = .e. 129, 16,** $ assemblarg
dsk 161 +* vf_init = .e. 145, 16,** $ init
dsk 162 +* vf_lablistptr = .e. 161, 16, ** $ lablistptr
dsk 163 +* vf_sub1 = .e. 177, 16, ** $ subinfo(1), a name
dsk 164 +* vf_sub2 = .e. 193, 16, ** $ subinfo(2)
dsk 165 +* vf_sub3 = .e. 209, 16, ** $ subinfo(3)
dsk 166 +* vf_subrargs = .e. 225, 16, ** $ no. of arguments of current
dsk 167 $ routine
dsk 168 +* vf_ha0 = .e. 241, 16, ** $ ha index of constant 0.
dsk 169 +* vf_ha1 = .e. 257, 16, ** $ ha index of constant 1.
dsk 170 ..s32
571 .+s37.
572 $ first, fields common to all header entries
573 +* vf_code = .e. 1,16, ** $ code of item
574 +* vf_lo = .e.49,16, ** $ lo entry of array
575 $ for debugging
576 +* vf_hi = .e.65,16, ** $ high entry of array
577 +* vf_listcode = .e. 81, 01, ** $ on to list generated code.
578 $ to format of any item written to voa.
579 +* vf_hamax = .e. 97,16, ** $ hamax in gen
580 $ bits 113...128 reserved for future expansion
581
582 $ fields used to pass non/array args to assembler
583 +* vf_asmarg = .e. 129, 16,** $ assemblarg
584 +* vf_init = .e. 145, 16,** $ init
585 +* vf_lablistptr = .e. 161, 16, ** $ lablistptr
586 +* vf_sub1 = .e. 177, 16, ** $ subinfo(1), a name
587 +* vf_sub2 = .e. 193, 16, ** $ subinfo(2)
588 +* vf_sub3 = .e. 209, 16, ** $ subinfo(3)
589 +* vf_subrargs = .e. 225, 16, ** $ no. of arguments of current
590 $ routine
591 +* vf_ha0 = .e. 241, 16, ** $ ha index of constant 0.
592 +* vf_ha1 = .e. 257, 16, ** $ ha index of constant 1.
593 ..s37
594 .+s66.
595 +* vf_code = .e. 01, 06, ** $ code of item
596 +* vf_hdrseq = .e. 07, 18, ** $ header sequence number.
597 +* vf_es = .e. 25, 12, ** $ entry size in bits
598 +* vf_lo = .e. 37, 12, ** $ lo entry of array
599 +* vf_hi = .e. 49, 12, ** $ high entry of array
600 +* vf_listcode = .e. 61, 01, ** $ on to list generated code.
601 +* vf_hamax = .e. 62, 11, ** $ hamax in gen
602 +* vf_asmarg = .e. 73, 12,** $ assemblarg
603 +* vf_init = .e. 85, 12,** $ init
604 +* vf_lablistptr = .e. 97, 12, ** $ lablistptr
605 +* vf_sub1 = .e. 109, 12, ** $ subinfo(1), a name
606 +* vf_sub2 = .e. 121, 12, ** $ subinfo(2)
607 +* vf_sub3 = .e. 133, 12, ** $ subinfo(3)
608 +* vf_subrargs = .e. 145, 12, ** $ no. of arguments of current
609 $ routine
610 +* vf_ha0 = .e. 157, 12, ** $ ha index of constant 0.
611 +* vf_ha1 = .e. 169, 12, ** $ ha index of constant 1.
612 ..s66
613 .+s10.
614 +* vf_code = .f. 1, 18, **
615 +* vf_hdrseq = .f. 19, 18, **
616 +* vf_es = .f. 37, 18, **
617 +* vf_lo = .f. 55, 18, **
618 +* vf_hi = .f. 73, 18, **
619 +* vf_listcode = .f. 91, 1, **
620 +* vf_hamax = .f. 109, 18, **
621 +* vf_asmarg = .f. 127, 18, **
622 +* vf_init = .f. 145, 18, **
623 +* vf_lablistptr = .f. 163, 18, **
624 +* vf_sub1 = .f. 181, 18, **
625 +* vf_sub2 = .f. 199, 18, **
626 +* vf_sub3 = .f. 217, 18, **
627 +* vf_subrargs = .f. 235, 18, **
628 +* vf_ha0 = .f. 253, 18, **
629 +* vf_ha1 = .f. 271, 18, **
630 ..s10
631
632 +* vf_lablistp = vf_lablistptr ** $ rename with edit later.
633
634 $ values for routine type.
635
636 +* st_subr = 0 ** $ subroutine.
637 +* st_fnct = 1 ** $ function.
638 +* st_prog = 2 ** $ main program.
639
640 +* vofsz = $ size of voa header frame
641 .+s10 288
dsk 171 .+s32 256
dsk 172 .+s37 256
642 .+s66 240
643 **
644
645 size vof(vofsz); $ -voa- header frame.
646
647
648
649 $ x a r g. extra arguments array
dsn 42 +* xargsz = $ size of xarg array.
dsn 43 .+s10 ws
dsn 44 .+s32 64
dsn 45 .+s37 64
dsn 46 .+s66 ws
dsn 47 **
651 +* xargmax = 511 ** $ xarg dims
652 .+s66 nameset blank; $ keep in blank common on s66.
653 size xarg(xargsz); dims xarg(xargmax); $ extra arguments array
654 .+s66 end nameset;
655 size xargptr(ps); data xargptr = 1; $ ptr to xarg
656 $ fields of xarg array
657 $ xa_dbf is called xa_db.
658 .+s66.
659 +* xa_voa = .f. 16, 15, ** $ ptr to voa entry
660 +* xa_db= .f. 31, 1, **
661 +* xa_rep = .f. 1, 15, **
662 ..s66
dsk 173 .+s32.
dsk 174 +* xa_voa = .f. 1, 16, **
dsk 175 +* xa_db = .f. 17, 1, **
dsn 48 +* xa_rep = .f. 33, 32, **
dsk 177 ..s32
663 .+s37.
664 +* xa_voa = .f. 1, 16, **
665 +* xa_db = .f. 17, 1, **
dsn 49 +* xa_rep = .f. 33, 32, **
667 ..s37
668 .+s10.
dsn 50 +* xa_voa = .f. 1, 15, **
dsn 51 +* xa_rep = .f. 19, 18, **
dsn 52 +* xa_db = .f. 16, 1, **
672 ..s10
673
674 +* xa_arf = xa_voa ** $ rename with edit later.
675 .+defer.
676 $ -dops-
677
678 $ the -dops- array is used if deferring is set to hold
679 $ operations that have been deferred until a later time. these
680 $ operations are linked via the -dr_out- field of the dummy
681 $ register which is the output of an operation.
682
683 $ fields in -dops-.
684
685 +* dp_inp1 = .f. 01, 8, ** $ first input.
686 +* dp_inp2 = .f. 09, 8, ** $ second input.
687 +* dp_inp3 = .f. 17, 8, ** $ third input.
688 +* dp_oup = .f. 25, 8, ** $ output.
689 .+s10 +* dp_op = .f. 57, 8, ** $ operation code
dsk 178 .+s32 +* dp_op = .f. 33, 8, ** $ operation code
dsk 179 .+s37 +* dp_op = .f. 33, 8, ** $ operation code
690 .+s66 +* dp_op = .f. 33, 8, ** $ operation code
691 +* dp_chain = .f. 41, 8, ** $ points to next free entry.
692 +* dp_nargs = .f. 49, 8, ** $ number of arguments (0,1,2, or 3)
693
694 +* dopssz = $ size of dops
695 .+s10 72
dsk 180 .+s32 64
dsk 181 .+s37 64
696 .+s66 60
697 **
698
699 size dops(dopssz); dims dops(dopsdim);
700
701 ..defer
702
703 $ operands in the code generator are passed as dummy registers.
704 $ these dummy registers point to dummy words and dummy items.
705 $ a dummy item is, in a sense, a local copy of the -voa- entry
706 $ for that variable (if it is a variable). there is one dummy
707 $ word for each word of an item that has been used and there
708 $ may be many dummy registers for each word. one dummy register
709 $ for each word.
710
711 $ the dummy items, words, and, registers and chained and link
712 $ to and from each other. the information contained in each
713 $ block is that information which is common for all blocks
714 $ under it.
715
716 $ fields of -ditem-.
717
718 /*
719 di_chain is pointer to voa if di_baseblk is zero, or to voa
720 if di_baseblk is nonzer.
721 di_syze is item size.
722 di_scon is on if item is short constant (1 to 18 bits), in which
723 case di_cval is constant value.
724 di_nwords is number of machine words in item.
725 di_count is number of users of item.
726 di_addrreg is nonzero if address of item is in machine reg addrreg
727 di_out is deferred output ptr for dop.
728 di_luse is number of drops.
729 di_lword is start of -dword- chain.
730 di_mblk is machine block for item.
731 di_scon is nonzero if item is short constant, in which case
732 di_cval contains constant value.
733 di_mw is nonzero for multi-word item.
734 di_real is nonzero for real, or floating point, item.
735 di_baseblk is nonzero if di_chain points to baseblock, not voa.
736 di_array is nonzero if item is array.
737 di_temp is nonzero if item is temporary.
738 di_const is nonzero if item is constant.
739 di_var is nonzero if item is variable.
740 di_ldrop is nonzero if last use in voa.
741 di_anum is nonzero if item if procedure argument, and value gives
742 argument number.
743 */
744
745 +* di_luseminus1val = 4b'ff' ** $ to avoid overflow problem.
dsb 66 .+s10.
rkb 13 +* scs = 18 ** $ short constant size.
dsb 67 +* di_chain = .f. 01, 12, **
dsb 68 +* di_syze = .f. 13, 11, **
dsb 69 +* di_cval = .f. 127, 18, **
dsb 70 +* di_nwords = .f. 42, 08, **
dsb 71 +* di_count = .f. 50, 08, **
dsb 72 +* di_addrreg = .f. 61, 05, **
dsb 73 +* di_out = .f. 118, 08, **
dsb 74 +* di_luse = .f. 76, 08, **
dsb 75 +* di_lword = .f. 84, 08, **
dsb 76 +* di_mblk = .f. 92, 08, **
dsb 77 +* di_scon = .f. 100, 01, **
dsb 78 +* di_mw = .f. 101, 01, **
dsb 79 +* di_real = .f. 102, 01, **
dsb 80 +* di_baseblk = .f. 103, 01, **
dsb 81 +* di_array = .f. 104, 01, **
dsb 82 +* di_temp = .f. 105, 01, **
dsb 83 +* di_const = .f. 106, 01, **
dsb 84 +* di_var = .f. 107, 01, **
dsb 85 +* di_ldrop = .f. 109, 01, **
dsb 86 +* di_anum = .f. 110, 08, **
dsb 87 ..s10
dsk 182 .+s32.
rkb 14 +* scs = 16 ** $ short constant size.
dsk 183 +* di_chain = .f. 1, 16, ** $ ptr to -voa- or -baseblock-.
dsk 184 +* di_syze = .f. 17, 16, ** $ length in bits of item.
dsk 185 +* di_cval = .f. 33, 16, ** $ short constant value.
dsk 186 +* di_nwords = .f. 49, 8, ** $ number of words in item.
dsk 187 +* di_count = .f. 57, 8, ** $ number of users of item.
dsk 188 +* di_addrreg = .f. 65, 8, ** $ address register for item.
dsk 189 +* di_out = .f. 73, 8, ** $ deferred output of -dop-.
dsk 190 +* di_luse = .f. 81, 8, ** $ number of drops.
dsk 191 +* di_lword = .f. 89, 8, ** $ head of -dword- chain.
dsk 192 +* di_mblk = .f. 97, 8, ** $ machine block of item.
dsk 193 +* di_scon = .f. 105, 1, ** $ 'item is short constant'
dsk 194 +* di_mw = .f. 106, 1, ** $ 'item is multi-word'
dsk 195 +* di_real = .f. 107, 1, ** $ 'item is floating-point'
dsk 196 +* di_baseblk = .f. 108, 1, ** $ 'item is in base block'
dsk 197 +* di_array = .f. 109, 1, ** $ 'item is array'
dsk 198 +* di_temp = .f. 111, 1, ** $ 'item is temporary'
dsk 199 +* di_const = .f. 112, 1, ** $ 'item is constant'
dsk 200 +* di_var = .f. 113, 1, ** $ 'item is variable'
dsk 201 +* di_ldrop = .f. 115, 1, ** $ 'last use in -voa-'
dsk 202 +* di_anum = .f. 121, 8, ** $ argument number.
dsk 203 ..s32
dsk 204 .+s37.
rkb 15 +* scs = 16 ** $ short constant size.
dsk 205 +* di_chain = .f. 1, 16, ** $ ptr to -voa- or -baseblock-.
dsk 206 +* di_syze = .f. 17, 16, ** $ length in bits of item.
dsk 207 +* di_cval = .f. 33, 16, ** $ short constant value.
dsk 208 +* di_nwords = .f. 49, 8, ** $ number of words in item.
dsk 209 +* di_count = .f. 57, 8, ** $ number of users of item.
dsk 210 +* di_addrreg = .f. 65, 8, ** $ address register for item.
dsk 211 +* di_out = .f. 73, 8, ** $ deferred output of -dop-.
dsk 212 +* di_luse = .f. 81, 8, ** $ number of drops.
dsk 213 +* di_lword = .f. 89, 8, ** $ head of -dword- chain.
dsk 214 +* di_mblk = .f. 97, 8, ** $ machine block of item.
dsk 215 +* di_scon = .f. 105, 1, ** $ 'item is short constant'
dsk 216 +* di_mw = .f. 106, 1, ** $ 'item is multi-word'
dsk 217 +* di_real = .f. 107, 1, ** $ 'item is floating-point'
dsk 218 +* di_baseblk = .f. 108, 1, ** $ 'item is in base block'
dsk 219 +* di_array = .f. 109, 1, ** $ 'item is array'
dsk 220 +* di_temp = .f. 111, 1, ** $ 'item is temporary'
dsk 221 +* di_const = .f. 112, 1, ** $ 'item is constant'
dsk 222 +* di_var = .f. 113, 1, ** $ 'item is variable'
dsk 223 +* di_ldrop = .f. 115, 1, ** $ 'last use in -voa-'
dsk 224 +* di_anum = .f. 121, 8, ** $ argument number.
dsk 225 ..s37
746 .+s66.
rkb 16 +* scs = 18 ** $ short constant size.
747 +* di_chain = .f. 01, 12, **
748 +* di_syze = .f. 13, 11, **
749 +* di_cval = .f. 24, 18, **
750 +* di_nwords = .f. 42, 08, **
751 +* di_count = .f. 50, 08, **
752 +* di_addrreg = .f. 61, 05, **
753 +* di_out = .f. 66, 08, **
754 +* di_luse = .f. 76, 08, **
755 +* di_lword = .f. 84, 08, **
756 +* di_mblk = .f. 92, 08, **
757 +* di_scon = .f. 100, 01, **
758 +* di_mw = .f. 101, 01, **
759 +* di_real = .f. 102, 01, **
760 +* di_baseblk = .f. 103, 01, **
761 +* di_array = .f. 104, 01, **
762 +* di_temp = .f. 105, 01, **
763 +* di_const = .f. 106, 01, **
764 +* di_var = .f. 107, 01, **
765 +* di_ldrop = .f. 109, 01, **
766 +* di_anum = .f. 110, 08, **
767 ..s66
768
769 +* ditemsz = $ size of -ditem-
770 .+s10 144
dsk 226 .+s32 128
dsk 227 .+s37 128
771 .+s66 120
772 **
773
774 size ditem(ditemsz); dims ditem(ditemdim);
775
776
777 $ fields in -dword-.
778
vaxa 92 .+s66.
vaxa 93 .+t10.
779 +* dw_word = .f. 1, 18, ** $ word number in item (from left).
780 +* dw_madr = .f. 19, 18, ** $ machine addr or register offset.
781 +* dw_next = .f. 37, 8, ** $ index of next -dword- in chain.
782 +* dw_freg = .f. 45, 8, ** $ index of first -dreg- in chain.
vaxa 94 ..t10
vaxa 95 .+t32.
vaxa 96 +* dw_madr = .f. 1, 32, **
vaxa 97 +* dw_word = .f. 33, 18, **
vaxa 98 +* dw_next = .f. 61, 8, **
vaxa 99 +* dw_freg = .f. 69, 8, **
vaxa 100 ..t32
vaxa 101 ..s66
dsn 53 .+s10.
dsn 54 .+t10.
dsn 55 +* dw_word = .f. 1, 18, ** $ word number in item (from left).
dsn 56 +* dw_madr = .f. 19, 18, ** $ machine addr or register offset.
dsn 57 +* dw_next = .f. 37, 8, ** $ index of next -dword- in chain.
dsn 58 +* dw_freg = .f. 45, 8, ** $ index of first -dreg- in chain.
dsn 59 ..t10
dsn 60 .+t32.
dsn 61 +* dw_madr = .f. 1, 32, **
dsn 62 +* dw_word = .f. 33, 18, **
dsn 63 +* dw_next = .f. 61, 8, **
dsn 64 +* dw_freg = .f. 69, 8, **
dsn 65 ..t32
dsn 66 ..s10
dsk 228 .+s32.
dsk 229 +* dw_word = .f. 1, 16, ** $ word number in item (from left)
dsk 230 +* dw_next = .f. 17, 8, ** $ pointer to next -dword- in chain.
dsk 231 +* dw_freg = .f. 25, 8, ** $ pointer to -dreg-.
dsk 232 +* dw_madr = .f. 33, 32, ** $ machine addr or register offset.
dsk 233 ..s32
dsk 234 .+s37.
dsk 235 +* dw_word = .f. 1, 16, ** $ word number in item (from left)
dsk 236 +* dw_next = .f. 17, 8, ** $ pointer to next -dword- in chain.
dsk 237 +* dw_freg = .f. 25, 8, ** $ pointer to -dreg-.
dsk 238 +* dw_madr = .f. 33, 32, ** $ machine addr or register offset.
dsk 239 ..s37
784 +* dwordsz = $ size of -dword-
785 .+s10 72
dsk 240 .+s32 64
dsk 241 .+s37 64
vaxa 102 .+s66.
vaxa 103 .+t10 60
vaxa 104 .+t32 120
vaxa 105 ..s66
787 **
788
789 size dword(dwordsz); dims dword(dworddim);
790
791
792 $ fields in -dreg-.
793
794 $ dr_item - pointer to -ditem-
795 $ dr_word - pointer to -dword-.
796 $ dr next - next -dreg- in chain.
797 $ dr_reg - machine register containing form.
798 .+s10.
799 +* dr_item = .f. 01, 08, **
800 +* dr_word = .f. 09, 08, **
801 +* dr_next = .f. 17, 08, **
802 +* dr_reg = .f. 25, 08, **
803 ..s10
dsk 242 .+s32.
dsk 243 +* dr_item = .f. 1, 8, ** $ pointer to -ditem-.
dsk 244 +* dr_reg = .f. 9, 8, ** $ machine register containing form.
dsk 245 +* dr_word = .f. 17, 8, ** $ pointer to -dword-.
dsk 246 +* dr_next = .f. 25, 8, ** $ next -dreg- in chain.
dsk 247 ..s32
dsk 248 .+s37.
dsk 249 +* dr_item = .f. 5, 8, ** $ pointer to -ditem-.
dsk 250 +* dr_word = .f. 17, 8, ** $ pointer to -dword-.
dsk 251 +* dr_next = .f. 25, 8, ** $ next -dreg- in chain.
dsk 252 +* dr_reg = .f. 33, 8, ** $ machine register containing form.
dsk 253 ..s37
804 .+s66.
805 +* dr_item = .f. 01, 08, **
806 +* dr_word = .f. 09, 08, **
807 +* dr_next = .f. 17, 08, **
808 +* dr_reg = .f. 25, 08, **
809 ..s66
810
dsk 254 +* dregsz =
dsk 255 .+s66 60
dsk 256 .+s10 36
dsk 257 .+s32 32
dsk 258 .+s37 64
dsk 259 **
812
813 size dreg(dregsz); dims dreg(dregdim);
814
815 $ -reglis-
816
817 $ the entries is this table correspond to the real machine
818 $ register. they contain information used to allocate the
819 $ real machine registers to the dummy registers.
820
821 +* rl_content = .f. 01, 09, ** $ pointer to -dreg- that is
822 $ 'in' this register or, for
823 $ base types, the -madr/1024-.
824 +* rl_type = .f. 16, 04, ** $ type of item in register.
825 +* rl_subtype = .f. 16, 03, ** $ sub-type of item
826 +* rl_perm = .f. 19, 01, ** $ 'value is permanently in reg'
827 +* rl_hold = .f. 20, 01, ** $ hold bit.
828 +* rl_addrhold = .f. 21, 01, ** $ address hold bit.
829 +* rl_usevalue = .f. 22, 11, ** $ value for lru allocation
830
831 +* reglissz = 32 ** $ size of -reglis- array.
832
833 size reglis(reglissz); dims reglis(rhihi); $ machine reg. list
834
835
836 $ values of -rl_type- field.
837 $ note that the order of these types corresponds to increasing
838 $ priority of the register.
839
840 +* rt_dead = 00 ** $ register is empty
841 +* rt_address = 01 ** $ register contains address of variable
842 +* rt_need = 02 ** $ register contains needed value
843 +* rt_live = 03 ** $ register contains only copy of data
844 +* rt_liveaddr = 04 ** $ register contains only copy of address
845
846 $ the rest of the types are the same as above but are
847 $ permanently assigned.
848
849 +* rt_permresv = 8 ** $ permanent reserved value. (r13, etc.)
850 +* rt_perm = 8 + rt_need **
851 +* rt_permlive = 8 + rt_live **
852
853
854
855 $ -lablist-.
856
857 $ the -lablist- array is used to hold information about
858 $ labels in the routine being compiled.
859
860 .+labopt. $ used only if this option is on.
861 +* ll_count = .f. 1, 16, ** $ number of times label used.
862 +* ll_def = .f. 17, 16, ** $ -voa- operation defining label.
863 ..labopt
864
865 +* lablistsz = 32 ** $ size of -lablist-
866
867 size lablist(lablistsz); dims lablist(lablistdim);
868 size lablistptr(ps); $ pointer into -lablist-.
869
870 $ -pdlist-.
871
872 $ the -pdlist- array is used to hold the parameter lists
873 $ for all calls generated by the program.
874
dsk 260 .-s32.
875 +* pd_madr = .f. 1, 18, ** $ machine address of parameter.
876 +* pd_block = .f. 19, 8, ** $ machine block of parameter.
dsk 261 .+s32.
dsn 67 +* pd_madr = .f. 1, 32, **
dsn 68 +* pd_block = .f. 33, 32, **
dsk 264 ..s32
877
878+* pdlistsz = $ size of pdlist.
879 .+s10 ws
dsn 69 .+s32 64
881 .+s66 ws
882**
883 size pdlist(pdlistsz); dims pdlist(pdlistdim);
884 size pdlistp(ps); $ pointer to pdlist.
885
vaxa 106 .+t10 size longname(.sds. 6); $ long routine names.
vaxa 107 .+t32 size longname(.sds. namelen); $ long routine names.
887 dims longname(vo_sasin); $ highest entry used.
888
889 data $ initialize -longname- array.
890 +* long(en, n) = longname(en) = n **
891 $ since only standard form on s10, need full set of multi-word
892 $ comparison procedures.
893
vaxa 108 .+t10.
894 long(do_add, 'iadd$m'):
895 long(do_sub, 'isub$m'):
896 long(do_mul, 'imul$m'):
897 long(do_div, 'idiv$m'):
898 long(do_and, 'band$m'):
899 long(do_eq, 'bequ$m'):
900 long(do_ne, 'bneq$m'):
901 long(do_lt, 'bles$m'):
902 long(do_ge, 'bgeq$m'):
903 long(do_or, 'bior$m'):
904 long(do_exor, 'bxor$m'):
905 long(do_not, 'bnot$m'):
906 long(do_fb, 'bfir$m'):
dsc 10 long(do_nb, 'bnum$m'):
908
909 long(vo_sasin, 'casi$m'):
910 long(vo_ccat, 'ccat$m'):
911 long(vo_in, 'cind$m'):
912 long(vo_seq, 'cequ$m'):
913 long(vo_sext, 'cext$m'):
914 long(vo_easin, 'easi$m'):
915 long(vo_eext, 'eext$m');
vaxa 109 ..t10
vaxa 110 .+t32.
vaxa 111 long(do_add, 'iadd$mw'):
vaxa 112 long(do_sub, 'isub$mw'):
vaxa 113 long(do_mul, 'imul$mw'):
vaxa 114 long(do_div, 'idiv$mw'):
vaxa 115 long(do_and, 'band$mw'):
vaxa 116 long(do_eq, 'bequ$mw'):
vaxa 117 long(do_ne, 'bneq$mw'):
vaxa 118 long(do_lt, 'bles$mw'):
vaxa 119 long(do_ge, 'bgeq$mw'):
vaxa 120 long(do_or, 'bior$mw'):
vaxa 121 long(do_exor, 'bxor$mw'):
vaxa 122 long(do_not, 'bnot$mw'):
vaxa 123 long(do_fb, 'bfir$mw'):
vaxa 124 long(do_nb, 'bnum$mw'):
vaxa 125
vaxa 126
vaxa 127 long(vo_sasin, 'casi$mw'):
vaxa 128 long(vo_ccat, 'ccat$mw'):
vaxa 129 long(vo_in, 'cind$mw'):
vaxa 130 long(vo_seq, 'cequ$mw'):
vaxa 131 long(vo_sext, 'cext$mw'):
vaxa 132 long(vo_easin, 'easi$mw'):
vaxa 133 long(vo_eext, 'eext$mw');
vaxa 134 ..t32
916
917
918 size moptab(.sds. 3); dims moptab(num_mo);
919 data
920 moptab(mo_ban) = 'ban':
921 moptab(mo_bfb) = 'bfb':
922 moptab(mo_bnb) = 'bnb':
923 moptab(mo_bno) = 'bno':
924 moptab(mo_bor) = 'bor':
925 moptab(mo_bxo) = 'bxo':
926 moptab(mo_cal) = 'cal':
927 moptab(mo_ceq) = 'ceq':
928 moptab(mo_cge) = 'cge':
929 moptab(mo_cgt) = 'cgt':
930 moptab(mo_cle) = 'cle':
931 moptab(mo_clt) = 'clt':
932 moptab(mo_cne) = 'cne':
933 moptab(mo_iab) = 'iab':
934 moptab(mo_iad) = 'iad':
935 moptab(mo_iao) = 'iao':
936 moptab(mo_ico) = 'ico':
937 moptab(mo_idi) = 'idi':
938 moptab(mo_idt) = 'idt':
939 moptab(mo_ieq) = 'ieq':
dsj 43 moptab(mo_ifr) = 'ifr':
940 moptab(mo_ige) = 'ige':
941 moptab(mo_igt) = 'igt':
942 moptab(mo_ile) = 'ile':
943 moptab(mo_ilt) = 'ilt':
944 moptab(mo_imo) = 'imo':
945 moptab(mo_imt) = 'imt':
946 moptab(mo_imu) = 'imu':
947 moptab(mo_ine) = 'ine':
948 moptab(mo_isi) = 'isi':
949 moptab(mo_iso) = 'iso':
950 moptab(mo_isu) = 'isu':
951 moptab(mo_jeq) = 'jeq':
952 moptab(mo_jge) = 'jge':
953 moptab(mo_jgt) = 'jgt':
954 moptab(mo_jle) = 'jle':
955 moptab(mo_jlt) = 'jlt':
956 moptab(mo_jmn) = 'jmn':
vaxa 135 .+t10 moptab(mo_jmp) = 'jmp':
vaxa 136 .+t32 moptab(mo_jmp) = 'jma':
958 moptab(mo_jne) = 'jne':
959 moptab(mo_lda) = 'lda':
960 moptab(mo_ldf) = 'ldf':
961 moptab(mo_ldl) = 'ldl':
962 moptab(mo_ldr) = 'ldr':
963 moptab(mo_ldw) = 'ldw':
eaa 75 .+t20.
eaa 76 moptab(mo_lla) = 'lla':
eaa 77 ..t20
964 moptab(mo_lpr) = 'lpr':
965 moptab(mo_mvw) = 'mvw':
dsu 61 moptab(mo_mvx) = 'mvx':
966 moptab(mo_rab) = 'rab':
967 moptab(mo_rad) = 'rad':
968 moptab(mo_rco) = 'rco':
969 moptab(mo_rdi) = 'rdi':
970 moptab(mo_req) = 'req':
971 moptab(mo_ret) = 'ret':
dsj 44 moptab(mo_rfi) = 'rfi':
972 moptab(mo_rge) = 'rge':
973 moptab(mo_rgt) = 'rgt':
974 moptab(mo_rle) = 'rle':
975 moptab(mo_rlt) = 'rlt':
976 moptab(mo_rmo) = 'rmo':
977 moptab(mo_rmu) = 'rmu':
978 moptab(mo_rne) = 'rne':
979 moptab(mo_rsi) = 'rsi':
980 moptab(mo_rsu) = 'rsu':
dsj 45 moptab(mo_rtr) = 'rtr':
981 moptab(mo_spr) = 'spr':
982 moptab(mo_stf) = 'stf':
983 moptab(mo_stl) = 'stl':
vaxa 137 .+t10 moptab(mo_str) = 'str':
vaxa 138 .+t32 moptab(mo_xjm) = 'xjm':
985 moptab(mo_stw) = 'stw':
986 moptab(mo_zeb) = 'zeb':
eaa 78 .+t20.
eaa 79 moptab(mo_hba) = 'hba':
eaa 80 moptab(mo_hbb) = 'hbb':
eaa 81 moptab(mo_hbc) = 'hbc':
eaa 82 ..t20
987 moptab(mo_zew) = 'zew';
988
989 $ -baseblock-
990
991 $ this table is used to create a map of the base block
992 $ addressed by base. it is a hashed table containing addresses,
993 $ some local variables, some temporaries, parameter lists,
994 $ and single-word constants. it uses a link for hash clashes
995 $ and is threaded by order of address in block. (note that this
996 $ corresponds to the order in which entries are inserted into
997 $ this table.)
998
999
1000 $ fields of -baseblock-.
1001
1002 .+s10.
1003 +* bb_chain = .f. 01, 09, ** $ next entry in block by address
1004 +* bb_link = .f. 10, 09, ** $ link for hash clashes.
1005 +* bb_type = .f. 19, 03, ** $ type of item in block.
1006 +* bb_nwords = .f. 22, 05, ** $ length (in words) of item.
1007 +* bb_bptr = .f. 37, 11, ** $ back pointer. (-dreg- or -voa-)
1008 +* bb_pointer = .f. 48, 11, ** $ pointer depending on type.
1009 +* bb_addr = .f. 59, 10, ** $ offset of item in base block.
1010 ..s10
dsk 266 .+s32.
dsk 267 +* bb_chain = .f. 01, 09, ** $ next entry in block by address
dsk 268 +* bb_link = .f. 10, 09, ** $ link for hash clashes.
dsk 269 +* bb_type = .f. 19, 03, ** $ type of item in block.
dsk 270 +* bb_nwords = .f. 22, 05, ** $ length (in words) of item.
dsk 271 +* bb_bptr = .f. 33, 11, ** $ back pointer. (-dreg- or -voa-)
dsk 272 +* bb_pointer = .f. 44, 11, ** $ pointer depending on type.
dsk 273 +* bb_addr = .f. 55, 10, ** $ offset of item in base block.
dsk 274 ..s32
1011 .+s66.
1012 +* bb_chain = .f. 01, 09, ** $ next entry in block by address
1013 +* bb_link = .f. 10, 09, ** $ link for hash clashes.
1014 +* bb_type = .f. 19, 03, ** $ type of item in block.
1015 +* bb_nwords = .f. 22, 05, ** $ length (in words) of item.
1016 +* bb_bptr = .f. 27, 11, ** $ back pointer. (-dreg- or -voa-)
1017 +* bb_pointer = .f. 38, 11, ** $ pointer depending on type.
1018 +* bb_addr = .f. 49, 10, ** $ offset of item in base block.
1019 ..s66
1020
1021 +* baseblocksz = $ size of entry in bits.
1022 .+s10 72
dsk 275 .+s32 64
dsk 276 .+s37 64
1023 .+s66 60
1024 **
1025
1026 +* baseblockdim = 511 **
1027 +* baseblockprime = 499 **
1028 size baseblock(baseblocksz); dims baseblock(baseblockdim);
1029
1030 $ types used in -bb_type-
1031 +* bt_label = 1 ** $ label address. -bb_pointer- is -lablist-
1032 $ index.
1033 +* bt_const = 2 ** $ entry is single-word constant.
1034 $ -bb_pointer- is -val- index.
1035 +* bt_plist = 3 ** $ parameter list. -bb_pointer- points
1036 $ into -pdlist-.
1037
1038 +* bt_temp = 4 ** $ temporary.
1039 +* num_bt = 4 **
1040
1041
pic 9 .+s32.
pic 10 size pic_case(ps); data pic_case=no;
pic 11 size pic_char(cs);
pic 12 ..s32
1042
1043
1044
1045 size xx(1); data xx=yes; $ to force correct s37 load order.
1046 $ this required since otherwise dead code that sould be
1047 $ retained for correct load is eliminated.
1048 call asmini; $ initialize everything.
1049 while xx; $ loop until stopped.
1050 call setup; $ initialize for generation.
1051 call asmprog; $ generate code.
1052 call endsubr; $ terminate code for routine.
1053 end while;
1054
1055 $ ***** no exit to here expected. ****
1056
1057 exitcode = 0; call asmexit; $ for lked.
1058
dsb 89 .+s10 end prog start;
dsk 277 .+s32 end prog start;
dsb 90 .+s66 end subr start;
1 .=member asmini
2 subr asmini; $ code generator initialization.
3 $ this is the initialization routine for the code generator
4 $ which is entered first. it reads parameters, initializes
5 $ some tables, and opens files.
6 size i(ps), j(ps), flg(1); $ temporaries.
7 size cval(ws); $ constant value for 'pc' option.
8 size lnta(ps); dims lnta(8); $ array for -lntime-.
9 size lcp_opt(1); $ compiler parameter listing option.
11 size optval(.sds. namelen); $ options desired.
dsn 70 size voafilename(.sds.filenamelen); $ -voa- file name.
dsn 71 size codefilename(.sds.filenamelen); $ loader input file name.
dsn 72 size appstr(.sds. getapp_len); $ actual parameter string.
14
15 call lstime(comptime);
16
dsq 67 call getipp(ats_opt, 'ats=1/0'); $ get time stamp option.
dsq 68
17 $ generate local names for global blocks.
18 file ocsfile title=ocs, access=string, linesize=80;
19 do i = bl_global to mbadim;
20 put ocsfile ,column(1) ,'g' :i,i(2,2);
21 mblknames(i) = .s. 1, 3, ocs;
22 end do;
23 call ocsput(0, 2); $ clear code string.
24
25 $ read parameters.
dsn 73 .+s10 call getspp(voafilename, 'voa=*.voa/');
dsk 278 .+s32 call getspp(voafilename, 'voa=voa.tmp/,');
dsb 92 .+s66 call getspp(voafilename, 'voa=voa/');
28
dsn 74 .+s10 call getspp(codefilename, 'code=*.mac/');
dsk 280 .+s32 call getspp(codefilename, 'code=little.cod/');
dsb 95 .+s66 call getspp(codefilename, 'code=code/');
30 call getspp(optval, 'opt=dfl/');
31 $ [ds 2 jun 78 optimizations on by default, as they
32 $ were enabled for nyu checkout.]
33 .+defer.
34 .+ifopt opt_f = ('f' .in. optval) ^= 0;
35 ..defer opt_d = ('d' .in. optval) ^= 0 ! opt_f;
36 .+labopt opt_l = ('l' .in. optval) ^= 0;
37
38 .+trace. $ process trace parameter.
39 call getspp(optval, 'trace=/acdorv');
40 trace_a = ('a' .in. optval) ^= 0;
41 trace_c = ('c' .in. optval) ^= 0;
42 trace_d = ('d' .in. optval) ^= 0;
43 trace_l = ('l' .in. optval) ^= 0;
44 trace_o = ('o' .in. optval) ^= 0;
45 trace_r = ('r' .in. optval) ^= 0;
46 trace_v = ('v' .in. optval) ^= 0;
47
48 trace_any = (trace_a ! trace_c ! trace_d ! trace_l ! trace_o !
49 trace_r ! trace_v);
50 ..trace
51
vaxa 139 .+t10.
52 $ parameter unv names universal file. if not null, then
53 $ each t10 procedure will begin with search ufn
54 $ command where ufn is universal file name.
55
56 call getspp(univfilename, 'unv=t10mac/');
dsp 28
dsp 29 $ parameter end permits generation of end directive at end
dsp 30 $ of code file, for example end=prg yields endprg as last line
dsp 31 $ if end=0 specified, no special last line is generated.
dsp 32 call getspp(end_opt,'end=prg/seg');
dsp 33
vaxa 140 ..t10
57
dsq 69 .+t32 call getipp(iv_opt, 'iv=0/1'); $ integer overflow enable
58 call getipp(lcs_opt, 'lcs=1/0');
59 call getipp(lcp_opt, 'lcp=1/0');
dsvb 14 .+s32u.
dsq 71 $ quiet listing by default.
dsq 72 call getipp(lcs_opt, 'lcs=0/1');
dsq 73 call getipp(lcp_opt, 'lcp=0/1');
dsvb 15 ..s32u
60
eaa 83 .+t20.
eaa 84 call getspp(nsheap_prm,'nsheap=/nsheap');
eaa 85 if .len. nsheap_prm then $ if want dynamic heap
eaa 86 nsheap_opt = 1;
eaa 87 call stuc(nsheap_prm); $ fold name to primary case
eaa 88 call getspp(nsheap_org,'nshorg=^o2000001/');
eaa 89 else
eaa 90 nsheap_opt = 0;
eaa 91 end if;
eaa 92 ..t20
dsu 62 .+t32h.
dsu 63 call getspp(nsheap_prm,'nsheap=/nsheap');
dsu 64 if .len. nsheap_prm then $ if want dynamic heap
dsu 65 nsheap_opt = 1;
dsu 66 else
dsu 67 nsheap_opt = 0;
dsu 68 end if;
dsu 69 ..t32h
dsk 281 call getipp(fag_opt, 'fag=0/1');
dst 37 call getipp(nspage_opt,'nspage=0/1'); $ page alignment opt.
dsn 75
dsn 76 $ get actual parameters specified.
dsn 77 call getapp(appstr, getapp_len);
dsn 78
61 $ open files.
63 file voafile access=read, title=voafilename;
dsk 282 call dropsio(voafile, i); $ set to delete voa file.
eaa 93 .+s66 rewind voafile;
65 if codefile ^= 2 then $ if separate code file.
66 file codefile access=put, title=codefilename,linesize=80;
67 end if;
dst 38 .+enp.
dst 39 call getspp(enpfilename, 'enp=0/t.rep');
dsta 1 call getipp(enporg, 'enporg=0/0');
dst 41 if enpfilename .sne. '0' then $ if enp file wanted
dst 42 enpopt = yes;
dst 43 file enpfile access= get, title=enpfilename;
dst 44 while 1;
dst 45 size enpent(.sds. 20);
dst 46 size enptyp(.sds. 16);
dst 47 get enpfile ,skip :enptyp,a(16) :enpent,a(20);
dst 48 if filestat(enpfile,end) then quit; end if;
dst 49 if enptyp .sne. ' p ' then cont; end if;
dst 50 countup(enptot, enpmax, 'enp readin');
dst 51 size enpl(ps),brkc(ws);
dst 52 enpl = brkc(enpent,1, 1r,);
dst 53 if enpl>0 then .len. enpent = enpl; end if;
dst 54 enpara(enptot) = enpent;
dst 55 end while;
dst 56 end if;
dst 57 ..enp
dst 58
68 $ set up titling.
69 call ltitlr(assemblerlevel);
70 call stitlr(0, 'little compilation - code generation phase.');
71
72 $ list parameters, if desired.
73 if lcp_opt then $ parameter list wanted.
74 call stitlr(1, 'parameters for this code generation.');
dsn 80
dsn 81 if .len. appstr then $ if any explicitly specified.
dsn 82 textl(appstr) endl endl
dsn 83 end if;
dsn 84
75 textl('voa file name: voa = ') textl(voafilename)
76 textl('. code file name: code = ') textl(codefilename)
81 charl(1r.) endl
82
vaxa 141 .+t10.
dsp 34 textl('end line: end = ')
dsp 35 textl(end_opt)
dsp 36 textl('.' )
83 if (.len. univfilename) then $ if universal file.
84 textl('universal file: unv = ')
dsp 37 textl(univfilename) textl('.')
86 end if;
dsp 38 endl
eaa 94
eaa 95 .+t20.
eaa 96 textl('nsheap: nsheap = ') textl(nsheap_prm)
eaa 97 textl('. nsheap origin: nshorg = ')
eaa 98 textl(nsheap_org) textl('.') endl
eaa 99 ..t20
dsu 70 .+t32h.
dsu 71 textl('nsheap: nsheap = ') textl(nsheap_prm)
dsu 72 textl('.') endl
dsu 73 ..t32h
eaa 100
vaxa 142 ..t10
87 textl('optimizations to be performed: opt = ')
88 .+defer. if (opt_d) charl(1rd)
89 .+ifopt if (opt_f) charl(1rf)
90 ..defer
91 .+labopt if (opt_l) charl(1rl)
92 if (opt_d+opt_l = 0) charl(1r0)
93
94 .+trace.
95 if trace_any then $ print trace options.
96 textl('. tracing options: trace = ')
97 if (trace_a) charl(1ra)
98 if (trace_c) charl(1rc)
99 if (trace_d) charl(1rd)
100 if (trace_l) charl(1rl)
101 if (trace_o) charl(1ro)
102 if (trace_r) charl(1rr)
103 if (trace_v) charl(1rv)
104 end if;
105 ..trace
106
dsk 283 charl(1r.) endl
dsq 75 textl('time stamp: ats = ')
dst 59 intlp(ats_opt, 1) textl('. nspage: nspage = ')
dst 60 intlp(nspage_opt,1) charl(1r.)
dst 61 endl
dsk 284
dsk 285 textl('functions alter globals: fag = ') intlp(fag_opt, 1)
dsq 77 .+t32 textl('. iv: iv = ') intlp(iv_opt,1)
dsk 286 charl(1r.) endl endl
108 end if;
109
110
111
112 $ if statistics are desired, write headers.
113 if lcs_opt then $ write header.
114 call stitlr(1, 'statistics and error messages.');
115 endl textl('procedure')
116 tabl(30) textl('const')
117 tabl(40) textl(' base')
118 tabl(50) textl(' code')
119 tabl(60) textl('local')
120 tabl(70) textl('temps')
121 tabl(90) textl('module')
122 tabl(100) textl('global')
123 endl endl
124 else $ write different subtitle.
125 call stitlr(1, 'error messages.');
126 end if;
127
128
129
130
131 end subr asmini;
1 .=member setup
2 subr setup; $ initialize to process a new subroutine.
3 $ this routine is called to begin processing a new routine.
4 $ it initializes tables, reads data from the -voa- file, and
5 $ emits the initial routine starting code. in addition, this
6 $ routine decides which variables or base addresses should be
7 $ permanently assigned to a register and assigns them if any
8 $ are to be assigned.
9 size i(ps), j(ps), k(ps); $ temporaries.
10 size namep(ps); $ pointer to routine name.
11 size numargs(ps); $ number of arguments to routine.
12 size hap(ps); $ -ha- pointer.
13 size haent(hasz); $ -ha- entry.
14 size reg(ps); $ -dreg- used for peramanent value.
15 size flg(1); $ flag array for permanent assignment.
16 size addr(mps); $ machine address.
17 size mblk(ps); $ machine block.
18 size tempaddr(mps); $ address in temporary block.
19 size numglobs(ps); $ number of globals.
20 size totcnt(ps); $ total count for modes.
21 size lastcnst(ps); $ last constant entry so far.
dsj 46 size moff(mosize); $ address offset.
22
23
24 $ the first thing to do is to initialize the tables used for
25 $ generating code for a routine.
26
27 $ first, clear the -dreg- table by putting all entries on the
28 $ free chain.
29 do i = 1 to dregdim-1; $ scan over all but last.
30 dr_next dreg(i) = i+1; $ chain to next.
31 end do;
32 dr_next dreg(dregdim) = 0; $ show end of chain.
33 dregfree = 1; $ show first is free.
34
35 $ clear the -dword- table.
36 do i = 1 to dworddim-1; $ scan all but last.
37 dw_next dword(i) = i+1; $ build free chain.
38 end do;
39 dw_next dword(dworddim) = 0; $ show last in chain.
40 dwordfree = 1; $ show first is free.
41
42 $ do the same for -ditem-.
43 do i = 1 to ditemdim-1; $ scan all but last.
44 di_out ditem(i) = i+1; $ chain to next.
45 end do;
46 di_out ditem(ditemdim) = 0; $ show last in chain.
47 ditemfree = 1; $ show first is free.
48
49 do i = 1 to baseblockdim; baseblock(i) = 0; end do;
50
51 baseblockfree = baseblockdim;
52 basefirst = 0; baselast = 0; baselastaddr = 1;
53
54 codethis = 0; $ clear estimated length of code.
55
56 .+defer. $ clear -dops-.
57 if opt_d then $ if optimization is in effect.
58 do i = 1 to dopsdim-1; $ chain all to next.
59 dp_chain dops(i) = i+1; $ chain one to next.
60 end do;
61 dp_chain dops(dopsdim) = 0; $ chain last to nothing.
62 dopfree = 1; $ show first is on free chain.
63 end if;
64 ..defer
65
66
67 $ clear machine register table.
68 do i = r0 to rhihi;
69 reglis(i) = 0; $ show register dead.
70 end do;
71
72 reguseval = 0; $ reset register usage count.
vaxa 143
vaxa 144
vaxa 145 .+t32 regmask = 0; $ show no registers used yet.
73
74 +* checkvof(ptr, lim) = $ check file dimensions.
75 ptr = vf_hi vof; $ get dimension
76 if (vf_hi vof > lim) call aermey(3); $ if data too big.
77 **
78
79
80 $ read the -voa- file. loop until a routine trailer
81 $ frame is read.
82 while yes; $ loop until 'quit'ed.
83 read voafile, vof; $ get header frame.
84 if filestat(voafile,end) then $ if premature end
85 textl('error - premature end of voa file') endl
86 call aermey(37); $ need new error number.
87 end if;
88 go to l(vf_code vof) in 0 to num_vh; $ select frame type.
89
90 /l(vh_eof)/ $ end-of-file frame.
91 exitcode = 0; call asmexit; $ call termination routine.
92
93 /l(vh_hdr)/ $ file header frame.
94 cont while; $ ignore this frame.
95
96 /l(vh_asm)/ $ routine header frame.
97 lablistptr = vf_lablistp vof; $ get highest lablist value.
98 if (lablistptr>lablistdim) call aermey(39); $ if overflow.
99 do i = 1 to lablistptr; lablist(i) = 0; end do; $ clear.
100 namep = vf_sub1 vof; $ -ha- pointer of routine name.
101 subrtype = vf_sub2 vof; $ get routine type.
102 numargs = vf_subrargs vof; $ get number of arguments.
103 ha_0 = vf_ha0 vof; $ ha index of constant zero.
104 ha_1 = vf_ha1 vof; $ ha index of constant one.
105 .+trace trace_c = vf_listcode vof; $ set code trace option.
106 .+trace trace_any = (trace_c ! trace_d ! trace_o ! trace_r !
107 .+trace trace_a ! trace_l ! trace_v);
108 cont while; $ got all needed info.
109
110 /l(vh_voa)/ $ -voa- frame.
111 checkvof(voaptr, voadim); $ check and set dimension.
112 read voafile, voa(1) to voa(voaptr);
113 voaptr = voaptr-1; $ adjust pointer to last used.
114 cont while;
115
116 /l(vh_ha)/ $ -ha- frame.
117 $ the -ha- is transmitted packed. must read it in
118 $ packed format into the top of the -ha- and then unpack
119 $ it into the bottom of the array.
120 i = hadim - (vf_hi vof) + 1; $ set to place to start.
121 read voafile, ha(i) to ha(hadim);
122 hap = 0; $ initially, start to fill at bottom.
123 do i = i to hadim; $ scan received packed info.
124 haent = ha(i); $ get first packed entry.
125 do j = 1 to ha_zerents haent; $ insert zero entries.
126 hap = hap+1; ha(hap) = 0;
127 end do;
128 hap = hap+1; ha(hap) = haent; $ insert entry.
129 end do;
130 do i = hap+1 to hadim; $ clear rest of -ha-.
131 ha(i) = 0;
132 end do;
133 cont while;
134
135 /l(vh_names)/ $ -names- array frame.
136 checkvof(i, namesdim); $ check and set dimension.
137 read voafile, names(1) to names(i);
138 cont while;
139
140 /l(vh_xarg)/ $ -xarg- frame.
141 checkvof(i, xargdim); $ check and set dimension.
142 read voafile, xarg(1) to xarg(i);
143 cont while;
144
145 /l(vh_val)/ $ -val- array frame.
146 checkvof(valptr, valdim);
147 read voafile, val(1) to val(valptr);
148 cont while;
149
150 /l(vh_mba)/ $ -mba- frame.
151 checkvof(mbaptr, mbadim);
152 read voafile, mba(1) to mba(mbaptr);
153 do i = 1 to num_bl; mba(i) = 0; end do; $ clear special.
154 cont while;
155
156 /l(vh_eos)/ $ end-of-routine frame.
157 quit while; $ exit from loop to continue with initialization.
158 end while;
159
160
161 sdsname(currsubname, namep); $ get current routine name.
162
163 $ reserve parmreg is procedure has parameters.
164
165 if (numargs) rl_type reglis(parmreg) = rt_permresv;
166
167 call eminit(1, numargs, subrtype); $ emit initialization code.
168
dss 18 .+t32u lablorg = lablorg + labluse;
169 $ get a new label and use it for the label for returns.
170 countup(lablistptr, lablistdim, 'lablist'); $ new label.
171 returnlab = lablistptr; $ use this as the return label.
172 lablist(returnlab) = 0; $ clear -lablist- entry.
173 labluse = lablistptr; $ set last use pointer.
174
175 $ must make a pass over the -voa- to do the following:
176 $ 1) allocate all multi-word constants to the constant block.
177 $ 2) allocate all multi-word temporaries to the temp block.
178 $ 3) set flags indicating whether or not an operand can be
179 $ permanently assigned to a register.
180 $ 4) clear -inreg- fields of operands.
181 $ 5) count subroutine calls.
182 $ 6) decrease usage count for a variable for each time it
183 $ appears in subroutine or function calls.
184 $ 7) chain -voa- operations for faster access.
185 $ 8) if label optimization is wanted, indicate where label
186 $ is defined and also count uses of labels.
187 $ 9) change return operations into a goto to the return label.
188 numglobs = 0;
189 numcalls = 0; $ initially no calls.
190 addr = 1; $ set current address in constant block to start.
191 lastcnst = 0; $ show no nulti-word constants yet.
192 tempaddr = 1; $ set current address in temporary block.
193 voahead = 0; $ show nothing in -voa- op chain yet.
194 totcnt = 0; $ no counts.
195 do i = 1 to voaptr; $ scan -voa-.
196 if vv_opb voa(i) then $ this is operation.
197 $ chain in operation.
198 if voahead then $ chain this to last.
199 vv_chain voa(voalast) = i; $ chain this in.
200 else $ this is head of chain.
201 voahead = i; $ put on top of chain.
202 end if;
203
204 voalast = i; $ show this is last one.
205
206 $ check for operation which is subroutine
207 $ or function call. in this case global
208 $ variables must be stored so the number of such calls
209 $ is recorded for computing which variables should
210 $ permanently reside in a register.
211 if vv_opcode voa(i) = vo_scall ! $ if subroutine call.
212 vv_opcode voa(i) = vo_fcall then $ or function call.
213 numcalls = numcalls + 1; $ count the call.
dsk 287 if (vv_opcode voa = vo_fcall & fag_opt = no)
dsk 288 cont do; $ skip functions if globals not altered.
215 $ loop over all arguments.
216 if (vv_arglen voa(i) = 0) cont do; $ if no args.
217 do j = vv_argbeg voa(i) to vv_argbeg voa(i)
218 + vv_arglen voa(i) - 1;
219 k = xa_voa xarg(j);
220 $ if not constant or temporary and has a usage
221 $ count, then decrement by two to allow for
222 $ work needed for saving and restoring.
223 if (vv_temb voa(k)) cont do; $ skip temps.
224 if (vv_const voa(k)) cont do; $ and consts.
225 if (vv_mblk voa(k) >= bl_global) cont do;
226 if (vv_varnuse voa(k) < 2) cont do;
227
228 $ else, decrement.
229 vv_varnuse voa(k) = vv_varnuse voa(k) - 2;
230 end do;
231
232
233 $ change returns to gotos.
234 elseif vv_opcode voa(i) = vo_return then $ this is one.
235 vv_opcode voa(i) = vo_goto; $ set new operation.
236 vv_inp1 voa(i) = returnlab; $ set target label.
237 .+labopt.
238 if (opt_l) $ count uses of label.
239 ll_count lablist(returnlab) =
240 ll_count lablist(returnlab) + 1;
241 elseif vv_opcode voa(i) = vo_lab then $ this defines.
242 if (opt_l) ll_def lablist(vv_inp1 voa(i)) = i;
243 else $ this may use a label so call routine.
244 if (opt_l) call labcount(i, 1); $ count upwards.
245 ..labopt
246 end if;
247 cont do; $ done with this entry.
248 end if;
249
250 vv_ppdata voa(i) = no; $ initially.
251 vv_inreg voa(i) = 0; $ show not in a register.
252 if (vv_type voa(i) = 0) cont do; $ skip routine entries.
253 if vv_const voa(i) then $ if constant.
254 $ if this is single word constant that can
255 $ be represented safely in octal.
rkb 17 if vv_syze voa(i) <= scs $ if short,
257 & tmctab(vv_lextype voa(i)) <= tmc_b then
258 if (vv_signbit voa(i)) vv_syze voa(i) = mws;
259 $ can have in register if not short constant.
260 vv_ppdata voa(i) = vv_syze voa(i) > mps;
261 else $ multi-word constant.
262 vv_mblk voa(i) = bl_const; $ in constant block.
263 k = vv_syze voa(i); $ copy in case overflow.
264 addr = addr + (k + (mws-1))/mws;
265 vv_madr voa(i) = addr-1; $ set offset.
266 $ chain constants via -dimn-.
267 if lastcnst then $ if not first in chain.
268 vv_dimn voa(lastcnst) = i; $ chain last to this.
269 else $ first in chain.
270 mb_chain mba(bl_const) = i; $ put in head.
271 end if;
272 lastcnst = i; $ set last to this.
273 end if;
274 elseif vv_temb voa(i) then $ this is temporary.
275 if vv_syze voa(i) > mws then $ is multi-word temp.
276 vv_mblk voa(i) = bl_temp; $ set block.
277 k = vv_syze voa(i); $ copy in case overflow.
278 tempaddr = tempaddr + (k + (mws-1))/mws;
279 vv_madr voa(i) = tempaddr-1; $ set address.
280 end if;
281 else $ not constant or temporary.
282 .-vvfrs vv_frsdata voa(i) = 0; $ clear head of data chain
283 .+vvfrs vvfrsdata(i) = 0; $ clear head of data chain
284 if vv_isafnct voa(i) = no then $ ok.
285 if vv_syze voa(i) <= mws & vv_dimn voa(i) = 0 then
rkb 18 if (vv_argno voa(i)=0) vv_ppdata voa(i) = yes;
287 if (vv_mblk voa(i) >= bl_global)
288 numglobs = numglobs + 1;
289 end if;
290 $ list address in generated code.
291 if (i^=1) call eminit(2, i, i);
292
293 end if;
294
295 end if;
296
297 $ if can address as data, increment the total count for
298 $ that arithmetic mode.
299 if (vv_ppdata voa(i)) $ do increment.
300 totcnt = totcnt +
301 vv_varnuse voa(i); $ add to count.
302
303 end do;
304
305 $ if the total count for any mode is too small, set it to
306 $ a higher value to avoid trivial variables in registers.
307 $ also decrease counts by number of globals*number of calls.
308 totcnt = idim(totcnt, numglobs*numcalls);
309 if (totcnt < 20) totcnt = 20;
310
311 if (voahead) vv_chain voa(voalast) = 0; $ end the chain.
312
313
314 $ next, end the constant chain, if it exists, and then
315 $ allocate space in the base block for the addresses of the
316 $ parameters to the current routine.
317 mb_len mba(bl_const) = addr-1; $ set length of const block.
318 mb_len mba(bl_temp) = tempaddr-1; $ set length of temp block.
319 if (lastcnst) vv_dimn voa(lastcnst) = 0; $ end last chain.
320
321 $ see if the current routine is a function. if so, then
322 $ allocate space for the return value in the base block.
323 if subrtype = st_fnct then $ this is a function.
324 vv_mblk voa(1) = bl_base; $ show in base block.
325 i = (vv_syze voa(1) + mws-1) / mws;
326 vv_madr voa(1) = i;
327 baselastaddr = baselastaddr + i;
328 call eminit(2, 1, 1);
329 end if;
330
dsu 74 .+t32h.
dsu 75 $ see if nsheap option on. if so, see if nsheap nameset
dsu 76 $ referenced in current procedure, in which case indicate
dsu 77 $ references to the nameset are to be made dynamic.
dsu 78 nsheap_this = no; $ assume no refrences possible
dsu 79 ..t32h
331 do i = bl_global to mbaptr;
332 if (mb_used mba(i) = no) cont do;
333 sdsname(dopsname, mb_ha mba(i));
334 mbanames(i) = dopsname;
dsu 80 .+t32h.
dsu 81 if nsheap_opt then
dsu 82 if dopsname .seq. nsheap_prm then $ if heap block
dsu 83 nsheap_blk = i;
dsu 84 nsheap_this = yes;
dsu 85 end if;
dsu 86 end if;
dsu 87 ..t32h
335 end do;
336
337 $ check to see if variables should be permanently assigned
338 $ to registers.
339
340 $ see if any data can be permanently assigned.
341 $ will try to get at most 5 items permanently assigned to
342 $ registers.
343 i = 0;
dsu 88 .+t32h.
dsu 89 $ if heap block, reserve two registers which will contain the
dsu 90 $ byte and word address of the start of the nameset during
dsu 91 $ execution of the procedure.
dsu 92 if nsheap_this then $ if need to reserve registers.
dsu 93 nsheapreg_w = rhi;
dsu 94 nsheapreg_b = rhi-1;
dsu 95 i = 2; $ indicate registers reserved.
dsu 96 end if;
dsu 97 ..t32h
344 until i >= 5 ; $ loop until no more.
345
346 $ see if there is something that can be permanent.
347 call getperm(totcnt/20+1); $ get variable.
348
349 $ if none, set flag and exit.
350 if (voaep = 0) quit until; $ if none.
351
352 $ otherwise, assign to next register.
353 assign(reg, va_spec); $ assign to a dummy register.
354
vaxa 146 .+t10.
355 rl_content reglis(rlo+i) = reg; $ show owner.
356 rl_type reglis(rlo+i) = rt_perm; $ set type.
vaxa 147 ..t10
vaxa 148 .+t32.
vaxa 149 rl_content reglis(rhi-i) = reg; $ show owner.
vaxa 150 rl_type reglis(rhi-i) = rt_perm; $ set type.
vaxa 151 ..t32
vaxa 152
vaxa 153
357 vv_ppdata voa(voaep) = no; $ show cannot be perm again.
358 i = i+1; $ count register used.
359 end until;
360
vaxa 154 .+t10 nextgfree = rlo+i; $ show next available register.
vaxa 155 .+t32 nextgfree = rhi-i; $ show next available register.
362
363 $ if label optimization wanted, call routine.
364 .+labopt if (opt_l) call labfixup;
365
366
367 pdlistp = 0; $ no parameter lists yet.
368
369 $ emit the code to initialize a routine.
370
371
372 call eminit(3, 1, 2);
373
374 $ finally, load permanent data values.
375 do i = rlo to rhi; $ scan registers.
376 if rl_type reglis(i) = rt_perm then $ should load data.
dsj 47 getvar(rl_content reglis(i), gd_intoreg, j, i, moff);
378 rl_perm reglis(i) = yes; $ show to be permanent.
379 end if;
380 end do;
381
382 .+trace. $ generate trace code.
383 if (trace_d) call dumpdregs;
384 if (trace_r) call dumpmregs;
385 ..trace
386
387 end subr setup;
1 .=member eminit
2 subr eminit(case, nargs, ptype); $ emit initial code for proc.
3 $ emit initial t10 code for procedure.
4 size case(ps); $ case.
5 size nargs(ps); $ number of arguments
6 size ptype(ps); $ procedure type.
7 size i(ps); $ loop index.
dsw 9 size p(ps); $ position
8 size d(cs); $ access/definition code character.
9 size dops(mcs); $ t10 op to put out.
10 size blk(ps); $ machine block.
11 size dop(ps);
dsw 10 size blkname(.sds. namelen); $ block name
12
13 go to l(case) in 1 to 3;
14 /l(1)/ $ to start procedure.
15
16 .s. 1, 80, ocs = ''; $ clear ocs.
vaxa 156 .+t10.
17 $ if universal file specified, put out search directive.
18 if .len. univfilename then
19 put ocsfile ,column(9) ,'search'
20 ,column(17) :univfilename,a;
21 call ocsput(0,0);
22 end if;
vaxa 157 ..t10
23
24 .s. 9, 3, ocs = 'dsp';
25 put ocsfile ,column(17)
26 :currsubname,a ,
27 ',' :nargs,i ,',' :ptype,i ,x(30)
dsq 78 ,column(33)
dsq 79 ,tmcscom $ comment
dsq 80 ,' * * ' :currsubname,a(0,1)
29 ,' * *';
30 call ocsput(0, 0); $ put code line.
31
vaxa 158 .+t10 put ocsfile ,column(1) ,'; compiled by t10.'
dsq 81 .+t32.
dsq 82 put ocsfile ,column(1) ,tmcscom ,' compiled '
dsq 83 .+t32u ,'t32u by '
dsq 84 .+t32v ,'t32v by '
dsq 85 ..t32
dsq 86 ;
dsq 87 if ats_opt then $ if want time stamp
dsq 88 put ocsfile ,assemblerlevel ,' on '
dsq 89 :comptime,a;
dsq 90 end if;
35 call ocsput(0,0); $ put line.
36 .s. 1, 80, ocs = ''; $ clear ocs.
dss 19 .+t32u.
dss 20 call renblk(bl_base);
dss 21 call renblk(bl_const);
dss 22 call renblk(bl_temp);
dss 23 call renblk(bl_local);
dsw 11 $ avoid 'g--' symbols for unix; they are too much for 'as'.
dsw 12 do i = bl_global to mbaptr;
dsw 13 sdsname(blkname, mb_ha mba(i)); $ get name
dsw 14 while 1; $ map $ in name to _
dsw 15 p = '$' .in. blkname;
dsw 16 if (p=0) quit; $ if no more $'s in name.
dsw 17 .ch. p, blkname = 1r_; $ map $ to _.
dsw 18 end while;
dsw 19 mblkname(i) = blkname; $ substitute expanded name.
dsw 20 end do;
dss 24 ..t32u
37 return;
38 /l(2)/ $ put out address of variable as comment.
39 i = nargs;
40 sdlname(dopsname, vv_naym voa(i)); $ get (long) name.
dsq 91 put ocsfile ,column(1)
dsq 92 ,tmcscom
dsq 93 ,'='
dsq 94 ,column(9)
42 :dopsname,a(12) ,x; $ put name
43 if vv_argno voa(i) then $ if argument.
vaxa 160 .+t10 put ocsfile ,'@+' :vv_argno voa(i)-1,i
vaxa 161 .+t10 ,'(r' :parmreg-1,i ,')';
dsq 95 .+t32.
dsq 96 put ocsfile
dsq 97 ,tmcsind
dsq 98 ,'+'
dsq 99 :vv_argno voa(i) * mcpw,i ,'(ap)';
dsq 100 ..t32
46 else $ otherwise, write block, offset.
47 put ocsfile :mblkname(vv_mblk voa(i)),a ,'+'
vaxa 163 .+t10 :vv_madr voa(i)-1,i; $ put offset.
vaxa 164 .+t32 :(vv_madr voa(i)-1) * mcpw,i; $ put offset.
49 end if;
50 call ocsput(0,0);
51 return;
52 /l(3)/ $ put out nameset declarations.
vaxa 165 .+t10.
53 $ put out nameset declarations, dnd for defined namesets,
54 $ dna for accessed namesets.
eaa 102
eaa 103 .+t20.
eaa 104 $ see if nsheap option on. if so, see if nsheap nameset
eaa 105 $ referenced in current procedure, in which case indicate
eaa 106 $ references to the nameset are to be extended.
eaa 107 nsheap_this = no; $ assume no references possible.
eaa 108 nsheap_blk = 0; $ assume no references.
eaa 109 if nsheap_opt then
eaa 110 do i = bl_global to mbaptr;
eaa 111 sdsname(blkname, mb_ha mba(i)); $ get name.
eaa 112 call stuc(blkname); $ make upper case.
eaa 113 if blkname .sne. nsheap_prm then cont do; end if;
eaa 114 $ here if found
eaa 115 nsheap_blk = i;
eaa 116 nsheap_this = yes;
eaa 117 quit do;
eaa 118 end do;
eaa 119
eaa 120 if nsheap_this then $ if references
eaa 121 $ add extra descriptive line if extended addressing
eaa 122 put ocsfile ,column(1) , '; extended addressing for '
eaa 123 :nsheap_prm,a
eaa 124 ,' (g' :nsheap_blk,i ,')'
eaa 125 ,' with origin ' :nsheap_org,a ,skip;
eaa 126 call ocsput(0,0); $ put line.
eaa 127 .s. 1,80, ocs = '';
eaa 128 end if;
eaa 129 end if;
eaa 130 ..t20
55 do i = bl_global to mbaptr; $ loop over global namesets
dsu 98 .+t20 if nsheap_this & (i=nsheap_blk) then cont do; end if;
56 if mb_def mba(i) then d = 1rd; $ if defined.
57 elseif mb_used mba(i) then d = 1ra; $ if access.
58 else cont do; $ skip if neither.
59 end if;
60 sdsname(dopsname, (mb_ha mba(i))); $ get block name.
61 .s. 9, 2, ocs = 'dn';
62 put ocsfile ,column(11) :d,r(1)
63 ,column(17) :dopsname,a ,','
64 :mblkname(i),a ,',' :mb_len mba(i),i ;
65 call ocsput(0, 0);
66 end do;
67 $ reserve internal blocks.
68 do i = 1 to 3;
69 if i=1 then blk = bl_const; dop = 1rr;
70 elseif i=2 then blk=bl_temp; dop = 1rw;
71 elseif i=3 then blk=bl_local; dop = 1rw; end if;
72 if (mb_len mba(blk)=0) cont do;
73 .s. 9, 2, ocs = 'db';
74 .ch. 11, ocs = dop;
75 put ocsfile, column(17)
76 :mblkname(blk),a ,',' $ internal block name.
77 :mb_len mba(blk),i;
78 call ocsput(0, 0); $ put code line.
79 end do;
vaxa 166 ..t10
80 $ indicate start of code phase.
81 put ocsfile ,column(9), 'dsc'
82 ,column(17) :currsubname,a; $ indicate start of code.
83 call ocsput(0, 0); $ put code.
84 put ocsfile ,column(9) ,'ent'
85 ,column(17) :currsubname,a;
86 call ocsput(0,0); $ put line.
dst 62 .+enp.
dst 63 if enpopt then $ if enp op wanted
dst 64 enpnum = 0;
dst 65 do i = 1 to enptot;
dst 66 if enpara(i) .seq. currsubname then $ if match
dst 67 enpnum = i;
dst 68 quit do;
dst 69 end if;
dst 70 end do;
dst 71 if enpnum=0 then enpnotfound = enpnotfound + 1;end if;
dst 72 put ocsfile ,column(9) ,'enp' ,column(17)
dst 73 :currsubname,a ,',#' :(enpnum+enporg),i;
dst 74 call ocsput(0,0);
dst 75 end if;
dst 76 ..enp
dsu 99 .+t32h.
dsu 100 if nsheap_this then $ if references to heap.
dsu 101 put ocsfile ,column(9) ,'lha' ,column(17)
dsu 102 ,'r' :nsheapreg_b-1,i ,',r' :nsheapreg_w-1,i
dsu 103 ,',' :mblkname(nsheap_blk),a;
dsu 104 call ocsput(0,0); $ emit line
dsu 105 end if;
dsu 106 ..t32h
87 .s. 1, 80, ocs = '';
88 end subr eminit;
dssa 1 .+t32u.
dss 26 subr renblk(bl);
dss 27
dss 28 $ for unix only, generate unique name for 'local' blocks.
dss 29 $ the second and third characters are put in upper case to reduce
dss 30 $ probability of name clash with user names.
dss 31
dss 32 size bl(ps);
dss 33 size s(.sds. 2);
dss 34 s = .s. 2, 2, mblknames(bl);
dss 35 .s. 1, 1, s = .s. (totprocs/26)+1, 1,
dss 36 'abcdefghijklmnopqrstuvwxyz';
dss 37 .s. 2, 1, s = .s. 1 + totprocs - 26*(totprocs/26), 1,
dss 38 'abcdefghijklmnopqrstuvwxyz';
dss 39 call stuc(s);
dss 40 .s. 2, 2, mblknames(bl) = s;
dss 41 .s. 2, 2, mbanames(bl) = s;
dss 42 end subr renblk;
dss 43 ..t32u
1 .=member labfix
2 .+labopt. $ routine used for label optimization.
3 subr labfixup; $ clean up branch structure.
4 $ this routine is called when label optimization is
5 $ desired. it will make as many passes over the operations
6 $ in the -voa- as needed. it does the following things:
7 $ 1) deletes unreferenced labels.
8 $ 2) deletes dead code.
9 $ 3) deletes branches to the next statements.
10 $ 4) changes destinations of branches to -goto-s.
11 $ 5) fixes up things like if x,3; goto,4;lab,3
12 $ by changing it to ifnot x,4
13 size voap(ps); $ current index into -voa-.
14 size modfl(1); $ flag indicating if any modifications
15 $ were made in the last pass over -voa-.
16 size lab(ps); $ label being referenced.
17 size i(ps), j(ps); $ temporaries.
18 size targsp(ps); $ pointer to targets array.
19 size targs(ps); dims targs(10);
20
21 $ will loop over the -voa- until the last pass made
22 $ no changes.
23 until modfl = no;
24 modfl = no; $ show no changes in this pass.
25 $ start at top of -voa-.
26 voap = voahead; $ set to first in chain.
27 while voap; $ while more operations.
28
29 $ first check for the case of an if/ifnot followed
30 $ by a goto followed by the target label being defined.
31 until yes; $ quit if not this case.
32 if (vv_opcode voa(voap) ^= vo_if &
33 vv_opcode voa(voap) ^= vo_ifnot) quit until;
34 i = vv_chain voa(voap); $ point to next.
35 if (i = 0) quit until; $ must not be last op.
36 if (vv_opcode voa(i) ^= vo_goto) quit until;
37
38 $ scan and see if any labels following are
39 $ the target of the if/ifnot.
40 j = vv_chain voa(i); $ start at next operation.
41 while j ^= 0 & vv_opcode voa(j) = vo_lab;
42 $ check destination against this label.
43 if vv_inp2 voa(voap) = vv_inp1 voa(j) then
44 $ reduce count of original label.
45 ll_count lablist(vv_inp2 voa(voap)) =
46 ll_count lablist(vv_inp2 voa(voap)) - 1;
47 $ next, switch opcode to inverse operation.
48 vv_opcode voa(voap) = (vo_if+vo_ifnot) -
49 vv_opcode voa(voap);
50 $ change target label.
51 vv_inp2 voa(voap) = vv_inp1 voa(i);
52 $ finally, rechain around -goto-.
53 vv_chain voa(voap) = vv_chain voa(i);
54 modfl = yes; $ show a change was made.
55 quit until;
56 end if;
57
58 j = vv_chain voa(j); $ get next in chain.
59 end while;
60 end until;
61
62
63 $ see what the target of an -if-, -ifnot-, or
64 $ -goto- is pointing to and update if possible.
65 $ note that do not bother to update -goby-
66 $ operations because the payoff would be small.
67 until yes; $ exit if updated or cannot update.
68 $ see if this is an eligable op-code.
69 if vv_opcode voa(voap) = vo_goto !
70 vv_opcode voa(voap) = vo_if !
71 vv_opcode voa(voap) = vo_ifnot then $ this is ok.
72
73 $ first, get target label.
74 if vv_opcode voa(voap) = vo_goto
75 then lab = vv_inp1 voa(voap);
76 else lab = vv_inp2 voa(voap); end if;
77
78 $ get defining point of label.
79 i = ll_def lablist(lab);
80 if (i = 0) quit until; $ undefined or return.
81 targsp = 0; $ show no branch targets yet.
82
83 /labloop/ $ follow target.
84
85 $ first see if target is simply the next
86 $ statement.
87 j = vv_chain voa(voap); $ point to next.
88 while j ^= 0 & vv_opcode voa(j) = vo_lab;
89 if j = i then $ it is null branch.
dsl 11 if (vv_opcode voa(voap) ^= vo_goto)
dsl 12 quit while;
90 $ first, decrease label count.
91 ll_count lablist(lab) =
92 ll_count lablist(lab) - 1;
93 $ unchain the -goto-.
94 if voap = voahead then $ see if top.
95 voahead = vv_chain voa(voap);
96 else $ not start of chain.
97 vv_chain voa(voalast) = $ rechain.
98 vv_chain voa(voap);
99 end if;
100
101 modfl = yes; $ show change made.
102 voap = vv_chain voa(voap); $ next.
103 cont while voap; $ around again.
104 end if;
105
106 j = vv_chain voa(j); $ get next.
107 end while;
108
109 $ check for the case where a -goto- is the
110 $ destination. first skip any labels at the
111 $ branch point.
112 while i ^= 0 & vv_opcode voa(i) = vo_lab;
113 j = i; $ save last value.
114 i = vv_chain voa(i); $ point to next.
115 end while;
116
117 if i = 0 then $ must process this -goto-.
118 i = j; $ back to last label.
119 go to labproc; $ go and process.
120 end if;
121
122 $ do check of destination.
123 if vv_opcode voa(i) = vo_goto then $ special.
124 $ will want to change this to a
125 $ branch to the target so see what the
126 $ target is.
127 j = ll_def lablist(vv_inp1 voa(i));
128
129 $ if this is undefined, go process
130 $ by getting label from -goto-.
131 if (j = 0) go to labproc;
132
133 i = j; $ point to destination.
134
135 $ must verify that never branched
136 $ to this label in this search. this
137 $ could be caused by an infinite loop.
138 do j = 1 to targsp; $ scan targets.
139 if targs(j) = i then $ duplicate.
140 error('infinite loop found near '
141 !! 'label', j);
142 quit until; $ skip this.
143 end if;
144 end do;
145
146 $ insert into target array.
147 countup(targsp, 20, 'targs'); $ increment.
148 targs(targsp) = i; $ insert label into array.
149 go to labloop; $ take 'branch'.
150 end if;
151
152 $ look backwards for the next label in the
153 $ chain to use as a destination.
154 j = i; $ point to an operation in the chain.
155 do i = i to 1 by -1; $ scan backwards.
156 if (vv_opb voa(i) = no) cont do; $ not op.
157 if (vv_chain voa(i) ^= j) cont do;
158 j = i; $ show this is in chain.
159 if (vv_opcode voa(i) = vo_lab) quit do;
160 end do;
161
162 /labproc/ $ update the target to point to here.
163 if (i = 0) call aermey(2); $ this is error.
164
165 $ check if target changed. if so, update.
166 if vv_inp1 voa(i) ^= lab then $ it did.
167 modfl = yes; $ show an update done.
168 ll_count lablist(lab)=ll_count lablist(lab)-1;
169 ll_count lablist(vv_inp1 voa(i)) =
170 ll_count lablist(vv_inp1 voa(i)) + 1;
171
172 $ do update of target.
173 if vv_opcode voa(voap) = vo_goto
174 then vv_inp1 voa(voap) = vv_inp1 voa(i);
175 else vv_inp2 voa(voap) = vv_inp1 voa(i);
176 end if;
177 end if;
178 end if;
179 end until;
180
181
182 $ see if the current operation is an unreferenced
183 $ label. delete it if so.
184 if vv_opcode voa(voap) = vo_lab then $ it is a label.
185 if ll_count lablist(vv_inp1 voa(voap)) = 0 then
186 $ this label is unreferenced. so unchain it.
187 modfl = yes; $ show a change made.
188 $ unchain.
189 if voap = voahead then $ this is top.
190 voahead = vv_chain voa(voap); $ set new top.
191 else $ this is not top.
192 vv_chain voa(voalast) = vv_chain voa(voap);
193 end if;
194
dsp 39 i = voap; $ keep pointer to label being deleted.
195 voap = vv_chain voa(voap); $ point to next.
dsp 40 $ clear chain so won't be pickup up as valid
dsp 41 $ label later.
dsp 42 vv_chain voa(i) = 0; $ clear chain.
196 cont while; $ go around again.
197 end if;
198 end if;
199
200 $ see if this is an unconditional -goto- (or -goby-)
201 $ which is followed by something other than a label.
202 $ if so, delete text in between.
203 if vv_opcode voa(voap) = vo_goto ! $ if -goto-.
204 vv_opcode voa(voap) = vo_goby then $ or -goby-.
205 i = vv_chain voa(voap); $ point to next.
206 while i; $ loop until hit end.
207 if (vv_opcode voa(i) = vo_lab) quit while;
208
209 $ -i- points to unreferenced operation.
210 $ will delete it by rechaining so decrement
211 $ any label references of the deleted operation.
212 call labcount(i, -1); $ decrement counts.
213 i = vv_chain voa(i); $ point to next.
214 modfl = yes; $ show a modification was made.
215 end while;
216
217 $ rechain.
218 vv_chain voa(voap) = i; $ this may be same as before.
219 end if;
220
221
222
223 $ finally, go to next operation in -voa-.
224 voalast = voap; $ save pointer to last.
225 voap = vv_chain voa(voap); $ point to next.
226 end while voap;
227 end until modfl;
228
229
230 $ just do a final check on the -return-. see if the last
231 $ operation is a -goto- to the return label. if it is, then
232 $ can just remove it from the chain.
233 if vv_opcode voa(voalast) = vo_goto & $ it is -goto-.
234 vv_inp1 voa(voalast) = returnlab then $ it is this case.
235
236 $ scan backwards for the last operation before this one.
237 do i = voalast to 1 by -1; $ go back.
238 if (vv_opb voa(i) = no) cont do; $ skip data.
239 if vv_chain voa(i) = voalast then $ this is the one.
240 voalast = i; $ show this is last.
241 vv_chain voa(i) = 0; $ show in -voa-.
242 quit do;
243 end if;
244 end do;
245 end if;
246
247 $ if count of return label is zero, no return is done
248 $ from the routine so can clear -returnlab- to suppress
249 $ unneeded code.
250 if (ll_count lablist(returnlab) = 0) returnlab = 0;
251
252 $ finally, clear -lablist- again.
253 do i = 1 to lablistptr; lablist(i) = 0; end do;
254
255 end subr labfixup;
1 .=member labcnt
2 ..labopt
3 .+labopt. $ used only for label optimizations.
4 subr labcount(voap, inc); $ count usage of label.
5 $ this routine is passed a -voa- pointer and an increment.
6 $ it sees if there are any labels referenced (not defined)
7 $ in the operation and increments their counts by the increment
8 $ that it is passed (usually +1 or -1).
9 size voap(ps); $ pointer to operation.
10 size inc(ws); $ increment.
11 size i(ps); $ loop variable.
12 size lab(ps); $ label to decrement.
13
14 lab = 0; $ show no label found yet.
15
16 $ see what type of operation this is.
17 if vv_opcode voa(voap) = vo_goto then $ this references label.
18 lab = vv_inp1 voa(voap); $ get the label.
19 elseif vv_opcode voa(voap) = vo_if ! $ if -if-.
20 vv_opcode voa(voap) = vo_ifnot then $ or -ifnot-.
21 lab = vv_inp2 voa(voap); $ label is here.
22 elseif vv_opcode voa(voap) = vo_goby then $ indexed -goto-.
23 $ this is handled via a loop.
24 do i = vv_argbeg voa(voap) to $ loop over -xarg- entries.
25 vv_argbeg voa(voap) + vv_arglen voa(voap) - 1;
26 ll_count lablist(xa_voa xarg(i)) = $ change count.
27 ll_count lablist(xa_voa xarg(i)) + inc;
28 end do;
29 end if;
30
31 $ if a label was found, change its count.
32 if (lab) ll_count lablist(lab) = ll_count lablist(lab) + inc;
33
34 end subr labcount;
1 .=member getprm
2 ..labopt
3 subr getperm(min); $ assign permanent register.
4 $ this routine scans the -voa- to find the best value
5 $ to permanently assign to a register.
6 size min(ps); $ minimum count needed to assign.
7 size musage(ps); $ highest usage so far.
8 size i(ps); $ index.
9 size usage(ws); $ usage of scanned variable.
10
11 musage = min; $ show 'best' so far.
12 voaep = 0; $ show none assigned.
13 do i = 1 to voaptr; $ scan -voa-.
14 if (vv_opb voa(i)) cont do; $ skip operations.
15 if (vv_ppdata voa(i) = no) cont do; $ skip if not eligible.
16 usage = vv_varnuse voa(i); $ get usage count.
17 if (vv_mblk voa(i) >= bl_global) $ must decrement.
18 usage = usage - numcalls*2; $ allow for number of calls.
19
20 $ see if this is best so far.
21 if (usage < musage) cont do; $ worse.
22 $ else, show this variable is 'better'.
23 voaep = i; musage = usage;
24 end do;
25
26 .+trace.
27 if trace_d then $ print last action.
28 tintl('getperm, voaep', voaep) endl
29 end if;
30 ..trace
31
32 end subr getperm;
1 .=member asmprog
2 subr asmprog; $ scan -voa- operations.
3 $ this is the highest-level routine in -asm- for
4 $ generating the code for a routine. it is responsible
5 $ for looping over the -voa- and calling -emitdop-, the
6 $ next lower-level routine, to issue each -voa- operation
7 $ to be processed. this routine is largely table-driven
8 $ and machine-independent.
9
10 size voptab(ws); $ -voa- operation table.
11 dims voptab(num_vo); $ number of operations.
12
13 $ fields in -voptab-.
14
15 +* vt_ign = .f. 01, 1, ** $ new setting for -ignorevoa-
16 +* vt_storall = .f. 02, 1, ** $ 'must do -storall-'
17 +* vt_xargs = .f. 03, 1, ** $ 'operation has extra args'
18 +* vt_isout = .f. 04, 1, ** $ 'operation has output'
19 +* vt_inv = .f. 05, 1, ** $ 'invert operands'
20 +* vt_nargs = .f. 06, 3, ** $ number of arguments
21 +* vt_dop = .f. 09, 8, ** $ operation to issue
22 +* vt_kind = .f. 17, 5, ** $ operation types
23
24 $ types for -voa- opcodes.
25 +* vk_data = 01 ** +* vk_lab = 09 **
26 +* vk_ext = 02 ** +* vk_mwbin = 10 **
27 +* vk_fasin = 03 ** +* vk_sasin = 11 **
28 +* vk_fcall = 04 ** +* vk_scall = 12 **
29 +* vk_goby = 05 ** +* vk_sext = 13 **
30 +* vk_goto = 06 ** +* vk_simp = 14 **
31 +* vk_if = 07 ** +* vk_xfasin = 15 **
32 +* vk_io = 08 **
33
34 +* num_vk = 15 ** $ number of -voa- operation types
35
36 $ macro to initialize -voptab-.
37
38 +* vop(num, typ, dop, nargs, inv, out, xarg, stor, ign) =
39 voptab(num) = typ*4b'10000'+dop*4b'100'+nargs*4b'20'+
40 inv*1b'10000'+out*1b'1000'+xarg*1b'100'+stor*1b'10'+ign **
41
42 data $ initialize table.
43
44 $ vop kind dop args inv out xarg stor ign
45 $ --- ---- --- ---- --- --- ---- ---- ---
46
47 vop(vo_add, vk_simp, do_add, 2, no, yes, no, no, no):
48 vop(vo_sub, vk_simp, do_sub, 2, no, yes, no, no, no):
49 vop(vo_gt, vk_simp, do_lt, 2, yes, yes, no, no, no):
50 vop(vo_lt, vk_simp, do_lt, 2, no, yes, no, no, no):
51 vop(vo_ge, vk_simp, do_ge, 2, no, yes, no, no, no):
52 vop(vo_le, vk_simp, do_ge, 2, yes, yes, no, no, no):
53 vop(vo_eq, vk_simp, do_eq, 2, no, yes, no, no, no):
54 vop(vo_ne, vk_simp, do_ne, 2, no, yes, no, no, no):
55 vop(vo_mul, vk_simp, do_mul, 2, no, yes, no, no, no):
56 vop(vo_div, vk_simp, do_div, 2, no, yes, no, no, no):
57 vop(vo_or, vk_simp, do_or, 2, no, yes, no, no, no):
58 vop(vo_and, vk_simp, do_and, 2, no, yes, no, no, no):
59 vop(vo_exor, vk_simp, do_exor, 2, no, yes, no, no, no):
60 vop(vo_nb, vk_simp, do_nb, 1, no, yes, no, no, no):
61 vop(vo_fb, vk_simp, do_fb, 1, no, yes, no, no, no):
62 vop(vo_not, vk_simp, do_not, 1, no, yes, no, no, no):
63 vop(vo_fcall, vk_fcall, do_fcall, 0, no, yes, yes, no, no):
64 vop(vo_scall, vk_scall, do_scall, 0, no, no, yes, yes, no):
65 vop(vo_asin, vk_simp, do_asin, 2, no, no, no, no, no):
66 vop(vo_data, vk_data, 0, 0, no, no, no, no, no):
67 vop(vo_fasin, vk_fasin, do_fasin, 4, no, no, no, no, no):
68 vop(vo_io, vk_io, do_scall, 2, no, no, no, yes, no):
69 vop(vo_return, vk_simp, do_return, 0, no, no, no, yes, yes):
70 vop(vo_fext, vk_ext, do_fext, 3, no, yes, no, no, no):
71 vop(vo_if, vk_if, do_if, 1, no, no, no, yes, no):
72 vop(vo_lab, vk_lab, 0, 0, no, no, no, yes, no):
73 vop(vo_goto, vk_goto, do_goto, 0, no, no, no, yes, yes):
74 vop(vo_goby, vk_goby, do_goby, 1, no, no, no, yes, yes):
75 vop(vo_xload, vk_simp, do_xload, 2, no, yes, no, no, no):
76 vop(vo_xasin, vk_simp, do_xasin, 3, no, no, no, no, no):
77 vop(vo_xfasin, vk_xfasin, do_xfasin, 4, no, no, yes, no, no):
78 vop(vo_ifnot, vk_if, do_ifnot, 1, no, no, no, yes, no):
79 vop(vo_ccat, vk_mwbin, do_scall, 2, no, yes, no, no, no):
80 vop(vo_in, vk_mwbin, do_fcall, 2, no, yes, no, no, no):
81 vop(vo_eext, vk_ext, do_eext, 3, no, yes, no, no, no):
82 vop(vo_sext, vk_sext, do_scall, 3, no, yes, no, no, no):
83 vop(vo_easin, vk_fasin, do_easin, 4, no, no, no, no, no):
84 vop(vo_sasin, vk_sasin, do_scall, 4, no, no, no, no, no):
85 vop(vo_xeasin, vk_xfasin, do_xeasin, 4, no, no, yes, no, no):
86 vop(vo_xsasin, vk_simp, do_xsasin, 4, no, no, yes, no, no):
87 vop(vo_radd, vk_simp, do_radd, 2, no, yes, no, no, no):
88 vop(vo_rsub, vk_simp, do_rsub, 2, no, yes, no, no, no):
89 vop(vo_rgt, vk_simp, do_rlt, 2, yes, yes, no, no, no):
90 vop(vo_rlt, vk_simp, do_rlt, 2, no, yes, no, no, no):
91 vop(vo_rge, vk_simp, do_rge, 2, no, yes, no, no, no):
92 vop(vo_rle, vk_simp, do_rge, 2, yes, yes, no, no, no):
93 vop(vo_req, vk_simp, do_req, 2, no, yes, no, no, no):
94 vop(vo_rne, vk_simp, do_rne, 2, no, yes, no, no, no):
95 vop(vo_rmul, vk_simp, do_rmul, 2, no, yes, no, no, no):
96 vop(vo_rdiv, vk_simp, do_rdiv, 2, no, yes, no, no, no):
97 vop(vo_rusub, vk_simp, do_rusub, 1, no, yes, no, no, no):
98 vop(vo_abs, vk_simp, do_abs, 1, no, yes, no, no, no):
dsj 48 vop(vo_float, vk_simp, do_float, 1, no, yes, no, no, no):
dsj 49 vop(vo_ifix, vk_simp, do_ifix, 1, no, yes, no, no, no):
dsj 50 vop(vo_int, vk_simp, do_ifix, 1, no, yes, no, no, no):
dsj 51 vop(vo_aint, vk_simp, do_aint, 1, no, yes, no, no, no):
dsj 52 vop(vo_amod, vk_simp, do_amod, 2, no, yes, no, no, no):
99 vop(vo_iabs, vk_simp, do_iabs, 1, no, yes, no, no, no):
100 vop(vo_mod, vk_simp, do_mod, 2, no, yes, no, no, no):
101 vop(vo_sign, vk_simp, do_sign, 2, no, yes, no, no, no):
102 vop(vo_isign, vk_simp, do_isign, 2, no, yes, no, no, no):
103 vop(vo_dim, vk_simp, do_dim, 2, no, yes, no, no, no):
104 vop(vo_idim, vk_simp, do_idim, 2, no, yes, no, no, no):
105 vop(vo_seq, vk_simp, do_seq, 2, no, yes, no, no, no):
106 vop(vo_sne, vk_simp, do_sne, 2, no, yes, no, no, no);
107
108 macdrop(vop)
109
110 size inv(1); $ on if operands should be inverted
111 size xargs(1); $ on if operation has values in -xarg-
112 size storflag(1); $ on if must do 'storall' for op
113 size opkind(ps); $ operation type
114 size ignorevoa(1); $ flag to ignore dead -voa- ops
115 size t1(ps), t2(ps); $ temporaries
116 size i(ps), j(ps); $ loop variables.
117
118 size uio_routs(.sds. 7); $ routine names for unformatted i/o.
119 dims uio_routs(4); $ var/array and input/output
vaxa 167 .+t10 data uio_routs = 'rdlv$i', 'rdla$i',
vaxa 168 .+t10 'wtlv$i', 'wtla$i';
vaxa 169 .+t32 data uio_routs = 'rdlv$io', 'rdla$io',
vaxa 170 .+t32 'wtlv$io', 'wtla$io';
122
123
124 ignorevoa = no; $ initially don't ignore -voa- ops.
125
126 $ begin loop over -voa-.
127 voaep = voahead; reissuedop = yes; $ set initial status.
128 while yes; $ loop while more in chain.
129
130 $ see if should reissue last operation or if should
131 $ get a new one.
132 if reissuedop then $ must re-issue.
133 reissuedop = no; $ clear flag.
134 vopcode = vv_opcode voa(voaep); $ get -voa- op. code.
135 else $ get new operation.
136 voaep = vv_chain voa(voaep); $ step to next.
137 if (voaep = 0) quit while; $ exit at end of chain.
138 vopcode = vv_opcode voa(voaep); $ get -voa- op. code.
139 $ see if dead operation.
140 if (vopcode ^= vo_lab & ignorevoa) cont while; $ skip.
141 end if;
142
143 $ have a -voa- entry must process. extract
144 $ parameters for this opcode from -voptab-.
145 dopnargs = vt_nargs voptab(vopcode); $ number of args.
146 inv = vt_inv voptab(vopcode); $ 'invert arguments'
147 dophasout = vt_isout voptab(vopcode); $ 'has output'
148 dopcode = vt_dop voptab(vopcode); $ operation to issue
149 xargs = vt_xargs voptab(vopcode); $ 'uses -xarg-'
150 storflag = vt_storall voptab(vopcode); $ 'do -storall-'
151 opkind = vt_kind voptab(vopcode); $ operation type
152 ignorevoa = vt_ign voptab(vopcode); $ new setting
153
154 .+trace. $ generate trace code.
155 if trace_any then $ if any trace, give -voa- pointer.
156 tintl('voaep', voaep)
157 if trace_v then $ print operations.
158 tintl('op', vopcode) tintl('ign', ignorevoa)
159 tintl('kind', opkind) tintl('inv', inv)
160 end if;
161 endl
162 end if;
163 ..trace
164 $ if this is an operation with an output, but the lastuse
165 $ field of the operatin is zero, it means that the output
166 $ will never be used. thus there is no need to issue the
167 $ operation. operations of this type occur mostly in the
168 $ 'a(i) to a(j)' construct in the formatted and unformatted
169 $ io statements.
170 if (dophasout & vv_lastuse voa(voaep) = 0) cont while;
171
172 $ start processing. first, see if must store regs.
173 if (storflag) call storall; $ if need to store regs.
174
175 $ get arguments.
176 go to n(dopnargs) in 0 to 4; $ select number to get.
177
178 /n(4)/ $ four arguments.
179 assign(doplr, va_inp4); $ get fourth argument.
180 /n(3)/ $ three arguments
181 assign(dopkr, va_inp3); $ get third argument.
182 /n(2)/ $ two arguments
183 assign(dopjr, va_inp2); $ get second argument.
184 /n(1)/ $ one argument
185 assign(dopir, va_inp1); $ get first argument.
186 /n(0)/ $ no arguments - fall through to next step.
187
188 $ invert first & second args, if needed.
189 if inv then t1 = dopjr; dopjr = dopir; dopir = t1; end if;
190 $ get output, if it exists.
191 if dophasout then assign(dopor, va_oup); end if;
192 $ get extra arguments (-xarg-), if they exist.
193 if xargs then $ they do exist.
194 dopnx = vv_arglen voa(voaep); $ get number of arguments.
195 do t1 = 1 to dopnx; $ process each argument.
196 assign(dopxr(t1), va_xarg+t1)
197 end do;
198 else
199 dopnx = 0; $ no arguments present.
200 end if;
201
202 $ branch on opcode type.
203 go to l(opkind) in 1 to num_vk;
204
205 /l(vk_simp)/
206 $ simple operation - issue it.
207 call emitdop;
208 cont while;
209
210 /l(vk_scall)/
211 $ subroutine call.
vaxa 171 .+t10 sdlname(dopsname, vv_naym voa(voaep)); $ get (long) name to c
vaxa 172 .+t32 sdsname(dopsname, vv_naym voa(voaep)); $ get name to call.
213
214 $ subroutine call ends basic block if -vv_seblk- flag set.
215 if vv_seblk voa(voaep) then $ want to end block.
216 calldropgl = yes; $ indicate call should drop globals.
217 else $ indicate it shouldn't drop parameters.
218 callnodrop = yes; $ set special case flag.
219 end if;
220
221 call emitdop; $ issue call.
222
223 if (vv_seblk voa(voaep)) call endblock; $ end block.
224
225 cont while;
226
227 /l(vk_fcall)/
228 $ function call.
229 sdsname(dopsname, vv_naym voa(voaep)) $ get name to call.
230 callnodrop = yes; $ function cant change parameters.
dsk 289 calldropgl = fag_opt; $ set whether or not to drop globals.
231 call emitdop; $ issue call
232 cont while;
233
234 /l(vk_data)/
235 $ -data- statement. in this case call a special
236 $ routine, -asmdata-, to process this -voa- entry.
237 call asmdata;
238 cont while;
239
240 /l(vk_fasin)/
241 $ .f. field assignment.
242 call emitdop; $ issue it, or old code.
243 cont while;
244
245 /l(vk_io)/
246 $ unformatted io. this is to be assembled as a subroutine
247 $ call. generate the parameter list and issue a
248 $ subroutine call operation.
249 dopxr(1) = dopjr; $ first is i/o item.
250 assignconst(dopxr(2), syze(dopjr)) $ second is size.
251 if vv_inp3 voa(voaep) then $ if array slice.
252 dopnx = 4; $ show four parameters.
253 assign(dopxr(3), va_inp3) $ third is from inp3.
254 if vv_arglen voa(voaep) then $ get hi value.
255 assign(dopxr(4), va_xarg+1) $ get fourth value.
256 else $ if hi = lo.
257 dopxr(4) = dopxr(3); $ copy value.
258 using(dopxr(3)); $ show additional use.
259 end if;
260 else $ this is simple variable case.
261 dopnx = 2; $ set short parameter list length.
262 end if;
263 $ select routine to call depending on whether this is
264 $ input or output and whether this is slice or not.
265 dopsname = uio_routs(2*(vv_oup voa(voaep)) + (dopnx>2) + 1);
266 dopnargs = 0; dophasout = (dopcode = do_fcall); $ reset.
267 callnodrop = (vv_oup voa(voaep) > 0);
dse 14 kill(dopir);
268 call emitdop; $ issue call to i/o routine.
270 $ if input call, this ends block.
271 if (vv_oup voa(voaep) = 0) call endblock;
272 cont while;
273
274 /l(vk_ext)/
275 $ .f. extract.
276 call emitdop; $ issue operation.
277 cont while;
278
279 /l(vk_if)/
280 $ -if- or -ifnot- operation. get label number and issue.
281 dopjr = vv_inp2 voa(voaep); $ label is in -vv_inp2-.
282 call emitdop;
283 cont while;
284
285 /l(vk_lab)/
286 $ label. end basic block and define label.
287 call endblock;
288 labdef(vv_inp1 voa(voaep), yes) $ label is in -vv_inp1-.
289 cont while;
290
291 /l(vk_goto)/
292 $ goto operation. get label number and issue.
293 dopir = vv_inp1 voa(voaep); $ label is in -vv_inp1-.
294 call emitdop; $ issue operation.
295 cont while;
296
297 /l(vk_goby)/
298 $ indexed -goto-. copy labels and issue.
299 dopnx = vv_arglen voa(voaep); $ get no. of labels.
300 t1 = vv_argbeg voa(voaep)-1; $ save time in loop.
301 do t2 = 1 to dopnx; $ move in each label.
302 dopxr(t2) = xa_voa xarg(t1+t2); $ copy from -xarg-.
303 end do;
304 call emitdop; $ issue operation.
305 cont while;
306
307 /l(vk_xfasin)/
308 $ .f. x, y, a(i) op, indexed extract.
309 call emitdop; $ issue operation.
310 cont while;
311
312 /l(vk_mwbin)/
313 $ .cc. or .in. operation. process as subroutine call.
314 dopsname = longname(vopcode); $ get routine name.
315 dopnx = 3; $ this call has three parameters.
316 dopxr(1) = dopir; dopxr(2) = dopjr; $ first two are inputs.
317 dopxr(3) = dopor; $ third parameter is output.
318 if (vopcode = vo_in) dopnx = 2; $ .in. is function.
319 dopnargs = 0; dophasout = (dopcode = do_fcall); $ reset.
320 call emitdop; $ issue op.
321 cont while;
322
323 /l(vk_sasin)/
324 $ .s. assignment operation. process as subroutine call.
325 dopsname = longname(vo_sasin); $ get routine name.
326 dopnx = 4; $ set to four parameters.
327 dopxr(1) = dopkr; $ first argument is position.
328 dopxr(2) = doplr; $ second is length.
329 dopxr(3) = dopjr; $ third is source.
330 dopxr(4) = dopir; $ and fourth is target.
331 dopnargs = 0; dophasout = (dopcode = do_fcall); $ reset.
332 call emitdop; $ issue call.
333 cont while;
334
335 /l(vk_sext)/
336 $ .s. extraction. process as subroutine call.
337 dopsname = longname(vo_sext); $ get routine name.
dsh 11 dopnx = 4; $ call has four parameters.
339 dopxr(1) = dopir; $ first is character position.
340 dopxr(2) = dopjr; $ second is length.
341 dopxr(3) = dopkr; $ third is source.
342 dopxr(4) = dopor; $ and fourth is output.
344 dopnargs = 0; dophasout = (dopcode = do_fcall); $ reset.
345 call emitdop; $ issue operation.
346 cont while;
347
348 end while; $ end of main -voa- loop.
349
350
351 macdrop(vt_ign) macdrop(vt_storall)
352 macdrop(vt_xarg) macdrop(vt_isout)
353 macdrop(vt_inv) macdrop(vt_nargs)
354 macdrop(vt_dop) macdrop(vt_kind)
355
356 macdrop(vk_data) macdrop(vk_easin)
357 macdrop(vk_simp) macdrop(vk_ext)
358 macdrop(vk_fasin) macdrop(vk_fcall)
359 macdrop(vk_goby) macdrop(vk_goto)
360 macdrop(vk_if) macdrop(vk_io)
361 macdrop(vk_lab) macdrop(vk_mwbin)
362 macdrop(vk_sasin) macdrop(vk_scall)
363 macdrop(vk_sext) macdrop(vk_xeasin)
364 macdrop(vk_sasin) macdrop(num_vk)
365
366 end subr asmprog;
1 .=member emitdop
2 subr emitdop; $ process deferred-level operations.
3 $ this routine processes each 'deferred' operation sent
4 $ by -asmprog-. the attributes of each operation are
5 $ kept in the table -doptab-. -emitdop- checks to see
6 $ if deferring mode is enabled (compilation option) and
7 $ whether the operation being processed can be deferred.
8 $ if so, the operation will be deferred until its operands
9 $ are needed. next, unless it is flagged as permissable
10 $ for an operand of the current operation to be deferred,
11 $ the current operation is reissueed until the operand at
12 $ fault is evaluated.
13 $
14 $ if the processor for any operation find that an operand
15 $ has been deferred and the operation that yields the operand
16 $ is not one the enables a special case, that processor will
17 $ branch to label -reissue- to indicate that the current
18 $ operation must be reissueed until the operand can be
19 $ evaluated. the operation to execute is passed in the
20 $ variable -dophold-. note that the processor must
21 $ determine if it must force evaluation of any operands
22 $ before it does 'anything else' that affects status
23 $ of the compilation.
24
25 size doptab(ws); $ deferred operation table.
26 dims doptab(num_do); $ length of table.
27
28 $ fields in -doptab-.
29
30 +* dt_dx = .f. 01, 1, ** $ '-xargs- can be deferred'
31 +* dt_do = .f. 02, 1, ** $ 'output can be deferred'
32 +* dt_d4 = .f. 03, 1, ** $ 'input four can be deferred'
33 +* dt_d3 = .f. 04, 1, ** $ 'input three can be deferred'
34 +* dt_d2 = .f. 05, 1, ** $ 'input 2 can be deferred'
35 +* dt_d1 = .f. 06, 1, ** $ 'input 1 can be deferred'
36 +* dt_defer = .f. 07, 1, ** $ 'operation should be deferrred'
37 +* dt_spcasin = .f. 08, 1, ** $ 'operation is special cased'
38 +* dt_type = .f. 09, 8, ** $ operation type
39 +* dt_aop = .f. 17, 8, ** $ operation to issue
40
41 $ deferred operation types.
42
43 .+eab.
44 +* dk_asin = 01 ** +* dk_simp0 = 14 **
45 +* dk_bool = 02 ** +* dk_simp1 = 15 **
46 +* dk_casin = 03 ** +* dk_simp2 = 16 **
47 +* dk_cext = 04 ** +* dk_xasin = 17 **
48 $ casin and cext should never occur for s10, but keep codes now.
49 +* dk_easin = 05 ** +* dk_xeasin = 18 **
50 +* dk_eext = 06 ** +* dk_xload = 19 **
51 +* dk_fasin = 07 ** +* dk_xsasin = 20 **
52 +* dk_fcall = 08 ** +* dk_mod = 21 **
53 +* dk_fext = 09 ** +* dk_dim = 22 **
54 +* dk_fnb = 10 ** +* dk_return = 23 **
55 +* dk_goto = 11 ** +* dk_seq = 24 **
56 +* dk_if = 12 ** +* dk_goby = 25 **
57 +* dk_not = 13 ** +* dk_comp = 26 **
58
59 +* num_dk = 26 ** $ number of types.
60 .-eab.
61 .=zzyorg a
62
63 defc(dk_asin)
64 defc(dk_bool)
65 defc(dk_easin)
66 defc(dk_eext)
67 defc(dk_fasin)
68 defc(dk_fcall)
69 defc(dk_fext)
70 defc(dk_goto)
71 defc(dk_if)
72 defc(dk_not)
73 defc(dk_simp0)
74 defc(dk_simp1)
75 defc(dk_simp2)
76 defc(dk_mod)
77 defc(dk_xasin)
78 defc(dk_xeasin)
79 defc(dk_xload)
80 defc(dk_xsasin)
81 defc(dk_return)
82 defc(dk_seq)
83 defc(dk_dim)
84 defc(dk_goby)
85 defc(dk_comp)
86
87 +* num_dk = dk_comp **
88 ..eab
89
90 $ macro to initialize -doptab-.
91 +* dop(num, df, of, as, typ, aop) =
92 doptab(num) = aop*4b'10000'+typ*4b'100'+
93 as*4b'80' + df*1b'1000000' + of **
94
95 data $ build table.
96
97
98 $ dop def 1234ox as type aop
99 $ --- --- ------ -- ---- ---
100
101 dop(do_add, yes, 1b'001100', yes, dk_simp2, ao_iad):
102 dop(do_sub, yes, 1b'001100', yes, dk_simp2, ao_isu):
103 dop(do_lt, yes, 1b'111100', no, dk_comp, ao_ilt):
104 dop(do_ge, yes, 1b'111100', no, dk_comp, ao_ige):
105 dop(do_eq, yes, 1b'111100', no, dk_comp, ao_ieq):
106 dop(do_ne, yes, 1b'111100', no, dk_comp, ao_ine):
107 dop(do_mul, yes, 1b'001100', yes, dk_simp2, ao_imu):
108 dop(do_div, yes, 1b'001100', no, dk_simp2, ao_idi):
109 dop(do_and, yes, 1b'111100', no, dk_bool, ao_ban):
110 dop(do_or, yes, 1b'111100', no, dk_bool, ao_bor):
111 dop(do_exor, yes, 1b'001100', yes, dk_bool, ao_bxo):
112 dop(do_fb, yes, 1b'011100', yes, dk_simp1, ao_bfb):
113 dop(do_nb, yes, 1b'011100', yes, dk_simp1, ao_bnb):
114 dop(do_not, yes, 1b'111100', yes, dk_not, ao_bno):
115 dop(do_fcall, no, 1b'111100', no, dk_fcall, 0):
116 dop(do_scall, no, 1b'111110', no, dk_simp0, 0):
117 dop(do_asin, no, 1b'011110', no, dk_asin, 0):
118 dop(do_fasin, no, 1b'001010', no, dk_fasin, 0):
119 dop(do_return, no, 1b'111110', no, dk_return, 0):
120 dop(do_fext, yes, 1b'101100', no, dk_fext, 0):
121 dop(do_if, no, 1b'111110', no, dk_if, 0):
122 dop(do_goto, no, 1b'111110', no, dk_goto, 0):
123 dop(do_xload, yes, 1b'011100', no, dk_xload, 0):
124 dop(do_xasin, no, 1b'001110', no, dk_xasin, 0):
125 dop(do_xfasin, no, 1b'001011', no, dk_fasin, 0):
126 dop(do_ifnot, no, 1b'111110', no, dk_if, 0):
127 dop(do_eext, no, 1b'000100', no, dk_eext, 0):
dsh 12 dop(do_easin, no, 1b'000010', no, dk_easin, 0):
dse 15 dop(do_xeasin, no, 1b'001010', no, dk_xeasin, 0):
130 dop(do_xsasin, no, 1b'001010', no, dk_xsasin, 0):
131 dop(do_radd, yes, 1b'001100', yes, dk_simp2, ao_rad):
132 dop(do_rsub, yes, 1b'001100', no, dk_simp2, ao_rsu):
133 dop(do_rlt, yes, 1b'001100', no, dk_simp2, ao_rlt):
134 dop(do_rge, yes, 1b'001100', no, dk_simp2, ao_rge):
135 dop(do_req, yes, 1b'001100', yes, dk_simp2, ao_req):
136 dop(do_rne, yes, 1b'001100', yes, dk_simp2, ao_rne):
137 dop(do_rmul, yes, 1b'001100', yes, dk_simp2, ao_rmu):
138 dop(do_rdiv, yes, 1b'001100', no, dk_simp2, ao_rdi):
139 dop(do_rusub, yes, 1b'011100', yes, dk_simp1, ao_rco):
140 dop(do_abs, yes, 1b'011100', yes, dk_simp1, ao_rab):
dsj 53 dop(do_ifix, yes, 1b'011100', yes, dk_simp1, ao_ifr):
dsj 54 dop(do_float, yes, 1b'011100', yes, dk_simp1, ao_rfi):
dsj 55 dop(do_aint, yes, 1b'011100', yes, dk_simp1, ao_rtr):
dsj 56 dop(do_amod, yes, 1b'001100', no, dk_simp2, ao_rmo):
141 dop(do_iabs, yes, 1b'011100', yes, dk_simp1, ao_iab):
142 dop(do_mod, yes, 1b'001100', no, dk_mod , ao_imo):
143 dop(do_sign, yes, 1b'001100', no, dk_simp2, ao_rsi):
144 dop(do_isign, yes, 1b'001100', no, dk_simp2, ao_isi):
145 dop(do_dim, yes, 1b'001100', no, dk_dim , ao_rsu):
146 dop(do_idim, yes, 1b'001100', no, dk_dim , ao_isu):
147 dop(do_seq, no, 1b'001100', no, dk_seq, 0):
148 dop(do_sne, no, 1b'001100', no, dk_seq, 0):
149 dop(do_goby, no, 1b'011111', no, dk_goby, 0);
150
151 $ the deferring entry is one if entry can be deferred and
152 $ zero if it cannot be deferred. if no input, the entry
153 $ is one indicating it can be deferred, but later code
154 $ detects that actually no input.
155 macdrop(dop)
156
157
158 size work(ps), work1(ps); $ temporary operands.
159 size i(ps), j(ps); $ temporary variables
160 size lab(ps); $ temporary label.
161 size type(ps); $ type of operation.
162 size aop(ps); $ operation to issue.
163 size resform(ps); $ result form.
164 size invform(ps); $ inverse forms.
165 size mask(ws); $ mask used for -not-.
166
167 .+trace. $ assembler trace code
168 if trace_o then $ trace is wanted.
169 tintl('dop', dopcode)
170 if dopcode>0 & dopcode<=num_do then
171 textl(' ') textl(dopname(dopcode)) textl(' ')
172 end if;
173
174 tintl('i', dopir)
175 tintl('j', dopjr) tintl('k', dopkr)
176 tintl('l', doplr) tintl('o', dopor) endl
177 end if;
178 ..trace
179
180 .+defer. $ code used only if defering ops.
181 if (opt_d = no) go to issue; $ skip if not defering.
182
183 $ check if any inputs to this operation are unevaluated
184 $ operations and the corresponding input is not allowed
185 $ to be such operations. if so, branch to -reissue- to process
186 $ and evaluate that operation.
187
188 if dt_d1 doptab(dopcode) = no then $ check first operand.
189 dophold = dout(dopir); $ get result op.
190 if (dophold) go to reissue; $ branch if there is one.
191 end if;
192
193 if dt_d2 doptab(dopcode) = no then $ second operand
194 dophold = dout(dopjr);
195 if (dophold) go to reissue;
196 end if;
197
198 if dt_d3 doptab(dopcode) = no then $ third operand
199 dophold = dout(dopkr);
200 if (dophold) go to reissue;
201 end if;
202
203 if dt_d4 doptab(dopcode) = no then $ fourth operand.
204 dophold = dout(doplr);
205 if (dophold) go to reissue;
206 end if;
207
208 if dt_do doptab(dopcode) = no then $ output
209 dophold = dout(dopor);
210 if (dophold) call aermey(31);
211 end if;
212
213 if dopnx then $ check arguments.
214 if dt_dx doptab(dopcode) = no then $ must not be deferred.
215 do i = 1 to dopnx; $ test each one.
216 dophold = dout(dopxr(i));
217 if (dophold) go to reissue;
218 end do;
219 end if;
220 end if;
221
222
223 $ check if this operation itself is to be deferred.
224 if dt_defer doptab(dopcode) then $ it is to be deferred.
225 if (dopfree = 0) go to issue; $ table is full.
226
227 $ after having verified that a table entry exists, build
228 $ one for this operation.
229 doptr = dopfree; dopfree = dp_chain dops(dopfree);
230 dops(doptr) = 0; $ clear entry.
231 dp_inp1 dops(doptr) = dopir; $ set first input.
232 dp_inp2 dops(doptr) = dopjr; $ set second input.
233 dp_inp3 dops(doptr) = dopkr; $ set third input.
234 dp_oup dops(doptr) = dopor; $ set output.
235 dp_op dops(doptr) = dopcode; $ set operation code.
236 dp_nargs dops(doptr) = dopnargs; $ set number of inputs.
237 .+trace if trace_o then tintl(' *defer*', doptr) endl end if;
238 dout(dopor) = doptr; $ point back to this operation.
239 di_count ditem(dr_item dreg(dopor)) = $ decrement count.
240 di_count ditem(dr_item dreg(dopor)) - 1;
241
242 return; $ done with this case
243 end if;
244
245 /issue/ $ issue operation
246 ..defer
247
248 $ extract fields from descriptive table to determine type
249 $ of processing needed for each operation.
250 type = dt_type doptab(dopcode); $ -goto- index.
251 aop = dt_aop doptab(dopcode); $ operation code for lower-level.
252
253 $ branch on operation type.
254 go to l(type) in 1 to num_dk;
255
256 /l(dk_comp)/
257 $ comparison operators. merely check for deferred inputs.
258 .+defer.
259 dophold = dout(dopir); $ get first input operation.
260 if (dophold) go to reissue; $ this is not ok.
261 dophold = dout(dopjr); $ check second operand.
262 if (dophold) go to reissue;
263 ..defer
264 go to l(dk_simp2);
265
266
267 /l(dk_simp2)/
268 $ simple two-operand operations. in this case call
269 $ a routine to check for special cases and just issue
270 $ the operation.
271
272 $ check for multi-word.
273 if (ismw(dopir) ! ismw(dopjr)) go to multi;
274
275 $ see if special case.
276 call special;
277 if (isspecial) go to endop; $ done if so.
278
279 $ set status flags.
280 lastuse(dopir); lastuse(dopjr); lastuse(dopor); $ set status.
281 bin_op(aop, dopor, dopir, dopjr); $ issue operation.
282 go to endop; $ done.
283
284 /l(dk_simp1)/
285 $ simple unary operation.
286 if (ismw(dopir)) go to multi; $ check for multi-word.
287 lastuse(dopir); lastuse(dopor); $ set status.
288 un_op(aop, dopor, dopir); $ issue operation.
289 go to endop;
290
291 /l(dk_simp0)/
292 $ operations without arguments.
293 call_op; $ this can only be a call.
294 go to endop;
295
296 /l(dk_bool)/
297 $ boolean operation (.or., .and., .exor.).
298 $ in this case call a routine to check for special cases.
299 $ otherwise, process as simple operation.
300
301 .+defer.
302 $ since these operands can be deferred must check that they
303 $ are not in this case. this arises in the case of an assignment
304 $ to a variable of a logical expression. i.e., in the
305 $ statement x = (i>j ! a = b);
306 $ in this case, the two comparisons and the -or- will be
307 $ deferred in the hope that this is part of an -if- statement.
308 $ when it is discovered that it is not, the comparisons must
309 $ be performed prior to performing the -or- operation.
310 dophold = dout(dopir); $ check first input.
311 if (dophold) go to reissue; $ force evaluation.
312 dophold = dout(dopjr); $ check second input.
313 if (dophold) go to reissue; $ force evaluation.
314 ..defer
315
316 go to l(dk_simp2); $ else, process as simple operation.
317
318 .+eab.
319 /l(dk_fnb)/
320 $ .fb. or .nb. operation.
321 $ in this case, a check is made to see if the operand is
322 $ not in standard form. in this (unlikely) case, the operation
323 $ is a no-op and will merely cause a copy, if needed.
324
325 if (ismw(dopir)) go to multi; $ check for multi-word.
326
327 $ this is the normal case. put into register 0 and call
328 $ offline routine. upon return from this routine, the
329 $ result will be in register 0.
330 lastuse(dopir); $ indicate last use in processor.
331 forcezero(dopir, no); $ force value into r0.
332 if dopcode = do_nb then $ set routine name.
333 dopsname = 'nbop$sw'; $ single-word .nb.
334 else $ must be .fb.
335 dopsname = 'fbop$sw'; $ single-word .fb.
336 end if;
337 callnodrop = yes; call_op; $ issue call
338 lastuse(dopor); $ set status.
339 inzero(dopor, no); $ show value in r0.
340 go to endop; $ done.
341 ..eab
342
343 /l(dk_not)/
344 $ .not. operation.
345
346 .+defer.
347 $ check if input is a deferred operation. this can occur for
348 $ similar reasons as for booleans.
349 dophold = dout(dopir); $ see if deferred result.
350 if (dophold) go to reissue;
351 ..defer
352
353 if (ismw(dopir)) go to multi; $ handle multi-word.
354
355 $ see if this is a full word .not.
356 if syze(dopir) = mws then $ it is full word.
357 lastuse(dopir); lastuse(dopor); $ set status.
358 not_op(dopor, dopir); $ negate.
359 else $need longer code.
360 getdreg(work); $ get a temporary.
361 lastuse(dopir); $ set status.
362 not_op(work, dopir); $ negate input.
363 lastuse(work); lastuse(dopor); $ set status.
vaxa 173 .+t10 lpr_op(dopor, work, 0, syze(dopor)); $ extract significant pa
vaxa 174 .+t32 assignconst(i, 0); lastuse(i); $ get first bit.
vaxa 175 .+t32 assignconst(j, syze(dopor)); lastuse(j); $ get length.
vaxa 176 .+t32 lpr_op(dopor, work, i, j); $ extract significant pa
365 end if;
366
367 go to endop; $ done.
368
369 /l(dk_fcall)/
370 $ function call. issue call and retrieve result from r0.
dsk 290 forcezero(0, no); call_op;
372 lastuse(dopor); inzero(dopor, ismw(dopor)); $ get result.
373 go to endop; $ done.
374
375 /l(dk_asin)/
376 $ simple assignment.
377 $ first, check for multi-word case. in multi-word case, move
378 $ and clear, as appropriate.
379 if ismw(dopir) then $ multi-word output.
380
381 .+defer.
382 $ first, check if input is a deferred operation and force
383 $ evaluation if so.
384 dophold = dout(dopjr); $ check input.
385 if (dophold) go to reissue;
386 ..defer
387
388 if ismw(dopjr) then $ multi-word input too.
389 if nwords(dopjr) < nwords(dopir) then $ must clear
390 getaddr(work, dopir, 1, 0); $ get address.
391 i = nwords(dopir)-nwords(dopjr); $ get no. of words.
392 clear_op(work, i); $ clear first part.
393 else $ will fit. need not clear.
394 i = 0; $ set start offset to zero.
395 end if;
396 getaddr(work, dopir, i+1, 0); $ get proper word.
397 getaddr(work1, dopjr, 1 + idim(nwords(dopjr), $ source.
398 nwords(dopir)), 0); $ place to start move from.
399 lastuse(work1); lastuse(work); $ set status.
400 smove_op(work, work1, nwords(work)-i); $ move source.
401 else $ source is single-word.
402 i = nwords(dopir); $ save for later.
403 getaddr(work, dopir, 1, 0); $ first word.
404
405 $ check for special case of assignment to zero.
406 if isscon(dopjr) & conval(dopjr) = 0 then
407 lastuse(work); $ set status.
408 clear_op(work, i); $ clear.
409 lastuse(dopjr); drop(dopjr);
410 else $ store in word.
411 clear_op(work, i-1); $ clear all but last word.
412 lastuse(dopir); lastuse(dopjr); $ set status.
413 storeword(dopjr, dopir, i, 0); $ store into last word
414 $ clear all but last word.
415 end if;
416 end if;
417 else $ simple, single-word assignment.
418
419 .+defer.
420 $ check for the case where the operation of the input
421 $ is of a very simple type. in this case, the operation
422 $ can be issued with the assignment target as its output
423 $ provided that this is last use of input. this will
424 $ generate more efficient code in many cases.
425 dophold = dout(dopjr); $ get input op.
426 if dophold then $ check if this is special.
427 if (di_ldrop ditem(dr_item dreg(dopjr)) = no !
428 di_count ditem(dr_item dreg(dopjr)) ^= 1)
429 go to reissue; $ cannot modify output yet.
430 if (dt_spcasin doptab(dp_op dops(dophold)) = no)
431 go to reissue; $ not special operation.
432
433 $ get inputs of this operation and check for
434 $ multi-word.
435 work = dp_inp1 dops(dophold); $ set new first input.
436 work1 = dp_inp2 dops(dophold); $ set new second input.
437 i = dp_nargs dops(dophold); $ save argument count.
438 if (ismw(work)) go to reissue;
439
dsk 291 if dout(work) then $ input is a deferred op.
dsk 292 dophold = dout(work); go to reissue; $ reissue it.
dsk 293 end if;
dsk 294
440 $ check for 1 or 2 operand operation and process.
441 if i=2 then $ 2-operand.
442 if (ismw(work1)) go to reissue; $ not special.
dsk 295 if dout(work1) then $ input is a deferred operation
dsk 296 dophold = dout(work1); go to reissue;
dsk 297 end if;
dsk 298
443 using(work1); $ show using this operand.
444 end if;
445
446 $ kill the input operation and reset to issue
447 $ this operation again differently.
448 using(work); $ show using this input.
449 kill(dopjr); $ drop old operation.
450 dopor = dopir; dopir = work;
451 dopjr = work1; dopnargs = i;
452 dopcode = dp_op dops(dophold); dophasout = yes;
453
454 $ if the output is the same as an input, can reset
455 $ live status.
456 if dopor = dopir ! (dopor = dopjr & dopnargs = 2 ) then
457 if dr_reg dreg(dw_freg dword(dr_word dreg(dopir)))
rkd 11 ^=0 & (dopor=dopir) then
rkd 12 rl_subtype reglis(dr_reg dreg(dopir))
459 = rt_need;
460 end if;
rkd 13 if dopnargs=2 then
rkd 14 if dr_reg dreg(dw_freg dword(dr_word dreg(dopjr)))
rkd 15 ^=0 & (dopor=dopjr) then
rkd 16 rl_subtype reglis(dr_reg dreg(dopjr))
rkd 17 = rt_need;
rkd 18 end if;
rkd 19 end if;
461 spcdrop = yes; $ set special -clear- operation.
462
463 $ since the usage count of the input should
464 $ be one less then it is, must decrement usage
465 $ count. however, must also pre-decrement the
466 $ lastuse count so that this ihem is not dropped
467 $ too early.
468 di_count ditem(dr_item dreg(dopor)) =
469 di_count ditem(dr_item dreg(dopor)) - 1;
470 di_luse ditem(dr_item dreg(dopor)) =
471 di_luse ditem(dr_item dreg(dopor))
472 + di_luseminus1val;
473 end if;
474
475 clear(dopor); $ clear output.
476 spcdrop = no; $ clear in case special was set.
477 go to issue; $ re-issue.
478 end if;
479 ..defer
480
481 clear(dopir); $ clear output
482 getword(dopjr, dopjr, nwords(dopjr), 0); $ get proper word.
483 lastuse(dopir); lastuse(dopjr); $ set status
484 move_op(dopir, dopjr); $ move (copy if needed)
485 end if;
486
487 go to endop; $ done.
488
489 /l(dk_fasin)/
490 $ .f. assignment.
491 $ set register containing first bit and ensure that opcode
492 $ is for a field and not a character assignment.
493 work = dopkr; $ this is case for non-indexed.
494 if (dopcode = do_xfasin) work = dopxr(1);
495
496 call asmfld(work, doplr, dopir, dopjr); $ do .f. assignment.
497 .+defer if (dophold) go to reissue;
498
499 go to endop; $ done.
500
501 /l(dk_return)/
502 call aermey(4); $ this should not occur.
503
504 /l(dk_fext)/
505 $ .f. field extraction.
506 call asmfld(dopir, dopjr, dopkr, 0); $ do .f. extract
507 .+defer if (dophold) go to reissue;
508
509 go to endop; $ done.
510
511 /l(dk_xload)/
512 $ indexed load operation. calculate storage offset and
513 $ either shift or multiply index over. then get desired
514 $ address or value.
515 .+defer.
516 call asmdxchk(dopjr); $ check index.
517 if (dophold) go to reissue;
518 ..defer
519
520 doff = nwords(dopir); call asmxload(dopir, dopjr);
521
522 $ in multi-word case, get address of first (left-most) word.
523 $ in single-word case, get the word.
524 if ismw(dopir) then $ multi-word.
525 if dopjr then lastuse(dopir); lastuse(dopjr); end if;
526 getaddr(work, dopir, doff, dopjr); $ get addr.
527 lastuse(work); lastuse(dopor); $ set status.
528 call moveaddr(dopor, work); $ move address to -dopor-.
529 else $ single-word case.
530 if dopjr then lastuse(dopir); lastuse(dopjr); end if;
531 getword(work, dopir, doff, dopjr); $ get word.
532 $ move to output value.
533 lastuse(dopor); lastuse(work); $ set status.
534 move_op(dopor, work); $ issue move.
535 end if;
536 go to endop; $ done.
537
538 /l(dk_xasin)/
539 $ indexed assignment.
540 call asmxasin; $ call routine to generate indexed assignment.
541 .+defer if (dophold) go to reissue; $ must reissue prior op.
542 go to endop; $ done.
543
544 /l(dk_eext)/
545 $ .e. extraction. handle as routine call.
546 dopxr(1) = dopir; $ first parameter is first bit.
547 dopxr(2) = dopjr; $ second parameter is length.
548 dopxr(3) = dopkr; $ third is source.
549 assignconst(dopxr(4), syze(dopkr)) $ length of source.
550 dopxr(5) = dopor; $ target.
551 assignconst(dopxr(6), syze(dopor)) $ length of target.
552 dopsname = longname(vo_eext); $ get routine name.
553 callnodrop = yes; dopnx = 6; call_op; $ call with six parameters.
554 go to endop; $ done.
555
556 /l(dk_easin)/
557 $ .e. assignment. call off-line routine.
558 dopxr(1) = dopkr; $ first parameter is first bit.
559 dopxr(2) = doplr; $ second is length.
560 dopxr(3) = dopjr; $ third is source.
561 assignconst(dopxr(4), syze(dopjr)) $ length of source.
562 dopxr(5) = dopir; $ target.
563 assignconst(dopxr(6), syze(dopir)) $ length of target.
564 dopsname = longname(vo_easin); $ get routine name.
565 callnodrop = yes; dopnx = 6; call_op; $ call with six parameters.
566 go to endop; $ done.
567
568 /l(dk_xeasin)/
569 $ .e. indexed assignment. calculate address of target and
570 $ call off-line routine.
571 .+defer.
572 call asmdxchk(dopkr); $ check index.
573 if (dophold) go to reissue;
574 ..defer
575 doff = nwords(dopir); call asmxload(dopir, dopkr);
576
577 $ set up parameters for call.
578 $ (first parameter already set - first bit position)
579 dopxr(2) = doplr; $ second parameter is length.
580 dopxr(3) = dopjr; $ third parameter is source.
581 assignconst(dopxr(4), syze(dopjr)) $ length of source.
582 assignconst(dopxr(6), syze(dopir)) $ length of target.
583 if dopkr then lastuse(dopkr); lastuse(dopir); end if;
584 getaddr(work, dopir, doff, dopkr); dopxr(5) = work;
585 dopsname = longname(vo_easin); $ get routine name.
586 callnodrop = yes; dopnx = 6; call_op; $ call with six parameters.
587 go to endop; $ done.
588
589 /l(dk_xsasin)/
590 $ indexed .s. assignment. get address of target and call
591 $ off-line routine.
592 .+defer.
593 call asmdxchk(dopkr); $ check index.
594 if (dophold) go to reissue;
595 ..defer
596 doff = nwords(dopir); call asmxload(dopir, dopkr);
597
598 $ set up parameters. (parameter one is already set up)
599 dopxr(2) = doplr; $ length.
600 dopxr(3) = dopjr; $ source.
601 if dopkr then lastuse(dopir); lastuse(dopkr); end if;
602 getaddr(work, dopir, doff, dopkr); dopxr(4) = work;
603 dopsname = longname(vo_sasin); $ get name.
604 callnodrop = yes; dopnx = 4; call_op; $ call with four parms.
605 go to endop; $ done.
606
607 /l(dk_goto)/
608 $ go to operation. just issue.
609 goto_op(dopir); $ branch to label.
610 go to endop; $ done.
611
612 /l(dk_if)/
613 $ -if- operation. in complicated case, call a routine to
614 $ generate code. otherwise, just issue the appropriate branch.
615
616 .+defer.
617 dophold = dout(dopir); $ get deferred op for input, if any.
618 .+ifopt.
619 if dophold then $ must do something.
620 if (opt_f) call asmif; $ if optimization, call routine.
621 if (dophold) go to reissue; $ if must reissue something.
622 go to endop; $ otherwise done with operation.
623 end if;
624 .-ifopt if (dophold) go to reissue; $ if no optimzation, evaluate.
625 ..defer
626
627 $ simple case - select branch instruction from form of input.
628
629 aop = bm_zer;
630 if (dopcode = do_if) aop = binv(bm_zer); $ invert aop.
631 lastuse(dopir); $ set status.
632 if_op(aop, dopir, dopjr); $ issue branch.
633 go to endop; $ done.
634
635 /l(dk_seq)/
636 $ .seq. or .sne. comparison. handle as function call.
637 dopxr(1) = dopir; $ first parameter is input 1.
638 dopxr(2) = dopjr; $ second parameter is input 2.
639 dopsname = longname(vo_seq); $ get routine name.
rkc 9 forcezero(0, no); $ free up r0.
640 callnodrop = yes; dopnx = 2; call_op; $ call routine.
dsk 299 inzero(dopor, no); $ show function result.
dsk 300 if dopcode = do_sne then $ see if this was .sne.
dsk 301 lastuse(dopor); $ set lastuse status.
dsk 302 assignconst(work, 1); $ set to a one.
dsk 303 exor_op(dopor, dopor, work); $ negate value.
dsk 304 else $ this was a .seq.
dsl 13 kill(dopor); $ simply drop output.
dsk 306 end if;
dsk 307
643 go to endop; $ done.
644
645 /l(dk_mod)/
646 $ -mod- function. check for a power of two.
647 if .nb. conval(dopjr) = 1 then $ it is.
648 assignconst(work, conval(dopjr)-1); $ get mask.
649 kill(dopjr); $ drop unused constant.
650 lastuse(dopor); lastuse(dopir); lastuse(work);
651 and_op(dopor, dopir, work); $ do as -and- with mask.
652 go to endop; $ done in this special case.
653 end if;
654
655 $ otherwise process as normal operation.
656 go to l(dk_simp2);
657
658 /l(dk_dim)/
659 $ -idim- or -dim- function. generate as subtraction and test.
660 lastuse(dopir); lastuse(dopjr); $ set status.
661 bin_op(aop, dopor, dopir, dopjr); $ do subtraction.
662
663 $ get label and generate test.
664 labget(lab); $ get a label.
665 ifpos_op(dopor, lab); $ done if positive.
666 sub_op(dopor, dopor, dopor); $ else set to zero.
667 labdef(lab, no); $ define label.
668 labfree(lab); $ and free it.
669 kill(dopor); $ free output. note that this could not have
670 $ been done on the subtract because of the label.
671 go to endop;
672
673 /l(dk_goby)/ $ indexed -goto- operation.
674 call asmgoby; $ call routine to process.
675 go to endop; $ done with this operation.
676
677 /multi/
678 $ multi-word operation found. call routine to generate
679 $ call (or maybe inline code for some).
680 call asmlong;
681 go to endop; $ done with this operation.
682
683
684 /endop/
685
686 $ must do the housekeeping for the end of an operation.
687
688 do i = r0 to rhi; $ first clear all hold bits.
689 rl_hold reglis(i) = no; $ clear normal hold.
690 rl_addrhold reglis(i) = no; $ clear address hold.
dse 16 if (rl_type reglis(i) = rt_dead) reglis(i) = 0;
691 end do;
692
693
694 .+trace. $ write out desired traces.
695 if (trace_d) call dumpdregs;
696 if (trace_r) call dumpmregs;
697 ..trace
698
699
700 return; $ done with operation.
701
702
703 .+defer.
704 /reissue/ $ reissue current operation and process operation pointed
705 $ to by -dophold-.
706
707 $ must check to see if this is an intermediate
708 $ operation being passed over. in that case, this
709 $ operation must be deferred again.
710 if reissuedop then $ this is intermediate operation.
711 if (dopfree = 0) call aermey(29); $ table is full.
712
713 $ after having verified that a table entry exists, build
714 $ one for this operation.
715 doptr = dopfree; dopfree = dp_chain dops(dopfree);
716 dops(doptr) = 0; $ clear entry.
717 dp_inp1 dops(doptr) = dopir; $ set first input.
718 dp_inp2 dops(doptr) = dopjr; $ set second input.
719 dp_inp3 dops(doptr) = dopkr; $ set third input.
720 dp_oup dops(doptr) = dopor; $ set output.
721 dp_op dops(doptr) = dopcode; $ set operation code.
722 dp_nargs dops(doptr) = dopnargs; $ set number of inputs.
723 .+trace if trace_o then tintl(' *defer*', doptr) endl end if;
724 dout(dopor) = doptr; $ point back to this operation.
725 di_count ditem(dr_item dreg(dopor)) = $ decrement usage count.
726 di_count ditem(dr_item dreg(dopor)) - 1;
727 else $ this is not intermediate operation.
728 $ must drop all inputs of current operation to make it
729 $ look as though the operation was never issued.
730 spcdrop = yes; $ set for special handling in -dropr-.
731 go to n1(dopnargs) in 0 to 4; $ drop arguments.
732
733 /n1(4)/ kill(doplr);
734 /n1(3)/ kill(dopkr);
735 /n1(2)/ kill(dopjr);
736 /n1(1)/ kill(dopir);
737 /n1(0)/
738
739 if dophasout then kill(dopor); end if;
740
741 if dopnx ^= 0 & dopcode ^= do_goby then $ free extra args.
742 do i = 1 to dopnx;
743 kill(dopxr(i));
744 end do;
745 end if;
746
747 spcdrop = no; $ reset flag.
748
749 reissuedop = yes; $ flag for -asmprog- to re-issue.
750 end if;
751
752 $ clear output pointer of output of this operation.
753 dout(dp_oup dops(dophold)) = 0; $ because will do now.
754
755 $ reset variables to point to operation.
756 .+trace if trace_o then tintl(' *reset*', dophold) endl end if;
757 dopcode = dp_op dops(dophold); $ get operation code.
758 dopor = dp_oup dops(dophold); $ ... output.
759 dopir = dp_inp1 dops(dophold); $ ... input 1.
760 dopjr = dp_inp2 dops(dophold); $ ... input 2.
761 dopkr = dp_inp3 dops(dophold); $ ... input 3.
762 dopnargs = dp_nargs dops(dophold); $ ... number of inputs.
763 $ count use of the output again.
764 using(dopor); $ because dropped when deferred.
765
766
767 $ insert on free queue.
768 dp_chain dops(dophold) = dopfree; dopfree = dophold;
769
770 go to issue; $ issue operation.
771 ..defer
772
773 macdrop(dt_dx) macdrop(dt_do)
774 macdrop(dt_d4)
775 macdrop(dt_d3) macdrop(dt_d2)
776 macdrop(dt_d1) macdrop(dt_defer)
777 macdrop(dt_spcasin) macdrop(dt_type)
778 macdrop(dt_aop) macdrop(dt_resform)
779
780 macdrop(dk_asin) macdrop(dk_bool)
781 macdrop(dk_casin) macdrop(dk_cext)
782 macdrop(dk_easin) macdrop(dk_eext)
783 macdrop(dk_fasin) macdrop(dk_fcall)
784 macdrop(dk_fext) macdrop(dk_fnb)
785 macdrop(dk_goto) macdrop(dk_if)
786 macdrop(dk_not) macdrop(dk_simp0)
787 macdrop(dk_simp1) macdrop(dk_simp2)
788 macdrop(dk_xasin) macdrop(dk_xeasin)
789 macdrop(dk_xfasin) macdrop(dk_xload)
790 macdrop(dk_xsasin) macdrop(dk_mod)
791 macdrop(dk_dim) macdrop(dk_goby)
792 macdrop(num_dk)
793
794 end subr emitdop;
1 .=member asmxasi
2 subr asmxasin; $ process indexed assignment.
3 size work(ps), work1(ps); $ work registers.
4 size i(ps), j(ps); $ temporaries.
5
6 .+defer.
7 call asmdxchk(dopkr); $ check index.
8 if (dophold) return;
9 ..defer
10
11 doff = 1; call asmxload(dopir, dopkr); $ process index.
12
13 $ check for multi-word cases.
14 if ismw(dopir) then $ target multi-word.
15 j = nwords(dopir); $ get no. of words for later.
16 if ismw(dopjr) then $ source multi-word.
17 $ have two cases depending on the sizes of source
18 $ and target.
19 if nwords(dopjr) < nwords(dopir) then $ must zero-fill.
20 getaddr(work, dopir, doff, dopkr); $ get address.
21 i = nwords(dopir)-nwords(dopjr); $ length to clear.
22 if dopkr then lastuse(work); end if;
23 clear_op(work, i); $ clear to zero.
24 else $ need not zero-fill.
25 i = 0; $ difference is zero.
26 end if;
27 if dopkr then lastuse(dopir); lastuse(dopkr); end if;
28 getaddr(work, dopir, doff+i, dopkr);
dsa 14 getaddr(work1, dopjr, 1+idim(nwords(dopjr),j), 0);
30 $ move in source.
31 lastuse(work1); lastuse(work); $ set status.
32 smove_op(work, work1, (j-i));
33 return; $ done.
34 else $ source is single-word.
35 $ check for special case of assigning zero.
36 if isscon(dopjr) & conval(dopjr) = 0 then
37 kill(dopjr); $ free the zero.
38 $ point to first word in variable.
39 if dopkr then lastuse(dopkr);lastuse(dopir); end if;
40 getaddr(work, dopir, doff, dopkr);
41 lastuse(work); $ set status.
42 clear_op(work, j); $ clear to zero.
43 return; $ done.
44 else $ must clear high-order.
45 getaddr(work, dopir, doff, dopkr);
46 lastuse(work); $ set status $ check with s37 chngs
47 clear_op(work, (nwords(dopir)-1)); $ clear to zero.
48 $ fall through to single-word case.
49 end if;
50 end if;
51 end if;
52
53 $ in single-word case, merely store source into target array.
54 lastuse(dopir); lastuse(dopjr); $ set status.
55 if dopkr then lastuse(dopkr); end if;
56 storeword(dopjr, dopir, doff+nwords(dopir)-1, dopkr); $ store.
57
58 end subr asmxasin;
1 .=member asmdata
2 subr asmdata; $ process -data- statement.
3 $ -data- statements are processed by chaining them in order of
4 $ increasing subcript value, to the variable that it being
5 $ initialized.
6 size i(ps), j(ps); $ pointers.
7 size ind(ps); $ index value.
8
9 $ first get index value. if this is not for subscripted
10 $ variable or if the subscript is left out, set the index
11 $ to 1.
12 i = vv_inp3 voa(voaep); $ -voa- pointer to index.
13 if i then $ if index given.
14 ind = val(vv_vbeg voa(i)); $ load value.
15 else $ not given.
16 ind = 1; $ set to one.
17 end if;
18
19 $ index will be stored in -vv_inp1- of -data- operation for
20 $ later use.
21 vv_inp1 voa(voaep) = ind;
22
23 $ get pointers to variable to be initialized and to the
24 $ start of the data chain for it.
25 i = ha_ep ha(vv_naym voa(voaep)); $ point to -voa- entry.
26 .-vvfrs j = vv_frsdata voa(i); $ point to head of chain
27 .+vvfrs j = vvfrsdata(i); $ point to head of chain.
28
29 $ check if a chain is present.
30 if j then $ a chain is present.
31 $ see if this index is lower than the first entry in chain.
32 $ if so, then this becomes the first index in the chain.
33 if ind < vv_inp1 voa(j) then $ this becomes first in chain.
34 vv_inp2 voa(voaep) = j; $ maintain chain.
35 .-vvfrs vv_frsdata voa(i) = voaep;
36 .+vvfrs vvfrsdata(i) = voaep;
37 else $ not below first in chain.
38 $ search for the place at which this new entry
39 $ should be inserted in the chain. the 'maybe' loop
40 $ is exited when the entry has been added to the chain.
41 until yes; $ exit when added to chain/
42 while vv_inp2 voa(j); $ loop while more in chain.
43 i = vv_inp2 voa(j); $ set to next in chain.
44 if ind < vv_inp1 voa(i) then $ insert here.
45 vv_inp2 voa(voaep) = i;
46 vv_inp2 voa(j) = voaep; $ put into chain.
47 quit until; $ show in chain.
48 end if;
49 j = i; $ step to next in chain next time around.
50 end while;
51
52 $ if reach here, the entry is higher than any in
53 $ the chain so add to end.
54 vv_inp2 voa(voaep) = 0; $ set to end of chain.
55 vv_inp2 voa(j) = voaep; $ point to new entry.
56 end until;
57 end if;
58
59 else $ chain is empty -- put as first entry.
60 vv_inp2 voa(voaep) = 0; $ show last in chain.
61 .-vvfrs vv_frsdata voa(i) = voaep; $ show first also.
62 .+vvfrs vvfrsdata(i) = voaep; $ show first also.
63 end if;
64
65 end subr asmdata;
1 .=member asmgoby
2 subr asmgoby; $ generate code for indexed goto.
3 $ this routine generates code for the indexed goto operation.
4 size i(ps); $ loop variable.
5 size lab(ps); $ temporary label.
6 size lab1(ps); $ second label.
7 size reg(ps); $ temporary dummy register.
8 size mreg(ps); $ machine register.
9 size mode(ps); $ machine mode for label table.
10 size moff(mosize); $ machine offset for label table.
11 size t(ws); $ temporary.
vaxa 177 size work(ps); $ temporary dreg.
vaxa 178 .+t32 size work2(ps); $ temporary dreg.
12
13 $ define a label to indicate that the index is acceptable
14 $ so far and branch to it if the index is strictly positive.
15 labget(lab); $ get a temporary label.
16 ifspos_op(dopir, lab); $ branch if greater than zero.
17
18 $ define an error point at this location.
19 labget(lab1); $ get a label.
20 labdef(lab1, no); $ define it locally.
21
22 $ call an error routine. put the bad index () into
23 $ r0 and call the routine with no parameters.
24 forcezero(dopir, no); $ force into r0.
25 i = dopnx; $ save no. arguments for later.
26 dopnx = 0; dopsname = 'goto$er'; call_op; $ call with no args.
27 dopnx = i; $ restore number of arguments.
28
29 $ define the 'good-so-far' label and check if the index
30 $ is too high.
31 labdef(lab, no); $ define the label locally.
32 labfree(lab); $ this is last use of that label.
33 assignconst(reg, dopnx); $ get no. to compare with.
34 lastuse(reg); $ set status.
35 cmp_op(bm_pos, dopir, reg, lab1); $ do compare.
36 labfree(lab1); $ done with this label.
37
vaxa 179 .+t10 work = dopir; $ copy to variable to use later.
vaxa 180 .+t32 assignconst(work2, 2); $ get amount to shift.
vaxa 181 .+t32 getdreg(work); $ get dummy register.
vaxa 182 .+t32 lastuse(work2); lastuse(dopir); $ set status.
vaxa 183 .+t32 mul2_op(work, dopir, work2); $ shift over.
vaxa 184
vaxa 185
vaxa 186 getvar(work, gd_reg, mode, mreg, moff); $ get index into reg
vaxa 187
vaxa 188
vaxa 189 .+t10.
39 if mreg = r0 then $ check if it is in r0.
40 $ in this case it must be moved somewhere because r0
41 $ cannot be used as an index register.
42 getreg(mreg, rt_live); $ must get a register.
vaxa 190 dr_reg dreg(work) = mreg; $ set to new register.
44 reglis(mreg) = reglis(r0); $ copy status.
45 reglis(r0) = 0; $ free register zero.
46 end if;
vaxa 191 ..t10
vaxa 192
vaxa 193
vaxa 194 kill(work); $ free index.
48 $ emit an indexed branch into the label table to be built in
49 $ the base block.
50 moff = 0; mbo_blk moff = bl_base; $ set to base block
51 $ if base block address would go negative, increment it.
52 if (baselastaddr=1) baselastaddr=2;
53 t = baselastaddr - 2;
54 if (t<0) t = mneg(iabs(t)); $ if negative.
55 mbo_off moff = t;
vaxa 195 .+t10 emop(mo_jmp, r0, am_reli, mreg, moff); $ do the branch.
vaxa 196 .+t32 emop(mo_xjm, mreg, am_mem, sparereg, moff); $ do branch.
57
58 $ now insert the labels into the base block.
59 do i = 1 to dopnx; $ loop over each label.
60 baseprobelab(t, dopxr(i)); $ insert a label.
61 end do;
62
63 end subr asmgoby;
1 .=member asmif
2 .+ifopt.
3 subr asmif;
4 $ this routine processes the expression of an -if- statement.
5 $ it is used to generate the appropriate compare instructions
6 $ rather than subtracts, exclusive-ors, etc.
7 $
8 $ it receives as input the tree for the expression in the -dops-
9 $ array. it then copies and processes the tree. its first
10 $ pass is to copy the tree into an internal structure. this
11 $ structure indicates exactly what comparisons are to be done,
12 $ what branch mask is to be used to the true case, and what
13 $ variables, offsets, and masks are involved. this first pass
14 $ also checks that everything is validly deferred and will
15 $ return to force evaluation if not.
16 $
17 $ the second pass then scans the tree to actually generate the
18 $ comparisons and branches.
19
20 $ the main table used by this routine is the i-f t-able (it).
21 $ it contains the nodes of the tree built from the expression.
22 $ the format of each node is given below.
23 +* it_op = .f. 1, 8, ** $ operation type.
24 +* it_tlab = .f. 9, 8, ** $ true branch label index.
25 +* it_flab = .f. 17, 8, ** $ false branch label index.
26 +* it_dop = .f. 25, 8, ** $ pointer to deferred operation.
27 +* it_llink = .f. 33, 8, ** $ left tree link pointer.
28 +* it_rlink = .f. 41, 8, ** $ right tree link pointer.
29 +* it_blink = .f. 49, 8, ** $ back pointer.
30 +* it_count = .f. 57, 8, ** $ number of nodes below this.
31 +* it_bmask = .f. 65, 8, ** $ true branch mask.
32 +* it_inp1 = .f. 73, 8, ** $ input one to operation.
33 +* it_inp2 = .f. 81, 8, ** $ second input to operation.
34 +* it_len = .f. 89, 8, ** $ byte offset or mask.
35 +* it_rlf = .f. 97, 1, ** $ right/left flag.
36 +* it_tdef = .f. 98, 1, ** $ 'defines new true label'
37 +* it_fdef = .f. 99, 1, ** $ 'defines new false label'
38 +* it_negfl = .f. 100, 1, ** $ 'changes status of -negfl-'
39
40 +* itsz = 128 ** $ size of table.
dsd 11 $ define it fields using 32 bit (s37) as default, correct
dsd 12 $ as needed for other machines. this not standard practice,
dsd 13 $ but acceptable as fields referenced only in this procedure.
dsd 14
dsd 15 .+s10 +* itsz = 144 ** +* it_llink = .f. 137, 8, **
dsd 16 .+s66 +* itsz = 120 ** +* it_count = .f. 113, 8, **
41
42
43 $ the other tables that are used are the -iv- and the -il-
44 $ tables. -iv- contains a list of variables which will be used
45 $ in generating the expression. this is done so usage counts
46 $ can be correctly maintained. the -il- table contains a list
47 $ of generated labels. if an entry is zero, it means that no
48 $ label has been assigned for that index. if it is nonzero,
49 $ then it is the label number.
50
51 $ define maximum table dimensions.
52 +* itmax = 32 **
53 +* ivmax = 30 **
54 +* ilmax = 20 **
55
56 $ define tables and pointers.
57 size it(itsz), itptr(ps);
58 dims it(itmax);
59
60 size iv(ps), ivptr(ps);
61 dims iv(ivmax);
62
63 size il(ps), ilptr(ps);
64 dims il(ilmax);
65
66
67 $ operation types used.
68 +* ip_or = 1 ** $ logical -or-.
69 +* ip_and = 2 ** $ logical -and-.
70 +* ip_cmp = 3 ** $ do simple comparison.
71
72 $ flag values for tree.
73 +* left = 0 ** $ at left subtree.
74 +* right = 1 ** $ at right subtree.
75
76
77 $ table for conversion of op --> branch mask.
78 size bmasks(ps); dims bmasks(do_ne - (do_lt-1));
79
80 +* bmi(op, bm) = bmasks(op - (do_lt-1)) = bm **
81
82 data $ initialize table.
83
84 $ table bmi bewow is machine-independent.
85 bmi(do_lt, bm_neg):
86 bmi(do_ge, binv(bm_neg)):
87 bmi(do_eq, bm_zer):
88 bmi(do_ne, binv(bm_zer));
89
90 macdrop(bmi)
91
92
93 size in1(ps), in2(ps), in3(ps); $ inputs to operation.
94 size optr(ps); $ pointer to -dop-.
95 size negfl(1); $ negate flag.
96 size opc(ps); $ operation code.
97 size lptr(ps); $ last tree entry pointer.
98 size one(ps); $ register containing one.
99 size zero(ps); $ register containing zero.
100 size nextop(ps); $ pointer to next operation.
101 size bmask(ps); $ branch mask for node.
102 size t(ps); $ temporary.
103 size itval(itsz); $ temporary copy of node.
104 size i(ps); $ loop index.
105 size lab(ps); $ temporary label and index.
106
107
108 $ first, initialize variables for pass one.
109 itptr = 0; ivptr = 0; $ show empty tables.
110 ilptr = 2; il(1) = dopjr; il(2) = 0; $ initialize -il- table.
111 optr = dophold; $ set initial -dop- index.
112 negfl = no; $ set initial negation flag.
113 lptr = 0; $ set initial tree status.
114
115 assignconst(one, 1); assignconst(zero, 0);
116
117
118 $ start pass one.
119 while yes; $ exit from this ends pass one.
120 $ first, extract op-code and operands.
121 opc = dp_op dops(dophold); $ get operation.
122 in1 = dp_inp1 dops(dophold); in2 = dp_inp2 dops(dophold);
123
124 $ process the operation depending on type.
125 if opc = do_or then $ logical or case.
126 $ in this case, simply add an -or- operation
127 $ to the tree (or an -and- operation if the negate
128 $ flag is set) and set the next operation to the first
129 $ input.
130 $ first make sure that if any input is not deferred,
131 $ that it is an operand of size 1.
132 if dout(in1) = 0 then $ first input not deferred.
133 if (syze(in1) ^= 1) go to force;
134 end if;
135
136 if dout(in2) = 0 then $ second input not deferred.
137 if (syze(in2) ^= 1) go to force;
138 end if;
139
140 nextop = in1; $ set next operation.
141 in1 = 0; in2 = 0; $ show no operands.
142 opc = ip_or; if (negfl) opc = ip_and;
143 $ go to build; $ add operation to tree.
144
145
146 elseif opc = do_and then $ logical and case.
147 $ this is similar to the -or- case above.
148 if dout(in1) = 0 then $ first input not deferred.
149 if (syze(in1) ^= 1) go to force;
150 end if;
151
152 if dout(in2) = 0 then $ second input not deferred.
153 if (syze(in2) ^= 1) go to force;
154 end if;
155
156 nextop = in1; $ set next operation.
157 in1 = 0; in2 = 0; $ show no operands.
158 opc = ip_and; if (negfl) opc = ip_or;
159 $ go to build; $ add operation to tree.
160
161
162 elseif opc = do_not then $ logical not operation.
163 $ in the case of a -not- opertation, simply set the
164 $ negate flag and apply de morgan's laws. also set
165 $ a flag in the last operation added to the tree so that
166 $ when back up past it on the way up, the negate flag
167 $ can be toggled to its previous status.
168 if dout(in1) = 0 then $ first input not deferred.
169 if (syze(in1) ^= 1) go to force;
170 end if;
171
172 negfl = .not. negfl; $ negate 'negate' flag.
173 if (lptr) it_negfl it(lptr) = .not. it_negfl it(lptr);
174 nextop = in1; go to next; $ continue but dont add op.
175
176
177 elseif opc >= do_lt & opc <= do_ne then $ is comparison.
178 $ this is the most common, complex, and important case.
179 $ want to check the operands of the comparison.
180 $ first, though, will test to see if this is a
181 $ comparison of a one-bit item with either zero or one
182 $ or any item with zero.
183 $ if it is, then it is either a -not- or a noop and
184 $ can be processed accordingly.
185 until yes; $ exit if not special.
186 if (opc ^= do_eq & opc ^= do_ne) quit until;
187
188 $ for simplicity, want to set the constant
189 $ operand to the second operand so swap if not
190 $ that way already.
191 if in1 = one ! in1 = zero then $ swap.
192 t = in1; in1 = in2; in2 = t;
193 elseif in2 ^= zero & in2 ^= one then
194 quit until; $ this is not special.
195 end if;
196
197 if ((syze(in1) ^= 1 & in2 = one) ! ismw(in1))
198 quit until; $ this is not special.
199
200 nextop = in1; $ get next operation.
201
202 $ see if this is a -not-. if so, do the negation.
203 if (opc = do_eq) .ex. (in2 ^= zero) then
204 negfl = .not. negfl; $ negate the negate flag.
205 if (lptr) it_negfl it(lptr) = ^it_negfl it(lptr);
206 end if;
207 go to next; $ go down chain.
208 end until;
209
210 $ check for none of the following special cases.
211 $ 1 convert a<1 to 0 >= a
212 $ 2 convett a>= 1 to 0 < a
213 if in2 = one & (opc = do_lt! opc = do_ge) then
214 in2 = in1; in1 = zero; $ change operands.
215 opc = (do_lt + do_ge) - opc; $ switch operation
216 end if;
217 $ otherwise have a normal comparison. first, compute
218 $ the branch mask.
219 bmask = bmasks(opc - (do_lt-1)); $ get normal mask.
220 if (negfl) bmask = binv(bmask); $ invert if negated.
221
222 $ check operands of the comparison.
223 if (dout(in1) ! dout(in2)) go to force; $ normal.
dsk 308 if (ismw(in1) ! ismw(in2)) go to force; $ if multi-word.
224 $ this is a normal comparison. all must do
225 $ is check for a comparison against zero and, if so,
226 $ ensure it is the second operand. then the
227 $ comparison operation can be built.
228 if in1 = zero then $ first input is zero.
229 in1 = in2; $ set to nonzero input.
230 in2 = 0; $ show this is zero.
231 bmswap(bmask, t); $ swap the branch mask.
232 elseif in2 = zero then $ second input is zero.
233 in2 = 0; $ flag as such.
234 end if;
235
236 nextop = 0; $ show to go back.
237 opc = ip_cmp; $ add operation.
238 else $ not special operation.
239 go to force; $ so force evaluation.
240 end if;
241
242 /build/
243
244
245 $ first, add variables to -iv- table.
246 if (ivptr > ivmax-2) go to force; $ overflow.
247 iv(ivptr+1) = in1; iv(ivptr+2) = in2; $ insert.
248 ivptr = ivptr + (in1^=0) + (in2^=0); $ increment.
249
250 if (itptr > itmax-1) go to force; $ tree is full.
251
252 itval = 0; $ clear entry.
253
254 $ build the node for the tree.
255 it_op itval = opc; $ set opcode.
256 it_dop itval = optr; $ set operation pointer.
257 it_blink itval = lptr; $ set back link.
258 it_bmask itval = bmask; $ set branch mask.
259 it_inp1 itval = in1; $ set first input.
260 it_inp2 itval = in2; $ set second input.
261
262 itptr = itptr+1; it(itptr) = itval; $ insert into tree.
263
264
265 $ see about updating pointer to this node.
266 if lptr then $ if this is not root.
267 if it_rlf it(lptr) = left $ see which to update.
268 then it_llink it(lptr) = itptr; $ left.
269 else it_rlink it(lptr) = itptr; end if; $ right.
270 end if;
271
272 lptr = itptr; $ set last node pointer.
273
274 /next/ $ merge here to advance to next operation.
275 if nextop = 0 then $ this means back up the tree.
276 lptr = it_blink it(lptr); $ step back the tree.
277 while lptr; $ loop while someplace to go.
278 negfl = negfl .ex. it_negfl it(lptr); $ flip switch.
279
280 it_negfl it(lptr) = no; $ clear switch.
281 $ see whether are in left or right subtree
282 $ of the ancestor node.
283 if it_rlf it(lptr) = left then $ are in left.
284 $ in this case, merely move to the right
285 $ subtree.
286 it_rlf it(lptr) = right; $ set to right subtree.
287 nextop = dp_inp2 dops(it_dop it(lptr)); $ next.
288 go to next; $ go process that op or variable.
289
290 else $ are in the right subtree.
291 $ in this case must back up to the ancestor
292 $ of this node. but first must do two
293 $ things. the first is to set the status back
294 $ to left for the second pass.
295 it_rlf it(lptr) = left;
296
297 $ the second thing is to update the count of
298 $ the number of nodes below this one. in
299 $ addition, if the left subtree has more nodes
300 $ than the right subtree, they are swapped.
301 it_count it(lptr) =
302 it_count it(it_llink it(lptr)) +
303 it_count it(it_rlink it(lptr));
304
305 if it_count it(it_llink it(lptr)) >
306 it_count it(it_rlink it(lptr)) then $ swap.
307 t = it_llink it(lptr);
308 it_llink it(lptr) = it_rlink it(lptr);
309 it_rlink it(lptr) = t;
310 end if;
311
312 lptr = it_blink it(lptr); $ back up to try again.
313 end if;
314 end while;
315
316 $ if reach here, then are done with the first
317 $ pass.
318 quit while; $ exit from first pass.
319
320
321 elseif dout(nextop) = 0 then
322 $ in this case the next 'operation' is actually
323 $ a variable. so must build an operation which
324 $ compares it against zero.
325 dophold = 0; $ this is zero also.
326 opc = ip_cmp; in1 = nextop; in2 = 0; $ set parms.
327 bmask = binv(bm_zer); if (negfl) bmask = bm_zer;
328 nextop = 0; go to build; $ add to tree.
329
330 else
331 $ this is the case where the next operation is
332 $ really an operation.
333 dophold = dout(nextop); optr = dophold; $ set index.
334 end if;
335 end while;
336
337
338
339
340 $ this is the end of the first pass.
341
342 $ before the second pass is started, must go through
343 $ the variable table and indicate the using status. then the
344 $ initial input and the dummy zero and one can be dropped so
345 $ that only the variables that will actually be used are shown
346 $ as being used.
347 do i = 1 to ivptr; $ loop over the whole table.
348 using(iv(i)); $ increment the count.
349 end do;
350
351 kill(zero); kill(one); kill(dopir); $ drop junk.
352
353
354
355 $ are ready to begin the second pass. first must
356 $ assign the labels for the root of the tree depending on the
357 $ original operation code.
358 if dopcode = do_if then
359 it_tlab it(1) = 1;
360 it_flab it(1) = 2;
361 else $ must be -ifnot- so invert.
362 it_tlab it(1) = 2;
363 it_flab it(1) = 1;
364 end if;
365
366
367 itptr = 1; $ start traverse at root of tree.
368 while itptr; $ while not done with tree.
369 $ first extract values from node.
370 itval = it(itptr); $ get copy of node.
371 opc = it_op itval; $ get operation code.
372 in1 = it_inp1 itval; in2 = it_inp2 itval; $ inputs.
373 bmask = it_bmask itval;
374
375 $ get target label. will use the lower of the two
376 $ label indices.
377 lab = it_tlab itval; $ assume true is lower.
378 if lab > it_flab itval then $ it is in fact higher.
379 lab = it_flab itval; $ set to false label.
380 bmask = binv(bmask); $ invert branch mask.
381 end if;
382
383 $ if this is neither and -and- nor an -or- and a label
384 $ has not been assigned to the index, must assign one
385 $ now.
386 if opc ^= ip_and & opc ^= ip_or & il(lab) = 0 then
387 labget(t); $ get a label;
388 il(lab) = t; $ put it into the table.
389 end if;
390
391 lab = il(lab); $ get the actual label number.
392
393
394 $ must process the node depending on operation.
395 if opc = ip_and ! opc = ip_or then $ logical ops.
396 $ in this case all must do is to update the true
397 $ and false labels of the sons of the node. in all
398 $ cases the right son gets the same labels. however,
399 $ the left son gets a new label for either true or false
400 $ depending on the operation.
401 it_tlab it(it_rlink itval) = it_tlab itval;
402 it_flab it(it_rlink itval) = it_flab itval;
403
404 $ initially copy both labels to left son also.
405 it_tlab it(it_llink itval) = it_tlab itval;
406 it_flab it(it_llink itval) = it_flab itval;
407
408 countup(ilptr, ilmax, 'il'); $ get a label index.
409 il(ilptr) = 0; $ clear entry to show unassigned.
410
411 if opc = ip_and then $ assign to true label.
412 it_tlab it(it_llink itval) = ilptr;
413 it_tdef it(it_llink itval) = yes; $ show definer.
414 else $ must be -or-.
415 it_flab it(it_llink itval) = ilptr;
416 it_fdef it(it_llink itval) = yes;
417 end if;
418
419
420 elseif opc = ip_cmp then
421 $ this is either a simple comparison or a test.
422 if in2 then $ this is comparison.
423 lastuse(in1); lastuse(in2); $ set status.
424 cmp_op(bmask, in1, in2, lab);
425 else $ this is just test.
426 lastuse(in1); $ set status.
427 if_op(bmask, in1, lab);
428 end if;
429
430
431 end if;
432
433
434 $ if have just done a forward branch must set a flag
435 $ to indicate that can no longer put items into registers
436 if lab .ne. 0 & lab .ne. il(1) then $ if must set
437 isinif = yes; $ set flag for emitbin and emitcmp.
438 end if;
439 $ go down the left branch until hit end.
440 lptr = it_llink itval; $ get left pointer.
441 if lptr then $ will continue down.
442 itptr = lptr; $ set to son.
443 cont while; $ continue.
444 end if;
445
446
447 /loop/ $ merge here to back up tree.
448
449 $ go back up the tree.
450 itptr = it_blink it(itptr); $ go back up.
451 if (itptr = 0) quit while; $ done when hit top.
452
453 $ see if are in the left or right subtree of that
454 $ node.
455 if it_rlf it(itptr) = left then $ were in left subtree.
456 $ in this case set to right subtree.
457 it_rlf it(itptr) = right; $ set for next time.
458 itptr = it_rlink it(itptr); $ go to the right.
459 cont while; $ process it.
460
461 else $ were in right subtree.
462 $ in this case must actually define any labels
463 $ that were flagged as being defined in this node and
464 $ that were used. then back up the tree again.
465 lab = 0; $ assume no label to define.
466 if (it_tdef it(itptr)) lab = it_tlab it(itptr);
467 if (it_fdef it(itptr)) lab = it_flab it(itptr);
468
469 $ see if there was a label to define and if it
470 $ was used.
471 if lab then $ a label was defined.
472 if il(lab) then $ it was also used.
473 labdef(il(lab), no); $ define at this point.
474 labfree(il(lab)); $ free the label.
475 il(lab) = 0; $ clear just to be sure.
476 end if;
477 end if;
478
479 go to loop; $ back up again.
480 end if;
481 end while;
482
483
484
485 isinif = no; $ reset flag for emit level routines.
486 $ are done with both passes. all that remains is to
487 $ define the initial 'true' label if it has been used.
488 if il(2) then $ it has been used.
489 labdef(il(2), no); $ define the label.
490 labfree(il(2)); $ free the label.
491 end if;
492
493
494 dophold = 0; $ show nothing to evaluate.
495 return;
496
497 /force/
498 $ this is branched to in order to force evaluation of
499 $ something. this will pick the best thing to force
500 $ evaluation of (as far down the tree as possible.)
501
502 kill(one); kill(zero); $ first, drop constants.
503
504 if (dophold) return; $ if something here, done.
505
506 dophold = optr; $ else set to last operation.
507 if (dophold) return; $ if something here, done.
508
509 dophold = dout(dopir); $ else set to initial operation.
510 return;
511
512 macdrop(it_op) macdrop(it_tlab)
513 macdrop(it_flab) macdrop(it_dop)
514 macdrop(it_llink) macdrop(it_rlink)
515 macdrop(it_bink) macdrop(it_count)
516 macdrop(it_bmask) macdrop(it_inp1)
517 macdrop(it_inp2) macdrop(it_off1)
518 macdrop(it_off2) macdrop(it_len)
519 macdrop(it_tdef) macdrop(it_fdef)
520 macdrop(it_negfl) macdrop(itsz)
521 macdrop(itmax) macdrop(ivmax)
522 macdrop(ilmax) macdrop(ip_or)
523 macdrop(ip_and) macdrop(ip_cmp)
524 macdrop(left)
525 macdrop(right)
526
527 end subr asmif;
528 ..ifopt
1 .=member asmlong
2 subr asmlong; $ call off-line multi-word routine.
3 $ this routine processes multi-word simple operations by
4 $ generating calls to off-line routines.
5 size aop(ps); $ operation to issue.
6 size dop_comparison(do_not); $ flags comparison ops.
7 data dop_comparison = 1b'00000 00011 1100';
8
9 dopsname = longname(dopcode); $ get routine name.
10 callnodrop = yes; $ dont drop parameters.
11
12 if dopnargs = 1 then $ unary operation.
13 dopxr(1) = dopir; $ first is input.
14 if dopcode = do_not then $ this is subroutine call.
15 assignconst(dopxr(2), syze(dopir)) $ length.
16 dopnx = 3; $ three parameters.
17 dopxr(3) = dopor; $ third is output.
18 call_op; $ call routine.
19 else $ this is a call to library function.
20 assignconst(dopxr(2), nwords(dopir)) $ length of input.
21 forcezero(0, no); $ clear register zero.
22 dopnx = 2; call_op; $ call with two parameters.
23 inzero(dopor, no); $ indicate output in r0.
24 end if;
25
26 else $ must be binary operation.
27
28 $ insert first four operands for call.
29 dopxr(1) = dopir; assignconst(dopxr(2), nwords(dopir))
30 dopxr(3) = dopjr; assignconst(dopxr(4), nwords(dopjr))
31 $ comparison operation are functions, so check if this
32 $ is a comparison operation.
33 if .f. dopcode, 1, dop_comparison then $ if comparison.
34 dopnx = 4; $ only four arguments.
pic 13 forcezero(0,no); $ clear register zero
35 call_op; $ call routine.
36 inzero(dopor, no); $ show in r0.
37 else $ normal binary operation. output is last argument.
38 dopnx = 5; $ has five arguments.
39 dopxr(5) = dopor; $ fifth is output.
40 call_op; $ call routine.
41 end if;
42 end if;
43
44 end subr asmlong;
1 .=member asmfld
2 subr asmfld(fb, len, var, source); $ prepare for .f. op.
3 $ this routine emits the code for all the .f.
4 $ operations. it first checks that all inputs are validly
5 $ deferred. then it processes constant length and position
6 $ and sets up index and position registers where aplicable.
7 size fb(ps); $ register containing bit position.
8 size len(ps); $ register containing field length.
9 size var(ps); $ register containing .f. variable.
10 size source(ps); $ register containing source of assignment
11 size t1(ps), t2(ps); $ temporaries.
12 size i(ps); $ temporary
13 size isaop(1); $ 'this is assignment operation'
14 size isxop(1); $ 'this is indexed operation'
15 size ismwop(1); $ 'this is multi-word operation'
16 size work(ps), work1(ps), work2(ps); $ work registers.
17 size mode(ps); $ machine mode for target word.
18 size mreg(ps); $ machine register for target word.
19 size moff(mosize); $ machine offset for target word.
20 size mreg1(ps); $ temporary machine register.
21
22 $ first, set flags for operation type.
23
24 isxop = (dopcode = do_xfasin);
25
26 isaop = isxop ! (dopcode = do_fasin);
27
28 ismwop = ismw(var); $ set multi-word attribute.
29
30
31 $ set flags and value for constant length and position.
32 doplenconst = isscon(len); $ constant length flag.
33 doplenval = conval(len); $ value of constant length.
34
35 dopfbconst = isscon(fb); $ constant position flag.
36 dopfbm1val = conval(fb) - (conval(fb)^=0);
37
38
39 .+defer.
40 $ ensure that all inputs are validly deferred.
41 dophold = dout(fb); $ first check bit position.
42 if dophold then $ it is deferred.
43 if (dp_op dops(dophold) ^= do_add) go to ret; $ must be add.
44 t1 = dp_inp1 dops(dophold); t2 = dp_inp2 dops(dophold);
45 until yes; $ ensure that at least one is constant.
46 dopfbm1 = t2; $ assume inp1 is constant.
47 if (conval(t1) = 1) quit until; $ exit if it is.
48 dopfbm1 = t1; $ assume inp2 is constant.
dsd 17 if (conval(t2) = 1) quit until; $ exit if it is.
50 go to ret; $ else cannot defer this input.
51 end until;
52
53 dopfbconst = isscon(dopfbm1); $ reset constant and
54 dopfbm1val = conval(dopfbm1); $ value flags.
55 end if;
56
57 $ if this is an indexed operation, check the index.
58 if isxop then $ this is indexed.
59 call asmdxchk(dopkr); $ index is kept there.
60 if (dophold) go to ret; $ force evaluation if needed.
61 end if;
62
63 dophold = dout(var); $ check variable (always zero or asin).
64 if dophold then $ this is deferred.
65 if di_ldrop ditem(dr_item dreg(var)) = no !
66 di_count ditem(dr_item dreg(var)) ^= 1 then
67 if (ismwop) go to ret;
68 end if;
69
70 if (dp_op dops(dophold) ^= do_xload) go to ret; $ not valid.
71 $ call routine to check if the operands to this indexed
72 $ load are validly deferred.
73 call asmdxchk(dp_inp2 dops(dophold)); $ check index.
74 if (dophold) go to ret; $ not validly deferred.
75 end if;
76
77
78 .+eab.
79 $ [the desired code here is, for s37, to emit ni, tm, and oi
80 $ which clear target bit, skip if source bit off, and if
81 $ source bit on, then -or- constant one in to effect move 20 apr]
82 $ do special check for the case of a field move of one bit.
83 if source then $ this may be a special case.
84 dophold = dout(source); $ see if source is deferred.
85 if dophold then $ it is.
86 if (doplenval ^= 1) go to ret; $ not one bit asign.
87 if (dopfbconst = no) go to ret; $ not constant position.
88 if (dp_op dops(dophold) ^= do_fext) go to ret;
89 if (conval(dp_inp2 dops(dophold)) ^= 1) go to ret;
90 if (isscon(dp_inp1 dops(dophold)) = no) go to ret;
91 $ must be carefull that this is never a field
92 $ move from a field to the same field because in that
93 $ case the clear of the bit would be done before the
94 $ test of the bit. since it is not simple to compare
95 $ both arrays, will compare the bit positions.
96 if (dopfbm1val = conval(dp_inp1 dops(dophold)) - 1)
97 go to ret; $ cannot have this as special case.
98 dophold = dout(dp_inp3 dops(dophold));
99 if (dophold) go to ret; $ cannot have index.
100 isspecial = yes; $ show this is a special case.
101 end if;
102 end if;
103 ..eab
104
105 $ if reach here, the operands were validly deferred, so
106 $ clear -dophold-.
107 dophold = 0;
108 ..defer
109
110 $ process position to do subtraction if needed.
111 if dopfbconst then $ this is constant.
112 kill(fb); $ can drop constant register.
113 assignconst(dopfbm1, dopfbm1val); $ set new constant.
114 .+defer.
115 elseif dout(fb) then $ this was an addition of one.
116 using(dopfbm1); kill(fb); $ reset status.
117 ..defer
118 else $ must subtract one.
119 getdreg(dopfbm1); $ get result register.
120 lastuse(fb); $ set status.
121 sub1_op(dopfbm1, fb); $ do the subtraction.
122 end if;
123
124 $ process the variable and index. first, initialize.
125 dopvar = var; dopindx = 0; $ original variable, no index.
126 .+defer.
127 if dout(var) then $ this is indexed load so set new items.
128 dopvar = dp_inp1 dops(dout(var)); $ get base.
129 dopindx = dp_inp2 dops(dout(var)); $ get index.
130 using(dopvar); using(dopindx); kill(var); $ set status.
131 end if;
132 ..defer
133
134 doff = nwords(dopvar); $ set initial word offset.
135 $ if this is an indexed operation, set index.
136 if isxop then $ this is indexed operation.
137 dopindx = dopkr; $ this is where index is kept.
138 .+defer.
139 end if;
140
141 $ if there is an index register, position it and
142 $ compute possible new offset.
143 if dopindx then $ there is an index register.
144 ..defer
145 call asmxload(dopvar, dopindx); $ position index.
146 end if;
147
148
149 ismwop = ismw(dopvar); $ reset multi-word flag.
150
151 $ are ready to use the bit position to build the
152 $ correct index value to access the desired word.
153 $ this is only done if the variable is multi-word.
154 if ismwop then $ get new index.
155 $ if constant position, just compute new word index.
156 if dopfbconst then $ this is constant position.
157 doff = doff - dopfbm1val/mws;
158 dopfbm1val = mod(dopfbm1val, mws); $ to place in word.
vaxa 197 kill(dopfbm1); $ drop old value.
vaxa 198 assignconst(dopfbm1, dopfbm1val); $ get new one.
159 else $ must compute index register.
vaxa 199 .+t10 assignconst(work2, mws); $ get constant.
vaxa 200 .+t10 getdreg(work); lastuse(work2);
vaxa 201 .+t32 getdreg(work);
162 if doplenval = mws then $ need not keep values.
163 lastuse(dopfbm1); $ set status.
164 end if;
165
vaxa 202 .+t10 div_op(work, dopfbm1, work2);
vaxa 203 .+t32 assignconst(work2, 5); lastuse(work2);
vaxa 204 .+t32 div2_op(work, dopfbm1, work2);
vaxa 205 .+t32 assignconst(work2, 2); $ set to log2 (mcpw).
vaxa 206 .+t32 mul2_op(work, work, work2); $ shift over again.
167
168 if doplenval ^= mws then $ must compute new fb
169 $ compute bit position mod ws.
170 getdreg(work1); $ get a result register.
vaxa 207 .+t10 assignconst(work2, mws); $ get word size.
vaxa 208 .+t32 assignconst(work2, mws-1); $ get word size.
172 lastuse(dopfbm1); lastuse(work2); $ set status.
vaxa 209 .+t10 mod_op(work1, dopfbm1, work2); $ get offset.
vaxa 210 .+t32 and_op(work1, dopfbm1, work2); $ get offset.
174 dopfbm1 = work1; $ set new position.
175 end if;
176
177 $ must compute final offset. must get a new
178 $ register and either negate or subtract.
179
180 getdreg(work1); lastuse(work);
181
182 if dopindx then $ must subtract two registers.
183 lastuse(dopindx); $ set status.
184 sub_op(work1, dopindx, work); $ do subtract.
185 else $ just negate offset.
186 neg_op(work1, work); $ do negation.
187 end if;
188
189 dopindx = work1; $ set to new index register.
190 end if;
191 end if;
192
193
vaxa 211 .+t10.
194 /*
195 the following is the code skeletons for field ops.
196 the code sequences for field extraction and insertion
197 are very similar, as shown below by parenthesized comments
198 indicating code for field insertion.
199 r = .f. c1+1, c2, ea (or .f. c1+1, c2, ea = r)
200 lpr r,ea,c1,c2 (or spr r,ea,c1,c2)
201
202 r = .f. c, e, ea (or .f. c, e, ea = r)
eaa 132 lda* ra,ea
204 ldwi rb,c-1
205 spr rb,ra,30,6 set p
206 ldw rb,e
207 spr rb,ra,24,6 set s
208 ldf r,ra (or stf r,ra)
209
210 r = .f. e, c, ea (or .f. e, c, ea = r)
eaa 133 lda* ra,ea
212 ldwi rb,c
213 spr rb,ra,24,6 set s
214 iso rb,e
215 spr rb,ra,30,6 set p
216 ldf r,ra (or stf r,ra)
217
218 r = .f. e1, e2, ea (or .f. e1, e2, ea = r)
eaa 134 lda* ra,ea
220 iso rb,e1
221 spr rb,ra,30,6 set p
222 ldw rb,e2
223 spr rb,ra,24,6 set s
224 ldf r,ra (or stf r,ra)
225
eaa 135 instances of lda* denote lda except for extended addressing (t20),
eaa 136 where lla op is implied.
226 */
vaxa 212 ..t10
vaxa 213
vaxa 214
227 if dopindx then $ must set lastuse flags.
228 lastuse(dopvar); lastuse(dopindx);
229 end if;
230
231 i = gw_word; if (isaop) i = gw_addr;
eaa 137 .+t20. $ if possible dynamic heap reference.
eaa 138 if nsheap_this then
eaa 139 $ need special getword call to defer address load if
eaa 140 $ reference to heap. we are adding an oracle so getword
eaa 141 $ can tell us if doing assignment to indexed heap variable.
eaa 142 asmflh_gwi = 1; $ indicate special call
eaa 143 $ set if not constant field length and origin.
eaa 144 asmflh_varext = (1 -dopfbconst & doplenconst);
eaa 145 end if;
eaa 146 ..t20
232 getwordc(i, dopkr, dopvar, doff, dopindx); $ get needed word.
233
eaa 147 .+t20. $ see if need special code for dynamic heap reference.
eaa 148 if nsheap_this then
eaa 149 asmflh_gwi = 0; $ indicate endof special call
eaa 150 else
eaa 151 asmflh_gwo = 0;
eaa 152 end if;
eaa 153 ..t20
234 $ see if this is a full word operation. if so
235 $ just move in the word.
236 if doplenval = mws then $ it is.
237 kill(len); $ kill constant length.
238 lastuse(dopkr); $ set last use of target word.
239 if isaop then $ this is an assignment.
240 lastuse(source); $ set status.
241 move_op(dopkr, source); $ move the word.
242 else $ this is an extraction.
243 lastuse(dopor); $ set status.
244 move_op(dopor, dopkr); $ move into output.
245 end if;
246
247 go to ret; $ done in this case.
248 end if;
249
vaxa 215 .+t10.
250 if doplenconst & dopfbconst then $ if both constant.
251 kill(len); kill(dopfbm1); $ kill constants.
252 lastuse(dopkr); $ show last use on target word.
253 if isaop then $ if is assignment.
254 lastuse(source); $ set status.
255 spr_op(source, dopkr, dopfbm1val, doplenval);
256 else $ this is field extract.
257 lastuse(dopor); $ set status.
258 lpr_op(dopor, dopkr, dopfbm1val, doplenval);
259 end if;
260
261 go to ret; $ done
262 end if;
263
264
265 $ in this case we have the more general field extract or assign
266 $ when either the offset or length is an expression. in this
267 $ case, we must build a byte pointer and then issue an -ldf- or
268 $ -stf- operation to do the extract or assign.
269
270 $ first, load the address of the desired target word into a
271 $ machine register to use as a byte pointer.
272 getdreg(work); $ get dummy register for byte pointer.
273
274 $ if wanted word is a short constant which is not in a register,
275 $ must get its address in the base block.
276 i = gd_use; $ default type is gd_use.
277 if (isscon(dopkr) & dr_reg dreg(dopkr) = 0) i = gd_addr;
278 mreg = dr_reg dreg(dopkr);
279 if lastdrop(dopkr) then $ if last use.
280 if mreg then
281 if rl_type reglis(mreg) = rt_need then
282 reglis(mreg) = 0; $ free register.
283 dr_reg dreg(dopkr) = 0;
284 mreg = 0;
285 end if;
286 end if;
287 end if;
288 if mreg & isaop then
289 rl_subtype reglis(mreg) = rt_live;
290 end if;
291 getdesc(dopkr, i, mode, mreg, moff); $ get address.
292
293 getreg(mreg1, rt_live); $ get register for byte pointer.
eaa 154 .-t20.
294 emop(mo_lda, mreg1, mode, mreg, moff); $ get address into reg.
eaa 155 .+t20.
eaa 156 if asmflh_gwo>0 & isaop then
eaa 157 emop(mo_hbc, mreg1, mode, mreg,moff);
eaa 158 else
eaa 159 emop(mo_lla, mreg1,mode, mreg,moff);
eaa 160 end if;
eaa 161 asmflh_gwo = 0;
eaa 162 ..t20
295 if (mode=am_reg & isaop) rl_hold reglis(mreg) = yes;
296 rl_content reglis(mreg1) = work; $ show owner of data.
297 dr_reg dreg(work) = mreg1; $ show in machine register.
298
299 $ now insert position and length into byte pointer.
300 if dopfbconst & dopfbm1val = 0 then $ special case.
301 kill(dopfbm1); $ get rid of constant of zero.
302 else $ normal case.
303 lastuse(dopfbm1); $ show last use of position.
304 spr_op(dopfbm1, work, 30, 6); $ set p field.
305 end if;
306
307 if doplenconst & doplenval = 0 then $ special case.
308 kill(len); $ done with constant length.
309 else $ normal case.
310 lastuse(len); $ show last use of length.
311 spr_op(len, work, 24, 6); $ set s field.
312 end if;
313
314
315 $ now do the actual extract or assign.
316 lastuse(work); $ show next is last use of byte pointer.
317 if isaop then $ if is assignment.
318 lastuse(source); $ set status.
319 stf_op(source, work); $ do the assignment.
320 else $ this is an extraction.
321 lastuse(dopor); $ set status.
322 ldf_op(dopor, work); $ do the extraction.
323 end if;
324
325 kill(dopkr); $ kill the desired word.
vaxa 216 ..t10
vaxa 217 .+t32.
vaxa 218 lastuse(len); lastuse(dopfbm1); lastuse(dopkr); $ set status.
vaxa 219 if isaop then $ is field assignment.
vaxa 220 lastuse(source); $ set status.
vaxa 221 spr_op(source, dopkr, dopfbm1, len); $ do assign.
vaxa 222 else $ is field extract.
vaxa 223 lastuse(dopor); $ set status.
vaxa 224 lpr_op(dopor, dopkr, dopfbm1, len); $ do extract.
vaxa 225 end if;
vaxa 226 ..t32
326
327 /ret/
328 end subr asmfld;
329 .+defer.
1 .=member asmdxch
2 subr asmdxchk(index); $ check for valid index deferral.
3 size index(ps); $ index to check.
4 size in1(ps), in2(ps); $ inputs to operation.
5
6 dophold = dout(index); $ see if index is deferred.
7 if dophold then $ if so, process.
8 $ the index can only be deferred if it is an addition
9 $ of a constant.
10 until yes; $ quit if ok.
11 in1 = dp_inp1 dops(dophold); in2 = dp_inp2 dops(dophold);
12 if dp_op dops(dophold) = do_add then $ may be ok.
13 if (isscon(in1)) quit until; $ this is ok.
14 if isscon(in2) then $ this is ok too.
15 dp_inp1 dops(dophold) = in2; $ switch to simplify
16 dp_inp2 dops(dophold) = in1; $ job of -asmxload-.
17 quit until; $ show is ok.
18 end if;
19 end if;
20
21 return; $ else must evaluate.
22 end until;
23
24 dophold = 0; $ otherwise, show ok.
25 end if;
26
27 end subr asmdxchk;
28 ..defer
1 .=member asmxld
2 subr asmxload(base, index); $ process index for array.
3 $ this routine processes the index for an array. it sets up
4 $ the index to be a machine index into the array. it will
5 $ either multiply the index by the appropriate amount or will
6 $ do a shift of the appropriate amount. in addition, if the
7 $ index is a constant or an index plus a constant, the constant
8 $ will be added to the global variable -doff-.
9 size base(ps); $ base variable (array)
10 size index(ps); $ index.
11 size off(ps); $ temporary offset value.
12 size work(ps), work1(ps); $ temporary registers.
13 size t(ps); $ temporary.
14
15 off = 0; $ initialize offset.
16
17 .+defer.
18 $ if the index is deferred, the it must be constant+new index.
19 $ so get the constant and the new index.
20 if dout(index) then $ it is.
21 work = index; $ save old index.
22 off = conval(dp_inp1 dops(dout(index))); $ get offset.
23 index = dp_inp2 dops(dout(index)); $ get new index.
24 using(index); kill(work); $ set status.
25 end if;
26 ..defer
27
28 $ if index is a constant, just add in constant.
29 if isscon(index) then $ it is a constant.
30 off = off + conval(index); $ add it in.
31 kill(index); index = 0; $ drop index.
32 else $ must multiply or shift.
33 t = nwords(base); $ get amount to multiply by.
34 if (t & (t-1)) = 0 then $ is a power of two.
vaxa 227 .+t10 if t^=1 then $ if not identity.
36 getdreg(work); $ get dummy register.
vaxa 228 .+t10 assignconst(work1, ((.fb.t)-1));
vaxa 229 .+t32 assignconst(work1, ((.fb.t)+1));
38 lastuse(work1); lastuse(index);
39 mul2_op(work, index, work1);
40 index = work;
vaxa 230 .+t10 end if;
42
43 else $ must multiply.
vaxa 231 .+t10 getdreg(work); assignconst(work1, t);
vaxa 232 .+t32 getdreg(work); assignconst(work1, t * mcpw);
45 lastuse(work1); lastuse(index); $ set status.
46 mul_op(work, index, work1); $ do multiply.
47 index = work; $ set new index.
48 end if;
49 end if;
50
51 doff = doff + off*nwords(base); $ set new word offset.
52
53 end subr asmxload;
1 .=member assign
2 subr assignr(type); $ assign a dummy register
3 size type(ps); $ encoding of desired argument
4 size db(1); $ holds drop bit
5 size var(ps); $ holds -voa- pointer.
6 size i(ps); $ temporary.
7 size di(ps); $ pointer to dummy item.
8 size dw(ps); $ pointer to dummy word.
9 size ditemval(ditemsz), dwordval(dwordsz); $ temporaries.
10
11 $ first, must determine which -voa- entry is wanted.
12 $ then, the -voa- index and the drop bit are set and the
13 $ main section of this routine is executed.
14
15 $ [ds 11 apr, for efficiency replace else...elseif by goby]
16 if type > va_xarg then $ this is reference to -xarg-.
17 db = xa_db xarg(vv_argbeg voa(voaep)+type-(va_xarg+1));
18 var = xa_voa xarg(vv_argbeg voa(voaep)+type-(va_xarg+1));
19 elseif type = va_oup then $ request for output of operation.
20 db = no; var = vv_oup voa(voaep);
21 elseif type = va_inp1 then $ request for input one.
22 db = vv_db1 voa(voaep); var = vv_inp1 voa(voaep);
23 elseif type = va_inp2 then $ request for input two.
24 db = vv_db2 voa(voaep); var = vv_inp2 voa(voaep);
25 elseif type = va_inp3 then $ request for input three.
26 db = vv_db3 voa(voaep); var = vv_inp3 voa(voaep);
27 elseif type = va_inp4 then $ fourth input (in vv_oup)
28 db = vv_dboup voa(voaep); var = vv_oup voa(voaep);
29 elseif type = va_fnct then $ request for function result.
30 db = yes; var = 1; $ set to function return.
31 elseif type = va_spec then $ special call.
32 db = yes; var = voaep; $ specific variable.
33 else $ invalid -assign- call.
34 call aermey(5); $ write error message and terminate.
35 end if;
36
37 $ can begin processing the operand. first, check to
38 $ see if the operand is already in a dummy register.
39
40 if vv_inreg voa(var) then $ it is.
41 $ in this case merely set drop bit status, assign to return
42 $ variable, and increment count.
43 di = vv_inreg voa(var); $ copy register number.
44 if (di_lword ditem(di) = 0) call aermey(6); $ error.
45
46 .+defer. $ check if this is re-use of a deferred temporary.
47 if type=va_oup & di_temp ditem(di) & di_ldrop ditem(di) then
48 vv_inreg voa(var) = 0; $ clear this entry.
rke 10 if (di_baseblk ditem(di))
rke 11 bb_bptr baseblock(di_chain ditem(di)) = 0;
50 go to skip; $ must get a new value.
51 end if;
52 ..defer
53
54 $ update status.
55 di_count ditem(di) = di_count ditem(di)+1; $ increment count.
56 di_ldrop ditem(di) = db; $ set new drop value.
57 di_luse ditem(di) = 0; $ show no drop flags yet.
58
59 assignreg = dw_freg dword(di_lword ditem(di)); $ get reg.
60 go to ret; $ return this value.
61 end if;
62
63 /skip/ $ entered here to get new -dreg-.
64 $ handle case where the -voa- operand is a constant. in
65 $ this case the -assignconst- routine is called to process
66 $ the constant. if it is a multi-word constant, then it is
67 $ processed as a normal variable.
68
rkb 19 if vv_const voa(var) & vv_syze voa(var) <= scs
70 & tmctab(vv_lextype voa(var)) <= tmc_b then $ if safe.
rkb 20 $ have a short constant. must set special
rkb 21
72 $ flags for -assignconst- to indicate that the size of
73 $ the constant is known and also that is already in -val-
74 $ array. then pass the -val- index rather than the
75 $ constant itself to -assignconst-.
76 asconstspc = yes; $ show special case.
77 asconstdb = db; $ copy over drop bit.
78 asconstsz = vv_syze voa(var); $ get size.
79 asconstreal = vv_amode voa(var); $ set mode.
80 assignconst(assignreg, vv_vbeg voa(var)); $ assign constant.
81 go to ret; $ return value.
82 end if;
83
84 $ have a normal case which will be handled in this
85 $ routine. first must obtain dummy values from the free
86 $ list and then fill in the appropriate fields.
87
88 di = ditemfree; $ get off free list.
89 if (di = 0) call aermey(7); $ error if full.
90 ditemfree = di_out ditem(di); $ restore chain.
91
92 dw = dwordfree; $ get off free word list.
93 if (dw = 0) call aermey(8); $ error if full.
94 dwordfree = dw_next dword(dw); $ restore chain.
95
96 assignreg = dregfree; $ get off register list.
97 if (assignreg = 0) call aermey(9); $ error if full.
98 dregfree = dr_next dreg(assignreg); $ restore free chain.
99
100 ditemval = 0; dwordval = 0; $ clear values.
101
102 vv_inreg voa(var) = di; $ point -voa- to item.
103
104 $ fill in common fields in -ditem-.
105 di_syze ditemval = vv_syze voa(var); $ get size.
106 di_mw ditemval = (vv_syze voa(var) > mws); $ multi-word flag.
107 di_nwords ditemval = (vv_syze voa(var) + (mws-1))/mws;
108 di_real ditemval = vv_amode voa(var); $ arithmetic mode.
109 di_temp ditemval = vv_temb voa(var); $ temporary bit.
110 di_var ditemval = (vv_temb voa(var) = no); $ since not constant.
111 di_array ditemval = (vv_dimn voa(var)^=0)&(vv_const voa(var)=no);
112 di_ldrop ditemval = db; $ set drop bit.
113 di_count ditemval = 1; $ show just this one use.
114 di_anum ditemval = vv_argno voa(var); $ get argument number.
115 di_lword ditemval = dw; $ point to -dword-.
116
117 $ set fields in -dword-.
118 dw_freg dwordval = assignreg; $ set first register.
119 dw_word dwordval = di_nwords ditemval; $ set word position.
120 if (di_array ditemval) $ must update word position.
121 dw_word dwordval = (di_nwords ditemval)*2;
122
123 $ process single-word temporaries.
124 if di_temp ditemval & di_mw ditemval = no then $ this case.
125 $ if not output is error.
126 if (type ^= va_oup) call aermey(31); $ terminal error.
127
128 $ otherwise, allocate space in temporary block.
129 baseprobenc(i, 1, bt_temp, yes); $ i --> temporary.
130 bb_pointer baseblock(i) = no; $ show no longer free.
131 bb_bptr baseblock(i) = var; $ point back to -voa-.
132 di_chain ditemval = i; $ point to base block.
133 di_baseblk ditemval = yes; $ show in vase block.
134 di_mblk ditemval = bl_base; $ set machine block.
135 dw_madr dwordval = bb_addr baseblock(i); $ set address.
136
137 else $ multi-word temporary or variable.
138 di_chain ditemval = var; $ point to -voa-.
139 di_mblk ditemval = vv_mblk voa(var); $ get machine block.
140 dw_madr dwordval = vv_madr voa(var); $ get machine address.
141 if (di_anum ditemval) dw_madr dwordval = 1;
142 end if;
143
144 $ finally, plant all values in table.
145 ditem(di) = ditemval; dword(dw) = dwordval;
146
147 dreg(assignreg) = 0; $ clear dummy reg.
148 dr_word dreg(assignreg) = dw; $ point to dummy word.
149 dr_item dreg(assignreg) = di; $ point to dummy item.
150
151 /ret/ $ return register.
152 .+trace. $ generate trace code.
153 if trace_d then $ if tracing enabled.
154 tintl('assign var', var) tintl('to', assignreg) endl
155 end if;
156 ..trace
157
158 end subr assignr;
1 .=member asconst
2 subr asconst(value); $ assign register to constant.
3 size value(ws); $ value to assign to register.
4 size valp(ps); $ pointer to -val- array.
5 size hcode(mws/2);$ hash code in -baseblock-.
6 size i(ps); $ index.
7 size ditemval(ditemsz), dwordval(dwordsz); $ temporaries.
8 size di(ps); $ pointer to dummy item.
9 size dw(ps); $ pointer to dummy word.
10
11 $ the first thing that must be done is to set various parameters
12 $ these are size of constant, index into -val- of constant,
13 $ and drop bit value for constant. normally, these are
14 $ calculated from the constant itself. however, when the
15 $ flag -asconstspc- is set, it indicates that this call is
16 $ from -assignr- and thus these parameters have already been
17 $ set. in the latter case, the flag is reset.
18
19 if asconstspc then $ this is internal call.
20 valp = value; $ value passed is index into -val-.
21 asconstspc = no; $ clear special case flag.
22 else $ normal call.
23 asconstsz = (.fb. value) + (value=0); $ compute size.
24 countup(valptr, valdim, 'val'); $ get space in -val-.
25 valp = valptr; val(valp) = value; $ set into -val- array.
26 asconstdb = yes; $ assume last use.
27 asconstreal = no; $ assume integer value.
28 end if;
29
30 $ must place constant into -baseblock-. the hash code
31 $ is computed by exclusive-or'ing the two half-words of the
32 $ constant.
33
34 hcode = .f. 1,mws/2, val(valp) .exor. .f.mws/2+1,mws/2, val(valp);
35
36 $ insert into table, if not already present, by use of
37 $ -baseprobe- macro to search hashed table.
38 baseprobe(i, hcode, 1, bt_const, valp, ar_val, valptr);
39
40 $ handle case where constant is already in dummy register.
41 if bb_bptr baseblock(i) then $ it is.
42 di = bb_bptr baseblock(i); $ get item pointer.
43 di_count ditem(di) = di_count ditem(di)+1; $ increment count.
44 di_ldrop ditem(di) = asconstdb; $ set drop flag.
45 di_luse ditem(di) = 0; $ show no drop flags yet.
46 asconstreg = dw_freg dword(di_lword ditem(di)); $ get -dreg-.
47 go to ret; $ go return register.
48 end if;
49
50 $ in the other case, get a dummy item, word, and register
51 $ from the free lists and initialize them.
52
53 di = ditemfree; $ get a dummy item.
54 if (di = 0) call aermey(7); $ error if none.
55 ditemfree = di_out ditem(di); $ restore free chain.
56
57 dw = dwordfree; $ get word from free chain.
58 if (dw = 0) call aermey(8); $ error if all being used.
59 dwordfree = dw_next dword(dw); $ restore free chain.
60
61 dwordval = 0; ditemval = 0; $ clear values.
62
63 $ if the address is assigned, copy it.
64 if bb_addr baseblock(i) then $ it is assigned.
65 di_mblk ditemval = bl_base; $ show in base block.
66 dw_madr dwordval = bb_addr baseblock(i); $ set machine addr.
67 end if;
68
69 $ initialize common fields in dummy values.
70 di_chain ditemval = i; $ point to base block.
71 di_baseblk ditemval = yes; $ show in base block.
72 di_syze ditemval = asconstsz; $ set size.
73 di_const ditemval = yes; $ show is constant.
74 di_nwords ditemval = 1; $ this routine only handles 1-word.
75 di_real ditemval = asconstreal; $ set mode.
76 di_lword ditemval = dw; $ point to last word item.
77 di_count ditemval = 1; $ show just this one user.
78 di_ldrop ditemval = asconstdb; $ set drop bit.
79
80 $ check for short constants.
81 if asconstsz <= mps then $ this is short.
82 di_scon ditemval = yes; $ show is short constant.
83 di_cval ditemval = val(valp); $ set short value.
84 end if;
85
86 $ initialize some fields in word value.
87 dw_word dwordval = 1; $ show which word is being referenced.
88
89
90 $ grab a dummy register.
91 asconstreg = dregfree; $ get from free list.
92 if (asconstreg = 0) call aermey(9); $ error if none.
93 dregfree = dr_next dreg(asconstreg); $ restore list.
94
95 $ can point dummy word to dummy register.
96 dw_freg dwordval = asconstreg; $ point first in chain.
97
98 $ plant all values in tables.
99 dword(dw) = dwordval; ditem(di) = ditemval;
100 dreg(asconstreg) = 0; $ clear dummy register.
101
102 $ set up chains from dummy register.
103 dr_word dreg(asconstreg) = dw; $ point to dummy word.
104 dr_item dreg(asconstreg) = di; $ point to dummy item.
105
106 bb_bptr baseblock(i) = di; $ finally, point base block to item.
107
108 /ret/ $ have register to return.
109 .+trace. $ trace code.
110 if trace_d then $ request trace code.
111 tintl('asconst val', val(valp)) tintl('to', asconstreg) endl
112 end if;
113 ..trace
114
115 return;
116 end subr asconst;
1 .=member clearr
2 subr clearr(reg); $ clear a dummy register.
3 size reg(ps); $ register to clear.
4 size i(ps), j(ps); $ temporary indexes.
5
6 $ do a check to ensure that things haven't gotten messed up.
7 if (istemp(reg)) call aermey(12);
8
9
10 $ must drop any registers that contain data for other
11 $ words of the item if multi-word.
12 if ismw(reg) then $ must check other words.
13 i = di_lword ditem(dr_item dreg(reg)); $ get first in chain.
14 while i; $ while more words to loop over.
15 if i ^= dr_word dreg(reg) then $ skip original word.
16 j = dw_freg dword(i); $ point to first register.
17 if dr_reg dreg(j) then $ must drop register.
18 reglis(dr_reg dreg(j)) = 0; $ drop.
19 dr_reg dreg(j) = 0; $ show not in register.
20 end if;
21 end if;
22
23 i = dw_next dword(i); $ get next word in chain.
24 end while;
25 end if;
26
27
28
29 .+defer. $ only needed if deferring.
30 $ if register is output of deferred operation, that operation
31 $ was never used so flush it.
32 if dout(reg) then $ must flush operation.
33 dropdop(dout(reg)); $ flush operation.
34 dout(reg) = 0; $ clear field.
35 end if;
36 ..defer
37
38 $ if a register has been assigned to the register, free it
39 $ unless it has been permanently assigned.
40 if dr_reg dreg(reg) then $ must drop machine register.
41 if rl_perm reglis(dr_reg dreg(reg)) = no & spcdrop = no then
42 reglis(dr_reg dreg(reg)) = 0; $ drop machine register.
43 dr_reg dreg(reg) = no; $ show not in register.
44 end if;
45 end if;
46
47 .+trace if trace_d then tintl('*clear', reg) endl end if;
48
49 end subr clearr;
1 .=member dropr
2 subr dropr(arg); $ drop a -dreg- or -dop-.
3 $ this routine is called by the -drop- or -dropdop- macros.
4 $ if it is called to drop a register, the -drop- macro does
5 $ nothing unless the last use bit is set. this routine then
6 $ checks if the value is dead (count=1 & last drop set). if so,
7 $ it frees the item. otherwise, it merely decrements the usage
8 $ count.
9
10 $ when this routine is called by the -dropdop- macro, it will
11 $ add the -dop- to the free chain and recursively free the
12 $ operands of the operation.
13 size arg(ps); $ argument (-dreg- or -dop-)
14 size i(ps), j(ps), k(ps); $ temporaries.
15 size reg(ps); $ -dreg- pointer.
16 size di(ps); $ -ditem- pointer.
17
18 .+defer. $ additional code for dererring.
19 $ if deferring is being used, this routine is recursive. t
20 $ therefore, a stack is used to list all the -dreg-'s that must
21 $ be dropped. a loop is then entered until the stack is empty.
22 size stack(ps); dims stack(20); $ the stack.
23 size stackp(ps); $ pointer into -stack-.
24 size dop(ps); $ index into -dops-.
25
26 +* push(d) = $ push onto stack.
27 stackp = stackp+1; $ up pointer.
28 stack(stackp) = d; ** $ add onto stack.
29
30 +* pop(d) = $ pop from stack.
31 d = stack(stackp); $ read data.
32 stackp = stackp-1; ** $ decrement pointer.
33
34 +* exit = cont while stackp; ** $ recursive exit.
35
36 $ initialize stack and contents.
37 stackp = 0; $ initially empty stack.
38 if dropdopflg then $ this is -dop-.
39 dropdopflg = no; $ reset flag.
40 dop = arg; $ set index.
41 go to procdop; $ go process -dop-.
42 end if;
43
44 push(arg); $ push first -dreg- onto stack.
45
46 $ loop until the stack is empty.
47 while stackp; $ done when nothing more to drop.
48 pop(reg); $ get first thing to do from stack.
49 .-defer. $ generate code for non-deferrings.
50 +* exit = return; ** $ process exit code.
51
52 reg = arg; $ set thing to drop.
53 ..defer
54
55 $ can just return if this was a freed dummy register.
56 if (dr_item dreg(reg) = 0) exit; $ done in this case.
57
58 .+trace. $ generate trace code.
59 if trace_d then $ print trace info.
60 tintl(' drop, reg', reg) endl
61 end if;
62 ..trace
63
64 $ see if must drop or just decrement count.
65 if di_count ditem(dr_item dreg(reg)) ^= 1 !
66 di_ldrop ditem(dr_item dreg(reg)) = no ! spcdrop then
67 $ must decrement count and last usage.
68 di = dr_item dreg(reg); $ get item number.
69 if (di_luse ditem(di)) di_luse ditem(di) =
70 di_luse ditem(di) - 1;
71 di_count ditem(di) = di_count ditem(di) - 1;
72 if (spcdrop) di_ldrop ditem(di) = no;
73 exit; $ done with this case.
74 end if;
75
76 $ otherwise, must actually drop register.
77
78
79 $ drop all forms.
80 di = dr_item dreg(reg); $ point to dummy item.
81 i = di_lword ditem(di); $ get last dummy word.
82 while i; $ loop over each word.
83 j = dw_freg dword(i); $ get first form in word.
84 $ see if must store any live.
85 if di_var ditem(di) then $ is variable.
86 if dr_reg dreg(j) then $ it is in a register.
87 if (rl_perm reglis(dr_reg dreg(j)))
88 call aermey(32); $ this is an error.
89 if (rl_type reglis(dr_reg dreg(j)) = rt_live)
90 store(dr_reg dreg(j), j); $ store it.
91 end if;
92 end if;
93 dropform(j); $ drop this form.
94
95 j = dw_next dword(i); $ get next word in chain.
96
97 $ drop that current word.
98 dword(i) = 0; $ clear it.
99 dw_next dword(i) = dwordfree; dwordfree = i; $ free it.
100 i = j; $ set to next word.
101 end while;
102
103 $ drop any live address for this item.
104 if (di_addrreg ditem(di)) reglis(di_addrreg ditem(di)) = 0;
105
106 $ if this is not a constant or temporary and it is
107 $ chained to the -voa-, clear the -voa- pointer to this
108 $ dummy item.
109 if di_chain ditem(di) then $ there is a chain.
110 i = di_chain ditem(di); $ get pointer.
111 if di_baseblk ditem(di) then $ in base block.
112 if di_temp ditem(di) then $ free temporary.
113 bb_pointer baseblock(i) = yes;
114 if bb_bptr baseblock(i) then $ if points to voa
115 $ check that this pointer in fact points
116 $ to the dummy item that are freeing.
117 if (vv_inreg voa(bb_bptr baseblock(i)) = di)
118 vv_inreg voa(bb_bptr baseblock(i)) = 0;
119 end if;
120 end if;
121 bb_bptr baseblock(i) = 0; $ clear base block pointer
122 else $ in -voa-.
123 $ check that clear the correct pointer
124 if (vv_inreg voa(i) = di) vv_inreg voa(i) = 0;
125 end if;
126 end if;
127
128 .+defer dop = di_out ditem(di); $ set if this is output.
129
130 $ finally free dummy item.
131 ditem(di) = 0; $ clear all status info.
132 di_out ditem(di) = ditemfree; $ point this to free chain.
133 ditemfree = di; $ put this on free chain.
134
135 .+defer if (dop = 0) $ only quit if no deferred output.
136 exit; $ quit this drop call.
137
138
139 $ process the dropping of a deferred operation.. first
140 $ push any registers that this used onto the stack of work
141 $ to be done. then free this operation.
142 /procdop/
143 .+trace.
144 if trace_o then $ print output.
145 tintl('drop, dop', dop) endl
146 end if;
147 ..trace
148
149 go to n(dp_nargs dops(dop)) in 1 to 3; $ get number to drop.
150
151 /n(3)/ push(dp_inp3 dops(dop));
152 /n(2)/ push(dp_inp2 dops(dop));
153 /n(1)/ push(dp_inp1 dops(dop));
154
155 $ actually free this deferred operation.
156 dp_chain dops(dop) = dopfree; $ set this to free chain.
157 dopfree = dop; $ put this onto free chain.
158 end while; $ loop around again.
159
160 macdrop(push) macdrop(pop)
161 ..defer
162
163 macdrop(exit)
164
165 end subr dropr;
1 .=member dmpdreg
2 .+trace.
3 subr dumpdregs; $ dump dummy registers.
4 $ this routine is used for tracing purposes to print out
5 $ the contents of the dummy items, words, and registers.
6 size i(ps); $ index.
7 size ditemmap(ditemdim), dwordmap(dworddim), dregmap(dregdim);
8 size ditemval(ditemsz), dwordval(dwordsz), dregval(dregsz);
9
10
11 $ first print dummy items. see which are on free chain.
12 i = ditemfree; $ point to free chain.
13 ditemmap = 0; $ show none initially free.
14 while i; $ while more on free chain.
15 if (.f. i, 1, ditemmap) call aermey(13); $ dup -ditem-.
16 .f. i, 1, ditemmap = yes; $ else set bit to show free.
17 i = di_out ditem(i); $ get next in chain.
18 end while;
19
20 $ complement map to show which items are in use.
21 ditemmap = .not. ditemmap;
22
23 if ditemmap then
24 $ print title.
25 endl textl(' dummy items') endl endl
26 textl(' n b chain s m r a t c v l syze count nwrds luse '
27 !! 'lwrd mblk') endl
28
29 $ print each dummy item.
30 while ditemmap; $ while more to print.
31 i = .fb. ditemmap; $ get index to print.
32 intlp(i, 2) $ print index.
33 ditemval = ditem(i); $ get values.
34
35 $ print header information.
36 intlp(di_baseblk ditemval,2)
37 intlp(di_chain ditemval, 6) intlp(di_scon ditemval, 2)
38 intlp(di_mw ditemval, 2) intlp(di_real ditemval, 2)
39 intlp(di_array ditemval, 2)
40 intlp(di_temp ditemval, 2) intlp(di_const ditemval, 2)
41 intlp(di_var ditemval, 2)
42 intlp(di_ldrop ditemval, 2)
43 intlp(di_syze ditemval, 5)
44 intlp(di_count ditemval, 6) intlp(di_nwords ditemval, 6)
45 intlp(di_luse ditemval, 5) intlp(di_lword ditemval, 5)
46 intlp(di_mblk ditemval, 5)
47
48 $ print out any special values.
49 if (di_scon ditemval) then
50 textl(' cval ') octl(di_cval ditemval)
51 end if;
52 if (di_addrreg ditemval) tintl('addrreg',di_addrreg ditemval)
53 .+defer if (di_out ditemval) tintl('out', di_out ditemval)
54 if (di_anum ditemval) tintl('anum', di_anum ditemval)
55
56 .f. i, 1, ditemmap = no; $ show done with register.
57 endl
58 end while;
59 else textl('no dummy items') endl end if;
60
61 $ print dummy words.
62 dwordmap = 0; $ show none in use yet.
63 i = dwordfree; $ start at head of free chain.
64
65 while i; $ while some in free chain.
66 if (.f. i, 1, dwordmap) call aermey(14); $ dup -dword-.
67 .f. i, 1, dwordmap = yes; $ else show free.
68 i = dw_next dword(i); $ point to next in chain.
69 end while;
70
71 $ complement map to get words in use.
72 dwordmap = .not. dwordmap;
73
74 if dwordmap then
75 $ print title.
76 endl endl textl(' dummy words') endl endl
77 textl(' n next madr freg word') endl
78
79 while dwordmap; $ while more in use.
80 i = .fb. dwordmap; $ get first in list.
81 intlp(i, 3) $ print out index.
82 dwordval = dword(i); $ get value.
83
84 $ print out values.
85 intlp(dw_next dwordval, 5) intlp(dw_madr dwordval, 5)
86 intlp(dw_freg dwordval, 5)
87 intlp(dw_word dwordval, 5)
88
89 .f. i, 1, dwordmap = no; $ show this not in use.
90 endl
91 end while;
92 else textl('no dummy words') endl end if;
93
94
95 $ process dummy registers.
96 dregmap = 0; $ show none free yet.
97 i = dregfree; $ point to head of free chain.
98
99 while i; $ loop over free chain.
100 if (.f. i, 1, dregmap) call aermey(15); $ dup -dreg-.
101 .f. i, 1, dregmap = yes; $ show on free chain.
102 i = dr_next dreg(i); $ get next on chain.
103 end while;
104
105 $ invert map to get registers in use.
106 dregmap = .not. dregmap;
107
108 if dregmap then
109 $ print titles.
110 endl endl textl(' dummy registers') endl endl
111 textl(' n next item word reg') endl
112
113 $ process each register.
114 while dregmap; $ while more in use.
115 i = .fb. dregmap; $ get first to process.
116 intlp(i, 3); $ print index.
117 dregval = dreg(i); $ get register value.
118
119 $ print information.
120 intlp(dr_next dregval, 5) intlp(dr_item dregval, 5)
121 intlp(dr_word dregval, 5)
122 intlp(dr_reg dregval, 4)
123 if (dr_next dregval) call aermey(21);
124
125 .f. i, 1, dregmap = no; $ show done this one.
126 endl
127 end while;
128 else textl('no registers in use') endl end if;
129
130 endl $ leave a blank line at the end.
131
132 end subr dumpdregs;
133 ..trace
1 .=member dmpmreg
2 .+trace. $ only used if tracing.
3 subr dumpmregs; $ dump machine registers.
4 $ this routine prints a dump of the machine register status
5 $ for use in debugging.
6 size i(ps); $ loop index.
7 size nact(ps); $ number of active registers.
8 size rname(.sds. 4); $ register names.
9 dims rname(rhihi); $ number of registers.
10 data rname = ' r0 ', ' r1 ', ' r2 ', ' r3 ', ' r4 ',
11 ' r5 ', ' r6 ', ' r7 ', ' r8 ', ' r9 ',
vaxa 233 .+t10 'r10 ', 'r11 ', 'r12 ', 'r13 ', 'r14 ',
vaxa 234 .+t32 'r10 ', 'r11 ', 'ap ', 'fp ', 'sp ',
vaxa 235 .+t10 'r15 ';
vaxa 236 .+t32 'pc ';
14
15 size rtype(.sds. 5); $ register types.
16 dims rtype(rt_permlive+1); $ number of types +1.
17 data rtype(rt_dead+1) = ' dead':
18 rtype(rt_need+1) = ' need':
19 rtype(rt_address+1) = ' addr':
20 rtype(rt_live+1) = ' live':
21 rtype(rt_liveaddr+1) = ' ladr':
22 rtype(rt_permresv+1) = ' resv':
23 rtype(rt_perm+1) = ' perm':
24 rtype(rt_permlive+1) = ' prml';
25
26
27
28 nact = 0;
29 do i = r0 to rhi; $ loop over all registers.
vaxa 237 if (reglis(i) = 0) cont do; $ dont list dead.
31 nact = nact + 1;
32 if nact = 1 then $ if need title.
33 endl textl(' machine registers') endl
34 textl('nam content type h ah useval') endl
35 end if;
36
37 $ list attributes.
38 textl(rname(i)) intlp(rl_content reglis(i), 8)
39 textl(rtype(rl_type reglis(i)+1))
40 intlp(rl_hold reglis(i), 2) intlp(rl_addrhold reglis(i), 3)
41 intlp(rl_usevalue reglis(i), 7) endl
42 end do;
43
44
45 endl $ leave a blank line.
46 end subr dumpmregs;
1 .=member endblk
2 ..trace
3 subr endblock; $ end a basic block.
4 $ this routine is called by -asmprog- when a basic block is to
5 $ be ended. this routine drops all registers except those
6 $ which only need be dropped when a label is encountered.
7 size i(ps); $ do loop index.
8 size reg(ps); $ -dreg- pointer.
9
10 $ if the -reissuedop- flag is on, this routine just returns
11 $ because it will be called again.
12 .+defer if (reissuedop) return;
13
14 .+trace if trace_a then textl(' *endblock') endl end if;
15
16 do i = r0 to rhi;
17 if (rl_perm reglis(i)) cont do; $ skip permanent.
18 if (rl_type reglis(i) = rt_dead) cont do; $ ignore dead.
19 if (rl_type reglis(i) = rt_address) cont do; $ leave addr.
20
21 $ know that have a register which either contains
22 $ data or a live address. drop the appropriate
23 $ type.
24 if rl_type reglis(i) = rt_liveaddr then $ error.
25 call aermey(30); $ cannot have this at block end.
26 else $ must be a data type.
27 dr_reg dreg(rl_content reglis(i)) = 0; $ clear pointer.
28 end if;
29
30 reglis(i) = 0; $ drop register.
31 end do;
32
33 end subr endblock;
1 .=member forcer
2 subr forcer(reg, flg); $ force a variable to register zero.
3 $ this routine is called by the macro -forcezero-. it puts
4 $ either a variable or the address of a variable into register
5 $ zero.
6 size reg(ps); $ variable to force into register zero.
7 size flg(1); $ set if address wanted in r0.
8 size t(ps); $ temporary.
9 size mode(ps); $ mode.
10 size mreg(ps); $ machine register.
11 size moff(mosize); $ machine offset.
12 size mnam(ps);
13 .+trace.
14 if trace_a then $ trace output wanted.
15 tintl('force, reg', reg) tintl('fl', flg) endl
16 end if;
17 ..trace
18
19 $ clear register zero before putting anything into it.
20 if rl_type reglis(r0) ^= rt_dead then $ must do it.
21 getreg(t, rl_type reglis(r0)); $ get new register.
22 if t then $ register available.
23 reglis(t) = reglis(r0); $ copy status.
24 mrcopy(t, r0); $ copy regs.
25 end if;
26 dr_reg dreg(rl_content reglis(r0)) = t; $ set new owner.
27 reglis(r0) = 0; $ free register zero.
28 end if;
29
30 $ if -reg- is given as zero, this was a call just to clear
31 $ register zero.
32
33 if (reg = 0) return;
34
35 $ first, check to see whether the address or data is wanted
36 $ in register zero.
37 if flg then $ address wanted in register zero.
38 $ get the descriptor for the last word.
39 getdesc(dw_freg dword(di_lword ditem(dr_item dreg(reg))),
40 gd_addr, mode, mreg, moff); $ get machine values.
41 emop(mo_lda, r0, mode, mreg, moff);
42
43 else $ want variable itself in register.
44 mreg = r0; $ set to get into r0.
45 getvar(reg, gd_inregnu, mode, mreg, moff); $ load to register
46 end if;
47
48 drop(reg); $ free if last use.
49
50 end subr forcer;
1 .=member getdreg
2 subr getdregr(dr); $ get a new dummy register.
3 size dr(ps); $ register obtained.
4 size dw(ps); $ pointer to dummy word.
5 size di(ps); $ pointer to dummy item.
6 size bbp(ps); $ base block pointer.
7 size ditemval(ditemsz), dwordval(dwordsz); $ temporaries.
8
9 $ first get a new dummy item, word, and register.
10 di = ditemfree; $ get from free list.
11 if (di = 0) call aermey(7); $ none left.
12 ditemfree = di_out ditem(di); $ rechain.
13
14 dw = dwordfree; $ get free word.
15 if (dw = 0) call aermey(8); $ none left.
16 dwordfree = dw_next dword(dw); $ rechain.
17
18 dr = dregfree; $ get free register.
19 if (dr = 0) call aermey(9); $ none left.
20 dregfree = dr_next dreg(dr); $ rechain.
21
22 $ initialize values.
23 ditemval = 0; dwordval = 0;
24
25 $ find an available temporary.
26 baseprobenc(bbp, 1, bt_temp, yes); $ scan base block.
27 bb_pointer baseblock(bbp) = no; $ show no longer free.
28
29 $ fill in fields for -ditem-.
30 di_chain ditemval = bbp; $ point to base block.
31 di_baseblk ditemval = yes; $ show is in base block.
32 di_syze ditemval = mps; $ set to one word.
33 di_nwords ditemval = 1; $ show one word long.
34 di_temp ditemval = yes; $ show is temporary.
35 di_ldrop ditemval = yes; $ show this is last use.
36 di_count ditemval = 1; $ show just one user.
37 di_mblk ditemval = bl_base; $ set machine block.
38 di_lword ditemval = dw; $ point to dummy word.
39
40 $ set fields for -dword-.
41 dw_madr dwordval = bb_addr baseblock(bbp); $ machine address.
42 dw_word dwordval = 1; $ show is first word.
43 dw_freg dwordval = dr; $ point to first in register chain.
44
45 $ replace fields and do final chaining.
46 ditem(di) = ditemval; dword(dw) = dwordval;
47
48 dreg(dr) = 0; dr_item dreg(dr) = di; dr_word dreg(dr) = dw;
49
50 .+trace if trace_d then tintl('gotdreg', dr) endl end if;
51
52 end subr getdregr;
1 .=member getword
2 subr getwordr(out, in, type, offset, index); $ word/character.
3 $ this routine is used to address, store, or retrieve a word
4 $ or character of a multi-word item.
5 size out(ps); $ output dummy register.
6 size in(ps); $ input dummy register.
7 size type(ps); $ type of call.
8 size offset(ps); $ word or character offset.
9 size index(ps); $ register for index.
10
11 $ this routine uses a table to define the operations to be
12 $ performed on the operands.
13
14 $ the fields in this table are defined below.
15
16 +* gt_inddr = .f. 1, 1, ** $ 'drop forms if indexed'
17 +* gt_kind = .f. 3, 2, ** $ kinds of 'output's.
18 +* mop_gt = .f. 9, 8, ** $ machine instruction to issue.
19
20 $ kind values for output.
21
22 +* gk_output = 0 ** $ it is a real output.
23 +* gk_input = 1 ** $ it is really an input operand.
24
25 +* num_gk = 1 **
26
27 +* gwt(typ, mop, drp, outk) = $ build table.
28 gwtab(typ) = mop*4b'100'+outk*1b'100'+drp **
29
30 size gwtab(ws); dims gwtab(num_gw); $ define table.
31 data $ initialize table.
32 $ type mop drp kind
33 $ ---- --- --- ----
34
35 gwt(gw_word, mo_ldw, no, gk_output):
36 gwt(gw_addr, mo_lda, yes, gk_output):
37 gwt(gw_sword, mo_stw, yes, gk_input);
38
39 macdrop(gwt)
40
41 size woff(ps); $ word offset.
42 size nmadr(ws); $ new machine address.
43 size reg(ps), reg1(ps); $ temporary -dreg-'s.
44 size mreg(ps), mreg1(ps), mreg2(ps); $ temporary -mreg-'s.
45 size moff(mosize); $ machine offset.
dsj 57 size moff1(mosize); $ temporary.
46 size mode(ps); $ machine address type.
47 size t(ws), t1(ps);$ dummy variables and temporaries.
48 size mop(ps); $ machine operation to issue.
49 size hcode(mws/2); $ hash code for -baseblock-.
50 size di(ps); $ dummy item index.
51 size dw(ps); $ dummy word index.
52
eaa 163 .+t20. $ special code for nsheap (extended addressing)
eaa 164 if asmflh_gwi then $ if called from asmfld
eaa 165 $ asmflh_gwi nonzero indicates we are being called from asmfld
eaa 166 $ and caller wants to know if assignment target is in dynamic
eaa 167 $ heap.
eaa 168 asmflh_gwo = 0; $ assume not heap reference
eaa 169 end if;
eaa 170 ..t20
53 woff = offset; $ copy offset to local variable.
54
55 $ now check for the normal case and exit immediately if so.
56 if (type = gw_addr ! type = gw_word) & nwords(in) = 1 & index = no
57 & di_array ditem(dr_item dreg(in)) = no then $ do nothing.
58 out = in; $ just copy the word to the output.
59 go to ret; $ done.
60 end if;
61
62 $ first, get pointers to dummy item and word.
63 di = dr_item dreg(in); dw = dr_word dreg(in);
64
65 if di_anum ditem(di) ^= 0 & di_addrreg ditem(di) = 0 then
66 $ must obtain machine reg with address of rightmost word.
67 getreg(mreg, rt_liveaddr); $ get register.
vaxa 238 .+t10 emop(mo_ldw, mreg, am_rel, parmreg, di_anum ditem(di)-1);
vaxa 239 .+t32 moff1 = 0; mbo_off moff1 = di_anum ditem(di);
vaxa 240 .+t32 emop(mo_ldw, mreg, am_rel, parmreg, moff1);
69 rl_type reglis(mreg) = rt_address;
70 rl_content reglis(mreg) = di;
71 rl_hold reglis(mreg) = yes;
72 di_addrreg ditem(di) = mreg;
73 end if;
74
75 getdesc(in, gd_addr, mode, mreg, moff);
76 nmadr = mbo_off moff - (dw_word dword(dw) - woff) + 1;
77 if (nmadr<0) nmadr = mneg(iabs(nmadr));
78 t = nmadr - 1;
79 if (t<0) t = mneg(iabs(t));
80 mbo_off moff = t;
81
82 $ build a new dummy word for the desired word.
83 $ first see if it already exists.
84 t1 = di_lword ditem(di); $ set to start of chain.
85 while t1; $ while more in chain.
86 if dw_word dword(t1) = woff then $ found what want.
87 dw = t1; reg = dw_freg dword(dw); $ set to this one.
88 quit while; $ show found.
89 end if;
90
91 t = t1; $ save last position in chain.
92 t1 = dw_next dword(t1); $ point to next.
93 end while;
94
95 $ if hit end of chain, must build new word.
96 if t1 = 0 then $ at end of chain.
97 dw = dwordfree; $ get from free chain.
98 if (dw = 0) call aermey(7); $ none left.
99 dwordfree = dw_next dword(dw); $ rechain.
100
101 $ build new word.
102 dword(dw) = dword(t); $ copy most from old.
103 dw_madr dword(dw) = nmadr; $ set new address.
104 dw_word dword(dw) = woff; $ set to wanted word.
105 dw_next dword(t) = dw; $ put into chain.
106
107 $ get new dummy register.
108 reg = dregfree; $ get from free list.
109 if (reg = 0) call aermey(9); $ none left.
110 dregfree = dr_next dreg(reg); $ rechain.
111
112 $ chain in new register.
113 dreg(reg) = 0; $ set initial values.
114 dr_item dreg(reg) = di; dr_word dreg(reg) = dw;
115 dw_freg dword(dw) = reg;
116 end if;
117
118 $ split up into two cases depending on whether or not
119 $ an index register is specified.
120 if index then $ have an index register.
121 $ first, save all 'live' forms.
122 t = di_lword ditem(di); $ point to first word in chain.
123 while t; $ while more word.
124 $ the only form which can be live is the 'primary'
125 $ form so just check it.
126 if dr_reg dreg(dw_freg dword(t)) then $ in a register.
127 $ see if live.
128 if rl_type reglis(dr_reg dreg(dw_freg dword(t))) =
129 rt_live then $ must do the store.
130 store(dr_reg dreg(dw_freg dword(t)),
131 dw_freg dword(t)); $ store live variable.
132 end if;
133 end if;
134 t = dw_next dword(t); $ get next in chain.
135 end while;
136
137 $ get index value into a machine register.
dsj 58 getvar(index, gd_reg, t, mreg1, moff1);
139
vaxa 241 .+t10.
140 $ check if the index register is in r0. if so,
141 $ must move it somewhere else.
142 if mreg1 = r0 then $ it is.
143 getreg(mreg1, rt_live); $ get a register.
144 dr_reg dreg(index) = mreg1; $ set new register.
145 reglis(mreg1) = reglis(r0); $ copy status.
146 reglis(r0) = 0; $ clear r0.
147 mrcopy(mreg1, r0);
148 end if;
vaxa 242 ..t10
149
150 $ [rk 24 may code below can be optimized to do only iad,
151 $ based on lastuse information.]
152 if mode = am_rel then $ if relative
153 getreg(mreg2, rt_liveaddr);
154 emop(mo_ldw, mreg2, am_reg, mreg1, 0);
155 emop(mo_iad, mreg2, am_reg, mreg, 0);
156 reglis(mreg2) = 0;
157 rl_hold reglis(mreg2) = yes;
158 mreg = mreg2;
159 elseif mode = am_mem then $ if in memory.
160 mreg = mreg1;
161 mode = am_rel;
162 else $ fatal if here
163 call aermey(35); $ need correct aermey message.
164 end if;
165 $ finally, select operation type by output type.
166 go to iopk(gt_kind gwtab(type)) in 0 to num_gk;
167
168 /iopk(gk_output)/ $ indexed -getword- or -getaddr-.
169 $ in these cases, the word or address of the desired
170 $ item will be loaded into a new dummy register. the
171 $ result form will have minimal information set because
172 $ it is only used in a few cases.
173 getdreg(out); $ get a dummy register for the output.
174 isreal(out) = di_real ditem(di); $ set arithmetic mode.
175 dw = dr_word dreg(out); di = dr_item dreg(out); $ get ptrs.
176 mop = mop_gt gwtab(type); $ get machine operation to issue.
177
178 $ get appropriate register.
179 getreg(mreg2, rt_live); $ get general register.
180
eaa 171 .+t20.
eaa 172 $ note only load address for indexed field assignment
eaa 173 if mop=mo_lda & nsheap_this & (mbo_blk moff = nsheap_blk) then
eaa 174 $ if assignment to dynamic heap, emit special opcode.
eaa 175 mop = mo_hba;
eaa 176 if (asmflh_varext) mop = mo_hbb;
eaa 177 asmflh_gwo = 1; $ indicate heap reference.
eaa 178 asmflh_mreg = mreg; $ save register.
eaa 179 asmflh_moff = moff; $ save offset.
eaa 180 asmflh_mode = mode; $ save mode.
eaa 181 end if;
eaa 182 ..t20
181 $ do the operation.
182 emop(mop, mreg2, mode, mreg, moff); $ do load or load addr.
183
184 $ update the status depending on type.
185 if type = gw_addr then $ update address values.
186 di_addrreg ditem(di) = mreg2; $ show register.
187 di_mw ditem(di) = yes; $ show multi-word.
vaxa 243 rl_type reglis(mreg2) = rt_liveaddr; $ set reg. type.
189 rl_content reglis(mreg2) = di; $ show owner.
190 dw_madr dword(dw) = 1; $ show offset of zero.
191 else $ this is a value load.
192 dr_reg dreg(out) = mreg2; $ show in register.
193 rl_content reglis(mreg2) = out; $ show owner.
194 end if;
195 go to reti; $ process common indexed return actions.
196
197
198 /iopk(gk_input)/ $ input operand storeword
199 $ load input into register.
dsj 59 getvar(out, gd_reg, t, mreg2, moff1);
201 mop = mop_gt gwtab(type); $ set op. to issue.
202 $ do operation.
203 emop(mop, mreg2, mode, mreg, moff); $ do store.
204 go to reti; $ go do common return.
205
206
207 /reti/ $ common return from indexed operations.
208 $ if -inddr- flag is set in type table for this operation
209 $ type, must drop all forms in registers.
210 if gt_inddr gwtab(type) then $ must do drops.
211 t = di_lword ditem(dr_item dreg(in)); $ start of words.
212 while t; $ while more in chain.
213 t1 = dw_freg dword(t); $ first in register chain.
214 if dr_reg dreg(t1) then $ is in register.
215 reglis(dr_reg dreg(t1)) = 0; $ free register.
216 dr_reg dreg(t1) = 0; $ show freed.
217 end if;
218 t = dw_next dword(t); $ next in word chain.
219 end while;
220 end if;
221 go to ret; $ go do common return.
222
223 else $ non-indexed case.
224
225 $ go process each operation type.
226 go to opk(gt_kind gwtab(type)) in 0 to num_gk;
227
228 /opk(gk_output)/ $ case where output is a alternate form.
229 out = reg; $ just point to the new form.
230 go to ret; $ go to common return processing.
231
232
233
234 /opk(gk_input)/ $ input -- storeword,
235
236 $ this is a simple store operation, can just do
237 $ move to see if should store or keep in register.
238 move_op(dw_freg dword(dw), out); $ do store.
239 return; $ done -- already dropped.
240
241 end if;
242
243
244 /ret/ $ common return processing.
245 $ at this point, merely issue drop calls for each input
246 $ or output used.
247 if index then drop(index); end if;
248 drop(in); $ drop input.
249
250 $ drop output unless -output- type.
251 if gt_kind gwtab(type) ^= gk_output then $ can drop output.
252 drop(out); $ go drop it.
253 end if;
254
255 .+trace.
256 if trace_d then $ print trace info.
257 if type = gw_word ! type = gw_addr then
258 tintl('gotwordr', out) tintl('offset', offset)
259 tintl('index', index) endl
260 end if;
261 end if;
262 ..trace
263
264 macdrop(gk_output) macdrop(gk_oper) macdrop(gk_input)
265 macdrop(gk_mask) macdrop(num_gk)
266
267 end subr getwordr;
1 .=member inzero
2 subr inzeror(reg, flg); $ indicate value in register zero.
3 $ the routine is called by the macro -inzero- to indicate
4 $ that a value is currenly in register zero. this is normally
5 $ called after a function call. the first parameter is the
6 $ dummy register describing the operand. the second parameter
7 $ is a flag indicating whether or not it is actually the address
8 $ of the operand.
9 size reg(ps); $ operand contained in register zero.
10 size flg(1); $ set if address is in register zero.
11 size mreg(ps); $ machine register for operand.
12 size t(ps); $ temporary and dummy variable.
13
14 $ see if quantity or address of quantity is in register zero.
15 if flg then $ this is case where address is in register.
16 $ in this case, allocate a register to contain the address
17 $ and move it from r0.
vaxa 244 .+t10 getreg(mreg, rt_liveaddr); $ must get a register.
vaxa 245 .+t32 mreg = r0; $ fake to use this register.
19 rl_content reglis(mreg) = dr_item dreg(reg); $ show owner.
20 di_addrreg ditem(dr_item dreg(reg)) = mreg; $ point to reg.
21 t = di_lword ditem(dr_item dreg(reg)); $ point to last word.
22 if (t^=dr_word dreg(reg) ! dw_next dword(t)) call aermey(17);
23 dw_madr dword(t) = 1; $ reset machine address.
vaxa 246 .+t10 mrcopy(mreg, r0); $ copy it over.
25 else $ data item is in r0.
26 $ in this case, set the status of the variable to
27 $ indicate that it is in register zero.
28 rl_content reglis(r0) = reg; $ set contents of register.
29 rl_type reglis(r0) = rt_live; $ set status.
30 dr_reg dreg(reg) = r0; $ point varible to register.
31 end if;
32
33 drop(reg); $ drop if last use.
34 end subr inzeror;
1 .=member labdef
2 subr labdefr(label, flag); $ define a label.
3 $ this routine is called by the -labdef- macro to define the
4 $ position of a label in code. if desired, it performs some
5 $ clearing actions corresponding to the occurance of a label.
6 $ if branch optimization is enabled, and there are fixup
7 $ requests pending on the label, they will be emitted.
8 size label(ps); $ label to define.
9 size flag(1); $ set to indicate clearing action wanted.
10 size i(ps), j(ps); $ work variables.
11 size reg(ps); $ temporary -dreg- pointer.
12
13 .+trace. $ generate trace code.
14 if trace_a then $ trace wanted.
15 tintl('labdef, label', label) tintl('f', flag) endl
16 end if;
17 ..trace
18
19 $ if flag is set, drop all base registers and register with
20 $ addresses in them. in addition, set all permenantly assigned
21 $ registers to live status.
22 if flag then $ clearing actions wanted.
23 do i = r0 to rhi; $ scan all registers.
24 if rl_type reglis(i) = rt_perm then $ set to live.
25 if (isconst(rl_content reglis(i))) cont do;
26 rl_type reglis(i) = rt_permlive; $ set to live.
27 elseif rl_type reglis(i) = rt_address then $ drop addr.
28 di_addrreg ditem(rl_content reglis(i)) = 0;
29 reglis(i) = 0; $ free register.
30 end if;
31 end do;
32
33 $ clear register useage counter since all not-permanent
34 $ register should be empty.
35 reguseval = 0; $ clear value for lru allocation.
36
37 end if;
38
39 put ocsfile ,column(9) ,'lab'
dss 44 ,column(17)
dss 45 ,'l'
dss 46 :(label+lablorg),i(labcol, labcol)
dss 47 ,x(17-labcol)
dss 48 ,column(33) ,tmcscom
dss 49 ,' / l '
dss 50 :(label+lablorg),i(2*labcol-1, labcol, 1)
dss 51 ,' /';
42 call ocsput(0, 0); $ put code.
43 .s. 33, 20, ocs = ''; $ clead ocs.
44
45 end subr labdefr;
1 .=member movadr
2 subr moveaddr(outr, inr); $ move an address.
3 $ this routine is called by -emitdop- to process a multi-word
4 $ indexed load. it is used to take the output -dreg- from a
5 $ -getaddr- and move the address pointed to by it into a
6 $ register so that it can be set as the output of the load.
7 size outr(ps); $ output register.
8 size inr(ps); $ input register.
9 size ildr(1); $ 'last usage of input'
10 size reg(ps); $ temporary register.
11 size mreg(ps); $ machine register.
12 size mreg1(ps); $ second machine register.
13 size moff1(mosize); $ machine offset.
14 size di(ps); $ pointer to dummy item.
15 size mode1(ps); $ dummy parameter.
16
17 .+trace. $ emit trace code.
18 if trace_a then $ trace wanted
19 tintl('moveaddr, out', outr) tintl('in', inr) endl
20 end if;
21 ..trace
22
23 $ [output of getaddr is 'funny temporary' when there is index.
24 $ [to use it, must get through moveaddr 20 apr]
25 di = dr_item dreg(inr); $ get dummy item pointer.
26
27 $ first, see if input dummy register has an address in a machine
28 $ register. if it does, that address can be moved into a new
29 $ register.
30 if di_addrreg ditem(di) then $ it is in a machine register.
31 $ if this is last use of the input and the register is
32 $ not permanent, then it can be used.
33 ildr = (di_count ditem(di) = 1 & di_ldrop ditem(di) &
34 di_luse ditem(di) ^= 0); $ get last usage status.
35 if ildr & rl_perm reglis(di_addrreg ditem(di)) = no then
36 $ can use this register. note that need
37 $ not check if a store is necessary because cannot
38 $ have a live address for a variable.
39 mreg = di_addrreg ditem(di); $ get machine register.
40 di_addrreg ditem(di) = 0; $ show not in register.
41 else $ must get a new register.
42 getreg(mreg, rt_liveaddr); $ go get register.
43 mrcopy(mreg, (di_addrreg ditem(di)));
44 end if;
45
46 elseif di_anum ditem(di) then $ must load address.
47 call aermey(18);
48 else $ must do load address.
49 getreg(mreg, rt_liveaddr); $ get register.
50
51 $ get base, displacement for value.
52 getdesc(inr, gd_addr, mode1, mreg1, moff1);
53
54 emop(mo_lda, mreg, mode1, mreg1, moff1);
55 end if;
56
57 $ set offset of dummy word.
58 dw_madr dword(dr_word dreg(outr)) = 1; $ set machine offset.
59
60 $ set output register status.
61 rl_subtype reglis(mreg) = rt_liveaddr; $ set to live address.
62 rl_content reglis(mreg) = dr_item dreg(outr); $ set to owner.
63 di_addrreg ditem(dr_item dreg(outr)) = mreg; $ show in register.
64
65 drop(outr); drop(inr); $ drop operands.
66
67 end subr moveaddr;
1 .=member sdsnam
2 subr sdsnamr(string, ptr); $ convert -ha- pointer to sds.
3 $ this routine is used to convert an -ha- pointer into an
4 $ sds containing the first -namelen- characters of the
5 $ name given in the little program.
6 size string(.sds. namelen); $ output string.
7 size ptr(ps); $ -ha- pointer of name to convert.
8 size namesp(ps); $ pointer to -names- array.
9 size i(ps); $ loop variable.
10 size j(ps); $ temporary.
vaxa 247 .+t32 size c(ps); $ character.
11
12 $ first, set length to max(nchars(ha), namelen)
13 j = ha_nchars ha(ptr); $ get length of name.
vaxa 248 .+t10 if (j>6) j = 6; $ at most six chars.
vaxa 249 .+t32 if (j>15) j = 15; $ at most 15 chars.
15
16 $ initialize string descriptor.
17 string = 0; $ clear unused parts.
18 sorg string = .sds. namelen + 1; $ set origin.
19 namesp = ha_nayme ha(ptr); $ get -names- pointer
20 if (namesp=0) j = 0; $ null string if no name.
21 slen string = j;
22
23 do i = 1 to j; $ copy all characters.
24 .ch. i, string = .f. ws+1-cs - mod(i-1, cpw)*cs, cs,
25 names(namesp + (i-1)/cpw); $ move character.
dsp 43 .+t10 if (.ch. i, string = 1r_) .ch. i, string = 1r$;
26 end do;
27
28 end subr sdsnamr;
1 .=member sdlnam
2 subr sdlnamr(string, ptr); $ convert -ha- pointer to sds.
3 $ this routine is used to convert an -ha- pointer into an
4 $ sds containing the first -namelen- characters of the
5 $ name given in the little program.
6 size string(.sds. namelen); $ output string.
7 size ptr(ps); $ -ha- pointer of name to convert.
8 size namesp(ps); $ pointer to -names- array.
9 size i(ps); $ loop variable.
10 size j(ps); $ temporary.
11
12 $ first, set length to max(nchars(ha), namelen)
13 j = ha_nchars ha(ptr); $ get length of name.
14 if (j>namelen) j = namelen; $ at most six chars.
15
16 $ initialize string descriptor.
17 string = 0; $ clear unused parts.
18 sorg string = .sds. namelen + 1; $ set origin.
19 namesp = ha_nayme ha(ptr); $ get -names- pointer
20 if (namesp=0) j = 0; $ null string if no name.
21 slen string = j;
22
23 do i = 1 to j; $ copy all characters.
24 .ch. i, string = .f. ws+1-cs - mod(i-1, cpw)*cs, cs,
25 names(namesp + (i-1)/cpw); $ move character.
dsp 44 .+t10 if (.ch. i, string = 1r_) .ch. i, string = 1r$;
26 end do;
27
28 end subr sdlnamr;
1 .=member special
2 subr special; $ special case binary operations.
3 $ this routine check for and processes special cases for
4 $ simple binary operators. it sets the global flag -isspecial-
5 $ to indicate whether or not a special case was found.
6 $
7 $ possible special cases are, at present, only those in which
8 $ one or more of the two operands is a short constant so only
9 $ these need be processed further. each operation that can
10 $ be special cased has two routines. one is for the case where
11 $ the right-hand variable is a short constant and the other is
12 $ for the case where the left-hand variable is a short constant.
13 $ note that for commutative operations only one of these is
14 $ necessary and the right-hand one is used.
15 size dop_commutes(do_div); $ flags which operations commute.
16 data dop_commutes = 1b'01110001'; $ add, eq, ne, mul commute.
17 size aop(ws); $ a op
18 size constv(ws); $ constant value
19 size work(ps); $ operand pointer
20 size t(ps); $ temporary.
21
22 $ initially, not a special case.
23 isspecial = no;
24
25 $ only operations below -do_div- are special cased by this
26 $ subroutine.
27 if (dopcode > do_div) return;
28
29 $ if right operand is short constant, process.
30 if (isscon(dopjr)) go to right;
31
32 $ check left operand.
33 if isscon(dopir) then
34 $ if operation commutes, reverse operands so that right
35 $ operand will be the constant. else process left operand.
36 if .f. dopcode, 1, dop_commutes then $ operation commutes.
37 t = dopir; dopir = dopjr; dopjr = t; $ swap
38 go to right; $ process right operand.
39 else $ operation does not commute.
40 go to left; $ process left operand.
41 end if;
42 end if;
43
44 $ since neither operand is a short constant, this is not a
45 $ special case.
46 return;
47
48 /right/
49 $ process operand on right-hand side.
50 constv = conval(dopjr); $ get constant value.
51
52 go to r(dopcode) in do_add to do_div; $ select routine.
53
54 /left/
55 $ process operand on left-hand side.
56 constv = conval(dopir); $ get constant value.
57 go to l(dopcode) in do_add to do_div; $ select routine.
58
59
60
61 /r(do_add)/
62 $ special case routine for addition.
63
64 if (constv ^= 1) return;
65 isspecial = yes; $ is special case.
66 kill(dopjr); $ kill constant.
67
68 lastuse(dopir); lastuse(dopor); $ set status.
69 add1_op(dopor, dopir); $ add one.
70 return;
71
72 /r(do_sub)/
73 $ special case routine for right-hand constant in subtraction.
74 $ if constant is not 1, not special. if it is 1, then use
75 $ shorter subtraction by 1.
76 if (constv ^= 1) return;
77 isspecial = yes; $ show special.
78
79
80 kill(dopjr); $ kill constant input.
81
82 lastuse(dopir); lastuse(dopor); $ set status.
83 sub1_op(dopor, dopir); $ subtract.
84 return;
85
86
87 /r(do_mul)/ /r(do_div)/ $ multiplication, division.
88 $ if constant is power of two generate appropriate arithmetic
89 $ shift operation.
90
91 if (.nb. constv ^=1) return;
92 if (dopcode = do_div & syze(dopir) = mws) return;
93 isspecial = yes; $ is special case.
94 assignconst(work, ((.fb. constv)-1));
95 aop = ao_imt; $ assume multiplication.
96 if (dopcode = do_div) aop = ao_idt; $ if division.
97 lastuse(dopor); lastuse(dopir); lastuse(work); $ set status.
98 bin_op(aop, dopor, dopir, work); $ emit op.
99 return;
100
101 $ define unused processors. these can occur either
102 $ because a short constant on a given side of an operation
103 $ does not allow any special case and for the left-hand side
104 $ of commutative operators.
105 /l(do_add)/ /l(do_eq)/ /l(do_ne)/ /l(do_mul)/ /l(do_div)/
106 /l(do_sub)/ /r(do_lt)/ /l(do_lt)/ /r(do_ge)/ /l(do_ge)/
107 /r(do_eq)/ /r(do_ne)/
108
109 end subr special;
1 .=member storall
2 subr storall; $ store all machine registers.
3 $ this routine stores all live, non-permanent machine registers.
4 size i(ps); $ register index.
5
6 .+trace if trace_a then textl(' *storall') endl end if;
7
8 do i = r0 to rhi; $ loop over all registers.
9 if rl_type reglis(i) = rt_live then $ check if live data.
10 if (isvar(rl_content reglis(i)) = no) cont do;
11 store(i, rl_content reglis(i)); $ store register.
12 end if;
13 end do;
14
15 end subr storall;
1 .=member emitbin
2 subr emitbin(iop, iout, iin1, iin2); $ emit binary operation.
3 $ this routine emits binary operations. it handles much of
4 $ the lowest-level optimizations done in this code generator.
5 $ it decides what machine instruction types should be issued
6 $ for various cases of register status. it is driven by an
7 $ internal table which contains information needed for the
8 $ various sub-routines in this routine.
9 size iop(ps); $ operation.
10 size t(mosize); $ temporary for offset copy.
11 size iout(ps); $ output register.
12 size iin1(ps); $ first input.
13 size iin2(ps); $ second input.
14
15 $ operation types used in table.
16 +* ek_norm = 1 ** $ normal binary operation.
17 .+eab.
18 +* ek_mul = 2 ** $ multiplication.
19 +* ek_div = 3 ** $ division or -mod- function.
20 +* ek_sign = 4 ** $ -sign- or -isign- operation.
21 +* ek_shift = 5 ** $ shift right or left.
22
23 +* num_ek = 5 **
24 .-eab.
25 +* num_ek = 1 ** $ only norm for
26 ..eab
27
28 size ebtab(ws); $ operation table.
29 dims ebtab(ao_lbo-ao_fbo+1);
30
31 $ define fields in -ebtab-.
32
33 +* eb_mop = .f. 1, 8, ** $ machine operation to use.
34 +* eb_type = .f. 9, 4, ** $ operation type.
35 +* eb_comm = .f. 13, 1, ** $ 'operation commutes'
36
37 +* ebset(op, rm, ty, cm) = $ build table.
38 ebtab(op - (ao_fbo-1)) =
39 cm*4b'1000'+ty*4b'100'+rm **
40
41 data $ initialize binary operation table.
42
43 $ aop r-mop type comm
44 $ --- ----- ---- ----
45
46 ebset(ao_ban, mo_ban, ek_norm, yes):
47 ebset(ao_bor, mo_bor, ek_norm, yes):
48 ebset(ao_bxo, mo_bxo, ek_norm, yes):
49 ebset(ao_idi, mo_idi, ek_norm, no):
50 ebset(ao_idt, mo_idt, ek_norm, no):
51 ebset(ao_ieq, mo_ieq, ek_norm, yes):
52 ebset(ao_ige, mo_ige, ek_norm, no):
53 ebset(ao_igt, mo_igt, ek_norm, no):
54 ebset(ao_ile, mo_ile, ek_norm, no):
55 ebset(ao_ilt, mo_ilt, ek_norm, no):
dsf 9 ebset(ao_imo, mo_imo, ek_norm, no):
57 ebset(ao_imu, mo_imu, ek_norm, yes):
dsc 11 ebset(ao_imt, mo_imt, ek_norm, no):
59 ebset(ao_ine, mo_ine, ek_norm, yes):
60 ebset(ao_isi, mo_isi, ek_norm, no):
61 ebset(ao_isu, mo_isu, ek_norm, no):
62 ebset(ao_iad, mo_iad, ek_norm, yes):
63 ebset(ao_rad, mo_rad, ek_norm, yes):
64 ebset(ao_rdi, mo_rdi, ek_norm, no):
65 ebset(ao_req, mo_req, ek_norm, yes):
66 ebset(ao_rge, mo_rge, ek_norm, no):
67 ebset(ao_rgt, mo_rgt, ek_norm, no):
68 ebset(ao_rle, mo_rle, ek_norm, no):
69 ebset(ao_rlt, mo_rlt, ek_norm, no):
70 ebset(ao_rmo, mo_rmo, ek_norm, no):
71 ebset(ao_rmu, mo_rmu, ek_norm, yes):
72 ebset(ao_rne, mo_rne, ek_norm, yes):
73 ebset(ao_rsi, mo_rsi, ek_norm, no):
74 ebset(ao_rsu, mo_rsu, ek_norm, no);
75
76 macdrop(ebset)
77
78 size op(ps); $ local copy of operation.
79 size out(ps); $ local copy of output.
80 size in1(ps); $ local copy of first input.
81 size in2(ps); $ local copy of second input.
82 size i1ldr(1); $ 'last usage of input 1'
83 size i2ldr(1); $ 'last usage of input 2'
84 size oldr(1); $ 'last usage of output'
85 size omreg(ps); $ machine register for output.
86 size omode(ps); $ machine indicator for output.
87 size omoff(mosize); $ machine offset for output.
88 size i1mreg(ps); $ machine register for first input.
89 size i1mode(ps); $ machine indicator for first input.
90 size i1moff(mosize); $ machine offset for first input.
91 size i2mreg(ps); $ machine register for second input.
92 size i2mode(ps); $ machine indicator for second input.
93 size i2moff(mosize); $ machine offset for second input.
94 size mreg(ps); $ temporary machine register.
95 size mop(ps); $ temporary operation.
96 size lab(ps); $ label to use.
97 size mreg1(ps); $ second temporary machine register.
98 size mreg2(ps); $ third temporary machine register.
99 size i(ps); $ temporary.
100
101 .+trace. $ print trace info.
102 if trace_a then $ trace info. wanted.
103 tintl('binop, op', iop) tintl('out', iout)
104 tintl('in1', iin1) tintl('in2', iin2) endl
105 end if;
106 ..trace
107
108 $ initialize variable for emission.
109 op = iop - (ao_fbo-1); $ get local op code.
110 out = iout; in1 = iin1; in2 = iin2; $ get local copy of operands.
111
112
113 $ set last usage indicator for inputs and get machine
114 $ parameters for them.
115 i1ldr = lastdrop(in1); $ get last usage counts.
116
117 i2ldr = lastdrop(in2); $ get last usage counts.
118
119 oldr = lastdrop(out); $ get last usage counts.
120
121 getdesc(in1, gd_use, i1mode, i1mreg, i1moff);
dse 17 if iop = ao_imt ! iop = ao_idt then $ if mul/div by power of two
dse 18 if dr_reg dreg(in2) then $ if input in register.
dse 19 if (isscon(in2) = no) call aermey(41); $ need constant.
dse 20 reglis(dr_reg dreg(in2)) = 0; $ clear register status.
dse 21 dr_reg dreg(in2) = 0; $ show no longer in register.
dse 22 end if;
dse 23 end if;
dse 24
dse 25 getdesc(in2, gd_use, i2mode, i2mreg, i2moff);
123 getdesc(out, gd_use, omode, omreg, omoff);
124
125 $ branch to proper operation type.
126 .+eab go to l(eb_type ebtab(op)) in 1 to num_ek;
127 .-eab $ for bootstrap, all ops are ek_norm type.
128
129
130 /l(ek_norm)/ $ processor for normal binary operation.
131
132 $ first check for the case where an operand is used for
133 $ both inputs and the output and the operation is either
134 $ a subtraction or exclusive-or. in this case, get a
135 $ register and assign it to all of the operands.
136 if out = in1 & in1 = in2 & omode^=am_reg then $ have this case.
137 if iop = ao_isu ! iop = ao_bxo ! iop = ao_rsu then
138 omreg = dr_reg dreg(out); $ see if output register.
139 if omreg = 0 then $ third is not.
140 getreg(omreg, rt_live); $ get register.
141 end if;
142
143 emop(eb_mop ebtab(op), omreg, am_reg, omreg, 0); $ issue.
144 go to ret; $ done.
145 end if;
146 end if;
147
148 $ the next step is to see if either of the inputs are
149 $ not in a register but it is not their last use. in this
150 $ case, they are loaded into a register, if one is available.
151
152 if i1ldr = no & i1mode^=am_reg & isinif=no then $ see if can get
153 $ first, get a register of the appropriate type.
154 getreg(mreg, rt_need); $ get real or general.
155
156 if mreg then $ one is available.
157 i1mreg = mreg; $ show register that input will be in.
158 getvar(in1, gd_intoreg, i1mode, i1mreg, i1moff); $ load.
159
160 if out = in1 then $ must update -out- status too.
161 omreg = mreg; omode = am_reg; omoff = 0;
162 end if;
163 if in2 = in1 then $ must update -in2- status too.
164 i2mreg = mreg; i2mode = am_reg; i2moff = 0;
165 end if;
166 end if;
167 end if;
168
169 if i2ldr = no & i2mode^=am_reg & isinif=no then $ see if can get
170 getreg(mreg, rt_need); $ get register.
171
172 if mreg then $ one is available.
173 i2mreg = mreg; $ show operand is in a register.
174 getvar(in2, gd_intoreg, i2mode, i2mreg, i2moff); $ load.
175
176 if out = in2 then $ must update -out- status too.
177 omreg = mreg; omode = am_reg; omoff = 0;
178 end if;
179 end if;
180 end if;
181
182
183 i = rt_need; $ set to try to find first time.
184 while omode^=am_reg; $ when exited, register will be in -omreg-.
dsc 15 omoff = 0;
186
187 $ if input 1 is in non-permanent register and this is
188 $ the last use, can use for output.
189 if i1ldr & i1mode=am_reg & rl_perm reglis(i1mreg) = no then
190 omreg = i1mreg; $ set output register.
dsc 16 omode = am_reg;
191 $ must store if live.
192 if rl_type reglis(i1mreg)=rt_live & isvar(in1) then
193 store(i1mreg, in1);
194 end if;
195 dr_reg dreg(in1) = 0; $ not in here any more.
196 quit while;
197 end if;
198
199 $ if operation is commutative, can check for same thing
200 $ on second input.
201 if eb_comm ebtab(op) then $ it is commutative.
202 if i2ldr & i2mode=am_reg & rl_perm reglis(i2mreg)=no then
203 omreg = i2mreg; $ set output register.
dsc 17 omode = am_reg;
204 $ must store if live.
dsc 18 if rl_type reglis(i2mreg)=rt_live & isvar(in2) then
dsc 19 store(i2mreg, in2);
dsc 20 end if;
208 dr_reg dreg(in2) = 0; $ not in here any more.
209 $ swap fields.
210 t = i1moff; i1moff = i2moff; i2moff = t;
211 t = i1mode; i1mode = i2mode; i2mode = t;
212 t = i1mreg; i1mreg = i2mreg; i2mreg = t;
213 t = in1; in1 = in2; in2 = t;
214 quit while;
215 end if;
216 end if;
217
218 $ otherwise, hold the input register (just to be sure)
219 $ and see if output register is available.
220 rl_hold reglis(i1mreg) = yes;
221 rl_hold reglis(i2mreg) = yes;
222 getreg(omreg, i); $ try to get a register.
223 $ if got one, can exit loop.
dsc 21 if omreg then
dsc 22 omode = am_reg;
dsc 23 quit while;
dsc 24 end if;
225
226 $ at this point there are no registers available. in this
227 $ case, fake as if the inputs had last use and loop again.
228 i = rt_live; $ set next time to try all.
229
230 $ if a register does not have live status, show that
231 $ it can be used.
232 i1ldr = (rl_type reglis(i1mreg) ^= rt_live);
233 i2ldr = (rl_type reglis(i2mreg) ^= rt_live);
234 end while;
235
236 $ next, must get an input (for non-commutative -- first input)
237 $ into the output register.
238 until yes; $ quit when in register.
239 if (i1mreg = omreg) quit until; $ have it.
240
241 if i2mreg = omreg then $ second arg. is in output register.
242 if eb_comm ebtab(op) = no then $ not commutative op.
243 $ must check the operation. if this is a
244 $ subtraction, complement input, set operation to
245 $ addition, and swap. otherwise error.
246 if op = ao_isu - (ao_fbo-1) then $ normal sub.
247 emop(mo_ico, omreg, am_reg, omreg, 0); $ complemen
248 op = ao_iad - (ao_fbo-1); $ set for add.
249 elseif op = ao_rsu - (ao_fbo-1) then $ if real.
250 emop(mo_rco, omreg, am_reg, omreg, 0); $ complemen
251 op = ao_rsu - (ao_fbo-1); $ set for add.
252 else $ error.
253 call aermey(19); $ this is fatal error.
254 end if;
255 end if;
256
257 i2mreg = i1mreg; i2moff = i1moff; i2mode = i1mode;
258 quit until; $ have in register.
259 end if;
260
261
262 if i1mode = am_reg then $ this is in register. copy it.
263 mrcopy(omreg, i1mreg); $ copy reg.
264 quit until; $ have in register.
265 end if;
266
267 $ if operation is commutative, see if input 2 is in reg.
268 if i2mode = am_reg & eb_comm ebtab(op) then $ ok.
269 mrcopy(omreg, i2mreg); $ move into reg.
270 i2mreg = i1mreg; i2mode = i1mode; i2moff = i1moff; $ swap.
271 quit until;
272 end if;
273
274 $ otherwise, do load into output.
275 $ if this is commutative operation with the first
276 $ operand a short constant, swap operands.
277 if eb_comm ebtab(op) & isscon(in1) then $ it is.
278 i2moff=i1moff; i2mreg=i1mreg; i2mode=i1mode; in1=in2;
279 end if;
280
281 $ get first operand into register.
282 getvar(in1, gd_inregnu, t, omreg, t);
283 end until;
284
285 $ finally, do operation.
286 emop(eb_mop ebtab(op), omreg, i2mode, i2mreg, i2moff);
287
288 go to ret;
289
290
291 .+eab. $ defer sign, isign code until after bootstrap
292 $ and do off-line for bootstrap.
293 /l(ek_sign)/ $ -sign- or -isign- function.
294
295 $ first, get first input into a register if it is not already.
296 if i1mode ^= am_reg then $ it is not in a register.
297 getvar(in1, grtype, i1mode, i1mreg, i1moff);
298 end if;
299
300 $ get register to use for output.
301 i = rt_need; $ initially, just see if one available.
302 while omode ^= am_reg; $ exit when register in -omreg-.
303
304 $ see if can use input register.
305 if i1ldr & i1mode=am_reg & rl_perm reglis(i1mreg)=no then
306 omreg = i1mreg; $ set to proper register.
307 dr_reg dreg(in1) = 0; $ not in here any more.
308 quit while;
309 end if;
310
311 $ try to get an appropriate register.
312 rl_hold reglis(i1mreg) = yes; $ hold this input.
313 rl_hold reglis(i2mreg) = no; $ but release other one.
314 getreg(omreg, i); $ try to get a register.
315 $ if a register was obtained, use it.
316 if (omreg) quit while;
317
318 $ otherwise, must reset to use input.
319 i1ldr = (rl_type reglis(i1mreg) ^= rt_live); $ fake last use.
320 i = rt_live; $ set to force a register.
321 end while;
322
323 $ do operation. first, get absolute value.
324 rrop(eb_mop ebtab(op), omreg, i1mreg); $ -lper- or -lpr-
325
326 $ get a label and emit branch to it if second operand is
327 $ positive.
328 labget(lab); ifpos_op(in2, lab); $ branch on second operand.
329
330 $ if was not positive, then do complement.
331 rrop(eb_xmop ebtab(op), omreg, omreg); $ -lcer- or -lcr-.
332
333 $ define ending label and free it.
334 labdef(lab, no); labfree(lab);
335
336 go to ret;
337 ..eab
338
339
340 .+eab. $ defer mul/div special casing
341 /l(ek_mul)/ $ multiplication.
342
343
344 $ the first thing to do is to see which, if any, of the input
345 $ registers can be pre-empted. then call the -getregpair-
346 $ routine to get a register pair.
347
348 mreg1 = 0; mreg2 = 0; $ initially none can.
349 if (i1ldr & i1mode = am_reg & rl_perm reglis(i1mreg) = no)
350 mreg1 = i1mreg; $ can use first register.
351 if (i2ldr & i2mode = am_reg & rl_perm reglis(i2mreg) = no)
352 mreg2 = i2mreg; $ can use second register.
353
354 getregpair(mreg, mreg1, mreg2); $ get pair into -mreg-.
355
356 $ next, get an input into the second register of the pair.
357 until yes; $ exit when gotten.
358 if (mreg+1 = i1mreg) quit until; $ got 1st.
359 if mreg+1 = i2mreg then $ got 2nd -- exchange.
360 t = in2; in2 = in1; in1 = t;
361 t = i2mreg; i2mreg = i1mreg; i1mreg = t;
362 t = i2moff; i2moff = i1moff; i1moff = t;
363 t = i2mode; i2mode = i1mode; i1mode = t;
364 quit until;
365 end if;
366
367 $ else must load into register.
368 getvar(in1, gd_inregnu, t, mreg+1, t); $ force to -mreg+1-.
369 end until;
370
371 $ set -mreg1- to the register to contain the output.
372 mreg1 = mreg+1; $ set for common code.
373
374 /muldiv/ $ this code is common for multiplication and division.
375 $ if the second operand is not in a register and this is not
376 $ the last usage of that operand, then load it into a
377 $ register if one if available.
378 if i2ldr = no & i2mode^=am_reg then $ try to get a register.
379 rl_hold reglis(mreg) = yes; rl_hold reglis(mreg+1) = yes;
380 getreg(mreg2, rt_need); $ see if one is available.
381 if mreg2 then $ there is one available.
382 i2mreg = mreg2; $ show which register is in.
383 getvar(in2, gd_intoreg, i2mode, i2mreg, i2moff);
384 end if;
385 end if;
386
387 $ do operation.
388 if i2mode^=am_reg then $ do -rx- operation.
389 rxop(eb_xmop ebtab(op), mreg, i2moff, r0, i2mreg);
390 else $ do -rr- operation.
391 rrop(eb_mop ebtab(op), mreg, i2mreg);
392 end if;
393
394 rl_hold reglis(mreg+1) = no; $ this is unheld.
395
396 $ must see if either register in the pair was
397 $ holding one of the inputs to the operation. if so, must
398 $ show that the input is no longer in that register.
399 if i1mreg = mreg ! i1mreg = mreg+1 then $ hit input one.
400 dr_reg dreg(in1) = 0; $ show not assigned.
401 end if;
402
403 if i2mreg = mreg ! i2mreg = mreg+1 then $ hit input two.
404 dr_reg dreg(in2) = 0; $ show not assigned.
405 end if;
406
407 $ must move the result to the output. if the output
408 $ is a permanently assigned register or if the register pair
409 $ allocated is non-standard, must move the data. otherwise,
410 $ can just indicate that it resides in the pair.
411 if mreg1 = r1 ! mreg1 >= r14 then $ bad place.
412 reglis(r1) = 0; rl_type reglis(r1) = rt_permresv; $ reset.
413 if omode^=am_reg then $ must get output register.
414 getreg(omreg, rt_live); $ get one.
415 end if;
416
417 $ just move to output.
418 mcropy(omreg, mreg1);
419 go to ret; $ done.
420 end if;
421
422 $ check if the output is a permanently assigned register.
423 if omode = am_reg then $ it is a register.
424 mrcopy(omreg, mreg1); $ copy reg.
425 reglis(mreg1) = 0; $ clear register.
426 go to ret;
427 end if;
428
429 $ otherwise, can assign to output.
430 omreg = mreg1; $ show output is here.
431 $ the regster which does not contain the output is
432 $ to be concidered dead.
433 if omreg = mreg
434 then reglis(mreg+1) = 0;
435 else reglis(mreg) = 0; end if;
436
437 go to ret;
438
439 /l(ek_div)/ $ division or -mod- function.
440
441 $ in this case, must see if can pre-empt the first input
442 $ register and, if so, so indicate. then a register pair is
443 $ obtained.
444 mreg1 = 0; $ assume cannot pre-empt.
445 if (i1ldr & i1mode = am_reg & rl_perm reglis(i1mreg) = no)
446 mreg1 = i1mreg; $ can use.
447
448 $ [ds 11 apr should issue aop for t10, and hence no need
449 $ for reg pair here.]
450 getregpair(mreg, mreg1, 0); $ get register pair.
451
452 $ must load first input into high register of pair. note
453 $ that do not bother to check for the case where this is not
454 $ last use of the input because division is not that common
455 $ an operation.
456 if mreg ^= i1mreg then $ must put it in.
457 getvar(in1, gd_inregnu, t, mreg, t); $ move it.
458 end if;
459
460 $ do shift down to high register.
461 rxop(mop_srda, mreg, ws, r0, r0); $ propagate sign through high.
462
463 $ prepare to branch to common code to emit operation.
464 $ set -mreg1- to that register that will contain the output
465 $ of the operation.
466 mreg1 = mreg+1; $ assume division.
467 if (iop = ao_mod) mreg1 = mreg; $ set for -mod- function.
468 go to muldiv; $ enter common code.
469
470 ..eab
471
472
473 /ret/ $ common return point.
474 $ first, update status of output register.
475 dr_reg dreg(out) = omreg; $ show in this register.
476 rl_subtype reglis(omreg) = rt_live; $ show changed.
477 rl_content reglis(omreg) = out; $ show owner.
478
479 /noupdate/ $ branch here to skip status update.
480 $ drop inputs.
481 drop(iin1); drop(iin2); drop(iout);
482
483 return;
484
485 .+eab macdrop(ek_norm) macdrop(ek_mul)
486 .+eab macdrop(ek_div) macdrop(ek_sign)
487 macdrop(ek_shift) macdrop(eb_mop)
488 macdrop(eb_type) macdrop(eb_comm)
489 macdrop(eb_fp)
490
491 end subr emitbin;
1 .=member emitcmp
2 subr emitcmp(imask, iin1, iin2, lab); $ emit comparison.
3 $ this routine emits a compare and a branch. it compares
4 $ two inputs and will conditionally branch to a given label.
5 size imask(3); $ conditional branch mask.
6 size iin1(ps); $ first input.
7 size iin2(ps); $ second input.
8 size lab(ps); $ label to branch to.
9 size mask(ps); $ copy of branch mask.
10 size in1(ps); $ copy of first input.
11 size in2(ps); $ copy of second input.
12 size i1ldr(1); $ drop bit for first input.
13 size i2ldr(1); $ drop bit for second input.
14 size i1mode(ps); $ indirect bit for first input.
15 size i2mode(ps); $ indirect bit for second input.
16 size i1mreg(ps); $ machine register for first input.
17 size i2mreg(ps); $ machine register for second input.
18 size i1moff(mosize); $ machine offset for first input.
19 size i2moff(mosize); $ machine offset for second input.
20 size mreg(ps); $ register obtained.
21 size t(ps); $ temporary.
22 size gtype(ps); $ desired address type.
dsb 96 size moctb(ps); dims moctb(9);
dsb 97 +* mo_cmptab(i) = moctb((i)+1) ** $ array is zero-origin
24 data mo_cmptab(bm_all) = mo_jmp:
25 mo_cmptab(bm_neg) = mo_clt:
26 mo_cmptab(bm_pos) = mo_cgt:
27 mo_cmptab(bm_zer) = mo_ceq:
28 mo_cmptab(binv(bm_all)) = mo_jmn:
29 mo_cmptab(binv(bm_neg)) = mo_cge:
30 mo_cmptab(binv(bm_pos)) = mo_cle:
31 mo_cmptab(binv(bm_zer)) = mo_cne;
32
33 $ first, make copy of inputs and set some initial defaults.
34 in1 = iin1; in2 = iin2; mask = imask;
35 $ get last usage bits.
36 i1ldr = lastdrop(in1); $ get last usage counts.
37
38 i2ldr = lastdrop(in2); $ get last usage counts.
39
40
41 $ get machine descriptors for inputs.
42 getdesc(in1, gd_use, i1mode, i1mreg, i1moff);
43 getdesc(in2, gd_use, i2mode, i2mreg, i2moff);
44
45 $ see if this is not the last use of the first input and
46 $ it is in storage. load it into an available register if so.
47 if i1ldr = no & i1mode^=am_reg & isinif=no then $ can get to re
48 getreg(mreg, rt_need); $ see if reg available.
49 if mreg then $ if reg available.
50 i1mreg = mreg; $ copy to result register.
51 getvar(in1, gd_intoreg, i1mode, i1mreg, i1moff);
52 $ must check for the cases where both inputs same.
53 if in2 = in1 then $ update in2 status also
54 i2mreg = mreg; i2mode = am_reg; i2moff = 0;
55 end if;
56 end if;
57 end if;
58 $ do the same for the second input.
59
60 if i2ldr = no & i2mode^=am_reg & isinif=no then $ can get in2.
61 getreg(mreg, rt_need); $ see if reg available.
62 if mreg then $ if reg. available.
63 i2mreg = mreg; $ set result reg.
64 getvar(in2, gd_intoreg, i2mode, i2mreg, i2moff);
65 end if;
66 end if;
67
68 $ get one of the inputs into a register.
69 until yes; $ quit when one is loaded.
70 mreg = i1mreg; $ assume first input in a register.
71 if (i1mode = am_reg) quit until; $ quit if it is.
72 if i2mode = am_reg then $ second input is in a register.
73 $ copy descriptors.
74 mreg=i2mreg; i2mreg=i1mreg; i2mode=i1mode; i2moff=i1moff;
75 bmswap(mask, t); $ reverse branch mask.
76 quit until; $ indicate in register.
77 end if;
78
79 $ must get a register.
80 getreg(mreg, rt_live); $ get register.
81
82 $ if the first input is a short constant, then
83 $ will want to load second into the register.
84 if isscon(in1) then $ it is.
85 in1 = in2; $ set to this input.
86 i2mode = i1mode; i2mreg = i1mreg; i2moff = i1moff;
87 bmswap(mask, t); $ reverse branch mask.
88 end if;
89
90 gtype = gd_intoreg; if (isinif) gtype = gd_inregnu;
91 getvar(in1, gtype, i1mode, mreg, i1moff);
92 if (isinif) reglis(mreg) = 0; $ clear status of gotten regis
93 end until;
94
95 $ do the comparison.
96 emop(mo_cmptab(binv(mask)), mreg, i2mode, i2mreg, i2moff);
97 goto_op(lab);
98
99 drop(iin1); drop(iin2); $ drop the inputs.
dsb 98 macdrop(mo_cmptab)
100
101 end subr emitcmp;
1 .=member emitif
2 subr emitif(iop, inr, label); $ emit an -if- operation.
3 $ this routine is called to proces conditional branch
4 $ operations. it decides whether to do the operation as
5 $ a storage operation or to load it into a register and test
6 $ it in the register.
7 size iop(ps); $ branch mask to use.
8 size inr(ps); $ dummy register to test.
9 size label(ps); $ label to branch to if condition true.
10 size mreg(ps); $ machine register for operand.
11 size moff(mosize); $ machine address.
12 size mode(ps); $ machine mode.
13
14
15 .+trace.
16 if trace_a then $ trace output wanted.
17 tintl('ifop, mask', iop) tintl('in', inr)
18 tintl('l', label) endl
19 end if;
20 ..trace
21
22 $ first set flag to indicate whether this is last use of
23 $ operation. this will be used later.
24
25
26 $ get description of variable.
27 getdesc(inr, gd_use, mode, mreg, moff);
28 if mode ^= am_reg then $ if not in register.
29 getvar(inr, gd_reg, mode, mreg, moff); $ bring to reg.
30 if isinif then $ if in if.
31 reglis(mreg) = 0; dr_reg dreg(inr) = 0;
32 end if;
33 end if;
34
35 $ finally, emit branch instruction.
36 branchop(iop, mreg, label);
37
38 /ret/ $ common return code.
39
40 drop(inr); $ free if last use.
41 end subr emitif;
42 subr emitlong(op, outr, inr, length); $ emit long op.
1 .=member emitlon
2 $ the routine emits code for the storage-storage operations.
3 $ it uses a table to determine which machine operation to
4 $ issue. in addition, it handles the storing and freeing of
5 $ words near the operand locations.
6 size op(ps); $ internal operati!n code.
7 size outr(ps); $ output dummy register.
8 size inr(ps); $ input dummy register.
9 size length(ps); $ length, in words, of operation to perform.
10 size imode(ps); $ input address mode.
11 size omode(ps); $ output address mode.
12 size imreg(ps); $ machine register for input.
13 size imoff(mosize); $ machine offset for input.
14 size omreg(ps); $ machine register for output.
15 size omoff(mosize); $ machine offset for output.
16 size mreg(ps); $ machine register.
17 size i(ps), j(ps), k(ps); $ temporaries.
18 size dw(ps); $ pointer to dummy word.
19
20 .+trace. $ generate trace code.
21 if trace_a then $ if tracing these ops.
22 tintl('longop, op', op) tintl('out', outr)
23 tintl('in', inr) tintl('l', length) endl
24 end if;
25 ..trace
26 $ must store any live forms of the input that fall
27 $ into the range to be moved.
28 if op = ao_mvw then $ only store if move operation.
29 i = dw_word dword(dr_word dreg(inr)); j = i+length-1;
30 dw = di_lword ditem(dr_item dreg(inr)); $ point to first wor
31 while dw; $ while more in chain.
32 $ see if in specified range.
33 if dw_word dword(dw) >= i & dw_word dword(dw) <= j then
34 $ it is. see if primary register is live.
35 if dr_reg dreg(dw_freg dword(dw)) then $ there is on
36 if rl_subtype reglis(dr_reg dreg(dw_freg
37 dword(dw))) = rt_live then $ it is live.
38 store(dr_reg dreg(dw_freg dword(dw)), $ stor
39 dw_freg dword(dw)); $ primary form.
40 end if;
41 end if;
42 end if;
43
44 dw = dw_next dword(dw); $ get next in chain.
45 end while;
46 end if;
47
48 $ get descriptors for output and input and go do operation.
49 getdesc(inr, gd_addr, imode, imreg, imoff); $ get input.
50 getdesc(outr, gd_addr, omode, omreg, omoff); $ get output.
51
52 $ now emit the long operation. first move the output address in
53 $ to a register.
54 $ if the start of the output is at offset zero from a register,
55 $ then can use that register.
56 if omoff = 0 & omode = am_rel then $ can use register.
57 mreg = omreg; $ set register to use.
58 else $ must get a register.
59 getreg(mreg, rt_live); $ get a register.
60 emop(mo_lda, mreg, omode, omreg, omoff); $ load address.
61 reglis(mreg) = 0; $ nothing usefull in register.
62 end if;
63
64 $ now actually emit the move or clear.
65 if op = ao_mvw then $ emit move.
66 emopparm1 = length; $ set length to move.
67 emop(mo_mvw, mreg, imode, imreg, imoff); $ emit the move.
68 else $ this must be a clear.
69 imoff = 0; mbo_blk imoff = bl_imm; $ set for immediate.
70 mbo_off imoff = length; $ put length out as ea.
71 emop(mo_zeb, mreg, am_mem, sparereg, imoff); $ clear storage.
72 end if;
73
74 $ must drop any output words that are in range modified.
75 i = dw_word dword(dr_word dreg(outr));j = i+length-1;
76 dw = di_lword ditem(dr_item dreg(outr)); $ get first word.
77 while dw; $ loop until end of chain.
78 $ see if in range.
79 if dw_word dword(dw) >= i & dw_word dword(dw) <= j then
80 $ it is. drop all assigned registers.
81 k = dw_freg dword(dw); $ point to first.
82 if dr_reg dreg(k) then $ must free this one.
83 if rl_perm reglis(dr_reg dreg(k)) then
84 omreg = dr_reg dreg(k); $ get reg number
85 dr_reg dreg(k) = 0; $ temporarily free.
86 getvar(k, gd_intoreg, omode, omreg, omoff);
87 rl_perm reglis(omreg) = yes; $ show perm
88 else $ not permanent, actually free.
89 reglis(dr_reg dreg(k)) = 0; $ free reg.
90 dr_reg dreg(k) = 0; $ show not in reg.
91 end if;
92 end if;
93 end if;
94
95 dw = dw_next dword(dw); $ get next word.
96 end while;
97
98 $ drop input and output.
99 drop(outr); $ drop output.
100 if op = ao_mvw then drop(inr); end if; $ drop input.
101
102 end subr emitlong;
1 .=member emitsub
2 subr emitsub; $ emit subroutine/function call.
3 $ this routine emits the operations needed to call a subroutine
4 $ or function. the routine name is located and any needed
5 $ housekeeping is done. then the parameter list is generated.
6 size reg(ps); $ dummy register.
7 size i(ps), j(ws), k(ps); $ temporaries.
8 size hcode(ws/2); $ hash code for base block.
9 size mreg(ps); $ machine register.
10 size moff(mosize); $ machine offset.
11 size mop(ps); $ machine operation.
12 size mode(ps); $ address mode.
13 size t(ws); $ temporary if address goes negative.
vaxa 250 size moff1(mosize); $ temporary machine offset.
dsu 107 .+t32h size moff2(mosize);
14
15 .+trace. $ handle special trace actions.
16 if trace_any then $ if tracing.
17 textl(' * call ') textl(dopsname)
18 if trace_a then tintl(' np', dopnx) end if;
19 endl
20 end if;
21
22 $ see if this 'routine' to be called is actually a
23 $ special flag to turn on traces.
24 if .ch. 3, dopsname = 1r= then $ it is special.
25 if .ch. 1, dopsname = 1rt & .ch. 2, dopsname = 1rr then
26 dopsname = .s. 4, .len. dopsname-3, dopsname;
27 $ set new trace values.
28 trace_d = ('d' .in. dopsname) > 0;
29 trace_o = ('o' .in. dopsname) > 0;
30 trace_a = ('a' .in. dopsname) > 0;
31 trace_r = ('r' .in. dopsname) > 0;
32 trace_c = ('c' .in. dopsname) > 0;
33 trace_l = ('l' .in. dopsname) > 0;
34 trace_v = ('v' .in. dopsname) > 0;
35
36 trace_any = trace_d!trace_o!trace_a!trace_r!trace_c!
37 trace_l!trace_v; $ set any trace info.
38
39 return; $ end of dummy call.
40 end if;
41 end if;
42 ..trace
43
44 $ if name longer than six characters, truncate to length six
45 $ for possible output in generated code file.
vaxa 251 .+t10 if (.len. dopsname > 6) .len. dopsname = 6;
47
48 $ must scan the contents of all permanently-assigned
dsk 309 $ registers. if the register has live data in it and the
50 $ data is a global variable, then it must be saved across
51 $ the call because the called routine may modify it.
52 $ the -hold- flag is set to those those registers that
53 $ contain such global information so that they can be
54 $ reloaded at the completion of the call.
55
56 $ this is only done when the -calldropgl- flag is set.
dsk 310 do i = rlo to rhi; $ search all registers.
rka 10 if (rl_subtype reglis(i) ^= rt_need &
rka 11 rl_subtype reglis(i) ^= rt_live) cont do;
dsk 311 if di_mblk ditem(dr_item dreg(rl_content reglis(i))) >=
dsk 312 bl_global then $ this is a special case.
dsk 313 if calldropgl then $ go ahead.
dsk 314 if rl_subtype reglis(i) = rt_live then
dsk 315 store(i, rl_content reglis(i))
dsk 316 end if;
dsk 317
dsk 318 if rl_perm reglis(i) then $ if permanent.
dsk 319 rl_hold reglis(i) = yes; $ show special.
dsk 320 else $ not permanent.
dsk 321 dr_reg dreg(rl_content reglis(i)) = 0; $ show not.
dsk 322 reglis(i) = 0; $ free register.
dsk 323 end if;
dsk 324
dsk 325 else $ dont hold.
dsk 326 rl_hold reglis(i) = no; $ show not special.
dsk 327 end if;
dsk 328 else $ not a global.
dsk 329 rl_hold reglis(i) = no; $ show not special.
dsk 330 end if;
dsk 331 end do;
74
75 $ process arguments to calls, if any.
dsk 332 hcode = 0;
76 if dopnx then $ arguments exist.
77
78 $ make a pass over the arguments to build the parameter
79 $ list. in addition, if any arguments are live in registers
80 $ those registers must be stored. also, if the item is
81 $ in a permanent register, it must be flagged to be reloaded
82 $ after the call is complete.
84 do i = 1 to dopnx; $ scan all parameters.
85 reg = dopxr(i); $ get parameter -dreg- value.
86 countup(pdlistp, pdlistdim, 'pdlist'); $ get space.
87 pdlist(pdlistp) = 0; $ clear parameter list entry.
88
89 $ if this parametet does not have a fixed address,
90 $ will have to move it into the parm. list at run-time.
91 $ in this pass over the parameters it is ignored
92 $ because only known addresses are compiled into the
93 $ parameter list.
94 if di_addrreg ditem(dr_item dreg(reg)) = 0 &
95 isind(reg) = no then $ normal address.
96 $ can put this address into the parm list.
97 $ check for the case where an address has not been
98 $ assigned and assign an address to it.
99 if di_mblk ditem(dr_item dreg(reg)) = 0 then
100 getdesc(reg, gd_addr, j, mreg, moff); $ get value
101 rl_hold reglis(mreg) = no; $ release.
102 end if;
103
104 pd_block pdlist(pdlistp) = $ set machine block.
105 di_mblk ditem(dr_item dreg(reg));
106 pd_madr pdlist(pdlistp) = $ machine address.
107 dw_madr dword(dr_word dreg(reg));
108 hcode = hcode .ex. $ hash in machine address.
109 dw_madr dword(dr_word dreg(reg));
110 end if;
111
112 $ check for the case where the parameter is in a
113 $ register.
114 if dr_reg dreg(reg).ne. 0 & isscon(reg)=no then $ it is
115 $ if live, must store.
116 if rl_subtype reglis(dr_reg dreg(reg)) = rt_live then
117 store(dr_reg dreg(reg), reg); $ do the store.
118 end if;
119
120 $ if -callnodrop- is set, this is end of
121 $ processing for this variable.
122 if (callnodrop) cont do;
123
124 $ see how to drop.
125 if rl_perm reglis(dr_reg dreg(reg)) then $ perm.
126 rl_hold reglis(dr_reg dreg(reg)) = isvar(reg);
127 else $ must do normal clear if variable.
128 if isvar(reg) then $ do normal clear.
129 clear(reg); $ clear all fields.
130 end if;
131 end if;
132 end if;
133 end do;
vaxa 252 .+t32 end if;
134
135
136 $ allocate space in base block for the parameter list.
137 $ if base block address would go negative, increment it.
138 if (baselastaddr=1) baselastaddr=2;
139 baseprobe(j, hcode, dopnx, bt_plist, $ get space for p-list.
140 pdlistp - (dopnx-1), ar_plist, pdlistp);
141 moff = 0;
vaxa 253 .+t10 t = bb_addr baseblock(j) - 2;
vaxa 254 .+t32 t = bb_addr baseblock(j) - 1;
143 if (t<0) t = mneg(iabs(t));
144 mbo_off moff = t; $ set offset.
145 mbo_blk moff = bl_base;
vaxa 255
vaxa 256
vaxa 257 .+t32 if dopnx then $ if parameters.
146
147 $ make a pass over the parameters to move any needed
148 $ values into the parameter list at run-time.
149 do i = 1 to dopnx; $ loop over all parameters.
150 reg = dopxr(i); $ get -dreg- number.
151 if di_addrreg ditem(dr_item dreg(reg)) then $ else live.
152 $ see if last word is in register. else must
153 $ get last word into a register.
154 if (dw_word dword(dr_word dreg(reg))^=nwords(reg))
155 call aermey(20); $ this is a fatal error.
156 if dw_madr dword(dr_word dreg(reg)) = 1 then $ last.
vaxa 258 moff1 = moff; mbo_off moff1 = mbo_off moff1 + i;
157 emop(mo_stw, di_addrreg ditem(dr_item dreg(reg)),
vaxa 259 am_mem, sparereg, moff1);
159 else $ use as temporary.
160 j = dw_madr dword(dr_word dreg(reg))-1;
161 if (j<0) j = mneg(-j);
vaxa 260 moff1 = 0; mbo_off moff1 = j;
vaxa 261 emop(mo_lda, sparereg, am_rel,
vaxa 262 di_addrreg ditem(dr_item dreg(reg)), moff1);
vaxa 263 moff1 = moff; mbo_off moff1 = mbo_off moff1 + i;
164 emop(mo_stw, sparereg, am_mem,
vaxa 264 sparereg, moff1);
166 end if;
167 elseif isind(reg) then $ move in address.
vaxa 265 .+t10 emop(mo_ldw, sparereg, am_rel, parmreg,
vaxa 266 .+t10 di_anum ditem(dr_item dreg(reg)) - 1);
vaxa 267 .+t32 moff1 = 0; mbo_off moff1 =
vaxa 268 .+t32 di_anum ditem(dr_item dreg(reg));
vaxa 269 .+t32 emop(mo_ldw, sparereg, am_rel, parmreg, moff1);
vaxa 270 moff1 = moff; mbo_off moff1 = mbo_off moff1 + i;
vaxa 271 emop(mo_stw, sparereg, am_mem, sparereg, moff1);
dsu 108 .+t32h.
dsu 109 elseif nsheap_this &
dsu 110 (nsheap_blk = di_mblk ditem(dr_item dreg(reg))) then
dsu 111 .s. 9, 3, ocs = 'sha';
dsu 112 put ocsfile ,column(17);
dsu 113 getdesc(reg, gd_addr, j, mreg, moff2);
dsu 114 call emitea(am_mem, sparereg, moff2);
dsu 115 put ocsfile ,',';
dsu 116 moff1 = moff;
dsu 117 mbo_off moff1 = mbo_off moff1 + i;
dsu 118 call emitea(am_mem, sparereg, moff1); $ emit base blk
dsu 119 call ocsput(0,0);
dsu 120 ..t32h
171 end if;
172 kill(reg); $ last usage of parameter.
173 end do;
174
175 $ load parameter list address into r1.
176 $ emop(mo_lda, r1, am_mem, sparereg, moff+1);
177 end if;
178
179 $ emit call.
vaxa 272 .+t10 if (.len. dopsname > 6) .len. dopsname = 6;
vaxa 273 .+t32 if (.len. dopsname > 15) .len. dopsname = 15;
181 .s. 9, 3, ocs = 'cal';
182 put ocsfile ,column(17)
183 :dopsname,a
184 ,',' :dopnx,i ,',' ;
185 $ if arguments, put out ea of param list, else put zero.
vaxa 274 .+t10 if dopnx then $ if arguments.
vaxa 275 .+t10 call emitea(am_mem, sparereg, moff+1);
vaxa 276 .+t32 call emitea(am_mem, sparereg, moff);
vaxa 277 .+t10 else put ocsfile ,'0'; end if;
189 call ocsput(0, 0); $ put code line.
190
dst 77 .+enp.
dst 78 if enpopt then $ if tracking active procs, indicate
dst 79 $ back in 'current' procedure.
dst 80 put ocsfile ,column(9) ,'enp' ,column(17)
dst 81 :currsubname,a ,',#' :(enpnum+enporg),i;
dst 82 call ocsput(0,0);
dst 83 end if;
dst 84 ..enp
191 $ reload any permanent registers marked for reload.
192 do i = rlo to rhi; $ search all registers.
193 if rl_perm reglis(i) & rl_hold reglis(i) then $ got one.
194 if rl_type reglis(i) = rt_permlive ! $ check for data.
195 rl_type reglis(i) = rt_perm then $ this is data.
196 getdesc(rl_content reglis(i), gd_addr, mode, mreg, moff);
197 $ get operation to use for load.
198 emop(mo_ldw, i, mode, mreg, moff);
199 clear(rl_content reglis(i)); $ clear -dreg-.
200 rl_subtype reglis(i) = rt_need; $ not live.
201 end if;
202 end if;
203 end do;
204
205
206 callnodrop = no; calldropgl = no; $ set default state of flags.
207
208 end subr emitsub;
1 .=member emitsf
2 subr emitsfld(op, inr, target); $ emit field store operation.
3 $ this routine emits code for field store operations.
4 size op(ps); $ operation code.
5 size inr(ps); $ input register to store.
6 size target(ps); $ target register.
7 size mode(ps); $ machine mode of target.
8 size mreg(ps); $ machine register of target.
9 size moff(mosize); $ machine offset of target.
10 size mreg1(ps); $ machine register for input.
11 size mop(ps); $ machine operation to emit.
12
13 $ get input to a register.
14 getvar(inr, gd_reg, mode, mreg1, moff);
15
16 mreg = dr_reg dreg(target);
dsj 60 if op = ao_spr then $ if spr.
18 if lastdrop(target) then $ if last use of target.
19 if mreg then
20 if rl_type reglis(mreg) = rt_need then
21 reglis(mreg) = 0;
22 dr_reg dreg(target) = 0;
23 mreg = 0;
24 end if;
25 end if;
26 end if;
27 if (mreg) rl_subtype reglis(mreg) = rt_live;
28 end if;
29
30 $ now get ea for target.
31 getdesc(target, gd_use, mode, mreg, moff);
32
33 $ now get machine operation to issue. handle special case
34 $ of halfword ops for spr.
35 mop = mo_stf; $ assume was stf_op.
36 if op = ao_spr then $ it was not.
37 mop = mo_spr; $ set for normal case.
vaxa 278 .+t10.
38 if emopparm2 = mws/2 then $ could be halfword.
39 if emopparm1 = 0 then $ is right half.
40 mop = mo_str; $ set to store right.
41 elseif emopparm1 = mws/2 then $ is left half.
42 mop = mo_stl; $ store left half.
43 end if;
44 end if;
vaxa 279 ..t10
45 end if;
46
47 $ now emit operation.
48 emop(mop, mreg1, mode, mreg, moff);
49
50 drop(inr); drop(target); $ drop register.
51
52 end subr emitsfld;
1 .=member emitun
2 subr emitun(iop, outr, inr); $ emit unary operation.
3 $ this routine emits unary operations. it is highly table-
4 $ driven and handles special cases depending on mahchine
5 $ register status.
6 size iop(ps); $ internal operation code.
7 size outr(ps); $ output operand.
8 size inr(ps); $ input operand.
9 size imode(ps); $ input one addressing mode
10 size imoff(mosize); $ input addressing mode
11 size imreg(ps); $ input machine register
12 size omreg(ps); $ output machine register
13 size omode(ps); $ output mode.
14 size omoff(mosize); $ output offset.
15 size mop(ps); $ machine operation.
16 size i(ps); $ index.
17
18 size eutab(ps); $ table to drive routine.
19 size euotab(ps); dims euotab(ao_luo-ao_fuo+1);
20 +* eutab(i) = euotab(i-(ao_fuo-1)) **
21 data
22 eutab(ao_bfb) = mo_bfb:
23 eutab(ao_bnb) = mo_bnb:
24 eutab(ao_bno) = mo_bno:
25 eutab(ao_iab) = mo_iab:
26 eutab(ao_iao) = mo_iao:
27 eutab(ao_ico) = mo_ico:
dsj 61 eutab(ao_ifr) = mo_ifr:
28 eutab(ao_iso) = mo_iso:
29 eutab(ao_rab) = mo_rab:
30 eutab(ao_rco) = mo_rco:
dsj 62 eutab(ao_rfi) = mo_rfi:
dsj 63 eutab(ao_rtr) = mo_rtr:
31 eutab(ao_ldf) = mo_ldf:
32 eutab(ao_lpr) = mo_lpr;
33
34 macdrop(eutab)
35
36 size mreg(ps); $ machine register.
37 size ildr(1); $ 'last usage of input'
38 size op(ps); $ operation code within routine.
39 size t(ps); $ dummy variable.
40
41 .+trace. $ generate trace info.
42 if trace_a then $ this trace wanted.
43 tintl('unop, op',iop) tintl('out',outr) tintl('in',inr) endl
44 end if;
45 ..trace
46
47 $ initialize for emission.
48 op = iop - (ao_fuo-1); $ get operation code for local use.
49 i = gd_use;
50 if (isscon(inr) & dr_reg dreg(inr)=0) i = gd_addr;
51 getdesc(inr, i, imode, imreg, imoff); $ get input.
52 getdesc(outr, gd_use, omode, omreg, omoff); $ get input into reg
53
54 $ get last usage value for variable.
55 ildr = lastdrop(inr); $ get last usage counts.
56
57 $ the next step is to see if the input is not in a register
58 $ but this is not the last use. in this case, bring into
59 $ register, if one is available.
60
61 if ildr = no & imode^=am_reg & isinif = no then $ check for -i
62 $ first, get a register of the appropriate type.
63 getreg(mreg, rt_need); $ get real or general.
64
65 if mreg then $ one is available.
66 imreg = mreg; $ show register that input will be in.
67 getvar(inr, gd_intoreg, imode, imreg, imoff); $ load.
68
69 if outr = inr then $ must update -out- status too.
70 omreg = mreg; omode = am_reg;
71 end if;
72 end if;
73 end if;
74
75 $ must get a register to use as the output of the
76 $ operation. this can come from either a register permanently
77 $ assigned to the output, from the input if register status
78 $ indicates such, or from a new register. upon exit from
79 $ the following 'maybe' loop, -omreg- contains the output
80 $ register to use.
81 until yes; $ get a register.
82 if (omode=am_reg) quit until; $ if have it, quit.
83 omreg = imreg; $ see if safe to use input register.
84 if (imode=am_reg & ildr & rl_perm reglis(imreg)=no)
85 quit until;
86
87 $ otherwise, get register if available.
88
89 $ see if must get a new register.
90 i = rt_need; $ assume dont have to.
91 if (rl_type reglis(imreg) > rt_need) i = rt_live; $ do.
92 if (imode^=am_reg) i = rt_live; $ cannot use if not in reg.
93 getreg(omreg, i); $ get register for output.
94 if (omreg) quit until; $ if got one, exit.
95 omreg = imreg; $ else use input after all.
96 end until;
97
98 $ see if input register used was input register.
99 if omreg = imreg then $ it was. must drop and/or store.
100 if rl_type reglis(imreg)=rt_live & isvar(inr) then
101 store(imreg, inr);
102 end if;
103 dr_reg dreg(inr) = 0; $ show no longer in register.
104 end if;
105
106 $ get machine operation and check for halfword case in lpr.
107 mop = euotab(op); $ get default operation.
vaxa 280 .+t10.
108 if mop = mo_lpr & emopparm2 = mws/2 then $ could be special.
109 if emopparm1 = 0 then $ is right half.
110 mop = mo_ldr; $ load right half.
111 elseif emopparm1 = mws/2 then $ is left half.
112 mop = mo_ldl; $ load left half.
113 end if;
114 end if;
vaxa 281 ..t10
115
116 emop(mop, omreg, imode, imreg, imoff); $ emit op.
117
118 $ set status of output register.
119 rl_content reglis(omreg) = outr; $ show it contains output.
120 rl_subtype reglis(omreg) = rt_live; $ show live.
121 dr_reg dreg(outr) = omreg; $ point -dreg- to -mreg-.
122
123 drop(inr); drop(outr); $ drop operands.
124
125
126 end subr emitun;
1 .=member branchr
2 subr branchr(bmask, mreg, label); $ handle branches.
3 $ process branch operations.
4 size bmask(4); $ input branch mask.
5 size label(ps); $ label number to branch to.
6 size fixptr(ps); $ pointer to fixup table.
7 size mreg(ps); $ machine register.
8 size labent(lablistsz); $ temporary
9 size bops(.sds.3); dims bops(8);
10 +* bop(bm, op) = bops(bm+1) = op **
11
12 data
vaxa 282 .+t10 bop(bm_all , 'jmp'):
vaxa 283 .+t32 bop(bm_all , 'jma'):
14 bop(bm_neg , 'jlt'):
15 bop(bm_pos , 'jgt'):
16 bop(bm_zer , 'jeq'):
17 bop(binv(bm_all) , 'jmn'):
18 bop(binv(bm_neg) , 'jge'):
19 bop(binv(bm_pos) , 'jle'):
20 bop(binv(bm_zer) , 'jne');
21 macdrop(bop)
22
23 .+trace. $ generate trace code.
24 if trace_a then $ print trace info.
25 tintl('branchop, mask', bmask) tintl('label', label) endl
26 end if;
27 ..trace
28
29 put ocsfile ,column(9)
30 :bops(bmask+1),a(3), column(17)
dss 52 ,'r' :mreg-1,i
dss 53 ,',l'
dss 54 :(label+lablorg),i(labcol, labcol);
32 call ocsput(0, 0);
33 end subr branchr;
1 .=member getdesc
2 subr getdescr(var, type, mode, reg, off); $ get register descr.
3 $ this routine is passed a dummy register pointer in
4 $ variable -var- and a type in -type-.
5 size var(ps); $ variable to process.
6 size type(ps); $ type of call.
7 size mode(ps); $ indirect reference flag.
8 size reg(ps); $ machine register.
9 size off(mosize); $ machine offset.
10 size hcode(mws); $ hash code for temporary allocation.
11 size i(ps), j(ps); $ temporary pointers.
12 size blk(ps), adr(ws); $ block and address.
13
14 $ first, unless the type is -gd_addr-, in which case a value
15 $ in a register is not wanted, if a register contains the value,
16 $ return it.
17
18 if dr_reg dreg(var) then $ check for special type.
19 if type ^= gd_addr then $ return value in reg.
20 reg = dr_reg dreg(var); $ set register.
21 mode = am_reg; $ show not indirect.
22 adr = 0; blk = 0;
23 go to ret; $ return value.
24 end if;
25 end if;
26
27 $ if address of value is in register, use it as indirect.
28 if di_addrreg ditem(dr_item dreg(var)) then $ have this case.
29 reg = di_addrreg ditem(dr_item dreg(var)); $ set register.
30 adr = (dw_madr dword(dr_word dreg(var)))-1; $ set offset.
31 blk = 0;
32 mode = am_rel; $ set to use indirectly.
33 go to ret;
34 end if;
35
36 $ handle case where variable is parameter to routine.
37 if isind(var) then $ is an argument.
38 if (dr_word dreg(var) ^= di_lword ditem(dr_item dreg(var)))
39 call aermey(23); $ this is a fatal error.
40 $ get a base register for the address.
vaxa 284 .+t10 adr = di_anum ditem(dr_item dreg(var))-1; blk = 0;
vaxa 285 .+t32 adr = di_anum ditem(dr_item dreg(var)); blk = 0;
42 reg = parmreg; mode = am_reli; blk = 0;
43 go to ret;
44 end if;
45
46 if isscon(var) & type^=gd_addr then $ if short constant
47 off = 0; adr = conval(var); blk = bl_imm;
48 reg = sparereg;
49 mode = am_mem;
50 go to ret;
51 end if;
52
53 $ if address has not been assigned, this must be a
54 $ constant that resides in the base block.
55 if di_mblk ditem(dr_item dreg(var)) = 0 then $ not assigned.
56 if (di_baseblk ditem(dr_item dreg(var)) = no ! ismw(var))
57 call aermey(24); $ this is a fatal error.
58 i = di_chain ditem(dr_item dreg(var)); $ baseblock pointer.
59 if (bb_type baseblock(i) ^= bt_const) call aermey(24);
60
61 $ must allocate an address to the constant.
62 bb_addr baseblock(i) = baselastaddr; $ set address.
63 di_mblk ditem(dr_item dreg(var)) = bl_base; $ set block.
64 dw_madr dword(dr_word dreg(var)) = baselastaddr; $ address.
65 baselastaddr = baselastaddr + 1; $ step up adddess.
66
67 $ put entry on chain.
68 if baselast then $ is not first.
69 bb_chain baseblock(baselast) = i; $ set onto chain.
70 else $ this is first entry.
71 basefirst = i; $ set to chain head.
72 end if;
73
74 baselast = i; $ show this is last in chain.
75 end if;
76
77 mode = am_mem; $ in memory.
78 reg = sparereg; $ constant pseudo-reg.
79 blk = di_mblk ditem(dr_item dreg(var));
80 adr = dw_madr dword(dr_word dreg(var)) - 1;
81
82 /ret/
83 if (adr<0) adr = mneg(iabs(adr));
84 off = 0; mbo_blk off = blk; mbo_off off = adr;
85 .+trace. $ compile trace code.
86 if trace_r then $ if tracing machine registers
87 tintl('getdesc var', var) tintl('type', type)
88 textl(' --> ') tintl('reg', reg)
89 tintl('mode',mode) tintl('blk', blk)
90 textl('off ')
91 if .f. mps, 1, adr then $ if negative offset
92 textl('-') intl(mneg(adr))
93 else
94 intl(adr)
95 end if;
96 endl end if;
97 ..trace
98
99 rl_hold reglis(reg) = yes; $ indicate register needed soon.
100 end subr getdescr;
101 subr getvarr(var, type, mode, mreg, moff); $ get variable.
1 .=member getvar
2 $ this routine is called to reference a dummy register. it
3 $ can be used to load a dummy register into a machine register,
4 $ to get the address of a dummy register's variable, or to
5 $ get a dummy register into any addressable mode. the type is
6 $ used to determine parameters to use to determine what
7 $ operations to issue. -mode-, -mreg-, and -moff- are set as
8 $ in -getdescr-.
9 size var(ps); $ dummy register.
10 size type(ps); $ type of call.
11 size mode(ps); $ indirect flag.
12 size mreg(ps); $ machine register to return.
13 size moff(mosize); $ machine offset.
14 size i(ps), j(ps); $ temporaries.
15 size mreg1(ps); $ temporary machine register.
16 size mode1(ps); $ temporary machine indirect flag.
17 size moff1(mosize); $ temporary machine offset.
18 size mop(ps); $ machine operation to issue.
19
20 $ table for actions depending on type.
21 size gvtab(2); $ define table.
22 dims gvtab(num_gd); $ number of types.
23
24 $ macros for bits in table.
25 +* gt_forcr = .f. 1, 1, ** $ force into any register.
26 +* gt_forci = .f. 2, 1, ** $ force into specific register.
27
28 +* gvt(i, fr, fi) = $ macro to define table.
29 gvtab(i) = fi*2+fr **
30
31 data $ initialize type table.
32 $ type fr fi
33 $ ---- -- --
34 gvt(gd_addr, no, no):
35 gvt(gd_use, no, no):
36 gvt(gd_reg, yes, no):
37 gvt(gd_intoreg, yes, yes):
38 gvt(gd_inregnu, yes, yes);
39
40 macdrop(gvt)
41
42 $ first, get descriptor for variable.
43 getdesc(var, type, mode1, mreg1, moff1);
44 mode = mode1; moff = moff1; $ set user return values.
45
46 $ see if the variable is in a register.
47 if mode1 = am_reg then $ it is in a register.
48 $ if must force into a
49 $ specific register.
50 if gt_forci gvtab(type) then
51
52 $ if in the desired register, return.
53 if (mreg1 = mreg) return;
54
55 mrcopy(mreg, mreg1); $ copy reg.
56
57 $ unless type is not to update status, do the
58 $ status update.
59 if type ^= gd_inregnu then $ must do update.
60 $ if old was permanent, build new form.
61 if rl_perm reglis(mreg1) then $ it is.
62$ call gfdreg(mreg, var); $ get new -dreg-.
63 call aermey(34);
64 else $ can do simple update.
65 reglis(mreg) = reglis(mreg1); $ copy status.
66 reglis(mreg1) = 0; $ clear old status.
67 dr_reg dreg(var) = mreg; $ show in register.
68 end if;
69 end if;
70
71 else $ it is ok as is.
72 mreg = mreg1; $ copy register given.
73 end if;
74
75
76 else $ dummy register is not in a machine register.
77 $ see if must load to a register.
78 if gt_forcr gvtab(type) then $ must get into register.
79 mode = am_reg; $ show will be in register.
80
81 $ unless are going to force into a particular
82 $ register, must get a register.
83 if gt_forci gvtab(type) = no then $ must get a register.
84 getreg(mreg, rt_live); $ get register.
85 end if;
86
87 $ if the output register is not real and the input
88 $ is a short constant, can bring it in without a
89 $ storage reference.
90 if isscon(var) & conval(var)=0 then
91 mrclear(mreg); $ zeroize reg.
92
93 else $ not constant.
94 emop(mo_ldw, mreg, mode1, mreg1, moff1);
95 end if;
96
97 $ unless this was a no-update call, update status.
98 if type ^= gd_inregnu then $ must update.
99 rl_content reglis(mreg) = var; $ show owner.
100 dr_reg dreg(var) = mreg; $ show which register.
101 rl_type reglis(mreg) = rt_need; $ reduce type.
102 end if;
103
104 else $ it is ok as is.
105 mreg = mreg1; $ copy register given.
106 end if;
107 end if;
108
109 .+trace. $ emit trace code.
110 if trace_r then $ print trace info.
111 tintl('getvar', var) tintl('mreg', mreg) endl
112 end if;
113 ..trace
114
115 rl_hold reglis(mreg) = yes; $ hold gotten register.
116
117 end subr getvarr;
1 .=member getreg
2 subr getregr(type); $ get a register.
3 $ thus routine is the register allocator for the general
4 $ purpose registers. it returns the register number via the
5 $ global variable -gotreg-.
6 size type(ps); $ register type.
7 size lo(ps), hi(ps); $ search limits.
8 size i(ps); $ loop variable.
9 size blru(ps); $ best lru value so far.
10 size btype(ps); $ best type so far.
11 size reg(ps); $ dummy register pointer.
12
13 $ select the register bounds to search.
14 lo = nextgfree; hi = rhi; $ set high bounds for general.
15
16 gotreg = 0; $ initially dont have a register.
17 blru = 4b'1000'; $ set to worst lru value.
18 btype = type; $ set to worst allowable type.
19 if (btype = rt_live) btype = rt_liveaddr; $ ensure -live- gets.
20
21 $ scan for best register to use.
vaxa 286 .+t10 do i = nextgfree to rhi; $ scan all registers.
vaxa 287 .+t32 do i = rlo to nextgfree; $ scan all registers.
23 if (rl_hold reglis(i)) cont do; $ skip if held.
24 if (rl_addrhold reglis(i)) cont do; $ skip if held.
25 if (rl_type reglis(i) > btype) cont do; $ worse type.
26 if (rl_type reglis(i) = btype & rl_usevalue reglis(i) > blru)
27 cont do; $ worse lru for same type.
28
29 $ else, this is best so far.
30 gotreg = i; $ set to use this register.
31 btype = rl_type reglis(i); $ set best type so far.
32 blru = rl_usevalue reglis(i); $ set best lru value so far.
33 end do;
34
35
36 if gotreg then $ found a register.
37 $ select method of dropping this register by its prior type.
38 go to dtyp(btype) in rt_dead to rt_liveaddr;
39
40 /dtyp(rt_live)/ $ drop live register.
41 store(gotreg, rl_content reglis(gotreg)); $ store it.
42 $ status is -need- so fall through.
43
44 /dtyp(rt_need)/ $ value in register.
45 dr_reg dreg(rl_content reglis(gotreg)) = 0; $ not in reg.
46 go to dtyp(rt_dead); $ register is dead.
47
48 /dtyp(rt_address)/ $ address is in register.
49 di_addrreg ditem(rl_content reglis(gotreg)) = 0;
50 go to dtyp(rt_dead); $ type is dead.
51
52 /dtyp(rt_liveaddr)/ $ live address in register.
53 store(gotreg, dw_freg dword(di_lword ditem(rl_content
54 reglis(gotreg)))); $ store into primary register.
55 $ status is -dead- so fall through.
56
57 /dtyp(rt_dead)/ $ register can be used.
58 reglis(gotreg) = 0; $ clear register status.
59 rl_type reglis(gotreg) = type; $ set to desired type.
60 rl_hold reglis(gotreg) = yes; $ hold gotten register.
61
62
63 end if;
64
65
66 .+trace.
67 if trace_r then $ print register info.
68 tintl('gotreg', gotreg) tintl('type', type) endl
69 end if;
70 ..trace
71
72 end subr getregr;
1 .=member getpair
2 .+eab.
3 subr getrpair(use1, use2); $ get a register pair.
4 $ this routine is called by the -getregpair- macro to get a
5 $ pair of registers. it first checks to see if a pair exists
6 $ of which neither register is on hold. the best such pair is
7 $ picked and a pair containing one of the 'ok-to-use' registers
8 $ is weigthed more heavily. if no normal registers are a
9 $ available, r0-r1 and r14-r15 are tried, in that order.
10 $ the lowest register of the gotten pair is returned via
11 $ global variable -gotrpair-.
12 size use1(ps), use2(ps); $ registers that can be used.
13 size i(ps), j(ps); $ temporaries.
14 size btype(ws); $ best type so far.
15 size blru(ws); $ best lru value so far.
16 size type(ws); $ type of this pair.
17 size lru(ws); $ lru value of this pair.
18 size reg(ps); $ temporary register.
19
20 $ first, scan all registers to find the best available
21 $ pair. note that can use a register which has -addrhold-
22 $ set as long as it does not also have -hold- set because
23 $ it can be moved to another register.
24 btype = rt_liveaddr*2; $ set to worst type.
25 blru = 4b'1000'*2; $ set to worst lru.
26 gotrpair = 0; $ show didn't find any yet.
27 $ rhi was r10, not r12 (check).
28 do i = rlo to rhi by 2; $ scan all pairs.
29 $ set combined values for both registers.
30 type = 0; lru = 0; $ set counters to zero.
31 do j = i to i+1; $ scan both registers in pair.
32 if (rl_addrhold reglis(j)) cont do i; $ if perm.
33 if (rl_perm reglis(j)) cont do i; $ or if perm.
34 if j = use1 ! j = use2 then $ can use this one.
35 type = type-1; lru = lru-1; $ make this seem better.
36 else $ just add types and lru value.
37 if (rl_hold reglis(j)) cont do i; $ skip if held.
38 type = type+rl_type reglis(j); $ add type.
39 lru = lru+rl_usevalue reglis(j); $ add lru.
40 end if;
41 end do j;
42
43 $ that have the combined type and useage value of
44 $ the pair, if this is worse than the best so far, skip.
45 if (type > btype) cont do; $ worse type.
46 if (lru > blru) cont do; $ worse lru value.
47 gotrpair = i; $ show register obtained.
48 btype = type; blru = lru; $ set new 'best' values.
49 end do i;
50
51 $ see if got a register.
52 if gotrpair = 0 then $ didn't.. try r0 and r14.
53 call aermey(25);
54 end if;
55 $ [ds 11 apr what does end if below close...]
56 end if;
57
58
59 $ scan both registers and drop them as needed.
60 do j = gotrpair to gotrpair+1; $ scan over both in pair.
61 $ hold both registers.
62 rl_hold reglis(gotrpair)=yes; rl_hold reglis(gotrpair+1)=yes;
63 if j ^= use1 & j ^= use2 & j ^= r1 then $ must drop.
64 go to drp(rl_type reglis(j)) in rt_dead to rt_liveaddr;
65 else $ cannot drop register.
66 cont do; $ go around loop again.
67 end if;
68
69 /drp(rt_need)/ /drp(rt_address)/ /drp(rt_live)/
70 /drp(rt_liveaddr)/ $ most needed types.
71 $ in this case try to get a another register of the desired
72 $ type and do a move.
73 getreg(gotreg, rl_type reglis(j)); $ try to get one.
74 if gotreg then $ got one.
75 mrcopy(gotreg, j); $ copy reg.
76 reglis(gotreg) = reglis(j); $ move status.
77 rl_hold reglis(gotreg) = no; $ but clear hold.
78 end if;
79
80 $ if type is address update all forms or otherwise
81 $ just one.
82 if rl_type reglis(j) = rt_address ! $ update all forms.
83 rl_type reglis(j) = rt_liveaddr then $ go ahead.
84 di_addrreg ditem(rl_content reglis(j)) = gotreg;
85 else $ data -- just clear one form.
86 dr_reg dreg(rl_content reglis(j)) = gotreg; $ update.
87 end if;
88
89 /drp(rt_dead)/ $ need not drop anything.
90 reglis(j) = 0; $ so just clear status.
91 cont do;
92
93 end do j;
94
95 $ just clear to set final status.
96 rl_hold reglis(gotrpair) = yes; $ hold first register.
97 rl_hold reglis(gotrpair+1) = yes; $ hold second.
98
99 .+trace.
100 if trace_r then $ print trace info.
101 tintl('getregpair, reg', gotrpair) tintl('u1', use1)
102 tintl('u2', use2) endl
103 end if;
104 ..trace
105
106 end subr getrpair;
107 ..eab
1 .=member storer
2 subr storer(mreg, reg); $ store a machine register.
3 $ this routine is called to store the contents of a
4 $ machine register in order to free the register. it
5 $ is called for two classes of contents. in the case
6 $ where the register is a live address, it is called to
7 $ move the data pointed to by the register into a
8 $ temporary. in the other cases, the register contains
9 $ data that is simply stored. note that this routine
10 $ may be called by the register allocator and this must
11 $ be carefull which routines it calls.
12 size mreg(ps); $ machine register to store.
13 size reg(ps); $ dummy register to store into.
14 size mreg1(ps); $ machine register for item.
15 size moff1(mosize); $ machine offset for item.
16 size mode1(ps); $ machine mode for item.
17 size t(ws); $ temporary.
18 size i(ps); $ loop variable.
19
20 .+trace. $ print trace code if wanted.
21 if trace_r then $ trace code is wanted.
22 tintl('storer, mreg', mreg) tintl('reg', reg) endl
23 end if;
24 ..trace
25
26 $ check if this is the case of data in a register.
27 if rl_subtype reglis(mreg) ^= rt_liveaddr then $ it is.
28 $ must get the address of the item for which
29 $ this register corresponds. the only time that
30 $ have trouble and cannot do this directly is when
31 $ have a word other than the last of an argument.
32 $ so first handle the simple case.
33 if isind(reg) = no ! dr_word dreg(reg) = $ test for simple.
34 di_lword ditem(dr_item dreg(reg)) !
35 di_addrreg ditem(dr_item dreg(reg)) then $ it is.
36 getdesc(reg, gd_addr, mode1, mreg1, moff1); $ get item.
37 else $ this is the less simple case. in this case,
38 $ will get the address of the last word and then
39 $ subtract enough to point to the desired position.
vaxa 288 .+t10 emop(mo_ldw, sparereg, am_reg, parmreg,
vaxa 289 .+t10 di_anum ditem(dr_item dreg(reg))-1);
vaxa 290 .+t32 moff1=0; mbo_off moff1=di_anum ditem(dr_item dreg(reg));
vaxa 291 .+t32 emop(mo_ldw, sparereg, am_reg, parmreg, moff1);
42 mreg1 = sparereg;
43 mode1 = am_rel;
44 t = dw_madr dword(dr_word dreg(reg)) - 1; $ get desired addre
45 if (t<0) t = mneg(iabs(t)); $ set to valid machine address.
46 moff1 = 0; mbo_off moff1 = t; $ set offset.
47 end if;
48
49 $ get operation to issue.
50 $ do the actual store.
51 emop(mo_stw, mreg, mode1, mreg1, moff1);
52
53 $ set the status of the register to only needed if it
54 $ was live before.
55 if (rl_subtype reglis(mreg) = rt_live) $ update.
56 rl_subtype reglis(mreg) = rt_need;
57
58
59
60 else $ this is a live address in a register.
61 $ first check to see if this is a valid call.
62 if (rl_content reglis(mreg) ^= dr_item dreg(reg))
63 call aermey(27); $ this is an error.
64
65 if (istemp(reg) = no ! ismw(reg) = no) call aermey(28);
66
67 $ get the word offset (-1) that the register is
68 $ pointing to.
dsu 121 t = (dw_word dword(dr_word dreg(reg)) -
dsu 122 dw_madr dword(dr_word dreg(reg))) * mcpw;
71
72 $ if it is not pointing to the first word, must
73 $ adjust it so it does.
74 if t then $ must adjust.
75 if (t<0) t = mneg(iabs(t)); $ set machine address.
76 moff1 = 0; mbo_blk moff1 = bl_imm; $ show immediate.
77 mbo_off moff1 = t; $ set constant to subtract.
78 emop(mo_isu, mreg, am_mem, sparereg, moff1); $ do subtrac
79 end if;
80
81 $ must get the address of the item back.
82 $ first, do another validity check.
83 if (di_baseblk ditem(dr_item dreg(reg))) call aermey(28);
84
85 t = vv_madr voa(di_chain ditem(dr_item dreg(reg))) -
86 nwords(reg); $ get low address -1.
87
88 $ update ditem status to show no longer floating
89 $ address in register.
90 di_addrreg ditem(dr_item dreg(reg)) = 0; $ no register.
91
92 $ update the address fields in each word to reflect
93 $ the core address.
94 i = di_lword ditem(dr_item dreg(reg)); $ point to head.
95 while i; $ while more words in chain.
96 dw_madr dword(i) = t + dw_word dword(i);
97 i = dw_next dword(i); $ step to next.
98 end while;
99
100 $ get address to store into and emit the move.
101 moff1 = 0; mbo_blk moff1 = di_mblk ditem(dr_item dreg(reg));
102 mbo_off moff1 = t; $ set offset of start (left end) of item.
103 emopparm1 = nwords(reg); $ set length to move.
dsu 123 emop(mo_mvx, mreg, am_mem, sparereg, moff1); $ move to storag
105
106 reglis(mreg) = 0; $ show register is dead.
107 end if;
108
109 end subr storer;
1 .=member mover
2 subr mover(outr, inr); $ move from out -dreg- to another.
3 $ this routine is called by the -move_op- macro to move
4 $ data from one -dreg- to another. it handles various
5 $ cases depending on the lastuse status of the output and
6 $ input and whether the output and input are already assigned
7 $ to registers.
8 size outr(ps); $ output dummy register.
9 size inr(ps); $ input dummy register.
10 size omode(ps); $ set if output is indirect (in core)
11 size imode(ps); $ set if input is in core.
12 size ooff(mosize); $ core offset of output if in core.
13 size ioff(mosize); $ core offset of input.
14 size omreg(ps); $ output register (or base if in core).
15 size imreg(ps); $ input register.
16 size oldr(1); $ set if last usage of output.
17 size ildr(1); $ set if last usage of input.
18 size treg(ps); $ temporary machine register.
19 size mop(ps); $ machine operation to issue.
20 size t(ps); $ temporary.
dsj 64 size moff(mosize); $ temporary.
21
22 .+trace.
23 if trace_a then $ print trace code.
24 tintl('move, out', outr) tintl('in', inr) endl
25 end if;
26 ..trace
27
28 if (inr = outr) go to ret; $ this is a no-op.
29
30 $ first, get information about the input.
31 ildr = lastdrop(inr);
32
33 $ get location descriptor for input.
34 getdesc(inr, gd_use, imode, imreg, ioff);
35
36 $ get info. for output.
37 oldr = lastdrop(outr);
38 getdesc(outr, gd_use, omode, omreg, ooff); $ get locator.
39
40 $ check for the case where the output will be used again
41 $ and is not assigned to a register and where the input is
42 $ in a register and this is it's last use. in this case,
43 $ re-assign the register to the output.
44 if omode^=am_reg & oldr = no & ildr & imode=am_reg then $ have t
45 $ if the input register is permanently assigned, it cannot
46 $ be re-assigned to the output. so in that case, this
47 $ proceedure will not be used.
48 if rl_perm reglis(imreg) = no then $ ok to re-assign.
49 if rl_type reglis(imreg)=rt_live & isvar(inr) then
50 store(imreg, inr);
51 end if;
52 rl_content reglis(imreg) = outr; $ set to output.
53 rl_type reglis(imreg) = rt_live; $ set to live.
54 dr_reg dreg(inr) = 0; $ set to null in this case.
55 dr_reg dreg(outr) = imreg; $ set output to old reg.
56 go to ret; $ done in this case.
57 end if;
58 end if;
59
60 if oldr & isscon(inr) & conval(inr)=0 then $ if zero.
61 emop(mo_zew, r0, omode, omreg, ooff); $ issue zew.
62 go to ret;
63 end if;
64
65 $ if input is in storage, then it must be loaded
66 $ into a register.
67 if imode^=am_reg then $ input is in storage.
68 $ must determine whether this register will be
69 $ to the input or the output because the register should
70 $ be of the same mode as the value to which it is being
71 $ assigned. if this is the last usage of the input, then
72 $ the register is assigned to the output and vice versa.
73 if ildr & omode=am_reg then $ last use of input -- assign to
74 $ if output is already assigned to a register, can use
75 $ it. (occurs when output is permanently in register).
76 treg = omreg; $ get output register.
77 else $ last usage of output -- assigned to input.
78 $ note that need not check for output permanently in
79 $ register because know that it is storage.
80 getreg(treg, rt_live); $ get register.
81 end if;
82
83
84 $ do load of input into -treg-.
dsj 65 getvar(inr, gd_inregnu, t, treg, moff); $ load no update.
86
87 $ update register tracking status. if last usage of
88 $ input, assign new register to output.
dsg 10 if ildr then $ assign to output.
90 dr_reg dreg(outr) = treg; $ set in -dreg- info.
91 rl_content reglis(treg) = outr; $ point -mreg- to -dreg-.
92 rl_subtype reglis(treg) = rt_live; $ show live.
93 omreg = treg; omode = am_reg; $ show output in regist
dsg 11 if (oldr) store(omreg, outr);
94 else $ assign to input.
95 dr_reg dreg(inr) = treg; $ set in -dreg- info.
96 rl_content reglis(treg) = inr; $ point -mreg- to -dreg-.
97 rl_subtype reglis(treg) = rt_need;
98 imreg = treg; imode = am_reg; $ show input in registe
99 end if;
100 end if;
101
102
103 $ if this is last usage of output and output is not
104 $ assigned to a register, store into output.
105 if oldr & omode^=am_reg then $ have this case.
106 /storecase/ $ branched to from below.
107 t = rl_type reglis(imreg); $ save old status.
108 store(imreg, outr); $ store into output.
109 rl_subtype reglis(imreg) = t; $ restore register status.
110 go to ret; $ done.
111 end if;
112
113 $ if input is not in a register and this is last usage of
114 $ input, all work has been done so exit.
115 if (ildr & imode^=am_reg) go to ret;
116
117 $ otherwise, must copy input register into output register.
118 rl_hold reglis(imreg) = yes; $ just in case.
119
120 $ must get a register of the correct mode. first
121 $ check if the output is permanently assigned to a register.
122 if omode=am_reg then $ it is -- use that register.
123 treg = omreg; $ set to output register.
124 else $ output not in register.
125 getreg(treg, rt_need); $ get register.
126 end if;
127
128 $ if no register was assigned, go do store case.
129 if (treg = 0) go to storecase; $ go store.
130
131 $ must check which load register operation to issue.
132 $ note that if the assigned input register and the permanently
133 $ assigned output register are of different modes, a load/store
134 $ must be done to do the operation.
135 mrcopy(treg, imreg); $ copy reg.
136
137 $ finally, update register status.
138 rl_subtype reglis(treg) = rt_live; $ set to live.
139 rl_content reglis(treg) = outr; $ point -mreg- to -dreg-.
140 dr_reg dreg(outr) = treg; $ set to register number.
141
142 /ret/ $ common exit point.
143 drop(outr); drop(inr); $ drop operands if last usage.
144 end subr mover;
1 .=member endsubr
2 subr endsubr; $ terminate processing of a routine.
3 $ this routine is called after all code for a routine has been
4 $ emitted. -endsubr- then computes the location of each
5 $ internal machine block in the program csect. it then emits
6 $ data, esd, and rld entries to initialize the base block and
7 $ any other blocks such as the constant block. in addition,
8 $ it calls -outdata- to process data statements for any
9 $ variables encountered.
10 $ routine has been emitted. it then emits
11 $ data entries to initialize the base block and
12 $ any other blocks such as the constant block. in addition,
13 $ it calls -outdata- to process data statements for any
14 $ variables encountered.
15 size i(ps), j(ps), k(ps), t(ps); $ temporaries.
16 size reg(ps); $ dummy register.
17 size len(ps); $ length.
18 size moff(mosize); $ temporary.
19
20
21 $ must put in code for return if return label is
22 $ set.
23 if returnlab then $ need code for return.
24 labdef(returnlab, yes); $ define label.
25
26 $ first, store all live permanent registers.
27 do i = r0 to rhi; $ scan all possible.
28 if rl_type reglis(i) = rt_permlive then $ must store.
29 store(i, rl_content reglis(i)); $ store back.
30 end if;
31 end do;
32
33 $ if function, must load r0 .
34 if subrtype = st_fnct then $ is function.
35 assign(reg, va_fnct); $ get register.
36 lastuse(reg); $ set status.
37 forcezero(reg, ismw(reg)); $ force into r0.
38 end if;
39
40 $ emit return operation.
41 put ocsfile ,column(9) ,'ret' ,column(17)
vaxa 292 .+t10 :currsubname,a;
vaxa 293 .+t32 ;
43 call ocsput(0, 0); $ put code
44 end if;
45
dsq 102 .+t32.
dsq 103 $ output entry mask shifted right by two.
dsq 104 $ set overflow bit if want integer overflow traps.
dsq 105 size maskword(ws);
dsq 106 maskword = .f. r2, rhi-r2+1, regmask;
dsq 107 if iv_opt then $ if want overflow trap
dsq 108 .f. 15-2, 1, maskword = 1; $ raise overflow traps.
dsq 109 end if;
dsu 124 .+t32h.
dsu 125 if nsheap_this then
dsu 126 .f. nsheapreg_w-2, 1, maskword = 1; $ using heap reg
dsu 127 .f. nsheapreg_b-2, 1, maskword = 1; $ using heap reg
dsu 128 end if;
dsu 129 ..t32h
dsq 110 ..t32
46 put ocsfile ,column(9) ,'dec' $ indicate end of code
vaxa 294 .+t10 ,column(17) :currsubname,a;
vaxa 295 .+t32 ,column(17) :currsubname,a ,','
dsq 111 .+t32 :maskword,b(0,4);
48 call ocsput(0, 0); $ put code.
49 trace_c = no; $ do not trace declarations.
50
51 mb_len mba(bl_base) = baselastaddr-1; $ length of base block.
52
vaxa 297 .+t10.
53 $ allocate base block.
54 if baselastaddr>1 then $ if base block.
55 put ocsfile ,column(9) ,'dbw' ,column(17)
56 :mblkname(bl_base),a ,',' $ put block name.
57 :baselastaddr-1,i;
58 call ocsput(0, 0); $ put code.
59 end if;
vaxa 298 ..t10
vaxa 299
vaxa 300
vaxa 301 .+t32.
vaxa 302 $ allocate constant block.
vaxa 303 if mb_len mba(bl_const) then $ there is a constant block.
vaxa 304 put ocsfile ,column(9) ,'dbr' ,column(17)
vaxa 305 :mblknames(bl_const),a ,','
vaxa 306 :(mb_len mba(bl_const))*mcpw,i;
vaxa 307 call ocsput(0, 0); $ write out line.
vaxa 308 end if;
vaxa 309 ..t32
60
61 $ emit constants in constant block.
62 i = mb_chain mba(bl_const); $ get start of constant block.
63 ddblk = bl_const;
dss 55 .s. 17, 3, ocs = mblkname(bl_const); $ indicate constant block.
dss 56 .s. 20, 1, ocs = '+';
65 while i;
66 ddoff = vv_madr voa(i) - (vv_syze voa(i) + (mws-1))/mws;
vaxa 310 .+t32 ddoff = ddoff * mcpw; $ set to byte address.
dsw 21 call outcon(i,3); $ put out value.
68 i = vv_dimn voa(i); $ link to next.
69 end while;
70
71
vaxa 311 .+t32.
vaxa 312 $ allocate base block.
vaxa 313 if mb_len mba(bl_base) then $ if there is a base block.
vaxa 314 put ocsfile ,column(9) ,'dbw' ,column(17)
vaxa 315 :mblknames(bl_base),a ,','
vaxa 316 :(mb_len mba(bl_base)) * mcpw,i;
vaxa 317 call ocsput(0, 0); $ write out line.
vaxa 318 end if;
vaxa 319 ..t32
dss 57 .s. 17, 3, ocs = mblkname(bl_base); $ indicate base block.
dss 58 .s. 20, 1, ocs = '+';
73 $ process entries in base block.
74 i = basefirst; $ point to first entry in block.
75 while i; $ while more entries remain.
76 j = bb_pointer baseblock(i); $ get pointer from entry.
77 ddoff = bb_addr baseblock(i) - 1; $ dd offset.
vaxa 320 .+t32 ddoff = ddoff * mcpw; $ set to byte pointer.
78 go to bt(bb_type baseblock(i)) in 1 to num_bt; $ select type.
79 /bt(bt_label)/ $ label entry.
80 .s. 9, 3, ocs = 'dwa'; $ set code op.
81 put ocsfile ,column(21)
82 :ddoff,i ,',' $ put offset
dss 59 ,'l'
dss 60 :(lablorg + bb_pointer baseblock(i)) ,i(labcol,labcol);
84 call ocsput(0, 1); $ put line.
85 go to contbase; $ continue.
86
87 /bt(bt_plist)/ $ parameter lists.
vaxa 321 .+t32. $ write out number of entries.
vaxa 322 .s. 9, 3, ocs = 'dwi';
vaxa 323 put ocsfile ,column(21) :ddoff,i ,','
vaxa 324 :bb_nwords baseblock(i),i;
vaxa 325 call ocsput(0, 1); $ write the line.
vaxa 326 ddoff = ddoff + mcpw; $ count the word.
vaxa 327 ..t32
vaxa 328
vaxa 329
88 .s. 9, 3, ocs = 'dwa';
eaa 183 .-t20.
89 do k = j to bb_nwords baseblock(i) + j-1;
90 if pd_block pdlist(k) then $ if entry.
dsu 130 .+t32h.
dsu 131 if (nsheap_this=no) !
dsu 132 (nsheap_this & (pd_block pdlist(k) ^= nsheap_blk)) then
dsu 133 ..t32h
91 put ocsfile ,column(21)
92 :ddoff,i ,','
93 :mblkname(pd_block pdlist(k)),a ,'+'
vaxa 330 .+t10 :pd_madr pdlist(k)-1,i;
vaxa 331 .+t32 :(pd_madr pdlist(k)-1) * mcpw, i;
95 call ocsput(0, 1); $ put line.
dsu 134 .+t32h end if;
96 end if;
vaxa 332 .+t10 ddoff = ddoff + 1; $ step to next address.
vaxa 333 .+t32 ddoff = ddoff + mcpw; $ step to next address.
98 end do;
eaa 184
eaa 185 .+t20.
eaa 186 do k = j to bb_nwords baseblock(i) + j - 1;
eaa 187 if pd_block pdlist(k) then $ if entry
eaa 188 if nsheap_this & (pd_block pdlist(k) = nsheap_blk) then
eaa 189 .s. 9, 3, ocs = 'dha'; $ indicate heap address.
eaa 190 put ocsfile ,column(21)
eaa 191 :ddoff,i ,',efiw ('
eaa 192 :nsheap_org,a ,'+'
eaa 193 :pd_madr pdlist(k)-1,i ,',0)';
eaa 194 else $ if not heap block
eaa 195 put ocsfile ,column(21)
eaa 196 :ddoff,i ,','
eaa 197 :mblkname(pd_block pdlist(k)),a ,'+'
eaa 198 :pd_madr pdlist(k)-1,i;
eaa 199 end if;
eaa 200 call ocsput(0, 1); $ put line.
eaa 201 .s. 9, 3, ocs = 'dwa'; $ restore dwa op (in case was dha)
eaa 202 end if;
eaa 203 ddoff = ddoff + 1; $ step to next address.
eaa 204 end do;
eaa 205 ..t20
eaa 206
99
100 go to contbase; $ continue.
101
102 /bt(bt_const)/ $ single word constants.
vaxa 334 .+t10 .s. 9, 3, ocs = 'dwo'; $ set op.
vaxa 335 .+t32 .s. 9, 3, ocs = 'dwh'; $ set op.
104 put ocsfile ,column(21)
105 :ddoff,i ,','
vaxa 336 .+t10 :val(bb_pointer baseblock(i)),b(0,3);
vaxa 337 .+t32 :val(bb_pointer baseblock(i)),b(0,4);
107 call ocsput(0, 1); $ put line.
108
109 /bt(bt_temp)/
110 /contbase/ $ continue.
111 i = bb_chain baseblock(i); $ chain to next entry;
112 end while;
113
114 call ocsput(0, 2); $ clear code line.
vaxa 338
vaxa 339
vaxa 340 .+t32.
vaxa 341 $ allocate temporary block.
vaxa 342 if mb_len mba(bl_temp) then $ nonempty.
vaxa 343 put ocsfile ,column(9) ,'dbw' ,column(17)
vaxa 344 :mblknames(bl_temp),a ,','
vaxa 345 :(mb_len mba(bl_temp)) * mcpw,i;
vaxa 346 call ocsput(0, 0); $ write out line.
vaxa 347 end if;
vaxa 348 ..t32
vaxa 349
vaxa 350
115 $ generate initial values for variables in namesets
116 $ defined in this procedure.
117 do i = bl_local to mbaptr; $ loop over nameset entries.
vaxa 351
vaxa 352
vaxa 353 .+t32.
vaxa 354 if (mb_used mba(i) = no) cont do;
vaxa 355
vaxa 356
vaxa 357 if i = bl_local then $ this is local block.
vaxa 358 put ocsfile ,column(9) ,'dbw' ,column(17);
vaxa 359 elseif mb_def mba(i) then
vaxa 360 sdsname(dopsname, (mb_ha mba(i))); $ get block name.
dst 85$ emit dnd, unless nspage_opt selected, in which case emit pnd
dst 86 put ocsfile, column(9);
dst 87 if nspage_opt then put ocsfile,'pnd';
dst 88 else put ocsfile,'dnd';
dst 89 end if;
dst 90 put ocsfile ,column(17)
vaxa 362 :dopsname,a ,',';
vaxa 363 else $ not local, not defined.
vaxa 364 sdsname(dopsname, (mb_ha mba(i))); $ get name.
dst 91$ emit dna, unless nspage_opt selected, in which case emit pna
dst 92 put ocsfile, column(9);
dst 93 if nspage_opt then put ocsfile,'pna';
dst 94 else put ocsfile,'dna';
dst 95 end if;
dst 96 put ocsfile ,column(17)
vaxa 366 :dopsname,a ,',';
vaxa 367 end if;
vaxa 368
vaxa 369
vaxa 370 put ocsfile :mblknames(i),a ,',' $ write internal name.
vaxa 371 :(mb_len mba(i)) * mcpw,i;
vaxa 372 call ocsput(0,0);
vaxa 374 ..t32
vaxa 375
vaxa 376
118 if (mb_def mba(i)=no) cont do;
dsu 135 .+t20 if nsheap_this & (i=nsheap_blk) then cont do; end if;
119 ddblk = i;
120
121 j = mb_chain mba(i); $ point to first entry.
122 while j; $ while more remain in chain.
123 len = ((vv_syze voa(j)+mws-1)/mws)*
124 (vv_dimn voa(j) + (vv_dimn voa(j)=0));
125 k = vv_madr voa(j) - ((vv_syze voa(j)+mws-1)/mws);
126
127 .-vvfrs if vv_frsdata voa(j) then $ must initialize.
128 .+vvfrs if vvfrsdata(j) then $ must initialize.
129 call outdata(j); $ call data routine.
130 end if;
131
132 j = vv_vbeg voa(j); $ chain to next entry.
133 end while;
134 end do;
135
136 call ocsput(0, 2); $ put line.
137
138 .s. 9, 3, ocs = 'dep'; $ indicate end of procedure
139 put ocsfile, column(17) :currsubname,a;
140 call ocsput(0, 0);
vaxa 377
vaxa 378
vaxa 379 .+t32. $ must write out real '.end' statement.
dsq 112 put ocsfile ,column(9)
dsq 113 .+t32u $ 'end' probably not required for unix bootstrap,but
dsq 114 .+t32u $ include for compatibility.
dsq 115 .+t32u ,'end';
dsq 116 .+t32v ,'.end';
vaxa 381 if (subrtype = st_prog) put ocsfile ,column(17)
vaxa 382 :currsubname,a; $ write out entry name if prog.
vaxa 383 call ocsput(0, 0); $ write the line.
vaxa 384 ..t32
141
142
dss 61 totprocs = totprocs + 1;
143 $ the rest of this processing is accumulation of statistics,
144 $ so if they are not wanted, return.
145 if (lcs_opt = no) return;
146
147 $ else, start statistics by writing out lengths of blocks
148 $ for this routine.
149 textl(currsubname) $ write routine name.
151
152 len = 0; $ clear acumulation.
153 tabl(30) intl(mb_len mba(bl_const))
154 len = len + mb_len mba(bl_const);
155 tabl(40) intl(mb_len mba(bl_base));
156 len = len + mb_len mba(bl_base);
157 tabl(50) intl(codethis);
158 len = len + codethis;
159 tabl(60) intl(mb_len mba(bl_local));
160 len = len + mb_len mba(bl_local);
161 tabl(70) intl(mb_len mba(bl_temp))
162 len = len + mb_len mba(bl_temp);
163
164 $ write out total module length.
165 tabl(90) intl(len)
166 totlength = totlength + len; $ add to total length.
167
168 len = 0; $ clear cumulative global length.
169 do i = bl_global to mbaptr;
170 if mb_def mba(i) then $ if defined here, add in length.
171 len = len + mb_len mba(i); $ add to total.
172 totglobs = totglobs + mb_len mba(i);
173 totns = totns + 1; $ count number of namesets.
174 end if;
175 end do;
176
177 tabl(100) intl(len) endl
178
179 $ reset variables to indicate which routine so far has
180 $ used the most table space.
181 if pdlistp > loadpd then $ this routine used most in -pdlist-
182 loadpd = pdlistp; loadrpd = currsubname;
183 end if;
184
185
186
187
188
189 if labluse > loadlab then
190 loadlab = labluse; loadrlab = currsubname;
191 end if;
192
193 if valptr > loadval then
194 loadval = valptr; loadrval = currsubname;
195 end if;
196
197 end subr endsubr;
1 .=member outdata
2 subr outdata(var); $ this routine process data statements.
3 $ this routine is called by -endsubr- to process any data
4 $ statements on the chain of -var-.
5 size var(ps); $ variable to process.
6 size dim(ps); $ dimension of variable.
7 size curind(ps); $ current index of variable.
8 size datvoa(ps); $ -voa- pointer to data statement.
9 size wlen(ps); $ word length of variable.
10 size i(ps), j(ps), k(ps); $ temporaries.
11 size len(ps); $ length of data item.
dsw 22 size nlen(ps); $ name length
12 size rep(ps); $ repetition factor.
13 size vp(ps); $ -voa- pointer to data value.
14 size vmadr(mps); $ variable address.
15
16 $ first, set values for this variable.
17 curind = 1; $ initially at first element.
18 dim = vv_dimn voa(var); $ set dimension.
19 if (dim = 0) dim = 1; $ reset if not array.
20 wlen = (vv_syze voa(var) + (mws-1))/mws; $ set word length.
21 vmadr = vv_madr voa(var) - wlen;
22 ddblk = vv_mblk voa(var);
23
24 $ process all data statements on chain for this variable.
25 .-vvfrs datvoa = vv_frsdata voa(var); $ get first entry index.
26 .+vvfrs datvoa = vvfrsdata(var); $ get first entry index.
27
28 .s. 9, 2, ocs = 'dw'; $ set declaritive op.
dsw 23 nlen = .len. mblkname(ddblk);
dsw 24 put ocsfile, column(17) :mblkname(ddblk),a ,'+';
30
31 while datvoa; $ loop while more remain.
32 $ check if this is an overlapping index.
33 if vv_inp1 voa(datvoa) < curind then $ it is.
34 error('data indices overlap', var)
35 quit while;
36 end if;
37
38 curind = vv_inp1 voa(datvoa); $ set current index.
39 do i = 1 to vv_arglen voa(datvoa); $ process all elements.
40 vp = xa_voa xarg(vv_argbeg voa(datvoa)+i-1);
41 len = (vv_syze voa(vp)+(mws-1))/mws;
42 rep = xa_rep xarg(vv_argbeg voa(datvoa)+i-1);
43
44 $ check if value too long.
45 if len > wlen then $ too long.
46 error('data value too long', var)
47 quit while;
48 end if;
49
50 $ get repetition value.
51 if rep then $ repetition is used.
52 rep = val(vv_vbeg voa(rep)); $ get constant value.
53 else $ will just do once.
54 rep = 1;
55 end if;
56
57 if curind+rep>(dim+1) then $ if out of range.
58 error('data index exceeds dimension', var);
59 quit while;
60 end if;
61
62 ddoff = vmadr +(curind-1) * wlen;
vaxa 385 .+t32 ddoff = ddoff * mcpw; $ set to byte address.
63 if vv_naym voa(vp) = ha_0 then $ if zeroizing.
64 put ocsfile ,column(11) ,'z' $ change op
dsw 25 ,column(18+nlen) :ddoff,i, ',' $ put offset
66 :rep*wlen,i;
67 call ocsput(0, 1); $ put line, retain text.
68 curind = curind + rep;
69 cont do;
70 end if;
71
72 do j = 1 to rep; $ do once/repetition.
73
74 if wlen-len > 0 then $ if must zero initial part.
75 put ocsfile ,column(11) ,'z' $ change opcode.
dsw 26 ,column(18+nlen)
77 :ddoff,i ,',' $ put offset.
78 :wlen-len,i;
79 call ocsput(0, 1); $ put line, retain text.
80 end if;
81
vaxa 386 .+t10 ddoff = ddoff + (wlen-len);
vaxa 387 .+t32 ddoff = ddoff + (wlen-len) * mcpw;
dsw 27 call outcon(vp, nlen); $ put constant value.
84 curind = curind + 1;
vaxa 388 .+t10 ddoff = ddoff + len;
vaxa 389 .+t32 ddoff = ddoff + len*mcpw;
86 end do;
87 end do;
88
89 k = datvoa; $ save one entry back.
90 datvoa = vv_inp2 voa(datvoa); $ get next data entry.
91 end while;
92
93 end subr outdata;
1 .=member outcon
dsw 28 subr outcon(voaptr, bl); $ output constant initialization.
3 size voaptr(ps); $ voa item to put out.
4 size tmi(ps); $ index.
5 size tmwd(mws); $ working copy of tmcval entry.
6 size c(mcs); $ character.
7 size n(ps); $ character count.
vaxa 390 .+t32 size i(ps); $ loop index.
8 size tmpos(ps); $ position in word.
9 size ddtab(mcs); dims ddtab(num_tmc); $ type table
dsw 29 size bl(ps); $ length of block name
vaxa 391 .+t10 data ddtab(tmc_b) = 1ro;
vaxa 392 .+t32 data ddtab(tmc_b) = 1rh;
11 data ddtab(tmc_i) = 1ri;
12 data ddtab(tmc_c) = 1rc;
13 data ddtab(tmc_r) = 1rr;
dsn 87 .+t32 data ddtab(tmc_s) = 1rs;
dsn 88 .+t10 data ddtab(tmc_s) = 1rc;
15
16 ddlt = tmctab(vv_lextype voa(voaptr));
17
18 call tmcons(voaptr); $ put into target machine form.
19
vaxa 393 .-hmeqtm.
20 .s. 9, 2, ocs = 'dw';
21 .ch. 11, ocs = ddtab(ddlt);
vaxa 394 .+hmeqtm.
vaxa 395 .+t10 .s. 9, 3, ocs = 'dwo';
vaxa 396 .+t32 .s. 9, 3, ocs = 'dwh';
vaxa 397 ..hmeqtm
22
23 do tmi = 1 to tmcvalptr;
24 tmwd = tmcval(tmi); $ copy entry.
dsw 30 put ocsfile ,column(18+bl)
vaxa 398 .+t10 :ddoff+tmi-1,i ,',';
vaxa 399 .+t32 :ddoff + (tmi-1)*mcpw,i ,',';
vaxa 400
vaxa 401
vaxa 402 .-hmeqtm.
27 go to l(ddlt) in 1 to num_tmc; $ branch on lexical type.
vaxa 403 ..hmeqtm
28
29 /l(tmc_b)/ $ bit string, put out in octal
vaxa 404 .+t10 put ocsfile :tmwd,b(0,3);
vaxa 405 .+t32 put ocsfile :tmwd,b(0,4);
31 go to ddcont;
32
vaxa 406 .-hmeqtm.
33 /l(tmc_i)/ $ integer
34 put ocsfile :tmwd,i;
35 go to ddcont;
36
37 /l(tmc_r)/ $ real
38 $ put out characters which are in same form
39 $ as character constant (cf. tmc_c codein tmcons).
40
vaxa 407 n = mcpw; if (tmi=1) n = mod(ddnc-1, mcpw)+1;
vaxa 408 put ocsfile :tmwd,r(n);
43 go to ddcont;
44
45 /l(tmc_c)/ $ character code (r) constant.
46 n = mcpw; if (tmi=1) n = mod(ddnc-1, mcpw) + 1;
vaxa 409 .+t10 tmpos = n*mcs+1; $ position at left.
vaxa 410 .+t32 tmpos = 1; $ position at right.
vaxa 411 .+t32 put ocsfile ,'<'; $ write out macro arg. starter.
48 put ocsfile :tmccdel,r(1); $ put delimiter.
vaxa 412 .+t10.
dsn 89 tmpos = mws + 1 ;
dsn 90 do n = 1 to mcpw ;
dsn 91 tmpos = tmpos - mcs ;
dsn 92 c = .f. tmpos, mcs, tmwd ;
dsn 93 if c ^= 0
dsn 94 then
dsn 95 if ( c = tmccdel ) put ocsfile :tmccdel,r(1) ;
dsn 96 put ocsfile :tmccdel,r(1) :c,r(1) :tmccdel,r(1) ;
dsn 97 end if ;
dsn 98 if ( n ^= mcpw ) put ocsfile ,',' ;
dsn 99 end do ;
vaxa 413 ..t10
vaxa 414 .+t32.
vaxa 415 i = n; $ save number of characters in word.
vaxa 416 until n = 0; $ until hit left end.
vaxa 417 n = n - 1; $ decrement count.
vaxa 418 c = .f. tmpos, mcs, tmwd; $ get a character.
vaxa 419 if c = tmccdel then $ this is delimiter.
vaxa 420 put ocsfile :c,r(1) ,'/' :c,r(1) ,'/' :c,r(1);
vaxa 421 elseif c = 1r< then $ handle special character.
vaxa 422 put ocsfile :tmccdel,r(1) ,'<60>' :tmccdel,r(1);
vaxa 423 elseif c = 1r> then $ handle special character.
vaxa 424 put ocsfile :tmccdel,r(1) ,'<62>' :tmccdel,r(1);
vaxa 425 else $ normal character.
vaxa 426 put ocsfile :c,r(1);
vaxa 427 end if;
vaxa 428
vaxa 429
vaxa 430 tmpos = tmpos + mcs; $ step to next character.
vaxa 431 end until;
vaxa 432
vaxa 433
vaxa 434 if i ^= mcpw then $ must insert zeros.
vaxa 435 do n = 1 to mcpw-i; $ mcpw-i times.
vaxa 436 put ocsfile :tmccdel,r(1) ,'<0>'
vaxa 437 :tmccdel,r(1);
vaxa 438 end do;
vaxa 439 end if;
vaxa 440
vaxa 441
vaxa 442 put ocsfile ,'>'; $ close macro delimiter.
vaxa 443
vaxa 444
vaxa 445 ..t32
vaxa 446
vaxa 447
55 put ocsfile :tmccdel,r(1); $ put delimiter.
56 go to ddcont;
57
58 /l(tmc_s)/ $ character string.
59 if tmi=tmcvalptr then $ put last word as octal.
vaxa 448 .+t10 .ch. 11, ocs = 1ro; go to l(tmc_b);
vaxa 449 .+t32 .ch. 11, ocs = 1rh; go to l(tmc_b);
61 end if;
62 n = mcpw; if (tmi=tmcvalptr-1) n=mod(ddnc,mcpw);
63 if (n=0) n = mcpw;
vaxa 450 .+t32 put ocsfile ,'<'; $ write out argument start.
64 put ocsfile :tmcsdel,r(1); $ put delimiter.
vaxa 451 .+t10.
65 tmpos = mws+1; $ start at leftmost position.
66 until n = 0; $ until all characters are processed.
67 n = n - 1; $ count the character.
68 tmpos = tmpos - mcs; $ allow for the character.
69 c = .f. tmpos, mcs, tmwd; $ get character.
70 put ocsfile :c,r(1); $ put character.
71 if (c=tmcsdel) put ocsfile :c,r(1); $ if delimiter.
72 end until;
vaxa 452 ..t10
vaxa 453 .+t32.
vaxa 454 if (n ^= mcpw) put ocsfile :4r ,r(mcpw-n); $ fill.
vaxa 455 tmpos = 1 + (mcpw-n) * mcs; $ start at right.
vaxa 456 until tmpos = mws+1; $ until at end of word.
vaxa 457 c = .f. tmpos, mcs, tmwd; $ get character.
vaxa 458 if c = 1r< then $ special case.
vaxa 459 put ocsfile :tmcsdel,r(1) ,'<60>' :tmcsdel,r(1);
vaxa 460 elseif c = 1r> then $ another special case.
vaxa 461 put ocsfile :tmcsdel,r(1) ,'<62>' :tmcsdel,r(1);
vaxa 462 else $ normal character.
vaxa 463 if (c = tmcsdel) $ if delimiter.
vaxa 464 put ocsfile :c,r(1) ,'/' :c,r(1) ,'/';
vaxa 465 put ocsfile :c,r(1); $ write out character.
vaxa 466 end if;
vaxa 467
vaxa 468
vaxa 469 tmpos = tmpos + mcs; $ step to next position.
vaxa 470 end until;
vaxa 471
vaxa 472
vaxa 473 put ocsfile :tmccdel,r(1);
vaxa 474 put ocsfile ,'>'; $ write argument terminator.
vaxa 475
vaxa 476
vaxa 477 $ now write out cleanly.
vaxa 478 i = filestat(ocsfile,column);
vaxa 479 put ocsfile ,x(57-i) ,'; ' :tmccdel,r(1);
vaxa 480 do i = 1 to n; $ for each character.
vaxa 481 put ocsfile :(.f. mws+1 - i*mcs, mcs, tmwd),r(1);
vaxa 482 end do;
vaxa 483 ..t32
vaxa 484
vaxa 485
73 put ocsfile :tmcsdel,r(1); $ put delimiter.
74 go to ddcont;
vaxa 486 ..hmeqtm
75
76 /ddcont/ $ write out line
77 call ocsput(0, 1); $ retain 1-16.
78 end do;
79
80 end subr outcon;
1 .=member tmcons
2 subr tmcons(voaptr); $ convert target machine constant.
3 $ given voa index -voaptr- of constant, convert as needed
4 $ so that tmcval(1) to tmcval(tmcvalptr) contains constant
5 $ in correct form for target machine.
6 $ for resident compiler, this requires just copying over
7 $ the contents of val array. for bootstrap, conversion
8 $ depends on host machine structure, as val entries passed
9 $ in form appropriate to host machine.
10 size c(cs); $ character temporary
11 size hmpos(ps); $ host machine word position.
12 size hmptr(ps); $ host machine word pointer
13 size hmwd(ws); $ temporary word value.
14 size i(ps); $ loop index.
15 size nc(ps); $ number of characters.
16 size nrem(ps); $ remaining characters.
17 size mbs(szmax-1); $ bit string to build target form.
18 size sz(ps); $ result size.
19 size vl(ps); $ vv_vlen value.
20 size vb(ps); $ vv_vbeg value.
21 size vp(ps); $ val pointer
22 size voaptr(ps); $ voa index
23
24 vp = vv_vbeg voa(voaptr); $ get starting point in val.
25 vl = vv_vlen voa(voaptr); $ get number of words in val.
26 sz = vv_syze voa(voaptr); $ get size.
27 tmcvalptr = (sz+mws-1) / mws; $ get target machine words.
28 ddlt = tmctab(vv_lextype voa(voaptr)); $ save lexical type.
29 ddnc = ha_nchars ha(vv_naym voa(voaptr));
vaxa 487 .+hmeqtm. $ if host = target, just copy into tmcval.
31 do i = 1 to vl; tmcval(i) = val(vp+i-1); end do;
32 if (vl ^= tmcvalptr) call aermey(38); $ error.
33 return;
vaxa 488 ..hmeqtm
35 .+s66. $ on different host machine, reconvert.
36 $ if result multiword on target, clear required
37 $ part of mbs.
38 do i = 1 to (sz+ws-1)/ws+1;
39 .f. (i-1)*ws+1, ws, mbs = 0;
40 end do;
41 go to l(ddlt) in 1 to num_tmc;
42
43 /l(tmc_i)/ $ integer, single word, so no conversion.
44 tmcval(tmcvalptr) = val(vp); $ no conversion
45 if (sz > mws) call aermey(38); $ if too long.
46 go to ret;
47
48 /l(tmc_b)/ $ bit, must format appropriate number to word.
49 if sz <= mws then $ if conversion not needed.
50 tmcval(tmcvalptr) = val(vp);
51 go to ret;
52 end if;
53 $ here to convert val packed hws bits to entry to
54 $ target form.
55 do i = 1 to vl;
56 .f. (vl-i)*ws+1, ws, mbs = val(vp+i-1);
57 end do;
58 go to retlong;
59 /l(tmc_c)/ $ character code constant.
60 $ host has passed characters left aligned, with blank
61 $ fill.
62 nc = ha_nchars ha(vv_naym voa(voaptr));
63 if (nc=0) call aermey(39);
64 hmpos = ws+1; hmptr = vp; hmwd = val(hmptr);
65 do i = 1 to nc;
66 hmpos = hmpos - cs;
67 c = .f. hmpos, cs, hmwd;
vaxa 489 .e. (nc-i)*mcs + 1, mcs, mbs = c;
69 if hmpos = 1 then $ if need new word.
70 hmpos = ws+1;
71 hmptr = hmptr + 1;
72 hmwd = val(hmptr);
73 end if;
74 end do;
75 go to retlong;
76
77 /l(tmc_r)/ $ real constant.
78 $ convert in same way as for character constants.
79 $ since real constants not 'safe' for bootstrap,
80 $ val will just contain characters of constant.
81
82 go to l(tmc_c);
83
84 /l(tmc_s)/ $ character string.
85 nc = ha_nchars ha(vv_naym voa(voaptr));
86 if nc = 0 then $ if null string
87 tmcval(1) = 0; go to ret; $ null string is zero.
88 go to ret;
89 end if;
90 $ characters are packed in val, left aligned with
91 $ blank fill.
92 nc = ha_nchars ha(vv_naym voa(voaptr));
vaxa 490
vaxa 491
vaxa 492 hmpos = ws+1; hmptr = vp; hmwd = val(hmptr); $ set up for start.
vaxa 493 do i = 1 to nc; $ process each character.
vaxa 494 hmpos = hmpos - cs; $ step to next character.
vaxa 495 c = .f. hmpos, cs, hmwd; $ get a character.
vaxa 496 .e. sz+1 - i*mcs, mcs, mbs = c; $ insert character.
vaxa 497 if hmpos = 1 then $ if need new word.
vaxa 498 hmpos = ws+1; $ reset.
vaxa 499 hmptr = hmptr + 1; hmwd = val(hmptr); $ get next word.
vaxa 500 end if;
vaxa 501 end do;
vaxa 502
vaxa 503
102 $ fill in string origin, length field.
vaxa 504 .f. 1, msl, mbs = nc; $ set length.
vaxa 505 .f. msl+1, mso, mbs = sz+1; $ origin.
105 go to retlong;
106
107 /retlong/ $ here to pack mbs to tmcval.
108 do i = 1 to tmcvalptr;
109 tmcval(i) = .e. (tmcvalptr-i)*mws+1, mws, mbs;
110 end do;
111 ..s66
112 /ret/
113 end subr tmcons;
1 .=member emopr
2 subr emopr(op, oreg, imode, ireg, ioff); $ emit machine instr.
3 $ emit machine instruction for m op -op-. oreg is accumulator
4 $ and imode, ireg and ioff represent effect address.
5
6 size op(ps); $ mop
7 size oreg(ps); $ result accumulator
8 size imode(ps); $ input address mode.
9 size ireg(ps); $ input machine register.
10 size ioff(mosize); $ input block, offset.
11 size regname(.sds. 3); dims regname(16);
12 size blk(ps); $ block of address.
13 size off(mps); $ offset of address.
14 size ic(cs); $ immediate code.
15 size ostr(.sds. namelen); $ for output description.
16 size nx(ps); $ space count.
dsu 136 size mvop(1); $ set if mvw or mvx op
17
18 codethis = codethis + moaiwc(op); $ add length of instr.
19 .s. 9, 3, ocs = moptab(op);
pic 14 .+t32v
pic 15 pic_case=no;
pic 16 if (op=mo_lda ! op=mo_ldw ! op=mo_stw )
pic 17 & (imode=am_rel ! imode=am_reli) &
pic 18 (mbo_blk ioff > bl_imm) then
pic 19 pic_case=yes;
pic 20 pic_char = .ch. 10, ocs;
pic 21 .ch. 10, ocs = 1rx;
pic 22 end if;
pic 23 ..t32v
20
dsu 137 mvop = (op=mo_mvw) ! (op=mo_mvx);
vaxa 506 .+t10.
21 $ if op admits immediate mode and operand is immediate,
22 $ append i to opcode.
23 if mbo_blk ioff = bl_imm then $ if immediate block.
24 if (moaimm(op) = no) call aermey(40); $ ***assign number***
25 put ocsfile ,column(12) ,'i';
26 end if;
vaxa 507 ..t10
27
28 put ocsfile ,column(17);
29 call emitea(am_reg, oreg, 0);
30 put ocsfile ,',';
31 ostr = strname;
dsu 138 .+t32h.
dsu 139 if mvop ! op=mo_lpr ! op=mo_spr ! op=mo_bnb
dsu 140 ! op=mo_bfb then
dsu 141 if nsheap_this then
dsu 142 nsheap_byte = yes;
dsu 143 end if;
dsu 144 end if;
dsu 145 ..t32h
32 call emitea(imode, ireg, ioff);
dsu 146 .+t32h nsheap_byte = no;
33
34 $ now put out any additional operands needed for specific ops.
vaxa 508 .+t10.
dsu 147 if op = mo_lpr ! op = mo_spr ! mvop then
36 put ocsfile ,',' :emopparm1,i; $ write parm. 1.
37
dsu 148 if mvop=0 then $ there is a second parm.
39 put ocsfile ,',' :emopparm2,i; $ write second.
40 end if;
41 end if;
vaxa 509 ..t10
vaxa 510 .+t32.
vaxa 511 size mode(ps), reg(ps), moff(mosize);
dsu 149 if mvop then $ if word move.
dsq 117 put ocsfile ,',' ,tmcslit
dsq 118 :emopparm1,i; $ write out extra operand.
vaxa 514
vaxa 515
vaxa 516 elseif op = mo_lpr ! op = mo_spr then $ field operation.
vaxa 517 put ocsfile ,','; $ write a comma.
vaxa 518 getdesc(emopparm1, gd_use, mode, reg, moff); $ get first bit
dsu 150 .+t32h nsheap_byte = yes;
vaxa 519 call emitea(mode, reg, moff); $ write the ea.
dsu 151 .+t32h nsheap_byte = no;
vaxa 520 getdesc(emopparm2, gd_use, mode, reg, moff); $ get length.
vaxa 521 put ocsfile ,','; $ write a comma.
dsu 152 .+t32h nsheap_byte = yes;
vaxa 522 call emitea(mode, reg, moff); $ write the ea.
dsu 153 .+t32h nsheap_byte = no;
vaxa 523 end if;
vaxa 524 ..t32
42
43 if slen strname ^= 0 ! slen ostr ^= 0 then
44 nx = 17 - mod(filestat(ocsfile,column), 8);
45 $ [ds 31 may separate nx reflects gen bug in nested
46 $ filestat handling.]
dsq 119 put ocsfile ,x(nx) ,tmcscom;
48 if (slen ostr) put ocsfile :ostr,a;
49 if slen strname then
50 if (slen ostr) put ocsfile ,',';
51 put ocsfile :strname,a;
52 end if;
53 end if;
54
pic 24 .+t32v pic_case=no;
55 call ocsput(0, 0); $ put line.
vaxa 525
vaxa 526
vaxa 527 .+t32.
vaxa 528 if op = mo_lpr ! op = mo_spr then $ field operations.
vaxa 529 drop(emopparm1); drop(emopparm2); $ drop parameters.
vaxa 530 end if;
vaxa 531 ..t32
vaxa 532
vaxa 533
56 end subr emopr;
1 .=member emitea
2 subr emitea(mode, reg, ioff); $ put out ea.
3 $ emit t10 code for operand.
4 size mode(ps); $ operand mode.
5 size reg(ps); $ machine register
6 size ioff(mosize); $ operand block, offset
7 size blk(ps), off(mps); $ block, offset.
8 size i(ps); $ temporary.
vaxa 534 size sign(cs); $ sign character (1r+ or 1r-).
9
10 $ free output register.
11 rl_hold reglis(reg) = no; $ no longer on hold.
12 reguseval = reguseval + 1; $ increment usage count.
13 rl_usevalue reglis(reg) = reguseval; $ save lru value.
vaxa 535 .+t32 .f. reg, 1, regmask = yes; $ show register used.
14
15 .len. strname = 0; $ clear name string.
16 i = rl_content reglis(reg); $ assume data.
17 if (rl_subtype reglis(reg) = rt_address
18 ! rl_subtype reglis(reg) = rt_liveaddr)
19 & (i^=0) then
20 i = dw_freg dword(di_lword ditem(i));
21 end if;
22
23 if reg ^= sparereg & i^=0 then $ if not empty.
24 if isvar(i) then $ if variable.
25 sdlname(strname, (vv_naym voa(di_chain
26 ditem(dr_item dreg(i))))); $ get name.
27 end if;
28 end if;
29
30 blk = mbo_blk ioff; off = mbo_off ioff; $ get block, offset.
eaa 208 .+t20.
eaa 209 if nsheap_this & (blk=nsheap_blk) then $ if need to redirect.
eaa 210 call emitex(mode, reg, off, blk);
eaa 211 return;
eaa 212 end if;
eaa 213 ..t20
dsu 154 .+t32h.
dsv 11$ only redirect if offset>0, i.e., keep refs to heap_adr as is
dsva 1 if nsheap_this & (blk=nsheap_blk) & .not.(mode=am_mem & off=0)
dsva 2 then call emiteh(mode, reg, off, blk);
dsu 157 return;
dsu 158 end if;
dsu 159 ..t32h
31 $ dispose of am_reg case.
32 if mode=am_reg then
33 put ocsfile ,'r' :reg-1,i;
34 return; end if;
35 if mode=am_reli then $ if indirect.
dsq 120 put ocsfile ,tmcsind; end if;
37 $ identify block unless immediate or absolute.
vaxa 536 .+t10 if blk>bl_imm then $ if need to identify.
vaxa 537 .+t32 if blk>=bl_imm then $ if need to identify.
dsq 121 .+t32.
pic 25 .+t32u.
pic 26 if (mode=am_rel & blk>bl_imm) put ocsfile ,'l' :tmccgra,r(1);
pic 27 ..t32u
pic 28 .+t32v.
pic 29 $ pic form
pic 30 if blk>bl_imm then put ocsfile ,'g^'; end if;
pic 31 ..t32v
dsq 125 ;
dsq 126 ..t32
39 put ocsfile :mblkname(blk),a;
40 end if;
41 $ indicate offset, as negative if sign bit set.
vaxa 539
vaxa 540
vaxa 541 if .f. mps, 1, off then $ if negative.
vaxa 542 off = mneg(off); sign = 1r-; $ set negative.
vaxa 543 else $ positive.
vaxa 544 sign = 1r+; $ show positive.
vaxa 545 end if;
vaxa 546
vaxa 547
vaxa 548 .+t32.
vaxa 549 if (blk ^= bl_imm) off = off * mcpw; $ set to byte value.
vaxa 550 if mode = am_mem ! off ^= 0 then
vaxa 551 ..t32
vaxa 552 put ocsfile :sign,r(1) :off,i; $ write out offset.
vaxa 553 .+t32 end if;
45 $ write index register if appropriate.
46 if mode=am_rel ! mode=am_reli then
vxaa 1 .+t10 put ocsfile ,'(r' :reg-1,i ,')';
vaxa 555 .+t32.
pic 32 .+t32u.
vaxa 556 if reg = parmreg
vaxa 557 then put ocsfile ,'(ap)';
vaxa 558 else put ocsfile ,'(r' :reg-1,i ,')'; end if;
pic 33 ..t32u
pic 34 .+t32v.
pic 35 if reg=parmreg then put ocsfile ,'(ap)';
pic 36 elseif blk>bl_imm then $ if need pic form then
pic 37 put ocsfile ,'[r' :reg-1,i ,']';
pic 38 else put ocsfile ,'(r' :reg-1,i ,')';
pic 39 end if;
pic 40 ..t32v
vaxa 559 ..t32
48 end if;
49 if mode=am_mem then
50 if (reg^=sparereg) call aermey(33); end if;
51 end subr emitea;
dsu 160 .+t32h.
dsu 161 subr emiteh(mode, reg, off, blk); $ put out ea.
dsu 162 $ emit t10 code for operand.
dsu 163 size mode(ps); $ operand mode.
dsu 164 size hreg(ws); $ reg if dynamic address
dsu 165 size reg(ps); $ machine register
dsu 166 size blk(ps), off(mps); $ block, offset.
dsu 167 size i(ps); $ temporary.
dsu 168 size sign(cs); $ sign character (1r+ or 1r-).
dsu 169
pic 41 .+t32v.
pic 42 if pic_case then $ no need pic fix for heap refs
pic 43 .ch. 10, ocs = pic_char;
pic 44 end if;
pic 45 ..t32v
dsu 170 $ dispose of am_reg case.
dsu 171 if mode=am_reg then
dsu 172 put ocsfile ,'r' :reg-1,i;
dsu 173 return; end if;
dsu 174 if mode=am_reli then $ if indirect.
dsu 175 put ocsfile ,tmcsind;
dsu 176 end if;
dsu 177 $ indicate offset, as negative if sign bit set.
dsu 178
dsu 179
dsu 180 if .f. mps, 1, off then $ if negative.
dsu 181 off = mneg(off); sign = 1r-; $ set negative.
dsu 182 else $ positive.
dsu 183 sign = 1r+; $ show positive.
dsu 184 end if;
dsu 185
dsu 186 if (blk ^= bl_imm) off = off * mcpw; $ convert to bytes
dsu 187
dsu 188 $ write index register if appropriate.
dsu 189 if mode=am_rel ! mode=am_reli then
dsu 190 if off ^= 0 then
dsu 191 put ocsfile :sign,r(1) :off,i; $ write out offset.
dsu 192 end if;
dsu 193 if reg = parmreg
dsu 194 then put ocsfile ,'(ap)';
dsu 195 else put ocsfile ,'(r' :reg-1,i ,')'; end if;
dsu 196 else $ put out @#off[rh]
dsv 13 put ocsfile ,tmcsind ,tmcslit :off,i;
dsu 198 if sign^=1r+ then call aermey(99); end if;
dsu 199 end if;
dsu 200
dsu 201 if nsheap_byte then hreg = nsheapreg_b;
dsu 202 else hreg = nsheapreg_w; end if;
dsu 203 put ocsfile ,'[r' :hreg-1,i ,']'; $ add indexing
dsu 204 if mode=am_mem then
dsu 205 if (reg^=sparereg) call aermey(33);
dsu 206 end if;
dsu 207
dsu 208 end subr emiteh;
dsu 209 ..t32h
eaa 214 .+t20.
eaa 215 subr emitex(mode, reg, off, blk); $ put out ea.
eaa 216 $ emit t20 code for operand.
eaa 217 size mode(ps); $ operand mode.
eaa 218 size hreg(ws); $ reg if dynamic address
eaa 219 size reg(ps); $ machine register
eaa 220 size blk(ps), off(mps); $ block, offset.
eaa 221 size i(ps); $ temporary.
eaa 222 size sign(cs); $ sign character (1r+ or 1r-).
eaa 223
eaa 224 $ dispose of am_reg case.
eaa 225 if mode=am_reg then
eaa 226 put ocsfile ,'r' :reg-1,i;
eaa 227 return; end if;
eaa 228 if mode=am_reli then $ if indirect.
eaa 229 call aermey(1); $ cannot have indirection here!!!
eaa 230 put ocsfile ,tmcsind;
eaa 231 end if;
eaa 232 $ write operand as @[heaporg + offset +register_specification]
eaa 233 put ocsfile ,'@[efiw ' :nsheap_org,a;
eaa 234 $ indicate offset, as negative if sign bit set.
eaa 235
eaa 236
eaa 237 if .f. mps, 1, off then $ if negative.
eaa 238 off = mneg(off); sign = 1r-; $ set negative.
eaa 239 else $ positive.
eaa 240 sign = 1r+; $ show positive.
eaa 241 end if;
eaa 242
eaa 243
eaa 244 put ocsfile :sign,r(1) :off,i; $ write out offset.
eaa 245 $ write index register if appropriate.
eaa 246 if mode=am_rel ! mode=am_reli then
eaa 247 put ocsfile ,',' :reg-1,i ,']';
eaa 248 else put ocsfile ,',0]';
eaa 249 end if;
eaa 250
eaa 251 if mode=am_mem then
eaa 252 if (reg^=sparereg) call aermey(33);
eaa 253 end if;
eaa 254 end subr emitex;
eaa 255 ..t20
1 .=member ocsput
2 subr ocsput(la, c); $ put code line.
3 size la(ps); $ length argument.
4 size l(ps); $ length.
5 size c(ps); $ action code.
dsq 128 .+hmeqtm.
dsq 129 size s(.sds. 80); $ copy of code string
dsq 130 ..hmeqtm
6 $ c=0 to clear 1-16 after write.
7 $ c=1 to retain 1-16 after write.
8 $ c=2 to clear 1-16, no write.
9
10 if c = 2 then $ if clear only wanted.
11 .s. 1, 16, ocs = '';
12 return;
13 end if;
14 l = la; if (l=0) l = filestat(ocsfile,column)-1;
dsq 131 .-hmeqtm.
15 put codefile :ocs,a(l) ,skip; $ put to codefile.
dsr 15 ..hmeqtm
16 if (trace_c) put :ocs,a(l) ,skip; $ put trace to print file.
dsq 133 .+hmeqtm.
dsq 134 $ here to try to generate tabs.
dsq 135 $ cannot alter ocs, so work with copy in s.
dsq 136
dsq 137 s = ocs; .len. s = l;
dsq 138 if l>8 then $ try to map initial blanks to tabs
dsq 139 if .s. 1, 8, s .seq. (''.pad.8) then
dsq 140 .ch. 1, s = tmcctab; $ insert tab
dsq 141 .s. 2, l-8, s = .s. 9, l-8, s;
dsq 142 l = l - 7;
dsq 143 .len. s = l;
dsq 144 $ now try to put tab in operator field
dsq 145 if l > 9 then
dsq 146 if .s. 5, 5, s .seq. (''.pad.5) then
dsq 147 .ch. 5, s = tmcctab;
dsq 148 .s. 6, l-9, s = .s. 10, l-9, s;
dsq 149 l = l - 4; $ adjust length.
dsq 150 .len. s = l;
dsq 151 end if;
dsq 152 end if;
dsq 153 end if;
dsq 154 end if;
dsq 155 put codefile :s,a(l) ,skip; $ put to codefile.
dsq 156 ..hmeqtm
17 if (c = 0) .s. 1, 16, ocs = '';
18 end subr ocsput;
1 .=member basprb
2 subr baseprober(ctyp, optr, ihcode, p1, p2, arrayp, array);
3 $ this routine is called by the various -baseprobe- macros
4 $ to insert items into the hased base block. -ctyp- is the
5 $ call type and determines some of the actions.
6 size ctyp(ps); $ calling type.
7 size optr(ps); $ the output pointer.
8 size ihcode(mws/2+7); $ the given hash code.
9 size p1(ps); $ one descriptive parameter.
10 size p2(ps); $ the second parameter.
11 size arrayp(ps); $ array pointer to data.
12 size array(ps); $ index value representing array.
13 size hcode(23); $ computed hash code to use.
14 size ptr(ps); $ base block pointer.
15 size type(ps); $ entry type.
16 size len(ps); $ entry length.
17 size i(ps), j(ps); $ temporaries.
18 size vptr(ps); $ desired data pointer.
19 size baseent(baseblocksz); $ temporary entry.
20
21 $ first must set the values for this probe based on
22 $ the calling type.
23 if ctyp = rp_addlab then $ label call.
24 type = bt_label; $ set type.
25 len = 1; $ labels are one word long.
26 vptr = p2; $ data pointer is label index.
27 hcode = p2; $ hashcode is initially label index.
28 elseif ctyp=rp_nocomp then
29 len = p1; type = p2;
30 vptr = arrayp; $ data pointer is array pointer.
31 hcode = vptr; $ initial hash code is pointer.
32 else $ this is normal call.
33 len = p1; type = p2; $ get length, type.
34 vptr = arrayp; $ set data pointer to array pointer.
35 hcode = ihcode; $ use caller's hash code.
36 end if;
37
38 $ complete hash code with type and length.
39 .f. mws/2+1, 3, hcode = type; $ insert type.
40 .f. mws/2+4, 3, hcode = len; $ insert length.
41
42 $ compute initial place to try in base block.
43 ptr = mod(hcode, baseblockprime); $ compute initial probe.
44 if (ptr = 0) ptr = baseblockprime - 2; $ set for bad value.
45
46 $ enter a loop which will be exited when a free entry
47 $ is found.
48 until yes; $ will exit when found entry.
49 $ if the first one is free, quit now.
50 if (bb_type baseblock(ptr) = 0) quit until;
51
52 $ scan and see if the desired entry is already in the
53 $ base block.
54 while yes; $ will quit when end of chain found.
55 $ must compare each entry. quit this next
56 $ loop if the entries do not match.
57 until yes; $ quit if no match.
58 $ in the case of the -addlab- call, will
59 $ just say that they dont compare.
60 if (ctyp = rp_addlab) quit until;
61
62 $ check types.
63 if (bb_type baseblock(ptr) ^= type) quit until;
64
65 $ next check lengths.
vaxa 560 .+t10 if (bb_nwords baseblock(ptr) < len) quit until;
vaxa 561 .+t32 if (bb_nwords baseblock(ptr) ^= len) quit until;
67
68 $ if the pointers compare, the items are the
69 $ same. so return this pointer.
70 if bb_pointer baseblock(ptr) = vptr then $ found.
71 optr = ptr; return; $ set return value.
72 end if;
vaxa 562
vaxa 563
73 if (ctyp ^= rp_normal) quit until;
74
75 $ finally, check every word in the data.
vaxa 564 .+t32 if len then $ if there is a list.
76 do i = 0 to len-1; $ check every entry.
77 $ do the array comparison that is needed.
78 j = bb_pointer baseblock(ptr)+i; $ get one value.
79 if array = ar_val then $ compare const array.
80 if (val(vptr+i) ^= val(j)) quit until;
81 else $ parm. lists.
82 if (pdlist(vptr+i) ^= pdlist(j)) quit until;
83 end if;
84 end do;
vaxa 565 .+t32 end if;
85
86 $ found a matching entry at a different
87 $ location. therefore, the entry in the array
88 $ that is pointed to is redundant. so if the
89 $ pointer is set to the last used value, can
90 $ update the last used value.
91 if (vptr = rparrmx - (len-1)) rparrmx = vptr - 1;
92
93 $ return pointer.
94 optr = ptr; return;
95 end until;
96
97 $ this entry is not the one wanted. see if more in
98 $ clash chain.
99 if (bb_link baseblock(ptr) = 0) quit while; $ no more.
100 ptr = bb_link baseblock(ptr); $ else get pointer.
101 end while;
102
103 $ must look for a free entry from the top of the array.
104 do i = baseblockfree to 1 by -1; $ scan down.
105 if (bb_type baseblock(i)) cont do; $ not free.
106 baseblockfree = i-1; $ update free pointer.
107 bb_link baseblock(ptr) = i; $ add to clash chain.
108 ptr = i; $ point to entry.
109 quit until; $ show found entry.
110 end do;
111
112 $ else, base block is full.
113 call aermey(26); $ this is a fatal error.
114 end until;
115
116 $ finally, build entry.
117 optr = ptr; $ set return value.
118
119 baseent = 0; $ set entry to null.
120 bb_type baseent = type; $ set type.
121 bb_nwords baseent = len; $ set length.
122 bb_pointer baseent = vptr; $ set data pointer.
123
124 baseblock(ptr) = baseent; $ place in block.
125
126 $ if type is constant, will not assign address now.
127 if (type = bt_const) return; $ so just return.
128
129 $ assign address and chain to entries whose address have
130 $ been assigned.
131 bb_addr baseblock(ptr) = baselastaddr; $ set address.
132 if baselast then $ this is not first in chain.
133 bb_chain baseblock(baselast) = ptr; $ chain last to this.
134 else $ this is first in chain.
135 basefirst = ptr; $ show is first.
136 end if;
137
138 baselast = ptr; $ show last in chain.
139 baselastaddr = baselastaddr + len; $ increment base block address
vaxa 566 .+t32 if (array = ar_plist) baselastaddr = baselastaddr + 1;
140
141
142 end subr baseprober;
1 .=member countup
2 subr countupr(name); $ process array overflow.
3 $ this routine informs the user of an array overflow
4 $ and terminates the compilation.
5 size name(.sds. namelen); $ name of array.
6
7 terml(yes) textl(error_notice) textl('array ') textl(name)
8 textl(' overflowed. compilation aborted.') endl
9 textl('assembling ') textl(currsubname) endl
10 errno = errno+1;
11
12 exitcode = 1; call asmexit; $ terminate compilation.
13 end subr countupr;
1 .=member aermey
2 subr aermey(n); $ print fatal error message.
3 $ this routine is called to print fatal error messages
4 $ and abort the compilation.
5 size n(ps); $ error message number.
6 size i(ps); $ temporary.
7
8 +* ender = go to ret; ** $ abbreviation.
9
10 terml(yes) textl(system_notice) $ write header.
dse 26 if n <= 0 ! n >= 42 then $ bad number.
12 tintl('bad message number', n) ender
13 end if;
14
rka 12 go to e(n) in 1 to 41; $ print error message.
16
17 /e(1)/ tintl('invalid error number', n) ender
18 /e(2)/ textl('chaining error in label fixup') ender
19 /e(3)/ textl('format error on voa file') ender
20 /e(4)/ textl('unconverted return found') ender
21 /e(5)/ textl('invalid call to -assignr-') ender
22 /e(6)/ textl('inreg points to free item') ender
23 /e(7)/ textl('dummy item table is full') ender
24 /e(8)/ textl('dummy word table is full') ender
25 /e(9)/ textl('dummy register table is full') ender
26 /e(10)/ textl('bad temporary drop status') ender
27 /e(11)/ textl('attempt to clear address-float item') ender
28 /e(12)/ textl('attempt to clear temporary') ender
29 /e(13)/ textl('-ditem- on free chain twice') ender
30 /e(14)/ textl('-dword- on free chain twice') ender
31 /e(15)/ textl('-dreg- on free chain twice') ender
32 /e(16)/ textl('bad address value with no register') ender
33 /e(17)/ textl('bad call to -inzeror-') ender
34 /e(18)/ textl('bad call to -moveaddr-') ender
35 /e(19)/ textl('bad non-commutative operation') ender
36 /e(20)/ textl('not last word received in -emitsub-') ender
37 /e(21)/ textl('more than one word on chain') ender
38 /e(22)/ textl('no base register available') ender
39 /e(23)/ textl('not last word of arg. in -getdescr-') ender
40 /e(24)/ textl('bad unassigned address') ender
41 /e(25)/ textl('cannot get register pair') ender
42 /e(26)/ textl('base block is full') ender
43 /e(27)/ textl('disagreeing values in store of addrlive') ender
44 /e(28)/ textl('bad input to store addrlive') ender
45 /e(29)/ textl('cannot obtain space in -dops-') ender
46 /e(30)/ textl('live address present at block end') ender
47 /e(31)/ textl('improper drop status of temporaries') ender
48 /e(32)/ textl('attempt to drop permanent value') ender
49 /e(33)/ textl('reg should be sparereg') ender
50 /e(34)/ textl('unexpected gdfdreg call') ender
51 /e(35)/ textl('invalid address mode') ender
52 /e(36)/ textl('bad dopcode') ender
53 /e(37)/ textl('premature end on voa file') ender
54 /e(38)/ textl('constant conversion problem') ender
55 /e(39)/ textl('lablist overflow') ender
56 /e(40)/ textl('expect immediate mode') ender
dse 27 /e(41)/ textl('-in2- not constant for idt/imt') ender
57
58 /ret/ $ common termination code.
59 endl endl $ leave some space.
rke 12 terml(no);
60
61 .+trace. $ print info. describing error.
dso 13 if n ^= 13 & n ^= 14 & n ^= 15 & n ^= 21 then
62 tintl(' at error dopcode', dopcode)
63 tintl('voaep', voaep) tintl('vopcode', vopcode)
64 endl tintl(' dopir', dopir) tintl('dopjr', dopjr)
65 tintl('dopkr', dopkr) tintl('dopor', dopor)
66 tintl('dopnargs', dopnargs) tintl('dopnx', dopnx) endl
67 call dumpdregs; call dumpmregs;
dso 14 end if;
68 ..trace
69
70 exitcode = 1; call asmexit; $ terminate.
71
72 end subr aermey;
1 .=member asmexit
2 subr asmexit; $ code generator termination routine.
3 $ this routine terminates the code generation. it prints
4 $ statistics, closes files, and writes messages to the user.
5 size totwaste(ps); $ total wasted space.
6
7 $ first, write statistics if user wants them.
8 if lcs_opt then $ statistics wanted.
9 terml(no) $ just in case.
10 call stitlr(1, 'statistics for this code generation.');
11 ejectlp(13) endl $ start at new page if near end.
12
13 $ write out length statistics.
14
15 if totprocs>1 then $ if several procs, give total length.
16 intl(totprocs) textl(' procedures, estimate ')
17 intlp(totlength, 6) textl(' words.') endl
18 end if;
19
20 if totns>1 then $ if several namesets, give total length.
21 intl(totns) textl(' namesets with ')
22 intlp(totglobs, 6) textl(' words.') endl
23 end if;
24
25 endl
26
27 textl('compiler array usage') endl
28 textl('array name') tabl(19)
29 textl('length') tabl(30)
30 textl(' used ') tabl(39)
31 textl('unused') tabl(50)
32 textl('procedure') endl
33
34 +* arastat(lib, max, tot, rout, sz) = $ print line.
35 textl(lib) tabl(20)
36 intl(max) tabl(30)
37 intl(tot) tabl(40)
38 intl(max-tot) tabl(50)
39 textl(rout) endl
40 totwaste = totwaste + (max-tot);
41 **
42
43 totwaste = 0; $ show nothing wasted yet.
44 arastat('pdlist', pdlistdim, loadpd, loadrpd, 1);