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 compile calls
 12 
 13    Initial Version: 16 April 1971 by BLW for Version II
 14           Modified:  5 November 1972 by BLW
 15           Modified: 15 February 1973 by RAB
 16           Modified: 25 June 1973 by RAB
 17           Modified: 2 August 1974 by RAB for constant arg list calls
 18           Modified: 16 November 1974 by RAB to fix bug 1232
 19           Modified: 17 November 1974 by RAB to fix bug 1255
 20           Modified: 12 December 1975 by RAB to remove call to state_man$erase_reg
 21           Modified: 23 June 1976 by RAB to centralize use of cg_stat$last_call
 22           Modified: 10 September 1977 by RAB to fix 1613 by adding 3rd arg to store_bit_address
 23           Modified: 23 April 1979 by PCK to implement 4-bit decimal
 24           Modified: 23 June 1981 by EBush to increase max size of arg lists
 25           Modified: 11 September 81 by EBush to add prepare_call_long and
 26                     prepare_quick_call_long macros.  */
 27 
 28 call_op:  proc(pt) returns(ptr);
 29 
 30 dcl       pt ptr;             /* points at call operator node */
 31 
 32 dcl       (cg_stat$cur_tree,cg_stat$double_temp,cg_stat$temp_ref,cg_stat$cur_node) ptr ext,
 33           cg_stat$cur_block ptr ext,
 34           cg_stat$text_pos fixed bin(18) ext,
 35           cg_stat$cur_level fixed bin ext;
 36 
 37 dcl       (p,q,node_pt,ret_pt,ent_pt,sal_pt,arglist,ap,p2,p2s,p3,
 38           arg(3),args,descs,ent_blk,save_cur_node) ptr,
 39           (i,j,n,skip,ent_type,n_args,arg_pos,dt) fixed bin,
 40           (macro1,macro2) fixed bin(15),
 41           last_freed fixed bin(18),
 42           arg_list_extent fixed bin(35),
 43           xr fixed bin(3),
 44           (atom,useless,quick,reset,use_itp) bit(1) aligned;
 45 
 46 dcl       prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
 47           expmac entry(fixed bin(15),ptr),
 48           copy_temp entry(ptr) returns(ptr),
 49           (stack_temp$assign_temp,stack_temp$free_temp) entry(ptr),
 50           compile_exp$save entry(ptr) returns(ptr),
 51           compile_exp$save_exp entry(ptr) returns(ptr),
 52           (compile_exp,load_size) entry(ptr);
 53 dcl       compare_expression entry(ptr,ptr) returns(bit(1) aligned) reducible;
 54 dcl       share_expression entry(ptr) returns(ptr),
 55           base_man$store_ptr_to entry(ptr,ptr),
 56           store_bit_address entry(ptr,ptr,fixed bin(18)),
 57           base_man$load_var entry(fixed bin,ptr,fixed bin),
 58           c_a entry(fixed bin,fixed bin) returns(ptr),
 59           (long_op$extend_stack,adjust_ref_count) entry(ptr,fixed bin(15)),
 60           store$save_string_temp entry(ptr),
 61           long_op$c_or_b entry(ptr,fixed bin,fixed bin(15)),
 62           need_temp entry(ptr,bit(2) aligned),
 63           xr_man$load_any_const entry(fixed bin,fixed bin(3)),
 64           xr_man$load_const entry(fixed bin,fixed bin),
 65           xr_man$super_lock entry(fixed bin),
 66           m_a entry(ptr,bit(2) aligned),
 67           expmac$zero entry(fixed bin(15)),
 68           expmac$many entry(fixed bin(15),ptr,fixed bin),
 69           state_man$flush entry,
 70           state_man$flush_address entry(ptr),
 71           cg_error entry(fixed bin,fixed bin),
 72           generate_constant$relocatable entry(ptr,fixed bin,bit(1) aligned) returns(ptr);
 73 
 74 dcl       (addr,bit,fixed,hbound,null,substr) builtin;
 75 
 76 dcl (     call_ent_var        init(230),
 77           zero_mac            init(308),
 78           lda                 init(1),
 79           alloc_char_temp     init(89),
 80           realloc_char_temp   init(92),
 81           prepare_call        init(362),
 82           prepare_quick_call  init(363),
 83           prepare_call_long   init(741),
 84           prepare_quick_call_long  init(742),
 85           quick_call          init(367)) fixed bin(15) int static;
 86 
 87 %include cg_reference;
 88 %include operator;
 89 %include list;
 90 %include symbol;
 91 %include block;
 92 %include temporary;
 93 %include data_types;
 94 %include op_codes;
 95 %include nodes;
 96 %include boundary;
 97 %include cgsystem;
 98 %include its;
 99 
100           save_cur_node = cg_stat$cur_node;
101           node_pt, cg_stat$cur_node = pt;
102           ret_pt = node_pt -> operand(1);
103 
104           /* get info about entry */
105 
106           q = node_pt -> operand(2);
107           ent_pt = prepare_operand(q,1,atom);
108           if ^ atom then ent_pt = compile_exp$save(q);
109 
110           ent_type = ent_pt -> reference.data_type;
111           if ent_type ^= int_entry then quick = "0"b;
112           else do;
113                ent_blk = ent_pt -> reference.symbol -> symbol.equivalence;
114                quick = ent_blk -> block.no_stack;
115                end;
116 
117           /* get ptr to std_arg_list operator */
118 
119           sal_pt = node_pt -> operand(3);
120 
121           /* The rest of the main procedure is put in a begin block so that
122              the extents of arrays (and bit vectors) that hold values for
123              each arg in the arg_list will conform to the number of args, via
124              auto adjustable storage, thus avoiding an artificial limit on
125              the number of args in a call. */
126 
127           if sal_pt = null
128                then arg_list_extent = 1;
129                else arg_list_extent = sal_pt->operand(2)->list.number;
130 
131      begin;
132           dcl rand_pt(arg_list_extent) ptr;
133           dcl (adjust,already)  bit(arg_list_extent);
134 
135 
136           if sal_pt = null
137           then do;
138 
139                /* no arguments, no sweat if this is quick call */
140 
141                if quick
142                then do;
143                     call state_man$flush;
144                     call expmac((quick_call),ent_pt);
145                     goto done;
146                     end;
147 
148                /* use temp location for arglist */
149 
150                arglist = cg_stat$double_temp;
151                descs = null;
152                n_args = 0;
153                goto l3;
154                end;
155 
156           /* get ptr to arglist and skip if we already evaluated it */
157 
158           arglist = sal_pt -> operand(1);
159           arglist -> reference.units = word_;
160           arglist -> reference.perm_address = "0"b;
161           if arglist -> reference.evaluated
162           then do;
163                arglist->reference.no_address = "1"b;
164                goto l2;
165                end;
166 
167           args = sal_pt -> operand(2);
168           n_args = args -> list.number;
169 
170           if n_args > max_list_elements
171           then do;
172                call cg_error(340,max_list_elements);
173                n_args = max_list_elements;
174                end;
175 
176           /* get info about all the arguments of the call */
177 
178           do i = 1 to n_args;
179                q = args -> element(i);
180                p = prepare_operand(q,-1,atom);
181 
182                if atom then goto step;
183                if q -> node.type ^= operator_node then goto step;
184 
185                if q -> operator.op_code = assign | q -> operator.op_code = assign_size_ck
186                then do;
187 
188                     if p -> reference.length = null then goto l1;
189 
190                     /* we have adjustable string temp = something,
191                        check to see if we have the same size on both
192                        sides of the assignment */
193 
194                     /* We have to be prepared to restore the
195                        original value of the data_type field
196                        of operand(2) if it is a reference,
197                        because if we don't, prepare_operand
198                        will get confused and not evaluate
199                        the length expression, if any. */
200 
201                     p2 = q -> operand(2);
202                     if p2 -> node.type = operator_node
203                          then p2 = p2 -> operand(1);
204                     dt = p2 -> reference.data_type;
205 
206                     p2 = prepare_operand((q -> operand(2)),-1,atom);
207                     p2s = p2 -> reference.length;
208 
209                     reset = "0"b;
210 
211                     if p2s = p -> reference.length
212                     then;
213                     else if compare_expression(p2s,(p -> reference.length))
214                          then do;
215 
216                               /* Have same size on both sides of assign, so optimize */
217 
218                               p2s = share_expression(p2s);
219                               if p2s -> node.type = reference_node
220                                    then p2s = prepare_operand(p2s,1,useless);
221                               p -> reference.length = p2s;
222                               end;
223                          else reset = "1"b;
224 
225                     if (p -> reference.data_type ^= p2 -> reference.data_type) | atom
226                     then do;
227 
228                          /* We restore the data_type field before
229                             calling compile_exp$save if the
230                             2 length exprs were not the
231                             same, as previously mentioned */
232 
233                          if reset
234                               then p2 -> reference.data_type = dt;
235                          p = compile_exp$save(q);
236                          end;
237                     else do;
238                          p -> reference.ref_count = p -> reference.ref_count + 1;
239                          dt = p -> reference.data_type - char_string;
240                          call compile_exp((q -> operand(2)));
241                          call long_op$extend_stack(p,realloc_char_temp+dt);
242                          call store$save_string_temp(p);
243                          call adjust_ref_count((q -> operand(2)),-1);
244                          end;
245 
246                     goto step;
247                     end;
248 
249                if p -> reference.long_ref
250                then p = compile_exp$save_exp(q);
251                else do;
252 l1:                 if p -> reference.c_length > 0
253                      | p -> reference.data_type < char_string
254                      | p -> reference.data_type > bit_string
255                     then p = compile_exp$save_exp(q);
256                     else do;
257 
258                          /* have zero length string being passed out */
259 
260                          p = q -> operand(1);
261 
262                          call stack_temp$assign_temp(p);
263 
264                          if p -> reference.varying_ref
265                          then do;
266                               p -> reference.c_offset = p -> reference.c_offset - 1;
267                               p -> reference.ref_count = p -> reference.ref_count + 1;
268                               call expmac((zero_mac),p);
269                               p -> reference.c_offset = p -> reference.c_offset + 1;
270                               end;
271                          end;
272                     end;
273 
274 step:          rand_pt(i) = p;
275                if p -> reference.length ^= null
276                then if p -> reference.ref_count = 1
277                     then call need_temp(p,"01"b);
278                end;
279 
280           /* allocate space for temp result of function, if necessary */
281 
282           if p -> reference.temp_ref
283           then if ^ p -> reference.allocated
284                then do;
285 
286                     if ^ p -> reference.allocate
287                     then do;
288                          p, ret_pt, rand_pt(n_args) = copy_temp(p);
289                          p -> reference.ref_count = 2;
290                          end;
291 
292                     call stack_temp$assign_temp(p);
293                     p -> reference.value_in.storage = "1"b;
294                     end;
295 
296           /* check to see if we can generate a constant arg list */
297 
298           if quick
299           then do;
300                use_itp = check_arg_addrs();
301                if use_itp
302                then do;
303                     call gen_itp_list;
304                     go to l2;
305                     end;
306                end;
307 
308           /* allocate space for arg list if necessary */
309 
310           if ^ arglist -> reference.allocated
311           then do;
312                if ^ arglist -> reference.allocate then arglist = copy_temp(arglist);
313                call stack_temp$assign_temp(arglist);
314                end;
315 
316           last_freed = arglist -> reference.qualifier -> temporary.last_freed;
317 
318           arg_pos = arglist -> reference.qualifier -> temporary.location;
319 
320           if arg_pos + 2*n_args + 1 < 16384
321                then ap = c_a(arg_pos,4);
322                else do;
323                     ap = c_a(0,4);
324                     call xr_man$load_const(arg_pos,1);      /* xr1 is safe because it is out of the pool */
325                     ap -> address.tag = "001001"b;
326                     arg_pos = 0;
327                     string(arglist -> reference.address) = string(ap -> reference.address);
328                     arglist->reference.perm_address = "1"b;
329                     end;
330 
331           /* put ptrs to arguments into arg list.  If an arg is a temporary, we will
332              adjust the reference count up by 1 so that the temporary remains allocated
333              until we return from call_op.  If we did not do this and some of the
334              registers had to be saved in storage, one of the temporaries used for
335              an arg passed by value might get used. */
336 
337           adjust = "0"b;
338           do i = 1 to n_args;
339                ap -> address.offset = bit(fixed(arg_pos + 2*i,15),15);
340                p = rand_pt(i);
341 
342                if p -> reference.temp_ref
343                then do;
344                     p -> reference.ref_count = p -> reference.ref_count + 1;
345                     substr(adjust,i,1) = "1"b;
346                     end;
347 
348                call store_bit_address(ap,p,last_freed);
349                end;
350 
351           /* decide if we have to skip a position in the arg list for stack ptr */
352 
353           skip = fixed(((ent_type = int_entry) & ^ quick) | (ent_type = entry_variable),1) + n_args;
354 
355           descs = sal_pt -> operand(3);
356           if descs = null then goto l2;
357 
358           /* put ptrs to descriptors into arg list */
359 
360           already = "0"b;
361           do i = 1 to n_args;
362 
363                if substr(already,i,1) then goto next;
364 
365                ap -> address.offset = bit(fixed(arg_pos + 2*(i+skip),15),15);
366                p = prepare_operand((descs -> element(i)),1,atom);
367                call base_man$store_ptr_to(p,ap);
368 
369               /* if same descriptor used later, store ptr to it now */
370 
371                do j = i + 1 to n_args;
372                     if p = descs -> element(j)
373                     then do;
374                          ap -> address.offset = bit(fixed(arg_pos + 2*(j+skip),15),15);
375                          call base_man$store_ptr_to(p,ap);
376                          substr(already,j,1) = "1"b;
377                          end;
378                     end;
379 
380 next:          end;
381 
382 l2:
383 
384           /* generate call */
385 
386 l3:       arg(1) = arglist;
387           if n_args > 127
388                then arg(2) = c_a((n_args*2),3);   /* for prepare_call_long macros */
389                else arg(2) = c_a((n_args*2048),2);  /* for prepare_call macros */
390 
391           if ent_type = int_entry & ^ quick
392           then do;
393                j = cg_stat$cur_level - ent_pt -> reference.symbol -> symbol.block_node -> block.level;
394 
395                if j ^= 0
396                then do;
397                     call xr_man$load_const(j,7);
398                     call xr_man$super_lock(7);
399                     ent_type = int_entry_other;
400                     end;
401 
402                end;
403 
404           if ret_pt ^= null
405           then if ^ ret_pt -> reference.shared
406                then if cg_stat$cur_tree = node_pt
407                     then call adjust_ref_count(ret_pt,-1);
408 
409           if quick
410           then do;
411                if use_itp
412                then do;
413                     call base_man$load_var(2,arglist,1);
414                     if descs ^= null
415                          then call expmac((lda),arglist);
416                     end;
417                else if n_args > 127
418                         then call expmac$many((prepare_quick_call_long),addr(arg),2);
419                         else call expmac$many((prepare_quick_call),addr(arg),2);
420 
421                call state_man$flush;
422                call expmac((quick_call),ent_pt);
423                end;
424           else do;
425                if n_args > 127
426                     then call expmac$many((prepare_call_long),addr(arg),2);
427                     else call expmac$many((prepare_call),addr(arg),2);
428                call base_man$load_var(2,ent_pt,1);
429                call state_man$flush;
430                call expmac$zero(call_ent_var + 2*(ent_type - entry_variable) + fixed(descs ^= null,1));
431                end;
432 
433           if adjust = "0"b then goto done;
434 
435           do i = 1 to n_args;
436                if substr(adjust,i,1)
437                then do;
438                     p = rand_pt(i);
439                     call adjust_ref_count(p,-1);
440                     end;
441                end;
442 
443 done:
444           ent_pt -> reference.perm_address = "0"b;
445           cg_stat$cur_node = save_cur_node;
446 
447           if ret_pt ^= null
448           then if ^ ret_pt -> reference.shared
449                then ret_pt -> reference.evaluated = "1"b;
450 
451           return(ret_pt);
452 /*^L*/
453 check_arg_addrs:    proc reducible returns(bit(1) aligned);
454 
455 dcl            (f,p,s) ptr;
456 
457                /* checks args to see if all addresses are suitable for use
458                   in a constant arg list */
459 
460                if cg_stat$cur_block -> block.last_auto_loc >= 16384
461                     then go to fail;
462 
463                /* make sure quick block contains no non-quick blocks */
464 
465                if ent_blk -> block.son ^= null
466                then if ^ check_block((ent_blk -> block.son))
467                     then go to fail;
468 
469                /* now check args for constant addresses */
470 
471                do i = 1 to n_args;
472                     p = rand_pt(i);
473 
474                     if p -> reference.offset ^= null
475                          then go to fail;
476 
477                     s = p -> reference.symbol;
478 
479                     if p -> reference.temp_ref
480                     then do;
481                          if p -> reference.address_in.storage
482                               then go to fail;
483 
484                          if p -> reference.aggregate
485                          then do;
486                               do f = s repeat f -> symbol.father while(f -> symbol.father ^= null);
487                                    end;
488                               if f -> symbol.word_size ^= null
489                                    then go to fail;
490                               end;
491                          end;
492 
493                     else if p -> reference.qualifier ^= null
494                          then go to fail;
495                          else if s -> symbol.auto
496                               then if cg_stat$cur_level ^= s -> symbol.block_node -> block.level
497                                    then go to fail;
498                                    else;
499                               else if s -> symbol.constant
500                                    then do;
501                                         if s -> symbol.equivalence ^= null
502                                              then s = s -> symbol.equivalence;
503 
504                                         if ^ s -> symbol.allocated
505                                         then go to fail;
506                                         else if p -> reference.units ^= 0
507                                              then if p -> reference.units ^= word_
508                                                   then go to fail;
509                                                   else;
510                                              else;
511                                         end;
512 
513                                    else go to fail;
514                     end;
515 
516                return("1"b);
517 
518 fail:          return("0"b);
519 
520                end;
521 
522 
523 /*^L*/
524 check_block:   proc(pt) reducible returns(bit(1) aligned);
525 
526 dcl            (p,pt) ptr;
527 
528                /* make sure all contained blocks are quick */
529 
530                 do p = pt repeat p -> block.brother while(p ^= null);
531                     if ^ p -> block.no_stack
532                          then go to fail;
533                     if p -> block.son ^= null
534                     then if ^ check_block((p -> block.son))
535                          then go to fail;
536                     end;
537 
538                return("1"b);
539 
540 fail:          return("0"b);
541 
542                end;
543 /*^L*/
544 gen_itp_list:       proc;
545 
546 dcl            iscan fixed bin;
547 dcl            doing_descriptors bit(1) aligned;
548 
549 dcl            1 arg_list auto aligned,
550                2 header aligned,
551                  3 arg_count fixed bin(17) unal,
552                  3 code bit(18) unal,
553                  3 desc_count fixed bin(17) unal,
554                  3 pad bit(18) unal,
555                2 itp_list(128) like itp aligned;
556 
557                /* generates an argument list of constant addresses using
558                   ITP pairs and ordinary indirect words */
559 
560                doing_descriptors = "0"b;
561                arg_list.code, arg_list.pad = "0"b;
562                adjust = "0"b;
563                iscan = 0;
564                arg_list.arg_count = 2 * n_args;
565 
566                /* fill in addresses of arguments */
567 
568                call fill_list;
569 
570                /* process descriptors, if any */
571 
572                descs = sal_pt -> operand(3);
573                if descs ^= null
574                then do;
575                     arg_list.desc_count = 2 * n_args;
576                     doing_descriptors = "1"b;
577                     call fill_list;
578                     end;
579                else arg_list.desc_count = 0;
580 
581                /* generate the constant argument list */
582 
583                arglist = generate_constant$relocatable(addr(arg_list),2 * iscan + 2,"1"b);
584 
585 fill_list:          proc;
586 
587 dcl                 ind_word bit(36) aligned based;
588 dcl                 eis bit(2) aligned;
589 dcl                 p ptr;
590 
591                     /* fills in the arg_list */
592 
593                     do i = 1 to n_args;
594                          iscan = iscan + 1;
595 
596                          if ^ doing_descriptors
597                               then p = rand_pt(i);
598                               else p = prepare_operand((descs -> element(i)),1,atom);
599 
600                          if string(p -> reference.address_in.b)
601                               then call state_man$flush_address(p);
602 
603                          /* make the arg addressable */
604 
605                          if p -> reference.units = word_
606                               then eis = "00"b;
607                               else eis = "11"b;
608 
609                          call m_a(p,eis);
610 
611                          if p -> reference.ic_ref
612                          then do;
613                               p -> reference.ic_ref = "0"b;
614                               p -> address.tag = "000000"b;
615                               end;
616 
617                          /* depending on ext_base, make an ITP pair or an indirect word */
618 
619                          string(itp_list(iscan)) = (72)"0"b;
620 
621                          if p -> address.ext_base
622                          then do;
623                               itp_list(iscan).pr_no = p -> address.base;
624                               itp_list(iscan).itp_mod = "100001"b;    /* 41(8) - ITP */
625                               itp_list(iscan).offset = bit(fixed(p -> address.offset,18),18);
626                               if p -> reference.c_f_offset ^= 0
627                               then if p -> reference.units = bit_
628                                    then itp_list(iscan).bit_offset = bit(p -> reference.c_f_offset,6);
629                                    else if p -> reference.units = character_
630                                         then itp_list(iscan).bit_offset = bit(fixed(bits_per_char * p -> reference.c_f_offset,6),6);
631                                         else itp_list(iscan).bit_offset = bit(fixed(bits_per_char
632                                                   * divide(p -> reference.c_f_offset,packed_digits_per_char,6),6),6);
633                               end;
634 
635                          else addr(itp_list(iscan)) -> ind_word = string(p -> reference.address);
636 
637                          /* adjust the reference count for this use of the argument */
638 
639                          if ^ p -> reference.shared
640                          then if p -> reference.temp_ref & ^ doing_descriptors
641                               then substr(adjust,i,1) = "1"b;
642                               else call adjust_ref_count(p,-1);
643                          end;
644 
645                     end;
646 
647                end;
648 
649 
650              end; /* begin block */
651 
652 
653           end;