1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(89-07-28,JRGray), approve(89-07-28,MCR8123), audit(89-09-12,Vu),
 17      install(89-09-22,MR12.3-1073):
 18      Called state_man$save_regs to save temps before conditionals are
 19      evaluated (pl1 2091 2177).
 20   2) change(89-09-26,JRGray), approve(89-09-26,MCR8123), audit(89-09-27,Vu),
 21      install(89-09-29,MR12.3-1076):
 22      Fixed so that saving registers for label arrays no longer causes side
 23      effects.
 24                                                    END HISTORY COMMENTS */
 25 
 26 
 27 /* procedure to compile jumps and conditional jumps
 28 
 29    Initial Version: 29 March 1971 by BLW for Version II
 30           Modified:  9 January 1973 by BLW
 31           Modified: 12 June 1973 by RAB for EIS
 32           Modified: 7 May 1974 by RAB to fix bug 941 by providing eval_primaries
 33           Modified: 23 October 1974 by RAB to fix bug 1242
 34           Modified: 2 November 1975 by RAB to allow outside access to eval_prim
 35           Modified: 16 May 1976 by RAB to fix 1497
 36           Modified: 23 June 1976 by RAB to centralize use of cg_stat$last_call
 37           Modified: 1 July 1976 by RAB for label array improvements
 38           Modified: 29 July 1976 by RAB to fix minor bug in label array stuff
 39           Modified: 5 November 1976 by RAB to take advantage of fix to bugs 1542 & 1546
 40                     in operator_semantics
 41           Modified: 9 March 1977 by RAB to remove some dead code caused by previous change
 42           Modified 790703 by PG to fix 1844 (using a decimal expression in an if statement and the then or else clause
 43                     sometimes generated bad code), and to remove old_fortran jump_three_way.
 44           Modified 790824 by PG to tension goto's only if -optimize was specified.
 45 */
 46 
 47 jump_op:  proc(pt);
 48 
 49 /* parameters */
 50 
 51 dcl       pt ptr;             /* points at an operator node */
 52 
 53 /* automatic */
 54 
 55 dcl       (pb,p,arg(3),q,s1,save_p1) ptr,
 56           (atomic,p2_atomic,p3_atomic,conditional,is_return,load_index) bit(1) aligned,
 57           (dt,i,j,k,n,macro,code,hard,size,count,start,finish) fixed bin(15);
 58 
 59 /* based */
 60 
 61 dcl       based_bit_string bit(size) aligned based;
 62 
 63 /* builtins */
 64 
 65 dcl       (fixed,null,substr) builtin;
 66 
 67 /* defined */
 68 
 69 dcl       p1 ptr defined(arg(1)),
 70           p2 ptr defined(arg(2)),
 71           p3 ptr defined(arg(3));
 72 
 73 /* entries */
 74 
 75 dcl       expmac entry(fixed bin(15),ptr),
 76           expmac$fill_usage entry(fixed bin(18),fixed bin(17)),
 77           expmac$zero entry(fixed bin(15)),
 78           error entry(fixed bin,ptr,ptr),
 79           base_man$load_var entry(fixed bin,ptr,fixed bin),
 80           xr_man$load_any_var entry(ptr,fixed bin(15),fixed bin),
 81           xr_man$load_const entry(fixed bin(15),fixed bin),
 82           c_a entry(fixed bin(15),fixed bin) returns(ptr);
 83 dcl       m_a entry(ptr,bit(2) aligned);
 84 dcl       compile_exp$save entry(ptr) returns(ptr),
 85           need_temp entry(ptr,bit(2) aligned),
 86           prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
 87           state_man$flush entry,
 88           state_man$create_ms entry returns(ptr),
 89           state_man$save_regs entry(ptr),
 90           state_man$save_ms entry(ptr,bit(1) aligned),
 91           state_man$discard_ms entry,
 92           set_indicators entry(ptr,ptr,ptr,fixed bin(15)) returns(fixed bin(15));
 93 
 94 /* external static */
 95 
 96 dcl       (cg_stat$cur_block,cg_stat$cur_statement,cg_stat$jump_label,cg_stat$m_s_p) ptr ext,
 97           cg_stat$text_pos fixed bin(18) ext,
 98           cg_stat$skip_to_label bit(1) ext,
 99           cg_stat$cur_level fixed bin ext,
100           cg_stat$optimize bit (1) aligned external static;
101 
102 /* internal static */
103 
104 dcl (     tra                 init(169),
105           tra_ext_1           init(170),
106           tra_ext_2           init(171)) fixed bin (15) int static;
107 
108 dcl       reverse(8) fixed bin(15) int static
109           init(2,1,8,7,6,5,4,3);
110 
111 dcl       jump_table(8 /* operator */, 0:1 /* string? */, 0:1 /* reversed? */) fixed bin(15) int static
112           init(     /* true   */ 181, 181, 181, 181,
113                     /* false  */ 180, 180, 180, 180,
114                     /*  <     */ 176, 178, 177, 179,
115                     /*  >     */ 178, 176, 179, 177,
116                     /*  =     */ 180, 180, 180, 180,
117                     /*  ^=    */ 181, 181, 181, 181,
118                     /*  <=    */ 182, 184, 183, 185,
119                     /*  >=    */ 184, 182, 185, 183);
120 
121 /* include files */
122 
123 %include reference;
124 %include operator;
125 %include symbol;
126 %include label;
127 %include block;
128 %include statement;
129 %include nodes;
130 %include op_codes;
131 %include data_types;
132 %include list;
133 ^L
134 /* program */
135 
136           pb = cg_stat$cur_block;
137 
138           p = pt;
139           s1, p1 = p -> operand(1);
140 
141           /* if the destination of this transfer is another transfer,
142              go directly to destination of other transfer */
143 
144           if p1 -> node.type = label_node & cg_stat$optimize
145           then do;
146                     do count = 1 to 10;                     /* limit number of attempts */
147                          p3 = p1 -> label.statement;
148                          q = p3 -> statement.root;
149 
150                          do while(q = null);
151                               p3 = p3 -> statement.next;
152                               if p3 = null then goto prep;
153                               q = p3 -> statement.root;
154                          end;
155 
156                          if q -> operator.op_code ^= jump then goto prep;
157 
158                          if p3 = cg_stat$cur_statement
159                          then do;
160                               call error(325,p3,null);      /* infinite loop */
161                               goto prep;
162                               end;
163 
164                          p2 = q -> operand(1);
165                          if p2 -> node.type ^= label_node then goto prep;
166                          if p1 -> label.block_node ^= p2 -> label.block_node then goto prep;
167 
168                          p1 = p2;
169                     end;
170 
171 prep:          if s1 ^= p1
172                then do;
173 
174                     /* if we actually skipped over a transfer, we have to correct the
175                        reference counts on the statements involved */
176 
177                     q = s1 -> label.statement;
178                     q -> statement.reference_count = q -> statement.reference_count - 1;
179 
180                     q = p1 -> label.statement;
181                     q -> statement.reference_count = q -> statement.reference_count + 1;
182 
183                     end;
184 
185                end;
186 
187           else if p1 -> node.type = reference_node
188                then if p1 -> reference.symbol = null
189                     then do;
190 
191                          /* a reference node with no symbol would have been created
192                             by a call to c_a.  This is used to indicate a conditional
193                             return statement           */
194 
195                          is_return = "1"b;
196                          goto sh;
197                          end;
198                     else if p1 -> reference.symbol -> node.type = label_node
199                          then call init_label_array_info;
200 
201           is_return = "0"b;
202 
203           /* operator_semantics ensures that operand(1) of a conditional jump
204              operator will not be an operator node nor a reference node with
205              expressions hanging off.  This used to arise in the case of
206              if <expr> then goto <lab>; when <lab> was other than a simple
207              reference to a label constant */
208 
209           p1 = prepare_operand(p1,1,atomic);
210           dt = p1 -> reference.data_type;
211           s1 = p1 -> reference.symbol;
212 
213 sh:       hard = 0;
214 
215           /* get integer giving op_code going from 0 to 8 */
216 
217           i, n = fixed(p -> operator.op_code,9) - fixed(jump,9);
218 
219           if n >= 3 then n = 3;
220 
221           if n > 0
222           then do;
223 
224                /* have conditional jump */
225 
226                if is_return then goto cond_ok;
227 
228                if dt = label_constant
229                then if cg_stat$cur_level = s1 -> label.block_node -> block.level
230                     then do;
231                          if ^ cg_stat$cur_statement -> statement.checked
232                          then if ^ s1 -> label.allocated
233                               then call eval_primaries((s1 -> label.statement));
234                               else if s1 -> label.array
235                                    then call eval_all_primaries;
236                          go to cond_ok;
237                          end;
238 
239                /* special action needed for conditional transfer to something
240                   other than a label constant */
241 
242                hard = 1;
243                i = reverse(i);
244                save_p1 = p1;
245 
246                s1 = cg_stat$jump_label;
247                s1 -> label.allocated = "0"b;
248                s1 -> label.location = 0;
249                p1 = prepare_operand(s1,1,atomic);
250 
251 cond_ok:       conditional = "1"b;
252                p2 = p -> operand(2);
253                goto switch(n);
254                end;
255 
256           if dt = label_constant
257           then if s1 -> label.array
258           then if p1 -> reference.offset ^= null
259           then if ^ cg_stat$cur_statement -> statement.checked
260           then if cg_stat$cur_block = s1 -> label.block_node
261           then call eval_all_primaries;
262 
263           /* have unconditional jump */
264 
265 uncond:   conditional = "0"b;
266 
267           if dt = local_label_variable
268           then do;
269 
270                q = s1 -> symbol.block_node;
271 
272                if q = pb
273                then do;
274 
275                     /* the local label variable is declared in current block,
276                        can transfer indirectly thru the pointer */
277 
278 jump_ind:           call m_a(p1,"1"b);                      /* no indirection allowed */
279                     p1 -> reference.perm_address = "1"b;
280                     substr(p1 -> address.tag,2,1) = "1"b;   /* r mod -> r* mod */
281                     goto put_tra;
282                     end;
283 
284                /* if none of the blocks between this one and the block in
285                   which the local label variable is declared have stack frames,
286                   we also can jump indirectly */
287 
288                do while(pb -> block.no_stack);
289                     pb = pb -> block.father;
290                     end;
291 
292                if q = pb then goto jump_ind;
293 
294                /* must use an unwinder to do the transfer */
295 
296 unwind:        macro = tra_ext_2;
297                load_index = "0"b;
298                goto load_bp;
299                end;
300 
301           /* if operand(1) is a pointer, we have jump to a do block */
302 
303           if dt = unpacked_ptr then goto jump_ind;
304 
305           if dt = real_fix_bin_1
306           then do;
307 
308                /* have transfer resulting from Fortran assigned goto */
309 
310                call xr_man$load_any_var(p1,k,0);
311                p1 = c_a(k,8);                     /* 0,xr */
312                goto put_tra;
313                end;
314 
315           if dt ^= label_constant then goto unwind;
316 
317           /* get number of blocks between current block and block in
318              which the constant appears */
319 
320           k = cg_stat$cur_level - s1 -> label.block_node -> block.level;
321 
322           if k ^= 0
323           then do;
324 
325                /* must use an unwinder since label is in an outer block */
326 
327                load_index = "1"b;
328                macro = tra_ext_1;
329 
330 load_bp:       call base_man$load_var(2,p1,1);    /* load ptr into bp */
331 
332                if load_index
333                     then call xr_man$load_const(k,7);       /* load x7 with number of frames to walk */
334 
335                call state_man$discard_ms;
336 
337                call expmac$zero(macro);
338                goto done;
339                end;
340 
341 put_tra:  macro = tra;
342 
343           goto put;
344 
345           /* opcode is jump_true */
346 
347 switch(1):
348           if hard = 1 then goto sw_2;
349 
350 sw_1:     if p2 -> node.type ^= operator_node then goto jump_tf;
351 
352           /* look for case "if ^ bit(1) then ..." */
353 
354           if p2 -> operator.op_code ^= not_bits then goto jump_tf;
355           if p2 -> operand(1) -> reference.c_length ^= 1 then goto jump_tf;
356           if ^ p2 -> operand(1) -> reference.shared then go to jump_tf;
357 
358           /* have case "if ^ bit(1)", remove the not and change to jump_false */
359 
360           pt -> operand(2), p2 = p2 -> operand(2);
361           i = i + 1;
362           goto jump_tf;
363 
364           /* opcode is jump_false */
365 
366 switch(2):
367           if hard = 1 then goto sw_1;
368 
369 sw_2:     if p2 -> node.type ^= operator_node then goto chk_const;
370 
371           /* look for case of form "if ^ bit(1) then return;" */
372 
373           if p2 -> operator.op_code ^= not_bits then goto jump_tf;
374           if p2 -> operand(1) -> reference.c_length ^= 1 then goto jump_tf;
375           if ^ p2 -> operand(1) -> reference.shared then go to jump_tf;
376 
377           /* remove the node and change to jump_true */
378 
379           pt -> operand(2), p2 = p2 -> operand(2);
380           i = i - 1;
381           goto jump_tf;
382 
383           /* look for jump produces by construct
384                     do while("1"b);
385              and eliminate the test     */
386 
387 chk_const:
388           if p2 -> reference.offset ^= null then goto jump_tf;
389           if p2 -> reference.c_offset ^= 0 then goto jump_tf;
390           if p2 -> reference.length ^= null then goto jump_tf;
391 
392           q = p2 -> reference.symbol;
393           if ^ q -> symbol.constant then goto jump_tf;
394           if ^ q -> symbol.bit then goto jump_tf;
395           if q -> symbol.varying then goto jump_tf;
396           if q -> symbol.dimensioned then goto jump_tf;
397 
398           if hard > 0 then goto jump_tf;
399 
400           size = q -> symbol.c_dcl_size;
401           if q -> symbol.initial -> based_bit_string then return;
402 
403 jump_tf:  code = 5;
404           p3 = null;
405           goto jump_rel;
406 
407           /* have conditional jump */
408 
409 switch(3):
410           code = 0;
411 
412 jump_rel: p2 = prepare_operand(p2,1,p2_atomic);
413 
414           if code = 0
415           then do;
416                p3 = prepare_operand((p -> operand(3)),1,p3_atomic);
417                code = fixed(p2_atomic || p3_atomic,2);
418                end;
419 
420           if ^is_return & hard = 0 & dt = label_constant then         /* save useful registers now to avoid clobbering indicators later */
421                if s1 -> label.array then call label_array_save_regs;
422                else if ^s1 -> label.allocated then call state_man$save_regs((s1 -> label.statement));
423 
424           k = set_indicators(pt,p2,p3,code);
425 
426           if p2 -> reference.data_type <= real_flt_bin_2 then j = 0;
427           else do;
428                q = p2 -> reference.symbol;
429                j = fixed(q -> symbol.bit | q -> symbol.char,1);
430                end;
431 
432           macro = jump_table(i,j,k);
433 
434 put:      if is_return then goto putx;
435 
436           call m_a(p1,"0"b);
437           p1 -> reference.perm_address = "1"b;
438 
439           if p1 -> reference.ref_count = 1
440           then if p1 -> reference.offset ^= null | p1 -> reference.qualifier ^= null
441                then call need_temp(p1,"10"b);
442 
443           if dt = label_constant
444           then if hard ^= 0
445                then call state_man$flush;
446                else if s1 -> label.array
447                     then call process_label_array;
448                     else if ^ s1 -> label.allocated
449                          then call state_man$save_ms((s1 -> label.statement),conditional);
450                          else if ^ conditional
451                               then call state_man$discard_ms;
452                               else;
453           else if hard ^= 0
454                then call state_man$flush;
455 
456 putx:     call expmac(macro,p1);
457 
458           if hard = 1
459           then do;
460 
461                /* just finished first part of conditional transfer to jump_label,
462                   how go unconditional transfer to the real label */
463 
464                p1 = save_p1;
465 
466                s1 = p1 -> reference.symbol;
467                hard = 2;
468                goto uncond;
469                end;
470 
471 done:     if hard = 2
472           then do;
473                call expmac$fill_usage(cg_stat$text_pos,(cg_stat$jump_label -> label.location));
474                if cg_stat$m_s_p = null then cg_stat$m_s_p = state_man$create_ms();
475                else call state_man$flush;
476                cg_stat$skip_to_label = "0"b;
477                end;
478           else cg_stat$skip_to_label = ^ conditional;
479 
480           return;
481 
482 jump_op$eval_primaries:       entry(pt);
483 
484           p1 = pt;
485           if p1 -> node.type = label_node
486           then call eval_primaries((p1 -> label.statement));
487           else do;
488                call init_label_array_info;
489                call eval_all_primaries;
490                end;
491           return;
492 
493 
494 
495 eval_primaries:     proc(stm);
496 
497                /* eval_primaries is called before an easy conditional forward
498                jump to ensure that all expressions known now and known
499                at the label are fully evaluated.  It searches the primary list
500                at the label.  This routine is necessary because the code generator
501                does not usually evaluate the addr_fun operator as an optimization,
502                and because short unaligned strings are most often not converted
503                to aligned temporaries when they are stored, but rather when they
504                are loaded again later.  Thus, an anomalous situation would
505                arise, if an expr, like those mentioned above, was encountered
506                before a conditional forward jump without its being evaluated,
507                was evaluated along one branch of execution, thus making the
508                code generator think it was already evaluated when it encountered
509                the expr yet again along the other branch of execution.  */
510 
511 dcl            (prim,q,r,stm) ptr;
512 
513                do prim = stm -> statement.reference_list
514                     repeat prim -> element(4) while(prim ^= null);
515                     q = prim -> element(1);
516                     if q -> node.type = operator_node
517                     then do;
518                          r = q -> operand(1);
519                          if ^ r -> reference.evaluated
520                          then if r -> reference.ref_count > 1
521                               then if q -> operator.op_code = addr_fun
522                                    then call evaluate;
523                          end;
524                     else if ^ q -> reference.aligned_ref
525                          then if q -> reference.ref_count > 1
526                               then if ^q -> reference.symbol -> symbol.decimal
527                                    then call evaluate;
528                     end;
529 
530 evaluate:           proc;
531 
532                     /* evaluate q */
533 
534 dcl                 atomic bit(1) aligned;
535 
536                     r = prepare_operand(q,1,atomic);
537 
538                     if ^ atomic
539                     then if ^ r -> reference.aggregate
540                          then r = compile_exp$save(q);
541 
542                     end;
543 
544                end;
545 
546 
547 init_label_array_info: proc;
548 
549 /* initializes start, finish for further use */
550 
551                if p1 -> reference.offset = null
552                then start, finish = p1 -> reference.c_offset + 1;
553 
554                else do;
555                     start = 1;
556                     finish = p1 ->reference.symbol -> label.statement -> list.number;
557                     end;
558 
559                end;
560 
561 
562 eval_all_primaries: proc;
563 
564                /* finds all statements for which eval_primaries must be called.
565                   called only for label array in same block */
566 
567 dcl            (q,vector) ptr;
568 dcl            i fixed bin;
569 
570                vector = p1 -> reference.symbol -> label.statement;
571 
572                do i = start to finish;
573                     if vector -> list.element(i) ^= null
574                     then do;
575                          q = vector -> element(i);
576                          if q -> statement.object.start = 0
577                               then call eval_primaries(q);
578                          end;
579                     end;
580 
581                end;
582 
583 
584 process_label_array: proc;
585 
586                /* handle machine state for local jumps to label array target */
587 
588 dcl            (vector,q) ptr;
589 dcl            i fixed bin;
590 dcl            cond bit(1) aligned;
591 
592                cond = conditional | start ^= finish;
593                vector = s1 -> label.statement;
594 
595                do i = start to finish;
596                     if vector -> element(i) ^= null
597                     then do;
598                          q = vector -> element(i);
599                          if q -> statement.object.start = 0
600                          then call state_man$save_ms(q,cond);
601                          else if ^ cond
602                               then call state_man$discard_ms;
603                          end;
604                     end;
605 
606                if start ^= finish
607                     then call state_man$discard_ms;
608 
609                end;
610 
611 label_array_save_regs:        proc;
612 
613           /* saves temp-values before local jumps to label array target */
614 
615 dcl       i fixed bin;
616 dcl       q ptr;
617 
618           do i =  start to finish;
619                q = s1 -> label.statement -> element(i);
620                if q ^= null then
621                     if q -> statement.object.start = 0 then call state_man$save_regs(q);
622             end;
623      end label_array_save_regs;
624 
625 end jump_op;