1 /* BEGIN fort_opt_utilities.incl.pl1 */
  2 
  3 /* Created:         December 18, 1979 by Richard A. Barnes for register optimizer. */
  4 
  5 get_opt_space:      proc(nwords) returns(ptr);
  6 
  7 dcl       nwords fixed bin(18);         /* size of allocation */
  8 
  9 dcl       p ptr;
 10 
 11           /* allocates all space for fort_optimizer */
 12 
 13 retry:
 14           p = addr(opt(next_free_opt));
 15 
 16           next_free_opt = next_free_opt + nwords;
 17 
 18           if next_free_opt < opt_max_len
 19           then return(p);
 20 
 21           else do;
 22                opt_base = get_next_temp_segment(shared_globals.opt_base,next_free_opt);
 23                go to retry;
 24                end;
 25 
 26           end /* get_opt_space */;
 27 ^L
 28 create_chain:  proc() returns(ptr);
 29 
 30 dcl       p ptr;
 31 
 32           /* allocates chain nodes */
 33 
 34           if free(size(chain)) = null
 35           then return(get_opt_space(size(chain)));
 36           else do;
 37                p = free(size(chain));
 38                free(size(chain)) = free(size(chain)) -> chain.next;
 39                return(p);
 40                end;
 41 
 42           end /* create_chain */;
 43 ^L
 44 get_quad_space:     proc(amt) returns(fixed bin(18));
 45 
 46 dcl       amt fixed bin(18);  /* amount to allocate */
 47 
 48 dcl       place fixed bin(18);
 49 
 50           place = next_free_quad;
 51           next_free_quad = next_free_quad + amt;
 52           if next_free_quad >= quad_max_len
 53           then do;
 54                call print_message(414,"The quadruple region",ltrim(char(quad_max_len)));
 55                return(0);
 56                end;
 57 
 58           return(place);
 59 
 60           end /* get_quad_space */;
 61 ^L
 62 chain_input:   proc(p,o,i);
 63 
 64                /* adds o to p's input list */
 65 
 66 dcl            p ptr,         /* ptr to temporary or array_ref that is input */
 67                o ptr,         /* ptr to operator that p is input to */
 68                i fixed bin(18);         /* which operand */
 69 
 70 dcl            qoff fixed bin(18);
 71 dcl            (q,last) ptr;
 72 
 73                q = create_input_to();
 74 
 75                q -> input_to.next = null;
 76                q -> input_to.operator = o;
 77                q -> input_to.which = i;
 78                qoff = fixed(rel(q),18);
 79                if p -> temporary.end_input_to = 0
 80                then p -> temporary.start_input_to = qoff;
 81                else do;
 82                     last = addr(polish(p -> temporary.end_input_to));
 83                     last -> input_to.next = q;
 84                     end;
 85                p -> temporary.end_input_to = qoff;
 86 
 87                end /* chain_input */;
 88 
 89 
 90 create_input_to:    proc() returns(ptr);
 91 
 92 dcl       q ptr;
 93 
 94           if freei = null
 95           then q = get_polish_space(size(input_to));
 96           else do;
 97                q = freei;
 98                freei = freei -> input_to.next;
 99                end;
100 
101           return(q);
102 
103           end /* create_input_to */;
104 
105 
106 get_polish_space:   proc(nwords) returns(ptr);
107 
108 dcl       nwords fixed bin(18);         /* size of allocation */
109 
110 dcl       p ptr;
111 
112           /* allocates polish space for input_to nodes */
113 
114           p = addr(polish(next_free_polish));
115 
116           next_free_polish = next_free_polish + nwords;
117 
118           if next_free_polish < polish_max_len
119           then return(p);
120 
121           else do;
122                call print_message(414,"The polish region",ltrim(char(polish_max_len)));
123                return(null);
124                end;
125 
126           end /* get_polish_space */;
127 ^L
128 /* derives insert_* fields in back target */
129 
130 derive_insert_for_bt:         proc(bt);
131 
132 dcl       bt ptr;   /* -> back target */
133 
134 dcl       (bt_statement, next_statement) fixed bin(18);
135 dcl       (o, btst) ptr;
136 
137           bt_statement = bt -> flow_unit.last_statement;
138           btst = addr(quad(bt_statement));
139           o = addr(quad(btst -> opt_statement.first_operator));
140 
141           if o -> operator.op_code = jump_op
142           then do;
143                bt -> flow_unit.insert_statement = fixed(btst -> opt_statement.back, 18);
144                bt -> flow_unit.insert_operator = btst -> opt_statement.prev_operator;
145                end;
146           else do;
147                bt -> flow_unit.insert_statement = bt_statement;
148                next_statement = fixed(btst -> opt_statement.next, 18);
149                bt -> flow_unit.insert_operator = addr(quad(next_statement)) -> opt_statement.prev_operator;
150                end;
151 
152           end /* derive_insert_for_bt */;
153 ^L
154 /* unthreads operator nodes.  The operator to be unthreaded must not be the first or last operator in a chain. */
155 
156 unthread: proc(o);
157 
158 dcl       (o,nextp,backp) ptr;
159 
160 dcl       nullx fixed bin(18) int static options(constant) init(262142);
161 
162           if o -> operator.next = nullx /* if already unthreaded, don't bother. */
163                then return;
164 
165           nextp = addr(quad(o -> operator.next));
166           backp = addr(quad(o -> operator.back));
167           nextp -> operator.back = o -> operator.back;
168           backp -> operator.next = o -> operator.next;
169 
170           /* Make sure nobody uses the threading words again.  An invalid use will cause a fault. */
171 
172           o -> operator.next,
173           o -> operator.back = nullx;
174 
175           end /* unthread */ ;
176 ^L
177 put_in_loop_end:    proc(pt,lp);
178 
179 dcl       (p, pt) ptr,        /* -> temp to be put in loop end chain */
180           lp ptr;             /* -> loop in whose chain temp is to be inserted */
181 
182 dcl       fu_to_put ptr;      /* -> flow_unit in whose chain temp is to be inserted */
183 
184 dcl       c ptr;
185 
186           p = pt;
187           fu_to_put = lp -> loop.last_unit;
188 
189           /* add to loop end chain */
190 
191           c = create_chain();
192           c -> lchain.next = fu_to_put -> flow_unit.loop_end_chain;
193           c -> lchain.value = fixed(rel(p),18);
194           fu_to_put -> flow_unit.loop_end_chain = c;
195           fu_to_put -> flow_unit.n_in_loop_end = fu_to_put -> flow_unit.n_in_loop_end + 1;
196 
197           /* increment the reference count */
198 
199           p -> temporary.ref_count = p -> temporary.ref_count + 1;
200 
201           /* add an input item for this operand */
202 
203           call chain_input(p,c,-1);
204 
205           p -> temporary.loop_end_fu_pos = fu_to_put -> flow_unit.position;
206 
207           end /* put_in_loop_end */;
208 ^L
209 connect_expression: proc(opnd,op,p_which);
210 
211 dcl       opnd fixed bin(18), /* operand to be connectged to op */
212           op fixed bin(18),   /* operator to which opnd becomes an operand */
213           (p_which,which) fixed bin(18);          /* operand number that opnd becomes */
214 
215 
216 dcl       (o, p) ptr;
217 
218           which = p_which;
219 
220           o = addr(quad(op));
221           o -> operator.operand(which) = opnd;
222           p = addr(rands(opnd));
223 
224           if p -> node.node_type = array_ref_node
225            | p -> node.node_type = temporary_node
226           then do;
227                p -> temporary.ref_count = p -> temporary.ref_count + 1;
228                p -> temporary.ref_count_copy = p -> temporary.ref_count_copy + 1;
229                call chain_input(p,o,which);
230                end;
231 
232           end /* connect_expression */;
233 
234 
235 ^L
236 disconnect_temporary:         proc(pt,p_o);
237 
238 dcl       (p,pt) ptr,         /* ptr to temp being disconnected */
239           (o,p_o) ptr;        /* ptr to operator from which p is disconnected */
240 
241 dcl       (inp,last) ptr;
242 dcl       found bit(1) aligned;
243 
244           p = pt;
245           o = p_o;
246 
247           last = null;
248           found = "0"b;
249           inp = addr(polish(p -> temporary.start_input_to));
250 
251           do while(^ found & inp ^= null);
252                if inp -> input_to.operator = o
253                then found = "1"b;
254                else do;
255                     last = inp;
256                     inp = inp -> input_to.next;
257                     end;
258                end;
259 
260           if ^ found
261           then do;
262                call print_message(386);
263                return;
264                end;
265 
266           if last ^= null
267           then do;
268                last -> input_to.next = inp -> input_to.next;
269                if inp -> input_to.next = null
270                     then p -> temporary.end_input_to = fixed(rel(last),18);
271                end;
272 
273           else if inp -> input_to.next = null
274                then p -> temporary.start_input_to, p -> temporary.end_input_to = 0;
275                else p -> temporary.start_input_to = fixed(rel(inp -> input_to.next),18);
276 
277           p -> temporary.ref_count = p -> temporary.ref_count - 1;
278           p -> temporary.ref_count_copy = p -> temporary.ref_count_copy - 1;
279 
280           end /* disconnect_temporary */;
281 ^L
282 in_namelist:        proc(o,variable) returns(bit(1) aligned);
283 
284 dcl       o ptr,              /* -> to {read|write}_namelist operator */
285           variable fixed bin(18);       /* variable being searched for */
286 
287 dcl       (var,i,ipol) fixed bin(18);
288 
289           var = variable;
290           ipol = addr(rands(o -> operator.operand(1))) -> symbol.initial;
291 
292           do i = 1 to polish(ipol);
293                if polish(ipol+i) = variable
294                     then return("1"b);
295                end;
296 
297           return("0"b);
298 
299           end /* in_namelist */;
300 
301 /* END fort_opt_utilities.incl.pl1 */