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 /* This procedure compiles decimal arithmetic expressions.
 12 
 13    Initial Version: 28 September 1973 by RAB
 14           Modified: 9 March 1978 by RAB to fix 1714 (use compile_exp$save_exp instead of $save)
 15           Modified: 25 April 1979 by PCK to implement 4-bit decimal                       */
 16 
 17 decimal_op:         proc(node_pt,refs,atom);
 18 
 19 dcl       node_pt ptr,                  /* points at operator node */
 20           refs(3) ptr,                  /* ptrs to ref nodes of operands */
 21           atom(3) bit(1) aligned;       /* ON if operand is atomic */
 22 
 23 dcl       (op,p(128),s(128),q,r,imag(2)) ptr;
 24 dcl       op_code bit(9) aligned;
 25 dcl       (i,iop,j,max_scale,min_scale,ninst,scale(128),number,ltemp) fixed bin;
 26 dcl       (macro,mac) fixed bin(15);
 27 dcl       const char(2) aligned;
 28 dcl       (adjust,atomic,all_fixed) bit(1) aligned;
 29 dcl       mask bit(36) aligned;
 30 
 31 dcl (     move_rounded        init(439),
 32           d3mac(0:5)          init(438,440,446,450,456,451),
 33           d2mac(4)            init(442,448,454,458),
 34           cplx_ops(3:4)       init(465,466),
 35           abs_decimal         init(473),
 36           abs_decimal_4bit    init(737),
 37           move_numeric        init(438),
 38           min_dec             init(474),
 39           max_dec             init(475),
 40           mod_dec             init(546),
 41           dvrcdec             init(467)) fixed bin(15) int static;
 42 
 43 /* Meaning of iop:
 44           0         move
 45           1         add
 46           2         sub
 47           3         mult
 48           4         div
 49           5         mult_rounded  */
 50 
 51 dcl       1 exponent aligned,           /* exponent of a float dec constant */
 52           2 pad bit(1) unal,
 53           2 value fixed bin(7) unal;
 54 
 55 dcl       exponent_char char(1) based(addr(exponent)) aligned;
 56 
 57 dcl       1 op_table(0:5) aligned int static,
 58           2 macro fixed bin(15) init(541,542,0,543,544,545),
 59           2 ltemp fixed bin init(1,1,0,0,80,1);
 60 
 61 dcl       (addr,bit,divide,fixed,length,max,min,mod,null,string) builtin;
 62 
 63 dcl       adjust_ref_count entry(ptr,fixed bin);
 64 dcl       assign_op$fix_dec_scaled entry(ptr);
 65 dcl       (base_man$update_base,base_man$load_var_and_lock) entry(fixed bin,ptr,fixed bin);
 66 dcl       c_a entry(fixed bin,fixed bin) returns(ptr);
 67 dcl       compare_expression entry(ptr,ptr) returns(bit(1) aligned) reducible;
 68 dcl       compile_exp$save_exp entry(ptr) returns(ptr);
 69 dcl       copy_temp entry(ptr) returns(ptr);
 70 dcl       declare_temporary entry(bit(36) aligned,fixed bin(31),fixed bin(15),ptr) returns(ptr);
 71 dcl       expmac entry(fixed bin(15),ptr);
 72 dcl       expmac$many_eis entry(fixed bin(15),ptr,fixed bin);
 73 dcl       expmac$two_eis entry(fixed bin(15),ptr,ptr);
 74 dcl       expmac$one_eis entry(fixed bin(15),ptr);
 75 dcl       generate_constant$relocatable entry(ptr,fixed bin,bit(1) aligned) returns(ptr);
 76 dcl       generate_constant$char_string entry(char(*) aligned,fixed bin) returns(ptr);
 77 dcl       get_imaginary entry(ptr) returns(ptr);
 78 dcl       make_n_addressable entry(ptr,fixed bin);
 79 dcl       prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr);
 80 dcl       state_man$unlock entry;
 81 
 82 %include op_codes;
 83 %include operator;
 84 %include symbol;
 85 %include cg_reference;
 86 %include data_types;
 87 %include cgsystem;
 88 %include mask;
 89 %include nodes;
 90 %include machine_state;
 91 
 92           /* Initialize and compile any non-atomic operands */
 93 
 94           ninst = 1;
 95           op = node_pt;
 96           op_code = op -> operator.op_code;
 97           all_fixed = "1"b;
 98           number = op -> operator.number;
 99 
100           do i = 1 to number;
101                if ^ atom(i)
102                     then p(i) = compile_exp$save_exp((op -> operand(i)));
103                     else p(i) = refs(i);
104                s(i) = p(i) -> reference.symbol;
105                scale(i) = s(i) -> symbol.scale;
106                all_fixed = all_fixed & s(i) -> symbol.fixed;
107                end;
108 
109           adjust = ^ (p(1) -> reference.temp_ref | p(1) -> reference.shared);
110 
111           /* Handle negate case */
112 
113           if op_code = negate
114           then do;
115                if s(1) -> symbol.complex
116                then do;
117                     ninst = 2;
118 
119                     /* We will multiply by -1 */
120 
121 use_mult:           iop = 3;
122                     const = "-1";
123                     end;
124                else do;
125                     if ^ p(1) -> reference.temp_ref
126                     then if compare_expression(p(1),p(2))
127                          then go to use_mult;
128 
129                     /* we will subtract from zero */
130 
131                     iop = 2;
132                     const = "+0";
133                     end;
134 
135                p(3) = p(2);
136                s(3) = s(2);
137                p(2) = generate_constant$char_string(const,2);
138                p(2) -> reference.data_type = real_fix_dec;
139                s(2) = p(2) -> reference.symbol;
140 
141                call issue;
142                return;
143                end;
144 
145 
146           /* Split off the builtins */
147 
148           if op_code > div then go to builtin;
149 
150           /* Now, we handle the other arithmetic cases.  Most code in the external procedure
151              past here deals with ensuring that the scales of the operands fall within the
152              limits of the 6180's EIS descriptors. */
153 
154           if s(1) -> symbol.complex then ninst = 2;
155 
156           iop = fixed(op_code,9) - 16;            /* encode operation */
157 
158           if iop <= 2
159           then do;
160 
161                max_scale = max(scale(1),scale(2),scale(3));
162                min_scale = min(scale(1),scale(2),scale(3));
163 
164                if max_scale <= max_dec_scale & min_scale >= min_dec_scale
165                then call issue;
166 
167                else if max_scale - min_scale <= max_dec_scale - min_dec_scale & all_fixed
168                     then do;
169                          do i = 1 to 3 while(scale(i) ^= max_scale);
170                          end;
171 
172                          do j = 1 to 3;
173                               s(j) -> symbol.scale = max_dec_scale - scale(i) + scale(j);
174                               end;
175 
176                          call issue;
177 
178                          do j = 1 to 3;
179                               s(j) -> symbol.scale = scale(j);
180                               end;
181                          end;
182 
183                     else do;
184                          call fix_scales;
185                          call issue;
186                          end;
187 
188                return;
189                end;
190 
191           call fix_scales;
192 
193           if s(1) -> symbol.complex
194           then if s(2) -> symbol.complex | iop = 4
195                then if s(3) -> symbol.complex
196                     then do;
197                          ltemp = 48;
198                          macro = cplx_ops(iop);
199                          if ^ s(2) -> symbol.complex
200                               then macro = dvrcdec;
201                          call gen_call;
202                          return;
203                          end;
204 
205           if iop = 4
206           then if s(1) -> symbol.float
207                then do;
208 
209                     /* Due to a hardware deficiency, floating point division must be done into
210                        a temporary whose precision is 2 greater than that of the target's, and
211                        the result is then moved into the target */
212 
213                     q = p(1);
214                     p(1) = decimal_op$get_float_temp(s(1) -> symbol.c_dcl_size + 2,(s(1) -> symbol.complex));
215 
216                     call issue;
217 
218                     p(2) = p(1);
219                     p(1) = q;
220                     s(2) = p(2) -> reference.symbol;
221                     iop = 0;
222 
223                     call issue;
224                     return;
225                     end;
226 
227           call issue;
228           return;
229 
230 
231 
232 /* Section to do decimal builtins */
233 
234 builtin:
235           if op_code = abs_fun
236           then if s(2) -> symbol.real
237                then do;
238                     iop = 0;
239                     if adjust
240                          then p(1) -> reference.ref_count = p(1) -> reference.ref_count + 1;
241 
242                     call issue;
243 
244                     if s(1) -> symbol.unaligned
245                     then mac = abs_decimal_4bit;
246                     else mac = abs_decimal;
247 
248                     call expmac$one_eis(mac,p(1));
249 
250                     machine_state.indicators = min(machine_state.indicators,-1);
251                     return;
252                     end;
253 
254 
255           if op_code = round_fun
256           then do;
257 
258                /* NOTE:  the following code assumes that the target has the proper pre-
259                          cision and scale */
260 
261                scale(3) = 0;
262                call fix_scales;
263 
264                if s(1) -> symbol.complex then ninst = 2;
265 
266                if s(1) -> symbol.float
267                then iop = 0;
268                else do;
269 
270                     /* generate a multiply rounded by 10**K */
271 
272                     iop = 5;
273                     s(1) -> symbol.scale = 0;
274                     s(2) -> symbol.scale = 0;
275                     p(3) = p(2);
276                     s(3) = s(2);
277                     exponent.pad = "0"b;
278                     exponent.value = scale(1) - scale(2);
279                     p(2) = generate_constant$char_string("+1" || exponent_char,3);
280                     s(2) = p(2) -> reference.symbol;
281                     end;
282 
283                call issue;
284 
285                if s(1) -> symbol.fixed
286                then do;
287                     s(1) -> symbol.scale = scale(1);
288                     s(3) -> symbol.scale = scale(2);
289                     end;
290                return;
291                end;
292 
293           if op_code = min_fun | op_code = max_fun
294           then do;
295                call fix_scales;
296                if op_code = min_fun
297                     then macro = min_dec;
298                     else macro = max_dec;
299                mac = move_numeric + fixed(s(1) -> symbol.float,1);
300 
301                if adjust
302                     then p(1) -> reference.ref_count = p(1) -> reference.ref_count + 1;
303 
304                call expmac$two_eis(mac,p(1),p(2));
305 
306                do i = 3 to number;
307                     if ^ p(i) -> reference.shared
308                          then p(i) -> reference.ref_count = p(i) -> reference.ref_count + 1;
309                     if adjust
310                          then p(1) -> reference.ref_count = p(1) -> reference.ref_count + 2;
311                     call expmac$two_eis(macro,p(1),p(i));
312                     call expmac$two_eis(mac,p(1),p(i));
313                     end;
314 
315                if adjust
316                     then call adjust_ref_count(p(1),-1);
317                refs(2) = p(2);
318                return;
319                end;
320 
321           if op_code = trunc_fun
322           then do;
323                call fix_scales;
324                if s(1) -> symbol.fixed
325                then do;
326                     call expmac$two_eis((move_numeric),p(1),p(2));
327                     return;
328                     end;
329                end;
330 
331           if op_code = complex_fun
332           then do;
333                imag(1) = get_imaginary(p(1));
334                macro = move_numeric + fixed(s(1) -> symbol.float,1);
335                call expmac$two_eis(macro,p(1),p(2));
336                call expmac$two_eis(macro,imag(1),p(3));
337                return;
338                end;
339 
340           if op_code = real_fun | op_code = imag_fun
341           then do;
342                if op_code = real_fun
343                then q = p(2);
344                else do;
345                     q = get_imaginary(p(2));
346                     if ^ p(2) -> reference.shared
347                          then call adjust_ref_count(p(2),-1);
348                     end;
349 
350                call expmac$two_eis(move_numeric + fixed(s(1) -> symbol.float,1),p(1),q);
351 
352                return;
353                end;
354 
355           if op_code = conjg_fun
356           then do;
357                imag(1) = get_imaginary(p(1));
358                imag(2) = get_imaginary(p(2));
359 
360                iop = 0;
361                call issue;
362 
363                p(1) = imag(1);
364                p(2) = imag(2);
365                go to use_mult;
366                end;
367 
368 /* Anything that reaches here results in calls to pl1_operators_ */
369 
370           if op_code ^= sign_fun
371           then if op_code ^= abs_fun
372                then call fix_scales;
373                else;
374           else do;
375                number = 1;
376                p(1) = p(2);
377                s(1) = s(2);
378                scale(1) = scale(2);
379                end;
380 
381           if op_code = pl1_mod_fun
382           then do;
383 
384                /* dec_ops_ will get stack extension */
385 
386                ltemp = 0;
387                macro = mod_dec;
388                end;
389           else do;
390                iop = fixed(op_code,9) - 144;
391                macro = op_table(iop).macro;
392                ltemp = op_table(iop).ltemp;
393                if ltemp = 1
394                     then ltemp = divide(p(2) -> reference.c_length + 3,chars_per_word,17,0);
395                end;
396 
397           call gen_call;
398           return;
399 
400 
401 
402 
403 
404 /* decimal_op$get_float_temp returns a floating decimal temporary of precision prec which is
405    complex is complex is ON */
406 
407 decimal_op$get_float_temp:    entry(prec,complex) returns(ptr);
408 
409 dcl       prec fixed bin(24);
410 dcl       complex bit(1) aligned;
411 
412           if complex
413                then mask = complex_mask;
414                else mask = real_mask;
415 
416           r = declare_temporary(mask | float_mask | decimal_mask | aligned_mask,(prec),
417                                         0,null);
418           r = copy_temp(r);
419           r = prepare_operand(r,1,atomic);
420           return(r);
421 
422 
423 
424 /* decimal_op$change_target is called when the target of a decimal arithmetic
425    operation has a scale outside of hardware limits to determine if the target
426    should be converted to floating point */
427 
428 decimal_op$change_target:     entry(node_pt) returns(bit(1) aligned);
429 
430           op = node_pt;
431           op_code = op -> operator.op_code;
432 
433           if op_code = add | op_code = sub
434           then do;
435                scale(1) = op -> operand(1) -> reference.symbol -> symbol.scale;
436                do i = 2 to 3;
437                     if op -> operand(i) -> node.type = reference_node
438                          then p(i) = op -> operand(i);
439                          else p(i) = prepare_operand((op -> operand(i)),1,atomic);
440                     if p(i) -> reference.symbol -> symbol.float
441                          then return("1"b);
442                     scale(i) = p(i) -> reference.symbol -> symbol.scale;
443                     end;
444 
445                if max(scale(1),scale(2),scale(3)) - min(scale(1),scale(2),scale(3))
446                      <= max_dec_scale - min_dec_scale
447                     then return("0"b);
448                end;
449 
450           return("1"b);
451 
452 
453 
454 issue:    proc;
455 
456 dcl       arg(2,3) ptr;
457 dcl       (i,nrands) fixed bin;
458 dcl       macro fixed bin(15);
459 dcl       (use_move,switch_rands) bit(1) aligned;
460 
461 /* This routine does most of the work of issuing a decimal macro.  It must handle the cases
462    concerning complex operands and cases in which the target variable is the same as one
463    of the sources */
464 
465           use_move = "0"b;
466 
467           if iop ^= 0
468                then nrands = 3;
469                else nrands = 2;
470           macro = d3mac(iop);
471 
472           if ^ p(1) -> reference.temp_ref
473           then do i = 2 to mod(iop,2) + 2;
474 
475                /* If the target is not a temporary, it may be one of the sources as well */
476 
477                if compare_expression(p(1),p(i))
478                then do;
479                     if ^ p(i) -> reference.shared
480                          then call adjust_ref_count(p(i),-1);
481                     if nrands = 2
482                     then do;
483                          if adjust
484                               then call adjust_ref_count(p(1),-1);
485                          return;
486                          end;
487                     nrands = 2;
488                     macro = d2mac(iop);
489                     if i = 2
490                     then do;
491                          p(2) = p(3);
492                          s(2) = s(3);
493                          scale(2) = scale(3);
494                          end;
495                     if iop <= 2
496                     then if ^ s(2) -> symbol.complex
497                          then ninst = 1;
498                     go to adjust_mac;
499                     end;
500                end;
501 
502 adjust_mac:
503           macro = macro + fixed(s(1) -> symbol.float,1);
504 
505           /* fill in the argument lists */
506 
507           do i = 1 to nrands;
508                arg(1,i) = p(i);
509                if ninst > 1
510                then if s(i) -> symbol.complex
511                     then arg(2,i) = get_imaginary(p(i));
512                     else if iop = 1
513                          then do;
514                               use_move = "1"b;
515                               switch_rands = i = 2;
516                               end;
517                          else if iop = 2
518                               then if i = 3
519                                    then do;
520                                         use_move = "1"b;
521                                         switch_rands = "0"b;
522                                         end;
523                                    else do;
524                                         arg(2,i) = generate_constant$char_string("+0",2);
525                                         arg(2,i) -> reference.data_type = real_fix_dec;
526                                         end;
527                               else do;
528                                    if ^ p(i) -> reference.shared
529                                         then p(i) -> reference.ref_count = p(i) -> reference.ref_count + 1;
530                                    arg(2,i) = p(i);
531                                    end;
532                end;
533 
534           /* Now, issue the macro . */
535 
536           do i = 1 to ninst;
537                if use_move
538                then if i = ninst
539                     then do;
540                          macro = d3mac(0);
541                          nrands = 2;
542                          if switch_rands
543                               then arg(2,2) = arg(2,3);
544                          end;
545                call expmac$many_eis(macro,addr(arg(i,1)),nrands);
546                end;
547 
548           end;
549 
550 
551 fix_scales:         proc;
552 
553           /* replaces fixed scaled inputs whose scales are outside hardware limits with their
554              floating point equivalents */
555 
556           do i = 2 to number;
557                if scale(i) > max_dec_scale | scale(i) < min_dec_scale
558                then do;
559                     call assign_op$fix_dec_scaled(p(i));
560                     s(i) = p(i) -> reference.symbol;
561                     scale(i) = 0;
562                     end;
563                end;
564           end;
565 
566 gen_call: proc;
567 
568           /* generates a call to pl1_operators_ to do decimal operation */
569 
570 dcl       (desc,work) ptr;
571 dcl       clength fixed bin(6);
572 dcl       one_rand bit(1) aligned;
573 
574 dcl       1 descriptor(3) aligned,
575           2 address bit(18) unal,
576           2 fract   bit(2) unal,
577           2 type    bit(4) unal,
578           2 dscale  fixed bin(5) unal,
579           2 dlength bit(6) unal;
580 
581 dcl       1 four_bit_descriptor(3) aligned based(addr(descriptor)),   /* EIS 4-bit operand descriptor */
582           2 address bit(18) unal,
583           2 fract   bit(3) unal,
584           2 type    bit(3) unal,
585           2 dscale  fixed bin(5) unal,
586           2 dlength bit(6) unal;
587 
588           /* get a pointer to a work area into the ab */
589 
590           if ltemp > 0
591           then do;
592                work = c_a(ltemp,12);
593                work -> reference.ref_count = 2;
594                call base_man$load_var_and_lock(2,work,3);
595                end;
596 
597           /* make sure bp is uninvolved in addressing code for the decimal operands */
598 
599           call base_man$update_base(0,null,1);
600 
601           /* make all decimal operands addressable without any tags */
602 
603           call make_n_addressable(addr(p),- number);
604 
605           /* now build a string of descriptors for use by the operator */
606 
607           do i = 1 to number;
608                descriptor(i).address = string(p(i) -> reference.address);
609                if s(i) -> symbol.unaligned
610                then do;
611                          four_bit_descriptor(i).fract = bit(fixed(p(i) -> reference.c_f_offset,3),3);
612                          four_bit_descriptor(i).type = "10"b || s(i) -> symbol.fixed;
613                     end;
614                else do;
615                          descriptor(i).fract = bit(fixed(p(i) -> reference.c_f_offset,2),2);
616                          descriptor(i).type = "000"b || s(i) -> symbol.fixed;
617                     end;
618                descriptor(i).dscale = - scale(i);
619                clength = p(i) -> reference.c_length;
620                if s(i) -> symbol.complex
621                     then clength = divide(clength,2,6,0);
622                descriptor(i).dlength = bit(clength,6);
623                end;
624 
625           desc = generate_constant$relocatable(addr(descriptor),number,"0"b);
626 
627           /* generate the operator call */
628 
629           call expmac(macro,desc);
630 
631           /* unlock the registers and decrement the operands' reference counts */
632 
633           call state_man$unlock;
634 
635           if ltemp > 0
636                then call adjust_ref_count(work,-1);
637 
638           one_rand = number = 1;
639 
640           do i = 1 to number;
641                if ^ p(i) -> reference.shared
642                then if ^ p(i) -> reference.temp_ref | i > 1 | one_rand
643                     then call adjust_ref_count(p(i),-1);
644                end;
645 
646           end;
647 
648 end;