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 /* this procedure compiles string expressions
 12 
 13    Initial Version:  5 October, 1968 by BLW
 14           Modified:  4 September 1971 by BLW for Version II
 15           Modified: 25 November 1972 by BLW
 16           Modified: 4 June 1973 by RAB for EIS
 17           Modified: 2 November 1975 by RAB to check for p3 in a
 18           Modified: 1 April 1979 by RAB to improve code generated when
 19                     expression lengths are the same, and to add commentary
 20                     on compiling string expressions.
 21           Modified: 20 August 1979 by RAB to improve code generated
 22                     for a & ^ b, where a and b are long strings.
 23           Modified: 21 August 1979 by RAB to use check_lengths for andnot and
 24                     to fix a bug in check_lengths.
 25           Modified: 30 March 1980 by RAB for reference.aligned_for_store_ref.
 26                     See prepare_operand for details.        */
 27 
 28 string_op: proc(node_pt,refs,p_code);
 29 
 30 dcl       node_pt   ptr,                /* points at operator node */
 31           refs(3)   ptr,                /* ptrs to reference nodes for operands */
 32           p_code    fixed bin(15);      /* encodes local context of operator */
 33 
 34 dcl       (cg_stat$double_temp,cg_stat$long_string_temp) ptr ext static,
 35           cg_stat$for_test_called bit(1) ext static;
 36 
 37 dcl       (p,p1,p2,p3,q2,q3,ref(3) defined(refs)) ptr,
 38           for_test bit(1) aligned,
 39           doing_andnot bit(1) aligned,
 40           code fixed bin(2),
 41           atom(2:3) bit(1) aligned,
 42           (s2,s3,op,k,l_op,load_double,op_code,n,which_andnot) fixed bin(15);
 43 
 44 dcl       load entry(ptr,fixed bin(15)),
 45           c_a entry(fixed bin(31),fixed bin) returns(ptr),
 46           aq_man$clear_q entry,
 47           string_temp entry(ptr,ptr,ptr) returns(ptr),
 48           expmac$eis entry(fixed bin(15),ptr),
 49           expmac$zero entry(fixed bin(15)),
 50           expmac entry(fixed bin(15),ptr),
 51           expmac$one entry(fixed bin(15),ptr,fixed bin(15)),
 52           prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
 53           adjust_ref_count entry(ptr,fixed bin),
 54           compile_exp entry(ptr),
 55           (compile_exp$save,compile_exp$save_exp) entry(ptr) returns(ptr);
 56 
 57 dcl       (bit,fixed,min,null,string,substr) builtin;
 58 
 59 dcl (     and                 init(1),
 60           not                 init(4)) fixed bin int static;
 61 
 62 dcl (     era                 init(52),
 63           move_not_bits       init(335),
 64           comp_bits           init(148),
 65           move_xor            init(341),
 66           ora                 init(46),
 67           move_or             init(304),
 68           ana                 init(40),
 69           and_for_test        init(615),
 70           move_and            init(264),
 71           move_andnot(0:1)    init(391,392),
 72           test_not            init(338),
 73           test_xor            init(344),
 74           test_or             init(331),
 75           test_and            init(267),
 76           test_andnot(0:1)    init(261,262),
 77           staq                init(6)) fixed bin(15) int static;
 78 
 79 %include cgsystem;
 80 %include reference;
 81 %include operator;
 82 %include machine_state;
 83 %include op_codes;
 84 %include nodes;
 85 ^L
 86           /*  ON COMPILATION OF STRING EXPRESSIONS
 87 
 88              Short string expressions (those of constant length <= 2 words) are
 89              evaluated in the A or the AQ and present no problems of special
 90              interest.
 91 
 92              Long string expressions must be evaluated in string temporaries
 93              which are allocated by string_temp.  There are 2 types of string
 94              temps -- (1) those that are allocated in the stack at compile-
 95              time like short temps, (2) those that are allocated by stack
 96              extension at runtime.  string_temp decides which type of string
 97              temporary to use.  The first type of temp is used if the reference
 98              count of operand(1) is greater than 1 and it has a constant length.
 99              Otherwise, a stack extension is used.  A  temp acquired by stack
100              extension is recognized by having reference.value_in.string_aq ON
101              (in which case, it is considered to be in the string aq) or by having
102              reference.address_in.storage ON.
103 
104              string_temp may try to save on execution time by reusing or extending
105              previously allocated stack extension temporaries.  If operand(1)
106              requires a stack extension, operand(2) is in the string aq, and the
107              relation between the lengths of operand(2) and operand(3) is known
108              at compile-time (or one of the operands is short), then string_temp
109              will reuse operand(2)'s temp if the length of operand(1) and operand(2)
110              is the same, or extend operand(2)'s temp otherwise.  IF the previously
111              mentioned conditions are not satisfied, new temporary space must be
112              allocated.
113 
114              When compile_exp is called for a long string expression, the location
115              of the string temp is not saved in storage.  When compile_exp$save or
116              compile_exp$save_exp is called for a long string expression and the
117              temp has been acquired by stack extension, the address of the temp is
118              saved in storage after expression evaluation.  This allows one to find
119              the temp if new stack extensions are made.  After calling compile_exp,
120              compile_exp$save, or compile_exp$save_exp on a long string expression,
121              the result reference count is left unchanged.
122 
123              When string_op is processing a long string_expression,
124              it may call compile_exp for at most one long string expression, since
125              evaluating the other may cause other stack extensions.  compile_exp
126              must not be called  if other activity may affect the string aq or PR2.
127              In this latter case, compile_exp$save[_exp] must be called.  compile_exp
128              is also not called unless there is a chance that string_temp will be able
129              to reuse or extend an existing temp.
130 */
131 ^L
132 
133 begin:    p = node_pt;
134           q2 = p -> operand(2);
135           code = p_code;
136 
137           op_code = fixed(substr(p -> operator.op_code,6,4),4);
138 
139           p1 = ref(1);
140           p2 = ref(2);
141 
142           if op_code ^= not
143           then do;
144                q3 = p -> operand(3);
145                p3 = ref(3);
146                end;
147 
148           for_test = cg_stat$for_test_called;
149           doing_andnot = "0"b;
150 
151           /* encode left size and dispatch on operator */
152 
153           if p2 -> reference.long_ref | p2 -> reference.varying_ref then s2 = 3;
154           else s2 = 2*fixed(p2 -> reference.c_length > bits_per_word,1);
155 
156           goto switch(op_code);
157 
158           /* have not operation */
159 
160 switch(4):
161 not_op:   if code ^= 0
162           then
163 
164                /* atm, generate move-not_bits for long atm or
165                   load short or double operand */
166 
167                if s2 <= 2
168                then do;
169                     call load(p2,s2);
170 complement:         call expmac$one((era),c_a((p2 -> reference.c_length),5),s2);
171                     end;
172                else do;
173 comp_long:          p1 = string_temp(p,p2,null);
174                     if for_test then l_op = test_not; else l_op = move_not_bits;
175                     call expmac$eis(l_op,p2);
176                     end;
177 
178           else do;
179 
180                /* exp, compile exp then generate comp_bits op
181                   or actually complement bits in ac */
182 
183                call compile_exp(q2);
184                if s2 > 2 then go to comp_long;
185                else goto complement;
186                end;
187 
188           goto string_done;
189 
190           /* Operation is EXCLUSIVE OR */
191 
192 switch(3):
193 xor_op:   op = era;
194           call check_lengths;
195           if for_test then l_op = test_xor; else l_op = move_xor;
196           load_double = 2;
197           goto set_s3;
198 
199           /* operation is OR */
200 
201 switch(2):
202 or_op:    op = ora;
203           call check_lengths;
204           if for_test then l_op = test_or; else l_op = move_or;
205           load_double = 2;
206           goto set_s3;
207 
208           /* operation is AND */
209 
210 switch(1):
211 and_op:   if for_test
212           then do;
213                op = and_for_test;
214                l_op = test_and;
215                end;
216           else do;
217                op = ana;
218                l_op = move_and;
219                end;
220 
221 set_s3:   if p3 -> reference.long_ref | p3 -> reference.varying_ref then s3 = 3;
222           else s3 = 2*fixed(p3 -> reference.c_length > bits_per_word,1);
223 
224           if op_code = and
225           then do;
226                load_double = 2*fixed(s2 = s3,1);
227 
228                /* See if we have a & ^ b.  If we do, we can shorten
229                   3 instructions to 2 */
230 
231                if can_do_andnot(which_andnot)
232                then do;
233                     atom(2) = code >= 2;
234                     atom(3) = mod(code,2) ^= 0;
235 
236                     if which_andnot = 0
237                          then call setup_andnot(p2,q2,s2,atom(2));
238                          else call setup_andnot(p3,q3,s3,atom(3));
239 
240                     code = fixed(atom(2) || atom(3), 2);
241 
242                     call check_lengths;
243 
244                     if for_test
245                          then l_op = test_andnot(which_andnot);
246                          else l_op = move_andnot(which_andnot);
247 
248                     doing_andnot = "1"b;
249                     end;
250                end;
251 
252           /* at this point the left and right sizes are coded in
253              s2 and s3 as 0: short, 2: double, 3: long.  now
254              dispatch on context of operator node */
255 
256           goto ao_sw(code);
257 
258           /* operation is atom-atom, reverse operands if
259              right operand longer than left */
260 
261 ao_sw(3):
262 ao_aa:    if p3 -> reference.value_in.a then call flip_rands;
263 
264           if s2 < s3 then call flip_rands;
265 
266           /* check for long operand(s) */
267 
268           if s2 > 2 then goto ao_aa_l;
269 
270           /* at this point right operand is shorter or same,
271              s3 = 0 for single, s3 = 2 for double */
272 
273           call load(p2,load_double);
274 ao_aa_1:  if op_code = and & s3 < s2 then call aq_man$clear_q;
275           call expmac$one(op,p3,s3);
276 
277           goto string_done;
278 
279           /* left (and possible right) operand is long */
280 
281 ao_aa_l:  p1 = string_temp(p,p2,p3);
282 
283 ao_aa_l1: if s3 > 2 | op_code = and | ^ p1 -> reference.aligned_for_store_ref | for_test
284           then do;
285 
286                /* right operand is long */
287 
288                call long_op;
289                end;
290           else do;
291 
292                /* right operand is short, generate
293                   xxsa or xxsa_xxsq macro */
294 
295                call load(p3,2);
296 ao_aa_l3:
297                if p1 -> reference.temp_ref
298                then if ^ p1 -> reference.shared
299                     then p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
300                call expmac$one(op+3,p1,s3);
301                machine_state.indicators = -1;
302                end;
303 
304           goto string_done;
305 
306           /* operation is atom-expression, reverse */
307 
308 ao_sw(2):
309 ao_ae:    call flip_rands;
310 
311           /* operation is expression-atom */
312 
313 ao_sw(1):
314 ao_ea:    if s2 > 2
315           then do;
316 
317                /* left is long, compile, then treat like
318                   atom-atom case */
319 
320                if p1 -> reference.length = null
321                 | (p2 -> reference.length = p3 -> reference.length
322                    & ^ p2 -> reference.varying_ref
323                    & ^ p3 -> reference.varying_ref)
324                     then call compile_exp(q2);
325                     else p2 = compile_exp$save(q2);
326                go to ao_aa_l;
327                end;
328 
329           /* left ^long, check for right long */
330 
331           if s3 > 2
332           then do;
333 
334                /* if right is really an expression, save value and treat
335                   like atom-atom case */
336 
337                p2 = compile_exp$save_exp(q2);
338                call flip_rands;
339                goto ao_aa_l;
340                end;
341 
342           /* neither operand is long */
343 
344           if ^ p3 -> reference.aligned_ref then p3 = compile_exp$save(p3);
345           call compile_exp(q2);
346           if s2 < s3 | (s3 ^= s2 & op_code = and) then call aq_man$clear_q;
347           call expmac$one(op,p3,s3);
348 
349           goto string_done;
350 
351           /* operation is expression-expression */
352 
353 ao_sw(0):
354 ao_ee:    if s2 < s3 then call flip_rands;
355 
356           /* at this point, right operand is shorter */
357 
358           if s3 > 2 then goto ao_ee_1;
359 
360           /* right operand is not long, left may be */
361 
362           if s2 > 2 then go to ao_ee_1;
363 
364           /* left is also not long */
365 
366           p3 = compile_exp$save(q3);
367           call compile_exp(q2);
368           goto ao_aa_1;
369 
370           /* both are long, check for the situation where the relation between
371              the lengths is unknown at compile-time */
372 
373 ao_ee_1:  if p2 -> reference.length ^= p3 -> reference.length
374            | p2 -> reference.varying_ref
375            | p3 -> reference.varying_ref
376           then do;
377 
378                /* compile right expression, then save temp */
379 
380                p3 = compile_exp$save(q3);
381 
382                /* compile left expression and save pointer */
383 
384                p2 = compile_exp$save(q2);
385 
386                /* since make_addressable will recognize the
387                   altered values of p2 and p3, we can treat like
388                   atom-atom case now */
389 
390                goto ao_aa_l;
391                end;
392 
393           if p2 -> reference.c_length < p3 -> reference.c_length then call flip_rands;
394 
395           /* both strings are constant or equal size, size2 >= size3 */
396 
397           p3 = compile_exp$save(q3);
398           call compile_exp(q2);
399           p1 = string_temp(p,p2,p3);
400           call long_op;
401 
402           /* string operator done */
403 
404 string_done:
405           if ^ p1 -> reference.long_ref
406                then a_reg.size = p1 -> reference.c_length;
407           return;
408 ^L
409 can_do_andnot: proc(which_andnot) returns(bit(1) aligned);
410 
411 /* determines whether we have a & ^ b, which can be optimized. */
412 
413 dcl            which_andnot fixed bin(15);        /* 0, if operand(2) is not_bits
414                                                      1, if operand(3) is not_bits (output) */
415 
416 dcl            i fixed bin;
417 dcl            q ptr;
418 
419                if p1 -> reference.long_ref
420                then do i = 2 to 3;
421                     q = p -> operand(i);
422                     if q -> node.type = operator_node
423                     then if q -> operator.op_code = not_bits
424                     then if ^ q -> operand(1) -> reference.evaluated
425                     then if q -> operand(1) -> reference.ref_count <= 1
426                     then do;
427                          which_andnot = i - 2;
428                          return("1"b);
429                          end;
430                     end;
431 
432                return("0"b);
433 
434           end /* can_do_andnot */;
435 ^L
436 setup_andnot:  proc(p_new,q,s,atom);
437 
438 /* sets up string_op vars for andnot */
439 
440 dcl            p_new ptr,     /* new ref node */
441                q ptr,         /* new opnd */
442                s fixed bin(15),         /* new length code */
443                atom bit(1) aligned;
444 
445                q = p -> operand(which_andnot+2) -> operand(2);
446 
447                p_new = prepare_operand(q,1,atom);
448 
449                if p_new -> reference.long_ref | p_new -> reference.varying_ref
450                     then s = 3;
451                     else s = 2 * fixed(p_new -> reference.c_length > bits_per_word, 1);
452 
453                call adjust_ref_count((p -> operand(which_andnot+2) -> operand(1)), -1);
454 
455                end /* setup_andnot */;
456 ^L
457 flip_rands:    proc;
458 
459 dcl            p ptr, s fixed;
460 
461                p = p2; p2 = p3; p3 = p;
462                p = q2; q2 = q3; q3 = p;
463                s = s2; s2 = s3; s3 = s;
464 
465                if doing_andnot
466                then do;
467                     which_andnot = mod(which_andnot+1,2);
468                     if for_test
469                          then l_op = test_andnot(which_andnot);
470                          else l_op = move_andnot(which_andnot);
471                     end;
472 
473                end /* flip_rands */;
474 
475 
476 check_lengths:      proc;
477 
478                if p1 -> reference.long_ref
479                then if for_test
480                     then if p2 -> reference.length ^= p3 -> reference.length
481                           | p2 -> reference.c_length ^= p3 -> reference.c_length
482                           | p2 -> reference.varying_ref
483                           | p3 -> reference.varying_ref
484                          then for_test, cg_stat$for_test_called = "0"b;
485 
486                end /* check_lengths */;
487 
488 
489 long_op:       proc;
490 
491                call expmac$eis(l_op,p3);
492 
493                end /* long_op */;
494 
495           end /* string_op */;