1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 /* Procedure to manage allocation of temporaries in stack
 12 
 13           Modified: 23 April 1973 by RAB
 14           Modified: 1 May 1977 by RAB to fix bug in assign_aggregate
 15           Modified: 10 September 1977 by RAB to fix 1613 by setting temporary.last_freed
 16           Modified 780717 by PG to count number of temporary nodes allocated
 17           Modified 791016 by PG to check temporary.ref_count < 0
 18 */
 19 
 20 stack_temp$assign_temp: proc(ref_pt) ;
 21 
 22 /* parameters */
 23 
 24 dcl       ref_pt ptr parameter;         /* points at temp reference to be allocated */
 25 
 26 /* external static */
 27 
 28 dcl       (cg_stat$cur_block,cg_stat$cur_statement,cg_stat$agg_temps) ptr ext,
 29           cg_stat$max_stack_size fixed bin ext,
 30           cg_stat$text_pos fixed bin(18) ext,
 31           cg_stat$extended_stack bit(1) ext,
 32           pl1_stat_$node_uses (18) fixed bin external static;
 33 
 34 /* automatic */
 35 
 36 dcl       (p,r,s,o) ptr,
 37           atomic bit(1) aligned,
 38           (size,bit_length) fixed bin;
 39 
 40 /* entries */
 41 
 42 dcl       error entry(fixed bin,ptr,ptr),
 43           cg_error entry(fixed bin,fixed bin),
 44           prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
 45           compile_exp entry(ptr),
 46           expmac$zero entry(fixed bin(15)),
 47           expmac entry(fixed bin(15),ptr),
 48           c_a entry(fixed bin(18),fixed bin) returns(ptr);
 49 
 50 /* internal static */
 51 
 52 dcl (     alloc_words         init(91),
 53           store_bp            init(61)) fixed bin(15) int static;
 54 
 55 /* builtins */
 56 
 57 dcl       (bin, divide, mod, null) builtin;
 58 
 59 /* include files */
 60 
 61 %include pl1_tree_areas;
 62 %include temporary;
 63 %include nodes;
 64 %include block;
 65 %include reference;
 66 %include symbol;
 67 %include machine_state;
 68 %include cgsystem;
 69 %include data_types;
 70 ^L
 71 /* program */
 72 
 73           r = ref_pt;
 74           s = r -> reference.symbol;
 75 
 76           if r -> reference.aggregate
 77           then do;
 78 
 79                /* this is aggregate temp so assign storage to level 1 ancestor
 80                   if none already assigned */
 81 
 82                r -> reference.allocated = "1"b;
 83 
 84                do p = s repeat(p -> symbol.father) while(p -> symbol.father ^= null);
 85                     end;
 86 
 87                if p -> symbol.initial = null then goto agg; else return;
 88                end;
 89 
 90           if s = null
 91           then if r -> reference.data_type = 0
 92                then size = r -> reference.c_length;
 93                else go to get_length;
 94           else if s -> symbol.temporary
 95                then size = s -> symbol.c_word_size;
 96                else do;
 97 get_length:         bit_length = r -> reference.c_length;
 98                     if r -> reference.data_type = char_string
 99                          then bit_length = bit_length * bits_per_char;
100                     size = divide(bit_length+bits_per_word-1,bits_per_word,17,0);
101                     end;
102 
103 common:   r -> reference.qualifier = get_temp(size);
104           r -> reference.qualifier -> temporary.ref_count = 1;
105           r -> reference.allocated = "1"b;
106 
107           if ^ r -> reference.address_in.storage
108           then if r -> reference.varying_ref
109                then r -> reference.c_offset = r -> reference.c_offset + 1;
110 
111           return;
112 
113 stack_temp$assign_block: entry(ref_pt,amount);
114 
115 dcl       amount fixed bin;
116 
117           r = ref_pt;
118           size = amount;
119           goto common;
120 
121 stack_temp$free_temp: entry(ref_pt);
122 
123           r = ref_pt;
124 
125           s = r -> reference.qualifier;
126           if s = null then return;
127 
128           if s -> node.type ^= temporary_node then return;
129 
130           if (r -> reference.ref_count < 0) | (s -> temporary.ref_count < 0)
131           then do;
132                call error(314,cg_stat$cur_statement,r);
133                return;
134                end;
135 
136           r -> reference.qualifier = null;
137 
138           call put_temp(s);
139           return;
140 
141 stack_temp$assign_return_value:         entry(sym_pt);
142 
143           p = sym_pt;
144 
145           r = get_temp(2);
146           p -> symbol.initial = r;
147 
148           go to chain_agg;
149 
150 stack_temp$assign_aggregate: entry(sym_pt);
151 
152 dcl       sym_pt ptr;
153 
154           p = sym_pt;
155 
156 agg:      if p -> symbol.word_size = null then size = p -> symbol.c_word_size;
157           else do;
158                o = p -> symbol.word_size;
159                r = prepare_operand(o,1,atomic);
160                call compile_exp(o);
161                call expmac$zero((alloc_words));
162                cg_stat$extended_stack = "1"b;
163                size = 2;
164                end;
165 
166           r = get_temp(size);
167           p -> symbol.initial = r;
168 
169           if p -> symbol.word_size ^= null
170           then do;
171                call expmac((store_bp),c_a(r -> temporary.location,4));
172                base_regs(1).type = 3;
173                base_regs(1).constant = r -> temporary.location;
174                end;
175 
176 chain_agg:
177           r -> temporary.symbol = p;
178           r -> temporary.next = cg_stat$agg_temps;
179           cg_stat$agg_temps = r;
180 
181           return;
182 
183 stack_temp$free_aggregates: entry;
184 
185           p = cg_stat$agg_temps;
186           do while(p ^= null);
187                p -> temporary.symbol -> symbol.initial = null;
188                r = p -> temporary.next;
189                call put_temp(p);
190                p = r;
191                end;
192 
193           cg_stat$agg_temps = null;
194           return;
195 
196 get_temp:      proc(amount) returns(ptr);
197 
198 dcl            (amount,amt,loc,i) fixed bin,
199                (cb,s,prev,p) ptr;
200 
201                cb = cg_stat$cur_block;
202                loc = cb -> block.last_auto_loc;
203 
204                amt = amount;
205                if amt >= 3 then goto big;
206 
207                if amt = 0 then amt = 1;
208 
209                i = amt;
210                p = cb -> block.free_temps(i);
211 
212                if p ^= null
213                then do;
214 l0:                 cb -> block.free_temps(i) = p -> temporary.next;
215 l1:                 return(p);
216                     end;
217 
218                if i = 1
219                then do;
220 l3:                 p = create_temp(amt);
221                     cb -> block.last_auto_loc = loc + amt;
222 
223                     if cb -> block.last_auto_loc > cg_stat$max_stack_size
224                     then call cg_error(308,cg_stat$max_stack_size);
225 
226                     goto l1;
227                     end;
228 
229 l4:            if mod(loc,2) = 0 then goto l3;
230 
231                p = create_temp(1);
232                p -> temporary.next = cb -> block.free_temps(1);
233                cb -> block.free_temps(1) = p;
234                loc = loc + 1;
235                goto l3;
236 
237 big:           prev = null;
238                i = 3;
239                p = cb -> block.free_temps(3);
240 
241                do while(p ^= null);
242 
243                     if p -> temporary.size >= amt
244                     then do;
245                          if prev = null then goto l0;
246                          prev -> temporary.next = p -> temporary.next;
247                          goto l1;
248                          end;
249 
250                     prev = p;
251                     p = p -> temporary.next;
252                     end;
253 
254                goto l4;
255 
256 put_temp:      entry(temp);
257 
258 dcl            temp ptr;
259 
260                cb = cg_stat$cur_block;
261 
262                s = temp;
263                s -> temporary.last_freed = cg_stat$text_pos;
264                i, amt = s -> temporary.size;
265 
266                if i < 3
267                then do;
268 l5:                 s -> temporary.next = cb -> block.free_temps(i);
269                     cb -> block.free_temps(i) = s;
270                     return;
271                     end;
272 
273                prev = null;
274                i = 3;
275                p = cb -> block.free_temps(3);
276 
277                do while(p ^= null);
278 
279                     if amt < p -> temporary.size
280                     then do;
281 l6:                      if prev = null then goto l5;
282                          s -> temporary.next = prev -> temporary.next;
283                          prev -> temporary.next = s;
284                          return;
285                          end;
286 
287                     prev = p;
288                     p = p -> temporary.next;
289                     end;
290 
291                goto l6;
292 
293 create_temp:        proc(number) returns(ptr);
294 
295 dcl                 number fixed bin,
296                     q ptr;
297 
298                     allocate temporary in(xeq_tree_area) set(q);
299                     pl1_stat_$node_uses (bin (temporary_node, 9)) = pl1_stat_$node_uses (bin (temporary_node, 9)) + 1;
300                     q -> temporary.node_type = temporary_node;
301                     q -> temporary.location = loc;
302                     q -> temporary.size = number;
303                     return(q);
304 
305                     end;
306 
307                end;
308 
309           end;