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 instructions to load a value
 12 
 13    Initial Version: 23 September 1971 by BLW
 14           Modified:  5 November 1972 by BLW
 15           Modified: 15 February 1973 by RAB
 16           Modified: 22 June 1973 by RAB for EIS
 17           Modified: 15 June 1976 by RAB to fix 1502
 18           Modified: 19 March 1977 by RAB for aq_man$left_shift
 19           Modified: 16 July 1978 by PCK for unsigned binary
 20           Modified: 9 December 1978 by RAB to fix 1803 (faults on get list(picture);)
 21           Modified: 17 July 1979 by RAB to check for load(decimal_value,...).
 22 */
 23 
 24 load:     proc(pt,control);
 25 
 26 dcl       pt ptr,             /* points at reference node */
 27           control fixed bin;  /* non-zero if negative should be loaded */
 28 
 29 dcl       (p,q) ptr,
 30           (i,n,type,size,d,dt,k,aq_length,units,cfo) fixed bin,
 31           offset fixed bin(8),
 32           (mac,macro,shift) fixed bin(15),
 33           mask bit(72) aligned,
 34           (fs,ft,arith,available) bit(1) aligned,
 35           for_save bit(1) aligned init("0"b),
 36           cg_stat$cur_statement ptr ext static,
 37           error entry(fixed bin,ptr,ptr),
 38           c_a entry(fixed bin,fixed bin) returns(ptr),
 39           generate_constant entry(bit(*) aligned,fixed bin) returns(ptr),
 40           stack_temp$free_temp entry(ptr),
 41           (long_op,long_op$c_or_b) entry(ptr,fixed bin,fixed bin(15)),
 42           (xr_man$load_var,adjust_ref_count) entry(ptr,fixed bin),
 43           xr_man$load_const entry(fixed bin,fixed bin),
 44           aq_man$trim_aq entry(fixed bin),
 45           aq_man$left_shift entry(fixed bin(8),bit(1) aligned),
 46           save_value entry(ptr),
 47           make_n_addressable entry(ptr,fixed bin),
 48           get_reference entry() returns(ptr),
 49           state_man$erase_reg entry(bit(19) aligned),
 50           expmac$two_eis entry(fixed bin(15),ptr,ptr),
 51           expmac$one entry(fixed bin(15),ptr,fixed bin),
 52           expmac$zero entry(fixed bin(15)),
 53           expmac entry(fixed bin(15),ptr);
 54 
 55 dcl       (addr,bit,fixed,mod,null,substr) builtin;
 56 
 57 dcl (     ldfx1               init(7),
 58           ldfx2               init(8),
 59           negate_op(4)        init(255,38,39,39),
 60           testfx1             init(508),
 61           test_lda            init(332),
 62           cana                init(323),
 63           lda                 init(1),
 64           als                 init(134),
 65           lls                 init(63),
 66           anaq                init(42),
 67           lrl                 init(62),
 68           lrs                 init(492),
 69           unpack_fl1          init(486),
 70           unpack_cfl1         init(488),
 71           clear_aq            init(58),
 72           move_cs_load_1      init(100),
 73           set_chars           init(436),
 74           load_logical        init(380)) fixed bin(15) int static;
 75 
 76 dcl       operator_table      init(262046) fixed bin(18) int static;  /* = 262144 - 98 */
 77 
 78 %include cgsystem;
 79 %include cg_reference;
 80 %include data_types;
 81 %include machine_state;
 82 %include boundary;
 83 %include symbol;
 84 
 85           p = pt;
 86 
 87 begin:    available, fs, ft = "0"b;
 88 
 89           type = p -> reference.data_type;
 90 
 91 l4:       if type = unpacked_ptr
 92           then do;
 93                type = real_fix_bin_2;
 94                goto chk;
 95                end;
 96 
 97           if type = packed_ptr
 98           then do;
 99                mac = lrl;
100                type = real_fix_bin_1;
101                goto chk;
102                end;
103 
104           if type >= char_string
105           then do;
106                arith = "0"b;
107                goto string_;
108                end;
109 
110           if type >= real_fix_dec
111           then do;
112                call error(374,cg_stat$cur_statement,p);
113                return;
114                end;
115 
116           mac = lrs;
117           if p -> reference.symbol ^= null
118           then if p -> reference.symbol -> symbol.unsigned
119                then mac = lrl;
120 
121 chk:      arith = "1"b;
122 
123           if control ^= 0
124           then do;
125                n = 3;
126                if p -> reference.value_in.q
127                then if type >= real_fix_bin_2 | (p -> reference.temp_ref & ^ p -> reference.value_in.storage)
128                     then do;
129                          call adjust_ref_count(p,-1);
130                          call expmac$zero((negate_op(type)));
131                          return;
132                          end;
133                end;
134           else do;
135                n = -1;
136 
137                if p -> reference.value_in.q
138                then do;
139                     if ft
140                     then if machine_state.indicators ^= 2
141                          then if (p -> reference.temp_ref & ^ p -> reference.value_in.storage) | ^ p -> reference.aligned_ref
142                               then do;
143                                    call expmac$zero(testfx1 + type - 1);
144                                    machine_state.indicators = 2;
145                                    end;
146                               else go to l1;
147 
148 drop:               if ^ p -> reference.shared
149                          then call adjust_ref_count(p,-1);
150 
151                     if ^ p -> reference.long_ref
152                          then call sv_value;
153 
154                     return;
155                     end;
156                end;
157 
158 l1:       if ^ p -> reference.aligned_ref
159           then do;
160                size = p -> reference.c_length;
161                type = bit_string;
162                if fs then goto l2; else goto str1;
163                end;
164 
165           if type = complex_flt_bin_1 then macro = ldfx2;
166           else macro = ldfx1 + n + type;
167 
168           call expmac(macro,p);
169 
170 thru:     call sv_value;
171 
172           if control = 0
173           then do;
174                q_reg.variable(1) = p;
175                q_reg.number = 1;
176                machine_state.indicators = 2;
177                p -> reference.value_in.q = "1"b;
178                end;
179 
180           return;
181 
182           /* we have a bit or character string to be loaded */
183 
184 string_:  if p -> reference.long_ref
185           then do;
186 
187 lg:            if p -> reference.value_in.string_aq
188                     then goto drop;
189 
190                call long_op$c_or_b(p,0,(set_chars));
191 
192                string_reg.variable = p;
193                string_reg.size = p -> reference.c_length;
194 
195                p -> reference.value_in.string_aq = "1"b;
196                return;
197                end;
198 
199           size = p -> reference.c_length * convert_size(type);
200 
201           if size = 0
202           then do;
203 caq:           call expmac$zero((clear_aq));
204                goto l72;
205                end;
206 
207 l2:       if p -> reference.value_in.a
208           then do;
209                if ft
210                then if machine_state.indicators ^= 1
211                     then goto str1;
212 
213                if a_reg.size < size then goto str1;
214 
215                call adjust_ref_count(p,-1);
216 
217                offset = a_reg.offset;
218                if offset ^= 0
219                then do;
220                     aq_length, k = offset + size;
221 
222                     if size ^= a_reg.size
223                          then a_reg.length = k;
224                          else k, aq_length = a_reg.length;
225                     goto sh;
226                     end;
227 
228                if mod(a_reg.length,bits_per_word) ^= 0 & ^ fs then goto mask_it;
229 
230                if a_reg.size = size
231                then do;
232                     if mod(a_reg.length,bits_per_word) = 0
233                          then call sv_value;
234                     return;
235                     end;
236 
237                goto mask_it;
238                end;
239 
240           /* the following section handles the case which arises from
241                     unspec(fixed(float_var))
242              where the value we want can be in the q register */
243 
244           if p -> reference.value_in.q
245           then do;
246 slide:         units = p -> reference.units;
247                if units = word_ then cfo = 0;
248                else do;
249                     cfo = mod(p -> reference.c_offset * convert_offset(units),
250                      bits_per_word);
251                     if cfo < 0 then cfo = cfo + bits_per_word;
252                     end;
253 
254                call adjust_ref_count(p,-1);
255 
256                /* this operation effectively erases both a and q
257                   since the shift moves the value from q to a
258                   rather than simply changing a_reg.offset */
259 
260                call state_man$erase_reg("11"b);   /* fixes bug 1502 */
261 
262                call expmac((lls),c_a((cfo + bits_per_word),1));
263 
264                k, aq_length = size;
265 
266                if fs then goto done; else goto l5;
267                end;
268 
269 str1:     if size > bits_per_word then d = fixed(control ^= 0,1); else d = 0;
270 
271           aq_length = bits_per_word*(d + 1);
272 
273           if p -> reference.aligned_ref
274           then do;
275                if ft then macro = test_lda; else macro = lda;
276                call expmac$one(macro,p,d);
277                goto done;
278                end;
279 
280           call setup;
281 
282 sh:       if offset > 0
283           then do;
284                call aq_man$left_shift(offset, k > bits_per_word);
285                k, aq_length = a_reg.length;
286                end;
287           else if p -> reference.padded_ref then goto done;
288 
289 l5:       if mod(k,bits_per_word) ^= 0
290           then do;
291 mask_it:       call aq_man$trim_aq(size);
292 l72:           aq_length = bits_per_two_words;
293                end;
294 
295 done:     if arith & ^ fs
296           then do;
297 
298                type = p -> reference.data_type;
299 
300                if type <= real_fix_bin_2 | type = packed_ptr
301                then do;
302                     k = bits_per_two_words - size;
303 em:                 call expmac(mac,c_a(k,1));
304                     goto thru;
305                     end;
306 
307                if type <= real_flt_bin_2
308                then do;
309                     call expmac$zero(unpack_fl1 - real_flt_bin_1 + type);
310                     goto thru;
311                     end;
312 
313                if type = complex_flt_bin_1
314                then do;
315                     k = bits_per_word - divide(size,2,17,0);
316                     if k > 0
317                     then do;
318                          mac = unpack_cfl1;
319                          goto em;
320                          end;
321                     end;
322 
323                goto thru;
324                end;
325 
326           a_reg.length = aq_length;
327           a_reg.offset = 0;
328 
329 done1:    a_reg.size = size;
330 
331           if a_reg.offset = 0
332           then call sv_value;
333 
334           a_reg.number = 1;
335           a_reg.variable(1) = p;
336           p -> reference.value_in.a = "1"b;
337 
338           if fs
339           then if ^ p -> reference.aligned_ref
340                then if a_reg.offset ^= 0 | mod(a_reg.length,bits_per_word) ^= 0
341                     then machine_state.indicators = 0;
342 
343 back:     return;
344 
345 load$for_test: entry(pt,control);
346 
347           /* this entry is called to load a bit string whose value
348              is to be tested against zero */
349 
350           p = pt;
351 
352           if ^ p -> reference.aligned_ref
353           then if p -> reference.ref_count > 1
354                     then goto begin;
355 
356           ft = "1"b;
357           arith, fs, available = "0"b;
358 
359           type = p -> reference.data_type;
360 
361           if p -> reference.ref_count > 1 then goto l4;
362 
363           if type ^= bit_string then goto l4;
364 
365           if p -> reference.value_in.a
366           then do;
367                if machine_state.indicators = 1
368                then if a_reg.offset = 0
369                     then if mod(a_reg.length,bits_per_word) = 0
370                           then goto drop;
371 
372                call adjust_ref_count(p,-1);
373                available = "1"b;
374                end;
375 
376           size = p -> reference.c_length;
377 
378           if p -> reference.aligned_ref & ^ available
379           then do;
380                call expmac$one((test_lda),p,control);
381                a_reg.offset = 0;
382                a_reg.length = fixed(size > bits_per_word,1) * bits_per_word + bits_per_word;
383                goto done1;
384                end;
385 
386           call setup;
387 
388           mask = (72)"0"b;
389           substr(mask,cfo+1,size) = (72)"1"b;
390 
391           q = generate_constant(mask,d+1);
392 
393           call expmac(cana+d,q);
394 
395           if available then return;
396 
397 done2:    a_reg.offset = cfo;
398           a_reg.length = k;
399           goto done1;
400 
401 load$for_store: entry(pt,control);
402 
403           /* this entry is called to load a value which will be stored elsewhere */
404 
405           p = pt;
406 
407           if ^ p -> reference.aligned_ref
408           then if p -> reference.ref_count > 1
409                then goto begin;
410 
411           fs = "1"b;
412           arith, available, ft = "0"b;
413 
414           type = p -> reference.data_type;
415 
416           if type ^= char_string
417           then if type ^= bit_string
418                then goto l4;
419 
420           if p -> reference.long_ref then goto lg;
421 
422           size = p -> reference.c_length * convert_size(type);
423 
424           if p -> reference.value_in.a
425                then if a_reg.size >= size
426                     then goto drop;
427                     else;
428                else if p -> reference.value_in.q
429                     then goto slide;
430 
431           if size = 0 then goto caq;
432 
433           if p -> reference.aligned_ref then goto str1;
434 
435           call setup;
436 
437           goto done2;
438 
439 load$short_string: entry(pt,control);
440 
441           /* this procedure is called to load the first word or two
442              of a long string */
443 
444           fs = "1"b;
445           arith, available, ft = "0"b;
446 
447           p = pt;
448           type = p -> reference.data_type;
449 
450           size = bits_per_word*(control+1);
451           goto l2;
452 
453 load$long_string: entry(pt);
454 
455           /* this entry is called to load the long string register
456              with a short string */
457 
458           p = pt;
459           type = p -> reference.data_type;
460           goto lg;
461 
462 load$for_save:      entry(pt,control);
463 
464           /* called by compile_exp$save when it has a hard_to_load string that wants to be
465              converted to an aligned temporary in storage and does not need to be loaded */
466 
467           p = pt;
468           for_save = "1"b;
469           go to begin;
470 
471 sv_value:      proc;
472 
473                if ^ p -> reference.aligned_ref
474                then if p -> reference.ref_count > 0
475                     then call save_value(p);
476 
477                end;
478 
479 setup:         proc;
480 
481                dcl (p1,p2) ptr;
482 
483                units = p -> reference.units;
484                if available
485                then cfo, offset = a_reg.offset;
486                else if units = word_
487                     then cfo, offset = 0;
488                     else do;
489                          cfo = mod(p -> reference.c_offset * convert_offset(units),bits_per_word);
490                          if cfo < 0 then cfo = cfo + bits_per_word;
491 
492                          if ^ p -> reference.hard_to_load
493                               then offset = cfo;
494                               else offset = 0;
495                          end;
496 
497                k = size + offset;
498 
499                d = fixed(k > bits_per_word,1);
500 
501                if available then return;
502 
503           /* if reference is hard to load we will move it into an aligned padded temporary
504              and load it from there */
505 
506                if p -> reference.hard_to_load
507                then do;
508                     if (^ arith | mod(size,bits_per_word) = 0) & (p -> reference.ref_count > 1 | for_save)
509                        & ^ p -> reference.aggregate
510                     then do;
511 
512                          /* We have a string with a high reference count, we will want future
513                             reference to the string to be made to the temporary we are using
514                             for the load */
515 
516                          call make_n_addressable(addr(pt),1);         /* make addressable and lock regs */
517 
518                          p2 = get_reference();              /* We will copy address into place holder */
519 
520                          p2 -> reference = p -> reference;
521                          p2 -> reference.qualifier, p2 -> reference.offset, p2 -> reference.length = null;
522                          string(p2 -> reference.info) = "0"b;
523                          p2 -> reference.perm_address = "1"b;
524 
525                          call save_value(p);                /* convert to temporary */
526 
527                          p -> reference.value_in.storage = "1"b;
528                          p1 = p;
529                          end;
530 
531                     else do;
532 
533                          /* Use double_temp as place to move */
534 
535                          p1 = c_a(46,4);
536                          p2 = p;
537                          end;
538 
539                     dt = type - char_string;
540 
541                     call expmac$two_eis(move_cs_load_1 + 2*d + dt,p1,p2);
542 
543                     if for_save then go to back;
544 
545                     call expmac$one((lda),p1,d);
546                     aq_length = bits_per_word * (d + 1);
547                     go to done;
548                     end;
549 
550 
551                call expmac$one((lda),p,d);
552 
553                a_reg.size = size;
554                a_reg.offset = cfo;
555                a_reg.length = k;
556 
557                end;
558 
559           end;