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
29
30
31
32
33
34
35
36 pointer_builtins:
37 proc (pt, store_it);
38
39 dcl pt ptr,
40 store_it bit (1) aligned;
41
42 dcl (
43 p,
44 q,
45 p2,
46 s3,
47 ref (3),
48 b2
49 ) ptr,
50 (i, ibase, macro, mac_1, n, old_changed)
51 fixed bin (15),
52 last_freed fixed bin (18),
53 base bit (3) aligned,
54 op_code bit (9) aligned,
55 (
56 atom (3),
57 adjust,
58 in_base
59 ) bit (1) aligned;
60
61 dcl (
62 cg_stat$temp_ref,
63 cg_stat$text_base
64 ) ptr ext,
65 cg_stat$text_pos fixed bin ext,
66 cg_stat$null_value bit (72) aligned ext,
67 cg_stat$cur_level fixed bin ext;
68
69 dcl adjust_ref_count entry (pointer, fixed bin);
70 dcl base_man$load_any_var
71 entry (fixed bin, ptr) returns (bit (3) aligned);
72 dcl prepare_operand entry (ptr, fixed bin (15), bit (1) aligned) returns (ptr),
73 compile_exp$save entry (ptr) returns (ptr),
74 compile_exp entry (ptr),
75 c_a entry (fixed bin (15), fixed bin) returns (ptr),
76 load entry (ptr, fixed bin),
77 (
78 base_man$load_var,
79 base_man$update_base
80 ) entry (fixed bin, ptr, fixed bin (15));
81 dcl base_man$load_arg_ptr
82 entry (fixed bin (15), ptr, fixed bin) returns (bit (3) aligned);
83 dcl base_man$load_display
84 entry (fixed bin, bit (3) aligned),
85 generate_constant$bit_string
86 entry (bit (*) aligned, fixed bin) returns (ptr);
87 dcl base_to_core entry (fixed bin (15), ptr),
88 state_man$flush_address
89 entry (ptr),
90 state_man$flush_ref entry (ptr),
91 store_bit_address entry (ptr, ptr, fixed bin (18)),
92 store entry (ptr),
93 expmac$zero entry (fixed bin (15));
94 dcl type2 fixed bin (17),
95 m_a entry (ptr, bit (2) aligned),
96 cg_error entry (fixed bin, fixed bin (9));
97 declare cg_stat$cur_statement
98 pointer external;
99
100 dcl (
101 SETCHARNO init (1),
102 ADDCHARNO init (2),
103 SETBITNO init (3),
104 ADDBITNO init (4)
105 ) fixed bin int static options (constant);
106
107 dcl (abs, addrel, bit, fixed, index, null, string)
108 builtin;
109
110 dcl fix_bin fixed bin based;
111
112 dcl ldfx2 init (8) fixed bin (15) static;
113
114 dcl 1 half aligned based,
115 2 left bit (18) unal,
116 2 right bit (18) unal;
117
118 dcl 1 instruction aligned based,
119 2 base bit (3) unal,
120 2 offset bit (15) unal,
121 2 op_code bit (10) unal,
122 2 skip bit (2) unal,
123 2 tag bit (6) unal;
124
125 dcl (
126 pointer_mac_const (6) init (326, 0, 652, 653, 654, 655),
127 addrel_mac_const (6) init (327, 0, 656, 657, 658, 659),
128 zero_bo (6) init (642, 0, 684, 685, 686, 687),
129 longbs_to_bs18 init (131),
130 pl1_pointer_easy init (602),
131 pl1_pointer_hard init (604),
132 pointer_mac_fx (6) init (213, 0, 661, 663, 665, 667),
133
134 addrel_mac_fx (6) init (215, 0, 669, 671, 673, 675),
135
136 baseptr_mac_fx (6) init (217, 0, 677, 679, 681, 683)
137 ) fixed bin (15) int static;
138
139 dcl epbx (0:7)
140 init ("0111010001"b, "0111010101"b, "0111110001"b, "0111010010"b, "0111010110"b,
141 "0111110010"b, "0111110110"b, "0111110101"b) bit (10) aligned int static;
142
143 %include cgsystem;
144 %include operator;
145 %include reference;
146 %include symbol;
147 %include block;
148 %include op_codes;
149 %include data_types;
150 %include nodes;
151 %include machine_state;
152 %include bases;
153 %include temporary;
154
155 p = pt;
156 p2 = p -> operand (2);
157
158
159 op_code = p -> operator.op_code;
160
161 if op_code = param_ptr
162 then do;
163 i = 0;
164
165 goto l4;
166 end;
167
168 if op_code = param_desc_ptr
169 then do;
170 i = 1;
171
172 l4:
173 ref (1) = prepare_operand ((p -> operand (1)), 1, atom (1));
174
175 base =
176 base_man$load_arg_ptr (i, (p -> operand (3)),
177 p2 -> reference.symbol -> symbol.initial -> fix_bin);
178
179 ibase = which_base (fixed (base, 3));
180 goto to_core;
181 end;
182
183 if op_code >= ptr_fun
184 then n = 1;
185 else n = -1;
186
187 do i = 1 to p -> operator.number;
188 ref (i) = prepare_operand ((p -> operand (i)), n, atom (i));
189 end;
190
191 if op_code = setcharno_fun
192 then call NO_FUNS (SETCHARNO);
193 else if op_code = addcharno_fun
194 then call NO_FUNS (ADDCHARNO);
195 else if op_code = setbitno_fun
196 then call NO_FUNS (SETBITNO);
197 else if op_code = addbitno_fun
198 then call NO_FUNS (ADDBITNO);
199
200 if op_code = addr_fun
201 then do;
202
203 if ^atom (2)
204 then if p2 -> node.type = operator_node
205 then ref (2) = compile_exp$save (p2);
206
207
208 adjust, in_base = "0"b;
209
210 if ref (2) -> reference.varying_ref
211 then do;
212 adjust = "1"b;
213 call adjust_c_offset (-1);
214 end;
215
216 ibase = which_base (bin (base_man$load_any_var (2, ref (2)), 3));
217
218 if adjust
219 then call reset_c_offset (-1);
220
221 ref (2) -> reference.address_in.b (ibase) = "0"b;
222
223 base_regs (ibase).variable = null;
224 base_regs (ibase).type = 0;
225 to_core:
226 if ref (1) -> reference.allocate
227 then if store_it
228 then call base_to_core (ibase, ref (1));
229 else ;
230 else call state_man$flush_ref (ref (1));
231
232 if ibase ^= 7
233 then call base_man$update_base (1, ref (1), ibase);
234 else call state_man$flush_ref (ref (1));
235
236 ref (1) -> reference.evaluated = "1"b;
237 done:
238 cg_stat$temp_ref = ref (1);
239 return;
240 end;
241
242 if op_code = addr_fun_bits
243 then do;
244
245 if ^atom (2)
246 then if p2 -> node.type = operator_node
247 then ref (2) = compile_exp$save (p2);
248
249
250 ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + 1;
251 last_freed = 0;
252 if ref (1) -> reference.temp_ref
253 then if ref (1) -> reference.qualifier ^= null
254 then last_freed = ref (1) -> reference.qualifier -> temporary.last_freed;
255
256 if store_it
257 then call store_bit_address (ref (1), ref (2), last_freed);
258 else begin;
259 declare base_bits bit (3) aligned;
260 base_bits = base_man$load_any_var (2 , ref (2));
261 call base_man$update_base (1, ref (1), (which_base (fixed (base_bits, 3))));
262 end;
263 goto done;
264 end;
265
266 if op_code = ptr_fun
267 then do;
268
269 if ref (2) -> reference.symbol -> symbol.ptr
270 then do;
271
272
273
274
275
276
277 if ^atom (2)
278 then if p2 -> node.type = operator_node
279 then do;
280 call adjust_ref_count ((p2 -> operator.operand (1)), +1);
281 call compile_exp (p2);
282 ref (2) = p2 -> operator.operand (1);
283 end;
284
285 if ref (3) -> reference.offset ^= null
286 then goto l1;
287 if ref (3) -> reference.c_offset ^= 0
288 then goto l1;
289
290 s3 = ref (3) -> reference.symbol;
291 if s3 -> symbol.constant
292 then
293 Multics_POINTER_CONSTANT:
294 do;
295 ibase = get_base ();
296 mac_1 = pointer_mac_const (ibase);
297 goto c0;
298 end;
299
300 goto l1;
301 end;
302
303
304
305
306 if ^atom (2)
307 then ref (2) = compile_exp$save (p2);
308
309 call load (ref (2), 0);
310
311 q = ref (3) -> reference.symbol;
312 if q -> symbol.internal & (q -> symbol.auto | q -> symbol.static)
313 then macro = pl1_pointer_easy;
314 else macro = pl1_pointer_hard;
315
316 call base_man$load_var (2, ref (3), 1);
317
318 call expmac$zero (macro + ref (1) -> reference.data_type - unpacked_ptr);
319
320 ref (2) -> reference.address_in.b (1) = "0"b;
321 base_regs (1).variable = null;
322 base_regs (1).type = 0;
323
324
325
326 q_reg.variable (1) = ref (1);
327 q_reg.number = 1;
328 ref (1) -> reference.value_in.q = "1"b;
329
330 if ref (1) -> reference.allocate & store_it
331 then call store (ref (1));
332
333 else do;
334 if ^ref (1) -> reference.allocate
335 then call state_man$flush_ref (ref (1));
336
337 q_reg.variable (1) = ref (1);
338 q_reg.number = 1;
339 ref (1) -> reference.value_in.q = "1"b;
340 end;
341
342 call base_man$update_base (1, ref (1), 1);
343
344 goto done;
345 end;
346
347 if op_code = addrel_fun
348 then do;
349
350 if ^atom (2)
351 then if p2 -> node.type = operator_node
352 then do;
353 call adjust_ref_count ((p2 -> operator.operand (1)), 1);
354
355 call compile_exp (p2);
356 ref (2) = p2 -> operator.operand (1);
357 end;
358
359 if ref (3) -> reference.offset ^= null
360 then goto l1;
361 if ref (3) -> reference.c_offset ^= 0
362 then goto l1;
363
364 s3 = ref (3) -> reference.symbol;
365 if ^s3 -> symbol.constant
366 then goto l1;
367
368 ibase = get_base ();
369 mac_1 = addrel_mac_const (ibase);
370
371 c0:
372 q = s3 -> symbol.initial;
373
374 if ref (3) -> reference.data_type = bit_string
375 then do;
376 if ref (3) -> reference.long_ref
377 then goto l1;
378 if ref (3) -> reference.c_length > 18
379 then goto l1;
380 end;
381 else if abs (q -> fix_bin) >= 131072
382 then goto l1;
383
384 old_changed = base_regs (ibase).changed;
385
386 call base_man$load_var (1, ref (2), ibase);
387 ref (2) -> reference.value_in.b (ibase) = "0"b;
388 base_regs (ibase).variable = null;
389 base_regs (ibase).type = 0;
390 n = base_regs (ibase).changed;
391
392 if op_code = ptr_fun
393 then if q -> fix_bin = 0 & n ^= old_changed
394 then do;
395 q = addrel (cg_stat$text_base, n);
396 q -> instruction.op_code = epbx (ibase);
397 base_regs (ibase).instruction = string (q -> instruction);
398 goto to_core;
399 end;
400
401
402 call expmac$zero (mac_1);
403
404 p = addrel (cg_stat$text_base, cg_stat$text_pos - 1);
405
406 if ref (3) -> reference.data_type = bit_string
407 then p -> left = q -> left;
408 else do;
409 if q -> fix_bin >= 0
410 then p -> left = bit (fixed (q -> fix_bin, 18), 18);
411 else p -> left = bit (fixed (262144 + q -> fix_bin, 18), 18);
412 end;
413
414 goto to_core;
415
416 l1:
417 if atom (3)
418 then call load (ref (3), 0);
419 else call compile_exp ((p -> operand (3)));
420
421 if ref (3) -> reference.long_ref
422 then call expmac$zero ((longbs_to_bs18));
423
424 ibase = get_base ();
425 if op_code = ptr_fun
426 then macro = pointer_mac_fx (ibase);
427 else macro = addrel_mac_fx (ibase);
428
429 old_changed = base_regs (ibase).changed;
430
431 call base_man$load_var (1, ref (2), ibase);
432 ref (2) -> reference.value_in.b (ibase) = "0"b;
433 base_regs (ibase).variable = null;
434 base_regs (ibase).type = 0;
435
436 if op_code ^= addrel_fun
437 then do;
438 l2a:
439 call expmac$zero (macro - fixed (ref (3) -> reference.data_type = bit_string, 1));
440 goto to_core;
441 end;
442
443 n = base_regs (ibase).changed;
444 if n = old_changed
445 then go to l2a;
446 q = addrel (cg_stat$text_base, n);
447
448 if q -> instruction.tag = "000000"b
449 then do;
450 if ref (3) -> reference.data_type = bit_string
451 then do;
452 if a_reg.changed > n
453 then go to l2a;
454 q -> instruction.tag = "000001"b;
455
456 end;
457 else do;
458 if q_reg.changed > n
459 then go to l2a;
460 q -> instruction.tag = "000110"b;
461
462 end;
463 go to set_inst;
464 end;
465
466 if q -> instruction.tag ^= "010000"b
467 then goto l2a;
468
469 if ref (3) -> reference.data_type = bit_string
470 then do;
471 if a_reg.changed > n
472 then goto l2a;
473 q -> instruction.tag = "110001"b;
474
475 end;
476 else do;
477 if q_reg.changed > n
478 then goto l2a;
479 q -> instruction.tag = "110110"b;
480
481 end;
482 set_inst:
483 base_regs (ibase).instruction = string (q -> instruction);
484 call expmac$zero ((zero_bo (ibase)));
485 goto to_core;
486 end;
487
488 if op_code = baseptr_fun
489 then do;
490
491 if atom (2)
492 then call load (ref (2), 0);
493 else call compile_exp ((p -> operand (2)));
494 if p -> operator.operand (2) -> node.type = operator_node
495 then ref (2) = p -> operator.operand (2) -> operator.operand (1);
496
497 ibase = get_base ();
498 macro = baseptr_mac_fx (ibase);
499 ref (3) = ref (2);
500
501 goto l2a;
502 end;
503
504 if op_code = stackframeptr_fun
505 then do;
506 if ref (1) -> reference.allocate & store_it
507 then do;
508 ibase = which_base (6);
509 goto to_core;
510 end;
511
512 ref (2) = c_a (0, 4);
513
514 ibase = get_base ();
515
516 call base_man$load_var (2, ref (2), ibase);
517
518 ref (2) -> reference.address_in.b (ibase) = "0"b;
519 base_regs (ibase).variable = null;
520 base_regs (ibase).type = 0;
521 goto to_core;
522 end;
523
524 if op_code = stackbaseptr_fun
525 then do;
526 ref (2) = c_a (0, 4);
527
528 ibase = get_base ();
529
530 old_changed = base_regs (ibase).changed;
531
532 call base_man$load_var (2, ref (2), ibase);
533 ref (2) -> reference.address_in.b (ibase) = "0"b;
534 base_regs (ibase).variable = null;
535 base_regs (ibase).type = 0;
536 n = base_regs (ibase).changed;
537
538 if n ^= old_changed
539 then do;
540 q = addrel (cg_stat$text_base, n);
541 q -> instruction.op_code = epbx (ibase);
542 base_regs (ibase).instruction = string (q -> instruction);
543 goto to_core;
544 end;
545
546 call expmac$zero ((pointer_mac_const (ibase)));
547 goto to_core;
548 end;
549
550 if op_code = codeptr_fun
551 then do;
552
553 if ^atom (2)
554 then ref (2) = compile_exp$save (p2);
555 ibase = get_base ();
556 type2 = ref (2) -> reference.data_type;
557
558 if type2 = label_constant | (ext_entry_in <= type2 & type2 <= int_entry_other)
559 then do;
560 call base_man$load_var (2, ref (2), ibase);
561 ref (2) -> reference.address_in.b (ibase) = "0"b;
562 end;
563 else do;
564 call base_man$load_var (1, ref (2), ibase);
565 ref (2) -> reference.value_in.b (ibase) = "0"b;
566 end;
567
568 base_regs (ibase).variable = null;
569 base_regs (ibase).type = 0;
570 goto to_core;
571
572 end;
573
574 if op_code = environmentptr_fun
575 then do;
576 if ^atom (2)
577 then ref (2) = compile_exp$save (p2);
578 type2 = ref (2) -> reference.data_type;
579
580 if type2 = ext_entry_in | type2 = ext_entry_out
581 then do;
582 ref (2) = generate_constant$bit_string (cg_stat$null_value, (bits_per_two_words));
583 ref (2) -> reference.data_type = unpacked_ptr;
584 ibase = get_base ();
585 call base_man$load_var (1, ref (2), ibase);
586 ref (2) -> reference.value_in.b (ibase) = "0"b;
587 base_regs (ibase).variable = null;
588 base_regs (ibase).type = 0;
589 end;
590
591 else if type2 = label_constant | type2 = int_entry | type2 = int_entry_other
592 then do;
593 b2 = ref (2) -> reference.symbol -> symbol.block_node;
594 if cg_stat$cur_level = b2 -> block.level
595 then do;
596 if ref (1) -> reference.allocate & store_it
597 then do;
598 ibase = which_base (6);
599 goto to_core;
600 end;
601
602 ref (2) = c_a (0, 4);
603 ibase = get_base ();
604 call base_man$load_var (2, ref (2), ibase);
605 ref (2) -> reference.address_in.b (ibase) = "0"b;
606 end;
607 else do;
608 call base_man$load_display (cg_stat$cur_level - b2 -> block.level, base);
609 ibase = which_base (fixed (base, 3));
610 end;
611 end;
612
613 else do;
614 ibase = get_base ();
615 call adjust_c_offset (2);
616 call base_man$load_var (1, ref (2), ibase);
617 call reset_c_offset (2);
618 base_regs (ibase).variable = null;
619 base_regs (ibase).type = 0;
620
621 end;
622
623 goto to_core;
624
625 end;
626
627 err:
628 call cg_error (301, fixed (op_code, 9));
629
630
631 get_base:
632 proc returns (fixed bin (15));
633
634 dcl i fixed bin (15);
635 dcl (
636 first_base init (3),
637 last_base init (6)
638 ) fixed bin (15) int static;
639
640
641
642
643
644
645 if string (ref (2) -> reference.value_in.b)
646 then if ref (2) -> reference.ref_count = 1 | ref (1) = ref (2)
647 then return (index (string (ref (2) -> reference.value_in.b), "1"b) - 1);
648 else ;
649 else if ref (2) -> reference.data_type >= unpacked_ptr
650 then do;
651
652
653
654 call m_a (ref (2), "00"b);
655 ref (2) -> reference.perm_address = "1"b;
656
657 end;
658
659 do i = 1, first_base to last_base;
660 if base_regs (i).type = 0
661 then return (i);
662 else if base_regs (i).type <= 2
663 then if base_regs (i).variable -> reference.hit_zero | ^base_regs (i).variable -> reference.allocate
664 then return (i);
665 end;
666
667 return (1);
668 end;
669
670 adjust_c_offset:
671 proc (adjust_offset);
672
673 dcl adjust_offset fixed bin;
674
675 ref (2) -> reference.c_offset = ref (2) -> reference.c_offset + adjust_offset;
676
677 if string (ref (2) -> reference.address_in.b)
678 then do;
679 if ref (2) -> reference.address.offset ^= (15)"0"b
680 then call m_a (ref (2), "00"b);
681 call state_man$flush_address (ref (2));
682 in_base = "1"b;
683 if adjust_offset >= 0
684 then ref (2) -> address.offset = bit (fixed (adjust_offset, 15), 15);
685 else ref (2) -> address.offset = bit (fixed (adjust_offset + 32768, 15), 15);
686 ref (2) -> reference.perm_address = "1"b;
687 ref (2) -> reference.no_address = "0"b;
688 end;
689 else in_base = "0"b;
690
691 end;
692
693 reset_c_offset:
694 proc (adjust_offset);
695
696 dcl adjust_offset fixed bin;
697
698 ref (2) -> reference.c_offset = ref (2) -> reference.c_offset - adjust_offset;
699
700 if in_base
701 then do;
702 ref (2) -> address.offset = (15)"0"b;
703 ref (2) -> reference.perm_address = "0"b;
704 end;
705
706 end;
707
708
709
710
711
712
713
714 NO_FUNS:
715 procedure (Funx);
716 declare Funx fixed bin;
717 declare base_man$load_var_and_lock
718 entry (fixed bin, ptr, fixed bin (15));
719 declare base_man$unlock entry (fixed bin (15));
720
721 declare q pointer;
722
723 declare expmac entry (fixed bin (15), pointer);
724 declare base_bits bit (3) aligned;
725 declare s3_constant bit (1) aligned;
726 declare constant_zero bit (1) aligned;
727 declare constant_value fixed bin (24);
728 declare based_fb_24 fixed bin (24) based;
729
730 declare MACRO (4) fixed bin (15) init (373, 373, 374, 374) int static options (constant);
731 declare binary builtin;
732
733
734 s3_constant = "0"b;
735
736 s3 = ref (3) -> reference.symbol;
737 if s3 -> symbol.constant
738 then do;
739 s3_constant = "1"b;
740 constant_value = s3 -> symbol.initial -> based_fb_24;
741 end;
742
743 constant_zero = s3_constant & constant_value = 0;
744
745 if constant_zero
746 then if Funx = ADDCHARNO | Funx = ADDBITNO
747 then do;
748 ibase = get_base ();
749 call base_man$load_var (1, ref (2), ibase);
750
751 go to to_core;
752 end;
753
754 if ^atom (2)
755 then call compile_exp (p2);
756
757 if s3_constant
758 then do;
759 if constant_zero
760 then call CONVERT_TO_POINTER_CONSTANT (0);
761 if Funx = SETCHARNO & mod (constant_value, 4) = 0
762 then call CONVERT_TO_POINTER_CONSTANT (divide (constant_value, 4, 24, 0));
763 else if Funx = SETBITNO & mod (constant_value, 36) = 0
764 then call CONVERT_TO_POINTER_CONSTANT (divide (constant_value, 36, 24, 0));
765 end;
766
767 q = c_a (0, 1);
768
769 ibase = get_base ();
770 base_bits = bases (ibase);
771 call base_man$load_var_and_lock (1, ref (2), ibase);
772
773
774
775
776
777 if ^atom (3)
778 then call compile_exp ((p -> operator.operand (3)));
779 else call load (ref (3), 0);
780
781 q -> reference.address.base = base_bits;
782 q -> reference.address.tag = "06"b3;
783 q -> reference.relocation = ""b;
784
785 if Funx = ADDCHARNO | Funx = ADDBITNO
786 then q -> reference.address.ext_base = "1"b;
787 call expmac (MACRO (Funx), q);
788 call base_man$unlock (ibase);
789 machine_state.base_regs (ibase).variable = null ();
790 machine_state.base_regs (ibase).type = 0;
791 ref (2) -> reference.value_in.b (ibase) = "0"b;
792 go to to_core;
793
794 CONVERT_TO_POINTER_CONSTANT:
795 procedure (Word_offset);
796 declare Word_offset fixed bin (24);
797 declare declare_constant ext entry (bit (*) aligned, bit (36) aligned, fixed bin (31), fixed bin (31))
798 returns (pointer);
799 declare size fixed bin (31);
800 declare value bit (36) aligned;
801 declare substr builtin;
802
803 %include mask;
804
805
806
807
808
809
810 op_code = ptr_fun;
811
812 size = 18;
813 value = unspec (Word_offset);
814
815 ref (3) = declare_constant (value, fixed_binary_real_mask | unsigned_mask, size, 0);
816 s3 = ref (3) -> reference.symbol;
817 go to Multics_POINTER_CONSTANT;
818 end CONVERT_TO_POINTER_CONSTANT;
819
820
821 end NO_FUNS;
822
823 end pointer_builtins;