1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28 call_op: proc(pt) returns(ptr);
29
30 dcl pt ptr;
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
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
118
119 sal_pt = node_pt -> operand(3);
120
121
122
123
124
125
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
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
149
150 arglist = cg_stat$double_temp;
151 descs = null;
152 n_args = 0;
153 goto l3;
154 end;
155
156
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
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
191
192
193
194
195
196
197
198
199
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
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
229
230
231
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
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
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
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
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);
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
332
333
334
335
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
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
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
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
385
386 l3: arg(1) = arglist;
387 if n_args > 127
388 then arg(2) = c_a((n_args*2),3);
389 else arg(2) = c_a((n_args*2048),2);
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
453 check_arg_addrs: proc reducible returns(bit(1) aligned);
454
455 dcl (f,p,s) ptr;
456
457
458
459
460 if cg_stat$cur_block -> block.last_auto_loc >= 16384
461 then go to fail;
462
463
464
465 if ent_blk -> block.son ^= null
466 then if ^ check_block((ent_blk -> block.son))
467 then go to fail;
468
469
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
524 check_block: proc(pt) reducible returns(bit(1) aligned);
525
526 dcl (p,pt) ptr;
527
528
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
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
558
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
567
568 call fill_list;
569
570
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
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
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
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
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;
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
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;
651
652
653 end;