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 aq register for pl/1
 12 
 13    Initial Version:  4 September 1971 by BLW for Version II
 14           Modified:  2 October 1972 by BLW
 15           Modified: 11 June 1973 by RAB for aq_man$load_any ...
 16           Modified: 19 March 1977 by RAB for aq_man$left_shift
 17                     and aq_man$right_shift
 18           Modified: 4 September 1977 by RAB to fix 1666
 19           Modified: 10 November 1977 by RAB to prevent trimming when amt is bits_per_two_words      */
 20 
 21 /*        These are the meanings of some important fields in the a_reg:
 22 
 23           a_reg.size          the size of the datum in the register without
 24                               pad bits
 25 
 26           a_reg.offset        the offset of the leftmost bit of the datum
 27                               from the left of the register
 28 
 29           a_reg.length        the sum of a_reg.offset + a_reg.size + any known
 30                               zero_bits of padding immediately to the right of
 31                               the datum.  (Anything beyond a_reg.length in the
 32                               register is unknown.)                   */
 33 
 34 aq_man$pad_aq: proc(type,size);
 35 
 36 dcl       type fixed bin,     /* bit_string or char_string */
 37           size fixed bin;     /* size to pad to, in bits */
 38 
 39 dcl       (cg_stat$double_temp,cg_stat$text_base) ptr ext,
 40           cg_stat$text_pos fixed bin ext;
 41 
 42 dcl       (i,j,k,n) fixed bin,
 43           arith bit(1),
 44           macro fixed bin(15),
 45           p ptr;
 46 
 47 dcl       word bit(36) aligned based;
 48 
 49 dcl       expmac entry(fixed bin(15),ptr),
 50           expmac$zero entry(fixed bin(15)),
 51           expmac$one entry(fixed bin(15),ptr,fixed bin),
 52           xr_man$load_const entry(fixed bin,fixed bin),
 53           aq_man$check_strings entry(fixed bin),
 54           aq_man$clear_q entry,
 55           c_a entry(fixed bin,fixed bin) returns(ptr),
 56           copy_temp entry(ptr) returns(ptr);
 57 
 58 dcl       (abs,addrel,bit,fixed,lbound,min,null,string,substr) builtin;
 59 
 60 dcl (     anaq                init(42),
 61           oraq                init(48),
 62           rfb1_to_rfb2        init(88),
 63           truncate(2)         init(520,521),
 64           q_left_shift(2)     init(515,63),       /* qls, lls */
 65           left_shift(2)       init(134,63),       /* als, lls */
 66           right_shift(2)      init(245,62),       /* arl, lrl */
 67           stfx1               init(15),
 68           sta                 init(4)) fixed bin(15) int static options(constant);
 69 
 70 %include cgsystem;
 71 %include cg_reference;
 72 %include symbol;
 73 %include data_types;
 74 %include machine_state;
 75 %include bases;
 76 %include boundary;
 77 
 78           if size <= a_reg.size then return;
 79 
 80           if a_reg.length < size
 81           then do;
 82                call expmac((anaq),c_a((a_reg.size),5));
 83                a_reg.length = bits_per_two_words;
 84                end;
 85 
 86           if type = bit_string then a_reg.size = a_reg.length;
 87           else do;
 88                call expmac((oraq),c_a((a_reg.size),6));
 89                if size < bits_per_two_words then call expmac((anaq),c_a(size,5));
 90                a_reg.size = size;
 91                end;
 92 
 93           return;
 94 
 95 aq_man$save_aq: entry(pt,pad);
 96 
 97 dcl       pt ptr,             /* points at reference node of value in aq */
 98           pad fixed bin;      /* ^= 0 means clear_q when storing */
 99 
100           p = pt;
101 
102           k = p -> reference.data_type;
103           if k <= real_flt_bin_2
104           then do;
105                arith = "1"b;
106                macro = stfx1 - 1 + k;
107                goto store;
108                end;
109 
110           arith = "0"b;
111 
112           if a_reg.size <= bits_per_word
113           then if pad = 0 then k = 0;
114                else do;
115                     k = 1;
116                     call aq_man$clear_q;
117                     end;
118           else do;
119                if a_reg.length < bits_per_two_words then call expmac((anaq),c_a((a_reg.size),5));
120                k = 2;
121                end;
122 
123 store:    if p -> reference.temp_ref
124           then do;
125                if p -> reference.shared
126                then do;
127                     p, pt = copy_temp(p);
128                     p -> reference.ref_count = 2;
129                     end;
130                else p -> reference.ref_count = p -> reference.ref_count + 1;
131 
132                if arith then call expmac(macro,p); else call expmac$one((sta),p,k);
133                end;
134 
135           else do;
136                if arith
137                     then call expmac(macro,cg_stat$double_temp);
138                     else call expmac$one((sta),cg_stat$double_temp,k);
139 
140                string(p -> reference.address) = string(cg_stat$double_temp -> reference.address);
141                p -> reference.relocation = cg_stat$double_temp -> reference.relocation;
142                p -> reference.perm_address = "1"b;
143                p -> reference.even = "1"b;
144                end;
145 
146           p -> reference.value_in.storage = "1"b;
147           return;
148 
149 aq_man$clear_q: entry;
150 
151           k = bits_per_word;
152           goto trim;
153 
154 aq_man$trim_aq: entry(n_bits);
155 
156 dcl       n_bits fixed bin;
157 
158           k = n_bits;
159           call aq_man$check_strings(k);
160 
161           /* check to see if last instruction was also a trimming instruction */
162 
163 trim:     p = addrel(cg_stat$text_base,cg_stat$text_pos - 1);
164 
165           if (p -> word & "111000000000000000111111111111111111"b)
166                        ^= "000000000000000000011111111001000000"b               /* anaq ap|0 */
167           then goto gen;
168 
169           if fixed(substr(p -> word,4,15),15) <= bits_per_four_words
170           then do;
171                substr(p -> word,4,15) = bit(fixed(2*k,15),15);
172                goto len;
173                end;
174 
175 gen:      if k < bits_per_two_words
176                then call expmac((anaq),c_a(k,5));
177           a_reg.length = bits_per_two_words;
178 
179 len:      a_reg.size = k - a_reg.offset;
180           return;
181 
182 aq_man$check_strings: entry(n_bits);
183 
184           /* check to make sure that no bits will get lost from any string
185              currently held in a register.  If bits will be lost, value must
186              be saved if not already in storage */
187 
188           n = a_reg.number;
189           do i = 1 by 1 while(i <= n);
190 check:         p = a_reg.variable(i);
191 
192                if p -> reference.data_type >= lbound(convert_size,1)
193                     then j = p -> reference.c_length * convert_size(p -> reference.data_type);
194                     else j = p -> reference.c_length;
195 
196                if n_bits - a_reg.offset < j
197                then do;
198                     if ^ p -> reference.temp_ref then goto drop;
199                     if p -> reference.value_in.storage then goto drop;
200                     if p -> reference.ref_count < 1 then goto drop;
201 
202                     /* have to save value */
203 
204                     p -> reference.store_ins = bit(cg_stat$text_pos,18);
205                     p -> reference.ref_count = p -> reference.ref_count + 1;
206 
207                     call expmac$one((sta),p,fixed(j > bits_per_word,1));
208 
209                     p -> reference.value_in.storage = "1"b;
210 
211 drop:               p -> reference.value_in.a = "0"b;
212 
213                     n = n - 1;
214                     a_reg.number = n;
215                     if n < i then return;
216 
217                     do j = i to n;
218                          a_reg.variable(j) = a_reg.variable(j+1);
219                          end;
220 
221                     goto check;
222                     end;
223                end;
224 
225           return;
226 
227 
228 aq_man$left_shift: entry(amt,long);
229 
230 dcl       amt fixed bin(8),             /* amount to shift */
231           long bit(1) aligned;          /* forces long shift */
232 
233 dcl       nregs fixed bin;              /* number of registers involved */
234 dcl       amount fixed bin;             /* amount to shift */
235 
236           amount = amt;
237 
238           if long | a_reg.size + a_reg.offset > bits_per_word
239                then nregs = 2;
240                else nregs = 1;
241 
242           call expmac(left_shift(nregs), c_a(amount,1));
243 
244           a_reg.offset = a_reg.offset - amount;
245           if a_reg.length < bits_per_words(nregs)
246                then a_reg.length = a_reg.length - amount;
247                else a_reg.length = bits_per_words(nregs);
248 
249           return;
250 
251 
252 aq_man$right_shift: entry(amt,long);
253 
254           amount = amt;
255 
256           if long | a_reg.size + a_reg.offset + amount > bits_per_word
257                then nregs = 2;
258                else nregs = 1;
259 
260           call expmac(right_shift(nregs), c_a(amount,1));
261 
262           a_reg.offset = a_reg.offset + amount;
263           a_reg.length = min(a_reg.length + amount, bits_per_words(nregs));
264           return;
265 
266 
267 aq_man$fix_scale: entry(pt,scale1,type1);
268 
269 dcl       (scale1,type1) fixed bin;
270 dcl       ptype fixed bin;
271 
272           ptype = pt -> reference.data_type;
273           n = scale1 - pt -> reference.symbol -> symbol.scale;
274           if n = 0
275           then do;
276                if type1 > ptype
277                     then call expmac$zero((rfb1_to_rfb2));
278                return;
279                end;
280 
281           if type1 > ptype
282           then do;
283                if n > bits_per_word
284                then do;
285                     macro = q_left_shift(2);
286                     goto shift;
287                     end;
288 
289                call expmac((q_left_shift(2)),c_a((bits_per_word),1));
290                n = n - bits_per_word;
291 
292                if n = 0 then return;
293 
294                k = 2;
295                end;
296 
297           else k = ptype;
298 
299           if n < 0
300           then do;
301                call xr_man$load_const(abs(n),2);
302                call expmac$zero((truncate(k)));
303                end;
304 
305           else do;
306                macro = q_left_shift(k);
307 shift:         call expmac(macro,c_a(n,1));
308                end;
309 
310           return;
311 
312 /* The following section is called to load string offsets and string lengths into the a or q
313    for use by EIS instructions. */
314 
315 /* Load variable offset or length into a or q */
316 
317 aq_man$load_any_var:          entry(pt,ar,base_offset);
318 
319 dcl       ar fixed bin(2),              /* specifies reg to be loaded */
320           base_offset fixed bin(24);    /* base offset to add to pt */
321 
322 dcl       1 machine_overlay based(m_s_p),
323           2 node_type bit(9),
324           2 indicators fixed bin,
325           2 next,
326           2 aq_regs(2) like machine_state.a_reg;
327 
328 dcl       c fixed bin(24);
329 dcl       l fixed bin;
330 dcl       lock bit(1) aligned;
331 dcl       cg_stat$cur_statement ptr ext static;
332 
333 dcl (     load_aq(2)          init(1,7),          /* lda, ldq */
334           add_aq(2)           init(645,19),       /* ada, adq */
335           right_shift_aq(2)   init(725,514))      /* ars, qrs */
336                     fixed bin(15) int static options(constant);
337 
338 dcl       adjust_ref_count entry(ptr,fixed bin);
339 dcl       generate_constant$real_fix_bin_1 entry(fixed bin(24)) returns(ptr);
340 dcl       get_single_ref entry(ptr) returns(ptr);
341 dcl       base_man$load_any_var_and_lock entry(fixed bin,ptr,bit(3) aligned);
342 dcl       base_man$unlock entry (fixed bin);
343 dcl       xr_man$load_any_var_and_lock entry(ptr,fixed bin(3),fixed bin(18));
344 dcl       error entry(fixed bin,ptr,ptr);
345 
346           lock = "0"b;
347           p = pt;
348           c = base_offset;
349 
350 search:   j = -1;
351           do i = 1 to 2;
352                     do l = 1 to aq_regs(i).number;
353                          if aq_regs(i).variable(l) = p
354                          then do;
355                               j = i;
356                               if aq_regs(i).constant = c
357                               then do;
358                                    if ^ p -> reference.shared
359                                         then call adjust_ref_count(p,-1);
360                                    go to return_i;
361                                    end;
362                               end;
363                     end;
364           end;
365 
366           i = get_free_aq();
367           if i ^= 0
368                then call load_aq_var;
369 
370 return_i: ar = i;
371           if lock
372           then do;
373                aq_regs(i).locked = "1"b;
374                aq_regs(i).number_h_o = 0;
375                end;
376           return;
377 
378 /* Load constant offset or length into a or q */
379 
380 aq_man$load_any_const:        entry(base_offset,ar);
381 
382           lock = "0"b;
383           p = generate_constant$real_fix_bin_1(base_offset);
384           c = 0;
385           go to search;
386 
387 aq_man$lock:        entry(pt,ar);
388 
389           i = ar;
390 
391           if pt ^= null & (^ aq_regs(i).locked | aq_regs(i).number_h_o ^= 0)
392           then do;
393                j, aq_regs(i).number_h_o = aq_regs(i).number_h_o + 1;
394                aq_regs(i).has_offset(j) = pt;
395                end;
396           else aq_regs(i).number_h_o = 0;
397 
398           aq_regs(i).locked = "1"b;
399 
400           return;
401 
402 /* Load variable offset or length into a or q and lock */
403 
404 aq_man$load_any_var_and_lock: entry(pt,ar);
405 
406           lock = "1"b;
407           p = pt;
408           c = 0;
409           go to search;
410 
411 /* Load item into specified register */
412 
413 aq_man$load_var:    entry(pt,ar);
414 
415           p = pt;
416           i = ar;
417 
418           if substr(string(p -> reference.value_in),i,1)
419           then do;
420                if ^ p -> reference.shared
421                     then call adjust_ref_count(p,-1);
422                return;
423                end;
424 
425           j = -1;
426           c = 0;
427           call load_aq_var;
428           return;
429 
430 /* Find a register in which to load the reference */
431 
432 get_free_aq:        proc() returns(fixed bin);
433 
434 dcl       (i,k,count(2)) fixed bin;
435 dcl       q ptr;
436 dcl       base bit(3) aligned;
437 dcl       xr fixed bin(3);
438 dcl       tag bit(6) aligned;
439 
440           if aq_regs(1).locked
441           then if aq_regs(2).locked
442                then do;
443 
444                     do i = 1 to 2;
445                     if aq_regs(i).number_h_o ^= 0
446                     then do;
447                          if aq_regs(i).constant = 0 & aq_regs(i).number ^= 0 & ^ aq_regs(i).has_offset(1) -> reference.big_offset
448                          then do;
449                               q = aq_regs(i).variable(1);
450 
451                               if ^ q -> reference.shared
452                               then q -> reference.ref_count = q -> reference.ref_count + 1;
453 
454                               call xr_man$load_any_var_and_lock(q,xr,0);
455 
456                               tag = "001"b || bit(xr,3);
457 
458                               do k = 1 to aq_regs(i).number_h_o;
459                               aq_regs(i).has_offset(k) -> address.tag = tag;
460                               end;
461 
462                          end;
463 
464                          else do k = 1 to aq_regs(i).number_h_o;
465                               q = aq_regs(i).has_offset(k);
466 
467                               if k < aq_regs(i).number_h_o | q -> reference.c_f_offset = 0
468                               then q -> reference.perm_address = "1"b;
469                               else do;
470                                    aq_regs(i).locked = "0"b;
471                                    aq_regs(i).number_h_o = 0;
472                                    end;
473 
474 
475                               if q -> reference.ext_base
476                               then if q -> address.base ^= sp
477                                    then call base_man$unlock(which_base(fixed(q -> address.base,3)));
478 
479                               if ^q -> reference.shared
480                               then q -> reference.ref_count = q -> reference.ref_count + 1;
481 
482                               call base_man$load_any_var_and_lock(2,q,base);
483 
484                               end;
485 
486                          aq_regs(i).locked = "0"b;
487                          aq_regs(i).number_h_o = 0;
488                          return(i);
489                          end;
490                     end;
491 
492                     call error(329,cg_stat$cur_statement,p);
493                     lock = "0"b;
494                     return(0);
495                     end;
496                else return(2);
497           else if aq_regs(2).locked
498                then return(1);
499 
500           if j > 0 then return(j);
501 
502           do i = 1 to 2;
503                if aq_regs(i).number = 0
504                     then return(i);
505           end;
506 
507           do i = 1 to 2;
508                count(i) = 0;
509                do k = 1 to aq_regs(i).number;
510                     count(i) = count(i) + aq_regs(i).variable(k) -> reference.ref_count;
511                end;
512           end;
513 
514           if count(1) < count(2)
515           then return(1);
516           else if count(2) < count(1)
517                then return(2);
518 
519           if aq_regs(1).changed < aq_regs(2).changed
520                then return(1);
521                else return(2);
522 end;
523 
524 
525 /* Load the specified register */
526 
527 load_aq_var:        proc();
528 
529 dcl       (cp,q) ptr;
530 dcl       c1 fixed bin(24);
531 
532           q = p;
533           c1 = c;
534 
535           if p -> reference.data_type = real_fix_bin_2
536                then q = get_single_ref(p);
537 
538           if j = i
539           then do;
540                c1 = c - aq_regs(i).constant;
541                if ^ q -> reference.shared
542                     then call adjust_ref_count(q,-1);
543                end;
544 
545           else do;
546                if q -> reference.temp_ref
547                then if ^ q -> reference.value_in.storage
548                     then if q -> reference.value_in.q
549                          then call aq_man$save_aq(q,0);
550 
551                call expmac((load_aq(i)),q);
552 
553                if ^ q -> reference.aligned_ref
554                then if q -> reference.units = word_ & q -> reference.c_length = bits_per_half
555                     then call expmac(right_shift_aq(i),c_a((bits_per_half),1));
556                     else call error(367,cg_stat$cur_statement,q);
557                end;
558 
559           if c1 ^= 0
560           then do;
561                if c1 > 0 & c1 < 262144
562                then cp = c_a((c1),2);
563                else cp = generate_constant$real_fix_bin_1(c1);
564                call expmac((add_aq(i)),cp);
565                end;
566 
567           if i = 1
568                then aq_regs(1).offset, aq_regs(1).size = 0;
569           aq_regs(i).constant = c;
570           aq_regs(i).number = 1;
571           aq_regs(i).variable(1) = p;
572           if c = 0
573                then substr(string(p -> reference.value_in),i,1) = "1"b;
574 end;
575 
576 end;