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 generate store sequences
 12 
 13    Initial Version: 10 September 1971 by BLW
 14           Modified: 4 November 1972 by BLW
 15           Modified: 15 February 1973 by RAB
 16           Modified: 22 June 1973 by RAB for EIS
 17           Modified: 26 October 1975 by RAB to spec case fixed bin unal
 18           Modified: 19 March 1977 by RAB for aq_man$left_shift
 19                     and aq_man$right_shift
 20           Modified: 7 August 1978 by RAB to fix 1751 by changing setting
 21                     of store_it for complex_flt_bin_1
 22           Modified: 30 March 1980 by RAB for reference.(padded aligned)_for_store_ref.
 23                     See prepare_operand for details.        */
 24 
 25 store:    proc(pt);
 26 
 27 dcl       pt ptr;             /* points at reference node */
 28 
 29 dcl       cg_stat$save_exp_called bit(1) aligned ext,
 30           cg_stat$text_pos fixed bin(18) ext,
 31           cg_stat$complex_ac ptr ext;
 32 
 33 dcl       (p,q,arg(2)) ptr,
 34           (type,size,cfo,unit_size,unit_offset,d,i,j,k,u,n,n1,n2,n3,n4,units) fixed bin,
 35           (store_it,contiguous,all_ones,all_zeros,b1,arith) bit(1) aligned,
 36           (macro,offset) fixed bin(15),
 37           shift fixed bin(8),
 38           bs bit(12),
 39           mask bit(72) aligned,
 40           in_q fixed bin(1) initial(0),
 41           base3 bit(3) aligned,
 42           xec(2) bit(36) aligned,
 43           (ta,tq) bit(6);
 44 
 45 dcl       m_a entry(ptr,bit(2) aligned);
 46 dcl       c_a entry(fixed bin,fixed bin) returns(ptr),
 47           xr_man$load_const entry(fixed bin,fixed bin),
 48           expmac$abs entry(ptr,fixed bin),
 49           expmac$zero entry(fixed bin(15)),
 50           expmac$many entry(fixed bin(15),ptr,fixed bin),
 51           expmac$two_eis entry(fixed bin(15),ptr,ptr),
 52           long_op$c_or_b entry(ptr,fixed bin,fixed bin(15)),
 53           xr_man$load_var entry(ptr,fixed bin),
 54           base_man$load_any_var entry(fixed bin,ptr,bit(3) aligned),
 55           stack_temp$assign_block entry(ptr,fixed bin),
 56           state_man$flush_ref entry(ptr),
 57           state_man$erase_reg entry(bit(19) aligned),
 58           (aq_man$left_shift, aq_man$right_shift) entry(fixed bin(8),bit(1) aligned),
 59           aq_man$check_strings entry(fixed bin),
 60           aq_man$trim_aq entry(fixed bin),
 61           generate_constant entry(bit(*) aligned,fixed bin) returns(ptr),
 62           adjust_ref_count entry(ptr,fixed bin),
 63           expmac$one entry(fixed bin(15),ptr,fixed bin),
 64           expmac entry(fixed bin(15),ptr);
 65 
 66 dcl       (abs,addr,addrel,bit,divide,fixed,mod,min,null,string,substr) builtin;
 67 
 68 dcl (     bytes(2)            init(9,6),
 69           nbspw(2)            init(4,6)) fixed bin int static;
 70 
 71 dcl       operator_table      init(262046) fixed bin(18) int static;  /* = 262144 - 98 */
 72 
 73           /* The following values are offsets obtained from a compilation
 74              of pl1_operators_ */
 75 
 76 dcl (     co_to_bo            init(0),
 77           ho_to_bo            init(4),
 78           store_a9_co         init(6),
 79           store_q9_co         init(26),           /* 32 octal */
 80           store_a9_ho         init(42),           /* 52 octal */
 81           store_q9_ho         init(54),           /* 66 octal */
 82           store_a6_ho         init(64),           /* 100 octal */
 83           store_q6_ho         init(82))           /* 122 octal */
 84                               fixed bin static;
 85 
 86 dcl       full(2) aligned bit(6) int static init("111100"b, "111111"b);
 87 
 88 dcl       init_xec_7(2) bit(36) aligned int static
 89           init(     "000000000000000000111111011001011111"b,          /* lrl ap|0,7*      */
 90                     "000000000000000000111001110001001111"b);         /* xec ap|0,7       */
 91 
 92 dcl       init_xec_q(2) bit(36) aligned int static
 93           init(     "000000000000000000111111001001010110"b,          /* arl ap|0,ql*     */
 94                     "000000000000000000111001110001000110"b);         /* xec ap|0,ql      */
 95 
 96 dcl (     stfx1               init(15),
 97           stfx2               init(16),
 98           store_pt            init(61),
 99           shift_and_mask      init(106),
100           als                 init(134),
101           ana(0:1)            init(40,688),
102           anaq                init(42),
103           era(0:1)            init(52,689),
104           ersa(0:1)           init(55,690),
105           lls                 init(63),
106           lrl                 init(62),
107           arl                 init(245),
108           orsa                init(49),
109           pack_fl1            init(489),
110           pack_cfl1           init(491),
111           move_chars          init(98),
112           store_units(2)      init(295,297),
113           sta                 init(4),
114           st_reg(0:1)         init(4,15),
115           store_logical       init(381)) fixed bin(15) int static;
116 
117 %include cgsystem;
118 %include reference;
119 %include machine_state;
120 %include data_types;
121 %include boundary;
122 %include bases;
123 
124           all_zeros, all_ones = "0"b;
125 
126 s0:       p = pt;
127 
128           if p -> reference.temp_ref & ^ p -> reference.aggregate
129           then do;
130                if ^ p -> reference.allocated
131                then do;
132                     if p -> reference.data_type = complex_flt_bin_1
133                     then call expmac((stfx2),cg_stat$complex_ac);
134                     return;
135                     end;
136 
137                store_it = cg_stat$save_exp_called;
138                end;
139           else store_it = "1"b;
140 
141           goto l0;
142 
143 store$force: entry(pt);
144 
145           all_zeros, all_ones = "0"b;
146           p = pt;
147           store_it = "1"b;
148 
149 l0:       call state_man$flush_ref(p);
150 
151           type = p -> reference.data_type;
152 
153           if type = unpacked_ptr
154           then do;
155                type = real_fix_bin_2;
156                goto l1;
157                end;
158 
159           if type = packed_ptr
160           then do;
161                type = real_fix_bin_1;
162                goto l1;
163                end;
164 
165           if type >= char_string
166           then do;
167                arith = "0"b;
168                goto string_;
169                end;
170 
171 l1:       arith = "1"b;
172 
173           if ^ p -> reference.aligned_for_store_ref
174           then do;
175 
176                if p -> reference.temp_ref
177                     then p -> reference.value_in.storage = "1"b;
178 
179                if type = real_fix_bin_1
180                then do;
181                     size = p -> reference.c_length;
182 
183                     if p -> reference.hard_to_load
184                     then if size = bits_per_word
185                          then do;
186                               in_q = 1;
187                               go to str1;
188                               end;
189                          else;
190                     else do;
191                          cfo = mod(p -> reference.c_offset * convert_offset(p -> reference.units),36);
192                          if cfo < 0 then cfo = cfo + 36;
193 
194                          if cfo = bits_per_word - size
195                          then do;
196                               in_q = 1;
197                               go to str1;
198                               end;
199                          end;
200                     end;
201 
202                call state_man$erase_reg("1"b);    /* erase a register */
203 
204                a_reg.size, size = p -> reference.c_length;
205                a_reg.length = 72;
206 
207                if type <= real_fix_bin_2
208                then do;
209                     a_reg.offset = 72 - size;
210                     goto str1;
211                     end;
212 
213                if type <= real_flt_bin_2
214                then do;
215                     call expmac$zero(pack_fl1 - real_flt_bin_1 + type);
216                     a_reg.offset = 0;
217                     goto str1;
218                     end;
219 
220                if type = complex_flt_bin_1
221                then do;
222                     k = bits_per_word - divide(size,2,17,0);
223                     if k > 0
224                          then call expmac((pack_cfl1),c_a(k,1));
225                     a_reg.offset = 0;
226                     goto str1;
227                     end;
228 
229                goto str1;
230                end;
231 
232           if type = complex_flt_bin_1 then macro = stfx2;
233           else macro = stfx1 - 1 + type;
234 
235           if store_it then call expmac(macro,p);
236 
237 up_q:     do i = 1 to q_reg.number;
238                if q_reg.variable(i) = p then goto thru;
239                end;
240 
241           if i < 11
242           then do;
243                q_reg.number = i;
244                q_reg.variable(i) = p;
245                p -> reference.value_in.q = "1"b;
246                end;
247 
248 thru:     if p -> reference.temp_ref & store_it
249           then do;
250                p -> reference.store_ins = bit(fixed(cg_stat$text_pos - 1,18),18);
251                p -> reference.value_in.storage = "1"b;
252                end;
253 
254           return;
255 
256 string_:  if ^ store_it then goto update_a;
257 
258           size = p -> reference.c_length * convert_size(type);
259 
260 str1:
261 
262 /* If a reference is hard_to_load, it is also hard to store and we will use EIS to
263    accomplish the feat */
264 
265           if p -> reference.hard_to_load
266           then do;
267 
268                /* First shift string to the left of the aq */
269 
270                if in_q = 0
271                then if a_reg.offset > 0
272                     then call aq_man$left_shift(a_reg.offset, a_reg.length > bits_per_word);
273 
274                /* store the string in the double temp (sp|46) */
275 
276                q = c_a(46,4);
277                q -> reference.c_length = p -> reference.c_length;
278 
279                call expmac$one((st_reg(in_q)),q,fixed(size > bits_per_word,1));
280 
281                /* Now update the machine state */
282 
283                if ^ arith
284                     then call up_a;
285                     else type = bit_string;
286 
287                /* Finally move from the temp to the actual reference */
288 
289                if p -> reference.temp_ref
290                     then p -> reference.value_in.storage = "1"b;
291 
292                call expmac$two_eis((move_chars + type - char_string),p,q);
293 
294                if in_q ^= 0 then go to up_q;
295                return;
296                end;
297 
298           units = p -> reference.units;
299 
300           if units = word_
301           then cfo = 0;
302           else do;
303                cfo = mod(p -> reference.c_offset * convert_offset(units),36);
304                if cfo < 0 then cfo = cfo + 36;
305                end;
306 
307           /* have constant bit offset, do the store out-of-line if
308              the string overlaps into third word */
309 
310           offset = cfo;
311           k = size + offset;
312           d = fixed(k > 36,1);
313           contiguous = k <= 36;
314 
315           if all_zeros then goto s1;
316           if in_q > 0 then goto s1;
317 
318           shift = offset - a_reg.offset;
319           if shift = 0 then goto s1;
320 
321           b1 = a_reg.length <= 36 & contiguous;
322 
323           if shift < 0
324           then call aq_man$left_shift(- shift, ^ b1);
325 
326           else do;
327 
328                if b1
329                     then i = bits_per_word;
330                     else i = bits_per_two_words;
331 
332                call aq_man$check_strings(i-shift);
333                if a_reg.size + offset > i then a_reg.size = i - offset;
334 
335                call aq_man$right_shift(shift, ^ b1);
336                end;
337 
338 s1:       if offset > 0 then goto check;
339 
340           if size = 0
341           then if ^ p -> reference.temp_ref
342                then goto easy_done;
343 
344           if mod(size,36) = 0
345           then do;
346                if a_reg.length < size then call aq_man$trim_aq(size);
347                goto blast;
348                end;
349 
350           if ^ p -> reference.padded_for_store_ref then goto check;
351 
352           /* can do single store, trim any excess bits on right */
353 
354           if all_zeros then goto blast;
355 
356           if a_reg.size > size | a_reg.length < 36*(d + 1)
357           then do;
358                call aq_man$trim_aq(size);
359                a_reg.size = size;
360                end;
361 
362 blast:    call expmac$one((sta),p,d);
363           goto easy_done;
364 
365           /* if offset is a constant multiple of 6 or 9 and size is a
366              multiple also, generate a stca-stcq or stba-stbq sequence.
367              otherwise, use insert code */
368 
369 check:
370 
371           do i = 1 to 2;
372                u = bytes(i);
373                if mod(offset,u) = 0
374                then do;
375                     j = mod(size,u);
376                     if j = 0 then goto easy;
377 
378                     if p -> reference.padded_for_store_ref
379                     then do;
380                          size = size + (u - j);
381                          goto easy;
382                          end;
383 
384                     end;
385                end;
386 
387           /* we must insert value into storage */
388 
389 insert:   if all_ones
390           then do;
391                call expmac$one((orsa),p,d);
392                go to easy_done;
393                end;
394 
395           if ^p -> reference.shared
396                then p -> reference.ref_count = p -> reference.ref_count + 1;
397 
398           call expmac$one((era(in_q)),p,d);
399 
400           p -> reference.perm_address = "1"b;
401 
402 
403           /* have constant bit offset, no shifting needed */
404 
405           if offset = 0 then q = c_a(k,5);
406           else do;
407                mask = (72)"0"b;
408                substr(mask,offset+1,size) = (72)"1"b;
409                if substr(mask,72,1) then q = c_a((offset),7);
410                else q = generate_constant(mask,d+1);
411                end;
412 
413           call expmac$one((ana(in_q)),q,d);
414 
415           call expmac$one((ersa(in_q)),p,d);
416 
417           p -> reference.perm_address = "0"b;
418 
419           if in_q > 0
420                then return;
421 
422 done:     a_reg.size = 0;
423 
424           do i = 1 to a_reg.number;
425           a_reg.variable(i) -> reference.value_in.a = "0"b;
426           end;
427 
428           a_reg.number = 0;
429 
430           return;
431 
432           /* can use special character instructions, calculate modifiers */
433 
434 easy:     unit_offset = divide(offset,u,17,0);
435           unit_size = divide(size,u,17,0);
436 
437           bs = "0"b;
438           substr(bs,unit_offset+1,unit_size) = (12)"1"b;
439 
440           n = nbspw(i);
441           ta = substr(bs,1,n);
442           tq = substr(bs,n+1,n);
443 
444           /* make destination addressable, place address in any base register if original address
445              has any tag other than 0 */
446 
447           call m_a(p,"0"b);
448 
449           if p -> reference.tag
450           then do;
451                if cfo ^= 0
452                     then p -> reference.units = word_;      /* Inhibit base_man from loading fractional offset */
453                p -> reference.perm_address = "1"b;
454                if ^p -> reference.shared
455                     then p -> reference.ref_count = p -> reference.ref_count + 1;
456                call base_man$load_any_var(2,p,base3);
457                if cfo ^= 0
458                then do;
459 
460                     /* Since we do not have full address in the pointer register,
461                        we must flush its address from the machine state */
462 
463                     p -> reference.units = units;
464                     j = which_base(fixed(base3,3));
465                     base_regs(j).type = 0;
466                     p -> reference.address_in.b(j) = "0"b;
467                     end;
468                end;
469 
470           p -> reference.perm_address = "1"b;
471 
472           if ta = full(i) then macro = sta;
473           else do;
474                macro = store_units(i) + in_q;
475                p -> reference.tag = ta;
476                end;
477 
478           if ^p -> reference.shared
479                then p -> reference.ref_count = p -> reference.ref_count + 1;
480 
481           call expmac(macro,p);
482 
483           if k <= 36
484           then do;
485                call adjust_ref_count(p,-1);
486                if in_q > 0 then go to up_q;
487                go to easy_done;
488                end;
489 
490           if tq = full(i)
491           then do;
492                macro = stfx1;
493                tq = "0"b;
494                end;
495           else macro = store_units(i) + 1;
496 
497           p -> address.offset = bit(fixed(fixed(p -> address.offset,15)+1,15),15);
498           p -> address.tag = tq;
499 
500 
501           call expmac(macro,p);
502 
503           a_reg.size = size;
504           a_reg.length = size + offset;
505 
506 easy_done:
507           p -> reference.perm_address = "0"b;
508 
509           if arith then return;
510 
511           a_reg.offset = offset;
512 
513 update_a: call up_a;
514 
515           if a_reg.number = 0
516                then return;
517                else go to thru;
518 
519 store$all_ones: entry(pt);
520 
521           all_ones = "1"b;
522           all_zeros = "0"b;
523           goto s0;
524 
525 store$all_zeros: entry(pt);
526 
527           all_ones = "0"b;
528           all_zeros = "1"b;
529           goto s0;
530 
531 store$save_string_temp: entry(pt);
532 
533           p = pt;
534           call stack_temp$assign_block(p,2);
535           p -> reference.address_in.storage = "0"b;
536           p -> reference.store_ins = bit(cg_stat$text_pos,18);
537           call expmac((store_pt),p);
538           p -> reference.address_in.storage = "1"b;
539           return;
540 
541 
542 up_a:     proc;
543 
544           do i = 1 to a_reg.number;
545           if a_reg.variable(i) = p then return;
546           end;
547 
548           if i < 11
549           then do;
550                a_reg.number = i;
551                a_reg.variable(i) = p;
552                p -> reference.value_in.a = "1"b;
553                end;
554 
555 end;
556 
557 
558           end;