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 /* program to compile a block
 12 
 13    Initial Version: 16 April 1971 by BLW for Version II
 14           Modified: 15 December 1972 by BLW
 15           Modified: 5 October 1975 by RAB to fix 1427
 16           Modified: 27 September 1976 by RAB to fix 1523
 17           Modified: 15 August 1977 by RAB to fix 1654
 18           Modified: 30 November 1978 by RAB to fix 1789
 19                     (bad storage allocation in quick begin blocks
 20                      contained within quick procedures)     */
 21 
 22 compile_block: proc(pt);
 23 
 24 dcl       pt ptr;             /* points at a block node */
 25 
 26 dcl       (cg_stat$cur_block,cg_stat$text_base,cg_stat$sym_base,
 27            cg_stat$prol_ent,cg_stat$root,cg_stat$cur_entry,
 28            cg_stat$sym_reloc_base,cg_stat$m_s_p,cg_stat$cur_statement,
 29            cg_stat$link_base,cg_stat$link_reloc_base,cg_stat$agg_temps,
 30            cg_stat$profile_base) ptr ext static,
 31           (cg_stat$text_pos,cg_stat$sym_pos,cg_stat$cur_level,cg_stat$profile_pos,cg_stat$map_start) fixed bin(18) ext,
 32           (cg_stat$table_option,cg_stat$in_prologue,cg_stat$skip_to_label,
 33            cg_stat$generate_map,cg_stat$old_id,cg_stat$profile_option,cg_stat$extended_stack) bit(1) ext;
 34 
 35 dcl       1 cg_stat$statement_map       unaligned ext,
 36           2 first             bit(18),
 37           2 last              bit(18);
 38 
 39 dcl       (bp,fp,sp,p,q,prol_save,entry_save,pl) ptr,
 40           n fixed bin,
 41           sym_pos fixed bin(18),
 42           bt bit(9),
 43           unused bit(1) aligned;
 44 
 45 dcl       (addrel,fixed,max,null,size,string) builtin;
 46 
 47 dcl       create_list entry(fixed bin) returns(ptr),
 48           create_label entry(ptr,ptr,bit(3) aligned) returns(ptr),
 49           (compile_block,compile_statement) entry(ptr),
 50           c_a entry(fixed bin,fixed bin) returns(ptr),
 51           (state_man$flush,io_op$init_ps) entry,
 52           state_man$create_ms entry returns(ptr),
 53           make_mod entry(fixed bin(17),fixed bin) returns(fixed bin(18)),
 54           prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
 55           expmac$fill_usage entry(fixed bin(18),fixed bin(17)),
 56           expmac$zero entry(fixed bin(15)),
 57           expmac entry(fixed bin(15),ptr),
 58           stack_temp$free_aggregates entry;
 59 
 60 dcl (     enter_prologue      init(202),
 61           leave_prologue      init(203),
 62           tra                 init(169)) fixed bin(15) int static;
 63 
 64 dcl       1 eax_ins           aligned based,
 65           2 offset            unal bit(18);
 66 
 67 dcl       relocation bit(36) aligned based;
 68 
 69 %include block;
 70 %include reference;
 71 %include statement;
 72 %include list;
 73 %include label;
 74 %include runtime_symbol;
 75 %include statement_map;
 76 %include profile_entry;
 77 %include declare_type;
 78 %include block_types;
 79 %include relbts;
 80 
 81           bp = pt;
 82           if bp = null then return;
 83 
 84           bt = bp -> block.block_type;
 85           if bt = begin_block
 86           then do;
 87 db:            call compile_block((bp -> block.brother));
 88                return;
 89                end;
 90 
 91           if bt = on_unit then goto db;
 92 
 93           goto l1;
 94 
 95 compile_block$begin_block: entry(pt);
 96 
 97           bp = pt;
 98           bt = bp -> block.block_type;
 99 
100           /* since we are doing a transition from one block to another,
101              block.last_auto_loc must be up to date (fixes 1789)      */
102 
103           if bp -> block.no_stack & cg_stat$cur_block -> block.no_stack
104           then do;
105                fp = cg_stat$cur_block;
106 
107                do while(fp -> block.no_stack);
108                     if fp -> block.owner = null
109                          then fp = fp -> block.father;
110                          else fp = fp -> block.owner;
111                     end;
112 
113                fp -> block.last_auto_loc = max(fp -> block.last_auto_loc, cg_stat$cur_block -> block.last_auto_loc);
114                end;
115 
116 l1:       cg_stat$cur_block, fp = bp;
117 
118           if bp -> block.no_stack
119           then do;
120 
121                /* get ptr to block in which storage should be allocated */
122 
123                do while(fp -> block.no_stack);
124                     if fp -> block.owner = null then fp = fp -> block.father;
125                     else fp = fp -> block.owner;
126                     end;
127 
128                bp -> block.last_auto_loc = fp -> block.last_auto_loc;
129                end;
130 
131           cg_stat$cur_level = bp -> block.level;
132 
133           if cg_stat$m_s_p = null then cg_stat$m_s_p = state_man$create_ms(); else call state_man$flush;
134 
135           bp -> block.free_temps(1),
136           bp -> block.free_temps(2),
137           bp -> block.free_temps(3) = null;
138 
139           entry_save = cg_stat$cur_entry;
140           cg_stat$cur_entry = null;
141 
142           prol_save = cg_stat$prol_ent;
143 
144           /* if there is only one entry to this block, we don't compile the prologue
145              sequence;  the entire prologue sequence will be inserted into the
146              main sequence by compile_tree when it sees the ex_prologue operator.
147              if there is more than one entry, we must compile prologue as a closed
148              subroutine, in this case cg_stat$prol_ent will point to a dummy
149              label used to identify start of prologue.  There is a different
150              label for each procedure | begin block */
151 
152           cg_stat$prol_ent = null;
153 
154           p = bp -> block.prologue;
155           if p = null
156           then if bp -> block.plio_ps = null
157                then goto do_main;
158 
159           if bp -> block.number_of_entries = 1 then goto do_main;
160 
161           cg_stat$in_prologue = "1"b;
162           cg_stat$skip_to_label = "0"b;
163 
164           if bt ^= begin_block
165           then do;
166                cg_stat$prol_ent = create_label((bp),null,by_compiler);
167                cg_stat$prol_ent -> label.location = cg_stat$text_pos;
168                cg_stat$prol_ent -> label.allocated = "1"b;
169 
170                bp -> block.enter.start = cg_stat$text_pos;
171 
172                n = bp -> block.last_auto_loc;
173                bp -> block.last_auto_loc = n + 1;
174 
175                call expmac((enter_prologue),c_a(n,4));
176                bp -> block.enter.end = cg_stat$text_pos;
177                end;
178 
179           if bp -> block.plio_ps ^= null
180           then do;
181                if bt = begin_block then bp -> block.enter.start = cg_stat$text_pos;
182                call io_op$init_ps;
183                bp -> block.enter.end = cg_stat$text_pos;
184                end;
185 
186           do while(p ^= null);
187                call compile_statement(p);
188                p = p -> statement.next;
189                end;
190 
191           if bt ^= begin_block
192           then do;
193                bp -> block.leave.start = cg_stat$text_pos;
194                call expmac((leave_prologue),c_a(n,4));
195                bp -> block.leave.end = cg_stat$text_pos;
196                call state_man$flush;
197                end;
198 
199           /* initialize object map if we're generating a symbol table */
200 
201 do_main:  if cg_stat$generate_map
202           then do;
203                sp = addrel(cg_stat$sym_base,bp -> block.symbol_block);
204                sp -> runtime_block.map.first = bit(fixed(cg_stat$sym_pos -
205                 bp -> block.symbol_block,18),18);
206                cg_stat$old_id = "0"b;
207                end;
208 
209           cg_stat$in_prologue = "0"b;
210 
211           /* compile main sequence */
212 
213           p = bp -> block.main;
214           do while(p ^= null);
215                call compile_statement(p);
216                p = p -> statement.next;
217                end;
218 
219           cg_stat$extended_stack = "0"b;          /* fixes 1654 */
220 
221           if bp -> block.no_stack then fp -> block.last_auto_loc =
222            max(fp -> block.last_auto_loc,bp -> block.last_auto_loc);
223 
224           /* free any aggregate temps that have not already been freed */
225 
226           if cg_stat$agg_temps ^= null
227                then call stack_temp$free_aggregates;
228 
229           /* do son block */
230 
231           p = bp -> block.son;
232           if p ^= null
233           then do;
234 
235                /* if this is a begin block, we must generate a transfer around
236                   the code for internal procedures */
237 
238                if bt = begin_block
239                then do;
240 
241                     q = p;
242                     do while(q ^= null);
243 
244                          if q -> block.block_type = internal_procedure
245                          then do;
246 
247                               q = create_label((bp),null,by_compiler);
248                               call expmac((tra),prepare_operand(q,1,unused));
249                               cg_stat$cur_statement -> statement.object.finish =
250                                cg_stat$cur_statement -> statement.object.finish + 1;
251                               goto l2;
252                               end;
253 
254                          q = q -> block.brother;
255                          end;
256                     end;
257 
258 l2:            call compile_block(p);
259 
260                if bt = begin_block
261                then if q ^= null
262                     then call expmac$fill_usage(cg_stat$text_pos,(q -> label.location));
263 
264                end;
265 
266           if bp -> block.no_stack
267           then do;
268 
269                /* update total automatic storage used in block holding allocations
270                   for this quick block.  if that block is a brother, it may have
271                   already been completely compiled, so we may have to fill in the
272                   stack size again */
273 
274                fp -> block.last_auto_loc = max(fp -> block.last_auto_loc,bp -> block.last_auto_loc);
275                if fp -> block.processed then call fill_stack(fp);
276                end;
277           else call fill_stack(bp);
278 
279           bp -> block.processed = "1"b;
280 
281 chk_st:   if ^ cg_stat$generate_map then goto chk_pf;
282 
283           if bp = cg_stat$root
284           then do;
285 
286                /* just finished root block, put dummy at end of map */
287 
288                sym_pos = cg_stat$sym_pos;
289                q = addrel(cg_stat$sym_base,sym_pos);
290                q -> statement_map.location = bit(cg_stat$text_pos,18);
291                string(q -> statement_map.source_id) = (27)"1"b;
292                addrel(cg_stat$sym_reloc_base,sym_pos) -> relocation = rc_t;
293                cg_stat$sym_pos = cg_stat$sym_pos + size(q -> statement_map);
294                cg_stat$statement_map.last = bit(cg_stat$sym_pos,18);
295                end;
296 
297           sp -> runtime_block.map.last = bit(fixed(cg_stat$sym_pos - bp -> block.symbol_block,18),18);
298 
299 chk_pf:   if ^ cg_stat$profile_option then goto do_bro;
300 
301           if bp ^= cg_stat$root then goto do_bro;
302 
303           /* put dummy entry at end of profile */
304 
305           addrel(cg_stat$profile_base,cg_stat$profile_pos) -> profile_entry.map = bit(fixed(sym_pos - cg_stat$map_start,18),18);
306 
307 do_bro:   if bt ^= begin_block
308           then if bt ^= on_unit
309                then if bp -> block.brother ^= null
310                     then call compile_block((bp -> block.brother));
311 
312           cg_stat$prol_ent = prol_save;
313           cg_stat$cur_entry = entry_save;
314 
315 fill_stack:    proc(blk);
316 
317 dcl            blk ptr;
318 
319 dcl            stack_size bit(18),
320                (p,q) ptr;
321 
322                /* fill stack size into first instruction (eaxy) of each entry
323                   in this block */
324 
325                stack_size = bit(make_mod(blk -> block.last_auto_loc,16),18);
326                p = blk -> block.entry_list;
327 
328                if blk -> block_type = begin_block
329                then do;
330                     p -> eax_ins.offset = stack_size;
331                     return;
332                     end;
333 
334                do while(p ^= null);
335                     q = p -> element(2) -> statement.labels -> element(2) -> reference.symbol;
336                     addrel(cg_stat$text_base,q -> label.location) -> eax_ins.offset = stack_size;
337                     p = p -> element(1);
338                     end;
339 
340                end;
341 
342           end;