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 index registers
 12 
 13    Initial Version: 23 November, 1968 by BLW
 14           Modified: 18 May, 1971 by BLW for Version II
 15           Modified: 13 September, 1972 by BLW
 16           Modified: 11 February, 1973 by RAB
 17           Modified: 15 October 1975 by RAB for update_xr
 18           Modified: 3 November 1976 to fix 1545 by RAB
 19           Modified: 25 March 1977 by RAB to fix 1599
 20           Modified: 14 August 1978 by RAB to fix 1727
 21           Modified: 28 May 1979 by RAB to fix 1831 (a(b(i+j)-1) = 0;
 22                     i = b(i+j); gets ERROR 315)
 23           Modified: 29 May 1979 by RAB to make minor changes to
 24                     get_free_index, flush_old, and load_xr_v
 25 
 26    xr_man has the following entries:
 27 
 28    load_any_var     tries to find an index already holding specified
 29                     variable.  if none exists, a new one is loaded.
 30 
 31    load_any_const   tries to find an index already holding specified
 32                     constant.  if none exists, a new one is loaded
 33 
 34    load_var         loads specified index with variable unless index
 35                     already holds variable
 36 
 37    load_const       loads specified index with constant unless index
 38                     already holds constant
 39 
 40    lock             "locks" a variable in the index register in which
 41                     it is known to be available;  a locked variable
 42                     will be unloaded only if all the index registers
 43                     become locked
 44 
 45    unlock           "unlocks" a variable
 46 
 47    super_lock       "super_locks" a variable in the index register in which it
 48                     is known to be available.  A super_locked register cannot
 49                     be unloaded.  This entry is called only from make_both_addressable.
 50 
 51    super_unlock     unlocks a register that was "super_locked"
 52 
 53    add_any_const    adds the contents of specified index register to specified constant
 54                     and places result in any index register
 55 
 56    update_xr        updates the machine state to say that a variable is in the
 57                     specified index
 58 
 59    The field "type" has the following meanings:
 60 
 61           0         empty
 62 
 63           1         constant
 64 
 65           2         variable + constant
 66 
 67           3         locked variable + constant
 68 
 69           -n        super_locked register of type n
 70 
 71                                                             */
 72 
 73 xr_man$load_any_var: proc(var,xr,base_offset);
 74 
 75 dcl       var       ptr,                /* points at var to be loaded */
 76           xr        fixed bin,          /* specifies index to load or loaded */
 77           base_offset fixed bin(18);    /* base offset to add to var */
 78 
 79 dcl       cg_stat$last_index_used fixed bin ext,
 80           (cg_stat$text_pos,cg_stat$last_call) fixed bin(18) ext,
 81           (cg_stat$text_base,cg_stat$cur_statement) ptr ext,
 82           macro_table_$eax_array(0:15) fixed bin(15) ext static;
 83 
 84 dcl       (p,vp) ptr,
 85           c fixed bin(18),
 86           sta_code bit(9) int static init("111101101"b),
 87           stq_code bit(9) int static init("111101110"b),
 88           staq_code bit(9) int static init("111101111"b),
 89           (i,j,k,type) fixed bin,
 90           lock bit(1) aligned init("0"b),
 91           expmac entry(fixed bin(15),ptr),
 92           c_a entry(fixed bin(18),fixed bin) returns(ptr),
 93           get_single_ref entry(ptr) returns(ptr),
 94           stack_temp$free_temp entry(ptr),
 95           adjust_ref_count entry(ptr,fixed bin),
 96           m_a entry(ptr,bit(2) aligned),
 97           error entry(fixed bin,ptr,ptr);
 98 
 99 dcl       (abs,addrel,bit,fixed,min,mod,null,ptr,rel,string,substr) builtin;
100 
101 dcl       word fixed bin based(p);
102 
103 dcl       full_word bit(36) aligned based(p);
104 
105 dcl       1 instruction       aligned based(p),
106           2 offset            unal bit(18),
107           2 op_code           unal bit(9),
108           2 rest              unal bit(9);
109 
110 dcl (     first_index         init(2),
111           last_index          init(7)) fixed bin int static;
112 
113 dcl       zero_mac            init(308) fixed bin(15) int static;
114 
115 %include cgsystem;
116 %include data_types;
117 %include boundary;
118 %include machine_state;
119 %include reference;
120 %include temporary;
121 %include symbol;
122 %include operator;
123 %include nodes;
124 %include "645op5";
125 
126           /* get ptr to variable */
127 
128 join:     vp = var;
129 
130           j,k = -1;
131 
132           do i = first_index to last_index;
133                type = abs(index_regs(i).type);
134                if type = 0 then k = i;
135                else if type >= 2
136                     then if index_regs(i).variable = vp
137                          then do;
138                               j = i;
139                               if index_regs(i).constant = base_offset then goto set_i_dec;
140                               end;
141                end;
142 
143           /* must load a register */
144 
145           call when_to_m_a;
146           call get_free_index;
147           c = base_offset;
148           call load_xr_v(k);
149 
150 ret_k:    xr = k;
151           if lock
152                then index_regs(xr).type = -abs(index_regs(xr).type);
153           return;
154 
155 set_i_dec:
156           if ^ vp -> reference.shared then call adjust_ref_count(vp,-1);
157 
158 set_i:    index_regs(i).used = cg_stat$text_pos;
159 
160           xr = i;
161           if lock
162                then index_regs(xr).type = -abs(index_regs(xr).type);
163           return;
164 
165 xr_man$load_any_const: entry(const,xr);
166 
167 dcl       const     fixed bin(18);      /* value of constant to be loaded */
168 
169           k = -1;
170           do i = first_index to last_index;
171                type = abs(index_regs(i).type);
172                if type = 0 then k = i;
173                else if type = 1
174                     then if index_regs(i).constant = const then goto set_i;
175                end;
176 
177           /* did not have index register holding exact value of
178              the constant, must load one */
179 
180           call get_free_index;
181           call load_xr_c(k);
182           goto ret_k;
183 
184 xr_man$load_var: entry(var,xr);
185 
186           i = xr;
187 
188           vp = var;
189 
190           if index_regs(i).type < 2 then goto lv;
191           if index_regs(i).variable ^= vp then goto lv;
192           if index_regs(i).constant = 0
193           then do;
194                if ^ vp -> reference.shared
195                then call adjust_ref_count(vp,-1);
196                goto lc_used;
197                end;
198 
199 lv:       c = 0;
200           j,k = -1;
201           cg_stat$last_index_used = i;
202           call when_to_m_a;
203           call load_xr_v(xr);
204           return;
205 
206 xr_man$load_const:  entry(const,xr);
207 
208           i = xr;
209           if index_regs(i).type ^= 1 then goto lc;
210 
211           if index_regs(i).constant = const
212           then do;
213 lc_used:       index_regs(i).used = cg_stat$text_pos;
214                return;
215                end;
216 
217 lc:       call load_xr_c(xr);
218           cg_stat$last_index_used = i;
219           return;
220 
221 
222 xr_man$lock: entry(var,xr);
223 
224           i = xr;
225           var -> reference.value_in.x(i) = "1"b;
226           index_regs(i).variable = var;
227           index_regs(i).type = 3;
228           return;
229 
230 xr_man$unlock: entry(ix);
231 
232 dcl       ix fixed bin;
233 
234           index_regs(ix).type = 2;
235           return;
236 
237 
238 xr_man$super_lock:  entry(ix);
239 
240           index_regs(ix).type = -abs(index_regs(ix).type);
241           return;
242 
243 
244 xr_man$super_unlock:          entry(ix);
245 
246           index_regs(ix).type = abs(index_regs(ix).type);
247           return;
248 
249 
250 xr_man$add_any_const:         entry(const,xr,old_xr);
251 
252 dcl       old_xr fixed bin;
253 
254           j = old_xr;
255           c = index_regs(j).constant + const;
256 
257           if index_regs(j).type >= 2
258           then do;
259                vp = index_regs(j).variable;
260 
261                if ^ vp -> reference.shared
262                     then vp -> reference.ref_count = vp -> reference.ref_count + 1;
263 
264                call xr_man$load_any_var(vp,xr,c);
265 
266                end;
267           else call xr_man$load_any_const(c,xr);
268 
269           return;
270 
271 
272 xr_man$load_any_var_and_lock: entry(var,xr,base_offset);
273 
274           lock = "1"b;
275           go to join;
276 
277 
278 xr_man$update_xr:   entry(var,xr);
279 
280           vp = var;
281           i = xr;
282 
283           call flush_old(i);
284 
285           vp -> reference.value_in.x(i) = "1"b;
286           index_regs(i).type = 2;
287           index_regs(i).variable = vp;
288           index_regs(i).constant = 0;
289           index_regs(i).used = cg_stat$text_pos;
290           return;
291 
292 /* ^L */
293 
294 
295 when_to_m_a:        proc;
296 dcl       p ptr;
297 
298 /* Decide whether we must make vp addressable before looking for a free index register
299    and loading vp */
300 
301           if j >= 0 then return;
302           if vp->reference.value_in.a then return;
303           if vp->reference.value_in.q then return;
304           if string(vp->reference.value_in.x) then return;
305           if ^ vp -> reference.no_address
306                then if vp -> reference.perm_address
307                          then return;
308 
309           do p = vp->reference.offset repeat p->reference.offset while (p ^= null);
310                     if p->node.type = operator_node
311                          then p = p->operand(1);
312                     if p->reference.ref_count > 1
313                      | p -> reference.temp_ref & string(p -> reference.value_in.x) = "0"b
314                     then do;
315                               call m_a(vp,"0"b);
316                               vp->reference.perm_address = "1"b;
317                               if k >= 0
318                                    then if index_regs(k).type ^= 0
319                                         then do;
320                                                   k = -1;
321                                                   do i = first_index to last_index;
322                                                             if index_regs(i).type = 0
323                                                                  then k = i;
324                                                   end;
325                                              end;
326                               return;
327                          end;
328           end;
329 end;
330 
331 
332 
333 /* ^L */
334 get_free_index: proc;
335 
336                /* if an empty register was found during scan use that,
337                   otherwise, try to pick a register containing a constant;
338                   if none, try to pick register containing unlocked
339                   variable with smallest reference count; as a last
340                   resort, pick locked variable with smallest reference
341                   count */
342 
343 dcl            (i,j,cmin,ignore,n,type) fixed bin,
344                p ptr;
345 
346                /* note: variable 'k' lives in outer block */
347 
348                if k >= 0
349                then do;
350                     cg_stat$last_index_used = k;
351                     return;
352                     end;
353 
354                ignore = 3;                        /* ignore locked vars */
355 
356 look:          j = -1;
357                cmin = 123456;
358 
359                do i = cg_stat$last_index_used + 1 to last_index, first_index to min(cg_stat$last_index_used,last_index);
360 
361                     type = index_regs(i).type;
362 
363                     if type >= 0 & type ^= ignore
364                     then do;
365 
366                          if type = 0 | type = 1
367                          then do;
368                               k, cg_stat$last_index_used = i;
369                               return;
370                               end;
371 
372                          p = index_regs(i).variable;
373 
374                          if p -> reference.shared
375                          then if p -> reference.temp_ref
376                               then n = 0;
377                               else n = 1;
378                          else n = p -> reference.ref_count;
379 
380                          if n = 0
381                          then do;
382                               k, cg_stat$last_index_used = i;
383                               return;
384                               end;
385 
386                          if n < cmin
387                          then do;
388                               j = i;
389                               cmin = n;
390                               end;
391                          else if n = cmin
392                               then if index_regs(i).used < index_regs(j).used
393                                    then do;
394                                         j = i;
395                                         cmin = n;
396                                         end;
397                          end;
398 
399                     end;
400 
401                if j >= 0
402                then do;
403                     k, cg_stat$last_index_used = j;
404                     return;
405                     end;
406 
407                /* we should never get here with ignore already = 2 */
408 
409                if ignore = 3
410                then do;
411                     ignore = 2;
412                     goto look;
413                     end;
414 
415                call error(328,cg_stat$cur_statement,vp);
416                k = 1;
417                end;
418 
419 /* ^L */
420 load_xr_v:     proc(xr);
421 
422 dcl            xr   fixed bin;          /* index to load */
423 
424 dcl            (p,q,old_p,text_pt) ptr,
425                x fixed bin,
426                b18 bit(18),
427                (n,text_pos,c1,i) fixed bin(18),
428                op_code bit(9) aligned;
429 
430                x = xr;
431                p, q = vp;
432 
433                c1 = c;
434                if c1 < 0 then c1 = c1 + 262144;             /* 2's complement */
435 
436                if p -> reference.value_in.q
437                then do;
438                     n = 0;
439                     goto l2;
440                     end;
441 
442                if p -> reference.value_in.a
443                then if p -> reference.aligned_ref | a_reg.offset = 0 | a_reg.offset = 18
444                then do;
445                     if ^ p -> reference.aligned_ref & a_reg.offset = 0
446                          then n = 16;
447                          else n = 8;
448 l2:
449                     call flush_old(x);
450 
451                     text_pos = cg_stat$text_pos;
452                     cg_stat$text_pos = cg_stat$text_pos + 1;
453                     goto l3;
454                     end;
455 
456                if j >= 0
457                then do;
458 
459                     /* value of variable is in another index with different
460                        base_offset, we can generate the instruction
461                               eaxx      diff,j                        */
462 
463                     call flush_old(x);
464 
465                     old_p = c_a((j),8);
466                     c1 = c - index_regs(j).constant;
467                     if c1 < 0 then c1 = c1 + 262144;
468                     substr(string(old_p -> reference.address),1,18) = bit(c1,18);
469                     call expmac(eax0+x,old_p);
470                     if ^p -> reference.shared
471                          then call adjust_ref_count(p,-1);
472                     goto l4;
473                     end;
474 
475                if p -> reference.value_in.storage then goto test;
476 
477                if ^ p -> reference.temp_ref then goto gen_lxl;
478 
479                if p -> reference.aggregate then goto gen_lxl;
480 
481                call error(315,cg_stat$cur_statement,p);
482 
483 test:          if p -> reference.symbol -> symbol.c_dcl_size >= bits_per_half then goto gen_lxl;
484 
485                text_pos = fixed(p -> reference.store_ins,18);
486                if text_pos < cg_stat$last_call then goto gen_lxl;
487 
488                if c ^= 0
489                then if ^ p -> reference.dont_save
490                     then go to gen_lxl;
491 
492                if index_regs(x).used >= text_pos
493                then do;
494 gen_lxl:            if p -> reference.data_type = real_fix_bin_2
495                          then q = get_single_ref(p);
496 
497                     n = lxl0;
498                     if ^ p -> reference.aligned_ref
499                     then if p -> reference.units = word_
500                          then n = ldx0;
501 
502                     if ^ q -> reference.perm_address
503                     then do;
504                          call m_a(q,"00"b);
505                          q -> reference.perm_address = "1"b;
506                          end;
507 
508                     call flush_old(x);
509 
510                     call expmac(n+x,q);
511                     if c ^= 0
512                     then do;
513                          old_p = c_a(c,1);
514                          old_p -> reference.tag = "001"b || bit(fixed(x,3),3);
515                          call expmac(eax0+x,old_p);
516                          end;
517                     end;
518 
519                else do;
520 
521                     /* the index register was not used from the point of the
522                        store instruction which evaluated the expression to
523                        the current instruction.  we'll attempt to change the
524                        store instruction into an eax instruction */
525 
526                     text_pt = addrel(cg_stat$text_base,text_pos);
527                     op_code = text_pt -> instruction.op_code;
528 
529                     if op_code = sta_code then n = 8;
530                     else if op_code = stq_code then n = 0;
531                          else if op_code = staq_code then n = 0;
532                               else goto gen_lxl;
533 
534                     /* make sure that the value was not used from the time it was
535                        put in storage.  we do this by looking for the address of
536                        the temporary being used.  This prevents a bug which might
537                        occur in the sequence
538                               dcl (a(10),b(10,10)) fixed bin;
539                               a(k) = b(k,k);
540                        where we might otherwise change "stq temp" into "eaxn 0,ql"
541                        even though sequence for calculating b's subscript did
542                        "adq temp"       */
543 
544                     b18 = "110"b || bit(fixed(mod(p -> reference.qualifier -> temporary.location,16384),15),15);
545                     do i = text_pos + 1 to cg_stat$text_pos - 1;
546                          if b18 = addrel(cg_stat$text_base,i) -> instruction.offset then goto gen_lxl;
547                          end;
548 
549                     call flush_old(x);
550 
551                     call stack_temp$free_temp(p);
552                     p -> reference.allocated = "0"b;
553                     p -> reference.store_ins = "0"b;
554                     p -> reference.value_in.storage = "0"b;
555 
556 l3:                 index_regs(x).changed = text_pos;
557                     text_pt = addrel(cg_stat$text_base,text_pos);
558 
559                     text_pt -> word = macro_table_$eax_array(n+x);
560 
561                     if c ^= 0
562                     then do;
563                          if c > 0
564                               then c1 = c;
565                               else c1 = c + 262144;
566                          text_pt -> instruction.offset = bit(c1,18);
567                          end;
568 
569                     index_regs(x).instruction = text_pt -> full_word;
570 
571                     if ^p -> reference.shared
572                          then call adjust_ref_count(p,-1);
573                     end;
574 
575 l4:
576                index_regs(x).variable = p;
577                if c = 0
578                     then p -> reference.value_in.x(x) = "1"b;
579 
580                if p -> reference.symbol ^= null then p -> reference.perm_address = "0"b;
581 
582                index_regs(x).type = 2;
583                index_regs(x).constant = c;
584                index_regs(x).used = cg_stat$text_pos;
585                end;
586 
587 
588 
589 
590 load_xr_c:     proc(xr);
591 
592 dcl            (x,xr) fixed bin;
593 
594                x = xr;
595 
596                call flush_old(x);
597 
598                index_regs(x).used = cg_stat$text_pos;
599                call expmac(lxl0+x,c_a(const,2));
600                index_regs(x).type = 1;
601                index_regs(x).constant = const;
602                end;
603 
604 
605 /* ^L */
606 flush_old:          proc(xr);
607 
608 dcl            (xr,x) fixed bin;
609 dcl            old_p pointer;
610 dcl            macro fixed bin(15);
611 
612                x = xr;
613 
614                if index_regs(x).type < 2
615                     then return;
616 
617                /* have a variable in the index register, if it is a temporary
618                   which doesn't exist in storage, we'll have to save it */
619 
620                old_p = index_regs(x).variable;
621                old_p -> reference.value_in.x(x) = "0"b;
622 
623                if ^ old_p -> reference.temp_ref
624                 | old_p -> reference.value_in.storage
625                 | index_regs(x).constant ^= 0
626                     then return;
627 
628                if old_p -> reference.ref_count > 0
629                then do;
630                     if old_p -> reference.symbol -> symbol.c_dcl_size >= bits_per_half
631                     then do;
632                          old_p -> reference.ref_count = old_p -> reference.ref_count + 2;
633                          call expmac((zero_mac),old_p);
634                          macro = sxl0 + x;
635                          end;
636 
637                     else do;
638                          old_p -> reference.ref_count = old_p -> reference.ref_count + 1;
639 
640                          /* convert the old reference in index register into
641                             a "packed" integer in storage */
642 
643                          old_p -> reference.aligned_ref = "0"b;
644                          old_p -> reference.c_offset = 0;
645                          old_p -> reference.c_length = bits_per_half;
646                          old_p -> reference.units = word_;
647 
648                          /* We set reference.dont_save as a
649                             kludge to fix bug 1599.  This
650                             prevents save_value from converting
651                             this back to an aligned temp,
652                             which could cause problems after
653                             an if statement. */
654 
655                          old_p -> reference.dont_save = "1"b;
656                          macro = stx0 + x;
657                          end;
658 
659                     call expmac(macro,old_p);
660                     old_p -> reference.value_in.storage = "1"b;
661 
662                     index_regs(x).used = cg_stat$text_pos;
663                     end;
664                end;
665 
666 
667           end;