Personal tools
You are here: Home Projects SETL SETL Source code OPT: SETL optimizer.
Document Actions

OPT: SETL optimizer.

by Paul McJones last modified 2021-03-18 20:22

OPT: SETL optimizer. stlopt.opl

       1 .=member intro
       2 .title 'setl optimizer'
       3$
       4$
       5$           ssssssss   eeeeeeeeee  tttttttttt  ll
       6$          ssssssssss  eeeeeeeeee  tttttttttt  ll
       7$          ss      ss  ee              tt      ll
       8$          ss          ee              tt      ll
       9$          sssssssss   eeeeee          tt      ll
      10$           sssssssss  eeeeee          tt      ll
      11$                  ss  ee              tt      ll
      12$          ss      ss  ee              tt      ll
      13$          ssssssssss  eeeeeeeeee      tt      llllllllll
      14$           ssssssss   eeeeeeeeee      tt      llllllllll
      15$
      16$
      17$                 oooooooo   ppppppppp   tttttttttt
      18$                oooooooooo  pppppppppp  tttttttttt
      19$                oo      oo  pp      pp      tt
      20$                oo      oo  pp      pp      tt
      21$                oo      oo  pppppppppp      tt
      22$                oo      oo  ppppppppp       tt
      23$                oo      oo  pp              tt
      24$                oo      oo  pp              tt
      25$                oooooooooo  pp              tt
      26$                 oooooooo   pp              tt
      27$
      28$
      29$              t h e    s e t l    o p t i m i z e r
      30$
      31$
      32$                     stefan m. freudenberger
      33$                            art grand
      34$                        jacob t. schwartz
      35$                          micha  sharir
      36$                          leonard vanek
      37$
      38$
      39$       this software is part of the setl programming system
      40$                address queries and comments to
      41$
      42$                          setl project
      43$                 department of computer science
      44$                      new york university
      45$            courant institute of mathematical sciences
      46$                       251 mercer street
      47$                      new york, ny  10012
      48$
      49$
      50$
      51$
      52$                        table of contents
      53$                        ----- -- --------
      54$
      55$   1.  intent of the optimiser
      56$
      57$   2.  data structures
      58$
      59$	2a.	internal form of the program
      60$	2b.	the program
      61$		maps on blocks, on instructions, instruction macros
      62$		iteration macros
      63$	2c.	code sequences for calls, entries,exits
      64$	2d.	scopes and routines
      65$		maps on scopes, scope types, procedure values, macros
      66$	2e.	effects of separate compilation
      67$	2f.	code for iterative set and tuple formers
      68$	2g.	code for case statement and multiparameter retrievals
      69$
      70$   3.	variable declarations
      71$
      72$	3a.	the symbol table
      73$	3b.	values of variables
      74$	3c.	occurences
      75$	3d.	q1-opcodes
      76$	3e.	control graph and interval analysis,
      77$		data flow maps, call graph
      78$	3f.	types
      79$	3g.	forms
      80$	3h.	call paths
      81$	3i.	various initial maps
      82$	3j.	control parameters
      83$
      84$   4.  global variable declarations
      85$
      86$   5.  module specifications
      87$
      88$	5a.	main program
      89$	5b.	compiler interface, utilities
      90$	5c.	call graph analysis
      91$	5d.	interval analysis
      92$	5e.	redundant expression elimination and code motion
      93$	5f.	live analysis
      94$	5g.	data flow analysis package
      95$	5h.	data flow analysis - bfrom computation
      96$	5i.	type finding
      97$	5k.	automatic data structure selection
      98$	5l.	conversion optimisation
      99$	5m.	copy optimisation
     100$	5n.	output to the code generator
     101$
     102$   6.  data structure declarations for global variables
     103$
     104$   7.  main program for the optimiser
     105$
     106$   8.  interface to little-written portions
     107$
     108$	8a.	read_q1, get_header
     109$	8b.	get_forms
     110$	8c.	get_symtab, cnvval
     111$	8d.	get_code
     112$	8e.	write_q1, set_ltl_maps, put_header
     113$	8f.	put_forms
     114$	8g.	put_symtab
     115$	8h.	put_code
     116$	8i.	bld_val, elmt_sym
     117$	8j.	reset
     118$
     119$   9.  routines for the preliminary pass
     120$
     121$	...	opt_ini, readcc,
     122$		first_pass,
     123$		shortcut, get_temp, transclose, exp_name
     124$	9a.	satisfy_members
     125$	9b.	satisfy_procs
     126$	9c.	bld_body
     127$	9d.	bld_entry, bld_label, bld_use, bld_def, bld_call,
     128$		bld_exitstop
     129$
     130$   10. interval analysis
     131$
     132$	10a.	find_intervals, find_graph
     133$	10b.	find_ints
     134$	10c.	update
     135$	10d.	dfst, .intof_lim, get_targ
     136$
     137$   11. available expressions analysis
     138$
     139$	11a.	csx
     140$	11b.	interproc_csx
     141$	11c.	intraproc_csx
     142$	11d.	move_eliminate, insert_exp
     143$	11e.	csx_blockmaps
     144$
     145$   12. live analysis
     146$
     147$	12a.	live
     148$	12b.	interproc_live
     149$	12c.	intraproc_live
     150$	12d.	live_blockmaps
     151$
     152$   11f.bfrom_analysis
     153$
     154$	11g.	find_bfrom, global_bfrom, local_bfrom
     155$	11h.	comp_bfrom
     156$	11i.	bfrom_blockmaps, .join
     157$
     158$   13. dataflow solver
     159$	    cgraph_analysis, interproc_fwd_analysis,
     160$	    interproc_fwd_eliminate, intraproc_fwd_eliminate,
     161$	    propagate_exposed, fwd_propagate_in, intraproc_fwd_analysis
     162$	    interproc_back_eliminate, intraproc_back_eliminate,
     163$	    intra_aux_eliminate, exit_info, back_propagatein,
     164$	    also auxiliary routines
     165$
     166$   14. type finder
     167$
     168$	14a.	the type lattice, basic algorithm
     169$	14b.	type_find
     170$	14c.	type_forward, given_type, dfs
     171$	14d.	type_backward
     172$	14e.	type_final
     173$	14f.	forward
     174$	14g.	backward
     175$	14h.	type_constant, constant_equality
     176$	14i.	ntyp, knt_type
     177$	14j.	pair_type
     178$	14k.	trim, norm
     179$	14l.	.con
     180$	14m.	.dis
     181$	14n.	.sub
     182$	14o.	const_typ, sting_length, .is_pair, .is_map
     183$	14p.	ads_type
     184$
     185$   15. auto_dstruct
     186$
     187$	...	auto_data
     188$	15a.	basegen
     189$	15b.	    genbases
     190$	15c.	    genabase
     191$	15d.	basemerge
     192$	15e.	    equibase
     193$	15f.	    .lim
     194$	15g.	baseadjust
     195$	15h.	    fancy_output
     196$	15i.	    real_repr, remarks
     197$
     198$   16. utilities for code manipulation
     199$
     200$	add_block,add_sym,add_label,add_int,add_inst,
     201$	insert, make_nl,ermesg,abort
     202$
     203$   17. dumps
     204$	dmp, symdmp,formdmp,codedmp,intdmp, etc.
     205$
     206$
     207$
       1 .=member ntent1
       2$
       3$
       4$
       5$ i n t e n t    o f    t h e    o p t i m i z e r
       6$ --------------------------------------------------
       7$
       8$ most of the optimizer is concerned with gathering information about a
       9$ program being optimized.  the optimization algorithms are so complex
      10$ that it is easy to loose track of how the optimizer actually improves
      11$ the code.  before getting started, we take time to discuss this.
      12$
      13$ the optimizer makes code improvements in five areas:
      14$
      15$ 1. it performs various classical optimizations such as code motion,
      16$    redundant subexpression elimination, removal of dead and
      17$    unreachable code, and constant propagation.  these optimizations
      18$    are reflected in changes to the q1 code.
      19$
      20$ 2. it determines the types of undeclared and partially declared
      21$    variables.  this means both type determination in the tennenbaum
      22$    sense, and automatic data structure selection.  this information
      23$    is used to fill in forms.
      24$
      25$ 3. it determines which routines are recursive, and determines which
      26$    temporaries and local variables can be made static (is_stk = om).
      27$
      28$ 4. it determines when copies must be made as part of an instruction.
      29$
      30$ 5. it makes various peephole optimizations to the code.
      31$
      32$ most information generated by the optimizer is in the form of attrib-
      33$ utes of variables.  the optimizer performs 'name splitting' in order
      34$ to insure that the attributes of a variable are the same throughout
      35$ the program.
      36$
      37$ name splitting is a process of dividing the occurrences of each
      38$ variable into equivalence classes such that all occurrences in each
      39$ class have the same attributes. each equivalence class is then made
      40$ into a new variable.
      41$
      42$ once we have performed name splitting, it is generally possible for
      43$ more than one variable to share the same run time address.  variables
      44$ which can share storage are made into aliases by setting the 'alias'
      45$ map.
      46$
      47$ new names are also added whenever we create bases, labels, etc.
      48$ this is done by the routine 'add_sym'.
      49$
      50
      51$
      52$ the following section describes all the data structures and modules of
      53$ the optimizer.  we begin with some comments on the data structures.
      54$
       1 .=member ifrm2a
       2 .title 'data structures'
       3
       4$ d a t a    s t r u c t u r e s
       5$ ------------------------------
       6
       7$ first we give declarations and reprs for all the global data
       8$ structures of the optimizer.
       9
      10
      11$ internal form of the program
      12$ ----------------------------
      13
      14$ in this section we discuss the internal form of setl programs and give
      15$ the data structures which define it.
      16
      17$ we begin by defining a few terms.
      18$
      19$ 1. symbols
      20$
      21$    each symbol corresponds to a resolved name in a setl source program
      22$    or to a compiler generated temporary.  symbols are represented as
      23$    atoms which are elements of the base 'symbols'.
      24$
      25$ 2. temporaries
      26$
      27$    a temporary is a symbol generated by the compiler to serve as the
      28$    output of an expression.  the output of an expression is always a
      29$    temporary;  symbols appearing in the source program may only appear
      30$    as outputs in assignment instructions.
      31$
      32$    when the program is read in from the semantic pass, each
      33$    instruction generates a unique temporary.  temporaries are merged
      34$    during redundant subexpression elimination.
      35$
      36$ 3. forms
      37$
      38$    a 'form' is a description of how a setl object is represented at
      39$    run time.  the form of a symbol indicates how values assigned to
      40$    that symbol are to be represented.  forms may be supplied by the
      41$    user through the 'repr' statement, or may be generated
      42$    automatically.
      43$
      44$    forms are represented as atoms on which various maps are defined.
      45$
      46$    note that the typefinder and the automatic data choice algorithm
      47$    do not compute the forms of variables.  instead they compute much
      48$    simpler type descriptors known as 'types'.  'types' are converted
      49$    to 'forms' later on.
      50$
      51$ 4. the program
      52$
      53$    the program is divided into routines, basic blocks, and
      54$    instructions.  each instruction consists of an opcode and a tuple
      55$    of arguments.  all the inputs and outputs of an instruction
      56$    appear explicitly as arguments.
      57$
      58$    the instructions in each block are arranged in a linked list. this
      59$    is designed to give maximum flexibility in the insertion and
      60$    deletion of code.  if we were to use tuples, then the entire block
      61$    might need to be copied if we were to insert or delete an instruc-
      62$    tion.
      63$
      64$ 5. occurrences
      65$
      66$    an occurrence is a use or definition of a variable.  occurrences
      67$    are identified by pairs
      68$
      69$	      [ instruction, argument no. ]
      70$
      71$    occurrences which are used as inputs are called 'ivariables', and
      72$    occurrences which are outputs are called 'ovariables'.  an
      73$    occurrence may be both an i- and o-variable, for example,
      74$    'f' in 'f(x) := y'.
      75
      76$ plex bases and data abstraction
      77$ ------------------------------
      78
      79$ symbols, forms, etc. can all be thought of as abstract data types.  we
      80$ treat abstract objects as atoms which have various maps based on them.
      81$
      82$ the objects of each abstract type form a base.  very often we will
      83$ have a set 's' which contains all the objects of a given type(say all
      84$ symbols).  's' is clearly equivalent to the base of symbols.
      85$
      86$ generally 's' will not be represented explicitly.  instead we will
      87$ keep a map which links all the elements of the base in order of
      88$ creation.  this is done for three reasons:
      89$
      90$ 1. is allows us to maintain 'symbols' as a plex base and still be able
      91$    to iterate over 's'.  plex bases are generally much more efficient
      92$    than normal bases.
      93$
      94$ 2. it allows us to iterate over 's' in a standard order for dumping
      95$    purposes.
      96$
      97$ 3. we must be able to iterate over all symbols in their order of
      98$    creation in order to build the tables which are passed to the code
      99$    generator.
     100$
     101$ a variety of macros for iterating over link maps are provided in the
     102$ section 'iteration macros'.
     103$
       1 .=member prog2b
       2 .title 'the program'
       3
       4$ the program
       5$ -----------
       6
       7$ the program is divided into routines, basic blocks, and instructions.
       8$ each instruction consists of an opcode and a tuple of arguments.  all
       9$ the inputs and outputs of an instruction appear explicitly as
      10$ arguments.
      11$
      12$ if an instruction has an output, it is always the first argument;
      13$ if an instruction has label as an argument, it is always the last
      14$ argument.
      15$
      16$ each instruction has at most one argument which may require copying.
      17$ the instruction's 'copy flag' indicates whether the argument must be
      18$ copied conditionally, unconditionally, or not at all.  the
      19$ instruction's opcode determines which argument the copy flag refers
      20$ to.
      21$
      22$ an instruction may also have an argument whose share bit must be set.
      23$ the instruction's 'share flag' indicates whether the bit must
      24$ actually be set.
      25$
      26$ the instructions in each block are threaded into a linked list.  this
      27$ is designed to allow maximum flexibility in code insertion and
      28$ deletion.
      29$
      30$ blocks are 'extended' in the sense that there may be more than one
      31$ branch out of a block.  the last instruction of a block is always a
      32$ procedure exit, stop or goto.  calls constitute a single instruction
      33$ blocks, but are represented by a 3-instruction block (containing
      34$ label, call, and go-to).  since each block ends in a goto, we can
      35$ generate code for blocks in any order.
      36$
      37$ when the optimizer reads in the program, it reads blocks in the order
      38$ in which they appear in the source.  this order is fairly optimal
      39$ since it makes the branches at the end of most blocks redundant.
      40$
      41$ we keep track of this order using the first_block and next_block maps
      42$ so that we can write the blocks out optimally.
      43$
      44
      45
      46$ maps on blocks
      47$ --------------
      48
      49    macro block_maps;
      50	routof,		$ routine containing block
      51	next_block,	$ next block, see above
      52	first_inst,	$ first instruction of block
      53	last_inst	$ last instruction of a block
      54    endm;
      55
      56
      57$ maps on instructions
      58$ --------------------
      59
      60    macro inst_maps;
      61	opcode,		$ operation code
      62	args,		$ tuple of arguments
      63	occs,		$ tuple of occurrences
      64	blockof,	$ gives block containing instruction
      65	stmtof,		$ cummulative statement count of the instruction
      66	copy_flag,	$ indicates what copy action should be done
      67	share_flag,	$ indicates setting of a share bit
      68	next_inst	$ next instruction in block
      69    endm;
      70
      71
      72$ macros for accessing instructions
      73$ ---------------------------------
      74
      75    macro arg1(i);	args(i)(1)				endm;
      76    macro arg2(i);	args(i)(2)				endm;
      77    macro arg3(i);	args(i)(3)				endm;
      78
      79
      80$ the following macro yields the label of a basic block.
      81
      82    macro blk_label(b);	arg1(first_inst(b))			endm;
      83
      84$ the values for copy flags are:
      85
      86    macro copy_actions;
      87	copy_no,	$ no copy required
      88	copy_yes,	$ always copy
      89	copy_test	$ test share bit before copy
      90    endm;
      91
      92
      93 .title 'iteration macros'
      94
      95$ iteration macros
      96$ ----------------
      97
      98$ the following macros are used for iterating over all
      99$ blocks, forms, symbols, etc.
     100
     101    macro for_list(x, first, next);	$ iterate over a list
     102	init x := first; while x /= om step x := next(x);
     103    endm;
     104
     105    macro for_block(b, scope);		$ for blocks in a scope
     106	for_list(b, first_block(scope), next_block)
     107    endm;
     108
     109    macro for_inst(i, b);		$ for instructions in a block
     110	for_list(i, first_inst(b), next_inst)
     111    endm;
     112
     113    macro for_form(f, scope);		$ for forms in a scope
     114					$ see scopes, below
     115	for_list(f, first_form(scope), next_form)
     116    endm;
     117
     118    macro for_sym(s, scope);		$ for symbols in a scope
     119					$ see scopes, below
     120	for_list(s, first_sym(scope), next_sym)
     121    endm;
     122
     123
       1 .=member clls2c
       2 .title 'code sequences for calls, entries, and exits'
       3
       4$ code sequences for calls, entries, and exits
       5$ -------------------------------------------
       6
       7$ in this section we discuss the representation of calls, entries and
       8$ exits in the q1 instructions.
       9
      10$ note
      11$ ----
      12
      13$ the setl system uses two radically different linkage mechanisms
      14$ depending on the 'back' option on the control card.
      15$
      16$ back=0 is the default, and indicates that backtracking is illegal.
      17$ this allows the relatively simple linkage mechanism described below.
      18$
      19$ back=1 indicates that the program may contain backtracking.  in this
      20$ case we refuse to optimize it.  we may choose to handle backtracking
      21$ in a later version of the optimizer.
      22
      23$ calling sequences
      24$ -----------------
      25
      26$ a calling section consists of:
      27$
      28$ 1. 'argin' assignments
      29$
      30$    these are a series of instructions which bind the actual arguments
      31$    to the formal parameters.  there is one q1_argin instruction for
      32$    each argument.  these instructions have:
      33$
      34$    arg1:	name of actual argument
      35$    arg2:	name of procedure being called
      36$    arg3:	argument number
      37$
      38$    for write-only arguments, arg1 points to the symbol 'om'.
      39$
      40$    the run time semantics of an argin instruction is to push arg1 onto
      41$    the invocation stack.  however the optimizer thinks of it as an
      42$    assignment to the formal parameter.  in order to do this, it adds
      43$    the formal parameter as the first argument of that instruction.
      44$
      45$ 2. the actual call
      46$
      47$    this consists of a q1_call instruction with:
      48$
      49$    arg1:	name of procedure
      50$    arg2:	number of actual arguments
      51$
      52$ 3. free and argout instructions
      53$
      54$    'free' instructions remove the values of read-only arguments from
      55$    the invocation stack.  they are ignored by the optimizer.  argout
      56$    instructions assign the values of write and read-write parameters
      57$    back to the arguments.
      58$
      59$    the q1_free and q1_argout instructions have the same arguments as
      60$    the q1_argin instruction.  the optimizer adds a fourth argument to
      61$    argout instructions as its last argument.
      62$
      63$ note that if a procedure has a variable number of arguments,
      64$ such as:
      65$
      66$    procedurep(a, b(*));
      67$
      68$ then the extra arguments are gathered into a tuple.  thus the call
      69$
      70$	p(1, 2, 3);
      71$
      72$ has two argin instructions.  the first passes '1' and the second
      73$ passes '[ 2, 3 ]'.  the q1_call instruction indicates that the call
      74$ had 3 arguments.  this is the value returned by the 'na' operator.
      75
      76
      77$ entry, exit, and stop blocks
      78$ ----------------------------
      79
      80$ each routine begins with an 'entry' block, and ends with an 'exit'
      81$ block followed by a 'stop' block. the entry block has a single
      82$ instruction with:
      83$
      84$ opcode:	q1_entry
      85$ arg1:		name of routine
      86$
      87$ the exit block has one instruction with:
      88$
      89$ opcode:	q1_exit
      90$ arg1:		name of routine
      91$
      92$ the stop block has one instruction with:
      93$
      94$ opcode:	q1_stop
      95$
      96
       1 .=member scor2d
       2 .title 'scopes and routines'
       3
       4$ scopes and routines
       5$ -------------------
       6
       7$ setl programs are divided into separate namescopes.  a namescope is
       8$ either a directory member, a procedure, or a special system namescope.
       9$ when the semantic pass writes out the q1 tables, it writes them one
      10$ scope at a time.  we must keep lists of the symbols, forms, and blocks
      11$ for each scope.  this is done by using a series of maps first_xxx
      12$ which point to the start of each list and last_xxx which point to the
      13$ end of the list.
      14$
      15$ namescopes are simply identified by their names. the following maps
      16$ are defined on scopes:
      17
      18    macro sc_maps;
      19	scopes,		$ tuple of scopes in lexical order
      20	cont_scopes,	$ tuple of containing scopes (inner-to-outer)
      21	sc_stmt_ct,	$ maps each scope to its statement count
      22	sc_estmt_ct,	$ maps each procedure scope to the statement
      23			$ number of the q1_entry instruction
      24	sc_type,	$ string sc_xxx giving the type of a scope
      25	sc_nprocs,	$ number of procedures in a member
      26	first_sym,	$ first symbol in a scope
      27	last_sym,	$ last symbol in a scope
      28	first_block,	$ first block in a scope
      29	last_block,	$ last block in a scope
      30	first_form,	$ first form in a scope
      31	last_form	$ last form in a scope
      32    endm;
      33
      34$ the scope types are:
      35
      36    macro sc_types;
      37	sc_sys,		$ system unit
      38	sc_lib,		$ library
      39	sc_dir,		$ directory
      40	sc_prog,	$ program
      41	sc_mod,		$ module
      42	sc_proc,	$ procedure
      43	sc_end		$ indicates end of file
      44    endm;
      45
      46$ the following maps are defined on procedure names:
      47$ note that procedure names are also symbols
      48
      49    macro rout_maps;
      50	routs,		$ set of all routines
      51	rentry,		$ entry block
      52	rexit,		$ exit block
      53	rstop,		$ stop block
      54	rparams,	$ tuple of formal parameter names
      55	membof		$ member in which routine is supplied
      56    endm;
      57$
      58$ there is more information on procedures contained in their 'value'
      59$ entries.  (see section 'values', below) this information is accessed
      60$ by the following macros:
      61$
      62$ rretn:   the global variable used to return the value of a function
      63$	   call.
      64$
      65$ rvary:   indicates procedure with variable number of arguments
      66$
      67$ rnargs:  indicates number of arguments
      68$
      69$ rptyps:  types of parameters: rd, wr, or rw.
      70$
      71    macro rretn(p);	value(p)(1)				endm;
      72    macro rvary(p);	value(p)(2)				endm;
      73    macro rnargs(p);	value(p)(3)				endm;
      74    macro rptyps(p);	value(p)(4)				endm;
      75
      76
       1 .=member secm2e
       2$ the effects of separate compilation
       3$ -----------------------------------
       4
       5$
       6$ setl allows members to be compiled separately.  when we run the  opti-
       7$ miser, there are four possibilities:
       8$
       9$ 1. the input is a set of libraries. add a dummy main program which
      10$    refers to all the libraries in its 'libraries' list, then go on
      11$    to case 2.
      12$
      13$ 2. the input consists of a program and a set of libraries.
      14$    add a dummy directory which contains a description of the
      15$    program, and go on to case 3.
      16$
      17$ 3. the input contains a set of libraries, a directory, and a set
      18$    of members which are described in the directory.  find all
      19$    the members which are described in the directory but not
      20$    included in the input and build dummy bodies for their
      21$    exported procedures. go on to case 4.
      22$
      23$ 4. the input is a complete program.
      24$
       1 .=member spcd2f
       2 .title 'code generated for various special operations'
       3
       4$ code for iterative set and tuple formers
       5$ ----------------------------------------
       6
       7$ the run time library uses a stack for argument
       8$ passage, recursion, etc. and also to implement
       9$ iterative set and tuple formers.
      10$
      11$ there are two q1 opcodes which manipulate the stack, and altogether
      12$ there are three opcodes used in relation with iterative set and
      13$ tuple formers:
      14$
      15$ q1_push:	push a1 onto the stack.
      16$
      17$ q1_set1:	build a set from the top a3 stack entries and
      18$		store it in a1.
      19$
      20$ q1_tup1:	similar to q1_set1, but builds a tuple.
      21$
      22$ note that in these last two operators the first input argument is the
      23$ expression in the iterative set or tuple former.  this aids in the
      24$ type finder.
      25$
      26$ q1_set1 and q1_tup1 are always used in conjunction with a q1_push
      27$ instruction.  their second argument is the same as the first argument
      28$ of the corresponding push.
      29$
      30$ the code for 's := {x : x in s1}' looks like:
      31$
      32$    counter := 0;
      33$
      34$    (forall x in s1)
      35$	push(x);
      36$	counter +:= 1;
      37$    end forall;
      38$
      39$    s := set1(x, counter);
      40$
      41$ 'q1_push' is used only for iterative set and tuple formers.
      42$ (procedures use q1_argin instructions to push parameters)
      43$ the optimizer can view it as a simple assignment t2 := t2.
      44$ (in connection with the computation of bfrom links, etc.)
      45$ the code generator will view it as a stack push.
      46$
      47$ the opcodes q1_set1 and q1_tup1 are used solely for enumerative
      48$ set- and tuple-formers, while iterative set- and tuple-formers use
      49$ the q1_set and q1_tup instructions, resp.
      50$
       1 .=member cacd2g
       2$
       3$ the code generated for "s := { x+1 : x in s1 }" is:
       4$
       5$     asn     t.1       0               $ initialize counter
       6$     asn     i.3       s1              $ iterate over copy os s1
       7$     inext   i.1       i.2       i.3
       8$     goto    l.1
       9$
      10$     label   l.1                       $ loop body
      11$     next    i.1       i.2       i.3   $ advance in s1
      12$     eq      t.2       i.2       om    $ check for iteration end
      13$     if      t.2       l.3
      14$     asn     x         i.1             $ assign next element to x
      15$     add     t.3       x         1     $ compute 
      16$     push    t.3       t.4             $ push set element
      17$     add     t.5       t.1       1     $ increment counter
      18$     asn     t.1       t.5
      19$     goto    l.2
      20$
      21$     label   l.2                       $ step block
      22$     goto    l.1
      23$
      24$     label   l.3                       $ term block
      25$     asn     i.1       om
      26$     asn     i.3       om
      27$     set1    t.4       t.3       t.1   $ setformer
      28$     asn     s         t.4
      29$
      30
      31
      32$ code for case statement
      33$ -----------------------
      34
      35$ a case statement such as 'case x of' ... '(red):' ... 'end'
      36$ is implemented by building a map from tag values to labels.
      37$ the actual 'q1_case' instruction has:
      38$
      39$ arg1:     name of map
      40$ arg2:     name of expression, i.e. 'x'
      41$ arg3:     label for 'else' clause.
      42$
      43$ note that the first argument is a constant. by examining
      44$ its value, we can determine the labels of all the alternatives
      45$ in the case statement.
      46$
      47
      48$ code for f(x1, ..., xn), etc.
      49$ -----------------------------
      50
      51$ multi-variate map retrieval and assignment statements compile into  an
      52$ enumerative tuple former for the domain element, which is then used to
      53$ index the map.  if the cardinality of the domain tuple is 1, then  the
      54$ semantic pass catches the obvious  optimization  to  not  create  this
      55$ tuple.
      56
      57
       1 .=member smtb3a
       2
       3
       4$ variable declarations
       5$ ---------------------
       6
       7$ in this section we declare variables global to the entire optimizer.
       8$ the globals can be divided into various logical groupings, such as
       9$ the code and the symbol table.  we provide a macro to list the
      10$ variables in each group.
      11
      12 .title 'symbol table'
      13
      14$ the symbol table
      15$ ----------------
      16
      17$ the 'symbol table' is a collection of maps on symbols.
      18$ these maps are:
      19$
      20$ name:		a string giving the name of the symbol.
      21$
      22$ is_internal:	flags internally generated name.
      23$
      24$ value:	the value of a symbol. see below.
      25$
      26$ is_const:	indicates constant
      27$
      28$ scope:	maps local variables into their procedures and
      29$		global variables into their module, library, etc.
      30$
      31$ form:		gives the form of a symbol
      32$
      33$ alias:	this field is used for symbols which share storage with
      34$		each other.  these symbols are created by the compiler
      35$		when it processes the 'const' statement and are created
      36$		by the optimizer during the 'name splitting' phase.
      37$
      38$		the alias field is used in conjunction with the is_store
      39$		field.  if two symbols s1 and s2 share storage, then one
      40$		of them, say s1, will have:
      41$
      42$		is_store = 1   indicating storage is required
      43$		alias    = om
      44$
      45$		while s2 will have:
      46$
      47$		is_store = om  indicating no separate storage
      48$		alias    = s1
      49$
      50$		the alias field is also used to link unsatisfied
      51$		external procedures which effect the same global
      52$		variables, etc.
      53$
      54$ is_store:	see above
      55$
      56$ is_temp:	flags temporary variables.
      57$		(is_temp is a subset of is_internal)
      58$
      59$ is_read:	indicates read permission for constant or variable
      60$
      61$ is_write:	indicates write permission for a variable
      62$
      63$ is_stk:	flags stacked variables
      64$
      65$ is_param:	flags formal parameters
      66$
      67$ is_repr:	indicates that specific information is available about
      68$		the internal representation of the object.  this
      69$		information is either supplied by the user, or
      70$		determined by the optimizer.
      71$
      72$ is_init:	flags initialised variables:   their  alias  field  will
      73$		point to the symbol table  entry  carrying  the  initial
      74$		value of this symbol.
      75$
      76$ is_seen:	member, procedure, or label has been seen in the input.
      77$
      78$ is_back:	flags backtracked variables:  we do not attempt to opti-
      79$		mise programs with backtracking, yet this  flag must  be
      80$		transmitted from the sem to cod.
      81$
      82$ is_rec:	flags recursive routines.  by default,  we  assume  that
      83$		all routines are recursive.  call  graph  analysis  will
      84$		tell us which routines are not recursive,  and  thus  do
      85$		not require (more expensive) recursive  routine  prologs
      86$		and epilogs.
      87$
      88$ next_sym:	links the symbols of each scope in order of creation
      89$		note that if a procedure has 'n' parameters then they
      90$		are the first 'n' symbols in its scope.
      91
      92
      93    macro symbol_table;
      94	name,
      95	is_internal,
      96	value,
      97	is_const,
      98	scope,
      99	form,
     100	alias,
     101	is_store,
     102	is_temp,	$ flags temporaries
     103	is_read,	$ indicates reads permission for a variable
     104	is_write,	$ indicates write permission for a variable
     105	is_stk,		$ flags local stacked variables
     106	is_param,	$ flags formal parameters
     107	is_repr,	$ indicates data structure info is available
     108	is_init,	$ flags initalised (global) variables
     109	is_seen,	$ flags members seen in the input
     110	is_back,	$ flags backtracked variables
     111	is_rec,		$ flags recursive routines
     112	next_sym
     113    endm;
     114
       1 .=member valu3b
       2 .title 'value of variables'
       3
       4$ value of variables
       5$ ------------------
       6
       7$ the 'value' map is defined for constants(is_const = 1) and variables
       8$ appearing in an 'init' statement.  constants have:
       9$
      10$ is_const:	1
      11$ value:	gives value of constant
      12$
      13$ uninitialized variables have:
      14$
      15$ is_const:	om
      16$ value:	om
      17$
      18$ we can distinguish between constants and initialized variables
      19$ by noting that constants have their 'is_write' bit = om, whereas
      20$ initialized variables have their 'is_write' bit = 1 (true).
      21$
      22$ we can distinguish between two types of 'value' entries:
      23$
      24$ 1. run time values
      25$
      26$    these are values for constant denotations, etc.  for example, the
      27$    value of the symbol '1' is the integer 1, and the value of the
      28$    symbol 'nl' is a null set.
      29$
      30$ 2. compile time values
      31$
      32$    symbols such as labels, module names, and procedures can be said to
      33$    have values even though they can never appear in expressions. their
      34$    values are of interest only to the compiler.
      35$
      36$    a. labels
      37$
      38$	the value of a label is the instruction which defines it.
      39$
      40$    b. perform blocks
      41$
      42$	the value of a perform block is a pair [ l1, l2 ] where l1 is
      43$	the label for the perform block and l2 is the label for the
      44$	point it returns to.  perform blocks are compiled into the
      45$       sequence 'go to l1; l2:'.
      46$
      47$    c. procedures
      48$
      49$	the value of a procedure is a (procedure descriptor) tuple whose
      50$	components are:
      51$
      52$	1. the name of the variable used to return the procedure value
      53$
      54$	2. a flag indicating whether the procedure has a variable number
      55$	   of arguments.
      56$
      57$	3. the number of arguments (or minimum number if the procedure
      58$	   can have a variable number of arguments).
      59$
      60$	4. a tuple whose i-th component is either 'rd', 'wr', or 'rw',
      61$	   indicating the type of the i-th parameter.
      62$
      63$    d. libraries, programs, and modules
      64$
      65$	the value (descriptor) of a library, program, or module is a
      66$	tuple [ libraries, reads, writes, imports, exports ] where
      67$	'libraries' is the set of libraries referenced, 'reads' is a
      68$	list of globals read, 'writes' is a set of globalswritten,
      69$	'exports' is a set of procedures exported, and 'imports' is a
      70$       set of procedures, exported from other modules which are called
      71$	from the member.
      72$
      73$ note that directories have no value.
      74$
      75$ when the compiler processes a statement such as
      76$
      77$    const s = { [ 1, 2 ], [ 2, 3 ] };
      78$
      79$ it generates three symbol table entries,  one for 's' and one for each
      80$ of its components.   the value of 's' is then represented as a list of
      81$ symbol table pointers to its elements.   the symbol table  entries for
      82$ the components always appear before the symbol table entry for 's'.
      83$
      84$ whenever a new composite value is added to a scope,  we first  have to
      85$ find (or add)  its components  to the  current scope,  or an enclosing
      86$ scope (i.e. a scope which is 'larger' than the  current scope).   this
      87$ process is neccessarily recursive.
      88$
      89$ during constant propagation, the optimizer may find that a variable
      90$$$ ????? may be simplified
      91$ 'x' has a constant value of 'v'. it must then do three things:
      92$
      93$ 1. set is_const(x) = 1.
      94$
      95$ 2. set value(x) = v.
      96$
      97$ 3. if 'v' is a set or tuple then iterate over its elements 'e' making
      98$    sure that there is a symbol table entry with value 'e' and the
      99$    proper scope and type.  the entry for 'e' must appear before the
     100$    entry for 'x'.
     101$
     102$ step (3) is done using a map called value_inv which sends a value,
     103$$$ ????? may be simplified
     104$ type, and scope into a symbol.
     105
     106
       1 .=member occr3c
       2 .title 'occurrences'
       3
       4$ occurrences
       5$ -----------
       6
       7$ an occurrence is a use or definition of a variable.  it is identified
       8$ as a triple
       9$
      10$   [ instruction identifier, argument number, call path ].
      11$
      12$ but in our initial debugging we ignore the third argument and treat
      13$ occurences as pairs.
      14$
      15$ 'call paths' are discussed in the next section.
      16$
      17$ occurrences which are inputs are called 'ivariables', and occurrences
      18$ which are outputs are called 'ovariables'.  an occurrence may be both
      19$ an i- and o-variable, for example 'f' in 'f(x) := y'.
      20$
      21$ o-variables always appear in the first argument position, while
      22$ i-variables may appear anywhere.
      23$
      24$ the set ops_ovar contains all opcodes whose first argument is an
      25$ ovariable, and the set ops_ivar contains all opcodes whose first
      26$ argument is an ivariable.  these sets are not mutually exclusive,
      27$ as seen from the 'f(x)' example above.
      28
      29
      30$ the following macros are used for occurrences:
      31$
      32$ oi_op:	the opcode of their instruction
      33$ oi_sym:	the symbol for the occurrence
      34$ oi_val:	the symbols value
      35$ oi_sib:	the n-th argument of the instruction containing i
      36
      37    macro ocrs_maps;
      38	instno,		$ the instruction number of an occurrence
      39	argno		$ the argument number of an occurrence
      40    endm;
      41
      42    macro path(oi);	oi(3)					endm;
      43
      44    macro oi_op(oi);	opcode(instno(oi))			endm;
      45    macro oi_sym(oi);	args(instno(oi))(argno(oi))		endm;
      46    macro oi_form(oi);	form(oi_sym(oi))			endm;
      47    macro oi_name(oi);	name(oi_sym(oi))			endm;
      48    macro oi_val(oi);	value(oi_sym(oi))			endm;
      49    macro oi_str(oi);	(str instno(oi)+'/'+str argno(oi))	endm;
      50    macro oi_rout(oi);	routof(blockof(instno(oi)))		endm;
      51
      52    macro oi_stmt(oi);
      53	(  name(oi_rout(oi)) + '.' +
      54	    str(stmtof(instno(oi)) - sc_stmt_ct(oi_rout(oi)) + 1)  )
      55    endm;
      56
      57$ in order to speed up iterations and test the types of occurrences,
      58$ we provide the following sets:
      59
      60    macro oi_sets;
      61	all_oi,		$ set of all occurrences
      62	all_o,		$ set of all o-variables
      63	all_i		$ set of all i-variables
      64    endm;
      65
      66
      67    macro is_ovar(oi);	(oi in all_o)				endm;
      68    macro is_ivar(oi);	(oi in all_i)				endm;
      69
      70    macro get_oi(i, j);	occs(i)(j)				endm;
      71    macro get_ovar(oi);	get_oi(instno(oi), 1)			endm;
      72
      73    macro first_ivar(op);	$ argument number of first i-variable
      74	if op in ops_ivar then 1 else 2 end
      75    endm;
      76
      77    macro get_ivars(oi; j);
      78	[ get_oi(instno(oi), j) :
      79		j in [ first_ivar(oi_op(oi))..#args(instno(oi)) ]  ]
      80    endm;
      81
      82
       1 .=member opcd3d
       2 .title 'q1 opcodes'
       3
       4$ the set opcodes defines all the operations in the internal program
       5$ representation.
       6
       7    macro opcodes;
       8$
       9$ binary operators
      10$
      11	q1_add,		$ +
      12	q1_div,		$ div
      13	q1_exp,		$ **
      14	q1_eq,		$ =
      15	q1_ge,		$ >=
      16	q1_lt,		$ <
smfh   1	q1_pos,		$ > 0 (used only for arithmetic iterators)
      17	q1_in,		$ in
      18	q1_incs,	$ incs, subset
      19	q1_less,	$ less
      20	q1_lessf,	$ lessf
      21	q1_max,		$ max
      22	q1_min,		$ min
      23	q1_mod,		$ //
      24	q1_mult,	$ *
      25	q1_ne,		$ /=
      26	q1_notin,	$ notin
      27	q1_npow,	$ npow
      28	q1_atan2,	$ atan2
      29	q1_slash,	$ /
      30	q1_sub,		$ -
      31	q1_with,	$ with
      32$
      33$ unary operators -  of form a1 := op a2 except where noted
      34$
      35	q1_abs,		$ abs
      36	q1_char,	$ char
      37	q1_ceil,	$ ceiling
      38	q1_floor,	$ floor
      39	q1_isint,	$ is_integer
      40	q1_isreal,	$ is_real
      41	q1_isstr,	$ is_string
      42	q1_isbool,	$ is_boolean
      43	q1_isatom,	$ is_atom
      44	q1_istup,	$ is_tuple
      45	q1_isset,	$ is_set
      46	q1_ismap,	$ is_map
      47	q1_arb,		$ arb
      48	q1_val,		$ val
      49	q1_dom,		$ domain
      50	q1_fix,		$ fix
      51	q1_float,	$ float
      52	q1_nelt,	$ #
      53	q1_not,		$ not
      54	q1_pow,		$ pow
      55	q1_rand,	$ random
      56	q1_sin,		$ sin
      57	q1_cos,		$ cos
      58	q1_tan,		$ tan
      59	q1_arcsin,	$ asin
      60	q1_arccos,	$ acos
      61	q1_arctan,	$ atan
      62	q1_tanh,	$ tanh
      63	q1_expf,	$ exp
      64	q1_log,		$ log
      65	q1_sqrt,	$ sqrt
      66	q1_range,	$ range
      67	q1_type,	$ type
      68	q1_umin,	$ unary minus
      69	q1_even,	$ even
      70	q1_odd,		$ odd
      71	q1_str,		$ str
      72	q1_sign,	$ sign
      73$
      74$ miscellaneous
      75$
      76	q1_end,		$ a1 := a2(a3..)
      77	q1_subst,	$ a1 := a2(a3..a4)
      78	q1_newat,	$ a1 := newat
      79	q1_time,	$ a1 := time
      80	q1_date,	$ a1 := date
      81	q1_na,		$ a1 := number of arguments of current routine
      82	q1_set,		$ enumerative set former
      83	q1_set1,	$ iterative set former
      84	q1_tup,		$ enumerative tuple former
      85	q1_tup1,	$ iterative tuple former
      86	q1_from,	$ a1 from a2;
      87	q1_fromb,	$ a1 fromb a2
      88	q1_frome,	$ a1 frome a2
      89$
      90$ iterators
      91$
      92	q1_next,	$ a1 := next element of a3
      93	q1_nextd,	$ a1 := next element of domain a3
      94	q1_inext,	$ initialize next loop
      95	q1_inextd,	$ initialize nextd loop
      96$
      97$ mappings
      98$
      99	q1_of,		$ a1 := a2(a3)
     100	q1_ofa,		$ a1 := a2<>
     101
     102	q1_sof,		$ a1(a2) := a3
     103	q1_sofa,	$ a1<> := a3
     104	q1_send,	$ a1(a2..) := a3
     105	q1_ssubst,	$ a1(a2..a3) := a4
     106$
     107$ assignments - all assign a2 to a1
     108$
     109	q1_asn,		$ a1 := a2
     110
     111$ argument passage - a1 is argument, a2 is routine, a3 is argument no.
     112
     113	q1_argin,	$ assign argument to formal parameter
     114	q1_argout,	$ assignment back to argument
     115
     116	q1_push,	$ push element for set former
     117	q1_free,	$ free stack space after call
     118$
     119$ control statements
     120$
     121	q1_call,	$ call a1.  a2 is number of arguments
     122	q1_goto,	$ goto a1
     123
     124	q1_if,		$ if a1 then goto a2
     125	q1_ifnot,	$ if not a1 then goto a2
smfg   1	q1_bif,		$ if a1 then goto a2 (a1 is boolean)
smfg   2	q1_bifnot,	$ if not a1 then goto a2 (a1 is boolean)
smfg   3	q1_ifasrt,	$ if getipp('assert=1/2') = 0 then goto a1
     126	q1_case,	$ t := a1(a2); if t = om then goto a3
     127	q1_stop,	$ stop
     128
     129	q1_entry,	$ procedure entry point.  a1 is the routine
     130	q1_exit,	$ routine exit.  a1 is the routine name
     131
     132	q1_ok,		$ ok
     133	q1_lev,		$ get ok level
     134	q1_fail,	$ fail
     135	q1_succeed,	$ succeed
     136
     137	q1_asrt,	$ if not a1 then error; end;
     138	q1_stmt,	$ indicates start of new statement
     139	q1_label,	$ 'a1:' defines label a1
     140	q1_tag,		$ label for case tag
     141	q1_debug,	$ debugging request
     142	q1_trace,	$ trace request
     143	q1_notrace,	$ cancel trace request
     144	q1_error,	$ compile time error
     145	q1_noop,	$ indicates dead instruction
     146$
     147$ auxiliary operations for external procedure simulation
     148$
     149	q1_ifrand,	$ if random go to a1
     150	q1_use,		$ most general use of a1
     151	q1_def,		$ most general definition of a1
smfg   4	q1_isom,	$ argument is omega
smfg   5	q1_notom,	$ argument is not omega
     152	q1_arbb,	$ arb to simulate q1_fromb
     153	q1_arbe,	$ arb to simulate q1_frome
     154	q1_lessb,	$ less to simulate q1_fromb
     155	q1_lesse,	$ less to simulate q1_frome
     156	q1_sargin,	$ argin for system routine call
     157	q1_sargout 	$ argout for system routine call
     158    endm;
     159
     160
     161
     162    macro ops_classes;	$ collection of operator classes
     163	ops_typeback,   $  - backwards type propagation is meaningful
     164	ops_exps,	$  - operators yielding valid expressions
     165	ops_modify,	$  - operators which modify program variables
     166	ops_extract,	$  - extractions
     167	ops_retrieve,	$  - retrievals
     168	ops_update,	$  - updates
     169	ops_sin,	$  - sinister assignments
     170	ops_bin,	$  - binary operators
     171	ops_un,		$  - unary operators
     172	ops_goto,	$  - all branches
     173	ops_iter,       $  - iterators
smfe   1	ops_typepred,	$  - type predicates
     174	ops_ovar,       $  - operators with o-variables
     175	ops_ivar,       $  - operators with arg1 an i-variable
     176	ops_destuse1,	$  - first i-variable is used destructively
     177	ops_destuse3,	$  - third i-variable is used destructively
     178	ops_destuse4,	$  - fourth i-variable is used destructively
     179        ops_share1,	$  - first argument becomes shared
     180	ops_share2,	$  - second argument becomes shared
     181	ops_share3,	$  - third argument becomes shared
     182	ops_share4,	$  - fourth argument becomes shared
     183        ops_smap,	$  - operators modifying maps leaving it s-maps
     184	ops_local,	$  - operators supporting local basing
     185	ops_sparse,	$  - operators supporting sparse representation
     186	ops_nonewval,	$  - operators which only transmit values
     187	ops_fold,       $  - constant folding possible
     188	ops_arith       $  - arithmetic operations
     189    endm;
     190
     191
     192    macro q1_vars;	$ variables which define q1
     193	symbol_table,	$  - all symbol table maps
     194	sym_om,		$  - symtab pointer for omega
     195	sym_sys,	$  - symtab pointer for system scope
     196	sym_dir,	$  - symtab pointer for directory scope
     197	sym_prog,	$  - symtab pointer for program scope (member)
     198	sym_main,	$  - symtab pointer for main program (routine)
     199	form_table,	$  - all form table maps
     200	std_form,	$  - maps basic forms to their form table entry
     201	system_routs,	$  - set of all system-defined routines
     202	sc_maps,	$  - all maps defined for scopes
     203	rout_maps,	$  - all maps defined for routines
     204	block_maps,	$  - all maps defined for blocks
     205	inst_maps	$  - all maps defined for instructions
     206    endm;
     207
     208
     209    macro q1_consts;	$ related constants
     210	sc_types,	$  - scope types: range values for sc_type
     211	tup_sc_types,	$  - ...
     212	ft_types,	$  - form types: range values for ft_type
     213	tup_ft_types,	$  - ...
     214	ft_mapcs,	$  - map types: range values for ft_mapc
     215	tup_ft_mapcs,	$  - ...
     216	ft_predicates,	$  - form table predicates is_fint, etc.
     217	simple_type,	$  - maps specific form types into classes
     218	opcodes,	$  - range values for opcode
     219	tup_opcodes,	$  - ...
     220	copy_actions,	$  - range values for copy_flag
     221	tup_copy_actions,  $ ...
     222	ops_classes	$  - collection of operator classes
     223    endm;
     224
     225
       1 .=member flow3e
       2 .title 'control graph and interval analysis'
       3
       4$ control graph and interval analysis
       5$ -----------------------------------
       6
       7$ one of the first steps of the optimizer is the construction of the
       8$ 'control graph'.  this graph consists of two maps on basic blocks:
       9$
      10$ after we build the control graph we divide the program into regions
      11$ known as intervals.  each interval corresponds to a loop in the
      12$ program.
      13$
      14$ each time we construct an interval we add a new basic block called
      15$ the interval's 'target block'.  when we move code out of an interval,
      16$ we move it to the interval's target block.
      17$
      18$ intervals are identified by their target block.
      19$
      20$ note that we do not build the derived graphs explicitly.  instead,
      21$ every time we build an interval we add a series of edges from the
      22$ interval's target block to the interval's successors.  these edges are
      23$ called virtual edges since they do not correspond to actual program
      24$ paths.  we also add edges from the interval's predecessors to its
      25$ target block, which replace corresponding edges entering the
      26$ interval's head, and we also add an edge linking the target block to
      27$ the head.  all these edges, however, are real and indicate actual
      28$ execution branchings.
      29$
      30$ the following maps and sets are used in connection with interval
      31$ analysis.
      32$
      33$ intof:	maps each block into its interval
      34$
      35$ int_nodes:	maps each interval into a tuple containing the nodes of
      36$		the interval in reverse postorder.  iterating over
      37$		int_nodes(i) is equivalent to iterating forward over the
      38$		nodes in i.
      39$
      40$ ints:		maps each routine 'r' into a tuple containing all the
      41$		intervals in 'r' in reverse preorder.  iterating
      42$		backwards (forward) over this tuple is equivalent to
      43$		iterating over the intervals of 'r' from outermost to
      44$		innermost (innermost to outermost).
      45$
      46$ proper_ints:	set of all proper intervals
      47$
      48$ vedges:	the set of all virtual edges
      49
      50    macro intv_maps;
      51	intof,
      52	int_nodes,
      53	ints,
      54	proper_ints,
      55	vedges
      56    endm;
      57
      58$ the following macro maps each interval into its head:
      59    macro int_head(i);	int_nodes(i)(1)				endm;
      60
      61
      62 .title 'data flow maps'
      63
      64$ data flow maps
      65$ --------------
      66
      67$ data flow analysis produces to maps on occurrences, called bfrom and
      68$ ffrom, and a set of occurrences called bfrom_dead.  before discussing
      69$ these sets, we give the following definition:
      70$
      71$ an x-clear path is a path through the program which is free of
      72$ occurrences of 'x'.
      73$
      74$ we now define the results of data flow:
      75$
      76$ 1. bfrom:
      77$
      78$    let 'i' be a use of 'x'.  then bfrom{i} is the set of occurrences
      79$    'oi' of 'x' such that there is an x-clear path from oi to i.
      80$
      81$ 2. ffrom:
      82$
      83$    this is the inverse of bfrom.
      84$
      85$ 3. bfrom_dead:
      86$
      87$    this is the set of all occurrences 'oi' of 'x' such that there is
      88$    an x-clear path from 'oi' to either a stop instruction (or an exit
      89$    instruction in the case of local variables) or a redefinition of
      90$    'x'.
      91
      92
      93$ the live analysis routine will compute another global map, known as
      94$ 'liveat', which maps each basic block to the set of all variables live
      95$ at its start.
      96
      97
      98 .title 'the call graph'
      99
     100$ the call graph
     101$ --------------
     102
     103$ the call graph is represented by the following maps:
     104$
     105$ cgraph:	this is the actual call graph.  it is a set of pairs
     106$		[ p, q ] where p and q are procedures and p contains
     107$		a call to q.
     108$
     109$ callsin:	maps each procedure to the set of all calls within it.
     110$
     111$ callproc:	maps each call block to the procedure it calls.
     112$
     113$ the call graph analysis will analyze cgraph and produce the following
     114$ objects:
     115$
     116$ cg_sccs:	a tuple of all strongly-connected components of the call
     117$		graph arranged in their reverse postorder.
     118$
     119$ scc_nodes:	maps each s.c.c s to the tuple of all its nodes in their
     120$		reverse postorder.
     121$
     122$ scc_d:	maps each s.c.c. s to the number of back-edge target
     123$		nodes in s.
     124$
     125$ note that a procedure p is (co-)recursive iff it belongs to a
     126$ s.c.c. s for which scc_d(s) > 0.
     127
     128    macro call_maps;
     129	cgraph,
     130	callsin,
     131	callproc,
     132	cg_sccs,
     133	scc_nodes,
     134	scc_d
     135    endm;
     136
     137
       1 .=member typs3f
       2 .title 'types'
       3
       4$ types
       5$ -----
       6
       7$ the typefinder produces a map 'typ' which sends each occurrence
       8$ into a tuple with the following fields:
       9$
      10$ 1. grosstyp
      11$
      12$    a set of strings indicating all possible 'real types' an
      13$    occurrence might take on.
      14$
      15$    the 'real type' of an occurrence is a string such as 'int'
      16$    or 'real' which we might get by applying the setl 'type'
      17$    operator to the occurence. the possible real types are:
      18$    'int', 'real', 'string', 'atom', 'tuple', and 'set'.
      19$
      20$    during automatic data structure choice we make use of additional
      21$    descriptors whose grosstyps are 'base' and 'elmt'.
      22$
      23$ 2. is_knt
      24$
      25$    a flag which is 1 for known length tuples and om otherwise.
      26$
      27$ 3. comptyp
      28$
      29$    this field contains information on the component
      30$    types of sets and tuples. it is interpreted in one of two
      31$    ways depending on the value of 'is_knt'.
      32$
      33$    is_knt = 1:  comptyp is a tuple whose i-th component is a
      34$	          type descriptor for the i-th component type.
      35$
      36$    is_knt = om: comptyp is the component type of the set or tuple.
      37$
      38$    the type finder exports three predicates for making the above
      39$    tests. these predicates are called is_null, is_pair, and is_map.
      40$    like the is_om field they have values of yes, no, and maybe.
      41$
      42$ at the end of the algorithm the type of each ovariable is a function
      43$ of the instruction which defines it, while the type of each ivariable
      44$ is a function of its use and the definitions and uses of all
      45$ occurrences it is linked to.
      46$
      47$ we may wind up with two occurrences 'o' and 'i' which are linked by
      48$ bfrom but have different types.  this means that the code generator
      49$ must insert a conversion along the path from 'o' to 'i'.  the type
      50$ finde checks whether such a conversion would be legal, and gives an
      51$ error message if it would not.
      52$
      53$ the typefinder ignores reprs supplied by the user.
      54$$$    ****** not consistent
      55$ the user supplied reprs are validated later on by the
      56$$$ ???? this not consistent with remark made elsewhere
      57$ automatic data structure choice algorithm.
      58$
      59$ note that union types are very often overestimates.  for example, the
      60$ union of 'set(int)' and 'tuple(string)' is 'set or tuple of int or
      61$ string'.
      62
      63
      64$ macros for fields of type descriptors
      65$ -------------------------------------
      66
      67$ the following macros are used to access parts of a type descriptor.
      68$ note that the 'comptyp' macro allows for two possibilities:
      69$
      70$ 1. the type descriptor is 'general'.  return general.
      71$ 2. otherwise return the second component of the type descriptor.
      72
      73    macro grosstyp(t);  t(1)					endm;
      74
      75    macro comptyp(t);
      76	(if t = type_gen or t = type_zero then t else t(2) end)
      77    endm;
      78
      79    macro is_knt(t);    t(3)					endm;
      80    macro is_om(t);	(t_om in grosstyp(t))			endm;
      81    macro is_notom(t);	(t_om notin grosstyp(t))		endm;
      82    macro is_based(t);	(t(4) = based)				endm;
      83    macro set_type(t);	t(5)					endm;
      84    macro map_type(t);	t(6)					endm;
      85
      86$ domtyp and rangetyp can be used on map types to retrive the domain and
      87$ range type descriptor, respectively.  we access the component type  (a
      88$ known-length tuple), its component type (a tuple of types of the known
      89$ length tuple), and then the first or second components are the desired
      90$ types.
      91
      92    macro domtyp(t);	t(2)(2)(1)				endm;
      93    macro rangetyp(t);	t(2)(2)(2)				endm;
      94
      95$ ctypn is used to retrieve the type descriptor of the i'th component of
      96$ a known-length tuple.
      97
      98    macro ctypn(t, i);	t(2)(i)					endm;
      99
     100$ test if grosstype is primitive, i.e. int, real, string, or atom.
     101
     102    macro is_prim(g);	(t_set notin g and t_tuple notin g)	endm;
     103
     104    macro is_const_int(oi);	$ test for integer constant
     105	(is_const(oi_sym(oi)) = 1 and t_int in grosstyp(typ(oi)))
     106    endm;
     107
     108    macro t_types;
     109	t_om,
     110	t_int,
     111	t_real,
     112	t_string,
     113	t_atom,
     114	t_elmt,
     115	t_error,
     116	t_tuple,
     117	t_set,
     118	t_map
     119    endm;
     120
     121    macro based_modes;
     122	locl,
     123	remt,
     124	sprse,
     125	neutrl
     126    endm;
     127
     128    macro typ_consts;	$ all constants for the type finder
     129	no, maybe, yes, max_depth, max_len,
     130	t_types, bsctyps, gross_types,
     131	type_int, type_real, type_string, type_boolean,
     132	type_atom, type_zero, type_gen, type_om, type_notom,
     133	type_tuple, type_pair, type_set, type_map,
     134	int_real, int_real_str, int_real_str_atom,
     135	str_tup, str_tup_set, set_tup, tup_set_map,
     136	type_int_real, type_int_real_str, type_str_tup,
     137	type_str_tup_set,
     138        ft_usetmaps, localtp, remotetp,
     139	based_modes,
     140	fixed_typ
     141    endm;
     142
     143
     144    macro ads_maps;
     145	oi_repr,
     146	actual_bases,
     147	elmt_mode,
     148	bscope,
     149	userbase
     150    endm;
     151
     152
       1 .=member frms3g
       2 .title 'forms'
       3
       4$ forms
       5$ -----
       6
       7$ a 'form' is a complete description of how an object is represented
       8$ at run time.
       9$
      10$ forms are treated as atoms on which various maps are defined.  if f1
      11$ and f2 are forms then f1 = f2 if and only if f(f1) = f(f2) for all 'f'
      12$ defined on forms.
      13$
      14$ at the beginning of the typefinder phase we extract information from
      15$ the 'form' map and build a map from 'occurrences' to 'types'.
      16$ a 'type' is a somewhat simplified description of how objects are
      17$ represented.
      18$
      19$ during the name splitting phase we rebuild formtab.  when we do this
      20$$$ ???? expand this point
      21$ we preserve its unique invertibility.
      22$
      23$ the following maps are defined on forms:
      24$
      25$ ft_type:	a string f_xxx giving the basic type
      26$
      27$ ft_mapc:	a string ft_xxx indicating whether a map is stored as a
      28$		map, smap, or mmap.
      29$
      30$ ft_elmt:	gives the form of the elements of sets, maps, and
      31$		tuples.  in the case of procedures, this gives the form
      32$		of the procedure parameters.
      33$
      34$ note that the form of the return-value of the procedure (if any) can
      35$ be found by first retrieving the return value symbol as the first
      36$ component in the value of the procedure, and then obtain its form.
      37$
      38$ ft_dom:	gives the form of the domain elements of a map.
      39$
      40$ ft_im:	gives f{x} for mmaps and f(x) for maps and smaps.
      41$
      42$ ft_imset	gives f{x} for maps: always 'sparse set(ft_im)'.
      43$
      44$ ft_base:	gives the form of the base 'b' in 'elmt b',
      45$		local set(elmt b) and remote set(elmt b).
      46$
      47$ ft_low:	the lower limit for a short integer.
      48$
      49$ ft_lim:	this field gives various kinds of range information
      50$		depending on the value of ft_type:
      51$
      52$		mixed tuples:
      53$
      54$		for mixed tuples, ft_lim gives the number of component
      55$		types.
      56$
      57$		homogeneous tuples:
      58$
      59$		ft_lim indicates the minumum number of components we
      60$		should allocate when we build the tuple.  suppose 't' is
      61$		a tuple which is usually indexed with values <= 5.  then
      62$		it is useful to allocate 't' with 5 components so that
      63$		a large number of range checks can be suppressed.  we
      64$		indicate this by setting ft_lim = 5.
      65$
      66$		procedures and user defined operators:
      67$
      68$		ft_lim is one more than the number of arguments
      69$
      70$		integers:
      71$
      72$		if ft_lim is non-zero it indicates the maximum value
      73$		which can be stored in the integer.
      74$
      75$ ft_tup:	this field is used only for remote maps.
      76$		a 'remote map(elmt b) mode' is represented using a tuple
      77$		whose type is 'tuple(mode)'.  ft_tup gives the form of
      78$		the tuple.
      79$
      80$ ft_hashok:	this is a flag indicating that the hash code of a set or
      81$		tuple should be maintained at run time.
      82$
      83$ ft_neltok:	this is a flag indicating that the cardinality of a set
      84$		or tuple should be maintained at run time.
      85$
      86$ ft_pos:	gives the position in the base element-block of a local
      87$		object, relative to the origin of all similarly repred
      88$		local objects of that base
      89$
      90$ ft_num:	maps each base and locally-repred form to the number of
      91$		such repred objects
      92$
      93$ ft_deref:	pointer to the form after dereferencing it
      94
      95
      96    macro form_table;
      97	ft_type,
      98	ft_mapc,
      99	ft_elmt,
     100	ft_dom,
     101	ft_im,
     102	ft_imset,
     103	ft_base,
     104	ft_low,
     105	ft_lim,
     106	ft_tup,
     107	ft_hashok,
     108	ft_neltok,
     109	ft_pos,
     110	ft_num,
     111	ft_deref,	$ dereferenced form
     112	next_form,	$ maps each form to the next form in formtab
     113	basesymb	$ maps each base form to its symtab entry
     114    endm;
     115$
     116$ the ft_type codes are:
     117$
     118    macro ft_types;
     119	f_gen,		$ general
     120	f_sint,		$ short int
     121	f_sstring,	$ short string
     122	f_atom,		$ short atom
     123	f_latom,	$ long atom
     124	f_elmt,		$ element
     125	f_uint,		$ untyped int
     126	f_ureal,	$ untyped real
     127	f_int,		$ long or short integer
     128	f_string,	$ long or short chars
     129	f_real,		$ real
     130	f_ituple,	$ integer tuple
     131	f_rtuple,	$ real tuple
     132	f_ptuple,	$ packed tuple
     133	f_tuple,	$ std. tuple
     134	f_mtuple,	$ mixed tuple
     135	f_uset,		$ standard set
     136	f_lset,		$ local subset
     137	f_rset,		$ remote subset
     138	f_umap,		$ standard map
     139	f_lmap,		$ local map
     140	f_rmap,		$ remote map
     141	f_limap,	$ local integer map
     142	f_lrmap,	$ local real map
     143	f_lpmap,	$ local packed map
     144	f_rimap,	$ remote integer map
     145	f_rrmap,	$ remote real map
     146	f_rpmap,	$ remote packed map
     147	f_base,		$ base
     148	f_pbase,	$ plex base
     149	f_uimap,	$ unbased untyped integer map
     150	f_urmap,	$ unbased untyped real map
     151	f_error,	$ error
     152	f_proc,		$ procedure or operator
     153	f_memb,		$ member
     154	f_lab		$ label
     155    endm;
     156$
     157$ the various map cases are:
     158$
     159    macro ft_mapcs;
     160	ft_map,		$ map
     161	ft_smap,	$ smap
     162	ft_mmap		$ mmap
     163    endm;
     164$
     165$ we provide the following predicates on forms:
     166$
     167$ is_fint:	true for typed and untyped integers
     168$ is_freal:	true for typed and untyped reals
     169$ is_funt:	true for untyped integers and reals
     170$ is_fnum:	true for typed and untyped integers and reals
     171$ is_fstring:	true for short and long strings
     172$ is_fprim:	true for primitive types
     173$ is_ftup:	true for tuples
     174$ is_fset:	true for sets, maps, and bases
     175$ is_fmap:	true for maps
     176$ is_floc:	true for local sets and maps
     177$ is_frem:	true for remote sets and maps
     178$ is_fbased:	true for based types, bases, and long atoms
     179$ is_fimap:	true for untyped integer maps
     180$ is_frmap:	true for untyped real maps
     181$ is_fbase:	true for bases and plex bases
     182$
     183    macro is_fint(fm);		(ft_type(fm) in ft_fint)	endm;
     184    macro is_freal(fm);		(ft_type(fm) in ft_freal)	endm;
     185    macro is_funt(fm);		(ft_type(fm) in ft_funt)	endm;
     186    macro is_fnum(fm);		(ft_type(fm) in ft_fnum)	endm;
     187    macro is_fstring(fm);	(ft_type(fm) in ft_fstring)	endm;
     188    macro is_fprim(fm);		(ft_type(fm) in ft_fprim)	endm;
     189    macro is_ftup(fm);		(ft_type(fm) in ft_ftup)	endm;
     190    macro is_fset(fm);		(ft_type(fm) in ft_fset)	endm;
     191    macro is_fmap(fm);		(ft_type(fm) in ft_fmap)	endm;
     192    macro is_floc(fm);		(ft_type(fm) in ft_floc)	endm;
     193    macro is_frem(fm);		(ft_type(fm) in ft_frem)	endm;
     194    macro is_fbased(fm);	(ft_type(fm) in ft_fbased)	endm;
     195    macro is_fimap(fm);		(ft_type(fm) in ft_fimap)	endm;
     196    macro is_frmap(fm);		(ft_type(fm) in ft_frmap)	endm;
     197    macro is_fbase(fm);		(ft_type(fm) in ft_fbase)	endm;
     198
     199
     200    macro ft_predicates;
     201	ft_fint, ft_freal, ft_funt, ft_fnum, ft_fstring, ft_fprim,
     202	ft_ftup, ft_fset, ft_fmap, ft_floc, ft_frem, ft_fbased,
     203	ft_fimap, ft_frmap, ft_fbase
     204    endm;
     205
     206
       1 .=member imps3i
       2 .title 'various initial maps'
       3
       4$ various initial maps
       5$ --------------------
       6
       7$ during the initial code scanning phase (phase 1 below), we
       8$ build up varrious maps required by subsequent optimization
       9$ phases. these maps are:
      10
      11    macro var_maps;
      12	variables,	$ set of all program variables
      13	uservars,	$ set of all variables appearing in the source
smfe   2	itervars,	$ set of all internal iterator variables
      14	globalvars,	$ set of all global variables
      15	localvars,	$ maps each routine to its local variables
      16	occsof		$ maps each variable to all its occurrences
      17    endm;
      18
      19    macro exp_maps;
      20	globalexps,	$ set of all expressions which depend on
      21			$ at least one global variable
      22	localexps,	$ maps each routine to the set of its strictly
      23			$ local expressions
      24	allexps,	$ set of all expresions appearing in the program
      25	opcexp,		$ maps each expression to the opcode defining it
      26	argsexp,	$ maps each expression to the tuple of its input
      27			$ arguments
      28	dependon	$ maps each variable to the set of all expres-
      29			$ sions which explicitly depend on it
      30    endm;
      31
      32
       1 .=member cpar3j
       2 .title 'control parameters'
       3
       4$ control parameters
       5$ ------------------
       6
       7$ the following variables are read from the control card:
       8$
       9$ default value   variable set  meaning
      10$ -------------   ------------  -------
      11$
      12$ rem=1/1         rem           run time error mode
      13$ db=/sfci        dump_string   first initial of each table to be dumped
      14$
      15$				a: available expression module
      16$				b: bfrom module
      17$				c: code after preliminary pass,
      18$					conversion analysis
      19$				d: data structure module
      20$					x: base merging phase
      21$					y: base adjustment phase
      22$				e: execution statistics
      23$				f: form table
      24$				i: intervals after find_ints
      25$				s: symbol table
      26$				t: type finder module
      27$
      28$ full=0/1			extended debugging diagnostic
      29$ summary=/all			print final summary
      30$
      31$ note that code motion can be performed only if the run time error mode
      32$ is 0 or 1.  any other value indicates that  errors  detected  in  code
      33$ moved out of loops will cause a run time abort.
      34
      35    macro control_params;
      36	q1_file,
      37	ssm_file,	$ cstmt_count -> setl source line
      38	term_file,
      39	prog_level,
      40	debug_flag,	$ perform error testing
      41	at_flag,	$ automatic titling
smfk   1	lcp_flag,	$ listing control:  program parameters
smfk   2	lcs_flag,	$ listing control:  program statistics
      42	rem,		$ run-time error mode
      43	dump_string
      44    endm;
      45
      46    macro utilities;
      47	add_sym(rd),                $ add symbol
      48	del_sym(rd, rd, rd),        $ delete symbol
      49	add_var(rd),                $ add variable
      50	add_int(rd, rd),            $ add integer constant
      51	add_label(rd),              $ add label
      52	add_form(rd),               $ add form
      53	add_block(rd, rd, rd),	    $ add block to scope
      54	add_inst(rd, rd, rd(*)),    $ add instruction
      55	insert_ins(rw, rd, rd(*)),  $ insert instruction after i
      56        insert_ins1(rw, rd, rd),    $ insert with tuple of args
      57	del_block(rd, rd, rd),      $ delete block from routine
      58	del_inst(rw, rd, rd)	    $ delete instruction from block
      59    endm;
      60
      61
      62    macro print_utils;
      63	ermsg(rd),              $ print error message
      64	abort(rd),              $ print error message and abort
      65	prints(rd, rd),         $ print sorted map
      66	format_type(rd),	$ format type descriptor into a string
      67	format_repr(rd),	$ format repr descriptor into a string
      68	format_form(rd),	$ format form table entry into string
      69	format_inst(rd, rd)	$ format instruction into source string
      70    endm;
      71
       1 .=member decls4
       2
       3    directory setl_optimizer;
       4
       5    var
       6	sc_maps,	$ maps on scopes
       7	block_maps,	$ maps on blocks
       8	inst_maps;	$ maps on instructions
       9
      10    const
      11	copy_actions,	$ copy actions for instructions
      12	base_copy_actions   = { copy_actions },
      13	tup_copy_actions    = [ copy_actions ],
      14	sc_types,	$ scope types
      15	base_sc_types	    = { sc_types },
      16	tup_sc_types	    = [ sc_types ];
      17
      18    var
      19	system_routs,	$ set of all system routines (like read, print,
      20			$ etc.) called by the program being analysed.
      21	rout_maps,	$ maps on routines
      22	symbol_table,	$ q1 symbol table maps
      23	sym_om,		$  - symtab pointer for omega
      24	sym_sys,	$  - symtab pointer for system scope
      25	sym_dir,	$  - symtab pointer for directory scope
      26	sym_prog,	$  - symtab pointer for program scope (member)
      27	sym_main;	$  - symtab pointer for main program (routine)
      28
      29    var
      30	all_modules;	$ set of all modules and program declared
      31			$ in a directory
      32
      33    const
      34	opcodes,
      35	base_opcodes = { opcodes },
      36	tup_opcodes  = [ opcodes ],
      37
      38	ops_exps =	$ operations yielding valid expressions
      39	    { q1_in,     q1_notin,  q1_incs,
      40	      q1_eq,     q1_ne,     q1_lt,     q1_ge,
smfh   2	      q1_pos,
      41	      q1_add,    q1_sub,    q1_mult,   q1_slash,
      42	      q1_div,    q1_mod,    q1_exp,    q1_atan2,
      43	      q1_max,    q1_min,    q1_npow,
      44	      q1_not,    q1_even,   q1_odd,
      45	      q1_isint,  q1_isreal, q1_isstr,  q1_isbool,
      46	      q1_isatom, q1_istup,  q1_isset,  q1_ismap,
      47	      q1_dom,    q1_range,  q1_pow,    q1_nelt,
      48	      q1_abs,    q1_char,   q1_ceil,   q1_floor,
      49	      q1_fix,    q1_float,  q1_sin,    q1_cos,
      50	      q1_tan,    q1_arcsin, q1_arccos, q1_arctan,
      51	      q1_tanh,   q1_expf,   q1_log,    q1_sqrt,
      52	      q1_sign,   q1_type,   q1_str,    q1_val,
      53	      q1_umin,
      54	      q1_of,     q1_ofa,    q1_subst,  q1_end,
      55	      q1_set,    q1_tup },
      56
      57	ops_modify =	$ operations which can modify program variables
      58	    { q1_with,
      59	      q1_less,   q1_lessb,  q1_lesse,  q1_lessf,
      60	      q1_arb,    q1_arbb,   q1_arbe,   q1_rand,
      61	      q1_newat,  q1_time,   q1_date,   q1_na,
      62	      q1_set1,   q1_tup1,
      63	      q1_inext,  q1_next,   q1_inextd, q1_nextd,
      64	      q1_sof,    q1_sofa,   q1_ssubst, q1_send,
      65              q1_def,
      66	      q1_asn,    q1_argin,  q1_argout, q1_sargout },
      67
      68	ops_extract =	$ extractions
      69	    { q1_from,   q1_rand,
      70	      q1_arb,    q1_arbb,   q1_arbe,
      71	      q1_next,   q1_nextd,  q1_inext,  q1_inextd },
      72
      73	ops_retrieve =	$ retrievals
      74	    { q1_of,     q1_ofa,    q1_end,    q1_subst },
      75
      76	ops_update =	$ updates
      77	    { q1_add,    q1_sub,    q1_mult,
      78	      q1_with,   q1_less,   q1_lesse,  q1_lessb,
      79	      q1_from,   q1_fromb,  q1_frome,  q1_lessf },
      80
      81	ops_sin =	$ sinister assignments
      82	    { q1_sof,    q1_sofa,   q1_ssubst, q1_send },
      83
      84	ops_bin =	$ binary operations
      85	    { q1_in,     q1_notin,  q1_incs,
      86	      q1_eq,     q1_ne,     q1_lt,     q1_ge,
smfh   3	      q1_pos,
      87	      q1_add,    q1_sub,    q1_mult,   q1_slash,
      88	      q1_div,    q1_mod,    q1_exp,    q1_atan2,
      89	      q1_max,    q1_min,    q1_npow,   q1_with,
      90	      q1_less,   q1_lessb,  q1_lesse,  q1_lessf },
      91
      92	ops_un =	$ unary operators
      93	    { q1_not,    q1_even,   q1_odd,
      94	      q1_isint,  q1_isreal, q1_isstr,  q1_isbool,
      95	      q1_isatom, q1_istup,  q1_isset,  q1_ismap,
      96	      q1_arb,    q1_arbb,   q1_arbe,
      97	      q1_dom,    q1_range,  q1_pow,    q1_nelt,
      98	      q1_abs,    q1_char,   q1_ceil,   q1_floor,
      99	      q1_fix,    q1_float,  q1_sin,    q1_cos,
     100	      q1_tan,    q1_arcsin, q1_arccos, q1_arctan,
     101	      q1_tanh,   q1_expf,   q1_log,    q1_sqrt,
     102	      q1_sign,   q1_type,   q1_str,    q1_val,
     103	      q1_umin,   q1_rand },
     104
     105	ops_goto =	$ all branches
     106	    { q1_goto,   q1_case,
smfg   6	      q1_if,     q1_ifnot,  q1_bif,    q1_bifnot,
smfg   7	      q1_ifasrt, q1_ifrand },
     108
     109	ops_ovar =	$ operations with o-variables
     110	    { q1_in,     q1_notin,  q1_incs,
     111	      q1_eq,     q1_ne,     q1_lt,     q1_ge,
smfh   4	      q1_pos,
     112	      q1_add,    q1_sub,    q1_mult,   q1_slash,
     113	      q1_div,    q1_mod,    q1_exp,    q1_atan2,
     114	      q1_max,    q1_min,    q1_npow,
     115	      q1_from,   q1_fromb,  q1_frome,  q1_with,
     116	      q1_less,   q1_lessb,  q1_lesse,  q1_lessf,
     117	      q1_not,    q1_even,   q1_odd,
     118	      q1_isint,  q1_isreal, q1_isstr,  q1_isbool,
     119	      q1_isatom, q1_istup,  q1_isset,  q1_ismap,
     120	      q1_arb,    q1_arbb,   q1_arbe,
     121	      q1_dom,    q1_range,  q1_pow,    q1_nelt,
     122	      q1_abs,    q1_char,   q1_ceil,   q1_floor,
     123	      q1_fix,    q1_float,  q1_sin,    q1_cos,
     124	      q1_tan,    q1_arcsin, q1_arccos, q1_arctan,
     125	      q1_tanh,   q1_expf,   q1_log,    q1_sqrt,
     126	      q1_sign,   q1_type,   q1_str,    q1_val,
     127	      q1_umin,   q1_rand,
     128	      q1_newat,  q1_time,   q1_date,   q1_na,
     129	      q1_set,    q1_set1,   q1_tup,    q1_tup1,
     130	      q1_inext,  q1_next,   q1_inextd, q1_nextd,
     131	      q1_of,     q1_ofa,    q1_subst,  q1_end,
     132	      q1_sof,    q1_sofa,   q1_ssubst, q1_send,
     133	      q1_def,
     134	      q1_asn,    q1_argin,  q1_argout, q1_sargout },
     135
     136	ops_ivar =	$ operations whose arg1's are i-variables
     137	    { q1_push,   q1_free,   q1_use,    q1_sargin,
smfg   8	      q1_if,     q1_ifnot,  q1_bif,    q1_bifnot,
smfg   9	      q1_case,   q1_asrt,   q1_isom,   q1_notom },
     139
     140	ops_iter =	$ iterators
     141	    { q1_inext,  q1_next,   q1_inextd, q1_nextd },
smfe   3
smfe   4	ops_typepred =	$ type predicates
smfe   5	    { q1_isint,  q1_isreal, q1_isstr,  q1_isbool,
smfe   6	      q1_isatom, q1_istup,  q1_isset,  q1_ismap },
     142
     143	ops_typeback  = $ operators for which backwards type propagation
     144			$ is meaningful.
     145	    { q1_in,     q1_notin,  q1_incs,
smfh   5	      q1_lt,     q1_ge,     q1_pos,
     147	      q1_add,    q1_sub,    q1_mult,   q1_slash,
     148	      q1_div,    q1_mod,    q1_exp,    q1_atan2,
     149	      q1_max,    q1_min,    q1_npow,   q1_with,
     150	      q1_less,   q1_lessb,  q1_lesse,  q1_lessf,
     151	      q1_not,    q1_even,   q1_odd,
smfe   7	      q1_isint,  q1_isreal, q1_isstr,  q1_isbool,
smfe   8	      q1_isatom, q1_istup,  q1_isset,  q1_ismap,
     152	      q1_arb,    q1_arbb,   q1_arbe,
     153	      q1_dom,    q1_range,  q1_pow,    q1_nelt,
     154	      q1_abs,    q1_char,   q1_ceil,   q1_floor,
     155	      q1_fix,    q1_float,  q1_sin,    q1_cos,
     156	      q1_tan,    q1_arcsin, q1_arccos, q1_arctan,
     157	      q1_tanh,   q1_expf,   q1_log,    q1_sqrt,
smfe   9	      q1_sign,   q1_type,   q1_str,    q1_val,
smfe  10	      q1_umin,   q1_rand,
     159	      q1_set,    q1_set1,   q1_tup,    q1_tup1,
     160	      q1_inext,  q1_next,   q1_inextd, q1_nextd,
     161	      q1_of,     q1_ofa,    q1_subst,  q1_end,
     162	      q1_sof,    q1_sofa,   q1_ssubst, q1_send,
     163	      q1_argin,  q1_argout, q1_sargin,
smfg  10	      q1_if,     q1_ifnot,  q1_bif,    q1_bifnot,
smfg  11	      q1_asn,    q1_asrt,   q1_isom,   q1_notom },
     165
     166	ops_destuse1 =  $ ops whose first ivar is used destructively
     167	    { q1_add,    q1_sub,    q1_mult,   q1_with,
     168	      q1_less,   q1_lessb,  q1_lesse,  q1_lessf },
     169
     170	ops_destuse3 =  $ same for third ivar
     171	    { q1_next,   q1_sof,    q1_sofa,   q1_send },
     172
     173	ops_destuse4 =  $ same for fourth ivar
     174	    { q1_ssubst },
     175
     176        ops_share1 =    $ ops that share their first argument
     177            { q1_of,     q1_push,   q1_asn,    q1_next,
     178              q1_arb,    q1_nextd,  q1_ofa,
     179	      q1_argin,  q1_argout },
     180
     181        ops_share2 =    $ second argument
     182            { q1_argin,  q1_asn },
     183
     184        ops_share3 =    $ third argument
     185            { q1_with,   q1_sof,    q1_sofa },
     186
     187	ops_share4 =	$ forth argument
     188	    { q1_argout },
     189
     190        ops_smap =	$ ops modifying a map leaving it a smap
     191            { q1_sof },
     192
     193        ops_local =	$ ops supporting local representation
     194            { q1_in,     q1_notin,  q1_less,   q1_lessf,
     195              q1_with,   q1_of,     q1_ofa,    q1_sof,
     196              q1_sofa },
     197
     198        ops_sparse =	$ ops supporting sparse repr (no hashing)
     199            { q1_npow,   q1_arb,    q1_from,   q1_dom,
     200              q1_range,  q1_nelt,   q1_pow,    q1_rand,
     201              q1_next,   q1_inext,  q1_nextd,  q1_inextd,
     202              q1_asn,    q1_argin,  q1_sargin, q1_sargout,
     203              q1_argout },
     204
     205	ops_nonewval =	$ ops with ovar that only transmit values
     206	    { q1_from,   q1_fromb,  q1_frome,
     207	      q1_arb,    q1_arbb,   q1_arbe,
     208	      q1_of,     q1_ofa,
     209	      q1_asn,    q1_argin,  q1_argout },
     210
     211	ops_fold =	$ operations which can be constant folded
     214	    { q1_in,     q1_notin,  q1_incs,
     215	      q1_eq,     q1_ne,     q1_lt,     q1_ge,
smfh   6	      q1_pos,
     216	      q1_add,    q1_sub,    q1_mult,   q1_slash,
     217	      q1_div,    q1_mod,    q1_exp,    q1_atan2,
     218	      q1_max,    q1_min,    q1_npow,   q1_with,
     219	      q1_less,   q1_lessb,  q1_lesse,  q1_lessf,
     220	      q1_not,    q1_even,   q1_odd,
     221	      q1_isint,  q1_isreal, q1_isstr,  q1_isbool,
     222	      q1_isatom, q1_istup,  q1_isset,  q1_ismap,
     223	      q1_dom,    q1_range,  q1_pow,    q1_nelt,
     224	      q1_abs,    q1_char,   q1_ceil,   q1_floor,
     225	      q1_fix,    q1_float,  q1_sin,    q1_cos,
     226	      q1_tan,    q1_arcsin, q1_arccos, q1_arctan,
     227	      q1_tanh,   q1_expf,   q1_log,    q1_sqrt,
     228	      q1_sign,   q1_type,   q1_str,    q1_val,
     229	      q1_umin,
     230	      q1_of,     q1_ofa,    q1_subst,  q1_end,
     231	      q1_sof,    q1_sofa,   q1_ssubst, q1_send,
smfb   1	      q1_asn,    q1_argin,  q1_argout },
     233
     234	ops_arith =	$ arithmetical operations
     235	    { q1_add,    q1_sub,    q1_mult,   q1_slash,
     236	      q1_div,    q1_mod,    q1_exp,
     237	      q1_max,    q1_min };
     238
     239
     240    var cessor,		$ maps each block into its successors
     241	pred;		$ maps each block into its predecessors
     242
     243    var intv_maps;	$ maps on intervals
     244
     245    var ocrs_maps,	$ maps on occurrences
     246	oi_sets;	$ sets on occurrences
     247
     248    var bfrom,		$ maps each occurrence to previous ones
     249	ffrom,		$ maps each occurrence to subsequent ones
     250	bfrom_dead;	$ set of occurrences that can be dead on a path
     251
     252    var call_maps;	$ maps on call instructions
     253
     254    var fom_syms, xom_syms,
     255	fom_ocrs, xom_ocrs;
     256
     257    var dead_labs;	$ labels of blocks being deleted
     258    var	cut_blocks;	$ blocks bypassed by short_cut
     259
     260    var typ;
     261
     262    const
     263	no = om,
     264	maybe = 1,
     265	yes = 1;
     266
     267    const
     268        max_depth = 06,         $ max nesting depth for type descriptors
     269	max_len   = 06;		$ maximum length for known-length tuples
     270
     271    const
     272	t_om		= 'om',
smfc   1	t_int		= 'integer',
     274	t_real		= 'real',
     275	t_string	= 'string',
     276	t_atom		= 'atom',
     277	t_elmt		= 'elmt',
     278	t_error		= 'error',
     279	t_tuple		= 'tuple',
     280	t_set		= 'set',
     281	t_map		= 'map',
     282	gross_types	= { t_types };
     283
     284    const
     285	bsctyps	= { t_om,     t_int,    t_real,	t_string, t_atom,
     286		    t_tuple,  t_set };
     287
     288    const
     289	type_zero	= [ {}					    ],
     290	type_om		= [ { t_om }				    ],
     291	type_gen	= [ bsctyps,	    type_zero,	    false   ],
     292
     293	type_notom	= [ { t_int,    t_real,   t_string,
     294			      t_atom,   t_tuple,  t_set     },
     295					    type_gen,	    false   ],
     296
     297	type_int	= [ { t_int }				    ],
     298	type_real	= [ { t_real }				    ],
     299	type_string	= [ { t_string }			    ],
     300	type_boolean	= [ { t_atom }				    ],
     301	type_atom	= [ { t_atom }				    ],
     302
     303	type_tuple	= [ { t_tuple },    type_gen,	    false   ],
     304	type_pair	= [ { t_tuple },    [ type_notom,
     305					      type_notom ], true    ],
     306
     307	type_set	= [ { t_set },	    type_gen,	    false   ],
     308	type_map	= [ { t_set },	    type_pair,	    false   ];
     309
     310    const
     311	int_real          = { t_int, t_real },
     312	int_real_str      = { t_int, t_real, t_string },
     313	int_real_str_atom = { t_int, t_real, t_string, t_atom },
     314	str_tup           = { t_string, t_tuple },
     315	str_tup_set       = { t_string, t_tuple, t_set },
     316	set_tup           = { t_tuple, t_set },
     317	tup_set_map       = { t_tuple, t_set, t_map };
     318
     319    const
     320	type_int_real	  = [ int_real				    ],
     321	type_int_real_str = [ int_real_str			    ],
     322	type_str_tup	  = [ str_tup,	    type_gen,	    false   ],
     323	type_str_tup_set  = [ str_tup_set,  type_gen,	    false   ];
     324$
     325$ the following constant map sends opcodes with a fixed output type to
     326$ to that type:
     327$
     328    const
     329	fixed_typ =
     330	    { [ q1_eq,       type_boolean ],
     331	      [ q1_ne,       type_boolean ],
     332	      [ q1_isint,    type_boolean ],
     333	      [ q1_isreal,   type_boolean ],
     334	      [ q1_isstr,    type_boolean ],
     335	      [ q1_isbool,   type_boolean ],
     336	      [ q1_isatom,   type_boolean ],
     337	      [ q1_istup,    type_boolean ],
     338	      [ q1_isset,    type_boolean ],
     339	      [ q1_ismap,    type_boolean ],
     340	      [ q1_type,     type_string  ],
     341	      [ q1_str,      type_string  ],
     342	      [ q1_date,     type_string  ],
     343	      [ q1_time,     type_int     ],
     344	      [ q1_na,       type_int     ],
     345	      [ q1_newat,    type_atom    ] };
     346
     347    const
     348	based_modes,
     349	base_based_modes = { based_modes };
     350
     351    var ads_maps;
     352
     353    var form_table;
     354
     355    const
     356	ft_types,
     357	base_ft_types = { ft_types },
     358	tup_ft_types  = [ ft_types ],
     359	ft_mapcs,
     360	base_ft_mapcs = { ft_mapcs },
     361	tup_ft_mapcs  = [ ft_mapcs ];
     362
     363
     364$ the variable 'std_form' maps the basic types 'f_xxx' into their
     365$ forms.  it is built when the q1 tables are read in.
     366$$$ ???? logic here unclear, needs careful check
     367
     368    var std_form;
     369
     370$ the following constant map is used to obtain the
     371$ type class of each of the above 'f_xxx' form types
     372    const
     373	simple_type =
     374	    { [  f_gen,      'gen'     ],
     375	      [  f_sint,     'int'     ],
     376	      [  f_sstring,  'string'  ],
     377	      [  f_atom,     'atom'    ],
     378	      [  f_latom,    'atom'    ],
     379	      [  f_elmt,     'elmt'    ],
     380	      [  f_uint,     'int'     ],
     381	      [  f_ureal,    'real'    ],
     382	      [  f_int,      'int'     ],
     383	      [  f_string,   'string'  ],
     384	      [  f_real,     'real'    ],
     385	      [  f_ituple,   'tuple'   ],
     386	      [  f_rtuple,   'tuple'   ],
     387	      [  f_ptuple,   'tuple'   ],
     388	      [  f_tuple,    'tuple'   ],
     389	      [  f_mtuple,   'tuple'   ],
     390	      [  f_uset,     'set'     ],
     391	      [  f_lset,     'set'     ],
     392	      [  f_rset,     'set'     ],
     393	      [  f_umap,     'map'     ],
     394	      [  f_lmap,     'map'     ],
     395	      [  f_rmap,     'map'     ],
     396	      [  f_lpmap,    'map'     ],
     397	      [  f_limap,    'map'     ],
     398	      [  f_lrmap,    'map'     ],
     399	      [  f_rpmap,    'map'     ],
     400	      [  f_rimap,    'map'     ],
     401	      [  f_rrmap,    'map'     ],
     402	      [  f_base,     'base'    ],
     403	      [  f_pbase,    'base'    ],
     404	      [  f_uimap,    'map'     ],
     405	      [  f_urmap,    'map'     ],
     406	      [  f_error,    'error'   ],
     407	      [  f_proc,     'proc'    ],
     408	      [  f_memb,     'memb'    ],
     409	      [  f_lab,      'lab'     ] };
     410
     411
     412    const
     413	ft_fint     = { f_sint,    f_uint,    f_int                 },
     414	ft_freal    = { f_ureal,   f_real                           },
     415	ft_funt     = { f_uint,    f_ureal                          },
     416	ft_fnum     = { f_sint,    f_uint,    f_int,
     417			f_ureal,   f_real                           },
     418	ft_fstring  = { f_sstring, f_string                         },
     419	ft_fprim    = { f_sint,    f_sstring, f_atom,    f_uint,
     420			f_ureal,   f_int,     f_string,  f_real     },
     421	ft_ftup     = { f_tuple,   f_ituple,  f_rtuple,  f_ptuple,
     422			f_mtuple                                    },
     423	ft_fset     = { f_uset,    f_lset,    f_rset,
     424			f_umap,    f_uimap,   f_urmap,
     425			f_lmap,    f_limap,   f_lrmap,   f_lpmap,
     426			f_rmap,    f_rimap,   f_rrmap,   f_rpmap,
     427			f_base,    f_pbase                          },
     428	ft_fmap     = { f_umap,    f_uimap,   f_urmap,
     429			f_lmap,    f_limap,   f_lrmap,   f_lpmap,
     430			f_rmap,    f_rimap,   f_rrmap,   f_rpmap    },
     431	ft_floc     = { f_lset,
     432			f_lmap,    f_limap,   f_lrmap,   f_lpmap    },
     433	ft_frem     = { f_rset,
     434			f_rmap,    f_rimap,   f_rrmap,   f_rpmap    },
     435	ft_fbased   = { f_elmt,    f_lset,    f_rset,
     436			f_lmap,    f_limap,   f_lrmap,   f_lpmap,
     437			f_rmap,    f_rimap,   f_rrmap,   f_rpmap    },
     438	ft_fimap    = { f_limap,   f_rimap,   f_uimap               },
     439	ft_frmap    = { f_lrmap,   f_rrmap,   f_urmap               },
     440	ft_fbase    = { f_base,    f_pbase                          };
     441
     442
     443    const
     444        ft_usetmaps =
     445            { f_uset, f_umap, f_uimap, f_urmap };
     446
     447    const
     448        localtp =
     449            { [ f_uset,  f_lset  ],
     450              [ f_umap,  f_lmap  ],
     451              [ f_uimap, f_limap ],
     452              [ f_urmap, f_lrmap ] };
     453
     454    const
     455        remotetp =
     456            { [ f_uset,  f_rset  ],
     457              [ f_umap,  f_rmap  ],
     458              [ f_uimap, f_rimap ],
     459              [ f_urmap, f_rrmap ] };
     460
     461    var push_former;   $ maps each push instruction to the set or
     462		       $ tuple former following it.
     463
     464    var
     465	var_maps,		$ maps on variables
     466	exp_maps,		$ maps on expressions
     467	control_params;		$ program parameters
     468    var statistics;		$ used to collect execution statistics
     469$
     470$ the following global objects are used for program annotation purposes.
     471$ we annotate each program analysed in the following manner:
     472$
     473$ 1. for each routine p, we print a  summary  of  all  global  variables
     474$    referenced or defined, formatted as reads/writes lists.
     475$
     476$ 2. for each routine p, we print a summary of all routines q which  are
     477$    called from p, formatted as an imports list.  (this information  is
     478$    contained in the call graph.)
     479$
     480$ 3. for each destructive use du of a global variable x in a routine  p,
     481$    we print warning message.
     482$
     483    var
     484	globals_du,	$ routine -> destructive use occurrence
smfk   3	globals_e,	$ maps routines to globals exposed
     485	globals_r,	$ maps routines to globals used
     486	globals_w,	$ maps routines to globals defined
     487	messages;	$ cstmt_count -> severity -> message
     488
     489
     490$
     491$ initialise the maps in the setl data structures to the null set.
     492$
     493    init
     494	$ initilise symbol table maps
     495	name := {},         value := {},        scope := {},
     496	form := {},         alias := {},
     497	is_read := {},      is_write := {},     is_const := {},
     498	is_internal := {},  is_temp := {},      is_store := {},
     499	is_stk := {},       is_param := {},     is_repr := {},
     500	is_init := {},      is_seen := {},      is_back := {},
     501	is_rec := {},       next_sym := {},
     502
     503	$ initialise form maps
     504	ft_type := {},      ft_mapc := {},      ft_elmt := {},
     505	ft_dom := {},       ft_im := {},        ft_imset := {},
     506	ft_base := {},
     507	ft_low := {},       ft_lim := {},       ft_tup := {},
     508	ft_hashok := {},    ft_neltok := {},    ft_pos := {},
     509	ft_num := {},       ft_deref := {},     next_form := {},
     510	basesymb := {},     std_form := {},
     511
     512	$ initialise scope maps
     513	scopes := [],       cont_scopes := {},
     514	sc_type := {},      sc_nprocs := {},
     515	sc_stmt_ct := {},   sc_estmt_ct := {},
     516	first_sym := {},    last_sym := {},
     517	first_form := {},   last_form := {},
     518	first_block := {},  last_block := {},
     519	all_modules := {},
     520
     521	$ initialise routine maps
     522	routs := {},        rentry := {},       rexit := {},
     523	rstop := {},        rparams := {},      system_routs := {},
     524	membof := {},
     525
     526	$ initialise interval maps
     527	ints := {},         proper_ints := {},
     528
     529	$ initialise block maps
     530	routof := {},       next_block := {},   first_inst := {},
     531	last_inst := {},    cessor := {},       pred := {},
     532	intof := {},        int_nodes := {},    vedges := {},
     533	cut_blocks := {},   dead_labs := {},
     534
     535	$ initialise instruction maps
     536	opcode := {},       args := {},         occs := {},
     537	blockof := {},      stmtof := {},       copy_flag := {},
     538	share_flag := {},   next_inst := {},
     539
     540	$ initialise maps on call instructions
     541	cgraph := {},       callsin := {},      callproc := {},
     542	cg_sccs := [],      scc_nodes := {},    scc_d := {},
     543
     544	$ initilise maps on occurrences
     545	instno := {},       argno := {},
     546	all_oi := {},       all_o := {},        all_i := {},
     547
     548	$ initialise maps on variables
smfe  11	variables := {},    uservars := {},     itervars := {},
smfe  12	globalvars := {},   localvars := {},    occsof := {},
     551
     552	$ initilise maps on expressions
     553	globalexps := {},   localexps := {},    allexps := {},
     554	opcexp := {},       argsexp := {},      dependon := {},
     555
     556	$ initialise maps for automatic documentation
smfk   4	globals_du := {},   globals_e := {},    globals_r := {},
smfk   5	globals_w := {},
smfk   6
     558	messages := {},
     560	statistics := [],
     561	push_former := {};
     562
     563
       1 .=member mman5a
       2 .title 'module specifications'
       3
       4$ overall design of the optimizer
       5$ -------------------------------
       6
       7$ in this section we describe the overall organization of the optimizer.
       8$ the optimizer contains one top level routine for each section; these
       9$ routines are called in sequence from the main program.
      10
      11$ in describing each section, we concentrate on the following points:
      12
      13$ 1. the general purpose of the section
      14$ 2. the algorithm used
      15$ 3. the principal routines contained in the section
      16$ 4. the tables produced as output of the section
      17$ 5. the diagnostics, warnings, etc. issued to the user.
      18
      19
      20 .title 'main program'
      21
      22$ main program
      23$ ------------
      24
      25$ the main program simply calls successive phases of the optimizer
      26$ till the program converges.
      27
      28    program setl_optimizer - main:
      29
      30	imports
      31	    opt_ini,		$ initialize
      32	    cgraph_analysis,	$ call graph analysis
      33	    find_intervals,	$ interval analysis
      34	    live,		$ live variable analysis
      35	    csx,		$ common subexpr elimination+code motion
      36	    find_bfrom,		$ bfrom computation
smfb   2	    find_region_constants,  $ flow-constant loop analysis
      37	    type_find,		$ type analysis
      38	    auto_data,		$ automatic data structure selection
      39	    conv_optimize,	$ conversion optimization
      40	    copy_optimize,	$ copy optimization
      41	    opt_term;		$ print tables, etc.
      42
      43	writes
      44	    statistics;
      45
      46
       1 .=member mutl5b
       2 .title 'utilities'
       3
       4$ utilities
       5$ ---------
       6
       7    module setl_optimizer - util:
       8
       9	exports
      10	    print_utils,
      11	    utilities;
      12
      13	writes
      14	    oi_sets,		$ sets on occurrences
      15	    var_maps,		$ maps on variables
      16	    exp_maps,		$ maps on expressions
      17	    ocrs_maps,		$ maps defining occurrences
      18	    dead_labs,
      19	    q1_vars,		$ variables defining q1
      20	    messages;		$ cstmt_count -> severity -> message
      21
      22	reads
      23	    q1_consts, q1_vars,	$ constants and variables defining q1
      24	    typ_consts,		$ all constants for the type finder
      25	    cessor,
      26	    pred,
      27	    intv_maps;		$ maps on intervals
      28
      29
      30 .title 'compiler interface'
      31
      32$ compiler interface
      33$ ------------------
      34
      35$ the setl compiler is written in a low level language called 'little'.
      36$ the semantic pass writes the q1 tables onto a binary file, which is
      37$ then read in by the code generator.
      38
      39$ the interface module contains two main routines.  the first reads in
      40$ the file created by the semantic pass using the setl binary i/o, and
      41$ converts the q1 tables to setl data structures.  the second routine
      42$ converts the setl data structures back to little data structures and
      44$ writes them onto the q1 file.
      45
      46    module setl_optimizer - interface:
      47
      48	reads
      49	    q1_consts,		$ constants used to define q1
      50	    control_params;	$ program parameters
      51
      52	writes
      53	    all_modules,
      54	    ocrs_maps,		$ maps defining occurrences
      55	    q1_vars;		$ variables defining q1
      56
      57	exports
      58	    read_q1,
      59	    write_q1;
      60
      61	imports
      62	    can_conv(rd, rd),
      63	    utilities,
      64	    print_utils,
      65	    dmp(rd, rd(*));
      66
      67
      68    module setl_optimizer - dumps:
      69
      70	exports
      71	    dmp(rd, rd(*)),
      72	    print_summary(rd);	$ print scope summary
      73
      74	imports
      75	    print_utils;
      76
      77	reads
      78	    q1_consts,		$ constants used to define q1
      79	    q1_vars,		$ variables defining q1
      80	    var_maps,		$ maps on variables
      81	    all_modules,	$ set of all modules
smfk   7	    globals_e,		$ maps routines to globals exposed
      82	    globals_r,		$ maps routines to globals used
      83	    globals_w,		$ maps routines to globals defined
      84	    globals_du,		$ destructively used global variables
      85	    call_maps,		$ maps on the call graph
      86	    ocrs_maps,		$ maps defining occurrences
      87	    cessor,
smfk   8	    ffrom,
      88	    intv_maps;		$ maps on intervals
      89
      90
      91 .title 'initialization'
      92
      93$ phase 1. initialization
      94$ -----------------------
      95
      96$ in this phase we read the control card, read the q1 tables generated
      97$ by the semantic pass, and make a prepass over the program.
      99
     100$ the prepass does the following things:
     101
     102$ 1. modify the input so that it appears to be a complete program.
     103$ 2. compute the 'oi_sets' such as all_oi.
     104$ 3. fill in the fourth arguments of argin and argout instructions.
     105$ 4. replace each 'from' instruction with an 'arb' followed by a 'less'
     106$ 5. compute the 'var_maps', 'exp_maps' and some of the 'call_maps'
     107$    (see section on 'various initial maps' for details).
     108
     109$ steps (3) and (4) are reversed before the program is written out for
     110$ the code generator.
     111
     112    module setl_optimizer - optinit:
     114
     115	imports
     116	    print_utils,
     117	    read_q1,
     118	    dmp(rd, rd(*)),
     119	    utilities;
     120
     121	reads
     122	    q1_consts;		$ constants used to define q1
     123
     124	writes
     125	    control_params,	$ program parameters
     126	    q1_vars,		$ variables defining q1
     127	    all_modules,
     128	    push_former,
     129	    cut_blocks,
     130	    var_maps,		$ maps on variables
     131	    exp_maps,		$ maps on expressions
     132	    ocrs_maps,		$ maps defining occurrences
     133	    call_maps,		$ maps on the call graph
     134	    oi_sets,		$ sets on occurrences
     135	    messages,		$ cstmt_count -> severity -> message
     136	    statistics;		$ used to collect execution statistics
     137$ note that these names are macros for groups of variables defined
     138$ above.
     139
     140	exports
     141	    opt_ini;
     142
     143
       1 .=member mcgr5c
       2 .title 'call graph analysis'
       3
       4$ phase 2. call graph analysis
       5$ ----------------------------
       6
       7$ this phase analyses the call graph and builds up some auxiliary
       8$ related maps. the relevant procedures are contained in the
       9$ 'dataflow_solver' module.  for details see the section 'data-flow
      10$ analysis package' below.
      11
       1 .=member mint5d
       2 .title 'interval analysis'
       3
       4$ phase 3. interval analysis
       5$ --------------------------
       6
       7$ interval analysis is performed using a variation of tarjans
       8$ algorithm.  the outputs of the algorithm are described in the
       9$ previous section, 'control graph and interval analysis'.
      10
      11
      13    module setl_optimizer - interval_analysis:
      14
      16	imports
      17	    dmp(rd, rd(*)),
      18	    print_utils,
      19	    utilities;
      20
      21	reads
      22	    control_params,	$ program parameters
      23	    q1_consts;		$ constants used to define q1
      24
      25	writes
      26	    q1_vars,		$ variables defining q1
      27	    dead_labs,
      28	    cut_blocks,
      29	    intv_maps,		$ maps on intervals
      30	    cessor,
      31	    pred,
      32	    statistics;		$ used to collect execution statistics
      33
      34	exports
      35	    find_intervals;
      36
      38
       1 .=member mcdm5e
       2 .title 'redundant expression elimination'
       3
       4$ phase 4. redundant expression elimination and code motion
       5$ ---------------------------------------------------------
       6
       7$ this phase finds redundant subexpressions using available
       8$ expression determination. it also moves code out of loops and
       9$ eliminates all redundant expression computations.
      10
      11$ the code motion procedure uses the interval structure to move code
      12$ out of intervals. each interval is entered through a block known
      13$ as the interval head; each interval head has a single predecessor
      14$ block which is outside the interval. this is known as the
      15$ target block of the interval. code moved out of an interval is
      16$ moved to the interval's target block. this is essentialy a
      17$ matter of concatenating the instruction to the target block.
      18
      19$ instructions are deleted either by changing their opcode to
      20$ 'q1_noop', or, more efficiently, when the previous instruction
      21$ is also available, by deleting them from the linked list of
      22$ their block.
      23
      24
      25    module setl_optimizer - availexp_analysis:
      26
      27	exports
      28	    csx;
      29
      30	imports
      31	    print_utils,
      32            utilities,
      33	    .comp_syms(rd, rd),
      34	    interproc_fwd_analysis_syms
      35		    (rw, wr, rd, rd, rd, rd, rw, wr, rd),
      36	    intraproc_fwd_analysis_syms
      37		    (rd, rw, wr, rd, rd, rd, rd, rw, wr, rd);
      38$ see the section 'data flow analysis package' below for details
      39$ concerning these routines.
      40
      41	reads
      42	    control_params,	$ program parameters
      43	    q1_consts,		$ constants used to define q1
      44	    call_maps,		$ maps on the call graph
      45	    intv_maps,		$ maps on intervals
      46	    cessor, pred;
      48
      49	writes
      50	    fom_syms, xom_syms,
      51	    oi_sets,		$ sets on occurrences
      52	    var_maps,		$ maps on variables
      53	    exp_maps,		$ maps on expressions
      54	    q1_vars,		$ variables defining q1
      55	    messages,		$ cstmt_count -> severity -> message
      56	    statistics;		$ used to collect execution statistics
      57
      58
       1 .=member mlva5f
       2 .title 'live variable analysis'
       3
       4    module setl_optimizer - live_analysis:
       5
       6	exports
       7	    live;
       8
       9	imports
      10	    utilities,
      11	    print_utils,
      12	    .comp_syms(rd, rd),
      13	    interproc_back_analysis_syms(rw, wr, rd, rd, rd),
      14	    intraproc_back_analysis_syms(rd, rw, wr, rd, rd, rd);
      15
      16	reads
      17	    all;
      18
      19	writes
      20	    fom_syms, xom_syms,
      21	    messages,		$ cstmt_count -> severity -> message
      22	    statistics;		$ used to collect execution statistics
      23
      24
       1 .=member dfap5g
       2 .title 'data-flow analysis package'
       3
       4$ data-flow analysis package
       5$ ---------------------------
       6
       7$ to facilitate several previously mentioned optimization phases, we
       8$ provide a general purpose package of routines which solve data flow
       9$ problems of the bitvectoring class under various situations (forward
      10$ or backward problems, interprocedural or intraprocedural solution).
      11$ this package also includes the call graph analysis routine mentioned
      12$ earlier.
      13$
      14$ nb.  there are actually two modules which are almost identical.
      15$ they differ in that the first module is used for problems where the
      16$ the lattice elements are symbols (elmt syms), while the second
      17$ module is used for problems where the lattice elements are oc-
      18$ currences (elmt ocrs).
      19$
      20    module setl_optimizer - dataflow_solver_syms:
      21
      22	imports
      23	    print_utils;
      24
      25	exports
      26	    .comp_syms(rd, rd),
      27	    cgraph_analysis,
      28$
      29$ the following routines perform data flow analysis for the
      30$ following respective cases: interprocedurally and forward,
      31$ intraprocedurally and forward, interprocedurally and backwards,
      32$ intraprocedurally and backwards.
      33$
      34	    interproc_fwd_analysis_syms
      35		    (rw, wr, rd, rd, rd, rd, rw, wr, rd),
      36	    intraproc_fwd_analysis_syms
      37		    (rd, rw, wr, rd, rd, rd, rd, rw, wr, rd),
      38$
      39$ the parameters of the interprocedural analyser are as follows:
      40$ f:            maps each flow edge into a data-flow map
      41$ soln:         the solution map (soln: flow node --> bitvector data)
      42$ id:           identity map for analysis
      43$ zero:         initial (default) data-value for analysis
      44$ meet_flag:    true if meet analysis, false if join analysis
      45$ move_code:    true if code motion required, false otherwise
      46$ exposed:      exposed block 'events' (needed only for code motion)
      47$ insert:       maps each interval to 'events' to be inserted at
      48$	        its entry (meaningless if code motion not required)
      49$
      50$ the intraprocedural analyser has the same parameters, with an
      51$ additional first parameter, equal to the procedure to be analysed
      52$
      53	    interproc_back_analysis_syms
      54		    (rw, wr, rd, rd, rd),
      55	    intraproc_back_analysis_syms
      56		    (rd, rw, wr, rd, rd, rd);
      57$
      58$ the parameters of the interprocedural analyser coincide with
      59$ the first five parameters of the corresponding forward analyser.
      60$ similar correspondence exists between the intraprocedural
      61$ analysers.
      62$
      63	reads
      64	    name,
      65	    fom_syms, xom_syms,
      66	    cessor, pred,
      67	    routof, sym_main,
      68	    rout_maps,
      69	    control_params;	$ program parameters
      70
      71	writes
      72	    is_rec,		$ flags recursive routines (symtab)
      73	    intv_maps,		$ maps on intervals
      74	    call_maps;		$ maps on the call graph
      75
      76
      77    module setl_optimizer - dataflow_solver_ocrs:
      78
      79	exports
      80	    .comp_ocrs(rd, rd),
      81	    interproc_fwd_analysis_ocrs
      82		    (rw, wr, rd, rd, rd, rd, rw, wr, rd),
      83	    intraproc_fwd_analysis_ocrs
      84		    (rd, rw, wr, rd, rd, rd, rd, rw, wr, rd),
      85	    interproc_back_analysis_ocrs
      86		    (rw, wr, rd, rd, rd),
      87	    intraproc_back_analysis_ocrs
      88		    (rd, rw, wr, rd, rd, rd);
      89
      90	reads
      91	    fom_ocrs, xom_ocrs,
      92	    cessor, pred,
      93	    routof, sym_main,
      94	    rout_maps,
      95	    call_maps;		$ maps on the call graph
      96
      97	writes
      98	    intv_maps;		$ maps on intervals
      99
     100
       1 .=member mflo5h
       2 .title 'data flow analysis'
       3
       4$ phase 5. data flow analysis
       5$ ---------------------------
       6
       7$ this phase builds bfrom, ffrom, and bfrom_dead.  these maps are
       8$ defined in the section 'data flow maps' above.
       9
      10
      11    module setl_optimizer - bfrom_analysis:
      12
      13	exports
      14	    find_bfrom;
      15
      16	imports
      17	    print_utils,
      18	    .comp_ocrs(rd, rd),
      19	    interproc_fwd_analysis_ocrs
      20		    (rw, wr, rd, rd, rd, rd, rw, wr, rd),
      21	    intraproc_fwd_analysis_ocrs
      22		    (rd, rw, wr, rd, rd, rd, rd, rw, wr, rd);
      23$ see description of 'data flow analysis package' above for
      24$ detailed account of parameters of these routines.
      25
      26	reads
      27	    var_maps,		$ maps on variables
      28	    q1_consts,		$ constants used to define q1
      29	    q1_vars,		$ variables defining q1
      30	    call_maps,		$ maps on the call graph
      31	    ocrs_maps,		$ maps defining occurrences
      32	    oi_sets,		$ sets on occurrences
      33	    intv_maps,		$ maps on intervals
      34	    cessor, pred,
      36	    control_params;	$ program parameters
      37
      38	writes
      39	    fom_ocrs, xom_ocrs,
      40	    bfrom, ffrom,
      42	    bfrom_dead,
smfk   9	    globals_e,		$ maps routines to globals exposed
      43	    globals_r,		$ maps routines to globals used
      44	    globals_w,		$ maps routines to globals defined
      45	    messages,		$ cstmt_count -> severity -> message
      46	    statistics;		$ used to collect execution statistics
      47
      48
smfb   3
smfb   4
smfb   5    module setl_optimizer - region_constants:
smfb   6
smfb   8	exports
smfb   9	    find_region_constants;
smfb  10	reads
smfb  11	    q1_consts,		$ constants used to define q1
smfb  12	    q1_vars,		$ variables defining q1
smfb  13	    var_maps,		$ maps on variables
smfb  14	    ocrs_maps,		$ maps defining occurrences
smfb  15	    oi_sets,		$ sets on occurrences
smfb  16	    bfrom,		$ occurrence -> preceding occurrences
smfb  17	    intv_maps,		$ maps on intervals
smfb  18	    call_maps,		$ maps on the call graph
smfb  19	    control_params;	$ program parameters
smfb  20	writes
smfb  21	    messages,		$ cstmt_count -> severity -> message
smfb  22	    statistics;		$ used to collect execution statistics
smfb  23
smfb  24
       1 .=member mtyp5i
       2 .title 'type finding'
       3
       4$ phase 8 - type finding
       5$ ----------------------
       6
       7$ this phase is an extension of the type finder described in a ph.d.
       8$ thesis by aaron tannenbaum.  it calculates a map called 'typ' which
       9$ sends each occurrence into a 'type descriptor'.  the structure of
      10$ type descriptors is described above in the section 'types'.
      11$
      12$ essentially the type finder collects two pieces of information
      13$ about each occuurrence:
      14$
      15$ 1. its type, in the sense of the setl 'type' operator.
      16$
      17$ 2. a flag indicating whether the occurrence is definitely omega,
      18$    possibly omega, or definitely not omega.
      19$
      20$ (1) and (2) are determined recursively for the components of sets and
      21$ tuples.
      22$
      23$ the type finder is driven by the bfrom and ffrom maps.  it exports
      24$ a main procedure and three predicates on types.  these predicates
      25$ use a three valued logic, and return values given by the constants
      26$ yes, no, and maybe.
      27
      28    module setl_optimizer - typfind:
      29
      30	reads
      31	    q1_consts,		$ constants used to define q1
      32	    q1_vars,		$ variables defining q1
      33	    ocrs_maps,		$ maps defining occurrences
      34	    oi_sets,		$ sets on occurrences
      35	    typ_consts,		$ all constants for the type finder
      36	    var_maps,		$ maps on variables
      37	    exp_maps,		$ maps on expressions
      38	    cessor, pred,
      39	    intv_maps,		$ maps on intervals
      40	    call_maps,		$ maps on the call graph
      41	    bfrom, ffrom, bfrom_dead,
      42	    control_params;	$ program parameters
      43
      44	writes
      45	    typ,		$ maps occurrences to their types
smfg  12	    bfrom, ffrom, bfrom_dead,
      46	    messages,		$ cstmt_count -> severity -> message
      47	    statistics;		$ used to collect execution statistics
      48
      49	imports
      50	    print_utils,
      51	    utilities;
      52
      53	exports
      54	    type_find,		$ top level routine
      55	    .is_pair(tp),	$ true for pairs
      56	    .is_map(tp);	$ true for maps
      57
       1 .=member adac5k
       2 .title 'automatic data structure selection'
       3
       4$ phase 10 - automatic data structure selection
       5$ ---------------------------------------------
       6
       7$ the automatic data structure selection algorithm, which  is  described
       8$ in detail in the member admn15 below, is driven by the data flow  maps
       9$ and the typ map, the result of the type finder module.
      10$
      11$ to allow for the results of the  automatic data  structure  selection,
      12$ we ultimately take three types of action:
      13$
      14$ 1. we add a new symbol table entry for each base.
      15$ 2. we build a map 'basetyp' from bases to type descriptors.
      16$ 3. we reset typ(oi) for each oi we decide to base.
      17
      18$ type descriptors for bases have:
      19$
      20$ grosstyp:	'base'
      21$ comptyp:	type of elements
      22$
      23$ type descriptors for elements have:
      24$
      25$ grosstyp:	'elmt'
      26$ comptyp:	not used
      27$ basenam:	symbol table pointer for base
      28$
      29$ type descriptors for primitive types (ie. integer, real,  string,  and
      30$ atom) have a grosstype of t_int, t_real, etc., and a component type of
      31$ type_zero, our error type.  non-primitive types (ie. tuple,  set,  and
      32$ map) have a grosstype of t_tuple, t_set, or t_map, and their component
      33$ type is itself a type descriptor for the component type of the  tuple,
      34$ the element type of the set, etc.  thus a type descriptor  for  a  map
      35$ from string to atom would have a component type of known-length  tuple
      36$ of length two, whose first component  must  be  a  string,  and  whose
      37$ second component must be an atom.
      38$
      39$ the automatic data-structure selection algorithm can take one  of  two
      40$ choices with respect to user-supplied reprs.  it is  not  clear  which
      41$ choice is correct:
      42$
      43$ 1. it can begin by using the user supplied reprs to refine and
      44$    validate the 'typ' map.
      45$
      46$ 2. it can ignore the user-supplied reprs until it is done, then use
      47$    them to refine and validate its results.
      48$
      49    module setl_optimizer - auto_dstruct:
      50
      51	exports
      52	    auto_data;
      54	imports
      55	    utilities,
      56	    print_utils,
      57	    .is_pair(tp),	$ true for pairs
      58	    .is_map(tp);	$ true for maps
      60	reads
      61	    q1_consts,		$ constants used to define q1
      62	    variables,		$ set of all variables
      63	    typ_consts,		$ all constants for the type finder
      64	    bfrom, ffrom, bfrom_dead,
      65	    ocrs_maps,		$ maps defining occurrences
      66	    oi_sets,		$ sets on occurrences
      67	    control_params;	$ program parameters
      69	writes
      70	    q1_vars,		$ variables defining q1
      71	    typ,		$ maps occurrences to their types
      72	    ads_maps,
      73	    statistics;		$ used to collect execution statistics
      74
      75
       1 .=member cnvo5l
       2 .title 'conversion optimization'
       3
       4$ phase 11 - conversion optimization
       5$ ----------------------------------
       6
       7$ conversion optimization completes the work begun with the type finding
       8$ and automatic data structure selection phases.
       9$
      10$ at this point the 'typ' map contains as much  information on  the type
      11$ and representation of each occurrence as we know how to collect.
      12$
      13$ we must now split each variable 'x' into several variables x1, ..., xn
      14$ such that each xi has the same 'typ' for all its occurrences.   in the
      15$ process it may be necessary  to add assignments of the form 'xi = xj'.
      16$ these assignments will actually be treated  as conversions by the code
      17$ generator.
      18$
      19$ once we have done name splitting we are able to talk about the type of
      20$ a variable 'xi'.  we then convert the xi's type descriptor into a form
      21$ and set form(xi).
      22$
      23$ then we perform a data  flow  analysis  to determine  when  and  where
      24$ should conversions from one split variable to another be performed.
      25
      26
      27    module setl_optimizer - conversion_analysis:
      28
      29	exports
      30	    conv_optimize,
      31	    can_conv(rd, rd);
      33	imports
      34	    utilities,
      35	    print_utils,
      36	    dmp(rd, rd(*)),
      37	    .comp_syms(rd, rd),
      38	    interproc_fwd_analysis_syms
      39		    (rw, wr, rd, rd, rd, rd, rw, wr, rd),
      40	    intraproc_fwd_analysis_syms
      41		    (rd, rw, wr, rd, rd, rd, rd, rw, wr, rd),
      42	    interproc_back_analysis_syms
      43		    (rw, wr, rd, rd, rd),
      44	    intraproc_back_analysis_syms
      45		    (rd, rw, wr, rd, rd, rd);
      47	reads
      48	    q1_consts,		$ constants used to define q1
      49	    var_maps,		$ maps on variables
      50	    ocrs_maps,		$ maps defining occurrences
      51	    intv_maps,		$ maps on intervals
      52	    typ_consts,		$ all constants for the type finder
      53	    control_params;	$ program parameters
      55	writes
      56	    fom_syms, xom_syms,
      57	    q1_vars,		$ variables defining q1
      58	    basesymb,
smfk  10	    occsof,		$ maps variables to their occurrences
      59	    variables,		$ set of all variables
      60	    uservars,		$ set of all user-defined variables
      61	    bfrom, ffrom, bfrom_dead,
      62	    typ,		$ maps occurrences to their type
      63	    ads_maps,
      64	    oi_sets,		$ sets on occurrences
      65	    messages,		$ cstmt_count -> severity -> message
      66	    statistics;		$ used to collect execution statistics
      67
       1 .=member mcpy5m
       2 .title 'copy optimisation'
       3
       4$ phase 9 - copy optimisation
       5$ ---------------------------
       6
       7$ copy optimisation is done using the technique described in
       8$ newsletter 176.  we associate a dummy share bit variable with
       9$ each variable in the program.  suppose that 'x' is a
      10$ variable and 'sx' is its shadow variable.
      11$
      12$ we assume that every operaton whch puts 'x' into a set or
      13$ tuple causes 'x' to be shared, i.e. causes its share bit to
      14$ be set to true.  we treat this as a definition of 'sx'.
      15$
      16$ we also assume that each time 'x' is used destructively it
      17$ is conditionally copied.  by this we mean that the library
      18$ checks x's share bit.  if the share bit is set, the library
      19$ copies 'x' and resets it's share bit to false.
      20$
      21$ the copy optimisation algorithm begins by indicating the
      22$ uses and definitions of the share bits 'sx'.  it then performs
      23$ code motion, redundant subexpression elimination, dead code
      24$ elimination and constant propagation on the shadow variables.
      25$
      26$ at the end of the algorithm we have filled in estimates concerning
      27$ uses and definitions of share bits.  we then create two maps on
      28$ instructions:
      29$
      30$ copy_flag:
      31$
      32$    if 'i' is an instruction, then copy_flag(i) has the
      33$    following values:
      34$
      35$    copy_pre:  copy arg1(i) before executing 'i'
      36$
      37$    copy_test: copy arg1(i) before executing 'i' iff its
      38$	        share bit is set.
      39$
      40$    copy_no:   don't copy arg1(i).
      41$
      42$    note that arg1 is the only argument which is ever used
      43$    destructively.
      44$
      45$ share_flag:
      46$
      47$    share_flag(i) is true if one of i's inputs must have
      48$    its share bit set. it is always obvious from the opcode of 'i'
      49$    which input we are talking about.
      50
      51    module setl_optimizer - copy_optimization:
      52
      53	exports
      54	    copy_optimize;
      55
      56	imports
      57	    utilities,
      58	    print_utils,
      59	    .comp_syms(rd, rd),
      60	    .comp_ocrs(rd, rd),
      61	    interproc_back_analysis_syms
      62		    (rw, wr, rd, rd, rd),
      63	    intraproc_back_analysis_syms
      64		    (rd, rw, wr, rd, rd, rd),
      65	    interproc_fwd_analysis_ocrs
      66		    (rw, wr, rd, rd, rd, rd, rw, wr, rd),
      67	    intraproc_fwd_analysis_ocrs
      68		    (rd, rw, wr, rd, rd, rd, rd, rw, wr, rd);
      69
      70	reads
      71	    q1_consts,		$ constants used to define q1
      72	    typ,		$ maps occurrences to their types
      73	    typ_consts,		$ all constants for the type finder
      74	    bfrom, ffrom,	$ data flow maps
      75	    var_maps,		$ maps on variables
      76	    ocrs_maps,		$ maps defining occurrences
      77	    oi_sets,		$ sets on occurrences
      78	    cessor,		$
      79	    control_params;	$ program parameters
      80
      81	writes
      82	    fom_syms, xom_syms,
      83	    fom_ocrs, xom_ocrs,
      84	    q1_vars,		$ variables defining q1
      85	    globals_du,		$ destructively used global variables
      86	    messages,		$ cstmt_count -> severity -> message
      87	    statistics;		$ used to collect execution statistics
      88
      89
       1 .=member outp5n
       2 .title 'interface with code generator'
       3
       4$ phase 13 - output to the code generator
       5$ --------------------------------------------
       6
       7$ this is the final phase of the optimizer. we do three things:
       8
       9$ 1. change all code sequences 'a := arb b; b less:= a;' to 'a from b'
      10$ 2. remove the fourth argument of all argin and argout instructions.
      11$ 3. write out the q1 tables.
      12
      13    module setl_optimizer - optend:
      15
      16	exports
      17	    opt_term;
      19	imports
      20	    utilities,
      21	    print_utils,
      22	    dmp(rd, rd(*)),
      23	    print_summary(rd),	$ print scope summary
      24	    write_q1;
      26	writes
      27	    q1_vars,		$ variables defining q1
      28	    statistics;		$ used to collect execution statistics
      30	reads
      31	    control_params,	$ program parameters
      32	    exp_maps,		$ maps on expressions
      33	    push_former,
      34	    dead_labs,
      35	    q1_consts,		$ constants used to define q1
      36	    messages;		$ cstmt_count -> severity -> message
      37
      38
       1 .=member reprs6
       2 .title 'reprs'
       3
       4$ data structures for global variables and procedures
       5$ --------------- --- ------ --------- --- ----------
       6
       7    repr
       8$
       9$ there are two  ways to  represent  booleans  in  setl,  namely as setl
      10$ booleans,  or as integers in the range from 1 to 1.   while the former
      11$ is  somewhat more elegant,  the latter requires, when packed, only one
      12$ bit of storage.   note that the range 'integer 1 .. 1' is dual-valued,
      13$ since this range implicitly includes om.   in this mode,  we represent
      14$ true as 1, and false as om.
      15$
      16	mode bool:		integer 1..1;
      17
      18	mode index:		integer 1..65535;
      19
      20
      21$$--	plex base syms;		$ symbol table
      22	plex base forms;	$ form table
      23	plex base blocks;	$ basic block table
      24	plex base insts;	$ instruction or code table
      25$$--	plex base ocrs;		$ symbol occurrences
      26
      27	base syms:		atom;
      28	mode symbol:		elmt syms;
      29
      30	base ocrs:		atom;
      31	mode occurrence:	elmt ocrs;
      32
      33	base df_base_ocrs:	occurrence;
      34	mode df_elmt_ocrs:	remote set(elmt df_base_ocrs);
      35	mode df_map_ocrs:	tuple(df_elmt_ocrs, df_elmt_ocrs);
      36
      37	base df_base_syms:	symbol;
      38	mode df_elmt_syms:	remote set(elmt df_base_syms);
      39	mode df_map_syms:	tuple(df_elmt_syms, df_elmt_syms);
      40
      41	base df_nodes:		elmt blocks;
      42	mode df_node:		elmt df_nodes;
      43
      44	base df_edges:		tuple(df_node, df_node);
      45	mode df_edge:		elmt df_edges;
      46
      47	base expressions:	symbol;
      48	mode expression:	elmt expressions;
      49$
      50$ there are several maps from scopes and routines defined.  for greater
      51$ space efficiency, we create bases for their domains, and base their
      52$ respective ranges locally on these two bases.
      53$
      54	base base_scopes:	symbol;
      55
      56	base base_routs:	elmt base_scopes;
      57	mode routine:		elmt base_routs;
      58
      59	base
      60	    base_sc_types,
      61	    base_ft_types,
      62	    base_ft_mapcs,
      63	    base_opcodes,
      64	    base_based_modes,
      65	    base_copy_actions:	string;
      66
      67	base tent_bases:	atom;
      68	mode tent_base:		elmt tent_bases;
      69
      70	base gross_types:	string;
      71	mode basic_type:	elmt gross_types;
      72	mode gross_type:	remote set(basic_type);
      73$
      74$ although there are no maps on types, or sets on types, we store all
      75$ type descriptors in a base.  this allows us to do fast type equality
      76$ tests.
      77$
      78	base types:		tuple(
      79				    gross_type,
      80				    general,
      81				    boolean,
      82				    *,		$$-- is_based
      83				    elmt base_based_modes,
      84				    elmt base_ft_mapcs
      85				    );
      86$
      87$ maps on symbols use the following data structures:
      88$ (see section symbol table for a more detailed account of these maps)
      89$
      90	name:			local smap(symbol) string;
      91	value:			local smap(symbol) general;
      92	scope:			local smap(symbol) elmt base_scopes;
      93	form:			local smap(symbol) elmt forms;
      94	alias:			local smap(symbol) symbol;
      95	is_read:		packed local smap(symbol) bool;
      96	is_write:		packed local smap(symbol) bool;
      97	is_const:		packed local smap(symbol) bool;
      98	is_internal:		packed local smap(symbol) bool;
      99	is_temp:		packed local smap(symbol) bool;
     100	is_store:		packed local smap(symbol) bool;
     101	is_stk:			packed local smap(symbol) bool;
     102	is_param:		packed local smap(symbol) bool;
     103	is_repr:		packed local smap(symbol) bool;
     104	is_init:		packed local smap(symbol) bool;
     105	is_seen:		packed local smap(symbol) bool;
     106	is_back:		packed local smap(symbol) bool;
     107	is_rec:			packed local smap(symbol) bool;
     108	next_sym:		local smap(symbol) symbol;
     109$
     110$ maps on scopes use the following data structures:
     111$ (see section 'scopes and routines' for a more detailed account of
     112$ these maps.)
     113$
     114	scopes:			tuple(elmt base_scopes);
     115	cont_scopes:		local smap(elmt base_scopes)
     116				    tuple(elmt base_scopes);
     117	sc_type:		local smap(elmt base_scopes)
     118				    elmt base_sc_types;
     119	sc_nprocs:		local smap(elmt base_scopes) integer;
     120	sc_stmt_ct:		local smap(elmt base_scopes) integer;
     121	sc_estmt_ct:		local smap(elmt base_scopes) integer;
     122	first_sym:		local smap(elmt base_scopes) symbol;
     123	last_sym:		local smap(elmt base_scopes) symbol;
     124	first_block:		local smap(routine) elmt blocks;
     125	last_block:		local smap(routine) elmt blocks;
     126	first_form:		local smap(elmt base_scopes) elmt forms;
     127	last_form:		local smap(elmt base_scopes) elmt forms;
     128	sc_types:		elmt base_sc_types;
     129	tup_sc_types:		tuple (elmt base_sc_types);
     130	sym_om:			symbol;
     131	sym_sys:		elmt base_scopes;
     132	sym_dir:		elmt base_scopes;
     133	sym_prog:		elmt base_scopes;
     134	sym_main:		routine;
     135	all_modules:		sparse set(elmt base_scopes);
     136$
     137$ maps on routines use the following data structures:
     138$ (see section 'scopes and routines' for a more detailed account of
     139$ these maps.)
     140$
     141	routs:			sparse set(routine);
     142	rentry:			local smap(routine) elmt blocks;
     143	rexit:			local smap(routine) elmt blocks;
     144	rstop:			local smap(routine) elmt blocks;
     145	rparams:		local smap(routine) tuple(symbol);
     146	membof:			local smap(routine) elmt base_scopes;
     147	system_routs:		sparse set(symbol);
     148$
     149$ maps on intervals use the following data structures:
     150$ see section 'data flow maps' for more details.
     151$
     152	ints:			local smap(routine) tuple(elmt blocks);
     153	proper_ints:		local set(elmt blocks);
     154$
     155$ there are several constants relating to forms.  they use the following
     156$ data structures:
     157$ (see section forms for further details.)
     158$
     159	ft_types:		elmt base_ft_types;
     160	tup_ft_types:		tuple(elmt base_ft_types);
     161	ft_mapcs:		elmt base_ft_mapcs;
     162	tup_ft_mapcs:		tuple(elmt base_ft_mapcs);
     163	std_form:		local smap(elmt base_ft_types)
     164				    elmt forms;
     165	ft_predicates:		local set(elmt base_ft_types);
     166$
     167$ maps on forms use the following data structures:
     168$ (see the section on forms for further details)
     169$
     170	ft_type:		packed local smap(elmt forms)
     171				    elmt base_ft_types;
     172	ft_mapc:		packed local smap(elmt forms)
     173				    elmt base_ft_mapcs;
     174	ft_elmt:		local smap(elmt forms) *;
     175	ft_dom:			local smap(elmt forms) elmt forms;
     176	ft_im:			local smap(elmt forms) elmt forms;
     177	ft_imset:		local smap(elmt forms) elmt forms;
     178	ft_base:		local smap(elmt forms) elmt forms;
     179	ft_low:			local smap(elmt forms) integer;
     180	ft_lim:			local smap(elmt forms) integer;
     181	ft_tup:			local smap(elmt forms) elmt forms;
     182	ft_hashok:		packed local smap(elmt forms) bool;
     183	ft_neltok:		packed local smap(elmt forms) bool;
     184	ft_pos:			local smap(elmt forms) integer;
     185	ft_num:			local smap(elmt forms)
     186$ nb. 'string' should be element of base of local types
     187				    smap(string) integer;
     188	ft_deref:		local smap(elmt forms) elmt forms;
     189	next_form:		local smap(elmt forms) elmt forms;
     190	basesymb:		sparse smap(elmt forms) symbol;
     191$
     192$ maps on blocks use the following data structures:
     193$ see section '...' for more details.
     194$
     195	routof:			local smap(elmt blocks) routine;
     196	next_block:		local smap(elmt blocks) elmt blocks;
     197	first_inst:		local smap(elmt blocks) elmt insts;
     198	last_inst:		local smap(elmt blocks) elmt insts;
     199	cessor:			local mmap(elmt blocks) elmt blocks;
     200	pred:			local mmap(elmt blocks) elmt blocks;
     201	intof:			local smap(elmt blocks) elmt blocks;
     202	int_nodes:		local smap(elmt blocks)
     203				    tuple(elmt blocks);
     204	vedges:			local mmap(elmt blocks) elmt blocks;
     205
     206	cut_blocks:		sparse set(elmt blocks);
     207	dead_labs:		sparse set(symbol);
     208$
     209$ there are various global collections defined on q1 opcodes.
     210$ the section q1 opcodes for more details.
     211$
     212	opcodes:		elmt base_opcodes;
     213	tup_opcodes:		tuple(elmt base_opcodes);
     214	copy_actions:		elmt base_copy_actions;
     215	tup_copy_actions:	tuple(elmt base_copy_actions);
     216	ops_classes:		local set(elmt base_opcodes);
     217$
     218$ maps on instructions use the following data structures:
     219$ (see section 'the program' for more details)
     220$
     221	opcode:			packed local smap(elmt insts)
     222				    elmt base_opcodes;
     223	args:			local smap(elmt insts) tuple(symbol);
     224	occs:			local smap(elmt insts)
     225				    tuple(occurrence);
     226	blockof:		local smap(elmt insts) elmt blocks;
     227	stmtof:			packed local smap(elmt insts) index;
     228	copy_flag:		packed local smap(elmt insts)
     229				    elmt base_copy_actions;
     230	share_flag:		packed local smap(elmt insts) bool;
     231	next_inst:		local smap(elmt insts) elmt insts;
     232$
     233$ maps on call instructions use the following data structures:
     234$ (see the section on the call graph for further details)
     235$
     236	cgraph:			sparse mmap(routine) routine;
     237	callsin:		local mmap(routine) elmt blocks;
     238	callproc:		sparse smap(elmt blocks) routine;
     239	cg_sccs:		tuple(routine);
     240	scc_nodes:		local smap(routine) tuple(routine);
     241	scc_d:			local smap(routine) integer;
     242$
     243$ sets of and maps on occurrences use the following data structures:
     244$ (see section 'occurrences' for further details)
     245$
     246	all_oi:			local set(occurrence);
     247	all_o:			local set(occurrence);
     248	all_i:			local set(occurrence);
     249
     250	typ:			remote smap(occurrence) elmt types;
     251
     252	t_types:		basic_type;
     253	bsctyps,
     254	int_real,
     255	int_real_str,
     256	int_real_str_atom,
     257	str_tup,
     258	str_tup_set,
     259	set_tup,
     260	tup_set_map:		gross_type;
     261	type_zero,
     262	type_om,
     263	type_gen,
     264	type_notom,
     265	type_int,
     266	type_real,
     267	type_string,
     268	type_boolean,
     269	type_atom,
     270	type_tuple,
     271	type_pair,
     272	type_set,
     273	type_map,
     274	type_int_real,
     275	type_int_real_str,
     276	type_str_tup,
     277	type_str_tup_set:	elmt types;
     278
     279	fixed_typ:		local smap(elmt base_opcodes)
     280				    elmt types;
     281	simple_type:		local smap(elmt base_ft_types) string;
     282					           $$$ ??? string ???
     283	ft_usetmaps:		local set(elmt base_ft_types);
     284        localtp, remotetp:	local smap(elmt base_ft_types)
     285				    elmt base_ft_types;
     286$
     287$ maps for the automatic data structure choice phase
     288$  (see section on types for declarations.)
     289$
     290	oi_repr:		remote smap(occurrence) elmt types;
     291	userbase:		remote smap(tent_base) symbol;
     292	actual_bases:		remote set(tent_base);
     293	bscope:			local smap(tent_base) elmt base_scopes;
     294	elmt_mode:		local smap(tent_base) elmt types;
     295$
     296$ maps on variables use the following data structures:
     297$ (see the section on various initial maps for further details)
     298$ (this section follows call paths)
     299$
     300	variables:		local set(symbol);
     301	uservars:		local set(symbol);
smfe  13	itervars:		local set(symbol);
     302	globalvars:		sparse set(symbol);
     303	localvars:		local mmap{routine}
     304				    sparse set(symbol);
     305	occsof:			local mmap{symbol}
     306				    sparse set(occurrence);
     307$
     308$ maps on expressions use the following data structures:
     309$ (see the section on various initial maps for further details)
     310$ (this section follows call paths)
     311$
     312	globalexps:		sparse set(expression);
     313	localexps:		local mmap{routine}
     314				    sparse set(expression);
     315	allexps:		local set(expression);
     316	opcexp:			local smap(expression)
     317				    elmt base_opcodes;
     318	argsexp:		local smap(expression) tuple(symbol);
     319	dependon:		sparse mmap{symbol}
     320				    sparse set(expression);
     321$
     322$ maps on occurrences use the following data structures:
     323$ (see the section on occurrences for further details)
     324$
     325	instno:			local smap(occurrence) elmt insts;
     326	argno:			packed local smap(occurrence) index;
     327$
     328$ data flow maps use the following data structures:
     329$ (see the section on data flow maps for further detail)
     330$
     331	bfrom:			local mmap{occurrence}
     332				    sparse set(occurrence);
     333	ffrom:			local mmap{occurrence}
     334				    sparse set(occurrence);
     335	bfrom_dead:		local set(occurrence);
     336
     337	xom_ocrs:		df_elmt_ocrs;
     338	fom_ocrs:		df_map_ocrs;
     339	xom_syms:		df_elmt_syms;
     340	fom_syms:		df_map_syms;
     341
     342	push_former:		sparse smap(elmt insts) elmt insts;
     343$
     344$ maps used to collect information for automatic documentation  use  the
     345$ following data structures:
     346$
     347	globals_du:		sparse mmap(routine) occurrence;
smfk  11	globals_e:		sparse mmap(routine) symbol;
     348	globals_r, globals_w:	sparse mmap(routine) symbol;
     349	messages:		mmap{integer}
     350				    mmap{string}
     351					set(tuple(string));
     352	statistics:		tuple(integer)(20);
     353$
     354$ general system parameters use the following data structures:
     355$
     356	q1_file:		string;
     357	ssm_file:		string;
     358	term_file:		string;
     359	debug_flag:		boolean;
     360	at_flag:		boolean;
smfk  12	lcp_flag, lcs_flag:	boolean;
     361	prog_level:		string;
     362	rem:			integer;
     363	dump_string:		string;
     364$
     365$ the following procedures are exported by module util
     366$
     367	add_sym:		procedure(elmt base_scopes) symbol;
     368	del_sym:		procedure(
     369				  symbol,
     370				  symbol,
     371				  elmt base_scopes
     372				  );
     373	add_form:		procedure(elmt base_scopes) elmt forms;
     374	add_block:		procedure(
     375				  elmt blocks,
     376				  elmt base_scopes,
     377				  boolean  )
     378					elmt blocks;
     379	add_inst:		procedure(
     380				  elmt blocks,
     381				  elmt base_opcodes,
     382				  tuple(symbol)   )
     383				    elmt insts;
     384	del_inst:		procedure(
     385				  elmt insts,
     386				  elmt insts,
     387				  elmt blocks
     388				  );
     389        insert_ins1,
     390	insert_ins:		procedure(
     391				  elmt insts,
     392				  elmt base_opcodes,
     393				  tuple(symbol)
     394				  );
     395	del_block:		procedure(
     396				  elmt blocks, elmt blocks,
     397				  elmt base_scopes  );
     398	add_label:		procedure(elmt base_scopes) symbol;
     399	add_var:		procedure(elmt base_scopes) symbol;
     400	add_int:		procedure(elmt base_scopes, integer)
     401				    symbol;
     402	ermsg, abort:		procedure(string);
     403	prints:			procedure(
     404				    string,
     405				    tuple(tuple(string, general))
     406				    );
     407	format_type:		procedure(elmt types) string;
     408	format_repr:		procedure(elmt types) string;
     409	format_form:		procedure(elmt forms) string;
     410	format_inst:		procedure(elmt insts, tuple(symbol))
     411				    string;
     412$
     413$ the following procedure is exported by the module dumps:
     414$
     415	dmp:			procedure(
     416				    elmt base_scopes,
     417				    tuple(string)
     418				    );
     419	print_summary:		procedure(sparse set(elmt base_scopes));
     420	read_q1, write_q1:	procedure;
     421	opt_ini, opt_term:	procedure;
     422$
     423$ the following procedures are exported by the modules
     424$ interval_analysis, availexp_analysis, live_analysis, and
     425$ bfrom_analysis, resp.  they are declared here purely to enable us to
     426$ use the ur check feature of sem.
     427$
     428	find_intervals:		procedure;
     429	csx:			procedure;
     430	live:			procedure;
     431	find_bfrom:		procedure;
smfb  25	find_region_constants:	procedure;
     432$
     433$ the following procedures are exported by module dataflow_solver:
     434$
     435$ nb.  there are two copies of the dataflow solver around, one operating
     436$ on the base of symbols (syms), the other on the base of occurrences
     437$ (ocrs).  this is due to the fact that setl does not have generic
     438$ bases.
     439$
     440	.comp_ocrs:		operator(df_map_ocrs, df_map_ocrs)
     441				    df_map_ocrs;
     442	cgraph_analysis:	procedure;
     443
     444$ nb. the setl system currently does not provide for an efficient
     445$ way to handle set operations between remote and sparse sets on
     446$ a common base.  while some of these operations could be done
     447$ more efficiently by source transformation, we have taken the
     448$ approach to ignore the potential sparseness of insert, etc, and
     449$ for now represent them as bit vectors (df_elmt = remote sets)
     450
     451	interproc_fwd_analysis_ocrs:
     452				procedure(
     453				  remote smap(df_edge) df_map_ocrs,
     454				  remote smap(df_node) df_elmt_ocrs,
     455				  df_map_ocrs,
     456				  df_elmt_ocrs,
     457				  boolean,
     458				  boolean,
     459				  remote mmap{df_node} df_elmt_ocrs,
     460				  remote mmap{df_node} df_elmt_ocrs,
     461				  remote mmap{df_node} df_elmt_ocrs
     462				  );
     463	intraproc_fwd_analysis_ocrs:
     464				procedure(
     465				  routine,
     466				  remote smap(df_edge) df_map_ocrs,
     467				  remote smap(df_node) df_elmt_ocrs,
     468				  df_map_ocrs,
     469				  df_elmt_ocrs,
     470				  boolean,
     471				  boolean,
     472				  remote mmap{df_node} df_elmt_ocrs,
     473				  remote mmap{df_node} df_elmt_ocrs,
     474				  remote mmap{df_node} df_elmt_ocrs
     475				  );
     476	interproc_back_analysis_ocrs:
     477				procedure(
     478				  remote smap(df_edge) df_map_ocrs,
     479				  remote smap(df_node) df_elmt_ocrs,
     480				  df_map_ocrs,
     481				  df_elmt_ocrs,
     482				  boolean
     483				  );
     484	intraproc_back_analysis_ocrs:
     485				procedure(
     486				  routine,
     487				  remote smap(df_edge) df_map_ocrs,
     488				  remote smap(df_node) df_elmt_ocrs,
     489				  df_map_ocrs,
     490				  df_elmt_ocrs,
     491				  boolean
     492				  );
     493	.comp_syms:		operator(df_map_syms, df_map_syms)
     494				    df_map_syms;
     495	interproc_fwd_analysis_syms:
     496				procedure(
     497				  remote smap(df_edge) df_map_syms,
     498				  remote smap(df_node) df_elmt_syms,
     499				  df_map_syms,
     500				  df_elmt_syms,
     501				  boolean,
     502				  boolean,
     503				  remote mmap{df_node} df_elmt_syms,
     504				  remote mmap{df_node} df_elmt_syms,
     505				  remote mmap{df_node} df_elmt_syms
     506				  );
     507	intraproc_fwd_analysis_syms:
     508				procedure(
     509				  routine,
     510				  remote smap(df_edge) df_map_syms,
     511				  remote smap(df_node) df_elmt_syms,
     512				  df_map_syms,
     513				  df_elmt_syms,
     514				  boolean,
     515				  boolean,
     516				  remote mmap{df_node} df_elmt_syms,
     517				  remote mmap{df_node} df_elmt_syms,
     518				  remote mmap{df_node} df_elmt_syms
     519				  );
     520	interproc_back_analysis_syms:
     521				procedure(
     522				  remote smap(df_edge) df_map_syms,
     523				  remote smap(df_node) df_elmt_syms,
     524				  df_map_syms,
     525				  df_elmt_syms,
     526				  boolean
     527				  );
     528	intraproc_back_analysis_syms:
     529				procedure(
     530				  routine,
     531				  remote smap(df_edge) df_map_syms,
     532				  remote smap(df_node) df_elmt_syms,
     533				  df_map_syms,
     534				  df_elmt_syms,
     535				  boolean
     536				  );
     537$
     538$ the following routines are exported by module typfind
     539$
     540	type_find:		procedure;
     541	.is_pair:		operator(elmt types) boolean;
     542	.is_map:		operator(elmt types) boolean;
     543$
     544$ the following procedure is exported by the module auto_dstruct:
     545$
     546	auto_data:		procedure;
     547$
     548$ the following routines are exported by the module conversion_analysis:
     549$
     550	conv_optimize:		procedure;
     551	can_conv:		procedure(elmt forms, elmt forms)
     552				    boolean;
     553$
     554$ the following procedure is exported by the module copy_optimization:
     555$
     556	copy_optimize:		procedure;
     557    end repr;
     558
     559
     560    end directory;
     561
     562
       1 .=member maino7
       2
       3
       4    program setl_optimizer - main;
       5$
       6$ this is the main program of the optimizer.  we begin by reading in the
       7$ intermediate tables.  we then perform inter- and intra-procedural
       8$ analysis, iterating until the control graph of the program converges.
       9$ we then perform type analysis, copy optimzation, automatic data
      10$ structure selection, etc.
      11$
      12    statistics with:= time;	$ save initial time
      13
      14    opt_ini;		$ initialize
      15
      16	cgraph_analysis;  $ find the call graph
      17	find_intervals;	$ perform interval analysis
      18	live;		$ live variable analysis
      19	csx;		$ common subexpr elimination and code motion
      20	find_bfrom;	$ bfrom computation
smfb  26	find_region_constants;	$ find flow-constant loops
      21
      22
      23    type_find;		$ type analysis
      24    auto_data;		$ automatic data structure selection
      25    conv_optimize;	$ conversion optimisation
      26    copy_optimize;	$ copy optimisation
      27    opt_term;		$ print tables, etc.
      28
      29
      30    end program setl_optimizer - main;
      31
      32
       1 .=member intfa8
       2
       3
       4    module setl_optimizer - interface;
       5$
       6$ this module handles the interface between the optimizer and the
       7$ rest of the compiler. it exports two procedures:
       8$
       9$ read_q1:	reads in the q1 code
      10$ write_q1:	writes it back out
      11$
      12
      13$ the q1 data structures
      14$ ----------------------
      15
      16$
      17$ the optimizer inttterfaces with the rest of the compiler via an
      18$ intermediate-code file called 'q1', which is written out by the
      19$ semantic pass in a form suitable to be read in by the setl binary
      20$ i-o routine 'getb'.  the optimizer will write out a modified q1 file
      21$ having a similar format, using the binary i-o routine 'putb', and this
      22$ file will be read in by the code generator.  this q1 file is different
      23$ from the standard q1 file used for direct communication between the
      24$ semantic pass and the code generator.
      25$
      26$ there are three 'main' data structures in the q1 representation each
      27$ of these is an array divided into several fields:
      28$
      29$ symtab:	the symbol table
      30$ formtab:	the form table
      31$ codetab:	the actual code
      32$
      33$ codetab contains an entry for each instruction. the codetab entry
      34$ contains the opcode, copy flag, etc. plus a list of arguments.
      35$
      36$ each basic block is assigned an index. this index is used to access an
      37$ array called blocktab which in turn gives the codetab index for the
      38$ start of the block.
      39$
      40
      41$  sequencing of information in the data to be read
      42$  ------------------------------------------------
      43
      44$
      45$ the q1 data structures are set up so that we do not have to keep the
      46$ entire program in core during compilation.
      47$
      48$ the little q1 tables are divided into 'segments'. there is one segment
      49$ for each module, procedure, etc. in the program.  each segment is
      50$ written out as soon as we are done compiling it.  when the symbols
      51$ defined in a segment are no longer needed we throw away the table
      52$ space used to store the segment, and re-use it for the next segment.
      53$
      54$ each segment consists of a header followed by a slice of each of the
      55$ arrays mentioned in the previous section.  these slices are arranged
      56$ in a standard order.
      57$
      58$ each header consists of:
      59$
      60$ 1. an integer code sc_xxx indicating whether the segment represents a
      61$    module, library, procedure,  etc.
      62$
      63$ 2. a string giving the name of the current segment.
      64$
      65$ 3. a symtab pointer to the segment name. (integer)
      66$    this pointer is needed for code generation. note also that
      67$    the segment name may not be unique, but the pointer would be.
      68$
      69$ 4. the number of procedures in the current module, library, etc.
      70$    this number is used to tell when we have read in the last
      71$    procedure in a segment.
      72$
      73$ 5. the statement count for the current member.
      74$
      75$ each array slice consists of:
      76$
      77$ 1. an integer 'org' giving the index in the full table of the
      78$    0-th entry to be read in.
      79$
      80$ 2. an integer 'last' giving the index in the full table of the
      81$    last entry to be read in.
      82$
      83$ 3. a series of entries, each of which consists of a series of
      84$    fields, each of which is a (setl) integer, real or character
      85$    string.
      86$
      87
      88$ the following macro is used to iterate over an array slice,
      89$ reading entries as it iterates. together with the next macro,
      90$ they try to resemble somewhat a loop header and a loop ender
      91$ for iteration over a tuple or map. 'index' is the index in full
      92$ table of the table entry currently read in.
      93
      94    macro for_slice(index);
      95	getb(q1_file, org, last);	$ indices of 0'th and last
      96					$ table entry
      97
      98	(forall index in [ org+1..last ])	$ iterate over entries
      99    endm;
     100
     101    macro end_slice;
     102	end forall
     103    endm;
     104$
     105$   the sequencing of information within each segment is as follow
     106$
     107$   1.  segment type		(integer code)
     108$   2.  segment name		(string)
     109$   3.  scope name		(integer index to symtab)
     110$   4.  number of procedures	(integer)
     111$   5.  statement count		(integer)
     112$
     113$   6.  formtab org and last	(integers)
     114$   7.  formtab body		(series of integer fields; see below)
     115$
     116$   8.  symbtab org and last	(integers)
     117$   9.  symbtab body		(series of various fields; see below)
     118$
     119$   10. blocktab org and last	(integers)
     120$   11. blocktab body		(integer pointers to codetab)
     121$
     122$   12. codetab org and last	(integers)
     123$   13. codetab body		(series of integer fields; see below)
     124$
     125
     126$ name and value
     127$ --------------
     128
     129$
     130$ some special fields in symtab, giving the name and value of
     131$ symbols deserve special comment.
     132$
     133$ 1. name
     134$
     135$    the 'name' field of a symtab entry is a string giving the
     136$    symbol name.  internally generated names have a name field
     137$    of ''.  rather than generate explicit names entries, we simply
     138$    call them 't$xxxx' where xxxx is their symtab index.
     139$
     140$ 2. value
     141$
     142$ constant symbols, initialized variables, procedures, members
     143$ and labels all have values. the 'vptr' field of a symtab entry
     144$ indicates whether the symbol does have a value. if so, then
     145$ at the end of the series of fixed fields for that entry, there
     146$ follow a series of value-entries, whose format depends on the
     147$ form of the symbol, as follows:
     148$
     149$    reals, integers and strings have one value-entry, giving their
     150$    (setl) value.
     151$
     152$    if 'c' is a constant of type 'elmt b' then c's val entry
     153$    is a symtab pointer to the constant you would get by
     154$    dereferencing 'c'.
     155$
     156$    for all other symbols, the first value entry is 'vlen', giving
     157$    the number of additional value entries to follow.
     158$
     159$    if 'c' is an n-tuple or an n-element set then its value
     160$    entries are n symtab pointers to its elements,
     161$    which may in turn be constant sets or tuples.
     162$
     163$    if 'c' is a procedure then its value entries are:
     164$
     165$    a. a pointer to the variable it uses for value return
     166$    b. a flag indicating whether it has a variable no. of args
     167$    c. its number of arguments
     168$    d. a series of symtab pointers to the entries for rd, wr, and rw.
     169$
     170$    if 'c' is a label its val entry is a codetab pointer to
     171$    the instruction defining it.
     172$
     173$    if 'c' is a module, program, or library then its val
     174$    entry consists of 5 lists of, respectively, libraries used,
     175$    globals read, globals written, procedures imported, and
     176$    procedures exported by the member. each list is an integer n,
     177$    followed by 'n' symtab pointers.
     178$
     179
     180
     181$
     182$ the optimizer represents type codes, opcodes, etc. as character
     183$ strings, while the compiler represents them as integers. the
     184$ following maps are used to send strings such as 'q1_add' into
     185$ the integer codes used by the compiler.
     186$
     187    var
     188	sc_type_no,	$ codes sc_xxx
     189	ft_type_no,	$ codes f_xxx
     190	ft_mapc_no,	$ codes ft_xxx
     191	cflag_no,	$ codes copy_xxx
     192	opcode_no;	$ codes q1_xxx
     193$ note that these quantities are initialized in write_q1
     194
     195
     196$ setl symbols are represented by blank atoms, little symbols are
     197$ representeed by array indices.  the maps below map each array
     198$ index into the corresponding atom
     199
     200    var
     201	stl_sym,	$ maps (little) symbols to setl symbols (members
     202			$ of plex base)
     203	stl_form,	$ maps (little) forms to setl forms (ditto)
     204	stl_block,	$ maps (little) block indices to setl blocks
     205			$ (ditto)
     206	stl_inst;	$ maps (little) instruction indices to setl
     207			$ instructions (ditto)
     208
     209$ the output interface builds the inverse mappings:
     210
     211    var
     212	ltl_sym,	$ maps setl symbols to (little) symbol indices
     213	ltl_form,	$ maps setl forms to (little) form indices
     214	ltl_block,	$ maps setl blocks to (little) block indices
     215	ltl_inst;	$ maps setl instructions to (little) instruction
     216			$ indices
     217
     218    var
     219	blocktab;	$ basic block table
     220
     221
     222    var
     223	cur_memb,	$ setl symbol for current member
     224	cur_scope;	$ setl symbol for current scope
     225
     226    var
     227	orgind,		$ maps each table to origin of current slice
     228	lastind,	$ maps each table to end of current slice
     229	org_stack;	$ stack of orgind values of superscopes
     230
     234    var
     235	scp_ind,	$ scope index of symbol table entry in its own
     236			$ scope, if it exists
     237	value_inv;	$ maps each scope to the values defined in this
     238			$ scope, to the symbol table entries that define
     239			$ these values.
     240
     241    init
     242	$ initialise little-to-setl maps
     243	stl_sym := {},      stl_form := {},     stl_block := {},
     244	stl_inst := {},
     245	$ initialise setl-to-little maps
     246	ltl_sym := {},      ltl_form := {},     ltl_block := {},
     247	ltl_inst := {},     value_inv := {};
     248
     249    repr
     250	stl_sym:		smap(integer) symbol;
     251	stl_form:		smap(integer) elmt forms;
     252	stl_block:		smap(integer) elmt blocks;
     253	stl_inst:		smap(integer) elmt insts;
     254
     255	ft_type_no:		smap(elmt base_ft_types) integer;
     256	ft_mapc_no:		smap(elmt base_ft_mapcs) integer;
     257	cflag_no:		smap(elmt base_copy_actions) integer;
     258	opcode_no:		smap(elmt base_opcodes) integer;
     259	sc_type_no:		smap(elmt base_sc_types) integer;
     260
     261	ltl_sym:		smap(symbol) integer;
     262	ltl_form:		smap(elmt forms) integer;
     263	ltl_block:		smap(elmt blocks) integer;
     264	ltl_inst:		smap(elmt insts) integer;
     265
     266	value_inv:		remote mmap{elmt base_scopes}
     267				    mmap{general}
     268					sparse set(symbol);
     270	blocktab:		tuple(*);
     271	cur_memb, cur_scope:	elmt base_scopes;
     272	scp_ind:		integer;
     273	orgind:			smap(string) integer;
     274	lastind:		smap(string) integer;
     275	org_stack:		tuple(smap(string) integer);
     276
     277	get_header:		procedure(boolean);
     278	get_forms:		procedure;
     279	get_symtab:		procedure;
     280	cnvval:			procedure(
     281				  symbol,
     282				  general    )
     283				    general;
     284	get_code:		procedure;
     285	set_ltl_maps:		procedure(elmt base_scopes);
     286	put_header:		procedure(elmt base_scopes);
     287	put_trailer:		procedure;
     288	put_forms:		procedure(elmt base_scopes);
     289	put_symtab:		procedure(elmt base_scopes);
     290	put_code:		procedure(elmt base_scopes);
     291	bld_val:		procedure(symbol)
     292				    tuple(
     293				      boolean,
     294				      integer,
     295				      tuple(general)
     296				      );
     297	elmt_sym:		procedure(
     298				  general,
     299				  elmt forms,
     300				  symbol    )
     301				    integer;
     302	reset:			procedure(
     303				  elmt base_scopes,
     304				  elmt base_scopes
     305				  );
     306    end repr;
     307
     308
       1 .=member gthd8a
       2
       3
       4    procedure read_q1;
       5$
       6$ this is the top level routine for reading the q1 tables generated
       7$ by the semantic pass.  we read one segment at a time until the
       8$ routine for reading a header encounters an end of file.
       9$
      10    repr
      11	done:			boolean;
      12    end repr;
      13
      14    loop
      15	doing get_header(done);	$ read header
      16	while not done
      17    do
      18	get_forms;	$ read formtab
      19	get_symtab;	$ read symtab
      20	get_code;	$ read code
      21    end loop;
      22
      23    $ delete the static variables global to the module
      24    stl_sym := om;      stl_form := om;     stl_block := om;
      25    stl_inst := om;
      26
      27    end procedure read_q1;
      28
      29
      30
      31
      32    procedure get_header(wr done);
      33$
      34$ this routine reads the header for a segment of q1.  we set 'done' if
      35$ we have reached the end of the input.
      36$
      37    repr
      38	i:			integer;
      39	tp:			elmt base_sc_types;
      40	nam:			string;
      41	nprocs:			integer;
      42	stmts:			integer;
      43	estmts:			integer;
      44	scp:			symbol;
      45    end repr;
      46
      47$ first read in the segment type and convert it to a string.
      48
      49    getb(q1_file, i);
      50    tp := tup_sc_types(i);
      51$ see introductory section scopes and routines
      52$ for the initialisation of this tuple
      53
      54$ see the 'reprs' section for the plex-base repring of all these
      55$ special string constants.
      56
      57$ the end of the q1 file is indicated by an empty segment whose type is
      58$ 'sc_end'.  if we have reached this segment we set 'done' and return.
      59    if tp = sc_end then
      60	done := true;
      61	return;
      62    else
      63	done := false;
      64    end if;
      65$
      66$ read the remaining part of the header record.  it consists of
      67$ 1. the scope name as a string
      68$ 2. the symbol table pointer for the scope name
      69$ 3. the number of procedures in the current scope
      70$ 4. the global statement count at the start of the scope
      71$ 5. the global statement count of the q1_entry  instruction  (in proce-
      72$    dure scopes only)
      73$
      74    getb(q1_file, nam, i, nprocs, stmts, estmts);
      75
      76    case tp of
      77
      78    (sc_sys):
      79
      80	$ the system scope can be thought of as a standard prelude which
      81	$ defines standard symbols such as om, true, etc.
      82	$
      83	$ even though there is no symbol table entry for this scope,  we
      84	$ still have to associate the usual scope maps with this  scope.
      85	$ therefore we generate a new atom for it here.
      86
      87	sym_sys := cur_scope := scp := newat;
      88	scp_ind := om;
      89
      90    (sc_lib):
      91
      92	$ the symbol table entry for a library is the first entry in  it
      93	$ own scope.   we open the scope here by generating a new  atom,
      94	$ and define scp_ind to suppress the generation of  a  new  atom
      95	$ in the get_symtab routine.
      96
      97	cur_scope := scp := newat;
      98	first_sym(cur_scope) := last_sym(cur_scope) := scp;
      99	scope(scp) := cur_scope;
     100	scp_ind := i;
     101
     102    (sc_dir):
     103
     104	$ like libraries, the symbol table entry for a directory is  the
     105	$ first entry in its own scope.  again, we open the scope  here,
     106	$ and in addition define sym_dir to point to it.
     107
     108	sym_dir := cur_scope := scp := newat;
     109	first_sym(cur_scope) := last_sym(cur_scope) := scp;
     110	scope(scp) := cur_scope;
     111	scp_ind := i;
     112
     113    (sc_prog):
     114
     115	$ if we have a directory, then the symbol table  entry  for  the
     116	$ program scope has appeared in the directory.   otherwise,  the
     117	$ symbol table entry for the program scope is the first entry in
     118	$ its own scope, and we open a new scope here.  in addition,  we
     119	$ set sym_prog to point to the new scope.
     120
     121	if sym_dir = om then	$ no directory: open new scope
     122	    sym_prog := cur_scope := scp := newat;
     123	    first_sym(cur_scope) := last_sym(cur_scope) := scp;
     124	    scope(scp) := cur_scope;
     125	    scp_ind := i;
     126	else	$ we previously have seen a directory: define cur_scope
     127	    scp := cur_scope := sym_prog;
     128	    scp_ind := om;
     129	end if;
     130
     131    (sc_mod, sc_proc):
     132
     133	$ we can only have a module if we have a directory.  if we  have
     134	$ a directory, then  the  symbol  table  entry  for  the  module
     135	$ appears in the directory scope, and stl_sym(i) points to it.
     136
     137	$ procedures always appear in some enclosing scope:  the  symbol
     138	$ table entry for a procedure appearing in an exports list of  a
     139	$ library appears in the library's  header,  while  a  procedure
     140	$ appearing in an exports or imports list of a directory appears
     141	$ in the directory scope.  procedures defined in  a  program  or
     142	$ module scope appear in the program's or module's header, resp.
     143
     144	scp := cur_scope := stl_sym(i);
     145	scp_ind := om;
     146
     147    end case;
     148
     149    $ we keep a global tuple of scopes so that segments can  be  written
     150    $ out in the order in which they were read.
     151    scopes with:= cur_scope;
     152
     153    $ define the relevant scope maps
     154    sc_type(cur_scope)     := tp;
     155    sc_nprocs(cur_scope)   := nprocs;
     156    sc_stmt_ct(cur_scope)  := stmts;
     157    sc_estmt_ct(cur_scope) := estmts;
     158
     159    $ mark the current scope as being part of the input.  the  remaining
     160    $ symbol table fields either have been or will be set by get_symtab.
     161    name(scp)    := nam;
     162    is_seen(scp) := 1;
     163
     164    if sc_type(scp) = sc_proc then
     165	membof(scp) := cur_memb;
     166    else
     167	cur_memb := scp;
     168    end if;
     169$
     170$ note that the correspondence between the little scope  index  and  the
     171$ setl atom, needed in the output interface, cannot be saved here  since
     172$ symbols might be added or deleted during optimisation.
     173$
     174
     175    end procedure get_header;
     176
     177
       1 .=member gtfm8b
       2
       3
       4    procedure get_forms;
       5$
       6$ this routine reads a segment of formtab.
       7$
       8    repr
       9	org:			integer;
      10	last:			integer;
      11	i:			integer;
      12	formtab_entry:		tuple(*);
      13	ft_type_:		integer;
      14	ft_mapc_:		integer;
      15	ft_elmt_:		integer;
      16	ft_dom_:		integer;
      17	ft_im_:			integer;
      18	ft_imset_:		integer;
      19	ft_base_:		integer;
      20	ft_deref_:		integer;
      21	ft_low_:		integer;
      22	ft_lim_:		integer;
      23	ft_pos_:		integer;
      24	ft_hashok_:		boolean;
      25	ft_neltok_:		boolean;
      26	ft_tup_:		tuple(integer);
      27	frm:			elmt forms;
      28	tp:			elmt base_ft_types;
      29	flim:			integer;
      30	cmpfrm:			integer;
      31	localtyps:		tuple(string);
      32	zzz:			string;
      33	yyy:			integer;
      34    end repr;
      35$
      36$ read in formtab entries one at a time and build the setl formtab
      37$
      38$ see the introductory section "form" for a description of the maps
      39$ (fields) being read here.
      40$
      41    for_slice(i)
      42	getb(q1_file, formtab_entry);
      43	[ ft_type_, ft_mapc_, ft_elmt_, ft_dom_, ft_im_, ft_imset_,
      44	  ft_base_, ft_deref_, ft_low_, ft_lim_, ft_pos_,
      45	    ft_hashok_, ft_neltok_, ft_tup_ ] := formtab_entry;
      46
      47	$ retain the relation between little and setl forms for later
      48	stl_form(i) := frm := add_form(cur_scope);
      49$
      50$ set various fields.  note that in the little data structures
      51$ ft_type is zero origined, so we must add one before accessing
      52$ tup_ft_types.
      53$
      54	ft_type(frm) := tp := tup_ft_types(ft_type_ + 1);
      55	ft_deref(frm) := stl_form(ft_deref_);
      56$
      57$ note the correspondence between the little 0 and the setl om in
      58$ the following test.
      59$ see section forms for the initialisation of tup_ft_types.
      60$
      61	if ft_mapc_ /= 0 then
      62	    ft_mapc(frm) := tup_ft_mapcs(ft_mapc_);
      63	end if;
      64$
      65$ the system segment contains a standard entry for each standard type
      66$ f_xxx.  this entry will always be the first entry whose ft_type is
      67$ f_xxx.  we detect these entries and use them to fill in a map from
      68$ strings f_xxx to standard forms.  this map is called std_form.
      69$
      70$ if this is the first form of type tp, save a pointer to it
      71	if std_form(tp) = om then std_form(tp) := frm; end if;
      72
      73$ note that in what follows, we make use of the fact that the
      74$ default (little) values for missing (irrlevant) fields are 0
      75
      76$ set element type, etc.
      77	if tp = f_mtuple or tp = f_proc then
      78	    ft_lim(frm)  := flim := ft_lim_;
      79	    ft_elmt(frm) := [ stl_form(cmpfrm) : cmpfrm in ft_tup_ ];
      80
      81	else
      82	    if tp = f_sint or is_ftup(frm) or is_fbase(frm) then
      83		if tp = f_sint then ft_low(frm) := ft_low_; end if;
      84		ft_lim(frm) := flim := ft_lim_;
      85	    end if;
      86
      87	    if is_floc(frm) then
      88		ft_pos(frm) := ft_pos_;
      89
      90	    elseif is_frem(frm) and is_fmap(frm) then
      91		ft_tup(frm) := stl_form(ft_tup_(1));
      92	    end if;
      93
      94	    if is_fset(frm) or is_ftup(frm) then
      95		ft_elmt(frm) := stl_form(ft_elmt_);
      96	    end if;
      97
      98	    if is_fmap(frm) then
      99		 ft_dom(frm) := stl_form(ft_dom_);
     100		 ft_im(frm)  := stl_form(ft_im_);
     101		if ft_mapc(frm) = ft_map then
     102		    ft_imset(frm) := stl_form(ft_imset_);
     103		end if;
     104	    end if;
     105
     106	    if is_fbased(frm) then
     107		 ft_base(frm) := stl_form(ft_base_);
     108	    end if;
     109	end if;
     110
     111	if ft_hashok_  then ft_hashok(frm)  := 1; end if;
     112	if ft_neltok_  then ft_neltok(frm)  := 1; end if;
     113
     114$ see comment in section 3g 'forms' explaining use of 'ft_tup'
     115$ and other maps (fields) appearing here
     116
     117$ compute the nasty 'ft_num' map for bases.
     118	if is_fbase(frm) then
     119	    localtyps :=
     120		[ f_lset, f_lmap, f_lpmap, f_limap, f_lrmap ];
     121	ft_num(frm) :=
     122		{ [zzz, ft_tup_(yyy)] : zzz = localtyps(yyy) };
     123	end if;
     124    end_slice;
     125
     126
     127    end procedure get_forms;
     128
     129
       1 .=member gtst8c
       2
       3
       4    procedure get_symtab;
       5$
       6$ this routine reads a segment of the symbol table, and then builds  the
       7$ corresponding (setl) symbol table entries.
       8$
       9    init
      10	$ the following maps are needed to account for forward  referen-
      11	$ ces within the current segment
      12	aliases := {},	$ maps symbols to their alias index
      13	values := {};	$ maps members and procedures to their values
      14
      15    repr
      16	org:			integer;
      17	last:			integer;
      18	aliases:		sparse smap(symbol) integer;
      19	values:			sparse smap(symbol) general;
      20	i:			integer;
      21	symtab_entry:		tuple(*);
      22	name_:			string;
      23	form_:			integer;
      24	alias_:			integer;
      25	is_repr_:		boolean;
      26	is_temp_:		boolean;
      27	is_stk_:		boolean;
      28	is_read_:		boolean;
      29	is_write_:		boolean;
      30	is_param_:		boolean;
      31	is_store_:		boolean;
      32	is_init_:		boolean;
      33	is_seen_:		boolean;
      34	is_back_:		boolean;
      35	is_rec_:		boolean;
      36	has_value_:		boolean;
      37	vlen_:			integer;
      38	value_:			general;
      39	sym:			symbol;
      40	alind:			integer;
      41    end repr;
      42
      43$ read symtab entries one at a time and build setl symbol table entries.
      44
      45$ see the introductory section 'the symbol table' for an account
      46$ of the maps (fields) being read
      47
      48$ note that the 'scope' and 'next_sym' fields of a symbol table
      49$ entry are set by the 'add_sym' utility while 'tempop' is set
      50$ during the initial pass over the code, when temporary (expression)
      51$ names are re-constructed; 'tempop' will map each such temporary
      52$ to the instruction in which it is computed. see 'symbol table'
      53
      54    for_slice(i)
      55	getb(q1_file, symtab_entry);
      56	[ name_, form_, alias_, is_repr_, is_temp_,
      57	    is_stk_, is_read_, is_write_, is_param_,
      58	    is_store_, is_init_, is_seen_, is_back_, is_rec_,
      59	    has_value_, vlen_, value_ ] := symtab_entry;
      60
      61	if i = scp_ind then
      62$ current symbol is the current scope (appearing in its own
      63$ symtab slice).  retrieve the already generated symbol for it.
      64	    sym := stl_sym(i) := cur_scope;
      65
      66	else
      67	    sym        := add_sym(cur_scope);  $ get setl symbol
      68	    stl_sym(i) := sym;
      69	end if;
      70
      71	form(sym) := stl_form(form_);
      72	if is_fbase(form(sym)) then basesymb(form(sym)) := sym; end if;
      73
      74	if name_ = '' then
      75	    name(sym) := 't.' + str i;   is_internal(sym) := 1;
      76	else
      77	    name(sym) := name_;   is_internal(sym) := om;
      78	end if;
      79$
      80$ account for possible forward references in the value entry
      81$
      82	if ft_type(form(sym)) = f_memb then
      83
      84	    $ the value of a member is  a  quintuple,  giving  (in  this
      85	    $ order) the libraries referenced,  the  globals  read,  the
      86	    $ globals written, the procedures imported, and  the  proce-
      87	    $ dures exported.  since the imports and exports  lists  may
      88	    $ contain forward references, we cannot process  them  until
      89	    $ the entire segment has been read.
      90
      91	    values(sym) := value_;
      92
      93	elseif ft_type(form(sym)) = f_proc then
      94
      95	    $ the value of a procedure is a quadruple, giving  (in  this
      96	    $ order) the global for the return value, a flag  indicating
      97	    $ whether the procedure has a variable number of  arguments,
      98	    $ the number of formal parameters, and a sequence  of  rd's,
      99	    $ rw's, and wr's indicating how a  parameter  was  declared.
     100	    $ since the return value is a forward reference,  we  cannot
     101	    $ process the value_ until the entire segment has been  read
     102
     103	    values(sym) := value_;
     104
     105	elseif alias_ /= 0 then
     106
     107	    $ the alias of a symbol may be a forward  reference.   hence
     108	    $ we cannot fill in this field now, but have to  wait  until
     109	    $ the entire segment has been read.  since the value  of  an
     110	    $ aliased symbol is the value of the alias, this  may  be  a
     111	    $ forward reference as well.
     112
     113	    aliases(sym) := alias_;
     114
     115	elseif has_value_ then
     116
     117	    $ in all other case, we can build the value entry.
     118
     119	    value(sym) := cnvval(sym, value_);
     120
     121	end if;
     122
     123	$ if we are currently processing the directory  scope,  then  we
     124	$ collect all module names so that we can determine later  which
     125	$ modules are missing in the input.
     126
     127	if cur_scope = sym_dir and ft_type(form(sym)) = f_memb then
     128
     129	    $ note that the symbol table entry for a library appears  as
     130	    $ the first symbol of its own scope,  and not in the  direc-
     131	    $ tory scope.   consequently  we collect here only the  main
     132	    $ program, and all modules mentioned in the directory.
     133
     134	    all_modules with:= sym;
     135
     136	    $ if this is the program scope, we must set sym_prog,  since
     137	    $ we cannot be sure that  the main program  is part  of  the
     138	    $ input.  note that the first symbol in the directory  scope
     139	    $ is the directory name.  the second  symbol with  a  member
     140	    $ form must be the main program.
     141
     142	    if cur_scope /= sym and sym_prog = om then
     143		sym_prog := sym;
     144		membof(sym_main) := sym_prog;
     145	    end if;
     146	end if;
     147
     148	$ when the semantic pass compiles the main  program,  it  treats
     149	$ it like a procedure with the reserved name '_main'.   if  this
     150	$ is the system scope, we must find this symbol table entry  for
     151	$ the main program and set sym_main to point to it.
     152
     153	if cur_scope = sym_sys and name(sym) = '_main' then
     154	    sym_main := sym;
     155	end if;
     156
     157	$ set all flags
     158	if is_temp_   then is_temp(sym)  := 1; end if;
     159	if is_stk_    then is_stk(sym)   := 1; end if;
     160	if is_read_   then is_read(sym)  := 1; end if;
     161	if is_write_  then is_write(sym) := 1; end if;
     162	if is_param_  then is_param(sym) := 1; end if;
     163	if is_store_  then is_store(sym) := 1; end if;
     164	if is_repr_   then is_repr(sym)  := 1; end if;
     165	if is_init_   then is_init(sym)  := 1; end if;
     166	if is_seen_   then is_seen(sym)  := 1; end if;
     167	if is_back_   then is_back(sym)  := 1; end if;
     168	if is_rec_    then is_rec(sym)   := 1; end if;
     169
     170	if has_value_ and not is_write_ then
     171	    is_const(sym) := 1;
     172	end if;
     173    end_slice;
     174$
     175$ we have finished to read the current segment, but we still  must  fill
     176$ in all the forward references.
     177$
     178    (forall value_ = values(sym))
     179	value(sym) := cnvval(sym, value_);
     180    end forall;
     181
     182    (forall alind = aliases(sym))
     183	alias(sym) := stl_sym(alind);
     184	if is_init(sym)=1 then continue forall; end if;
     185	value(sym) := value(stl_sym(alind));
     186    end forall;
     187
     188
     189    end procedure get_symtab;
     190
     191
     192
     193
     194    procedure cnvval(sym, value_);
     195$
     196$ this routine computes the value of a symbol table entry
     197$ and returns a pair [value, flag] where 'flag' indicates
     198$ whether the symbol has a value.
     199$
     200    repr
     201	frm:			elmt forms;
     202	tp:			elmt base_ft_types;
     203	tp1:			string;
     204	vl:			general;
     205	j:			integer;
     206	tup:			tuple;
     207	k:			integer;
     208	q:			integer;
     209	lenx:			integer;
     210    end repr;
     211
     212$ see the description of the value fields for details.
     213
     214$ elements of compound values are represented by pointers to their
     215$ symbols; we retrieve these element values using the macro
     216$ (note that the elements of a compound value v will always have
     217$ been processed before v):
     218
     219    macro elmt_val(j);   value(stl_sym(value_(j)))       endm;
     220
     221
     222    frm := form(sym);		$ get form of symbol
     223    tp  := ft_type(frm);
     224    tp1 := simple_type(tp);	$ int, real, etc.
     225$ this map sends (detailed) form indicators, such as "f-sint", "f-uint",
     226$ "f-int" into gross form indicators such as "int". it is initialized
     227$ in section 3g 'forms'
     228
     229    case tp1 of
     230
     231    ('int', 'real', 'string'):
     232
     233	vl := value_(1);
     234
     235     ('atom'):
     236
     237	$ recall that booleans are represented by the short atoms 0  and
     238	$ maxsi, where maxsi  is  an  implementation-dependend  constant
     239	$ giving to the maximum value for a short integer.
     240	$ note that there can be no other constants with mode atom.
     241
     242	if is_boolean value_(1) then
     243	    vl := value_(1);
     244	else
     245	    print('*** illegal type for constant in input: sym =',
     246		sym, name(sym), 'form =', frm, 'value =', value_);
     247	end if;
     248
     249    ('elmt'):		$ element
     250
     251	vl := elmt_val(1);
     252
     253    ('tuple'):		$ tuple
     254
     255	vl := [ elmt_val(j) : j in [ 1..#value_ ] ];
     256
     257    ('set', 'map'):	$ sets and maps
     258
     259	vl := { elmt_val(j) : j in [ 1..#value_] };
     260
     261    ('proc'):		$ procedures
     262
     263	$ the value of a procedure  is  a  quadruple,  giving  (in  this
     264	$ order) the global for the  return  value,  a  flag  indicating
     265	$ whether the procedure has a variable number of arguments,  the
     266	$ number of formal parameters, and a  sequence  of  rd's,  rw's,
     267	$ and wr's indicating how a  parameter  was  declared.
     268	$ note that the return value is a forward reference.
     269
     270	vl := [];
     271	vl(1) := stl_sym(value_(1));	$ global for return value
     272	if value_(2) = 1 then vl(2) := 1; end if;  $ var # parameters
     273	vl(3) := value_(3);		$ number of formal parameters
     274	vl(4) := [ stl_sym(value_(j)) : j in [ 4..#value_ ] ];
     275
     276    ('memb'):		$ members of directories
     277
     278	$ the value of a member is a quintuple, giving (in  this  order)
     279	$ the libraries referenced, the globals read, the globals  writ-
     280	$ ten, the procedures imported, and the procedures exported.
     281	$ note the the imports and exports  lists  may  contain  forward
     282	$ references.
     283
     284	$ each list consists of an integer n, followed by n symbol table
     285	$ pointers.
     286
     287	tup := [];	$ tuple of sets of symbols
     288	k := 1;
     289
     290	(forall q in [1..5])
     291	    lenx := value_(k);  $ length entries in q'th rights list
     292
     293	    tup with:= { stl_sym(value_(k+j)) : j in [1..lenx] };
     294	    k := k + lenx + 1;
     295	end forall;
     296
     297	vl := tup;
     298
     299    ('lab'):		$ labels and case tags
     300
     301	$ the value of a label should be the instruction that it  points
     302	$ to.  however, this will not be determined until  the  get_code
     303	$ procedure, and we need a valid map should we encounter a  case
     304	$ map.
     305
     306	vl := sym;
     307
     308    else
     309	print('*** illegal type for constant in input: sym =',
     310	    sym, name(sym), 'form =', frm, 'value =', value_);
     311
     312    end case;
     313
     314    return vl;
     315
     316    end procedure cnvval;
     317
     318
       1 .=member gtcd8d
       2
       3
       4    procedure get_code;
       5$
       6$ this routine reads segments of blocktab and codetab.
       7$
       8    repr
       9	org:			integer;
      10	last:			integer;
      11	i:			integer;
      12	nxt:			smap(integer) integer;
      13	codetab_entry:		tuple(*);
      14	opcode_:		integer;
      15	blockof_:		integer;
      16	next_:			integer;
      17	cflag_:			integer;
      18	sflag_:			integer;
      19	nargs_:			integer;
      20	args_:			tuple(*);
      21	inst:			elmt insts;
      22	opc:			elmt base_opcodes;
      23	blk:			elmt blocks;
      24	j:			integer;
      25	i1, i2:			integer;
      26	cstmt_count:		integer;
      27	argsi:			tuple(symbol);
      28	oi:			occurrence;
      29	occsi:			tuple(occurrence);
      30    end repr;
      31
      32$ we begin by reading in blocktab and mapping each little block number
      33$ into a setl block (an element of the plex base of setl blocks).
      34
      35    blocktab := [];
      36
      37    getb(q1_file, org, last);
      38
      39    (forall i in [ org+1..last ])
      40	getb(q1_file, blocktab(i));
      41    end forall;
      42
      43$ currently, in an attempt to make things easier for the optimiser,  the
      44$ semantic pass  performs basic  block  decomposition.   this  decision,
      45$ which  it may be  well to  review  and change,  was made at an earlier
      46$ stage of our design.
      47
      48$ note that all blocktab slices have org = 0 (as only one such table can
      49$ be nonempty in any stacking of scopes)
      50
      51    blk := om;
      52    (forall i in [ 1..#blocktab ])
      53	stl_block(i) := blk := add_block(blk, cur_scope, true);
      54    end forall;
      55
      56$ read codetab entries  one at  a  time and  build  entries for the setl
      57$ tables.   we also  build a temporary  map 'nxt' sending  the compiler-
      58$ issued number of each instruction into the number of the next instruc-
      59$ tion.   once all instructions  have  been  read  and  plex  base atoms
      60$ created for them,  this map will be converted into a map between these
      61$ atoms.
      62
      63    nxt := {};
      64
      65    cstmt_count := sc_estmt_ct(cur_scope);
      66
      67    for_slice(i)
      68	getb(q1_file, codetab_entry);
      69	[ opcode_, blockof_, next_, cflag_,
      70	    sflag_, nargs_, args_ ] := codetab_entry;
      71
      72	if sc_type(cur_scope) /= sc_proc then continue; end;
      73
      74	$ create an instruction atom in its plex base and note the
      75	$ correspondence between the instruction number and atom.
      76	stl_inst(i) := inst := newat;
      77
      78	opcode(inst)  := opc := tup_opcodes(opcode_);
      79	blockof(inst) := blk := stl_block(blockof_);
      80
      81	if opc = q1_stmt then cstmt_count +:= 1; end if;
      82	stmtof(inst) := cstmt_count;
      83
      84$ note that the next_ field is 0 for the last instruction in a block
      85	if next_ = 0 then
      86	    last_inst(blk) := inst;
      87	else
      88	    nxt(i) := next_;
      89	end if;
      90
      91$ store arguments. see introductory section 'the program' for an
      92$ account of the maps (fields) being read
      93
      94	argsi := [];   occsi := [];
      95
      96	(forall j in [ 1..nargs_ ])
      97	    argsi(j) := stl_sym(args_(j));
      98
      99	    oi := newat;	$ create new occurrence
     100	    instno(oi) := inst;
     101	    argno(oi)  := j;
     102	    occsi(j) := oi;
     103	end forall;
     104
     105	args(inst) := argsi;
     106	occs(inst) := occsi;
     107
     108$ if this is a label or case tag definition, establish its value,
     109$ which is the present instruction
     110
     111	if opcode(inst) in { q1_label, q1_tag } then
     112	    value(arg1(inst)) := inst;
     113	end if;
     114    end_slice;
     115
     116$ build up the maps 'first_inst' and 'next_inst'
     117
     118    (forall i in [1..#blocktab])
     119	first_inst(stl_block(i)) := stl_inst(blocktab(i));
     120    end forall;
     121
     122    (forall i2 = nxt(i1))
     123	next_inst(stl_inst(i1)) := stl_inst(i2);
     124    end forall;
     125
     126
     127    end procedure get_code;
     128
     129
       1 .=member pthd8e
       2
       3
       4    procedure write_q1;
       5$
       6$ this is the top level routine for writing the q1 tables generated
       7$ by the semantic pass.
       8$
       9    repr
      10	tp:			elmt base_ft_types;
      11	mapc:			elmt base_ft_mapcs;
      12	cact:			elmt base_copy_actions;
      13	opc:			elmt base_opcodes;
      14	sctp:			elmt base_sc_types;
      15	i:			integer;
      16	sc:			elmt base_scopes;
      17	scx:			elmt base_scopes;
      18	sym, sym1:		symbol;
      19	vl:			general;
      20    end repr;
      21
      22    printa(term_file, '   - start to write q1 file');
      23
      24$ initialize various tables and auxiliary variables.
      25
      26$ first we initialize a map 'orgind' mapping each q1 table to its origin
      27$ index in the currently processed scope.  for more comments on this
      28$ mechanism see introduction to this module.
      29
      30    orgind :=
      31	{ [ 'formtab', -1 ],
      32	  [ 'symtab',   0 ],
      33	  [ 'blocktab', 0 ],
      34	  [ 'codetab',  0 ] };
      35
      36$ initialize 'lastind', mapping each table to its last index in the
      37$ currently processed scope
      38    lastind := {};
      39
      40$ we also maintain a stack 'org_stack' for stacking up the orgind maps
      41$ of superscopes of the currently processed scope
      42    org_stack := [];
      43
      44$ initialize maps from codes to integers.  see introduction to this
      45$ module for description of the following tuples.
      46
      47    $ for ft_type_no, note the zero-origin of the little formtab
      48    ft_type_no := { [ tp,   i-1 ] : tp   = tup_ft_types(i)     };
      49    ft_mapc_no := { [ mapc,  i  ] : mapc = tup_ft_mapcs(i)     };
      50    cflag_no   := { [ cact, i-1 ] : cact = tup_copy_actions(i) };
      51    opcode_no  := { [ opc,   i  ] : opc  = tup_opcodes(i)      };
      52    sc_type_no := { [ sctp,  i  ] : sctp = tup_sc_types(i)     };
      53$
smfb  28$ compute value_inv which maps eahc scope to the values defined  in this
smfb  29$ scope, to the symbol table entry which defines the  denotation.   note
smfb  30$ that we assume here that all run-time constants originate from denota-
smfb  31$ tions.  composite  denotations  refer to  more  primitive  denotations
smfb  32$ which are defined previously.  hence if cont_scopes maps each scope to
smfb  33$ a tuple of scopes which contain this scope  (this map is build  during
smfb  34$ the first pass) then we can assert that
smfb  35$	exists sc in cont_scopes | value_inv{sc}(vl) /= om;
      61$
      62    (forall sc in scopes)
      63	(for_sym(sym, sc))
      64	    if (vl := value(sym)) /= om then
      65		if ft_type(form(sym)) = f_lab then
      66		    value_inv{sc}{sym} with:= sym;
      67		elseif alias(sym) = om and
      68			not exists sym1 in value_inv{sc}{vl} |
      69				form(sym) = form(sym1)		then
      70		    value_inv{sc}{vl} with:= sym;
      71		end if;
      72	    end if;
      73	end;
      74    end forall;
      75$
      76$ next iterate over scopes, and write out the scopes which were seen  in
      77$ the input stream.  thus we suppress scopes added  during  first  pass.
      78$ (such as the dummy procedures we added)
      79$
      80    (forall sc = scopes(i) | is_seen(sc) /= om)
      81	set_ltl_maps(sc);	$ initialize ltl_xxx maps for sc
      82	put_header(sc);		$ write out the scope header
      83	put_forms(sc);		$ write formtab
      84	put_symtab(sc);		$ write symtab
      85	put_code(sc);		$ write blocktab and codetab
      86	reset(sc, scopes(i+1));	$ reset the orgind map for next scope
      87    end forall;
      88
      89$ finally write a dummy header to indicate end of file
      90    put_trailer;
      91
      92    $ delete the static variables global to the module
      93    orgind := om;       lastind := om;      org_stack := om;
      94    ltl_sym := om;      ltl_form := om;     ltl_block := om;
      95    ltl_inst := om;     cflag_no := om;     opcode_no := om;
      96    ft_type_no := om;   ft_mapc_no := om;   sc_type_no := om;
      97    value_inv := om;
      98
      99    end procedure write_q1;
     100
     101
     102
     103
     104    procedure set_ltl_maps(sc);
     105$
     106$ this procedure computes the various 'ltl_xxx' maps for the current
     107$ scope 'sc'.  the reason for doing it in advance is that there are
     108$ various 'forward' cross references between the various tables, such as
     109$ symtab aliasing, value of labels, scope symtab pointers, procedure
     110$ return value symbols etc.
     111$
     112    repr
     113	$ representation of parameters
     114	sc:			elmt base_scopes;
     115
     116	$ representation of local variables
     117	frmorg:			integer;
     118	symorg:			integer;
     119	blockorg:		integer;
     120	instorg:		integer;
     121	frm:			elmt forms;
     122	sym:			symbol;
     123	blk:			elmt blocks;
     124	inst:			elmt insts;
     125    end repr;
     126
     127    frmorg := orgind('formtab');
     128    symorg := orgind('symtab');
     129    blockorg := instorg := 0;
     130
     133    (for_form(frm, sc))
     134	ltl_form(frm) := (frmorg +:= 1);
     135    end;
     136
     137    lastind('formtab') := frmorg;
     138
     139    (for_sym(sym, sc))
     140	ltl_sym(sym) := (symorg +:= 1);
     141    end;
     142
     143    lastind('symtab') := symorg;
     144
     145    (for_block(blk, sc))
     146	ltl_block(blk) := (blockorg +:= 1);
     147	(for_inst(inst, blk))
     148	    ltl_inst(inst) := (instorg +:= 1);
     152	end;	$ end for_inst;
     153    end;	$ end for_block;
     154
     155    lastind('blocktab') := blockorg;
     156    lastind('codetab') := instorg;
     157
     158    end procedure set_ltl_maps;
     159
     160
     161
     162
     163    procedure put_header(sc);
     164
     165$ this routine writes the header for a segment of q1.
     166
     167$ note that any scope other than the system scope will have already
     168$ appeared in a previous scope, so that its ltl_sym entry is
     169$ already available
     170
     171    repr
     172	sc:			elmt base_scopes;
     173	tp:			elmt base_sc_types;
     174    end repr;
     175
     176    putb(q1_file,
     177	    sc_type_no(tp := sc_type(sc)),
     178	    name(sc),
     179	    if tp = 'sc_sys' then 0 else ltl_sym(sc) end,
     180	    sc_nprocs(sc),
     181	    sc_stmt_ct(sc),
     182	    sc_estmt_ct(sc)
     183	);
     184
     185
     186    end procedure put_header;
     187
     188
     189
     190
     191    procedure put_trailer;
     192$
     193$ this routine writes out a dummy header to indicate end of file.
     194$
     195    putb(q1_file, sc_type_no(sc_end), '', 0, 0, 0, 0);
     196
     197    end procedure put_trailer;
     198
     199
       1 .=member ptfm8f
       2
       3
       4    procedure put_forms(sc);
       5
       6$ this routine writes a segment of formtab onto the q1 file.
       7
       8    repr
       9	sc:			elmt base_scopes;
      10	frm:			elmt forms;
      11	i:			integer;
      12	tp:			elmt base_ft_types;
      13	mapc:			elmt base_ft_mapcs;
      14	ft_type_:		integer;
      15	ft_mapc_:		integer;
      16	mttab_:			tuple(integer);
      17	f:			elmt forms;
      18	ft_dom_:		integer;
      19	ft_im_:			integer;
      20	ft_imset_:		integer;
      21	ft_base_:		integer;
      22	ft_deref_:		integer;
      23	ft_tup_:		integer;
      24	ft_elmt_:		integer;
      25	frm1:			elmt forms;
      26	ft_low_:		integer;
      27	ft_lim_:		integer;
      28	flim:			integer;
      29	ft_pos_:		integer;
      30	fpos:			integer;
      31	ft_neltok_:		boolean;
      32	ft_hashok_:		boolean;
      33	ft_num_:		tuple(integer);
      34	localtyps:		tuple(string);
      35	fm:			string;
      36	outform:		tuple(*);
      37    end repr;
      38
      39$ iterate over formtab writing out entries one at a time.
      40
      41    putb(q1_file, orgind('formtab'), lastind('formtab'));
      42
      43    loop for_form(frm, sc) do
      44
      45$ get little index of form for use just below.
      46	i    := ltl_form(frm);
      47
      48	tp   := ft_type(frm);
      49	mapc := ft_mapc(frm);
      50
      51	ft_type_  := ft_type_no(tp);
      52	ft_mapc_  := if mapc /= om then ft_mapc_no(mapc) else 0 end;
      53	ft_deref_ := ltl_form(ft_deref(frm));
      54
      55	if tp = f_mtuple or tp = f_proc then
      56	    mttab_ := [ ltl_form(f) : f in ft_elmt(frm) ];
      57	    ft_dom_ := ft_im_ := ft_base_ := ft_tup_ := 0;
      58	    ft_elmt_ := ft_imset_ := 0;
      59
      60	else
      61	    ft_elmt_ := if ft_elmt(frm) /= om
      62		then ltl_form(ft_elmt(frm)) else 0 end;
      63	    ft_dom_ := if (frm1 := ft_dom(frm)) /= om
      64		then ltl_form(frm1) else 0 end;
      65	    ft_im_ := if (frm1 := ft_im(frm)) /= om
      66		then ltl_form(frm1) else 0 end;
      67	    ft_imset_ := if (frm1 := ft_imset(frm)) /= om
      68		then ltl_form(frm1) else 0 end;
      69	    ft_base_ := if (frm1 := ft_base(frm)) /= om
      70		then ltl_form(frm1) else 0 end;
      71	    ft_tup_ := if (frm1 := ft_tup(frm)) /= om
      72		then ltl_form(frm1) else 0 end;
      73	end if;
      74
      75	ft_low_ := ft_low(frm) ? 0;
      76	ft_lim_ := ft_lim(frm) ? 0;
      77	ft_pos_ := ft_pos(frm) ? 0;
      78	ft_neltok_  := ft_neltok(frm) /= om;
      79	ft_hashok_  := ft_hashok(frm) /= om;
      80
      81	ft_num_ := [];
      82	if is_fbase(frm) then
      83	    localtyps :=
      84		[ f_lset, f_lmap, f_lpmap, f_limap, f_lrmap ];
      85	    (forall fm in localtyps)
      86		ft_num_ with:= ft_num(frm)(fm);
      87	    end forall;
      88	end if;
      89
      90	outform :=
      91	    [ ft_type_, ft_mapc_, ft_elmt_, ft_dom_, ft_im_,
      92	      ft_imset_, ft_base_, ft_deref_,
      93	      ft_low_, ft_lim_, ft_pos_, ft_hashok_, ft_neltok_ ];
      94
      95	if tp = f_mtuple or tp = f_proc then
      96	    outform with:= mttab_;
      97
      98	elseif is_frem(frm) and is_fmap(frm) then
      99	    outform with:= [ ft_tup_ ];
     100
     101	elseif is_fbase(frm) then
     102	    outform with:= ft_num_;
     103
     104	else
     105	    outform with:= [];
     106	end if;
     107
     108	putb(q1_file, outform);
     109    end loop;
     110
     111
     112    end procedure put_forms;
     113
     114
       1 .=member ptst8g
       2
       3
       4    procedure put_symtab(sc);
       5$
       6$ this routine writes a segment of symtab onto the q1 file.
       7$
       8    repr
       9	sc:			elmt base_scopes;
      10	sym:			symbol;
      11	i:			integer;
      12	name_:			string;
      13	has_value_:		boolean;
      14	vlen_:			integer;
      15	val_:			tuple(*);
      16	alias_:			integer;
      17	sym1:			symbol;
      18	form_:			integer;
      19	is_temp_:		boolean;
      20	is_read_:		boolean;
      21	is_write_:		boolean;
      22	is_stk_:		boolean;
      23	is_param_:		boolean;
      24	is_store_:		boolean;
      25	is_repr_:		boolean;
      26	is_init_:		boolean;
      27	is_seen_:		boolean;
      28	is_back_:		boolean;
      29	is_rec_:		boolean;
      30	outsymb:		tuple(*);
      31    end repr;
      32
      33$ iterate over symtab, writing out one entry at a time.
      34
      35    putb(q1_file, orgind('symtab'), lastind('symtab'));
      36
      37    loop for_sym(sym, sc) do
      38
      39	i := ltl_sym(sym);
      40	name_ := if is_internal(sym) = 1 then '' else name(sym) end;
      41	[ has_value_, vlen_, val_ ] := bld_val(sym);
      42
      43	alias_ := if (sym1 := alias(sym)) /= om then
      44	    ltl_sym(sym1) else 0 end;
      45
      46$ note that the map 'is_internal' is relevant only to the optimizer.
      47$ other parts of the compiler identify internal symbols as those having
      48$ zero name field.  therefore this map is ignored in this table dump.
      49
      50	form_ := ltl_form(form(sym));
      51
      52$ set all flags
      53	is_temp_  := is_temp(sym) /= om;
      54	is_read_  := is_read(sym) /= om;
      55	is_write_ := is_write(sym) /= om;
      56	is_stk_   := is_stk(sym) /= om;
      57	is_param_ := is_param(sym) /= om;
      58	is_store_ := is_store(sym) /= om;
      59	is_repr_  := true;
      60	is_init_  := is_init(sym) /= om;
      61	is_seen_  := is_seen(sym) /= om;
      62	is_back_  := is_back(sym) /= om;
      63	is_rec_   := is_rec(sym) /= om;
      64
      65	outsymb :=
      66	    [ name_, form_, alias_, is_repr_, is_temp_,
      67	      is_stk_, is_read_, is_write_, is_param_,
      68	      is_store_, is_init_, is_seen_, is_back_, is_rec_,
      69	      has_value_ ];
      70
      71	if has_value_ then  $ the symbol has a value entry
      72	    outsymb with:= vlen_;
      73	    outsymb with:= val_;
      74	end if;
      75
      76	putb(q1_file, outsymb);
      77    end loop;
      78
      79
      80    end procedure put_symtab;
      81
      82
       1 .=member ptcd8h
       2
       3
       4    procedure put_code(sc);
       5
       6$ this routine writes segments of blocktab and codetab.
       7
       8    repr
       9	sc:			elmt base_scopes;
      10	block:			elmt blocks;
      12	inst:			elmt insts;
      13	i:			integer;
      14	opcode_:		integer;
      15	nargs_:			integer;
      16	blockof_:		integer;
      17	next_:			integer;
      18	inst1:			elmt insts;
      19	cflag_:			integer;
smfb  36	cf:			elmt base_copy_actions;
      21	sflag_:			integer;
      22	argsi:			tuple(symbol);
      23	args_:			tuple(*);
      24	j:			integer;
      25	outcode:		tuple(*);
      26    end repr;
      27
      28    putb(q1_file, orgind('blocktab'), lastind('blocktab'));
      29
      30    loop for_block(block, sc) do
      33	putb(q1_file, ltl_inst(first_inst(block)));
      34    end loop;
      35
      36
      37$ finally build up codetab entries and write them out one at a time.
      38
      39    putb(q1_file, orgind('codetab'), lastind('codetab'));
      40
      41    loop for_block(block, sc) do loop for_inst(inst, block) do
      42	i := ltl_inst(inst);
      43
      44	opcode_  := opcode_no(opcode(inst));
      45	nargs_   := # args(inst);
      46	blockof_ := ltl_block(block);
      47
      48	next_ := if (inst1 := next_inst(inst)) /= om then
      49	    ltl_inst(inst1) else 0 end;
      50
      51	cflag_ := if (cf := copy_flag(inst)) /= om then
      52	    cflag_no(cf) else 0 end;
      53
      54	sflag_ := if share_flag(inst) /= om then 1 else 0 end;
      55
      56	argsi := args(inst);
      57	args_ := [ ltl_sym(argsi(j)) : j in [ 1..nargs_ ] ];
      58
      59	outcode :=
      60	    [ opcode_, blockof_, next_, cflag_, sflag_,
      61	      nargs_, args_ ];
      62
      63	putb(q1_file, outcode);
      64      end loop;
      65    end loop;
      66
      67    end procedure put_code;
      68
      69
       1 .=member bldv8i
       2
       3
       4    procedure bld_val(sym);
       5$
       6$ this routine computes for a given symbol 'sym' three value-related
       7$ entries:
       8$
       9$ has_value_:	a flag indicating whether the symbol has a value
      10$ vlen_:	the length of the value (see below)
      11$ val_ :	the value itself, as a series of subentries.
      12$
      13$ this routine uses an auxiliary routine, elmt_sym,  to  find,  given  a
      14$ value v, a form fm, and a scope sc, a symbol with value v and form  fm
      15$ in the containing scopes  (inner-to-outer),  or,  if  no  such  symbol
      16$ exists, a symbol with value v and a form fm' so that fm' can  be  con-
      17$ verted to fm.  again, this search is done inner-to-outer  through  the
      18$ containing scopes.  note that such a symbol must exists  unless  there
      19$ is a compiler bug.
      20$
      21    repr
      22	sym:			symbol;
      23	vl:			general;
      24	fm:			elmt forms;
      25	sc:			elmt base_scopes;
      26	tp:			elmt base_ft_types;
      27	tp1:			string;
      28	v:			general;
      29	i, j, n:		integer;
      30	val_:			tuple(integer);
      31	vli:			sparse set(symbol);
      32	sm:			symbol;
      33    end repr;
      34
      35
      36    $ constants and initialised variables with omega as their value  are
      37    $ aliased to sym_om, and thus will be rebuild in the code  generator
      38    $ interface correctly, as we copy the value of aliased symbols  from
      39    $ the symbol they are alised to.
      40
      41    if value(sym) = om then return [ false, 0 ]; end if;
      42
      43    vl  := value(sym);
      44    fm  := form(sym);
      45    sc  := scope(sym);
      46    tp  := ft_type(fm);
      47    tp1 := simple_type(tp);	$ int, real, etc.
      48$ 'simple_type' maps each ft_type string to a string describing
      49$ the 'basic' type of hat form, such as 'int', 'tuple', 'base' etc.
      50
      51    case tp1 of
      52
      53    ('int', 'real', 'string'):
      54
      55	return [ true, 1, [ vl ] ];
      56
      57    ('atom'):
      58
      59	$ recall that booleans are represented by the short atoms 0  and
      60	$ maxsi, where maxsi  is  an  implementation-dependend  constant
      61	$ giving to the maximum value for a short integer.
      62	$ note that there can be no other constants with mode atom.
      63
      64	if is_boolean vl then
      65	    return [ true, 1, [ vl ] ];
      66	else
      67	    print('*** illegal type for constant in output:',
      68		'sym =', sym, name(sym), 'form =', fm, 'scope =', sc);
      69	end if;
      70
      71    ('elmt'):		$ element
      72
      73	return
      74	    [ true, 1, [ elmt_sym(vl, ft_elmt(ft_base(fm)), sym) ] ];
      75
      76    ('tuple', 'set', 'map'):
      77
      78	return
      79	    [ true,
      80	      # vl,
      81	      if tp = f_mtuple then
      82		[ elmt_sym(v, ft_elmt(fm)(j), sym) : v = vl(j) ]
      83	      else
      84		[ elmt_sym(v, ft_elmt(fm), sym) : v in vl ]
      85	      end
      86	    ];
      87
      88    ('proc'):		$ procedures
      89
      90	$ the value of a procedure  is  a  quadruple,  giving  (in  this
      91	$ order) the global for the  return  value,  a  flag  indicating
      92	$ whether the procedure has a variable number of arguments,  the
      93	$ number of formal parameters, and a  sequence  of  rd's,  rw's,
      94	$ and wr's indicating how a parameter was declared.
      95
      96	return
      97	    [ true,
      98	      3 + # vl(4),	$ 3 + length of sequence of rd's, ...
      99	      [ ltl_sym(vl(1)),	$ global for the return value
     100		if vl(2) = om then 0 else 1 end,  $ variable #parameters
     101		vl(3) ] +	$ number of formal parameters
     102		[ ltl_sym(vl(4)(i)) : i in [ 1..#vl(4) ] ] ];
     103$ note that here we use pointers to the little symbol table entries for
     104$ the actual symbols rd/wr/rw; see the corresponding input routine
     105$ cnvval.
     106
     107    ('memb'):		$ members
     108
     109	$ the value of a member is a quintuple,  giving  (in this order)
     110	$ the libraries referenced, the globals read, the globals  writ-
     111	$ ten, the procedures imported, and the procedures exported.
     112
     113	n := 0;   val_ := [];
     114
     115	(forall i in [ 1..5 ])
     116	    vli := vl(i);
     117
     118	    n +:= (#vli + 1);
     119
     120	    val_ with:= #vli;
     121	    (forall sm in vli)
     122		val_ with:= ltl_sym(sm);
     123	    end forall;
     124	end forall;
     125
     126	return [ true, n, val_ ];
     127
     128    ('lab'):		$ labels
     129
smfi   1	return [ true, 1, [ ltl_inst(value(sym)) ] ];
     131
     132    else
     133	print('*** illegal type for constant in output:',
     134		'sym =', sym, name(sym), 'form =', fm, 'scope =', sc);
     135    end case;
     136
     137    end procedure bld_val;
     138
     139
     140
     141
     142    procedure elmt_sym(vl, fm, sym);
     143$
     144$ this routine returns the name of a setl symbol whose value is vl,
     145$ whose type is fm, and whose scope is sc or a containing scope.
     146$
     147    repr
     148	vl:			general;
     149	fm:			elmt forms;
     150	sym:			symbol;
     151	sc, scx:		elmt base_scopes;
     152	s:			symbol;
     153    end repr;
     154
     155    sc := scope(sym);
     156
     157    if exists scx in cont_scopes(sc), s in value_inv{scx}{vl} |
     158	    form(s) = fm then
     159	return ltl_sym(s);
     160
     161    elseif exists scx in cont_scopes(sc), s in value_inv{scx}{vl} |
     162	    can_conv(form(s), fm) then
     163	return ltl_sym(s);
     164
     165    else
     166	print('*** error in elmt_sym: scope = ' + str sc +
     167				   ', form = '  + str fm +
     168				   ', value = ' + str vl + ' ***'    );
     169
     170	print;
     171	print('value_inv =', value_inv);
     172	print;
     173    end if;
     174
     175
     176    end procedure elmt_sym;
     177
     178
       1 .=member rset8j
       2
       3
       4    procedure reset(sc, nxt);
       5$
       6$ this procedure is called to  reset the  'orgind' map  when we are done
       7$ writing  out the table  entries for  a scope.  'sc' is the scope name,
       8$ and 'nxt' is the next scope.
       9$
      10$ the following cases may arise:
      11$
      12$ 1. sc is not a procedure.   in this case nxt is a subscope of sc;   we
      13$ stack the 'orgind' value for sc in 'org_stack', and take 'lastind' for
      14$ sc to be the new 'orgind' value for nxt.
      15$
      16$ 2. sc is a procedure and nxt is also a procedure.   in this case we do
      17$ nothing, as the current 'orgind' map is appropriate for nxt also,  and
      18$ there is no need to stack it.
      19$
      20$ 3. sc is a procedure,  and nxt is a library,  the  directory,  or  the
      21$ main program.  in this case we observe that the library and  directory
      22$ headers are static.  in the case of libraries their headers are  still
      23$ needed since it contains the procedure symbol table  entries  for  the
      24$ exported procedures.  since we like  to  keep  these  headers,  we  do
      25$ nothing since the current orgind value is appropriate for nxt, too.
      26$$--  for libraries, this is an overestimate: only the entries for ex-
      27$$--  ported procedures and thei return values remain visible, but not
      28$$--  their  and 
      29$
      30$ 4. sc is a procedure, and nxt is a module header.  in this case we pop
      31$ org_stack to obtain the orgind map for nxt.  note that  the  preceding
      32$ scope must have been the main program or a module scope.
      33$
      34    if sc_type(sc) = sc_proc then
      35	if nxt = om or sc_type(nxt) = sc_mod then
      36	    orgind frome org_stack;
      37	end if;
      38    else    $ keep entries till end of member
      39	org_stack with:= orgind;
      40	orgind := lastind;
      41    end if;
      42
      43    end procedure reset;
      44
      45
      46    end module setl_optimizer - interface;
      47
      48
       1 .=member fpass9
       2
       3
       4    module setl_optimizer - optinit;
       5
       6
       7$ this module contains routines to initialize the optimizer.
       8
       9    var
      10	expsym,		$ maps expression opcode and args to the
      11			$ expresion identifying temporary
      12	expdepend,	$ explicit dependency relation between
      13			$ expressions
      14	live_temps;	$ live temporaries
      15
      16    init
      17	expsym := {},       expdepend := {},    live_temps := {};
      18
      19    repr
      20	expsym:			smap(tuple(
      21					elmt base_opcodes,
      22					tuple(symbol)    ))
      23				    symbol;
      24	expdepend:		sparse mmap{symbol}
      25				    remote set(expression);
      26	live_temps:		sparse set(symbol);
      27
      28	readcc:			procedure;
      29	first_pass:		procedure;
      30	shortcut:		procedure(symbol) symbol;
      31	get_temp:		procedure(
      32				  elmt base_opcodes,
      33				  tuple(symbol),
      34				  routine,
      35				  elmt insts    )
      36				    symbol;
smfc  24	exp_name:		procedure(
smfc  25				  elmt base_opcodes,
smfc  26				  tuple(symbol),
smfc  27				  elmt insts    )
smfc  28				    string;
      39	transclose:		procedure(
      40				  sparse set(symbol),
      41				  sparse mmap{symbol}
      42				      remote set(expression)    )
      43				    sparse mmap{symbol}
      44					remote set(expression);
      45	satisfy_members:	procedure;
      46	satisfy_procs:		procedure;
      47	bld_body:		procedure(
      48				  routine,
      49				  sparse set(symbol),
      50				  sparse set(symbol),
      51				  sparse set(routine)
      52				  );
      53	bld_entry:		procedure(routine);
      54	bld_label:		procedure(routine, symbol);
      55	bld_use:		procedure(routine, symbol);
      56	bld_def:		procedure(routine, symbol);
      57	bld_call:		procedure(routine, routine);
      58	bld_exitstop:		procedure(routine);
      59    end repr;
      60
      61
      62    procedure opt_ini;
      63
      64    readcc;			$ read control card parameters
      65
smfk  13    prog_level := 'opt(84180)';
      67
      68    title('cims.setl.' + prog_level);
      69
smfk  14    if lcp_flag then  $ print phase heading
smfk  15	print('parameters for this compilation:');
smfk  16	print;
smfk  17	print('q1 file: q1 =', q1_file);
smfk  18	print('source map file: ssm =', ssm_file);
smfk  19	print('run-time error mode: rem =', rem);
smfk  20	print('dumps requested: db =', dump_string);
smfk  21	print;
smfk  22    end if;
      78
      79    $ start log on terminal file
      80    open(term_file, 'text-out');
      81    printa(term_file, '  start cims.setl.' + prog_level, date);
      82
      83    $ read the q1 file written by the semantic pass
      84    open(q1_file,'binary');    read_q1;    close(q1_file);
      85    statistics with:= time;	$ save initial time
      86
      87    first_pass;			$ a priliminary pass through the code
      88
      89    $ dump tables
      90    if 's' in dump_string then dmp(om, 'symtab');  end if;
      91    if 'f' in dump_string then dmp(om, 'formtab'); end if;
      92    if 'c' in dump_string then dmp(om, 'codetab'); end if;
      93
      94    statistics with:= time;	$ save initial time
      95
      96
      97    end procedure opt_ini;
      98
      99
     100
     101
     102    procedure readcc;
     103$
     104$ this routine reads the control card parameters relevant to the
     105$ optimizer.
     106$
     107$ control card parameters are read in using two procedures in the
     108$ standard prelude:
     109$
     110$ getipp(s):	returns the value of an integer control card parameter
     111$ getspp(s):	returns the value of a string control card parameter
     112$
     113$ 's' is a string of the form 'xxx=yyy/zzz' where:
     114$
     115$ 'xxx' is the name of the parameter as it appears on the control card
     116$ 'yyy' is the default if the parameter is not supplied
     117$ 'zzz' is the default if only the parameter name is supplied.
     118$
     119    q1_file	:= getspp('q1=q1/q1');		$ q1 file name
     120    ssm_file    := getspp('ssm=/');		$ optimiser source map
     121    term_file   := getspp('sterm=0/0');		$ terminal file name
     122    rem		:= getipp('rem=1/1');		$ run-time error mode
     123    debug_flag  := getipp('odebug=1/1') = 1;	$ perform debugging code
     124    at_flag	:= getipp('at=0/1') = 1;	$ automatic titling
smfk  23    lcp_flag	:= getipp('lcp=0/1') = 1;	$ list program parms
smfk  24    lcs_flag	:= getipp('lcs=1/1') = 1;	$ list program stats
     125    dump_string := getspp('db=/sfci');		$ dump options
     126
     127
     128    end procedure readcc;
     129
     130
     131
     132
     133    procedure first_pass;
     134$
     135$ this procedure does a preliminary pass over the program performing
     136$ the following tasks:
     137$
     138$ 1. it generates a dummy routine for each unsatisfied external
     139$    procedure.
     140$
     141$ 2. it iterates over the code making various local cleanups which
     142$    simplify later algorithms.  at the same time it builds various
     143$    auxiliary sets and maps.
     144$
     145    init
smfh   8        varofexps := {},    push_of := {},
smfh   9        all_eq := {},       all_system_routs := {};
     148
     149    repr
     150	sc, scx:		elmt base_scopes;
     151	all_system_routs:	sparse set(symbol);
smfg  16	all_eq:			sparse set(elmt insts);
     152	sym:			symbol;
     153	r:			routine;
     154	params:			tuple(symbol);
     155	varofexps:		sparse set(symbol);
     156	expoftmp:		sparse smap(symbol) symbol;
     157	b:			elmt blocks;
     158	i, iprev:		elmt insts;
     159	opc:			elmt base_opcodes;
     160	oi1:			occurrence;
     161	a1, a2, a3:		symbol;
     162	p1:			symbol;
     163	formpar:		symbol;
     165	x, s:			symbol;
     166	y:			occurrence;
smfg  17	i1, i2:			elmt insts;
smfg  18	op1, op2:		elmt base_opcodes;
smfg  19	opc1, opc2:		elmt base_opcodes;
smfg  20	l:			symbol;
     168	opcarb, opcless:	elmt base_opcodes;
     169	j:			integer;
     170	a, aa, aivs:		tuple(symbol);
     171	aj, bj:			symbol;
     172	tsym:			symbol;
     173	opcrev:			elmt base_opcodes;
     174	lsin:			integer;
     175	presym:			symbol;
     181	rem_all_oi:		remote set(occurrence);
     182	oi:			occurrence;
     183	v:			symbol;
     184	push_of:		sparse smap(symbol) elmt insts;
     185	casemap, cas:		general;
     186	lab:			symbol;
     187    end repr;
     188
     189
     190$ the cleanups performed here are as follows:
     191$$$ ???????  art: supply description of cleanups
     192$ the auxiliary sets and maps built are as follows:
     193$ we begin by building the set of all procedures in the input.
     194    routs := { sc in scopes | sc_type(sc) = sc_proc };
     195    $ note that this set includes main program, too.
     196
     197    (for_sym(sym, sym_sys))
     198	if ft_type(form(sym)) = f_proc and sym /= sym_main then
     199	    all_system_routs with:= sym;
     200	end if;
     201	if name(sym) = 'om' then sym_om := sym; end if;
     202    end;
     203
     204$ check whether the input contains a directory and a main program.
     205$ if not, build dummies.
     206
     207    satisfy_members;
     208
     209$ next fill in the bodies of all procedures  mentioned in  the directory
     210$ but not supplied by the user.
     211
     212$ sometimes we will find two unsatisfied  externals p1 and p2  which can
     213$ have the same dummy body.   rather than  building separate  bodies for
     214$ each of  them we will  set alias(p1) = p2.   when we iterate over  the
     215$ code we will substitute p2 for each occurrence of p1.
     216
     217    satisfy_procs;
     218
     219$ build 'rparams' sending each  procedure into  a tuple  containing  its
     220$ formal parameters.   if a procedure has 'n' formal parameters they are
     221$ always its first 'n' symbols.
     222
     223    (forall r in routs)
     224	params := [];
     225
     226	(for_sym(sym, r))
     227	    if is_param(sym)=1 then
     228		params with:= sym;
     229	    elseif ft_type(form(sym)) /= f_lab then
     230		quit;
     231	    end if;
     232	end;
     233	rparams(r) := params;
     234    end forall;
     235
     236$ next we make a pass over the code to build the 'oi_sets',  'exp_maps',
     237$ and 'var_maps', and to accomplish various cleanups.
     238
     239$ the loop body consists of two parts.  the first part is a case
     240$$$ ???? reword this enigmatic paragraph
     241$ statement which performs various special actions and putting
     242$ the instruction's first occurrence into the appropriate sets.
     243$ the second part adds the instructions remaining occurrences
     244$ to all_oi and all_i.
     245
     246$ the loop builds the following sets and maps listed above:
     247$
     248$  a. rentry:	    sends each routine into its entry block
     249$  b. rexit:	    sends each routine into its exit block
     250$  c. rstop:	    sends each routine into its stop block
     251$  d. all_oi:	    set of all occurrences
     252$  e. all_o:	    set of ovariables
     253$  f. all_i:	    set of ivariables
     254$  g. callsin:	    maps each routine to its call blocks
     255$  h. callproc:     maps each call block to the routine it calls
     256$  i. cgraph:	    the call graph itself.
     257$  j. globalvars:   set of global variables
     258$  k. localvars:    maps each routine to its local variables
     259$     variables:    set of all program variables
     260$  l. occsof:       maps each variable to its occurrences
     261$  m. globalexps:   set of global expressions
     262$  n. localexps:    maps each routine to its local expressions
     263$  o. expdepend:    explicit dependency relation between expressions
     264$     varofexps:    user variables which are expression operands
     265$     live_temps:   all temporaries still needed after code modification
     266$     system_routs: system routines call by the program
     267$     allexps:	    set of all expressions
     268$     opcexp:	    maps expressions to their defining opcode
     269$     argsexp:	    maps expressions to tuple of their input args
     270$$$ ??????? micha: it may be most efficient to build
     271$$$ ??????? some block propagation maps right here
     272$
     273$ let us comment on the way we handle expressions in the optimiser.  the
     274$ semantic pass generates a temporary variable as an output variable for
     275$ for each expression  computation,  but  maintains uniqeness  of  these
     276$ names only within a basic block, so that the same expression, computed
     277$ in different blocks,  may be assigned (i.e. identified with) different
     278$ target temporaries.  however, for our redundant expression elimination
     279$ phase,  we  want to maintain this unique representation of expressions
     280$ by  their  target  temporaries  throughout  the  whole program.   this
     281$ requires renaming of temporaries, which is performed in this loop.
     282$
     283$ this  is  done  as  follows:  for  each  basic  block  we build  a map
     284$ 'expoftmp',  mapping each temporary to its  new expression-identifying
     285$ temporary  symbol.   when we  process an  instruction i  of  the  form
     286$ 't := op(a1, a2...an)' which is known to yield an  expression which is
     287$ well defined and has no side effects (thus excluding  expressions com-
     288$ puted  e.g.  by  'q1_arb' or  'q1_rand'  operators),  we replace  each
     289$ temporary among the i-variables by its 'expoftmp' value (which must be
     290$ already available) to obtain  a new list (b1, b2...bn) of  input argu-
     291$ ments.   then the pair tn = [ op, input args ] uniquely identifies the
     292$ expression  being  computed by this  instruction;  we maintain  a  map
     293$ 'expsym' which  maps each such pair to  the  corresponding expression-
     294$ identifying  temporary  symbol.   using this map  we  get the required
     295$ target variable for i and replace t, if necessary, by that variable.
     296$
     297$ we also try to re-use  temporaries generated  by the  semantic pass as
     298$ the new expression names.  any temporary that is not re-used is marked
     299$ as a dead symbol and will be later removed from the symbol table.
     300$
     301    (forall r in routs)
     302      expoftmp := {};
     303      (for_block(b, r))
     304	iprev := om;  $ keep previous instruction
     305
     306	(for_inst(i, b))
     307	    opc := opcode(i);
     308	    oi1 := get_oi(i, 1);	$ first occurrence
     309
     310	    case opc of
     311
     312	    (q1_stmt):
     313
     314		iprev := i;
     315		continue;
     316
     317	    (q1_argin, q1_argout, q1_free):
     318
     319		$ the second parameter of the current  instruction,  a2,
     320		$ gives the name of the routine called.  if  this  is  a
     321		$ call to an unsatisfied  external  procedure,  we  must
     322		$ account for the possibility that  satisfy_procs  might
     323		$ have determined that a2 belongs to a class  of  proce-
     324		$ dures p1, p2, ..., pn, all with identical  parameters,
     325		$ globals accessed, etc., and decided not  to  supply  a
     326		$ dummy body for each pi, but rather to supply  a  dummy
     327		$ body for some pj, and to set  alias(pi) = pj  for  the
     328		$ remaining pi's.  if this is the case, we substitute pj
     329		$ for pi in the instruction.
     330		$
     331		$ furthermore, we recall that the data  flow  algorithms
     332		$ require that the formal parameter name appears  as  an
     333		$ explicit, assignment-like argument to  the  argin  and
     334		$ argout instructions.  we add it at this time.
     335		$
     336		$ if, on the other hand, this instruction is part  of  a
     337		$ call to a setl systems routine such as read or  print,
     338		$ then we account for the fact that we do not  know  the
     339		$ structure of these routines  by  replacing  argin  and
     340		$ argout instructions by  sargin  and  sargout  instruc-
     341		$ tions, and thus are able to  distinguish  the  calling
     342		$ sequences.  note that we consider the  first  argument
     343		$ of an sargin instruction to be  an  i-variable,  while
     344		$ the first argument of an sargout is an o-variable.
     345		$
     346		$ note that the above  remarks  also  hold  for  q1_free
     347		$ instructions, since the code generator needs  to  know
     348		$ the forms of the formal parameters to be able to  emit
     349		$ the proper stack pops.
     350
     351		a2 := arg2(i);
     352		if a2 in all_system_routs then
     353		    system_routs with:= a2;
     354		    if opc = q1_argin then
     355			opc := opcode(i) := q1_sargin;
     356		    elseif opc = q1_argout then
     357			opc := opcode(i) := q1_sargout;
     358		    end if;
     359
     360		else
     361		    p1 := alias(a2);
     362		    if p1 /= om then arg2(i) := a2 := p1; end if;
     363
     364		    formpar := rparams(a2)(value(arg3(i)));
     365		    if opc = q1_argin then
     366			args(i) := [ formpar ] + args(i);
     367		    elseif opc = q1_argout then
     368			args(i) with:= formpar;
     369		    end if;
     370
smfc  30		    if #args(i) /= #occs(i) then
smfc  31			oi := newat;	$ record additional occurrence
smfc  32			instno(oi) := i;
smfc  33			argno(oi) := #args(i);
smfc  34			occs(i) with:= oi;
smfc  35		    end if;
     375		end if;
     376
     377	    (q1_call):
     378
     379		$ here the first argument, a1, is  the  procedure  name.
     380		$ as explained above, a1 may be an alias for some  other
     381		$ procedure.
     382
     383		a1 := arg1(i);
     384		if a1 in all_system_routs then
     385		    system_routs with:= a1;
     386
     387		    $ assure that this is not a call to host
     388		    if name(a1) = 'host' then
     389			abort('attempt to optimise program with host');
     390		    end if;
     391
     392		    $ define the return value
     393		    i1 := i;
     394		    insert_ins(i1, q1_def, value(a1)(1));
     395		else
     396		    p1 := alias(a1);
     397		    if p1 /= om then arg1(i) := a1 := p1; end if;
     398
smfg  21		    cgraph  with:= [ r, a1 ];	$ 'r' calls 'a1'
smfg  22		    callsin with:= [ r, b  ];	$ call block in 'r'
smfg  23		    callproc(b) := a1;		$ 'b' calls 'a1'
smfg  24
smfg  25		    $ this is a 'single-instruction' block, i.e. it
smfg  26		    $ consists of a label, a call, and a goto.
smfg  27		    $ assert opcode(first_inst(b)) = q1_label;
smfg  28		    $ assert next_inst(first_inst(b)) = i;
smfg  29		    $ assert next_inst(i) = last_inst(i);
     400		end if;
     401
     402	    (q1_entry):
     403
     404		rentry(r) := b;
     405
     406	    (q1_exit):
     407
     408		rexit(r) := b;
     409
     410	    (q1_stop):
     411
     412		rstop(r) := b;
     413
     414	    (q1_sof, q1_sofa, q1_send, q1_ssubst, q1_next):
     415
     416		$ these are opcodes whose  first  argument  is  both  an
     417		$ i-variable and an o-variable.  to simplify  our  task,
     418		$ we add a last argument, equal to the  first  argument,
     419		$ to account for the i-occurrence.
     420
smfg  30		args(i) with:= arg1(i);
     423
     424		oi := newat;		$ record additional occurrence
     425		instno(oi) := i;
     426		argno(oi)  := #args(i);
     427		occs(i)  with:= oi;
     428
     429	    (q1_from, q1_fromb, q1_frome):
     430
     431		$ the second argument  for  these  opcodes  is  both  an
     432		$ i-variable and an  o-variable.   since  'x from s'  is
     433		$ semantically equivalent to  'x := arb s;  s less:= x',
     434		$ we merely transform the former to  the  latter.   note
     435		$ that neither from nor  arb  yield  valid  expressions.
     436		$ this observation is important  if  we  later  want  to
     437		$ reverse the arbb and arbe sequences into  fromb's  and
     438		$ frome's, resp.  (this is done in the output  interface
     439		$ cleanup).
     440
     441		[ x, s ] := args(i);
     442
     443		opcode(i) := q1_noop;
     444		args(i)   := [];
     445		occs(i)   := [];
     446
     447		if opc = q1_from then
     448		    opcarb  := q1_arb;
     449		    opcless := q1_less;
     450		elseif opc = q1_frome then
     451		    opcarb  := q1_arbe;
     452		    opcless := q1_lesse;
     453		else
     454		    opcarb  := q1_arbb;
     455		    opcless := q1_lessb;
     456		end if;
     457
     458		if is_temp(s) /= om then is_temp(s) := om; end if;
     459		assert is_temp(x) = om;
     460		i1 := i;
     461		insert_ins(i1, opcarb,  x, s   );
     462		insert_ins(i1, opcless, s, s, x);
     463		opc := q1_noop;
smfg  31
smfg  32	    (q1_eq, q1_ne):
smfg  33
smfg  34		if arg2(i) /= arg3(i) then
smfg  35		    if arg2(i) = sym_om or arg3(i) = sym_om then
smfg  36			all_eq with:= i;
smfg  37		    end if;
smfg  38		end if;
     464
     465	    (q1_inext, q1_inextd):
     466
     467		$ precede the iterator variable a2 by a q1_def,  so that
     468		$ we don't have to worry about the two o-variables.
     469		$ note that this variable has no influence on  optimisa-
     470		$ tion, except that it appears as the operand to a  test
     471		$ for omega which signals the end of the iteration.
smfi   3		if #name(x := arg1(i)) > 2 and name(x)(1..2) = 't.' then
smfi   4		    if 'c' notin dump_string then
smfi   5			name(x) := '';
smfi   6		    end if;
smfi   7		end if;
smfe  15
smfe  16		itervars with:= arg2(i);
smfk  25
smfk  26		if #name(x := arg3(i)) > 2 and name(x)(1..2) = 't.'
smfk  27			and opcode(iprev) = q1_asn and x = arg1(iprev)
smfk  28			and 'c' notin dump_string
smfk  29		then
smfk  30		    name(x) := name(arg2(iprev));
smfk  31		end if;
     472
     473		i1 := iprev;
     474		insert_ins(i1, q1_def, arg2(i));
     475
     476	    (q1_push):
     477		x frome args(i);
     478		y frome occs(i);
     479		push_of(x) := i;
smfi   8
smfi   9		if 'c' notin dump_string then
smfi  10		    if is_temp(x := arg1(i)) /= om
smfi  11			    and opcode(iprev) = q1_asn
smfi  12			    and arg1(iprev) = arg1(i) then
smfi  13			name(x) := name(arg2(iprev));
smfi  14		    end if;
smfi  15		end if;
     480
     481	    (q1_set1, q1_tup1):
     482		push_former(push_of(arg1(i))) := i;
smfi  16
smfi  17		if #name(x := arg1(i)) > 2 and name(x)(1..2) = 't.' then
smfi  18		    if 'c' notin dump_string then
smfi  19			name(x) := format_inst(i, om);
smfi  20		    end if;
smfi  21		end if;
     483
     484	    (q1_case):
     485		casemap := value(arg1(i));
     486		value(arg1(i)) :=
     487			{ [ cas, shortcut(lab) ] : lab = casemap(cas) };
     488
     489	    (q1_goto):
     490		arg1(i) := shortcut(arg1(i));
     491		last_inst(b) := i;
     492		next_inst(i) := om;
     493
smfg  39	    (q1_if, q1_ifnot, q1_bif, q1_bifnot):
     495		arg2(i) := shortcut(arg2(i));
smfg  40
smfg  41	    (q1_ifasrt):
smfg  42		arg1(i) := shortcut(arg1(i));
     496
     497	    (q1_error):
     498		abort('optimisation terminated due to '
     499			'prior compilation error');
     500
     501	    (q1_ok, q1_fail, q1_succeed, q1_lev):
     502		abort('attempt to optimise program with backtracking');
     503
     504	    end case;
     505
     506$ add occurrences in i to the various 'oi_sets'.
     507	    (forall j in [ first_ivar(opc)..#args(i) ])
     508		oi := get_oi(i, j);
     509
     510		all_oi with:= oi;
     511		all_i  with:= oi;
     512	    end forall;
     513
     514	    if opc in ops_ovar then
     515		all_oi with:= oi1;
     516		all_o  with:= oi1;
     517	    end if;
     518
     519$ update the various 'exp_maps'
     520
     521	    a := args(i);	$ get arguments
     522	    if opc in ops_exps then
     523		(forall j in [ 2..#a ])
     524		    aj := a(j);
     525		    if (bj := expoftmp(aj)) /= om then
     526			a(j) := aj := bj;
     527		    else
     528			if is_const(aj) = om and aj /= sym_om then
     529			    varofexps with:= aj;
     530			end if;
     531		    end if;
     532		end forall;
     533
     534		aivs := a(2..);		$ get input arguments
     535
     536		$ get expression-identifying temporary
     537		tsym := get_temp(opc, aivs, r, i);
     538
     539		$ replace the output temporary  by the new  one and note
     540		$ that correspondence.
     541		a(1) := expoftmp(a(1)) := tsym;
     542
     543	    else
     544		$ not an expression-producing instruction:  in this case
     545		$ just  replace  temporaries  by  their  new expression-
     546		$ identifying symbols.
     547		(forall j in [ first_ivar(opc)..#a ])
     548		    if (bj := expoftmp(a(j))) /= om then
     549			a(j) := bj;
     550		    end if;
     551		end forall;
     552
     553		$ if a sinister assignment, e.g. 'f(x) := y', replace it
     554		$ by the pair  't := y'  'f(x) := t',  where  t  is  the
     555		$ expression-identifying temporary for 'f(x)'.
     556
     557		if opc in ops_sin then
     558		    if a(1) /= (a1 := a(#a)) then
     559			a(1) := a1;
     560			varofexps with:= a1;
     561		    end if;
     562
     563		    opcrev :=	$ the reverse opcode
     564			case opc of
     565			(q1_sof):	q1_of,
     566			(q1_sofa):	q1_ofa,
     567			(q1_send):	q1_end,
     568			(q1_ssubst):	q1_subst
     569			else om end;
     570		    lsin := if opc = q1_ssubst then 3 else 2 end;
     571		    aa := a(1..lsin);
     572		    tsym := get_temp(opcrev, aa, r, i);
     573		    if a(lsin+1) /= tsym then
     574			insert_ins(iprev, q1_asn, tsym, a(lsin+1));
     575			a(lsin+1) := tsym;
     576		    end if;
     577		end if;
     578
     579		if opc in ops_ovar then
     580		    live_temps with:= a(1);
     581		end if;
     582	    end if;
     583
     584	    $ restore argument list
     585	    args(i) := a;
     586	    iprev := i;
     587	end;	$ end for_inst;
     588      end;	$ end for_block;
     589    end forall;
     590$
     591$ next delete all dead temporaries from the symbol table
     592$
     593    (forall sc in scopes)
     594	presym := om;	$ note previous symbol
     595	(for_sym(sym, sc))
     596	    if is_temp(sym)=1 and sym notin live_temps then
     597		del_sym(sym, presym, sc);
     598		sym := presym;
     599	    else
     600		presym := sym;
     601	    end if;
     602	end;	$ end for_sym;
     603    end forall;
smfg  43$
smfg  44$ iterate  over all  equality tests  with one  constant  operand  to see
smfg  45$ whether control flow information should be made  explicit for the type
smfg  46$ finder.
smfg  47$
smfg  48    (forall i1 in all_eq)
smfg  49	i2  := next_inst(i1);
smfg  50	op1 := opcode(i1);
smfg  51	op2 := opcode(i2);
smfg  52
smfg  53	if op2 notin { q1_if, q1_ifnot, q1_bif, q1_bifnot } then
smfg  54	    continue forall;
smfg  55	end if;
smfg  56	if arg1(i1) /= arg1(i2) then continue forall; end if;
smfg  57
smfg  58	if arg2(i1) = sym_om or arg3(i1) = sym_om then
smfg  59	    a1 := if arg2(i1) /= sym_om then arg2(i1) else arg3(i1) end;
smfg  60	    opc1 := q1_isom; opc2 := q1_notom;
smfg  61	end if;
smfg  62
smfg  63	if op1 = q1_eq and op2 in { q1_ifnot, q1_bifnot }
smfg  64		or op1 = q1_ne and op2 in { q1_if, q1_bif }  then
smfg  65	    [ opc1, opc2 ] := [ opc2, opc1 ];
smfg  66	end if;
smfg  67
smfg  68	r := routof(blockof(i2));
smfg  69
smfg  70	b := add_block(om, r, true);
smfg  71	l := add_label(r);
smfg  72	i := add_inst(b, q1_label, l);
smfg  73	value(l)  := i;
smfg  74	stmtof(i) := stmtof(i1);
smfg  75
smfg  76	insert_ins(i,    opc1,       a1);
smfg  77	insert_ins(i, q1_goto, arg2(i2));
smfg  78
smfg  79	arg2(i2) := l;
smfg  80
smfg  81	insert_ins(i2, opc2, a1);
smfg  82
smfg  83    end forall;
     661$
     662$ next compute globalvars, localvars and occsof.
     663$
     664    (forall oi in (rem_all_oi := all_oi))
     665	v := oi_sym(oi);
     666
     667	$ record only occurrences which are not constant,  thus ignoring
     668	$ constant variables, denotations, labels, procedures, etc.
     669
     670	if is_const(v) = om and v /= sym_om then
     671
     672	    variables with:= v;
     673	    occsof{v} with:= oi;
     674
     675	    $ in addition, separate the variables which  appear  in  the
     676	    $ user's source program, thus ignoring  temporaries,  return
     677	    $ values, etc.
     678
     679	    if is_internal(v) = om then
smff   2		if '(' notin name(v) and '$' notin name(v) then
     681		    uservars with:= v;
     682		end if;
     683	    end if;
     684	end if;
     685    end forall;
     686
     687    (forall sc in scopes)
     688	(for_sym(v, sc))
     689	    if v in variables then
     690		if sc_type(sc) = sc_proc then
     691		    localvars{sc} with:= v;
     692		else
     693		    globalvars with:= v;
     694		end if;
     695	    end if;
     696
     697	    $ mark all variables which occur only once in the input
     698
     699	    if #occsof{v} = 1 and v in uservars then
smfc  36		messages{stmtof(instno(occsof(v)))}{'i'} with:=
     701		    [ '"' + name(v) + '" appears only here.' ];
smfe  17
smfe  18	    elseif occsof{v} = {} and v in uservars then
smfe  19		messages{sc_estmt_ct(scope(v))}{'i'} with:=
smfe  20		    [ '"' + name(v) + '" is declared but not used.' ];
     702	    end if;
     703	end;	$ end for_sym;
     704
smfb  38	$ take  the  opportunity  to build  cont_scopes  which maps each
smfb  39	$ scope to a tuple of scopes which contain it.
     706
     707	scx := membof(sc) ? sc;	$ scx is the first non-procedure scope
     708
     709	case sc_type(scx) of
     710	(sc_sys):   cont_scopes(sc) := [                  sym_sys  ];
     711	(sc_lib):   cont_scopes(sc) := [        scx,      sym_sys  ];
     712	(sc_dir):   cont_scopes(sc) := [        sym_dir,  sym_sys  ];
     713	(sc_prog):  cont_scopes(sc) := [  scx,  sym_dir,  sym_sys  ];
     714	(sc_mod):   cont_scopes(sc) := [  scx,  sym_dir,  sym_sys  ];
     715	end case;
     716
     717	if sc_type(sc) = sc_proc then
     718	    cont_scopes(sc) := [ sc ] + cont_scopes(sc);
     719	end if;
     720    end forall;
     721$
     722$ finally,  compute the 'dependon' relation as the transitive closure of
     723$ 'expdepend', domain-restricted to 'varofexps'.
     724$
     725    dependon := transclose(varofexps, expdepend);
     726
     727    $ delete the static variables global to the module
     728    expsym := om;       expdepend := om;    live_temps := om;
     729
     730
     731    end procedure first_pass;
     732
     733
     734
     735
     736    procedure shortcut(lab);
     737$
     738$ this routine returns the label of the first non-empty block that can
     739$ be reached from the label lab.
     740$
     741    repr
     742	lab:			symbol;
     743	seenlabs:		sparse set(symbol);
     744	i1, i2:			elmt insts;
     745    end repr;
     746
     747    seenlabs := {};
     748
     749    loop
     750      doing
     751	i1 := first_inst(blockof(value(lab)));
     752	i2 := next_inst(i1);
     753	$ nb. the first instruction of each  basic  block  is  either  a
     754	$ q1_label or a q1_tag instruction,  and  the  last  instruction
     755	$ of each basic block is  branch  instruction.   hence  a  block
     756	$ whose  second   instruction   is   an   unconditional   branch
     757	$ instruction is a trivial block, and can be  deleted.   if  the
     758	$ first instruction is a q1_tag instruction,  the  corresponding
     759	$ case map must  be  changed.   since  this  case  should  arise
     760	$ rarely, we ignore it,  and  only  short-cut  q1_label/q1_goto-
     761	$ blocks.
     762      while
     763	opcode(i1) = q1_label and opcode(i2) = q1_goto
     764    do
     765	if lab in seenlabs then
     766	    print(' *** warning: an infinite loop starting at', lab);
     767	    quit loop;
     768	end if;
     769
     770	seenlabs   with:= lab;
     771	cut_blocks with:= blockof(i1);
     772	lab := arg1(i2);
     773    end loop;
     774
     775    return lab;
     776
     777
     778    end procedure shortcut;
     779
     780
     781
     782
     783    procedure get_temp(opc, aivs, r, i);
     784
     785    repr
     786	opc:			elmt base_opcodes;
     787	aivs:			tuple(symbol);
     788	r:			routine;
     789	i:			elmt insts;
     790	tn:			tuple(elmt base_opcodes, tuple(symbol));
     791	tsym:			symbol;
     792	scps:			sparse set(elmt base_scopes);
     793	scr, scexp:		elmt base_scopes;
     794	aj:			symbol;
     795	j:			integer;
     796    end repr;
     797
     798
     799    tn := [ opc, aivs ];	$ expression-identifying pair
     800
     801    if (tsym := expsym(tn)) = om then
     802$ first find scope of tsym, and whether it has to be analysed
     803$ locally or globally.
     804	scps := { scope(aj) : aj in aivs};
     805$$$ ???? note that here we also take into account constant arguments of
     806$$$ ???? the expression.  thus 'x + 2' where x is local to r will be
     807$$$ ???? analyzed globally, as '2' is a global constant.  the reason for
     808$$$ ???? doing so is that cases like 'x + 375', where 'x' is global but
     809$$$ ???? '375' is a constant local to r, will be handled incorrectly if
     810$$$ ???? we ignore constant arguments;  namely, this expression will be
     811$$$ ???? regarded as a global expression.  this is o.k. if and only if
     812$$$ ???? we move '375' to the symbol table of the global scope of this
     813$$$ ???? expression.  eventually we will do this, but for the time being
     814$$$ ???? we do not exclude constants.
     815
     816	scexp :=
     817	    if r in scps then
     818		r
     819$ allow for the peculiar phenomenon that '_main' belongs
     820$ to the system scope rather than to the containing program scope
     821	    elseif r = sym_main and sym_prog in scps then
     822		sym_prog
     823	    elseif (scr := scope(r)) in scps then
     824		scr
     825	    else
     826		arb scps
     827	    end;
     828
     829	tsym := add_sym(scexp);
     830$
     831$ define the relevant symbol table maps
     832$
smfc  37	name(tsym)        := exp_name(opc, aivs, i);
     834	form(tsym)        := std_form(f_gen);
     835	is_temp(tsym)     := 1;
     836	is_internal(tsym) := 1;
     837	is_read(tsym)     := 1;
     838	is_write(tsym)    := 1;
     839	is_store(tsym)    := 1;
     840
     841	if exists aj in aivs | is_stk(aj) = 1 or is_param(aj) = 1 then
     842	    is_stk(tsym)  := 1;
     843	end if;
     844$
     845$ update the relevant epression sets and maps
     846$
     847	if exists aj in aivs |
     848		aj in globalexps or
     849		is_const(aj) = om and aj /= sym_om and scope(aj) /= r
     850	then
     851	    globalexps with:= tsym;
     852	else
     853	    localexps{r} with:= tsym;
     854	end if;
     855
     856	(forall aj in aivs | is_const(aj) = om and aj /= sym_om)
     857	    expdepend{aj} with:= tsym;
     858	end forall;
     859
     860	expsym(tn)    := tsym;
     861        opcexp(tsym)  := opc;
     862        argsexp(tsym) := aivs;
     863        allexps    with:= tsym;
     864	live_temps with:= tsym;
     865
     866    else
     867	$ we re-use  the  same  temporary  for  this  expression.   this
     868	$ implies that we have to  change the temporary  to an  internal
     869	$ variable since the storage  allocation  algorithm assumes that
smfi  22	$ each temporary is used exactly once.
     871	is_temp(tsym) := om;
     872    end if;
     873
     874    return tsym;
     875
     876
     877    end procedure get_temp;
     878
     879
     880
     881
     882    procedure transclose(a, rel);
     883
     884$ compute the transitive closure of the relation rel, domain-restricted
     885$ to the set a.
     886
     887$ although transclose is a general routine, its sole use in
     888$ first_pass justifies the representations below.
     889
     890    repr
     891	a:			sparse set(symbol);
     892	rel:			sparse mmap{symbol}
     893				    remote set(expression);
     894	tcl:			sparse mmap{symbol}
     895				    remote set(expression);
     896
     897	x:			symbol;
     898	y:			expression;
     899	tclx, newx, delta:	remote set(expression);
     900    end repr;
     901
     902    tcl := {};
     903    (forall x in a)
     904	tclx := newx := rel{x};
     905	(while newx /= {})
     906	    y from newx;
     907	    delta := rel{y} - tclx;
     908	    newx +:= delta;
     909	    tclx +:= delta;
     910	end while;
     911	tcl{x} := tclx;
     912    end forall;
     913
     914    return tcl;
     915
     916    end procedure transclose;
     917
     918
     919
     920
smfc  38    procedure exp_name(opc, aivs, i);
     922$
     923    repr
smfc  39	opc:			elmt base_opcodes;
smfc  40	aivs:			tuple(symbol);
     924	i:			elmt insts;
smfc  41	a:			tuple(symbol);
     925    end repr;
     926
     927    if 'c' in dump_string then return 't' + str i; end if;
     928
smfc  42    if opc = opcode(i) then
smfc  43	return format_inst(i, aivs);
smfc  44    elseif opc in ops_retrieve and opcode(i) in ops_sin then
smfc  45	a := aivs(2..); a(#aivs+1) := aivs(1);
smfc  46	return format_inst(i, a);
smfc  47    else
smfc  48	return 't' + str i;
smfc  49    end if;
     931
     932
     933    end procedure exp_name;
     934
     935
       1 .=member smem9a
       2
       3
       4    procedure satisfy_members;
       5$
       6$ this routine satisfies missing  members, so that we  get  the  program
       7$ into a normal form.  this simplifies the  optimisation  of  separately
       8$ compiled members considerably, and assures that we will always have  a
       9$ main program.
      10$
      11$ a member is a library, a directory, a program, or a module.
      12$
      13$ the semantic pass can compile program and module  members  separately,
      14$ provided that the program has a directory specifying the rights of the
      15$ individual modules w.r.t. read/write access to globals, and  what pro-
      16$ cedures are imported/exported by which member.  libraries are by their
      17$ definition independent to separate compilation since we always require
      18$ all libraries accessed by any member to be present during the semantic
      19$ pass.  thus the following are some examples for valid  separate compi-
      20$ lations:
      21$
      22$ 1. zero or more libraries
      23$ 2. zero or more libraries, plus a directory
      24$ 3. a directory, plus a main program
      25$ 4. a directory, plus zero or more modules
      26$
      27$ note that it does not make sense to speak about  separate  compilation
      28$ for a simple setl program, as such a program  consists  of  a  program
      29$ scope only.
      30$
      31$ to simplify our algorithms, we normalise the input so that we have:
      32$
      33$	zero or more libraries,
      34$	followed by a directory,
      35$	followed by a main program,
      36$	followed by zero or more modules.
      37$
      38$ this means that in case 1, above, we have to generate a new  directory
      39$ and a new main program, and in cases 2 and 4, a main program.
      40$
      41    repr
      42	j:			integer 0..65536;
      43	s:			symbol;
      44	sc:			elmt base_scopes;
      45    end repr;
      46$
      47$ if the input supplied a directory, then simply return;  otherwise, add
      48$ a new scope for a dummy directory, and initialise it.
      49$
      50    if sym_dir /= om then return; end if;
      51
      52    sym_dir := s := newat;	$ add a new scope for the directory
      53
      54    $ initialise the relevant scope maps
      55    sc_type(sym_dir)     := sc_dir;
      56    sc_nprocs(sym_dir)   := 0;
      57    sc_stmt_ct(sym_dir)  := 0;
      58    sc_estmt_ct(sym_dir) := 0;
      59
      60    last_sym(sym_dir) := first_sym(sym_dir) := sym_dir;
      61
      62    $ add the new scope to the tuple of all scopes
smfi  23    if exists sc = scopes(j) |
smfi  24	    sc_type(sc) = sc_prog or sc_type(sc) = sc_mod then
      64	$ insert the directory before the main program
      65	scopes(j..j-1) := [ sym_dir ];
      66    else
      67	$ input has only libraries
      68	$ (if it had main program, we would have found its scope above.)
      69	$ (if it had no main program, but zero or more modules, it would
      70	$ have a directory.)
      71	$ (note that this means that we will build a dummy main  program
      72	$ as well.)
      73	scopes with:= sym_dir;
      74    end if;
      75
      76    $ initialise the symbol table entry just created
      77    $ (note that a direcory member has no value due to a current bug  in
      78    $ grm/prs/sem - implementation restriction...)
      79    name(s)    := '_directory';
      80    scope(s)   := sym_dir;
      81    form(s)    := std_form(f_memb);
      82$
      83$ if the input supplied a main program, we move it into the directory we
      84$ just created, and for simplicity mark  the  directory  as  seen,  thus
      85$ eventually writing it out for the code generator.  this  is  ok  since
      86$ we look at a simple program, which cannot be part of a  separate  com-
      87$ pilation.  if the input did not supply a main  program,  we  create  a
      88$ dummy main program and have it reference all libraries.  note that  if
      89$ we don't have a directory, we cannot have any  modules  either.   this
      90$ is a consequence of the definition of module programs.
      91$
      92    if sym_prog /= om then	$ we have a main program: move it
      93
      94	last_sym(sym_dir)   := next_sym(sym_dir) := sym_prog;
      95	first_sym(sym_prog) := next_sym(sym_prog);
      96	next_sym(sym_prog)  := om;
      97	if first_sym(sym_prog) = om then last_sym(sym_prog) := om; end;
      98
      99	scope(sym_prog) := sym_dir;
     100	all_modules with:= sym_prog;
     101
     102	is_seen(sym_dir) := 1;
     103
     104    else
     105	sym_prog := s := newat;	$ add a new program scope
     106	last_sym(sym_dir) := next_sym(sym_dir) := sym_prog;
     107
     108	$ (the relevant scope maps will be initialised in satisfy_procs)
     109
     110	$ initialise the relevant symbol table maps
     111	name(s)     := '_program';
     112	scope(s)    := sym_dir;
     113	form(s)     := std_form(f_memb);
     114	is_const(s) := 1;
     115	value(s)    := [ { sc in scopes | sc_type(sc) = sc_lib },
     116			 {}, {}, {}, {}    ];
     117    end if;
     118
     119
     120    end procedure satisfy_members;
     121
     122
       1 .=member sprc9b
       2
       3
       4    procedure satisfy_procs;
       5$
       6$ this routine generates dummy routines  for  all  unsatisfied  external
       7$ procedures.
       8$
       9$ before we outline our algorithm, let us stress once more that  a  mem-
      10$ ber can always import all routines exported by the libraries it  refe-
      11$ rences.
      12$
      13$ we begin by assuming that all the modules are  missing,  then  iterate
      14$ over the list of supplied modules, removing  them  from  missing_mods.
      15$ this iteration is done by scanning forward through  the  scopes  tuple
      16$ which is created by the input interface and contains a list of all the
      17$ modules seen in the input.
      18$
      19$ then we determine the set of all missing procedures, namely the set of
      20$ all procedures exported by a missing module.  at  the  same  time,  we
      21$ determine which globals each of these missing procedures could  access
      22$ and which other procedures they might call.  (the latter  set  is,  of
      23$ course, the set of all procedures imported by the module).
      24$
      25$ finally we fill in the dummy bodies of  the  missing  procedures.   we
      26$ iterate over missing_procs building one dummy body at  a  time.   each
      27$ time we process a procedure p we look for all equivalent  procedures q
      28$ and make them aliases for p.
      29$
      30    repr
      31	l:			sparse set(elmt base_scopes);
      32	r, w:			sparse set(symbol);
      33	i, e:			sparse set(routine);
      34	missing_mods:		sparse set(elmt base_scopes);
      35	missing_procs:		sparse set(routine);
      36	lb, m, s:		elmt base_scopes;
      37	p, q:			routine;
      38	rds, wrts:		sparse mmap{routine}
      39				    sparse set(symbol);
      40	clls:			sparse mmap{routine}
      41				    sparse set(routine);
      42    end repr;
      43
      44
      45    $ recall that all_modules is the set of all  modules  referenced  by
      46    $ the directory, and is build by get_symtab.
      47    $ scopes is a tuple containing all the scopes seen in the input.
      48
      49    missing_mods := { m in all_modules | m notin scopes };
      50
      51    if sym_prog notin all_modules then
      52	$ the main program was generated by satisfy_members:  we have to
      53	$ build a body for it.
      54	missing_mods with:= sym_prog;
      55    end if;
      56$
      57$ find the libraries used, the variables read and written, and the  pro-
      58$ cedures imported and exported.
      59$
      60    missing_procs := {};    rds := {};    wrts := {};    clls := {};
      61
      62    (forall m in missing_mods)
      63
      64	$ (the value of a member is a quintuple, giving  (in this order)
      65	$ the libraries referenced, the globals read, the globals  writ-
      66	$ ten, the procedures imported, and the procedures exported.)
      67	[ l, r, w, i, e ] := value(m);
      68
      69	$ the missing procedures for this module are the  procedures  of
      70	$ its exports list.
      71	missing_procs +:= e;
      72
      73	$ open the scope for this module  and  initialise  the  relevant
      74	$ scope maps.
      75	if m = sym_prog then
      76	    sc_type(m) := sc_prog;
      77
      78	    $ we can (conceptually) think that the  main  program  scope
      79	    $ sym_prog exports the main program  procedure  sym_main  to
      80	    $ the system scope.
      81	    e with:= sym_main;    missing_procs with:= sym_main;
      82
      83	else
      84	    sc_type(m) := sc_mod;
      85	end if;
      86
      87	$ initialise the remaining relevant scope maps
      88	sc_nprocs(m)   := #e;
      89	sc_stmt_ct(m)  := 0;
      90	sc_estmt_ct(m) := 0;
      91	scopes      with:= m;
      92	all_modules with:= m;
      93
      94	$ the imports list of the missing procedure is really the  union
      95	$ of its imports list and of all procedures exported by all  the
      96	$ libraries referenced.
      97	i := i +/[ value(lb)(5) : lb in l ];
      98
      99	(forall p in e)
     100	    $ initialise the routine scope
     101	    sc_type(p)     := sc_proc;
     102	    sc_nprocs(p)   := 0;
smfi  25	    sc_stmt_ct(p)  := 1;
smfi  26	    sc_estmt_ct(p) := 1;
     105	    scopes with:= p;
     106	    routs  with:= p;
     107	    membof(p)      := m;
     108
     109	    $ all procedures exported by  this  module  are  assumed  to
     110	    $ read, write and call all the  globals  read,  the  globals
     111	    $ written, and procedures imported by this module.
     112	    rds{p} := r;    wrts{p} := w;    clls{p} := i;
     113	end forall;
     114    end forall;
     115$
     116$ finally fill in the dummy bodies of the missing procedures.
     117$
     118    (while missing_procs /= {})
     119
     120	p from missing_procs;
     121
     122	bld_body(p, rds{p}, wrts{p}, clls{p});
     123
     124	if p = sym_main then continue; end if;
     125
     126	loop while
     127	    (exists q in missing_procs | q /= sym_main and
     128		rvary(p)  = rvary(q)  and   $ varying # of arguments
     129		rptyps(p) = rptyps(q) and   $ same parameter types
     130		scope(p)  = scope(q)  and   $ same scope
     131		form(p)   = form(q)   and   $ same form
     132		rds{p}    = rds{q}    and   $ same variables read
     133		wrts{p}   = wrts{q}   and   $ same variables written
     134		clls{p}   = clls{q}         $ same procedures called
     135	    )
     136	do
     137	    missing_procs less:= q;
     138	    alias(q) := p;
     139
     140	    scopes := [ m in scopes | m /= q ];
     141	    routs less:= q;
     142	    membof      lessf:= q;
     143
     144	    sc_type     lessf:= q;
     145	    sc_nprocs   lessf:= q;
     146	    sc_stmt_ct  lessf:= q;
     147	    sc_estmt_ct lessf:= q;
     148	end loop;
     149    end while;
     150
     151
     152    end procedure satisfy_procs;
     153
     154
       1 .=member blbd9c
       2
       3
       4    procedure bld_body(p, rds, wrts, clls);
       5$
       6$ this routine generates a dummy  procedure  body  for  the  unsatisfied
       7$ external procedure p.  rds is the set of global variables  read,  wrts
       8$ the set of global variables written, and clls the  set  of  precedures
       9$ called by p.
      10$
      11$ each dummy procedure body looks as follows.  we start  by  adding  new
      12$ symbol table entries for the formal parameters of p, and then  proceed
      13$ to generate, after the standard code sequence for a  routine  prelude,
      14$ random uses and definitions of each of the formal  parameters,  depen-
      15$ ding on how they are declared (ie. rd, rw, or wr).  next  we  generate
      16$ code to use each variable in rds, followed by code to use  and  define
      17$ each variable in wrts, followed by a call to each procedure called  by
      18$ p, ie. the procedures mentioned in clls.  finally, after  we  added  a
      19$ random branch back to start of p, we define p's return value, and  end
      20$ p with the standard routine postlude.  note that  we  must  include  a
      21$ random jump to the routine's stop block.
      22$
      23    repr
      24	p:			routine;
      25	rds, wrts:		sparse set(symbol);
      26	clls:			sparse set(routine);
      27	l:			symbol;
      28	fms:			tuple(elmt forms);
      29	tps:			tuple(symbol);
      30	j:			integer 0..65536;
      31	sym:			symbol;
smfi  27	q:			routine;
      32    end repr;
      33
      34    $ build an entry block for the procedure
      35    bld_entry(p);
      36
      37    $ add 'l:' and save a pointer to l.  we  will  build  a  conditional
      38    $ branch back to l at the end of the routine.
      39    l := add_label(p);
      40    bld_label(p, l);
      41
      42    $ generate symbols for the parameters and build dummy uses and defi-
      43    $ nitions.
      44
      45    fms := ft_elmt(form(p));	$ forms of parameters
      46    tps := rptyps(p);		$ types of parameters
      47
      48    (forall j in [ 1..#tps ])
      49	sym := add_sym(p);	$ build symbol table entry
      50
      51	is_param(sym) := 1;
      52	form(sym)     := fms(j);
      53
      54	case name(tps(j)) of
      55
      56	('rd'):			$ read-only parameter: generate use
      57
      58	    is_read(sym) := 1;
      59	    bld_use(p, sym);
      60
      61	('wr'):			$ write-only parameter: generate def
      62
      63	    is_write(sym) := 1;
      64	    bld_def(p, sym);
      65
      66	('rw'):			$ read-write parameter
      67
      68	    is_read(sym) := 1;
      69	    is_write(sym) := 1;
      70
      71	    bld_use(p, sym);
      72	    bld_def(p, sym);
      73
      74	end case;
      75    end forall;
      76
      77    $ add uses of reads variables
      78    (forall sym in rds) bld_use(p, sym); end forall;
      79
      80    $ add definitions and uses of writes variables
      81    (forall sym in wrts) bld_use(p, sym); bld_def(p, sym); end forall;
      82
      83    $ add calls to imported procedures
smfi  28    (forall q in clls) bld_call(p, q); end forall;
      85
      86    $ build a conditional branch to the top of the routine
      87    add_inst(last_block(p), q1_ifrand, l);
      88
      89    $ each procedure p has a global variable associated with it which is
      90    $ used to return the value of function  calls.   the  name  of  this
      91    $ is given by rretn(p).  build an assignment to it
      92    bld_def(p, rretn(p));
      93
      94    $ build exit and stop blocks
      95    bld_exitstop(p);
smfk  32    assert opcode(first_inst(first_block(p))) = q1_entry;
smfk  33    stmtof(first_inst(first_block(p))) := 1;	$ for initialised vars
      96
      97
      98    end procedure bld_body;
      99
     100
       1 .=member blde9d
       2
       3
       4    procedure bld_entry(p);
       5$
       6$ this routine builds the entry block for p.
       7$
       8    repr
       9	p:			routine;
      10	b:			elmt blocks;
      11    end repr;
      12
      13
      14    b := add_block(om, p, true);$ add a block to the end of p
      15    add_inst(b, q1_entry, p);   $ add instruction to the end of b
      16    rentry(p) := b;		$ record that this is the entry block
      17
      18
      19    end procedure bld_entry;
      20
      21
      22
      23
      24    procedure bld_label(p, l);
      25$
      26$ add 'sym:' to the code for procedure p.
      27$
      28    repr
      29	p:			routine;
      30	l:			symbol;
      31	b:			elmt blocks;
      32	i:			elmt insts;
      33    end repr;
      34
      35
      36    b := last_block(p);		$ current end of p
      37
      38    add_inst(b, q1_goto, l);	$ add a branch to l
      39
      40    $ add a new block to define the label 'l'
      41    b := add_block(b, p, true);
      42    i := add_inst(b, q1_label, l);
      43    value(l) := i;
      44
      45
      46    end procedure bld_label;
      47
      48
      49
      50
      51    procedure bld_use(p, sym);
      52$
      53$ this routine adds the code for
      54$
      55$        if random [ true, false ] then use(sym); end if;
      56$
      57$ to the end of procedure 'p'.  'use' is a general use of sym.
      58$
      59    repr
      60	p:			routine;
      61	sym:			symbol;
      62	b:			elmt blocks;
      63	i:			elmt insts;
      64	l:			symbol;
      65    end repr;
      66
      67
      68    b := last_block(p);		$ current end of p
      69    l := add_label(p);		$ label for end
      70
      71    add_inst(b, q1_ifrand, l  );
      72    add_inst(b, q1_use,    sym);
      73    add_inst(b, q1_goto,   l  );
      74
      75    $ add a new block for the end and define l
      76    b := add_block(b, p, true);
      77    i := add_inst(b, q1_label, l);
      78    value(l) := i;
      79
      80
      81    end procedure bld_use;
      82
      83
      84
      85
      86    procedure bld_def(p, sym);
      87$
      88$ this routine adds the code for
      89$
      90$        if random [ true, false ] then def(sym); end if;
      91$
      92$ to the end of procedure 'p'.  'def' is a general definition of sym.
      93$
      94    repr
      95	p:			routine;
      96	sym:			symbol;
      97	b:			elmt blocks;
      98	i:			elmt insts;
      99	l:			symbol;
     100    end repr;
     101
     102
     103    b := last_block(p);		$ current end of p
     104    l := add_label(p);		$ label for end
     105
     106    add_inst(b, q1_ifrand, l  );
     107    add_inst(b, q1_def,    sym);
     108    add_inst(b, q1_goto,   l  );
     109
     110    $ add a new block for the end and define l
     111    b := add_block(b, p, true);
     112    i := add_inst(b, q1_label, l);
     113    value(l) := i;
     114
     115
     116    end procedure bld_def;
     117
     118
     119
     120
     121    procedure bld_call(p, q);
     122$
     123$ this routine adds the code for
     124$
     125$	if random [ true, false ] then q(...); end if;
     126$
     127$ to the end of procedure p.
     128$
     129    repr
     130	p, q:			routine;
     131	b:			elmt blocks;
     132	i:			elmt insts;
     133	l:			symbol;
     134	a:			tuple(symbol);
     135	x:			symbol;
     136	j:			integer 0..65536;
     137    end repr;
     138
     139
     140    b := last_block(p);		$ current end of p
     141    l := add_label(p);		$ label for end
     142
     143    add_inst(b, q1_ifrand, l);	$ add a random branch to the end block
     144
     145$ next we must invent arguments for the procedure  call.  since we  have
     146$ already emitted uses and  definitions  for  all  the  relevant  global
     147$ variables, we can assume that all the arguments are local.
     148
     149    $ generate new local variables for the arguments and define them
     150    a := [ add_var(p) : j in [ 1..rnargs(q) ] ];
     151    (forall x in a) bld_def(p, x); end forall;
smfi  29    b := last_block(p);		$ current end of p after bld_def call
     152
smfi  30    $ emit the argins
     154    (forall x = a(j))
     155	if name(rptyps(q)(j)) /= 'wr' then
     156	    add_inst(b, q1_argin,      x, q, add_int(p, j));
     157	else
     158	    add_inst(b, q1_argin, sym_om, q, add_int(p, j));
     159	end if;
     160    end forall;
     161
smfi  31    $ emit the call block
smfi  32    bld_label(p, add_label(p)); $ branch to and define the call block
smfi  33    add_inst(last_block(p), q1_call, q, add_int(p, rnargs(q)));
smfi  34    bld_label(p, add_label(p)); $ branch to and define the successor
smfi  35    b := last_block(p);		$ current end of p after call block
     164
     165    $ emit argouts
     166    (forall x = a(j))
     167	if name(rptyps(q)(j)) /= 'rd' then
     168	    add_inst(b,   q1_free, x, q, add_int(p, j));
     169	else
     170	    add_inst(b, q1_argout, x, q, add_int(p, j));
     171	end if;
     172    end forall;
     173
smfi  36    bld_label(p, l);		$ define the end label
     180
     181
     182    end procedure bld_call;
     183
     184
     185
     186
     187    procedure bld_exitstop(p);
     188$
     189$ this routine builds the exit and stop blocks for p.
     190$
     191    repr
     192	p:			routine;
     193	b:			elmt blocks;
     194	i:			elmt insts;
     195	l1, l2:			symbol;
     196    end repr;
     197
     198
     199    b := last_block(p);		$ current end of p
     200    l1 := add_label(p);		$ label for exit block
     201    l2 := add_label(p);		$ label for stop block
     202
     203    add_inst(b, q1_ifrand, l2);	$ add a random branch to the stop block
     204    add_inst(b, q1_goto,   l1);	$ branch to the exit block
     205
     206    $ add a new block, the exit block
     207    b := add_block(b, p, true);
     208    i := add_inst(b, q1_label, l1);
     209    value(l1) := i;
     210
     211    add_inst(b, q1_exit, p);
     212    rexit(p) := b;
     213
     214    $ add a new block, the stop block
     215    b := add_block(b, p, true);
     216    i := add_inst(b, q1_label, l2);
     217    value(l2) := i;
     218
     219    add_inst(b, q1_stop);
     220    rstop(p) := b;
     221
     222
     223    end procedure bld_exitstop;
     224
     225
     226    end module setl_optimizer - optinit;
     227
     228
       1 .=member end17a
       2
       3
       4    module setl_optimizer - optend;
       5
       6
       7    repr
       8	clean_up:		procedure;
       9    end repr;
      10
      11
      12    procedure opt_term;
      13$
      14    const binary;
      15    const tab = '	';
      16    const blank_tab = ' 	';
      17    const alphameric =	'abcdefghijklmnopqrstuvwxyz'
      18			'abcdefghijklmnopqrstuvwxyz'
      19			'0123456789'
      20			'_';
      21    const headers =   [ 'input interface:               ',
      22			'preliminary first pass:        ',
      23			'call graph & interval analysis:',
      24			'initial live variable analysis:',
      25			'available expression analysis: ',
      26			'bfrom computation:             ',
smfb  40			'flow-constant loop detection:  ',
      27			'type analysis:                 ',
      28			'data structure selection:      ',
      29			'conversion optimisation:       ',
      30			'copy optimisation:             ',
      31			'output interface:              ',
      32			'total:                         '  ];
      33
      34    repr
      35	l, s, v:		string;
      36	sc:			elmt base_scopes;
      37	todo:			remote set(elmt base_scopes);
      38	source_map:		smap(integer) tuple(string);
      39	message:		tuple(string);
      40	src_line, msg_line:	string;
      41	i, k:			integer 0..65536;
      42	j, stmt_lo, stmt_hi:	integer;
      43	elapsed_time:		integer;
      44	total_time:		integer;
      45	dd, hh, mm, ss, tt:	string;
      46	pp:			string;
      47    end repr;
      48
      49
      50
smfk  34    title('cims.setl.' + prog_level);
      52
      53    s := getspp('interface=all/all');
      54
      55    if #s = 0 then
      56	todo := {};
      57    elseif s = 'all' then
      58$$--  all forms are currently allocated in the system scope, so that
      59$$--  all optimiser-introduced bases appear there.  hence we must
      60$$--  include the system scope here.
      61$$-- 	todo := { sc : sc in scopes | sc_type(sc) /= sc_sys };
      62	todo := { sc : sc in scopes };
      63    else
      64	loop
      65	  init	todo := {};
      66		break(s, alphameric);
      67	  doing	v := span(s, alphameric);
      68		break(s, alphameric);
      69	  while v /= om
      70	do
      71	    todo +:= { sc in scopes | name(sc) = v };
      72	end loop;
      73    end if;
      74
      75    print_summary(todo);
      76
      77    open(ssm_file, binary); getb(ssm_file, source_map); close(ssm_file);
      78
      79    s := getspp('summary=all/all');
      80
      81    if #s = 0 then
      82	todo := {};
      83    elseif s = 'all' then
      84	todo := { sc : sc in scopes | sc_type(sc) /= sc_sys };
      85    else
      86	loop
      87	  init	todo := {};
      88		break(s, alphameric);
      89	  doing	v := span(s, alphameric);
      90		break(s, alphameric);
      91	  while v /= om
      92	do
      93	    todo +:= { sc in scopes | name(sc) = v };
      94	end loop;
      95    end if;
      96
      97    (forall sc = scopes(i) | is_seen(sc) /= om and sc in todo)
      98
      99	stmt_lo := sc_stmt_ct(sc);
smfi  37	if exists k in [ i+1..#scopes ] |
smfi  38		scopes(k) /= om and is_seen(scopes(k)) /= om then
smfi  39	    stmt_hi := sc_stmt_ct(scopes(k)) - 1;
smfi  40	else
smfi  41	    stmt_hi := #source_map;
smfi  42	end if;
     101
     102	$ if this directory was generated by the optimiser, ignore it.
     103	if sc_type(sc) = sc_dir and stmt_lo = 0 then continue; end if;
     104
     105	if at_flag then
     106	    src_line := '' +/[ source_map(stmt_lo)(j) :
     107				    j in [ 1..#source_map(stmt_lo) ] ];
     108	    span(src_line, blank_tab);    rspan(src_line, blank_tab);
     109	    title(src_line);
     110	end if;
     111
     112	(forall j in [ stmt_lo..stmt_hi ])
     113	    (forall src_line in source_map(j))
     114		print(lpad(str (j-stmt_lo+1), 6) + tab + src_line);
     115	    end forall;
smfd   2	    (forall l in 'fewis' | l in getspp('all=fewi/fewis'))
     117		(forall message in messages{j}{l})
     118		    if #message = 0 then continue; end if;
     119		    print('opt-' + l + '>' + tab + message(1));
     120		    (forall k in [ 2..#message ])
smfk  35			print(tab + '  ' + message(k));
     122		    end forall;
     123		end forall;
     124	    end forall;
     125	end forall;
     126    end forall;
     127
     128    $ reverse the temporary changes to the q1 code
     129    clean_up;
     130
     131    if 's' in dump_string then dmp(om, 'symtab');  end if;
     132    if 'f' in dump_string then dmp(om, 'formtab'); end if;
     133    if 'c' in dump_string then dmp(om, 'codetab'); end if;
     134
     135    $ write the q1 file for the code generator
     136    open(q1_file, binary);   write_q1;   close(q1_file);
     137    statistics with:= time;
smfk  36
smfk  37    if not lcs_flag then  return;  end if;
     138
     139    title('cims.setl.' + prog_level + ' - execution statistics');
     140
     141    total_time := statistics(#statistics) - statistics(1);
     142
     143    (forall i in [ 1..#statistics ])
     144
     145	if i = #statistics then
     146	    elapsed_time := total_time;
     147	    print;
     148	else
     149	    elapsed_time := statistics(i+1) - statistics(i);
     150	end if;
     151
     152	tt := str (elapsed_time              mod 1000);
     153	ss := str (elapsed_time div     1000 mod   60);
     154	mm := str (elapsed_time div    60000 mod   60);
     155	hh := str (elapsed_time div  3600000 mod   24);
     156	dd := str (elapsed_time div 86400000         );
     157	if #tt = 1 then tt := '00' + tt; end if;
     158	if #tt = 2 then tt :=  '0' + tt; end if;
     159	if #ss = 1 then ss :=  '0' + ss; end if;
     160	if #mm = 1 then mm :=  '0' + mm; end if;
     161	if #hh = 1 then hh :=  '0' + hh; end if;
     162	if #dd = 1 then dd :=  ' ' + dd; end if;
     163
     164	pp := str fix(1000.0*(float elapsed_time/float total_time)+0.5);
     165
     166	print(
     167	    headers(i),
     168	    dd, hh + ':' + mm + ':' + ss + '.' + tt,
     169	    lpad(str(elapsed_time div 1000), 11) + '.' + tt,
     170	    lpad(pp(1..#pp-1), 6) + '.' + pp(#pp) + '%'
     171	    );
     172    end forall;
     173
     174
     175    end procedure opt_term;
     176
     177
     178
     179
     180    procedure clean_up;
     181$
     182$ this routine scans the q1 code and restores some of the changes that
     183$ have been made only for the sake of the optimizer itself and which are
     184$ not acceptable by the code generator.  specifically, the following is
     185$ done in this routine:
     186$
     187$ 1. change back q1_arbb + q1_lessb to q1_fromb, and similarly for
     188$    q1_frome.  (q1_from is currently not restored, as it is actually
     189$    equivalent to the arb + less sequence.)
     190$
     191$ 2. eliminate the last argument of sinister assignments, added in the
     192$    initialization phase, and which is equal to the first argument.
     193$    note that in principle the data type or representation of the last
     194$    argument may differ from that of the first (output) argument;
     195$    however, the type finder and automatic data-structure selection
     196$    choice phases should function in such a manner as to guarantee that
     197$    no conversion will be required between these two arguments.
     199$
     200$ 3. restore the argin and argout instructions.  this amounts to
     201$    (a) if a system routine has been called, change the temporary
     202$        sargin and sargout opcodes back to argin and argout;
     203$    (b) otherwise, remove the extra argument added to these
     204$        instructions in the initialization phase.
     205$
     206$ 4. the handling of external procedures in the initialization phase is
     207$    ugly enough to merit searching for a better way.  for this reason,
     208$    this routine assumes that there are no such external procedures in
     209$    the code.  this should of course be later modified.
     211$
     212$ 5. temporaries are treated in the code generator in a different way
     213$    than in the optimizer:  the code generator assumes that a
     214$    temporary is dead after its first use, so that its storage and
     215$    symbol table entry are freed and can be used by other temporaries.
     216$    the optimizer, though, assigns a unique temporary to each
     217$    computation, so that any computation occurring more than once in
     218$    the code should be assigned to an internal variable (i.e. a symbol
     219$    whose is_temp bit is off) rather than to a temporary (is_temp is
     220$    set)
     221$
     222    repr
     223	noccs_temp:		smap(symbol) integer;
     224	r:			routine;
     225	b:			elmt blocks;
     226	pi, i, ni:		elmt insts;
     227	opc:			elmt base_opcodes;
     228	junk:			*;
     229	a:			symbol;
     230	t, t1, t2:		symbol;
     231	avail_temps:		remote mmap{elmt base_scopes}
     232				    sparse set(symbol);
     233	j:			integer 0..65536;
     234    end repr;
     235
     236    (forall r in routs)
     237
     238	avail_temps := {};
     239
     240        (for_block(b, r))
     241	    pi := om;
     242	    (for_inst(i, b))
     243		opc := opcode(i);
     244		case opc of
     245
     246		(q1_argin):
     247		    junk fromb args(i);
     248
     249		(q1_argout):
     250		    junk frome args(i);
     251
     252		(q1_sargin):
     253		    opcode(i) := q1_argin;
     254
     255		(q1_sargout):
     256		    opcode(i) := q1_argout;
     257
     258		(q1_sof, q1_sofa, q1_ssubst, q1_send):
     259		    junk frome args(i);
     260
     261		(q1_next):
     262		    junk frome args(i);
     263
     264		(q1_arbb):
     265		    ni := next_inst(i);
     266		    $ assert ni /= om;
     267		    $ assert opcode(ni) = q1_lessb;
     268		    $ assert arg1(i)  = arg3(ni);
     269		    $ assert arg2(i)  = arg1(ni);
     270		    $ assert arg1(ni) = arg2(ni);
     271		    opcode(i)    := q1_fromb;
     272		    copy_flag(i) := copy_flag(ni);
     273
     274		(q1_arbe):
     275		    ni := next_inst(i);
     276		    $ assert ni /= om;
     277		    $ assert opcode(ni) = q1_lesse;
     278		    $ assert arg1(i)  = arg3(ni);
     279		    $ assert arg2(i)  = arg1(ni);
     280		    $ assert arg1(ni) = arg2(ni);
     281		    opcode(i)    := q1_frome;
     282		    copy_flag(i) := copy_flag(ni);
     283
     284		(q1_lessb, q1_lesse, q1_def, q1_noop):
     285		    del_inst(i, pi, b);
     286		    continue;
     287
     288		(q1_push):
     289		    args(i) with:= arg1(push_former(i));
     290
     291		end case;
     292
     293		if opc in ops_ovar and
     294			is_temp(t := args(i)(1)) /= om then
     295
     296		    if (t1 := alias(t)) /= om
     297			    and is_seen(t) = om
     298			    and is_seen(t1) /= om then
     299			alias(t)    := alias(t1) ? t1;
     300			is_store(t) := om;
     301			is_seen(t)  := 1;
     302
     303		    elseif is_seen(t) = om then
     304			is_seen(t) := 1;
     305			if t1 /= om then is_seen(t1) := 1; end if;
     306
     307			if avail_temps{scope(t)} /= {} then
     308			    t2 from avail_temps{scope(t)};
     309
     310			    alias(t)	:= t2;
     311			    is_store(t) := om;
     312
     313			    if t1 /= om then
     314				alias(t1)    := t2;
     315				is_store(t1) := om;
     316			    end if;
     317			end if;
     318		    end if;
     319		end if;
     320
     321		(forall j in [ first_ivar(opc)..#args(i) ] |
     322			    is_temp(t := args(i)(j)) /= om and
     323			    opc /= q1_push    )
     324		    avail_temps{scope(t)} with:= alias(t) ? t;
     325		end forall;
     326		pi := i;
     327	    end;
     328	end;
     329    end forall;
     330
     331    end procedure clean_up;
     332
     333
     334    end module setl_optimizer - optend;
     335
     336
       1 .=member inta10
       2
       3
       4    module setl_optimizer - interval_analysis;
       5$
       6$ this module contains the interval analysis algorithm described in
       7$ section 3 of the technical report.
       8$
       9$ flow graph analysis produces two maps which serve as input to the
      10$ interval analysis:
      11$
      12$ 1. cessor:	the successor map for basic blocks
      13$
      14$ 2. pred:	the predecessor map for basic blocks
      15$
      16$ interval analysis produces five maps:
      17$
      18$ 1. intof:	a map from each node to the interval immediately
      19$		containing it.
      20$
      21$ 2. ints:	maps each routine to a tuple of all its intervals in
      22$		reverse preorder.  note that iterating over ints(rout)
      23$		is equivalent to iterating from innermost to outermost
      24$		interval.
      25$
      26$ 3. int_nodes: a map sending each interval into a tuple containing the
      27$		nodes of the interval in reverse postorder.  iterating
      28$		over int_nodes(i) is equivalent to iterating forward
      29$		over the nodes in i.
      30$
      31$ 4. proper_ints: the set of proper (reducible) intervals.
      32$
      33$ 5. vedges:	the set of all virtual edges added to the flow graph
      34$		during interval analysis. a virtual edge is an edge
      35$		having the form (i, v), where i is an interval and v
      36$		is a node outside i which is a successor of some node
      37$		in i.
      38$
      39$ all these variables are assumed to be globally accessible in the
      40$ setl optimizer.  additional global variables that are accessed in
      41$ this module are:
      42$
      43$ routs:	set of all routines in the program being analyzed.
      44$
      45$ rentry:	maps each routine to its entry block.
      46$
      47$ rexit:	maps each routine to its exit (return) block.
      48$
      49$ rstop:	maps each routine to its stop block, if it exists.
      50$
      51$ routof:	maps each basic block to the routine containing it.
      52$
      53$ the module contains three principal routines:
      54$
      55$ 1. find_intervals:	iterates over 'routs' calling other routines
      56$
      57$ 2. get_graph:		builds a flow graph for a routine.
      58$
      59$ 3. find_ints:		finds the intervals of a flow graph.
      60$
      61$ the following variables are used globally during interval analysis:
      62$
      63    var
      64	nodeno,			$ preorder node numbering
      65	postno,			$ postorder numbering
      66	ndescs,			$ number of descendants of each node
      67	nodes,			$ tuple of nodes in preorder
      68	postnodes,		$ tuple of nodes in postorder
      69	npre,			$ current pos in preorder numbering
      70	npost,			$ current pos in postorder numbering
      71	seen,			$ nodes already in spanning tree
      72	impropers;		$ set of 'heads' of multiple entry loops
      73
      74    init
      75	impropers := {};
      76
      77
      78    repr
      79	nodeno:			smap(elmt blocks) integer;
      80	postno:			smap(elmt blocks) integer;
      81	ndescs:			smap(elmt blocks) integer;
      82	nodes:			tuple(elmt blocks);
      83	postnodes:		tuple(elmt blocks);
      84	npre:			integer;
      85	npost:			integer;
      86	seen:			sparse set(elmt blocks);
      87	impropers:		sparse set(elmt blocks);
      88
      89	.intof_lim:		operator(elmt blocks) elmt blocks;
      90	find_graph:		procedure(routine);
      91	find_ints:		procedure(routine);
      92	update:			procedure(
      93				  elmt blocks,
      94				  elmt blocks,
      95				  sparse set(elmt blocks)
      96				  );
      97	dfst:			procedure(elmt blocks);
      98	get_targ:		procedure(elmt blocks) elmt blocks;
      99    end repr;
     100
     101
       1 .=member fns10a
       2
       3
       4    procedure find_intervals;
       5$
       6$ this routine iterates over all the routines in a setl program
       7$ finding the interval graph for each routine.
       8$
       9    repr
      10	r:			routine;
      12    end repr;
      13
smfc  51
      14    title('cims.setl.' + prog_level + ' - interval analysis');
      15    printa(term_file, '   - interval analysis');
      16
      17
      20    (forall r in routs)
      21	find_graph(r);
      22	find_ints(r);
      23    end forall;
      24
      25
      26    $ delete the static variables global to the module
      27    nodeno := om;       postno := om;       ndescs := om;
      28    nodes := om;        postnodes := om;    seen := om;
      29    impropers := om;
      30
      31    cut_blocks := om;
      32
      33    $ print the interval graph if requested
      34    if 'i' in dump_string then
      35	(forall r in routs) dmp(r, 'igraph'); end forall;
      36    end if;
      37
      38    statistics with:= time;	$ save time for final statistics
      43
      44
      45    end procedure find_intervals;
      46
      47
      48
      49
      50    procedure find_graph(r);
      51$
      52$ this routine builds the original control flow graph for a routine r.
      53$
      54    repr
      55	r:			routine;
      56	work:			sparse set(elmt blocks);
      57	blks:			sparse set(elmt blocks);
      58	b:			elmt blocks;
      59	i:			elmt insts;
      60	opc:			elmt base_opcodes;
      61	labels:			sparse set(symbol);
      62	lab:			symbol;
      63	new_blks:		sparse set(elmt blocks);
      64	b1:			elmt blocks;
      65	bprev:			elmt blocks;
      66	lprev:			symbol;
      67    end repr;
      68$
      69$ we examine blocks starting with the routine's entry block.  this way
      70$ we find any unreachable blocks.
      71$
      72    work := { rentry(r) };
      73    blks := {};
      74
      75    (while work /= {})
      76	b from work;
      77	blks with:= b;
      78
      79	$ iterate over b, looking for branch instrctions
      80	(for_inst(i, b))
      81	    opc := opcode(i);
      82
      83	    if opc = q1_case then
      84		$ arg1 is a map from case values to labels
      85		labels   := range value(arg1(i));
      86		new_blks := { blockof(value(lab)): lab in labels };
      87
      88	    elseif opc in ops_goto then
      89		lab      := args(i)(# args(i));
      90		new_blks := { blockof(value(lab)) };
      91
      92	    else
      93		continue;
      94	    end if;
      95
      96	    (forall b1 in new_blks)
      97		cessor{b} with:= b1;
      98		pred{b1}  with:= b;
      99	    end forall;
     100
     101	    work +:= (new_blks - blks);
     102	end;
     103    end while;
     104$
     105$ now check that all blocks in r are reachable from the entry block.
     106$
     107    bprev := om;
     108    (for_block(b, r))
     109	if b notin blks then
     110	    if b /= rstop(r) and b /= rexit(r) then
     111		if b notin cut_blocks then
     112		    ermsg(str b + ' is unreachable from entry of ' +
     113			name(r));
     114		end if;
     115		del_block(b, bprev, r);
     116		b := bprev;
     117	    end if;
     118	end if;
     119	bprev := b;
     120    end;
     121
     122    $ delete the labels defining the blocks which were deleted in the
     123    $ preceding loop.
     124    lprev := om;
     125    (for_sym(lab, r))
     126	if lab in dead_labs then
     127	    del_sym(lab, lprev, r);
     128	    lab := lprev;
     129	end if;
     130	lprev := lab;
     131    end;
     132
     133
     134    end procedure find_graph;
     135
     136
       1 .=member fnt10b
       2
       3
       4    procedure find_ints(r);
       5$
       6$ this routine calculates the intervals of an intraprocedural flow
       7$ graph corresponding to a given routine r.
       8$
       9$ find_ints is called once to process each procedure 'r'.
      10$ it produces five maps:
      11$
      12$ 1. intof:      a map from each node to its interval.
      13$
      14$ 2. ints:       a map sending each routine 'r' into a tuple
      15$                containing the intervals of 'r' in reverse preorder.
      16$                note that iterating backward (forward) through
      17$                ints(r) is equivalent to iterating from outermost
      18$                to innermost(innermost to outermost) interval.
      19$
      20$                the outermost interval is not really an interval
      21$                at all. instead it contains all nodes not contained
      22$                in other intervals. it is acyclic in the reducible
      23$                case.
      24$
      25$ 3. int_nodes:  a map sending each interval into a tuple containing
      26$                the nodes of the interval in reverse postorder.
      27$                iterating over int_nodes(i) is equivalent to iterating
      28$                forward over the nodes in i.
      29$
      30$ 4. vedges:     the set of all edges which are part of some higher
      31$                order graph.
      32$
      33$ 5. proper_ints: a set of all proper (reducible) intervals.
      34$
      35    repr
      36	r:			routine;
      37	backinv:		mmap(elmt blocks) elmt blocks;
      38	x, y, z:		elmt blocks;
      39	root, hd, tbx:		elmt blocks;
      40	targback:		tuple(elmt blocks);
      41	reachunder:		sparse set(elmt blocks);
      42	newreachunder:		sparse set(elmt blocks);
      43	i:			integer;
      44    end repr;
      45$
      46$ step 1: calculate the following objects:
      47$
      48$ 1. nodeno:     maps each node into its preorder index
      49$ 2. postno:     maps each node into its postorder index
      50$ 3. ndescs:     maps each node into the number of its descendants
      51$ 4. nodes:      tuple of nodes in preorder.
      52$ 5. postnodes:  tuple of nodes in postorder
      53$ 6. backinv:    the set of all (y, x) such that (x, y) is a back edge
      54$ 7. targback:   a tuple of targets of back edges in preorder.
      55$
      56$ (1) - (5) are built by an auxiliary depth-first searching routine
      57$ 'dfst'.  when we build the node indices we use only even numbers.
      58$ this leaves the odd numbers for target blocks (i.e. interval
      59$ preheaders). initially only the even elements of nodes and postnodes
      60$ are filled in.
      61$
      62    $ the following macro tests for tree descendancy
      63    macro is_desc(x, y);
      64	(nodeno(y) <= nodeno(x) and nodeno(x) <= nodeno(y)+ndescs(y))
      65    endm;
      66
      67    $ initialize the globals for the depth-first spanning tree routine
      68    nodeno := {};       postno := {};       ndescs := {};
      69    nodes := [];        postnodes := [];    seen := {};
      70    npre := 0;          npost := 0;
      71
      72    $ build the depth-first spanning tree rooted at the entry block of r
      73    dfst(rentry(r));
      74
      75    $ construct the set backinv of all reverse back edges
      76    backinv := {};
      77    (for_block(x, r))(forall y in pred{x} | is_desc(y, x))
      78	backinv with:= [ x, y ];
      79    end forall; end;
      80
      81    $ construct the tuple targback of all back edge target nodes,
      82    $ arranged in reverse preorder.
      83    targback := [ nodes(i) : i in [ #nodes, #nodes-1..1 ] |
      84	nodes(i) /= om and nodes(i) in domain backinv ];
      85$
      86$ step 2
      87$
      88$ at this point 'targback' contains all potential interval heads in
      89$ reverse preorder.  we iterate over x in targback doing three things:
      90$
      91$ 1. build the set 'impropers' of such nodes x which are heads of
      92$    multiple-entry loops, and thus are 'sources of irreducibility'.
      93$
      94$ 2. for each x find the set 'reachunder' of nodes (in the reduced
      95$    graph in which each already processed proper or improper
      96$    interval has been logically 'squashed', i.e. identified with
      97$    a single node - its target block) which reach x along a path
      98$    not passing through x whose final edge is a back edge. if any
      99$    node which is not a descendant of x belongs to 'reachunder',
     100$    then x is a head of a multiple-entry loop, and we add x to
     101$    'impropers'. otherwise x is a head of a single-entry loop,
     102$    and thus is an interval head in our sense; if
     103$    reachunder * impropers = {}, then that interval is a proper
     104$    interval, and we add it to 'proper_ints'; otherwise it is an
     105$    improper interval.
     106$
     107$ 3. if x is an interval head then:
     108$
     109$    a. create a new target block 'tbx'.
     110$    b. add tbx to 'ints(r)' and set int_nodes(tbx) to [].
     111$    c. for all y in reachunder, set intof(y) := tbx
     112$    d. update the flow graph to show the insertion of tbx.
     113$
     114    root := rentry(r);
     115
     116    ints(r) := [];
     117
     118    (forall x in targback)
     119	reachunder    := {x};
     120	newreachunder := { .intof_lim y : y in backinv{x} } - {x};
     121	$ intof .lim y is the largest interval constructed so far
     122	$ which contains y (see below for details).
     123
     124	(while newreachunder /= {})
     125	    y from newreachunder;
     126	    reachunder with:= y;
     127
     128	    if not is_desc(y, x) then  $ a multiple-entry loop
     129		impropers with:= x;
     130		quit while;
     131	    else
     132		newreachunder +:=
     133		    ({ .intof_lim z : z in pred{y} } - reachunder);
     134	    end if;
     135	end while;
     136
     137	if x in impropers then continue forall; end if;
     138$
     139$ here x is an interval head.
     140$
     141	tbx            := get_targ(x);
     142	int_nodes(tbx) := [];
     143
     144	ints(r) with:= tbx;
     145	$ check if tbx is proper
     146	if reachunder * impropers = {} then
     147	      proper_ints with:= tbx;
     148	end if;
     149
     150	$ map each node in reachunder to its containing interval tbx
     151	(forall y in reachunder) intof(y) := tbx; end forall;
     152
     153	$ update the flow graph to account for the insertion of tbx
     154	$ into it.  this involves the following actions:
     155	$ 1. add an edge [ tbx, x ] to the graph.
     156	$ 2. replace all edges entering the interval through 'x' by
     157	$    edges entering tbx, and change the corresponding branch
     158	$    instructions in the program code.
     159	$ 3. for each edge [u, v] leaving the interval whose head
     160	$    is x, add a 'virtual' edge [tbx,v] to the graph.  this
     161	$    edge is added to 'vedges'.
     162
     163	update(x, tbx, reachunder);
     164    end forall;
     165$
     166$ build the outermost 'interval', identified by the entry node 'root'.
     167$
     168    ints(r) with:= root;
     169    int_nodes(root) := [];
     170    proper_ints with:= root;   $ root will be removed from this set if
     171			       $ actually improper
     172$
     173$ iterate over the nodes in reverse postorder, adding each node to
     174$ int_nodes. if a node has its interval head undefined put it in the
     175$ outermost interval.
     176$
     177    (forall i in [ #postnodes, #postnodes-1..1 ])
     178	x := postnodes(i);
     179	if x = om then continue forall i; end if;
     180
     181	hd := intof(x);
     182	if hd = om then
     183	    hd := intof(x) := root;
     184	    if x in impropers then
     185		proper_ints less:= root;
     186	    end if;
     187	end if;
     188
     189	int_nodes(hd) with:= x;
     190    end forall;
     191
     192
     193    end procedure find_ints;
     194
     195
       1 .=member upd10c
       2
       3
       4    procedure update(x, tbx, inodes);
       5$
       6$ this routine updates the flow graph to show the insertion of
       7$ the target block 'tbx'. its arguments are:
       8$
       9$ x:        the interval head
      10$ tbx:      the target block
      11$ inodes:   the nodes in the interval
      12$
      13    repr
      14	x, tbx:			elmt blocks;
      15	inodes:			sparse set(elmt blocks);
      16	i:			elmt insts;
      17	y:			elmt blocks;
      18	l1, l2:			symbol;
      19	opc:			elmt base_opcodes;
      20	a1:			symbol;
      21	a, b:			symbol;
      22	u:			elmt blocks;
      23    end repr;
      24$
      25$ we begin by adding a branch from tbx to x, and adding the corres-
      26$ ponding edge to the flow graph.
      27$
      28    i := add_inst(tbx, q1_goto, blk_label(x));
      29    stmtof(i) := stmtof(first_inst(x));
      30
      31    cessor{tbx} with:= x;
      32    pred{x}     with:= tbx;
      33$
      34$ next we iterate over all the predecessors of x which are not in
      35$ the interval modifying the cessor and pred maps as we go.
      36$
      37    (forall y in pred{x} | y notin inodes and y /= tbx)
      38
      39	$ update the branch instructions in y
      40	l1 := blk_label(x);
      41	l2 := blk_label(tbx);
      42
      43	(for_inst(i, y))
      44	    opc := opcode(i);
      45
      46	    if opc in ops_goto then
      47		if args(i)(#args(i)) = l1 then
      48		    args(i)(#args(i)) := l2;
      49		end if;
      50		if opc = q1_case then
      51		    a1 := arg1(i);
      52
      53		    (forall [ a, b ] in value(a1) | b = l1)
      54			value(a1)(a) := l2;
      55		    end forall;
      56		end if;
      57	    end if;
      58	end;
      59
      60	$ update the flow graph
      61	cessor{y}  less:= x;
      62	cessor{y}  with:= tbx;
      63
      64	pred{x}    less:= y;
      65	pred{tbx}  with:= y;
      66    end forall;
      67$
      68$ find all edges which leave the interval and add a virtual edge
      69$ from tbx for each such edge.
      70$
      71    (forall u in inodes, y in cessor{u} |
      72	    y notin inodes and intof(y) /= u)
      73	cessor{tbx} with:= y;
      74	pred{y}     with:= tbx;
      75	vedges{tbx} with:= y;
      76    end forall;
      77
      78
      79    end procedure update;
      80
      81
       1 .=member dft10d
       2
       3
       4    procedure dfst(x);
       5$
       6$ this routine builds the depth-first spanning tree rooted at the node x
       7$
       8    repr
       9	x:			elmt blocks;
      10	y:			elmt blocks;
      11    end repr;
      12
      13
      14    nodeno(x) := (npre +:= 2);	$ note the use of even indices only
      15    ndescs(x) := 0;
      16
      17    nodes(npre) := x;
      18    seen with:= x;
      19
      20    (forall y in cessor{x} | y notin seen)
      21	dfst(y);
      22	ndescs(x) +:= (ndescs(y) + 2);
      23$ each node is counted as two descendants, to match the usage of
      24$ only even indices in nodeno and postno.
      25    end forall;
      26
      27    postno(x) := (npost +:= 2);
      28    postnodes(npost) := x;
      29
      30    end procedure dfst;
      31
      32
      33
      34
      35    operator .intof_lim(x);
      36$
      37$ this operator is an adaption of the general .lim(f,x) operator
      38$ restricted by the assumption that the only left operand it is used
      39$ with is intof.
      40$
      41$ the general operator finds a value 'y' such that y = f(f(f..f(x)..)))
      42$ and f(y) = om.
      43$
      44$ note that unlike tarjan's original approach we omit path
      45$ compression, tree balancing, etc. for the sake of simplicity,
      46$ though these could easily be added.
      47$
      48$
      49$ the data structure choices used here derive from the use
      50$ of .lim in this module.  the routine itself, however, is
      51$ of a more general nature.
      52$
      53    repr
      54	x:			elmt blocks;
      55	y:			elmt blocks;
      56    end repr;
      57
      58
      59    y := x;
      60    (while intof(y) /= om) y := intof(y); end while;
      61
      62    return y;
      63
      64    end operator .intof_lim;
      65
      66
      67
      68
      69    procedure get_targ(x);
      70$
      71$ this routine adds a target block before x.  we give the target block
      72$ a postno of postno(x) + 1.
      73$
      74    repr
      75	x:			elmt blocks;
      76	p:			routine;
      77	targ:			elmt blocks;
      78	l:			symbol;
      79	i:			elmt insts;
      80    end repr;
      81
      82
      83    p    := routof(x);
      84    targ := add_block(x, p, false);
      85    l    := add_label(p);
      86    i    := add_inst(targ, q1_label, l);
      87
      88    stmtof(i) := stmtof(first_inst(x));
      89    value(l)  := i;	$ the value of a label is its instruction
      90
      91    nodeno(targ)        := nodeno(x) - 1;
      92    nodes(nodeno(targ)) := targ;
      93
      94    postno(targ)            := postno(x) + 1;
      95    postnodes(postno(targ)) := targ;
      96
      97    return targ;
      98
      99
     100    end procedure get_targ;
     101
     102
     103    end module setl_optimizer - interval_analysis;
     104
     105
       1 .=member avex11
       2
       3
       4    module setl_optimizer - availexp_analysis;
       5$
       6$ this module performs the available expressions and code motion
       7$ analyses, using the data flow solver package.  this can be accom-
       8$ plished by performing a single data flow analysis, namely the
       9$ available expression analysis in the code motion mode (see module
      10$ dataflow_solver for more detail).
      11$
      12$ in this mode, in addition to the local flow maps of the available
      13$ expression analysis, we also have to supply another kind of local
      14$ information, which is a map sending each basic block to the set of
      15$ all expressions exposed within that block, ie. expressions which are
      16$ computed within that block with no prior computation or kill.  this
      17$ map is denoted as 'exposed', and can be computed in a manner rather
      18$ similar to the computation of the local expression availability maps
      19$ (see below for more comments on the required initialization phase).
      20$
      21$ in addition to the availability map, the availability analysis will
      22$ also compute a map 'insert', which maps each interval i into the set
      23$ of all expressions movable to the target block of i but not redundant
      24$ there.  the actual insertion of these computations into the end of
      25$ the target block of i, as well as the actual elimination of redundant
      26$ computations, has to be done in an auxiliary routine called by the
      27$ code motion driver routine.
      28$
      29$ standard available expressions analysis is a 'forward-meet' analysis,
      30$ whose semi-lattice l is the power set of (ie. all bit vectors over)
      31$ the set of all (relevant) program expressions.  in this analysis we
      32$ associate with each flow edge (m, n) a data propagation map f(m, n),
      33$ so that for each x in l
      34$
      35$		f(m,n)(x) = x * nokill(m,n) + gen(m,n)
      36$
      37$ where
      38$
      39$ nokill(m,n) = set of all expressions t such that any kill of t along
      40$		any path through m to n is followed by a recomputation
      41$		of t.
      42$
      43$ gen(m,n) =	set of all expressions t such that t is computed with
      44$		no subsequent kill along each path through m to n.
      45$
      46$ we briefly describe the way in which code motion is accomplished by
      47$ our algorithm.
      48$
      49$ suppose that i is an interval such that for each node nd of i we have
      50$ already computed the following two objects:
      51$
      52$ aux_f(nd) =	a flow map representing the flow from the entry to the
      53$		loop of i, through that loop, to the entry to nd;  let
      54$		aux_f(nd) be represented by the sets aux_nokill(nd) and
      55$		aux_gen(nd), in complete analogy to the representation
      56$		of the f maps themselves.
      57$
      58$ exposed(nd) =	set of all expressions t for which there exists a
      59$		computation of t in nd which becomes redundant iff t is
      60$		available at the entry to nd.
      61$
      62$ then
      63$		(aux_nokill(nd) - aux_gen(nd)) * exposed(nd)
      64$
      65$ yields precisely those expressions t with the property that nd
      66$ contains a computation of t which becomes redundant iff t is
      67$ available just before entering the loop of i.  hence, the union of
      68$ the above sets over all nodes nd in i yields the set of all
      69$ expressions movable out of the loop of i, if we use the criterion
      70$ that it is profitable to move a computation of an expression t out of
      71$ a loop i iff at least one computation of t within i is made redundant
      72$ by that motion.  note that we do not impose any safety criteria on
      73$ code motion, as we assume that code motion will be performed only in
      74$ association with the use of a special 'run-time error mode' of the
      75$ setl system in which invalid computations do not cause program abort.
      76$
      77$ the above description gives the general outline of our approach;  for
      78$ more technical details see the dataflow_solver module.
      79$
      80$
      81$ we assume that the following global objects are available:
      82$
      83$ globalexps -	set of all expressions which depend on at least one
      84$		global variable, and so must participate in the inter-
      85$		procedural analysis.
      86$
      87$ localexps -	maps each procedure p to the set of all expressions
      88$		strictly local to p, ie. depending only on local
      89$		variables of p.
      90$
      91$ dependon -	maps each user-defined variable to the set of all
      92$		expressions which depend (explicitly or implicitly) on
      93$		that variable.
      94$
      95$ ops_exps -	constant set of all opcodes of instructions which
      96$		compute expressions with a well defined value and with
      97$		no side effects.
      98$
      99$ ops_modify -	constant set of all opcodes of instructions which can
     100$		modify a program variables.
     101$
     102
       1 .=member csx11a
       2
       3    macro df_base;                 df_base_syms                 endm;
       4    macro .comp;                   .comp_syms                   endm;
       5    macro interproc_fwd_analysis;  interproc_fwd_analysis_syms  endm;
       6    macro intraproc_fwd_analysis;  intraproc_fwd_analysis_syms  endm;
       7    macro fom;                     fom_syms                     endm;
       8    macro xom;                     xom_syms                     endm;
       9
      10    var
      11        avail,		$ maps each block to set of expressions
      12			$ available at its entry.
      13        insert,		$ maps each interval to the set of
      14			$ expressions to be inserted at the
      15			$ end of its target block.
      16        ppi,		$ instruction for code motion
      17        already_there;	$ set of moved expressions
      18
      19    repr
      20	mode df_elmt:		df_elmt_syms;
      21	mode df_map:		df_map_syms;
      22
      23	avail:			sparse smap(elmt blocks)
      24				    remote set(expression);
      25	insert:			sparse mmap{elmt blocks}
      26				    remote set(expression);
      27	ppi:			elmt insts;
      28	already_there:		remote set(expression);
      29
      30	interproc_csx:		procedure;
      31	intraproc_csx:		procedure(routine);
      32	move_eliminate:		procedure;
      33	insert_exp:		procedure(expression);
      34	csx_blockmaps:		procedure(routine, df_elmt)
      35				    tuple(
      36				      remote smap(df_edge) df_map,
      37				      remote mmap{df_node} df_elmt
      38				    );
      39	.meet:			operator(df_map, df_map) df_map;
      40    end repr;
      41
      42
      43    procedure csx;
      44$
      45$ this is the master procedure for performing the optimizations
      46$ described above.  it consists of the following phases:
      47$
      48$ 1. interprocedural analysis of global variables and expressions.
      49$    this phase will move and eliminate expressions involving global
      50$    variables and formal parameters of procedures.
      51$
      52$ 2. intraprocedural analysis of each procedure, in which strictly
      53$    local expressions are moved and eliminated.
      54$
      55    repr
      56	p:			routine;
      57	usym1, usym2:		symbol;
      59    end repr;
      60
      61    title('cims.setl.' + prog_level + ' - available expressions');
      62    printa(term_file, '   - available expression analysis');
      65
      66    $ initialize the static variables global to this module
      67    avail := {};        insert := {};
      68
      69    $ define the undefined lattice element and flow map
      70    xom := { usym1 := newat };
      71    fom := [ { usym1 := newat }, { usym2 := newat } ];
      72
      73    interproc_csx;		$ interprocedural analysis
      74
      75    (forall p in routs)		$ intraprocedural analysis
      76	intraproc_csx(p);
      77    end forall;
      78
      79    $ perform actual motion and elimination of expressions
      80    move_eliminate;
      81
      82    $ delete the static variables global to this module
      83    avail := om;        insert := om;
      84    ppi := om;          already_there := om;
      85
      86    $ delete the expression maps which are not needed anymore
      87    globalexps := om;   localexps := om;    allexps := om;
      88    opcexp := om;       argsexp := om;      dependon := om;
      89
      90    statistics with:= time;	$ save time for final statistics
      91
      98
      99    end procedure csx;
     100
     101
       1 .=member erx11b
       2
       3
       4    procedure interproc_csx;
       5$
       6$ this routine performs the optimizations described above interproce-
       7$ durally for expressions involving global variables and formal para-
       8$ meters.  it uses the relevant routines in the general data flow
       9$ solver package.  it consists of the following phases:
      10$
      11$ 1. compute the local maps associated with basic blocks (other than
      12$    call blocks) for the available expressions analysis, and also
      13$    compute 'exposed' information, using the global objects
      14$    'globalexps' and 'dependon' mentioned above.
      15$
      16$    it is probably best to define the 'exposed' map in a manner which
      17$    puts exposed{c} := {} for each call block c.  this will make
      18$    code motion strictly intraprocedural, which is probably the right
      19$    choice.
      20$
      21$ 2. perform available expressions analysis in 'code motion mode',
      22$    using 'exposed' information also.  this analysis returns two
      23$    objects: 'avail', mapping each basic block to the set of all
      24$    expressions known to be available at its entry, and 'insert',
      25$    mapping each interval to the set of all expressions which should
      26$    be inserted into the end of its target block.  together, these
      27$    steps accomplish code motion.
      28$
      29$ 3. a final pass in which expressions are actually moved and
      30$    eliminated.  it iterates through each basic block b;  if b is not
      31$    a target block of an interval, start with the set avail(b) of
      32$    expressions found to be available at its start; update this set as
      33$    kills and generations within the block are encountered, and use it
      34$    to eliminate any computation of an expression which is known to be
      35$    available just before this computation.  if the basic block is a
      36$    target block, we do essentially the same thing, but in addition
      37$    insert all expressions belonging to insert{b} at the end of b
      38$    (recall that b represents its interval).
      39$
      40$    we suggest two alternative techniques for accomplishing this
      41$    insertion:
      42$
      43$    (a) first topologically sort the set insert{b} according to the
      44$        relative dependency relation between expressions, so that if
      45$        an expression t1 depends on another expression t2, then t2
      46$        precedes t1 in this order.  then for each expression t in this
      47$        order, insert the instruction defining t.
      48$
      49$    (b) proceed in any random order over all the expressions t in
      50$        insert{b}.  for each such expression t, insert the whole
      51$        sequence of instructions needed to compute t from scratch,
      52$        and, while doing so, record the availability of subexpressions
      53$        of t thus generated.  then eliminate computations of available
      54$        subexpressions.  for example, if both a*b and (a*b)*c are to
      55$        be inserted, then if we first insert the whole computation of
      56$        (a*b)*c, after which a*b will become available, then its
      57$        subsequent insertion can be bypassed.
      58$
      59$    our current data structures facilitate the first approach, which
      60$    is the one that we will implement.
      61$
      62    repr
      63	$ data structures for local variables
      64	globexps:		df_elmt;
      65	id:			df_map;
      66	zero:			df_elmt;
      67	f:			remote smap(df_edge) df_map;
      68	exposed:		remote mmap{df_node} df_elmt;
      69    end repr;
      70
      71    if globalexps = {} then return; end if;
      72
      73    globexps := globalexps;	$ assign to split variable
      74    zero := {};			$ initial availability information
      75    id   := [ globexps, zero ];	$ identity map
      76$
      77$ perform phase 1: computation of local flow maps and exposed
      78$ expressions for basic blocks.
      79$
      80    [ f, exposed ] := csx_blockmaps(om, globexps);
      81    $ (om indicates interprocedural analysis)
      82$
      83$ perform phase 2: availability analysis
      84$
      85    interproc_fwd_analysis
      86	(f, avail, id, zero, true, true, exposed, insert, om);
      87	$ meet_flag is true in the 'code motion mode' (the sixth parm
      88	$ move_code is true, supplying it with the 'exposed'  map and
      89	$ obtaining the output 'avail' which maps each block to the set
      90	$ of all expressions available at its start;  we also compute a
      91	$ map 'insert' which sends each target block into the set of
      92	$ expressions to be inserted at its end.
      93
      94
      95    end procedure interproc_csx;
      96
      97
       1 .=member arx11c
       2
       3
       4    procedure intraproc_csx(p);
       5$
       6$ this routine performs the optimizations described above intraproce-
       7$ durally for expressions which depend only on local variables of the
       8$ procedure p.  apart from this difference, it is quite similar to its
       9$ interprocedural analog; the same method and phases are used here.
      10$
      11    repr
      12	$ data structure for parameter
      13	p:			routine;
      14
      15	$ data structures for local variables
      16	procexps:		df_elmt;
      17	id:			df_map;
      18	zero:			df_elmt;
      19	f:			remote smap(df_edge) df_map;
      20	avalx:			remote smap(df_node) df_elmt;
      21	exposed:		remote mmap{df_node} df_elmt;
      22	insrtx:			remote mmap{df_node} df_elmt;
      23	x:			elmt blocks;
      24	y:			remote set(expression);
      25    end repr;
      26
      27    procexps := localexps{p};
      28
      29    if procexps = {} then return; end if;
      30
      31    zero := {};			$ initial information at the entry of p
      32    id   := [ procexps, zero ];	$ identity map
      33
      34    $ perform phase 1
      35    [ f, exposed ] := csx_blockmaps(p, procexps);
      36
      37    $ perform phase 2
      38    intraproc_fwd_analysis
      39	(p, f, avalx, id, zero, true, true, exposed, insrtx, om);
      40
      41    $ update the avail and insert maps
      42    (forall y = avalx(x))
      43        if avail(x) = om then
      44            avail(x) := y;
      45        else
      46            avail(x) +:= y;
      47        end if;
      48    end forall;
      49
      50    (forall y = insrtx{x})
      51	insert{x} +:= y;
      52    end forall;
      53
      54
      55    end procedure intraproc_csx;
      56
      57
       1 .=member mel11d
       2
       3
       4    procedure move_eliminate;
       5
       6
       7    init
       8	elimexps := {};
       9
      10    repr
      11	r:			routine;
      12	b:			elmt blocks;
      13	i, pi:			elmt insts;
      14	opc:			elmt base_opcodes;
      15
      16	availb:			remote set(expression);
      17	insexps, elimexps:	remote set(expression);
      18	temps, killedexps:	remote set(expression);
      19	oi:			occurrence;
      20	t:			expression;
      21	v:			symbol;
      22	lsin:			integer 0..65536;
      23
      24	x:			elmt blocks;
      25	y:			remote set(expression);
      26	z:			expression;
      27    end repr;
      28
      29
      30    (forall r in routs)
      31        (for_block(b, r))
      32            availb := avail(b);	$ expressions available at entry to b
      33            if availb = om then continue; end;
      34            pi := om;		$ previous instruction (for deletion)
      35            (for_inst(i, b))
      36                opc := opcode(i);
      37
      38                if opc in ops_modify then
      39                    v := arg1(i);
      40                    killedexps := dependon{v};
      41                    if opc in ops_iter then
      42                        killedexps +:= dependon{arg2(i)};
      43                    end if;
      44                    availb := availb - killedexps;
      45                    if opc in ops_sin then
      46                        lsin := if opc = q1_ssubst then 4 else 3 end;
      47                        t := args(i)(lsin);
      48                        if t in availb then $ redundant embedding
      49                            del_inst(i, pi, b);
      50                            elimexps with:= t;
smfc  52			     messages{stmtof(i)}{'s'} with:=
      52				[ 'use available embedding of '
      53				  '"' + name(t) + '".' ];
      54                        else
      55                            availb with:= t;
      56                        end if;
      57                    end if;
      58
      59                elseif opc in ops_exps then
      60                    t := arg1(i);
      61                    if t in availb then	    $ redundant computation
      62                        del_inst(i, pi, b);
      63                        elimexps with:= t;
smfc  53			messages{stmtof(i)}{'s'} with:=
      65				[ 'use available computation for '
      66				  '"' + name(t) + '".' ];
      67                    else
      68                        availb with:= t;
      69                    end if;
      70
      71                elseif opc = q1_entry then  $ kill stacked expressions
      72		    availb := { t in availb | is_stk(t) = om };
      73                end if;
      74                pi := i;
      75            end;
      76            if (insexps := insert{b}) /= {} and
      77		    b /= rentry(r) then
      78		    $ b is an interval (a target block) out of which we
      79		    $ move code
      80
      81		$ find one-before-last instruction in b
      82		$ (an ugly procedure)
      83                pi := om;
      84                (for_inst(i, b))
      85                    ppi := pi;
      86                    pi := i;
      87                end;
      88                already_there := availb;
      89		(forall t in insexps)
      90		    is_temp(t) := om;
      91		    if t notin already_there then
      92			insert_exp(t);
      93		    end if;
smfc  54		    messages{stmtof(ppi)}{'s'} with:=
      95			[ 'insert computation of "'+name(t)+'".' ];
      96                end forall;
      97            end if;
      98        end;
      99    end forall;
     100$
     101$ at this point, elimexps contains all common subexpressions and
     102$ expresions moved out of loops. to clean up the code, we iterate
     103$ again over it and look for pairs of the form
     104$
     105$            t := exp;
     106$            a := t;
     107$
     108$ where t is not a common subexpression (and hence bound to be dead
     109$ after the second instruction), and change it into
     110$
     111$            a := exp;
     112$
     113$ this will shorten the code, and facilitate the detection os locally
     114$ based sets, etc.
     115$
     116    (forall r in routs)
     117	(for_block(b, r))
     118	    pi := om;		$ preceding instruction
     119	    (for_inst(i, b))
     120		if opcode(i) = q1_asn and pi /= om then
     121		    if (t := arg2(i)) = arg1(pi) and
     122			    is_temp(t) = 1 and t notin elimexps then
     123			v := arg1(i);
     124			del_inst(i, pi, b);
     125			arg1(pi) := v;
     126			oi := get_oi(pi, 1);
     127			occsof{t} less:= oi;
     128			occsof{v} with:= oi;
     129		    end if;
     130		end if;
     131		pi := i;
     132	    end;	$ end for_inst
     133	end;		$ end for_block
     134    end forall;
     135
     136    if 'a' notin dump_string then return; end if;
     137
     138    print;
     139    print('common subexpression elimination and code motion maps =');
     140    print;
     141    prints('avail =',
     142	[ [ str x, { '"'+name(z)+'"': z in y } ]: y = avail(x)  ] );
     143    prints('insert =',
     144	[ [ str x, { '"'+name(z)+'"': z in y } ]: y = insert{x} ] );
     145
     146
     147    end procedure move_eliminate;
     148
     149
     150
     151
     152    procedure insert_exp(t);
     153$
     154$ this procedure inserts in a recursive manner an expression into a
     155$ target block of an interval. it uses two global-within-the-module
     156$ objects:
     157$
     158$ ppi:		the instruction after which t should be inserted
     159$ already_there: set of expressions already inserted (or already
     160$		available at this point).
     161$
     162$ the insertion is performed in the following recursive manner:
     163$ if all arguments of t are either not expressions or else are
     164$ expressions in already_there, insert after ppi an instruction
     165$ defining t.
     166$ otherwise, call insert_exp(t1) for each argument of t not
     167$ satisfying the above condition and then insert the computation
     168$ of t.
     169$
     170    repr
     171	t:			expression;
     172	tt:			expression;
     173    end repr;
     174
     175
     176    (forall tt in argsexp(t) |
     177	tt in allexps and tt notin already_there)
     178        insert_exp(tt);
     179    end forall;
     180$
     181$ next insert t
     182$
     183    insert_ins1(ppi, opcexp(t), [ t ] + argsexp(t));
     184    already_there with:= t;
     185
     186    end procedure insert_exp;
     187
     188
       1 .=member bma11e
       2
       3
       4    procedure csx_blockmaps(p, exps);
       5$
       6$ this routine computes the data-flow block maps and the exposed map
       7$ for the available expressions analysis.  as always, p = om indicates
       8$ the interprocedural case, otherwise p is the routine to be scanned.
       9$
      10$ note that call blocks will be assigned identity data-flow maps and
      11$ null exposed value, which is correct in the intraprocedural case.
      12$ in the interprocedural case, the data-flow maps will be reset anyway,
      13$ and this choice of the exposed value will cause, as noted above, code
      14$ motion to be strictly intraprocedural.
      15$
      16    repr
      17	$ data structures for parameters
      18	p:			routine;
      19	exps:			df_elmt;
      20
      21	$ data structures for returned variables
      22	f:			remote smap(df_edge) df_map;
      23	exposed:		remote mmap{df_node} df_elmt;
      24
      25	$ data structures for local variables
      26	todo:			sparse set(routine);
      27	r:			routine;
      28	b:			df_node;
      29	i:			elmt insts;
      30	opc:			elmt base_opcodes;
      31
      32	a:			tuple(symbol);
      33	v:			symbol;
      34	lsin:			integer;
      35	fblk:			df_map;
      36	t:			elmt df_base;
      37	thruexps:		df_elmt;
      38	temps:			df_elmt;
      39	sblks:			sparse set(elmt blocks);
      40	lb:			symbol;
      41	b1:			df_node;
      42    end repr;
      43
      44    if p = om then todo := routs; else todo := { p }; end if;
      45
      46    f := {};   exposed := {};
      47
      48    (forall r in todo)
      49	(for_block(b, r))
      50	    fblk := [exps, {}];	$ initialize block map to identity
      51	    (for_inst(i, b))
      52		opc := opcode(i);
      53		if opc in ops_modify then
      54		    v := arg1(i);
      55		    thruexps := exps - dependon{v};
      56		    if opc in ops_iter then
      57			thruexps -:= dependon{arg2(i)};
      58		    end if;
      59		    fblk := [ thruexps, {} ] .comp fblk;
      60$ however, if opc is a sinister assignment, then the item to be
      61$ assigned will be the temporary representing the inverse operation,
      62$ and this instruction makes this temporary available.
      63		    if opc in ops_sin then
      64			lsin :=
      65			    if opc = q1_ssubst then 4 else 3 end;
      66			t := args(i)(lsin);	$ get expression
      67			if t in exps then
      68			    fblk :=
      69				[ exps, (temps := {t}) ] .comp fblk;
      70			end if;
      71		    end if;
      72		elseif opc in ops_exps then
      73		    t := arg1(i);	$ get expression computed
      74		    if t in exps then
      75			if t in fblk(1) - fblk(2) then
      76			    exposed{b} with:= t;
      77			end if;
      78			fblk :=
      79			    [ exps, (temps := {t}) ] .comp fblk;
      80		    end if;
      81		elseif opc in ops_goto then
      82		    a := args(i);
      83		    if opc = q1_case then
      84			sblks := { blockof(value(lb)) :
      85					lb in range value(a(1)) };
      86		    else
      87			sblks := { blockof(value(a(#a))) };
      88		    end if;
      89		    (forall b1 in sblks)
      90			if b1 = rexit(r) then
      91			    $ upon return, all stacked expressions of r
      92			    $ will be killed.  we account for this by
      93			    $ killing these exps along the flow to the
      94			    $ exit block, and so unify our algoritm.
      95			    thruexps := { t in exps | is_stk(t) = om };
      96			    fblk     := [ thruexps, {} ] .comp fblk;
      97			end if;
      98			f([b, b1]) := fblk .meet f([b, b1]);
      99		    end forall;
     100		elseif opc = q1_entry then
     101		    $ all stacked expressions are killed at this point
     102		    thruexps := { t in exps | is_stk(t) = om };
     103		    fblk     := [ thruexps, {} ] .comp fblk;
     104		end if;
     105	    end;	$ end for_inst
     106	end;		$ end for_block
     107    end forall;
     108
     109    return [ f, exposed ];
     110
     111    end procedure csx_blockmaps;
     112
     113
     114
     115
     116    operator .meet(f, g);
     117$
     118$ functional meet of f and g, where only g can be undefined (om).  for
     119$ convenience, we avoid using a similar, though slightly different
     120$ operator available in the dataflow_solver module.
     121$
     122    repr
     123	$ data structures for parameters
     124	f, g:			df_map;
     125    end repr;
     126
     127    if g = om then
     128	return f;
     129    else
     130	return [ f(1) * g(1), f(2) * g(2) ];
     131    end if;
     132
     133    end operator .meet;
     134
     135
     136    drop
     137	df_base,
     138	.comp,
     139	interproc_fwd_analysis,
     140	intraproc_fwd_analysis,
     141	fom,
     142	xom;
     143
     144
     145    end module setl_optimizer - availexp_analysis;
     146
     147
       1 .=member live12
       2
       3
       4    module setl_optimizer - live_analysis;
       5$
smfb  41$ live-dead  analysis establishes  the live/dead  status  of  variables.
smfb  42$ a variable is said to be 'live' at a program point n if there exists a
smfb  43$ path  leading from  n to some  use of v  which is  free  of  any other
smfb  44$ occurrence  of v (implying  that the  current value  of v may be  used
smfb  45$ subsequenlty,   and  therefore  cannot  be  destroyed  or  discarded);
smfb  46$ otherwise v is said to be 'dead' at n.
smfb  47$
smfb  48$ standard  live variable  analysis is  a 'backward-join' analysis whose
smfb  49$ semi-lattice  l = pow(e)  is the power set  of  (i.e. all  bit vectors
smfb  50$ over)  the set of all (relevant)  program variables, and where lattice
smfb  51$ meet is set-union.   in this analysis we associate with each flow edge
smfb  52$ (m, n) a data propagation map f(m, n) so that for each x in l we have
smfb  53$
smfb  54$	f(m, n)(x) = thru(m, n) * x + livein(m, n)
smfb  55$
smfb  56$ where
smfb  57$
smfb  58$ thru(m, n) =	the set of all variables v in e for which there exists a
smfb  59$		path through  the flow of f  which is either free of any
smfb  60$		other  occurrence of v  or else  contains a use of v not
smfb  61$		preceded by any other occurrence of v.
smfb  62$
smfb  63$ livein(m,n) =	the set of all variables v in e for which there exists a
smfb  64$		path through the flow of f which contains a use of v not
smfb  65$		preceded by any other occurrence of v.
smfb  66$
smfb  67$ the output  of live-dead analysis is a map liveat,  mapping each basic
smfb  68$ block n to a set  liveat(n) of all  variables live at the  start of n.
smfb  69$ this set  can then be  propagated (backward) through  basics blocks to
smfb  70$ establish variable liveness at any program point.
smfb  71$
smfb  72$ live variable  calculation is  performed  straightforwardly  using our
smfb  73$ general-purpose  dataflow  solver  module.   the  algorithm  used  are
smfb  74$ described in more (technical) detail in the dataflow_solver module.
smfb  75$
       6    macro df_base;		    df_base_syms		  endm;
       7    macro .comp;		    .comp_syms			  endm;
       8    macro interproc_back_analysis;  interproc_back_analysis_syms  endm;
       9    macro intraproc_back_analysis;  intraproc_back_analysis_syms  endm;
      10    macro fom;			    fom_syms			  endm;
      11    macro xom;			    xom_syms			  endm;
      12
      13
      14    repr
      15	mode df_elmt:		df_elmt_syms;
      16	mode df_map:		df_map_syms;
      17
      18	.join:			operator(df_map, df_map) df_map;
      19	interproc_live:		procedure;
      20	intraproc_live:		procedure(routine);
      21	live_blockmaps:		procedure(routine, df_elmt)
      22				    remote smap(df_edge) df_map;
      23    end repr;
      24
      25
       1 .=member lva12a
       2
       3
       4    procedure live;
       5$
       6$ this is the master procedure  which  drives  the  live  analysis.   it
       7$ consists of the following phases:
       8$
       9$ interprocedural analysis for liveness of global variables.
      10$
      11$ intraprocedural analysis for liveness of local variables  within  each
      12$ routine.
      13$
      14$ for efficiency, we restrict the elements for our analysis here to  the
      15$ variables which appear in the user's program, or were directly derived
      16$ from program variables.  also note that formal parameters need not  be
      17$ analysed.  beyond these modifications, the algorithm which follows  is
      18$ the standard live variable algorithm.   furthermore,  the  results  of
      19$ each analysis are used as soon as they become available.
      20$
      21    repr
      22	p:			routine;
      23	usym1, usym2:		symbol;
      25    end repr;
      26
      27
      28    title('cims.setl.' + prog_level + ' live analysis');
      29    printa(term_file, '   - live analysis');
      30
      33    $ define the undefined lattice element and flow map
      34    xom := { usym1 := newat };
      35    fom := [ { usym1 := newat }, { usym2 := newat } ];
      36
      37    interproc_live;		$ interprocedural analysis
      38
      39    (forall p in routs)
      40	intraproc_live(p);	$ intraprocedural analysis
      41    end forall;
      42
      43    statistics with:= time;	$ save time for final statistics
      48
      49
      50    end procedure live;
      51
      52
       1 .=member ine12b
       2
       3
       4    procedure interproc_live;
       5$
       6$ this procedure performs interprocedural live analysis for the relevant
       7$ global variables.
       8$
       9    repr
      10	pi:			elmt insts;
      11	v:			symbol;
      12	globvars:		df_elmt;
      13	id:			df_map;
      14	zero:			df_elmt;
      15	f:			remote smap(df_edge) df_map;
      16	liveat:			remote smap(df_node) df_elmt;
      17    end repr;
      18
      19
      20    $ note that we restrict the elements for our analysis  here  to  the
      21    $ variables which appear in the user's  program,  or  were  directly
      22    $ derived from program variables.  also note that formal  parameters
      23    $ need not be analysed.  beyond these modifications,  the  algorithm
      24    $ which follows is the standard live variable algorithm.
      25
      26    globvars := { v in globalvars | is_internal(v) = om };
      27
      28    if globvars = {} then return; end if;
      29
      30    zero := {};			$ nothing live at program exit
      31    id := [ globvars, zero ];	$ identity map for the analysis
      32
      33    $ compute the global flow maps
      34    f := live_blockmaps(om, globvars);
      35    $ (om indicates interprocedural analysis)
      36
      37    $ perform interprocedural live analysis
      38    interproc_back_analysis(f, liveat, id, zero, false);
      39    $ meet_flag is false for the join analysis.
      40
      41    pi := first_inst(rentry(sym_main));
      42    (forall v in liveat(rentry(sym_main)))
      43	if is_init(v)=1 then
      44	    insert_ins(pi, q1_asn, v, alias(v));
      45	else
      46	    insert_ins(pi, q1_asn, v, sym_om);
smfk  38	    messages{sc_stmt_ct(scope(v))}{'w'} with:=
      48		[ 'init ' + name(v) + ' := om;'
smfi  43		  '    $ uninitialised variable.' ];
      50	end if;
      51    end forall;
      52
      53
      54    end procedure interproc_live;
      55
      56
       1 .=member ina12c
       2
       3
       4    procedure intraproc_live(p);
       5$
       6$ this procedure performs intraprocedural live analysis for the relevant
       7$ local variables of the procedure p.
       8$
       9    repr
      10	p:			routine;
      11	pi:			elmt insts;
      12	v:			symbol;
      13	procvars:		df_elmt;
      14	id:			df_map;
      15	zero:			df_elmt;
      16	f:			remote smap(df_edge) df_map;
      17	liveat:			remote smap(df_node) df_elmt;
      18    end repr;
      19
      20
      21    $ note that we restrict the elements for our analysis here  to  the
      22    $ variables which appear in the user's program,  or  were  directly
      23    $ derived from program variables.  also note that formal parameters
      24    $ need not be analysed.  beyond these modifications, the  algorithm
      25    $ which follows is the standard live variable algorithm.
      26
      27    procvars := { v in localvars{p} |
      28			is_internal(v) = om and is_param(v) = om };
      29
      30    if procvars = {} then return; end if;
      31
      32    zero := {};			$ nothing live at routine exit
      33    id := [ procvars, zero ];	$ identity map for the analysis
      34
      35    $ compute the local flow maps
      36    f := live_blockmaps(p, procvars);
      37
      38    $ perform intraprocedural live analysis
      39    intraproc_back_analysis(p, f, liveat, id, zero, false);
      40    $ meet_flag is false for the join analysis.
      41
      42    pi := first_inst(rentry(p));
      43    (forall v in liveat(rentry(p)))
      44	insert_ins(pi, q1_asn, v, sym_om);
      45	messages{sc_estmt_ct(scope(v))}{'w'} with:=
      46		[ 'init ' + name(v) + ' := om;'
smfi  44		  '    $ uninitialised variable.' ];
      48    end forall;
      49
      50
      51    end procedure intraproc_live;
      52
      53
       1 .=member lbk12d
       2
       3
       4    procedure live_blockmaps(p, vars);
       5$
       6$ this procedure computes the data-flow block maps for live analysis.
       7$
       8$ as always, p = om indicates the interprocedural case, otherwise  p  is
       9$ the routine to be scanned.
      10$
      11    repr
      12	p:			routine;
      13	vars:			df_elmt;
      14
      15	todo:			sparse set(routine);
      16	f:			remote smap(df_edge) df_map;
      17	r:			routine;
      18	b:			elmt blocks;
      19	i:			elmt insts;
      20	opc:			elmt base_opcodes;
      21	argsi:			tuple(symbol);
      22	fblk:			df_map;
      23	killed, gen:		df_elmt;
      24	k:			integer 0..65536;
      25	sblks:			sparse set(elmt blocks);
      26	lb:			symbol;
      27	b1:			elmt blocks;
      28    end repr;
      29
      30    if p = om then todo := routs; else todo := { p }; end if;
      31
      32    f := {};
      33
      34    (forall r in todo)
      35	(for_block(b, r))
      36	    fblk := [ vars, {} ];	$ start with the identity
      37
      38	    (for_inst(i, b))
      39		opc := opcode(i);
      40		argsi := args(i);
      41
      42		killed := gen := {};
      43
      44		(forall k in [ first_ivar(opc)..#argsi ] |
      45						argsi(k) in vars)
      46		    if k = 2 and (opc = q1_set1 or opc = q1_tup1) then
      47			continue forall;
      48		    end if;
      49
      50		    gen with:= argsi(k);
      51		end forall;
      52
      53		if opc in ops_ovar and argsi(1) in vars then
      54		    killed with:= argsi(1);
      55		end if;
      56
      57		fblk := fblk .comp [ vars - killed + gen, gen ];
      58
      59		if opc in ops_goto then
      60		    if opc = q1_case then
      61			sblks := { blockof(value(lb)) :
      62					lb in range value(argsi(1)) };
      63		    else
      64			sblks := { blockof(value(argsi(#argsi))) };
      65		    end if;
      66
      67		    (forall b1 in sblks)
      68			f([b, b1]) := fblk .join f([b, b1]);
      69		    end forall;
      70		end if;
      71	    end;	$ end for_inst
      72	end;		$ end for_block
      73    end forall;
      74
      75    return f;
      76
      77
      78    end procedure live_blockmaps;
      79
      80
      81
      82
      83    operator .join(f, g);
      84$
      85$ functional join of f and g, where only g can be undefined (om).
      86$
      87$ for convenience, we avoid using a similar, thought slightly  different
      88$ operator available in the dataflow_solver module.
      89$
      90    if g = om then
      91	return f;
      92    else
      93	return [ f(1) + g(1), f(2) + g(2) ];
      94    end if;
      95
      96
      97    end operator .join;
      98
      99
     100    drop
     101	df_base,
     102	.comp,
     103	interproc_back_analysis,
     104	intraproc_back_analysis,
     105	fom,
     106	xom;
     107
     108
     109    end module setl_optimizer - live_analysis;
     110
     111
       1 .=member bfd11f
       2
       3
       4    module setl_optimizer - bfrom_analysis;
       5$
       6$ this module computes the bfrom map and some related  maps,  using  the
       7$ general data flow analysis algorithms in the 'dataflow_solver' module.
       8$ this version does not employ call strings, and thus may loose a bit of
       9$ accuracy, even though the bfrom map for global  variables is  computed
      10$ correctly, using the interprocedural forward algorithm.
      11$
      12$ as usual, our analysis is partitioned into interprocedural analysis of
      13$ global variable occurrences, followed by intraprocedural  analysis  of
      14$ local variable occurrences within each procedure.
      15$
      16$ the bfrom map is defined on variable uses as follows: let vo be a  use
      17$ of some variable v; then bfrom is defined to be  the  set  of  all
      18$ occurrences vo1 of v (definitions or uses) which can reach vo along  a
      19$ path clear of any other occurrences of v.
      20$
      21$ we compute the bfrom map rather than  the  traditional  use-definition
      22$ map, for the following reasons:
      23$
      24$ 1. some optimization analyses use 'shadow variables' rather  than  the
      25$ variables themselves.  for example, copy optimization applies  to  the
      26$ share bits  of  variables.   definitions  and  uses  of  these  shadow
      27$ variables need not coincide with definitions and uses  of  the  actual
      28$ variables.  the use of bfrom allows a uniform treatment of  all  these
      29$ optimizations.
      30$
      31$ 2. we expect that using the bfrom instead  of  the  use-def  map  will
      32$ speed up various iterative algorithms, such as the type finder.
      33$
      34$ 3. the automatic data structure selection algorithm makes special  use
      35$ of the bfrom map, and will not function properly if use-def chains are
      36$ used instead.
      37$
      38$ the data-flow analysis used to compute bfrom  is  a  'reaching  occur-
      39$ rences' analysis, which is a forward-join analysis, in which, for each
      40$ flow graph node n, we wish to compute a set  reach(n)  of  all  occur-
      41$ rences vo which can reach n along a path which is free  of  any  other
      42$ occurrences of the variable of vo.  using this map, we can compute the
      43$ bfrom map in one additional linear scan of each basic block, as  shown
      44$ below.
      45$
      46$ this analysis is obviously of the  bitvectoring  class.   indeed,  let
      47$ 'vars' denote the set of all variables whose  occurrences  are  to  be
      48$ analysed (global variables or local variables within some  procedure),
      49$ and let 'occs' denote the set of  all  their  occurrences.   then  the
      50$ lattice l of our analysis is the power  set  of  occs,  and  for  each
      51$ flow-graph edge (m, n) we assign a data-flow map f(m, n), defined as:
      52$
      53$    f(m, n)(x) = reachthru(m,n) * x + reachfrom(m,n)   ,  x in l
      54$
      55$ where
      56$
      57$ reachthru(m,n) = set of all occurrences in occs which reach the  start
      58$ of n if they reach the start of m.  (note that this set also  includes
      59$ occurrences occurring within m that can reach the start of n.)
      60$
      61$ reachfrom(m,n) = set of all occurrences in  occs  occurring  within  m
      62$ which can reach the start of n.
      63$
      64$ after establishing the block maps we solve the corresponding data-flow
      65$ problem using our general package.  a final step computes the required
      66$ bfrom map, its inverse map ffrom, and  an  auxiliary  set  bfrom_dead,
      67$ defined as the set of all occurrences which can either reach a program
      68$ exit (or a  procedure  exit  for  local  variable  occurrences)  or  a
      69$ redefinition of their variable.
      70$
      71$ we assume that the following global variables are available.
      72$
      73$ globalvars:	set of all global variables
      74$
      75$ localvars:	maps each routine to the set of its local variables
      76$
      77$ occsof:	maps each variable to the set of its occurrences
      78$
       1 .=member fbf11g
       2
       3
       4    macro .comp;                   .comp_ocrs                   endm;
       5    macro interproc_fwd_analysis;  interproc_fwd_analysis_ocrs  endm;
       6    macro intraproc_fwd_analysis;  intraproc_fwd_analysis_ocrs  endm;
       7    macro fom;                     fom_ocrs                     endm;
       8    macro xom;                     xom_ocrs                     endm;
       9
      10
      11    var
      12	def_def,	$ maps definitions to definitions reached
      13	def_exit,	$ set of definitions which reach the exit block
      14	rem_bfrom_dead;	$ split variable to the global bfrom_dead
      15
      16
      17    repr
      18	mode df_elmt:		df_elmt_ocrs;
      19	mode df_map:		df_map_ocrs;
      20
      21	def_def:		sparse mmap{occurrence}
      22				    sparse set(occurrence);
      23	def_exit:		df_elmt;
      24	rem_bfrom_dead:		df_elmt;
      25
      26	.join:			operator(df_map, df_map) df_map;
      27	global_bfrom:		procedure()
      28				    tuple(
      29				      remote smap(df_node) df_elmt,
      30				      df_elmt
      31				    );
      32	local_bfrom:		procedure(routine)
      33				    tuple(
      34				      remote smap(df_node) df_elmt,
      35				      df_elmt
      36				    );
      37	comp_bfrom:		procedure(
      38			          routine,
      39			          df_elmt,
      40			          remote smap(df_node) df_elmt
      41			          );
      42	bfrom_blockmaps:	procedure(routine, df_elmt)
      43				    remote smap(df_edge) df_map;
      44    end repr;
      45
      46
      47    procedure find_bfrom;
      48$
      49$ this is the master procedure which drives the bfrom computation.
      50$ it consists of the following phases:
      51$
      52$ interprocedural analysis for occurrences of global variables.
      53$
      54$ intraprocedural analysis for occurrences of local variables within
      55$ each routine.
      56$
      57$ for efficiency, the results of each such analysis are used immediately
      58$ to  add  entries  to  bfrom  and  bfrom_dead,  and  are discarded when
      59$ proceeding to the next analysis.
      60$
      61    repr
      62	foccs:			df_elmt;
      63	freach:			remote smap(df_node) df_elmt;
      64	r:			routine;
      65	roccs:			sparse set(occurrence);
      66	uocrs1, uocrs2:		occurrence;
      67	vo1, vo2:		occurrence;
      68	errois:			remote set(occurrence);
      69	x:			occurrence;
      71    end repr;
      72
      73    $ initialize output objects
      74    bfrom := {};        ffrom := {};        rem_bfrom_dead := {};
      75    def_def := {};      def_exit := {};
      76
      77    title('cims.setl.' + prog_level + ' - bfrom analysis');
      78    printa(term_file, '   - bfrom analysis');
      79
      82    $ define the undefined lattice element and flow map
      83    xom := { uocrs1 := newat };
      84    fom := [ { uocrs1 := newat }, { uocrs2 := newat } ];
      85
      86    $ compute reaching occurrences for global variables
      87    [ freach, foccs ] := global_bfrom();
      88
      89    $ compute corresponding bfrom entries immediately
      90    $ (the first parameter = om to indicate the interprocedural case)
      91    comp_bfrom(om, foccs, freach);
      92
      93    (forall r in routs)
      94	$ compute reaching occurrences for local variables of r
      95	[ freach, foccs ] := local_bfrom(r);
      96	$ as before, add corresponding entries to bfrom immediately
      97	comp_bfrom(r, foccs, freach);
      98    end forall;
      99
     100    bfrom_dead := rem_bfrom_dead;   $ convert between data structures
     101
smfi  45  if debug_flag then
smfi  46
     102    errois := {};
     103    (forall [ vo1, vo2 ] in def_def | oi_sym(vo1) in uservars)
     104	if oi_op(vo1) = q1_asn and arg2(instno(vo1)) = sym_om then
     105	    continue forall;
     106	end if;
     107	if oi_op(vo2) = q1_asn and arg2(instno(vo2)) = sym_om then
     108	    continue forall;
     109	end if;
     110	if ffrom{vo1} = {} then
     111	    if vo1 in errois then continue; end if;
     112	    errois with:= vo1;
smfc  55	    messages{stmtof(instno(vo1))}{'i'} with:=
smfc  56		[ 'this definition of "' + oi_name(vo1) + '"'
     115		  ' is not used and thus redundant.' ];
     116	elseif getipp('full=0/1') = 1 then
smfc  57	    messages{stmtof(instno(vo1))}{'i'} with:=
smfc  58		[ 'this definition of "' + oi_name(vo1) + '"'
     119		  ' is not used before being redefined at ' +
     120		  oi_stmt(vo2) + '.' ];
     121	end if;
     122    end forall;
     123
     124    (forall vo1 in def_exit | oi_sym(vo1) in uservars)
     125	if oi_op(vo1) = q1_asn and arg2(instno(vo1)) = sym_om then
     126	    continue forall;
     127	end if;
     128	if #occsof{oi_sym(vo1)} = 1 then continue forall; end if;
     129	if ffrom{vo1} = {} then
     130	    if vo1 in errois then continue; end if;
     131	    errois with:= vo1;
smfc  59	    messages{stmtof(instno(vo1))}{'i'} with:=
smfc  60		[ 'this definition of "' + oi_name(vo1) + '"'
     134		  ' is not used and is thus redundant.' ];
     135	elseif getipp('full=0/1') = 1 then
smfc  61	    messages{stmtof(instno(vo1))}{'i'} with:=
smfc  62		[ 'this definition of "' + oi_name(vo1) + '"'
smfc  63		  ' is not used before the program exit.' ];
     139	end if;
     140    end forall;
smfi  47
smfi  48  end if;
     141
     142    $ delete the static variables global to this module
     143    def_def := om;      def_exit := om;
     144    rem_bfrom_dead := om;
     145
     146    if 'b' in dump_string then
     149	print;
     150	print('variable     occurrence   reaching occurences');
     151	print('---------------------------------------------');
     152	print;
     153	prints('',
     154	    [ [ rpad(oi_name(vo1), 12) + ' ' +
     155		    rpad(oi_str(vo1), 12),
     156		+/[ rpad(oi_str(vo2), 10) : vo2 in roccs ]    ] :
     157		    roccs = bfrom{vo1}] );
     158	print;
     159	prints('bfrom_dead =',
     160		[ [ rpad(oi_name(vo1), 12), oi_str(vo1) ] :
     161			    vo1 in bfrom_dead    ]    );
     166    end if;
     167
     168    statistics with:= time;	$ save time for final statistics
     176
     177
     178    end procedure find_bfrom;
     179
     180
     181
     182
     183    procedure global_bfrom;
     184$
     185$ this routine computes the  'reaching occurrences'  map for occurrences
     186$ of global variables,  using  our  general  interprocedural  data  flow
     187$ algorithm.
     188$
     189    repr
     190	r:			routine;
     191	v:			symbol;
smfi  49	c:			elmt blocks;
     192	globaloccs:		df_elmt;
     193	id:			df_map;
     194	zero:			df_elmt;
     195	f:			remote smap(df_edge) df_map;
     196	reach:			remote smap(df_node) df_elmt;
     197	dum1, dum2:		remote mmap{df_node} df_elmt;
     198    end repr;
     199$
     200$ the following code sequence has been lowered in level to allow for
     201$ greater efficiency.  the original code has been left as a comment.
     202$
     203$     globlvrs := globalvars + { pr : r in routs, pr in rparams(r) };
     204$
     205$     if globlvrs = {} then
     206$         print(' no global bfrom entries');
     207$         return [];
     208$     end if;
     209$
     210$     globaloccs := +/ [ occsof{v} : v in globlvrs ];
     211$
     212    globaloccs := {};
     213    (forall v in globalvars)
     214	globaloccs +:= occsof{v};
     215    end forall;
     216    (forall r in routs, v in rparams(r))
     217	globaloccs +:= occsof{v};
     218    end forall;
smfi  50
smfi  51    if globaloccs = {} and not debug_flag then
smfi  52	return [ {}, {} ];
smfi  53    end if;
     220
     221    id   := [ globaloccs, {} ];	$ identity map for analysis
     222    zero := {};			$ initial set of reaching occurrences
     223
     224    $ compute the block data-flow maps. the first parameter is om to
     225    $ indicate that all procedures are to be scanned.
     226    f := bfrom_blockmaps(om, globaloccs);
     227
     228    $ perform reaching occurrences analysis.
     229    interproc_fwd_analysis
     230	(f, reach, id, zero, false, false, dum1, dum2, om);
     231	$ here the meet_flag parameter is false (join analysis), the
     232	$ move_code parameter is also false (no code motion), and the
     233	$ last two parameters (needed only for code motion) are dummies
smfi  54
smfi  55    $ next we test for infinite recursion.  this is done by testing the
smfi  56    $ flow maps from each call block to its successor for fom.
smfi  57    if debug_flag then
smfi  58	(forall [ -, c ] in callsin | f([c, cessor(c)]) = fom)
smfi  59	    messages{sc_stmt_ct(callproc(c))}{'e'} with:=
smfi  60		[ 'no control path exists to '
smfi  61		  'this routine''s exit block.' ];
smfi  62	end forall;
smfi  63    end if;
     234
     235    return [ reach, globaloccs ];
     236
     237
     238    end procedure global_bfrom;
     239
     240
     241
     242
     243    procedure local_bfrom(r);
     244$
     245$ this routine computes the reach map for occurrences of local variables
     246$ within the routine r.
     247$
     248    repr
     249	$ data structures for parameters
     250	r:			routine;
     251
     252	$ data structures for local variables
     253	localsofr:		sparse set(symbol);
     254	pr:			symbol;
     255	localoccs:		df_elmt;
     256	v:			symbol;
     257	reach:			remote smap(df_node) df_elmt;
     258	id:			df_map;
     259	zero:			df_elmt;
     260	f:			remote smap(df_edge) df_map;
     261	dum1, dum2:		remote mmap{df_node} df_elmt;
     262    end repr;
     263$
     264$ the following code sequence has been lowered in level to allow for
     265$ greater efficiency.  the original code has been left as a comment.
     266$
     267$     localsofr := localvars{r} - { pr : pr in rparams(r)};
     268$
     269$     if localsofr = {} then
     270$         print(' no local bfrom entries in routine', name(r));
     271$         return [];
     272$     end if;
     273$
     274$     localoccs := +/[occsof{v} : v in localsofr];
     275    localoccs := {};
     276    (forall v in localvars{r} | v notin rparams(r))
     277	localoccs +:= occsof{v};
     278    end forall;
     279    if localoccs = {} then return [ {}, {} ]; end if;
     280
     281    reach := {};
     282    id   := [ localoccs, {} ];	$ identity map for analysis
     283    zero := {};			$ initially reaching occurrences
     284
     285    $ compute data flow maps for basic blocks
     286    f := bfrom_blockmaps(r, localoccs);
     287
     288    $ perform 'reaching occurrences' analysis
     289    intraproc_fwd_analysis(r, f, reach, id, zero, false, false,
     290			       dum1, dum2, om);
     291	$ (see comment in global_bfrom for the significance of these
     292	$ parameters.)
     293
     294    return [ reach, localoccs ];
     295
     296
     297    end procedure local_bfrom;
     298
     299
       1 .=member cbf11h
       2
       3
       4    procedure comp_bfrom(p, foccs, freach);
       5$
       6$ this routine performs a final scan of the code to add  entries  to the
       7$ bfrom map and the bfrom_dead set.   this scan will consider all occur-
       8$ rences in the set 'occs'.   p = om indicates interprocedural analysis,
       9$ in which all routines have to be scanned  (but only for occurrences of
      10$ global variables);  otherwise  p is the  routine  to be  scanned,  and
      11$ 'occs' is the set of all occurrences of local variables of p.  'reach'
      12$ is the reaching occurrences map,  as defined  in the  introduction  to
      13$ this module, and as computed by our general data-flow algorithms.
      14$
      15    repr
      16	$ data structures for parameters
      17	p:			routine;
      18	foccs:			df_elmt;
      19	freach:			remote smap(df_node) df_elmt;
      20
      21	$ data structures for local variables
      22	todo:			sparse set(routine);
      23	r:			routine;
      24	b:			elmt blocks;
      25	i:			elmt insts;
      26	opc:			elmt base_opcodes;
      27	v:			symbol;
      28	argsi:			tuple(symbol);
      29	vo, vo1:		occurrence;
      30	iva1:			integer;
      31	k:			integer;
      32	reachb:			df_elmt;
      33	reachd:			df_elmt;
      34	gen, killed:		df_elmt;
      35	voccs:			df_elmt;
      36    end repr;
      37
      38
      39    if p = om then todo := routs; else todo := { p }; end if;
      40
      41    (forall r in todo)
      42	(for_block(b, r))
      43	    reachb := freach(b);
      44	    if reachb = om then continue; end if;
      45	    (for_inst(i, b))
      46		opc := opcode(i);
      47
      48		if opc = q1_exit and (r = sym_main or p /= om)
      49			or opc = q1_stop then
      50$ a program or procedure exit, at which all occurrences in
      51$ reachb 'become' dead.  add these occurrences to bfrom_dead
      52	if debug_flag then
      53		    def_exit := { vo1 in reachb | is_ovar(vo1) };
      54	end if;
      55		    rem_bfrom_dead +:= reachb;
      56		end if;
      57
      58		argsi := args(i);	$ tuple of inst. arguments
      59		$ get the index of the first ivariable
      60		iva1 := first_ivar(opc);
      61
      62$ iterate over all arguments of i in reverse order. as we do this, we
      63$ update the value of reachb, to account for killing of the reachabi-
      64$ lity of all other occurrences of these variables, and generation of
      65$ new occurrences within i. also, the bfrom value of each ivariable
      66$ (use) is computed.
      67$
      68$ note that we 'freeze' the value of reachb when scanning the
      69$ ivariables of i, and treat the ovariable in a different manner than
      70$ the ivariables.  to understand this, consider the case where i is
      71$ 'v1 := v2 + v3' (where all arguments are occurrences of the same
      72$ variable v).  here we want both ivariables to be linked to the same
      73$ preceding occurrences of v, so that none of them should kill reacha-
      74$ bility of these occurrences until all ivariables are processed.
      75$ however, when we come to process the ovariable, we will want to
      76$ regard the ivariables as killing reachability of all preceding occur-
      77$ rences.  this will yield, for the above i,
      78$ bfrom{v2} = bfrom{v3} = all preceding reaching occurrences of v,
      79$ and bfrom{ any succeeding occ. of v } = { v1 }.
      80$
      81$ note also that if the first argument of i is both an ivariable and an
      82$ ovariable, e.g. if i is 'f(x) := f', then an argument quite analogous
      83$ to the above one implies that the bfrom value of both these occur-
      84$ rences of f is the set of all preceding reaching occurrences of f,
      85$ whereas bfrom of a succeeding occurrence of f contains only the
      86$ ovariable occurrence in i.
      87
      88		killed := gen := {};
      89
      90		(forall k in [ #argsi, #argsi-1..iva1 ])
      91		    vo := get_oi(i, k);	$ get occurrence
      92		    if vo notin foccs then continue forall; end if;
      93		    v := argsi(k);
      94		    voccs := occsof{v};
      95		    bfrom{vo} := voccs * reachb;
      96	if debug_flag then
      97		    if p = om and v in uservars and
smfk  39			    opc /= q1_argout then
     102			globals_r{r} with:= v;
smfk  40			if exists vo1 in bfrom{vo} |
smfk  41					oi_rout(vo1) /= r then
smfk  42			    globals_e{r} with:= v;
smfk  43			end if;
     103		    end if;
     104	end if;
     105		    (forall vo1 in bfrom{vo})
     106			ffrom{vo1} with:= vo;
     107		    end forall;
     108		    gen with:= vo;
     109		    killed +:= voccs;
     110		end forall;
     111
     112		vo := get_oi(i, 1);	$ potential output occurrence
     113		if is_ovar(vo) and vo in foccs then
     114		    v := argsi(1);
     115		    voccs := occsof{v};
     117		    reachd := (reachb - killed + gen) * voccs;
     120		    rem_bfrom_dead +:= reachd;
smfb  78	if debug_flag then
smfb  79		    def_def +:=
smfb  80			{ [ vo1, vo ] : vo1 in reachd | is_ovar(vo1) };
     121		    if p = om and v in uservars and
     122			    opc /= q1_argin then
     123			globals_w{r} with:= v;
     124		    end if;
     125	end if;
smfk  44
     126$ note that if i is 'v1 := v2 + v3', then the last statement will cause
     127$ only v2 and v3 to be added to bfrom_dead, whereas preceding
     128$ occurrences of v do not become dead.
     129		    gen := gen - voccs + {vo};
     130$ note that for the above i, the last statement makes only v1 generated
     131$ through i, whereas v2 and v3 are killed.
     132		    killed +:= voccs;
     133		end if;
     134
     135$ finally, update the reachb value
     136		reachb := reachb - killed + gen;
     137	    end;	$ end for_inst
     138	end;		$ end for_block
     139    end forall;
     140
     141    end procedure comp_bfrom;
     142
     143
       1 .=member bma11i
       2
       3
       4    procedure bfrom_blockmaps(p, foccs);
       5$
       6$ this routine computes the basic block data flow maps for the
       7$ occurrences in 'occs'.  p = om indicates the interprocedural case
       8$ (in which we process all procedures, but only for occurrences of
       9$ global variables); otherwise p is the routine to be scanned.
      10$
      11$ note that the identity map will be associated with call blocks.
      12$ this is ok for intraprocedural analysis, and does not matter in
      13$ the interprocedural analysis, as these maps are reset then later
      14$ anyway.
      15$
      16    repr
      17	$ data structures for parameters
      18	p:			routine;
      19	foccs:			df_elmt;
      20
      21	$ data structures for local variables
      22	todo:			sparse set(routine);
      23	f:			remote smap(df_edge) df_map;
      24	r:			routine;
      25	b:			elmt blocks;
      26	fblk:			df_map;
      27	i:			elmt insts;
      28	opc:			elmt base_opcodes;
      29	argsi:			tuple(symbol);
      30	iva1:			integer;
      31	killed:			df_elmt;
      32	gen:			df_elmt;
      33	k:			integer;
      34	vo:			occurrence;
      35	voccs:			df_elmt;
      36	sblks:			sparse set(elmt blocks);
      37	lb:			symbol;
      38	b1:			elmt blocks;
      39    end repr;
      40
      41
      42    if p = om then todo := routs; else todo := { p }; end if;
      43    f := {};			$ initialize the edge map f
      44
      45    (forall r in todo)
      46	(for_block(b, r))
      47	    fblk := [ foccs, {} ];	$ start with the identity
      48	    (for_inst(i, b))
      49		opc := opcode(i);
      50		argsi := args(i);
      51		iva1 := first_ivar(opc);
      52
      53$ update fblk with the effect of the instruction i.
      54$ i is scanned from right to left, and the ovariable occurrence
      55$ of i will kill other ivariable occurrences of the same variable.
      56$ note that if i is 'v1 := v2 + v3' then only the ovariable v1 is
      57$ to be generated in i, and neither v2 nor v3 reach the next
      58$ instruction (i.e. both are killed by i).  for more details, see
      59$ similar comments in the procedure comp_bfrom above.
      60
      61		killed := gen := {};
      62		(forall k in [ #argsi, #argsi-1..iva1 ])
      63		    vo := get_oi(i, k);	$ get occurrence
      64		    if vo notin foccs then continue forall; end if;
      65		    gen with:= vo;
      66		    killed +:= occsof{argsi(k)};
      67		end forall;
      68
      69		vo := get_oi(i, 1);	$ potential output occurrence
      70		if is_ovar(vo) and vo in foccs then
      71		    voccs := occsof{argsi(1)};
      72		    gen := gen - voccs + {vo};
      73		    killed +:= voccs;
      74		end if;
      75
      76		fblk := [ foccs-killed+gen, gen ] .comp fblk;
      77$ (.comp is exported from the dataflow_solver module.)
      78
      79		if opc in ops_goto then
      80$ get successor blocks.  the last argument of each branch instruction
smfb  81$ is a target label.   for case statements,  the last argument is a con-
smfb  82$ stant map from case tag values to their labels.
      85
      86$ note also that one argument of a case statement (the 'x' in
      87$ 'case x of ...' is not a constant, and so may participate in our
      88$ analysis.  in particular, the effect of this occurrence of x on the
      89$ block map has to be analysed before this statement can be treated as
      90$ a block exit.
      91
      92		    if opc = q1_case then
      93			sblks := { blockof(value(lb)) :
      94					lb in range value(argsi(1)) };
      95		    else
      96			sblks := { blockof(value(argsi(#argsi))) };
      97		    end if;
      98
      99		    (forall b1 in sblks)
     100			f([b, b1]) := fblk .join f([b, b1]);
     101		    end forall;
     102		end if;
     103	    end;	$ end for_inst
     104	end;		$ end for_block
     105    end forall;
     106
     107    return f;
     108
     109    end procedure bfrom_blockmaps;
     110
     111
     112
     113
     114    operator .join(f, g);
     115$
     116$ functional join of f and g, where only g can be undefined (om).
     117$ for convenience, we avoid using a similar, though slightly
     118$ different operator available in the 'dataflow_solver' module.
     119$
     120    if g = om then
     121	return f;
     122    else
     123	return [ f(1) + g(1), f(2) + g(2) ];
     124    end if;
     125
     126    end operator .join;
     127
     128
     129    drop
     130	.comp,
     131	interproc_fwd_analysis,
     132	intraproc_fwd_analysis,
     133	fom,
     134	xom;
     135
     136
     137    end module setl_optimizer - bfrom_analysis;
     138
     139
smfc  64
smfc  65
smfc  66    module setl_optimizer - region_constants;
smfc  67$
smfc  68$ 1. mark as  'invariant' all statements  whose operands are  all either
smfc  69$    constant or  have their reaching  definitions  outside  the current
smfc  70$    interval.
smfc  71$
smfc  72$ 2. repeat step  (3) until at  some repetition  no  new  statements are
smfc  73$    marked 'invariant'.
smfc  74$
smfc  75$ 3. mark  'invariant' all  those  statements not  previously  so marked
smfc  76$    whose  operands  all  are  either  constant,  have  their  reaching
smfc  77$    definitions  outside the  current interval,  or  have  exactly  one
smfc  78$    reaching definition,  and that  definition is  an statement  in the
smfc  79$    current interval marked invariant.
smfc  80$
smfc  81$ 4. flag all conditional branches which are determined by
smfc  82$    loop-invariant computations.  in addition, flag the interval if all
smfc  83$    conditional branches are determined by loop-invariant computations.
smfc  84$
smfc  85    macro ud(oi);	(ud_memo(oi) ? ud_rout(oi))		endm;
smfc  86
smfc  87    var
smfc  88	ud_memo;		$ use-definition map, computed on demand
smfc  89
smfc  90    repr
smfc  91	ud_memo:		smap(occurrence)
smfc  92				    sparse set(occurrence);
smfc  93
smfc  94	comp_region_constants:	procedure(routine);
smfc  95	ud_rout:		procedure(occurrence)
smfc  96				    sparse set(occurrence);
smfc  97    end repr;
smfc  98
smfc  99
smfc 100    procedure find_region_constants;
smfc 101$
smfc 102$ this routine is the main driver routine to detect potentially infinite
smfc 103$ loops.
smfc 104$
smfc 105    repr
smfc 106	p:			routine;
smfc 107    end repr;
smfc 108
smfc 109
smfc 110    title('cims.setl.' + prog_level + ' - flow-constant loops');
smfc 111    printa(term_file, '   - flow-constant loop analysis');
smfc 112
smfc 113    $ initialise global-to-module objects
smfc 114    ud_memo := {};
smfc 115
smfc 116    (forall p in routs)
smfc 117	comp_region_constants(p);
smfc 118    end forall;
smfc 119
smfc 120    $ delete global-to-module objects
smfc 121    ud_memo := om;
smfc 122
smfc 123    statistics with:= time;	$ save time for final statistics
smfc 124
smfc 125
smfc 126    end procedure find_region_constants;
smfc 127
smfc 128
smfc 129
smfc 130
smfc 131    procedure comp_region_constants(p);
smfc 132$
smfc 133$ this routine performs the analysis required to detect  region-constant
smfc 134$ branches.
smfc 135$
smfc 136    init
smfc 137	is_called := {},	$ maps each interval to the routines
smfc 138				$  which might be called from within it.
smfc 139	is_desc := {},		$ maps each interval to the intervals it
smfc 140				$  contains.
smfc 141	need_process := {};	$ set of intervals which need to be
smfc 142				$  processed, either because they have
smfc 143				$  more than one successor or because
smfc 144				$  they are potentially loop-invariant.
smfc 145
smfc 146    repr
smfc 147	p, q, r:		routine;
smfc 148	is_called:		mmap{elmt blocks} set(routine);
smfc 149	is_desc:		mmap{elmt blocks} set(elmt blocks);
smfc 150	need_process:		set(elmt blocks);
smfc 151	invariants:		set(elmt insts);
smfc 152	b, c, i, i1:		elmt blocks;
smfc 153	inst:			elmt insts;
smfc 154	opc:			elmt base_opcodes;
smfc 155	workpile, seen:		set(routine);
smfc 156	j, k:			integer 0..65536;
smfc 157	vo, vox, voy:		occurrence;
smfc 158	convrgd:		boolean;
smfc 159	has_const, has_cond:	boolean;
smfc 160	inv_count:		integer;
smfi  64	l_messages:		mmap{integer}
smfi  65				    mmap{string}
smfi  66					set(tuple(string));
smfc 161    end repr;
smfc 162
smfc 163
smfc 164    if 'e' in dump_string then	$ print heading for statistics
smfc 165	print('interval    #desc  #called   #scans   #invar   step 4');
smfc 166	print('-----------------------------------------------------');
smfc 167    end if;
smfc 168
smfc 169$ compute is_desc,  which maps each interval to the set of all intervals
smfc 170$ which are contained in it.   note that since intervals are strictly an
smfc 171$ intraprocedural structure,  we only  need the  is_descendant predicate
smfc 172$ for  the  intervals of  the routine currently being  analysed.   since
smfc 173$ is_desc is a multi-valued map, this will not cause any problems.
smfc 174
smfc 175    $ iterate over the intervals of p in reverse  preorder,  i.e. inner-
smfc 176    $ to-outer.  note that we do not include the outer-most interval.
smfc 177
smfc 178    (forall j in [ 1..#ints(p)-1 ])
smfc 179	i := ints(p)(j);	$ i is the interval header
smfc 180	is_desc{i} := { i } +/[ is_desc{b} : b in int_nodes(i) ];
smfc 181	is_called{i} := {} +/[ is_called{b} : b in int_nodes(i) ];
smfc 182	need_process +:= { b in int_nodes(i) | #vedges{b} > 1 };
smfc 183
smfc 184	$ find all routines  which  can  be  invoked  from  within  this
smfc 185	$ interval.   when we copmute the transitive closure of the call
smfc 186	$ graph,  domain-restricted to the routines called within i,  we
smfc 187	$ can use the fact that we have already computed the closure for
smfc 188	$ all  routines in called  within an interval  contained  in the
smfc 189	$ current interval, i.
smfc 190
smfc 191	workpile := {}; seen := is_called{i};
smfh  10        (forall c in callsin{p} |
smfh  11                        intof(c) = i and callproc(c) notin seen)
smfc 193	    workpile with:= callproc(c);
smfh  12	end forall;
smfh  13
smfc 195	(while workpile /= {})
smfc 196	    q from workpile; seen with:= q;
smfc 197	    is_called{i} with:= q;
smfc 198	    (forall r in cgraph{q} | r notin seen)
smfc 199		workpile with:= r;
smfc 200	    end forall;
smfc 201	end while;
smfc 202
smfc 203	$ next we  determine for each expression  whether it is constant
smfc 204	$ within the  current interval  or not.   racall that  we do not
smfc 205	$ include the outer-most interval.
smfc 206
smfc 207	$ step 1: mark 'invariant' those instructions whose operands are
smfc 208	$ all either  constant or have  all  their reaching  definitions
smfc 209	$ outside the interval i.
smfc 210
smfc 211	$ step 2: repeat step  (3)  until  at  some  repetition  no  new
smfc 212	$ instructions are marked 'invariant'.
smfc 213
smfc 214	$ step 3: mark 'invariant' al those  instructions not previously
smfc 215	$ so marked  whose  operands all  are either constant,  have all
smfc 216	$ their  reaching definitions  outside i,  or have  exactly  one
smfc 217	$ reaching definition,  and that definition is an instruction in
smfc 218	$ i marked invariant.
smfc 219
smfc 220	$ note that we can merge  steps (1) and (3) since the high-level
smfc 221	$ implementation  of invariants  requires no  separate  pass  to
smfc 222	$ initialise the data structure properly.
smfc 223
smfc 224	$ possibly we could speed up this step dramatically if after the
smfc 225	$ first iteration  over the code we would use a work pile and du
smfc 226	$ links to only check instructions which might become invariant,
smfc 227	$ rather than scan the entire code over again.  however, we must
smfc 228	$ be careful when we use ffrom links to make sure that we propa-
smfc 229	$ gate correctly, or we must compute du and ud links.
smfc 230
smfc 231	loop
smfc 232	  init  invariants := {};	$ invariant computations in i
smfc 233		inv_count := 0;		$ number of code scans
smfc 234	  doing convrgd := true;	$ flag indicating convergence
smfc 235		inv_count +:= 1;
smfc 236	  until convrgd
smfc 237	do
smfc 238	    (forall i1 in is_desc{i}, b in int_nodes(i1))
smfc 239	      (for_inst(inst, b))
smfc 240		if inst in invariants then continue; end if;
smfc 241		opc := opcode(inst);
smfc 242		if opc notin ops_fold then continue; end if;
smfc 243		if forall k in [ first_ivar(opc)..#args(inst) ] |
smfc 244			is_const(args(inst)(k))=1
smfh  14			or args(inst)(k) = sym_om
smfc 245			or # ud(get_oi(inst, k)) = 1
smfc 246				and instno(arb ud(get_oi(inst, k)))
smfc 247					in invariants
smfc 248$$--  the next sub-test would test that whenever there exists exactly
smfc 249$$--  one preceding definition for a global in a routine within the
smfc 250$$--  current region, then we assume that this definition is invariant.
smfc 251$$--  this represents a save overestimate.
smfc 252$$--			or # ud(get_oi(inst, k)) = 1
smfc 253$$--				and oi_rout(arb ud(get_oi(inst, k)))
smfc 254$$--					/= p
smfc 255$$--				and oi_rout(arb ud(get_oi(inst, k)))
smfc 256$$--					in is_called{i}
smfc 257			or forall vo in ud(get_oi(inst, k)) |
smfc 258				oi_rout(vo) = p
smfc 259				    and intof(blockof(instno(vo)))
smfc 260					notin is_desc{i}
smfc 261				or oi_rout(vo) /= p
smfc 262				    and oi_rout(vo) notin is_called{i}
smfc 263		then
smfc 264		    invariants with:= inst;
smfc 265		    convrgd := false;
smfc 266		end if;
smfc 267	      end;	$ end for_inst;
smfc 268	    end forall i1;
smfc 269	end loop;
smfc 270
smfc 271	if 'e' in dump_string then
smfc 272	    print(
smfc 273		lpad(str i, 8),
smfc 274		lpad(str(#(is_desc{i})), 8),
smfc 275		lpad(str(#(is_called{i})), 8),
smfc 276		lpad(str inv_count, 8),
smfc 277		lpad(str(#(invariants)), 8),
smfc 278		lpad(str(#(is_desc{i} * need_process with i)), 8)
smfc 279		);
smfc 280	end if;
smfc 281
smfc 282	$ step 4: flag all conditional branches  which are determined by
smfc 283	$ loop-invariant computations.   in addition,  flag the interval
smfc 284	$ if all  conditional  branches are determined by loop-invariant
smfc 285	$ computations.
smfc 286
smfi  67	has_const := false; has_cond := false; l_messages := {};
smfc 288
smfc 289	$ iterate over the code
smfc 290	(forall i1 in is_desc{i} | i1 = i or i1 in need_process)
smfc 291	  (forall b in int_nodes(i1))
smfc 292	    (for_inst(inst, b))
smfc 293
smfc 294		$ look for conditional branches
smfc 295		if opcode(inst) notin ops_goto then continue; end if;
smfc 296		if opcode(inst) notin ops_ivar then continue; end if;
smfg  84		if opcode(inst) = q1_bif    then continue; end if;
smfg  85		if opcode(inst) = q1_bifnot then continue; end if;
smfc 297
smfc 298		$ this is a conditional branch
smfe  21		if opcode(inst) = q1_case then
smfe  22		    vox := get_oi(inst, 2);
smfe  23		else
smfe  24		    vox := get_oi(inst, 1);
smfe  25		end if;
smfh  15
smfh  16		if forall voy in ud(vox) | oi_op(voy) = q1_pos then
smfh  17		    continue;
smfh  18		end if;
smfh  19
smfe  26		voy := arb ud(vox);
smfh  20		if is_const(oi_sym(vox))=1 or oi_sym(vox) = sym_om
smfc 301			or # ud(vox) = 1 and instno(voy) in invariants
smfc 302$$--  the next sub-test would test that whenever there exists exactly
smfc 303$$--  one preceding definition for a global in a routine within the
smfc 304$$--  current region, then we assume that this definition is invariant.
smfc 305$$--  this represents a save overestimate.
smfc 306$$--			or # ud(vox) = 1
smfc 307$$--				and oi_rout(voy) /= p
smfc 308$$--				and oi_rout(voy) in is_called{i}
smfc 309			or forall voy in ud(vox) |
smfc 310				oi_rout(voy) = p
smfc 311					and intof(blockof(instno(voy)))
smfc 312						notin is_desc{i}
smfc 313				or oi_rout(voy) /= p
smfc 314					and oi_rout(voy)
smfc 315						notin is_called{i}
smfc 316		then
smfi  68		    l_messages{stmtof(inst)}{'i'} with:=
smfc 318			[ 'expression controlling conditional branch '
smfc 319			    + if is_called{i} = {}
smfc 320				then 'is'
smfc 321				else 'appears to be'
smfc 322				end
smfc 323			    + ' loop-invariant'
smfc 324			    + if is_called{i} = {}
smfc 325				then ' in the loop'
smfc 326				else ''
smfc 327				end,
smfc 328			  if is_called{i} = {}
smfc 329				then ''
smfc 330				else 'in the loop '
smfc 331				end
smfc 332			    + 'starting at statement '
smfc 333			    + str(stmtof(first_inst(i))-sc_stmt_ct(p)+1)
smfc 334			];
smfc 335		    has_const := true;  $ i has constant branch
smfc 336		else
smfc 337		    has_cond := true;   $ i has conditional branch
smfc 338		end if;
smfc 339	    end;	$ end for_inst;
smfc 340	  end forall;
smfc 341	end forall;
smfc 342
smfc 343	if has_const then
smfc 344	    messages{stmtof(first_inst(i))}
smfc 345			{if has_cond then 'i' else 'w' end} with:=
smfc 346		[ 'this loop '
smfc 347		    + if not has_cond and is_called{i} = {}
smfc 348			then 'is'
smfc 349			else 'could be'
smfc 350			end
smfc 351		    + ' flow-constant:  '
smfc 352		    + if has_cond then 'some' else 'all' end
smfc 353		    + ' conditional branches '
smfc 354		    + if is_called{i} = {} then
smfc 355			if has_cond
smfc 356			  then 'are'
smfc 357			  else 'are controlled by'
smfc 358			  end
smfc 359		      else
smfc 360			'appear to'
smfc 361		      end,
smfc 362 		  if is_called{i} = {} then
smfc 363			if has_cond then 'controlled by ' else '' end
smfc 364		      else
smfc 365			'be controlled by '
smfc 366		      end
smfc 367		    + 'loop-invariant expressions.' ];
smfi  69
smfi  70	    if has_cond then messages +:= l_messages; end if;
smfc 368
smfc 369	    $ we might have to scan this interval again
smfc 370	    need_process with:= i;
smfc 371	end if;
smfc 372
smfc 373    end forall j;
smfc 374
smfc 375
smfc 376    end procedure comp_region_constants;
smfc 377
smfc 378
smfc 379
smfc 380    procedure ud_rout(oi);
smfc 381$
smfc 382$ this procedure  computes  the  transitive  closure  of bfrom  for the
smfc 383$ occurrence oi.
smfc 384$
smfc 385    repr
smfc 386	oi:			occurrence;
smfc 387	workoccs, seenoccs:	set(occurrence);
smfc 388	vox, voy:		occurrence;
smfc 389    end repr;
smfc 390
smfc 391    workoccs := { oi };		$ workpile of preceding occurrences
smfc 392    seenoccs := {};		$ occurrences already processed
smfc 393
smfc 394    (while workoccs /= {})
smfc 395	vox from workoccs; seenoccs with:= vox;
smfc 396	(forall voy in bfrom{vox})
smfc 397	    if is_ovar(voy) or
smfc 398		    oi_op(voy) in ops_iter and argno(voy) = 2 then
smfc 399		if ud_memo(oi) = om then
smfc 400		    ud_memo(oi) := { voy };
smfc 401		else
smfc 402		    ud_memo(oi) with:= voy;
smfc 403		end if;
smfc 404	    else
smfc 405		if ud_memo(voy) /= om then
smfc 406		    if ud_memo(oi) = om then
smfc 407			ud_memo(oi) := ud_memo(voy);
smfc 408		    else
smfc 409			ud_memo(oi) +:= ud_memo(voy);
smfc 410		    end if;
smfc 411		elseif voy notin seenoccs then
smfc 412		    workoccs with:= voy;
smfc 413		end if;
smfc 414	    end if;
smfc 415	end forall;
smfc 416    end while;
smfc 417
smfc 418    return ud_memo(oi);
smfc 419
smfc 420
smfc 421    end procedure ud_rout;
smfc 422
smfc 423
smfc 424    drop
smfc 425	ud;
smfc 426
smfc 427
smfc 428    end module setl_optimizer - region_constants;
smfc 429
smfc 430
       1 .=member dsol13
       2
       3
       4    module setl_optimizer - dataflow_solver_syms;
       5$
       6$ this module contains a package of general purpose routines to solve
       7$ bit vector data flow problems either intraprocedurally or interpro-
       8$ cedurally.  we can distinguish between four basic types of such
       9$ analyses, according to the character of the desired analysis:
      10$
      11$ forward  - data is to be propagated in the direction of the flow,
      12$	     from procedure entries forward.
      13$
      14$ backward - data is to be propagated in the reverse direction of the
      15$            flow, from exits backward.
      16$
      17$ meet     - whenever two paths converge (for forward analysis) or
      18$            diverge (for backward analysis) take the meet (set inter-
      19$            section)  of data values propagated along these paths.
      20$
      21$ join     - as in meet, except that the join (set union) of the
      22$            corresponding data values is to be taken.
      23$
      24$ typical examples are: expression availability analysis is a
      25$ forward - meet analysis, unconditional exposure of wxpressions (also
      26$ known as 'very busy' expressions analysis) is a backward - meet ana-
      27$ lysis; reaching definitions analysis is a forward - join analysis,
      28$ and live variables analysis is a backward - join analysis.
      29$
      30$ as noted in chapters 5 and 6, forward and backward analyses require
      31$ substantially different logic, so that each of them is executed in a
      32$ different subpackage;  however, the difference between meet and join
      33$ problems turns out to be rather minor, so that they both can be
      34$ handled by the same (forward or backward) package, using a switch to
      35$ indicate whether a particular analysis is of meet or join type.
      36$
      37$ this module exports the following procedures:
      38$
      39$ cgraph_analysis - call graph analysis routine, to be called once
      40$                   before solving any data flow problem interproce-
      41$                   durally.
      42$
      43$ interproc_fwd_analysis - call this to solve interprocedural
      44$                   forward data flow analyses.
      45$
      46$ intraproc_fwd_analysis - call this to solve intraprocedural
      47$                   forward data flow analysis for a given
      48$                   procedure.
      49$
      50$ interproc_back_analysis - call this to solve interprocedural
      51$                   backward data flow analysis
      52$
      53$ intraproc_back_analysis - performs intraprocedural backward
      54$                   analysis for a given procedure.
      55$
      56$ this package assumes the following global objects to be
      57$ available:
      58$
      59$ cgraph    - the program call graph, represented as a set
      60$             of edges; an edge (p,q) is in cgraph iff p is a
      61$             procedure which contains a call to the procedure q.
      62$
      63$ routs     - set of all program procedures (i.e. all nodes
      64$             of the call graph).
      65$
      66$ sym_main  - main-program identifier (i.e. the entry node of the
      67$             call graph).
      68$
      69$ routof    - maps each block to the procedure containing it.
      70$
      71$ rentry    - maps each procedure to its entry block.
      72$
      73$ rexit     - maps each procedure to its exit (return) block.
      74$
      75$ rstop     - maps each procedure to its stop block, if any.
      76$
      77$ callsin   - maps each procedure to the set of all call blocks
      78$             in it.
      79$
      80$ callproc  - maps each call block to the procedure it calls.
      81$
      82$ cessor    - the program flow graph, as a union of the flow graphs of
      83$             all procedures.  an edge (m, n) is in cessor iff either m
      84$             contains a branch to n, or else m is a call block and n
      85$             is the block immediately following n.  the nodes of the
      86$             flow graph are either basic blocks or derived intervals
      87$             (which are represented by their target blocks), in which
      88$             case an edge (int, v) in cessor can indicate the possi-
      89$             bility of a transfer of control from the interval int to
      90$             a successor v of some node in int.  these edges are
      91$             called virtual edges (as above; see the interval analysis
      92$             package for more details).
      93$
      94$ pred      - the inverse map of cessor.
      95$
      96$ ints      - maps each procedure to the tuple of its intervals
      97$             in reverse preorder (relative to a depth first
      98$             spanning tree of its flow graph).
      99$
     100$ int_nodes - maps each interval to the sequence of its nodes
     101$             in interval order (i.e., reverse postorder).
     102$
     103$ proper_ints - the set of all proper intervals (those which do
     104$             not contain irreducible nucleii).
     105$
     106$ intof     - maps each flow graph node to the interval containing
     107$             it.
     108$
     109$ vedges    - set of all virtual edges (see the description of
     110$             cessor above).
     111$
     112$ in addition this module uses the following global-within-
     113$ the-module variables, the first three of which are used
     114$ to transmit flags and analysis constants between inner routines,
     115$ while the rest are built by a recursive depth-first search
     116$ procedure during call-graph analysis, and are used later in that
     117$ analysis.
     118$
     119    macro .comp;                   .comp_syms                   endm;
     120    macro interproc_fwd_analysis;  interproc_fwd_analysis_syms  endm;
     121    macro intraproc_fwd_analysis;  intraproc_fwd_analysis_syms  endm;
     122    macro interproc_back_analysis; interproc_back_analysis_syms endm;
     123    macro intraproc_back_analysis; intraproc_back_analysis_syms endm;
     124    macro fom;                     fom_syms                     endm;
     125    macro xom;                     xom_syms                     endm;
     126
     127    var
     128	id,		$ identity flow map
     129	zero,		$ null data state
     130	meet_flag,	$ true if meet analysis; otherwise false
     131	seen,		$ procedures already in dfst of cgraph
     132	cnpre,		$ current preorder index in dfst
     133	cnpost,		$ current postorder index in dfst
     134	nodeno,		$ preorder numbering map
     135	postno,		$ postorder numbering map
     136	ndescs;		$ no. of descendants map
     137
     138
     139    repr
     140	mode df_elmt:		df_elmt_syms;
     141	mode df_map:		df_map_syms;
     142
     143       .meetjoin:		operator(df_map, df_map) df_map;
     144       .mjv:			operator(df_elmt, df_elmt) df_elmt;
     145       .of:			operator(df_map, df_elmt) df_elmt;
     146
     147	cdfst:			procedure(routine);
     148
     149       interproc_fwd_eliminate: procedure(
     150				  remote smap(df_edge) df_map	 )
     151				    remote smap(df_node) df_map;
     152       intraproc_fwd_eliminate: procedure(
     153				  routine,
     154				  remote smap(df_node) df_map,
     155				  remote smap(df_edge) df_map,
     156				  string    )
     157				    boolean;
     158	propagate_exposed:	procedure(
     159				  routine,
     160				  remote smap(df_edge) df_map,
     161				  remote smap(df_node) df_map,
     162				  remote mmap{df_node} df_elmt,
     163				  remote mmap{df_node} df_elmt,
     164				  remote mmap{df_node} df_elmt
     165				  );
     166	entry_info:		procedure(
     167				  remote smap(df_edge) df_map,
     168				  remote smap(df_node) df_map,
     169				  boolean,
     170				  remote mmap{df_node} df_elmt    )
     171				    remote smap(routine) df_elmt;
     172	fwd_propagate_in:	procedure(
     173				  routine,
     174				  remote smap(df_edge) df_map,
     175				  remote smap(df_node) df_map,
     176				  remote smap(df_node) df_elmt,
     177				  df_elmt,
     178				  boolean,
     179				  remote mmap{df_node} df_elmt
     180				  );
     181	interproc_back_eliminate:
     182				procedure(remote smap(df_edge) df_map)
     183				    remote smap(df_edge) df_map;
     184	intraproc_back_eliminate:
     185				procedure(
     186				  routine,
     187				  remote smap(df_edge) df_map,
     188				  remote smap(df_edge) df_map,
     189				  remote smap(routine) df_map,
     190				  *    )    $$-- flow_flag
     191				    boolean;
     192	intra_aux_eliminate:	procedure(
     193				  routine,
     194				  remote smap(df_edge) df_map,
     195				  remote smap(df_edge) df_map,
     196				  remote smap(df_node) df_map
     197				  );
     198	exit_info:		procedure(
     199				  remote smap(df_edge) df_map,
     200				  remote smap(df_edge) df_map,
     201				  remote smap(df_node) df_map    )
     202				    remote smap(routine) df_elmt;
     203	back_propagate_in:	procedure(
     204				  routine,
     205				  remote smap(df_node) df_map,
     206				  remote smap(df_node) df_elmt,
     207				  df_elmt
     208				  );
     209
     210	$ data structures for variables global to this module
     211	id:			df_map;
     212	zero:			df_elmt;
     213	meet_flag:		boolean;
     214	cnpre:			integer;
     215	cnpost:			integer;
     216	nodeno:			remote smap(routine) integer;
     217	postno:			remote smap(routine) integer;
     218	ndescs:			remote smap(routine) integer;
     219	seen:			remote set(routine);
     220    end repr;
     221
     222
       1 .=member cga13a
       2
       3    procedure cgraph_analysis;
       4$
       5$ this procedure performs the call graph analysis needed for
       6$ our interprocedural data flow analysis solver. it computes
       7$ the following objects:
       8$
       9$ cg_sccs    - a tuple of (roots of the) strongly connected
      10$              components of cgraph, arranged in reverse postorder.
      11$
      12$ scc_nodes  - maps each (root of a) strongly connected component
      13$              into a tuple containing its nodes in reverse
      14$              postorder.
      15$
      16$ scc_d      - maps each (root of a) strongly connected component
      17$              s into an estimate of its loop-interconnectedness
      18$              parameter d, defined as the maximal number of back
      19$              edges along any acyclic path in s (we do not attempt to
      20$              obtain that precise value, but rather use a crude
      21$              upper bound for it, namely the number of back
      22$              edge targets contained in s.)
      23$
      24    repr
      25	inverse:		remote mmap{routine}
      26				    remote set(routine);
      27	p, q, r:		routine;
      28	invpostnodes:		smap(integer) routine;
      29	n:			integer;
      30	backinv:		remote mmap{routine}
      31				    remote set(routine);
      32	targback:		remote set(routine);
      33	junk:			remote set(routine);
      34	sccroot:		remote smap(routine) routine;
      35	i:			integer;
      36	newnodes:		remote set(routine);
      37	tcl:			remote mmap{routine}
      38				    remote set(routine);
      39	tcl_p, new_p, delta:	remote set(routine);
      41    end repr;
      42$
      43$ begin by calling a standard depth first spanning tree
      44$ routine, which will compute the following objects:
      45$
      46$ nodeno - preorder node numbering map.
      47$ postno - postorder node numbering map.
      48$ ndescs - number of descendants map.
      49$
      50
      51    title('cims.setl.' + prog_level + ' - call graph analysis');
      52    printa(term_file, '   - call graph analysis');
      55
      56    $ initialize the globals for depth-first spanning tree routine
      57    nodeno := {};       postno := {};       ndescs := {};
      58    seen := {};         cnpre := 0;         cnpost := 0;
      59
      60    cdfst(sym_main);	$ build the call graph for the main program
      61
      62    if exists p in routs | p notin seen then $ disconnected call graph
      63	(forall p in routs | p notin seen)
      64	    ermsg(name(p)+' cannot be reached from the main program');
      65	end forall;
      66
      67	abort('disconnected call graph');
      68    end if;
      69
      70    $ delete the globals we are done with
      71    seen := om;         cnpre := om;        cnpost := om;
      72
      73    $ tree-descendancy macro, identical to the one used for interval
      74    $ analysis.
      75    macro is_desc(p, q);  $ test whether p is a descendant of q
      76	(nodeno(p) >= nodeno(q) and nodeno(p) <= nodeno(q)+ndescs(q))
      77    endm;
      78$
      79$ next compute some auxiliary objects:
      80$
      81    inverse := { [ p, q ] : [ q, p ] in cgraph }; $ inverse call graph
      82    invpostnodes := { [ #routs+1-n, p ] : n = postno(p) };
      83	      $ procedures in their reverse postorder
      84    backinv := { [ p, q ] in inverse | is_desc(q, p) };
      85	      $ set of all inverse back edges
      86    targback := domain backinv;	$ back edge targets
      87
      88    $ initialize globals (rf. above)
      89    cg_sccs := [];   scc_nodes := {};   scc_d := {};
      90
      91    sccroot := {};	$ strongly connected component root map
      92$
      93$ iterate through the procedures, looking for strongly
      94$ connected components.
      95$
      96    (forall i in [ 1..#invpostnodes ])
      97	p := invpostnodes(i);
      98	if sccroot(p) = om then	$ a new root of a s.c.c.
      99	    sccroot(p) := p;
     100	    cg_sccs with:= p;	$ p corresponds to a new component
     101	    scc_nodes(p) := [ p ];
     102	    if p in targback then   $ a non-trivial s.c.c.
     103		newnodes := backinv{p} less p; $ new nodes in s.c.c.
     104		scc_d(p) := 1;	$ no. of backedge targets in s.c.c.
     105		(while newnodes /= {})
     106		    q from newnodes;
     107		    sccroot(q) := p;	$ mark q belongs to s.c.c.
     108		    if q in targback then scc_d(p) +:= 1; end if;
     109		    newnodes +:=
     110			{ r in inverse{q} |
     111				is_desc(r, p) and sccroot(r) = om };
     112		end while;
     113
     114	    else		$ a trivial s.c.c.
     115		scc_d(p) := 0;
     116	    end if;
     117
     118	else			$ p belongs to a scc already scanned
     119	    scc_nodes(sccroot(p)) with:= p;
     120	end if;
     121    end forall;
     122$
     123$ determine which routines are recursive:  this is done by computing the
     124$ transitive closure of the call cgraph.
     125$
     126    tcl := {};
     127    (forall p in routs)
     128	tcl_p := new_p := cgraph{p};
     129	(while new_p /= {})
     130	    q from new_p;
     131	    delta := cgraph{q} - tcl_p;
     132	    new_p +:= delta;
     133	    tcl_p +:= delta;
     134	end while;
     135	tcl{p} := tcl_p;
     136    end forall;
     137
     138    (forall p in routs)
     139	if p in tcl{p} then is_rec(p) := 1; else is_rec(p) := om; end;
     140    end forall;
     141
     142    $ delete the static variables global to the module
     143    nodeno := om;       postno := om;       ndescs := om;
     148
     149
     150    end procedure cgraph_analysis;
     151
     152
     153
     154
     155    procedure cdfst(p);
     156$
     157$ this routine builds the depth first spanning tree starting with
     158$ node 'p'. this routine differs in various details from the depth
     159$ first spanning routine used for interval analysis.
     160$
     161    repr
     162	q:			routine;
     163    end repr;
     164
     165    nodeno(p) := (cnpre +:= 1);
     166    ndescs(p) := 0;
     167
     168    seen with:= p;
     169
     170    (forall q in cgraph{p} | q notin seen)
     171	cdfst(q);
     172	ndescs(p) +:= (ndescs(q) + 1);
     173    end forall;
     174
     175    postno(p) := (cnpost +:= 1);
     176
     177    end procedure cdfst;
     178
     179
       1 .=member efa13b
       2
       3
       4    procedure interproc_fwd_analysis(rw f, wr soln, id_prm, zero_prm,
       5				meet_flag_prm, move_code,
       6				rw exposed, wr insert, safe);
       7$
       8$ note declarations of 'read-write' parameters ('rw') and 'write-only'
       9$ parameters ('wr').
      10$
      11$ this is the master routine to perform a specific data flow
      12$ analysis interprocedurally. its parameters are:
      13$
      14$ f   - maps each edge (m, n) in the flow graph to a compact
      15$       representation of its data-propagation map f(m,n).
      16$       initially this information has to be provided only for
      17$       basic blocks (but not for call blocks); the first phase
      18$       of the analysis will fill in the additional entries.
      19$       each f(m,n) is represented as a pair [a, b] in l x l,
      20$       such that for each x in l, f(m,n)(x) = x*a + b, and
      21$       a contains b (this latter condition ensures that the
      22$       representation is unique, and also simplifies some
      23$       functional manipulations).
      24$
      25$ soln- the solution vector for the analysis. soln maps each
      26$       flow graph node to the data found to be known at its
      27$       entry.
      28$
      29$ the next three parameters are transmitted internally between
      30$ subprocedures by assigning them to global variables, as they
      31$ are constant per analysis. the corresponding globals are:
      32$
      33$ id  - the identity map representation. id = [u, {}], where
      34$       u is the universal set over which bitvectors are taken
      35$       in this analysis (e.g. set of all program expressions,
      36$       set of all variables etc.)
      37$
      38$ zero - the initial data value, i.e. flow data assumed at the main
      39$       program entry.
      40$
      41$ meet_flag - a flag indicating whether the analysis is a meet
      42$       analysis or a join analysis.
      43$
      44$ aux_f - these are auxiliary propagation maps. for each flow
      45$       graph node u, aux_f(u) denotes the effect of propagation
      46$       from the entry to i, the interval containing u, through
      47$       i, to the entry of u.
      48$
      49$ move_code - a flag indicating that code motion is required.
      50$
      51$ exposed - this is initially the set of computations (corresponding
      52$       to analysis elements (bits)) exposed at the start of each
      53$       basic block n (i.e. computed with no prior kill in n). the
      54$       inner-to-outer phase of our analysis attaches an 'exposed'
      55$       value to each interval processed. exposed{i} is the set of all
      56$       expressions t for which there exists a computation of t
      57$       within the interval i which would become redundant if and
      58$       only if t became available at the entry to (the target block
      59$       of) i. note, however, that the logical place at which
      60$       computations movable out of an interval i should be inserted
      61$       is the end of the target block of i, rather than its start.
      62$       thus if that target block is nonempty then exposed{i}
      63$       need not represent those movable computations. for this
      64$       reason we provide the parameter 'insert' which gives the
      65$       desired set of movable code.
      66$
      67$ insert - this output parameter will map each interval into
      68$       the set of all computations movable out of its loop,
      69$       which are to be inserted at the end of the target
      70$       block of the interval. the actual insertion should be
      71$       performed by the calling procedure.
      72$
      73$ our analysis procedures makes frequent use of the following
      74$ operators (which could be also written as macros, if it were
      75$ not for the convenience of the infix notation that we prefer
      76$ to use):
      77$
      78$ .comp     - functional composition
      79$ .meetjoin - functional meet or join, depending on meet_flag
      80$ .mjv      - meet or join of lattice values
      81$ .of       - functional application
      82$
      83$ all these operators have elementary set expressions; see below
      84$ for details.
      85$
      86$ note also that these operators must be prepared to handle
      87$ undefined flow values, which will be represented
      88$ by a special constant 'fom'; for example,
      89$        g .comp fom = fom .comp g = fom;
      90$                (concatenation of an undefined flow with a defined
      91$                one is still undefined)
      92$        g .meetjoin fom = fom .meetjoin g = g.
      93$                (a join or a meet of an undefined flow with a defined
      94$                flow yields the defined flow.)
      95$
      96$ another special constant 'xom' is used to denote the undefined data
      97$ state in l.
      98$
      99    repr
     100	$ data structures for parameters
     101	f:			remote smap(df_edge) df_map;
     102	soln:			remote smap(df_node) df_elmt;
     103	id_prm:			df_map;
     104	zero_prm:		df_elmt;
     105	meet_flag_prm:		boolean;
     106	move_code:		boolean;
     107	exposed:		remote mmap{df_node} df_elmt;
     108	insert:			remote mmap{df_node} df_elmt;
     109	safe:			remote mmap{df_node} df_elmt;
     110
     111	$ data structures for local variables
     112	aux_f:			remote smap(df_node) df_map;
     113	ent_inf:		remote smap(routine) df_elmt;
     114	p:			routine;
     115    end repr;
     116$
     117$ transfer constant parameters to globals
     118$
     119    id        := id_prm;
     120    zero      := zero_prm;
     121    meet_flag := meet_flag_prm;
     122$
     123$ the master procedure consists of the following three phases:
     124$
     125$ 1. interprocedural elimination phase
     126$
     127    aux_f := interproc_fwd_eliminate(f);
     128$
     129$ if code motion is required then perform an additional
     130$ phase, computing the sets of movable code.
     131$
     132    if move_code then
     133	insert := {};
     134	(forall p in routs)
     135	    propagate_exposed(p, f, aux_f, exposed, insert, safe);
     136	end forall;
     137    end if;
     138$
     139$ 2. find data at procedure entries
     140$
     141    ent_inf := entry_info(f, aux_f, move_code, insert);
     142$
     143$ 3. final propagation phase
     144$
     145    soln := {};     $ initialize the solution
     146    (forall p in routs)
     147	fwd_propagate_in(p, f, aux_f, soln, ent_inf(p),
     148			move_code, insert);
     149    end forall;
     150
     151    end procedure interproc_fwd_analysis;
     152
     153
       1 .=member efe13c
       2
       3
       4    procedure interproc_fwd_eliminate(rw f);
       5$
       6$ this is the driver routine for the first interprocedural
       7$ inner-to-outer interval pass. procedures are analyzed in
       8$ the following order: we process the strongly connected
       9$ components of the call graph in their postorder; for each
      10$ such component, we iterate through its procedures in their
      11$ postorder, no more than 2*d+1 times, where d is the loop-
      12$ interconnectedness parameter of the component.
      13$
      14    repr
      15	$ data structures for parameters
      16	f:			remote smap(df_edge) df_map;
      17
      18	$ data structures for local variables
      19	aux_f:			remote smap(df_node) df_map;
      20	i:			integer;
      21	scc:			routine;
      22	scc_procs:		tuple(routine);
      23	flow_flag:		string;
      24	j:			integer;
      25	proc_converge:		boolean;
      26	k:			integer;
      27	p:			routine;
      28    end repr;
      29
      30
      31    aux_f := {};   $ initialize auxiliary maps
      32
      33    $ iterate through the s.c.c.'s of cgraph
      34    (forall i in [ #cg_sccs, #cg_sccs-1..1 ])
      35
      36	scc := cg_sccs(i);		$ get a s.c.c.
      37	scc_procs := scc_nodes(scc);	$ procedures in that s.c.c.
      38	flow_flag := 'first_inter';	$ first processing of the s.c.c.
      39
      40	(forall j in [ 1..2*scc_d(scc)+1 ])
      41	    proc_converge := true;
      42
      43	    (forall k in [ #scc_procs, #scc_procs-1..1 ])
      44		p := scc_procs(k);
      45		proc_converge :=
      46		    intraproc_fwd_eliminate(p, aux_f, f, flow_flag)
      47		    and proc_converge;
      48$ the intraproc_fwd_eliminate routine analyzes p; its fourth parameter
      49$ indicates whether the analysis is first-time interprocedural, second
      50$ -time interprocedural or intraprocedural; it returns a flag to
      51$ indicate whether information in p has stabilized.
      52	    end forall k;
      53
      54	    flow_flag := 'second_inter'; $ additional passes thru scc
      55
      56	    if proc_converge then quit forall j; end;
      57	end forall j;
      58    end forall i;
      59
      60    return aux_f;
      61
      62    end procedure interproc_fwd_eliminate;
      63
      64
       1 .=member afe13d
       2
       3
       4    procedure intraproc_fwd_eliminate(p, rw aux_f, rw f, flow_flag);
       5$
       6$ this routine performs an intraprocedural elimination phase
       7$ for the procedure p, using interval analysis. the fourth parameter
       8$ indicates whether this routine has been invoked by the
       9$ intraprocedural solver or by the interprocedural solver, and
      10$ in the second case, whether this is the first time p is
      11$ being processed or not.
      12$
      13$ in this pass we iterate through the procedure's intervals
      14$ in an inner-to -outer order (i.e. in reverse preorder of their
      15$ heads in a dfst of the flow graph of p). for each interval
      16$ i processed in this manner we compute a set of data-propagation
      17$ maps of the form f(i, u), where
      18$
      19$ (1) if u is in i, then this map is an auxiliary map (which will
      20$ be denoted as aux_f(u), i being implicit in this case) which
      21$ represents the propagation effect as control advances from
      22$ the start of i, thru i, to the start of u;
      23$
      24$ (2) if u is not in i, then u is a successor of some node in i.
      25$ here the map f(i, u) represents the propagation effect as control
      26$ advances from the start of i, through i, to the start of u;
      27$ in this case f(i, u) is needed for the processing of the
      28$ intervals containing i. note that [i, u] is a virtual edge
      29$ in our flow graph; thus the elimination phase extends the
      30$ map f so as to be defined also on virtual edges.
      31$
      32$ any interval i processed in this routine is either a proper
      33$ strongly connected interval, or, if it contains 'improper'
      34$ nodes (i.e. nucleii of irreducibility), is a single-entry
      35$ strongly connected subgraph. in the first case we only have to
      36$ iterate thru the nodes of i twice, but in the second case till
      37$ convergence.
      38$
      39$ the outermost 'interval' is either a single entry acyclic
      40$ graph (if it does not contain irreducible nucleii), or a
      41$ general single-entry graph otherwise. for this 'interval' we
      42$ iterate either once in the first case, or till convergence
      43$ otherwise.
      44$
      45$ if the present routine is to be used for interprocedural analysis,
      46$ we first reset the propagation maps for call blocks in p. if none of
      47$ these maps have changed from the last processing of p,
      48$ then obviously analysis of p has stabilized and we can return
      49$ immediately. moreover, intervals need be re-processed if and only
      50$ if they contain a call block whose local effect has changed,
      51$ or, recursively, contain an interval whose local effects
      52$ have changed. in terms of the 'intof' tree, we only have to
      53$ re-analyze intervals lying along some path from the
      54$ root to a call block whose local effect has changed. this
      55$ can make reprocessing of a procedure considerably
      56$ faster than initial processing.
      57$
      58    repr
      59	$ data structures for parameters
      60	p:			routine;
      61	aux_f:			remote smap(df_node) df_map;
      62	f:			remote smap(df_edge) df_map;
      63	flow_flag:		string;
      64
      65	$ data structures for local variables
      66	need_process:		set(df_node);
      67	intt:			df_node;
      68	c:			df_node;
      69	v:			df_node;
      70	p1:			routine;
      71	ep1:			df_node;
      72	p_ints:			tuple(df_node);
      73	outint:			df_node;
      74	k:			integer;
      75	nodes:			tuple(df_node);
      76	head:			df_node;
      77	conv_control:		boolean;
      78	n_iter:			integer;
      79	j:			integer;
      80	d:			integer;
      81	convrgd:		boolean;
      82	nd:			df_node;
      83	ftemp:			df_map;
      84	pnd:			df_node;
      85	pv:			df_node;
      86    end repr;
      87
      88    if flow_flag = 'second_inter' then
      89	$ process only intervals containing calls with new effect
      90	need_process := {};
      91    else
      92	$ process all intervals
      93	need_process := { intt : intt in ints(p) };
      94    end if;
      95
      96    if flow_flag /= 'intra' then
      97	$ interprocedural analysis
      98	(forall c in callsin{p})
      99	    v   := cessor(c);	$ the block following the call
     100	    p1  := callproc(c); $ c calls p1
     101	    ep1 := rexit(p1);	$ the return block of p1
     102
     103$ (note here that if this routine is modified to include parameter-
     104$ passing assignments as part of call blocks, in the manner suggested
     105$ in a concluding remark in section 4, then one might manipulate
     106$ aux_f(ep1), which defines the local effect of executing p1, to get
     107$ f(c,v), rather than just assign the first map to the second one, as
     108$ is done below).
     109
     110	    if f([c, v]) /= aux_f(ep1) then
     111
     112		$ update flow function for call
     113		f([c, v]) := aux_f(ep1) ? fom;
     114
     115		$ interval containing call must be processed
     116		need_process with:= intof(c);
     117	    end if;
     118	end forall c;
     119
     120	$ if no intervals need be processed then information has
     121	$ stabilized and no re-processing of p need be done.
     122	if need_process = {} then return true; end if;
     123    end if;
     124
     125    p_ints := ints(p);		$ intervals of p in reverse preorder
     126    outint := p_ints(#p_ints);	$ outermost interval
     127
     128    (forall intt = p_ints(k) | intt in need_process)
     129	need_process with:= intof(intt);  $ process containing interval
     130	nodes := int_nodes(intt);   $ nodes of intt in interval order
     131
     132	head := nodes(1);	$ interval head
     133	aux_f(head) := id;	$ initialize to the identity
     134$
     135$ note here that the edge [intt, head] is a real edge in the
     136$ flow graph, so that f([intt, head]) will have been pre-computed in
     137$ an initialization phase, along with the flow maps for all other
     138$ real edges, and is therefore available here.
     139$
     140$ three cases are now possible:
     141$
     142$ (1) intt is proper, but not outermost; then iterate twice.
     143$ (2) intt is proper, and is outermost; then iterate once.
     144$ (3) intt is improper; iterate indefinitely (1 + number of
     145$     nodes is an adequate upper bound) until convergence.
     146$     (note that we do not make use of the better upper bound on
     147$     the number of iterations discussed in section 3).
     148$
     149	conv_control := intt notin proper_ints;
     150	$ test for convergence only in this case
     151
     152	n_iter :=	$ maximal number of iterations
     153	    if     intt notin proper_ints then #nodes + 1
     154	    elseif intt = outint          then 1
     155	    else                               2
     156	    end;
     157
     158$ if improper interval, initialize aux_f of all non-head nodes
     159$ to 'fom'.  this is because we cannot guarantee in this case that
     160$ when propagating data to a node within intt, all its predecessors
     161$ (within intt) have already been processed, so that we have to
     162$ prepare for the case where some of these predecessors still
     163$ have undefined auxiliary data-flow maps.
     164	if conv_control then
     165	    (forall j in [ 2..#nodes ])
     166		aux_f(nodes(j)) := fom;
     167	    end forall;
     168	end if;
     169
     170	$ iterate through the nodes of intt
     171
     172	(forall d in [ 1..n_iter ])
     173
     174	    convrgd := conv_control;
     175
     176	    $ iterate thrugh the nodes of intt, other than head
     177	    (forall j in [ 2..#nodes ])
     178
     179		nd := nodes(j);
     180		ftemp := fom;
     181		(forall pnd in pred{nd} | intof(pnd) = intt)
     182		    ftemp .meetjoin:=
     183				(f([pnd,nd]) .comp aux_f(pnd));
     184		end forall;
     185		convrgd and:= (ftemp = aux_f(nd));
     186		aux_f(nd) := ftemp;
     187
     188	    end forall j;
     189
     190	    $ test if processing of intt has terminated
     191	    if d = n_iter or convrgd then quit forall d; end if;
     192
     193	    $ re-compute aux_f(head), taking back edges into account
     194	    ftemp := fom;
     195	    (forall pnd in pred{head} | intof(pnd) = intt)
     196		ftemp .meetjoin:= (f([pnd,head]) .comp aux_f(pnd));
     197	    end forall;
     198	    ftemp .meetjoin:= aux_f(head);
     199
     200	    if not conv_control then
     201		convrgd := aux_f(head) = ftemp;
     202	    end if;
     203
     204	    aux_f(head) := ftemp;
     205	    if convrgd then quit forall d; end if;
     206	end forall d;
     207
     208$
     209$ compute f([intt, v]), where v is a successor of some node in
     210$ intt; note that this loop will be null for the
     211$ outermost interval.
     212$
     213	(forall v in vedges{intt})
     214	    ftemp := fom;
     215	    (forall pv in pred{v} | intof(pv) = intt)
     216		ftemp .meetjoin:= (f([pv,v]) .comp aux_f(pv));
     217	    end forall;
     218	    f([intt, v]) := ftemp .comp f([intt, head]);
     219
     220	end forall v;
     221    end forall intt;
     222
     223    return false;           $ to indicate no convergence
     224
     225    end procedure intraproc_fwd_eliminate;
     226
     227
       1 .=member pex13e
       2
       3
       4    procedure propagate_exposed(p, rw f, aux_f, rw exposed, rw insert,
       5		    safe);
       6$
       7$ this procedure performs an inner-to-outer pass over all
       8$ intervals to determine the computations which might be moved
       9$ out of the loop of each interval i. as explained above,
      10$ these computations are not necessarily those exposed in i;
      11$ hence, we build up both sets 'exposed' and 'insert'
      12$ simultaneously.
      13$
      14$ in this analysis, the set of computations movable out of the
      15$ loop of i is obtained by taking all computations t with
      16$ the property that there exists a node nd in i such that
      17$ t is exposed in nd and is available at the start of nd iff
      18$ it is available at the end of the target block of i.
      19$
      20$ the movable code is always assumed to be appended to the
      21$ end of the target block of the interval, to avoid any possible
      22$ conflict with code that is already present in the target block.
      23$ however, this appending takes place physically only at the end
      24$ of the elimination phase. thus, we do not attempt to make
      25$ use of the fact that these expressions are potentially
      26$ available at the head of i in updating any flow function.
      27$ this approach is necessary to ensure convergence of our algorithms
      28$ in cases of recursive cycles of interprocedural flow.
      29$
      30    repr
      31	$ data structures for parameters
      32	p:			routine;
      33	f:			remote smap(df_edge) df_map;
      34	aux_f:			remote smap(df_node) df_map;
      35	exposed:		remote mmap{df_node} df_elmt;
      36	insert:			remote mmap{df_node} df_elmt;
      37	safe:			remote mmap{df_node} df_elmt;
      38
      39	$ data structures for local variables
      40	p_ints:			tuple(df_node);
      41	outint:			df_node;
      42	intt:			df_node;
      43	k:			integer;
      44	nodes:			tuple(df_node);
      45	head:			df_node;
      46	itemp:			df_elmt;
      47	nd:			df_node;
      48	ftarg:			df_map;
      49	expfromentry:		df_elmt;
      50    end repr;
      51
      52    p_ints := ints(p);  $ intervals of p in reverse preorder
      53$
      54$ first extend f to indicate null flow from the entry block to
      55$ itself. since the outermost interval has no target block,
      56$ and is therefore identified with its head, this trick unifies
      57$ the treatment of that interval with the treatment of inner
      58$ intervals, as shown below.
      59$
      60    outint := p_ints(#p_ints);
      61    f([outint, outint]) := id;
      62
      63    (forall intt = p_ints(k))
      64	nodes := int_nodes(intt);
      65	head := nodes(1);
      66$
      67$ in computing exposed{intt}, we must reckon with the fact
      68$ that the target block of intt (also denoted by intt)
      69$ might be non-empty, due to prior code motion. this can mean that
      70$ (a) f([intt, head]) is not the identity, and (b) exposed{intt}
      71$ (where intt is treated as a basic block) is not null
      72$ initially.
      73$
      74	$ we proceed as follows: first find all exposed computations
      75	$ in the loop of intt, assuming the target block of intt to
      76	$ be null.  these are the computations movable out of the loop
      77	$ of intt.
      78	itemp := {};
      79	(forall nd in nodes)
      80	    itemp +:= (exposed{nd} * (aux_f(nd)(1) - aux_f(nd)(2)));
      81	end forall;
      82	if safe /= om then itemp := itemp * safe{intt}; end if;
      83	insert{intt} := itemp;
      84
      85	$ next find the new set of computations which are still
      86	$ exposed at the entry to the target block of intt.
      87	ftarg := f([intt, head]);
      88	expfromentry := insert{intt} * (ftarg(1) - ftarg(2));
      89
      90	$ add these computations to those exposed in the target block
      91	exposed{intt} := exposed{intt} + expfromentry;
      92
      93    end forall intt;
      94
      95
      96    end procedure propagate_exposed;
      97
      98
      99
     100
     101    procedure entry_info(f, aux_f, move_code, insert);
     102$
     103$ this function calculates and returns a mapping which sends
     104$ each procedure p into the flow information available at entry
     105$ to p.  it is called (only in the interprocedural case) just
     106$ before we begin the final outer-to-inner propagation phase.
     107$
     108    repr
     109	$ data structures for parameters
     110	f:			remote smap(df_edge) df_map;
     111	aux_f:			remote smap(df_node) df_map;
     112	move_code:		boolean;
     113	insert:			remote mmap{df_node} df_elmt;
     114
     115	$ data structures for local variables
     116	cgf:			smap( tuple(routine, routine) ) df_map;
     117	p, q:			routine;
     118	c:			df_node;
     119	ftemp:			df_map;
     120	iu:			df_node;
     121	hiu:			df_node;
     122	fins:			df_map;
     123	ent_inf:		remote smap(routine) df_elmt;
     124	cgrinv:			mmap(routine) routine;
     125	i:			integer;
     126	scc:			routine;
     127	scc_procs:		tuple(routine);
     128	n:			integer;
     129	convrgd:		boolean;
     130	k:			integer;
     131	temp:			df_elmt;
     132    end repr;
     133$
     134$ first we construct a map 'cgf' assigning to each edge (p, q)
     135$ of the call graph a data-propagation map, describing the
     136$ propagation effect as control advances from the entry of p
     137$ to the entry of q via any call to q from p.
     138$
     139    cgf := {};
     140    (forall [p,q] in cgraph) cgf([p,q]) := fom; end;
     141
     142    (forall q = callproc(c))  $ for all calls within all procedures
     143
     144	p := routof(c);   $ [p, q] is an edge of the call graph
     145
     146	$ compute the local effect as control advances from the entry
     147	$ of p to c.
     148	ftemp := aux_f(c);
     149
     150	(init iu := intof(c); while iu /= rentry(p))
     151
     152	    hiu := int_nodes(iu)(1);	$ head of iu
     153	    fins := id;
     154	    $ add also the effect of code moved out of iu
     155	    if move_code then fins(2) := insert{iu}; end;
     156	    ftemp := ftemp .comp fins .comp f([iu, hiu])
     157				.comp aux_f(iu);
     158
     159	    iu := intof(iu);
     160
     161	end;
     162
     163	cgf([p, q]) := cgf([p, q]) .meetjoin ftemp;
     164
     165    end forall q;
     166$
     167$ next we iterate through the call graph in 'invocation order', i.e.
     168$ process the strongly connected components in reverse postorder and
     169$ the set of procedures within each strongly connected component in
     170$ reverse postorder also.
     171$
     172    ent_inf := {[p, xom] : p in routs};  $ initialize solution
     173    ent_inf(sym_main) := zero;
     174    cgrinv := {[p, q] : [q, p] in cgraph};
     175
     176    $ pick strongly-connected components in reverse postorder
     177    (forall i in [ 2..#cg_sccs ])
     178
     179	$ nb. here we assume that the main program is non-recursive,  so
     180	$ that the first strongly-connected component of the call  graph
     181	$ consists of the main program only.  thus we can skip  it,  for
     182	$ the entry value of the main program is already assumed  known.
     183
     184	scc := cg_sccs(i);
     185	scc_procs := scc_nodes(scc);	$ procs in scc in rev. postorder
     186
     187	(forall n in [ 1..scc_d(scc)+1 ] )
     188
     189	    convrgd := true;
     190
     191	    (forall p = scc_procs(k))
     192
     193		temp := xom;
     194		(forall q in cgrinv{p})
     195		   temp .mjv:= (cgf([q,p]) .of ent_inf(q));
     196		end forall;
     197
     198		$ test for convergence
     199		convrgd and:= (temp = ent_inf(p));
     200
     201		ent_inf(p) := temp;
     202	    end forall p;
     203
     204	    if convrgd then quit forall n; end if;
     205	end forall n;
     206    end forall i;
     207
     208    return ent_inf;
     209
     210    end procedure entry_info;
     211
     212
       1 .=member fpi13f
       2
       3
       4    procedure fwd_propagate_in(p, rw f, aux_f, rw soln, ent_val,
       5			    move_code, rw insert);
       6$
       7$ this procedure performs outer-to-inner propagation for a
       8$ routine p, using the 'interval-effect' flow functions aux_f
       9$ to modify the solution map 'soln'.  the parameter ent_val
      10$ gives the flow information assumed (or known) at procedure
      11$ entry.
      12$
      13$ if code motion is required, then the computations in insert{i}
      14$ are assumed to be available at the end of the target block
      15$ of an interval i (but only for the purpose of propagation
      16$ inside i).  in addition, computations in insert{i} already
      17$ available at exit from the target block of i are removed from
      18$ insert{i}.
      19$
      20$ note that movable computations are assumed to be such that the
      21$ insertion of any of them will not 'kill' any others.
      22$
      23    repr
      24	$ data structures for parameters
      25	p:			routine;
      26	f:			remote smap(df_edge) df_map;
      27	aux_f:			remote smap(df_node) df_map;
      28	soln:			remote smap(df_node) df_elmt;
      29	ent_val:		df_elmt;
      30	move_code:		boolean;
      31	insert:			remote mmap{df_node} df_elmt;
      32
      33	$ data structures for local variables
      34	p_ints:			tuple(df_node);
      35	outint:			df_node;
      36	k:			integer;
      37	intt:			df_node;
      38	nodes:			tuple(df_node);
      39	soln1:			df_elmt;
      40	u:			df_node;
      41    end repr;
      42
      43    soln(rentry(p)) := ent_val;
      44    p_ints := ints(p);  $ intervals of p in reverse preorder
      45$
      46$ extend f to indicate null flow from the entry block to
      47$ itself.  since the outermost interval has no target block,
      48$ and is therefore identified with its head, this trick unifies
      49$ the treatment of that interval with the treatment of inner
      50$ intervals, as shown below.
      51$
      52    outint := p_ints(#p_ints);
      53    f([outint, outint]) := id;
      54
      55    (forall k in [ #p_ints, #p_ints-1..1 ])
      56
      57	intt := p_ints(k);
      58	nodes := int_nodes(intt);  $ nodes of intt
      59
      60	soln1 := soln(intt);  $ data value at entry to intt
      61
      62	$ convert soln1 to the data attribute value at the end of the
      63	$ target block of intt.
      64	$ propagate through the target block of intt; if
      65	$ intt = outint, the trick noted above will make the following
      66	$ statement a no-op.
      67	soln1 := f([intt, nodes(1)]) .of soln1;
      68
      69	$ if code motion is also required, then update insert{intt}
      70	$ and add it to soln1.
      71	if move_code and intt /= outint then
      72	    insert{intt} := insert{intt} - soln1;
      73	    soln1 := soln1 + insert{intt};
      74	end if;
      75
      76	$ now propagate attributes to the nodes of intt
      77	(forall u in nodes)
      78	    soln(u) := aux_f(u) .of soln1;
      79	end forall u;
      80
      81    end forall;
      82
      83
      84    end procedure fwd_propagate_in;
      85
      86
       1 .=member afa13g
       2
       3
       4    procedure intraproc_fwd_analysis(p, rw f, wr soln, id_prm, zero_prm,
       5				meet_flag_prm, move_code,
       6				rw exposed, wr insert, safe);
       7$
       8$ this is the master routine to perform a specific data flow
       9$ analysis intraprocedurally for a given routine p, within which
      10$ local variables are analyzed.
      11$
      12$ for more details and comments and description of parameters see the
      13$ corresponding interprocedural analyser.
      14$
      15    repr
      16	$ data structures for parameters
      17	p:			routine;
      18	f:			remote smap(df_edge) df_map;
      19	soln:			remote smap(df_node) df_elmt;
      20	id_prm:			df_map;
      21	zero_prm:		df_elmt;
      22	meet_flag_parm:		boolean;
      23	move_code:		boolean;
      24	exposed:		remote mmap{df_node} df_elmt;
      25	insert:			remote mmap{df_node} df_elmt;
      26	safe:			remote mmap{df_node} df_elmt;
      27
      28	$ data structures for local variables
      29	aux_f:			remote smap(df_node) df_map;
      31    end repr;
      32
      33    id        := id_prm;
      34    meet_flag := meet_flag_prm;
      35
      36    aux_f := {};
      37
      38    intraproc_fwd_eliminate(p,aux_f,f,'intra');
      41
      42    if move_code then
      43	insert := {};
      44	propagate_exposed(p, f, aux_f, exposed, insert, safe);
      45    end if;
      46
      47    soln := {};
      48    fwd_propagate_in(p, f, aux_f, soln, zero_prm, move_code, insert);
      49
      50    end procedure intraproc_fwd_analysis;
      51
      52
      53
      54
      55    procedure interproc_back_analysis(rw f, wr soln, id_prm, zero_prm,
      56				meet_flag_prm);
      57$
      58$ this is the master routine for performing a specific interprocedural
      59$ backward data flow analysis.  see the corresponding forward routine
      60$ for general comments and a description of parameters.  here we comment
      61$ only on differences between the forward and backward algorithms, which
      62$ are as follows:
      63$
      64$ a. functional composition must be computed in reverse order.
      65$
      66$ b. the auxiliary maps used in backward analysis are defined as
      67$    follows:  let i be an interval, u a node in i and v a node outside
      68$    i which is a successor of a node in i.  then aux_f([u, v]) is
      69$    defined to be the propagation effect experienced as control
      70$    advances from the start of u, through  i, to the start of v.
      71$
      72$    to compute this map requires iterating through i in reverse
      73$    interval order three times (if i is proper) or till convergence
      74$    otherwise.
      75$
      76$    since the outermost interval of a procedure p has no successors,
      77$    we regard the blocks rexit(p) and rstop(p) as its successors,
      78$    'hidden' inside that interval.  this is needed to enable us to
      79$    record the effect of the flow through the outermost interval in
      80$    a manner similar to that used for inner intervals.
      81$
      82$ c. in backward analysis we perform an extra step after the
      83$    elimination phase.  in this step we compute an additional set
      84$    'fexit' of auxiliary maps.  for each node u in p, fexit(u)
      85$    represents the propagation effect of the flow from the start
      86$    of u to the return block of p, combined with that of flow from
      87$    the start of u to the stop block of p.
      88$
      89$ d. in our backward analysis code motion issues are completely
      90$    ignored.
      91$
      92$ e. the technical problem concerning endless loops discussed in
      93$    section 5 is assumed to be resolved by preliminary processing
      94$    of the flow graph, in the manner suggested there.
      95$
      96    repr
      97	$ data structures for parameters
      98	f:			remote smap(df_edge) df_map;
      99	soln:			remote smap(df_node) df_elmt;
     100	id_prm:			df_map;
     101	zero_prm:		df_elmt;
     102	meet_flag_prm:		boolean;
     103
     104	$ data structures for local variables
     105	aux_f:			remote smap(df_edge) df_map;
     106	fexit:			remote smap(df_node) df_map;
     107	p:			routine;
     108	ex_inf:			remote smap(routine) df_elmt;
     109    end repr;
     110
     111    $ transfer constant parmeters to globals
     112    id        := id_prm;
     113    zero      := zero_prm;
     114    meet_flag := meet_flag_prm;
     115$
     116$ this master procedure consists of the following four phases:
     117$
     118$ 1. interprocedural elimination phase
     119$
     120    aux_f := interproc_back_eliminate(f);
     121$
     122$ 2. compute auxiliary fexit maps.
     123$
     124    fexit := {};
     125    (forall p in routs)
     126	intra_aux_eliminate(p, f, aux_f, fexit);
     127    end forall p;
     128$
     129$ 3. find data at procedure exits
     130$
     131    ex_inf := exit_info(f, aux_f, fexit);
     132$
     133$ 4. final propagation phase
     134$
     135    soln := {};     $ initialize the solution
     136    (forall p in routs)
     137	back_propagate_in(p, fexit, soln, ex_inf(p));
     138    end forall;
     139
     140    end procedure interproc_back_analysis;
     141
     142
       1 .=member ebe13h
       2
       3
       4    procedure interproc_back_eliminate(rw f);
       5$
       6$ this is the driver routine for the interprocedural first
       7$ inner-to-outer interval pass.  procedures are analyzed in
       8$ the following order: we process the strongly connected
       9$ components of the call graph in their postorder; then, for each
      10$ such component, we iterate through its procedures in their
      11$ postorder, no more than 2*d+1 times, where d is the loop-
      12$ interconnectedness parameter of the component.
      13$
      14    repr
      15	$ data structures for parameters
      16	f:			remote smap(df_edge) df_map;
      17
      18	$ data structures for local variables
      19	aux_f:			remote smap(df_edge) df_map;
      20	f_p:			remote smap(routine) df_map;
      21	i:			integer;
      22	scc:			routine;
      23	scc_procs:		tuple(routine);
      24	flow_flag:		string;
      25	j:			integer;
      26	proc_converge:		boolean;
      27	k:			integer;
      28	p:			routine;
      29    end repr;
      30
      31    aux_f := {};	$ initialize auxiliary maps
      32    f_p := {};		$ propagation effect thru procedures
      33
      34    $ iterate through the s.c.c.s of cgraph
      35    (forall i in [ #cg_sccs, #cg_sccs-1..1 ])
      36	scc := cg_sccs(i);		$ get a s.c.c.
      37	scc_procs := scc_nodes(scc);	$ procedures in that s.c.c.
      38	flow_flag := 'first_inter';	$ first processing of the s.c.c.
      39
      40	(forall j in [ 1..2*scc_d(scc)+1 ])
      41	    proc_converge := true;
      42
      43	    (forall k in [ #scc_procs, #scc_procs-1..1 ])
      44		p := scc_procs(k);
      45		proc_converge :=
      46		    intraproc_back_eliminate(p,aux_f,f,f_p,flow_flag)
      47		    and proc_converge;
      48		$ this routine analyzes p;  its fifth parameter
      49		$ indicates whether the analysis is first-time
      50		$ interprocedural, second-time interprocedural or
      51		$ intraprocedural; it returns a flag to indicate
      52		$ whether information has stabilized in p.
      53	    end forall;
      54
      55	    flow_flag := 'second_inter';    $ additional passes thru scc
      56
      57	    if proc_converge then quit forall j; end if;
      58	end forall;
      59    end forall;
      60
      61    return aux_f;
      62
      63    end procedure interproc_back_eliminate;
      64
      65
       1 .=member abe13i
       2
       3
       4    procedure intraproc_back_eliminate(p, rw aux_f, rw f, rw f_p,
       5				flow_flag);
       6$
       7$ this routine performs an intraprocedural elimination phase of a
       8$ backward data flow analysis for a given procedure p.
       9$
      10$ the overall logic is quite similar to its sister routine
      11$ 'intraproc_fwd_eliminate', and the reader should consult comments
      12$ given there.  the differences between these two phases reflects
      13$ mainly the reverse tracing of flow, which implies several minor
      14$ modifications of the forward approach, as follows:
      15$
      16$ a. auxiliary information is computed for each successor of each
      17$    interval.  that is, for each interval i, each node u in i, and
      18$    each successor node v of i, we compute a map aux_f([u, v]),
      19$    representing the flow from u through i to v.  the outermost
      20$    interval has no successors, but we regard the return block of p
      21$    and the stop block of p (if any) as its two successors, even
      22$    though they lie within it.  (note that since these two nodes
      23$    can never lie on a cycle through p, they must belong to the
      24$    outer-most interval).
      25$
      26$ b. nodes of an interval are processed in reverse interval order
      27$    (i.e. postorder);  this is done three times if i is a proper
      28$    inner interval, once if i is a proper outer-most inteval, and
      29$    till convergence otherwise.
      30$
      31$ c. functional composition is taken in reverse edge order.
      32$
      33$ d. an additional data structure f_p is used to hold the propagation
      34$    effect through the whole procedure in the interprocedural case.
      35$    this is because the flow through p is actually combined of two
      36$    flows:  one leading to the return block of p, and another leading
      37$    to the stop block of p, if any.  unlike in the forward case,
      38$    where the second flow can be, and is, actually ignored, here we
      39$    must take it into account.
      40$
      41    repr
      42	$ data structures for formal parameters
      43	p:			routine;
      44	aux_f:			remote smap(df_edge) df_map;
      45	f:			remote smap(df_edge) df_map;
      46	f_p:			remote smap(routine) df_map;
      47	flow_flag:		*;
      48
      49	$ data structures for local variables
      50	need_process:		set(df_node);
      51	intt:			df_node;
      52	c:			df_node;
      53	v:			df_node;
      54	p1:			routine;
      55	p_ints:			tuple(df_node);
      56	outint:			df_node;
      57	sp:			df_node;
      58	k:			integer;
      59	nodes:			tuple(df_node);
      60	head:			df_node;
      61	cesors:			sparse set(df_node);
      62	conv_control:		boolean;
      63	n_iter:			integer;
      64	nd:			df_node;
      65	d:			integer;
      66	convrgd:		boolean;
      67	j:			integer;
      68	ftemp:			df_map;
      69	snd:			df_node;
      70	fzero:			df_elmt;
      71    end repr;
      72
      73
      74    if flow_flag = 'second_inter' then
      75	$ process only intervals containing calls with new effects
      76	need_process := {};
      77    else
      78	$ process all intervals
      79	need_process := { intt : intt in ints(p) }; $ convert to set
      80    end if;
      81
      82    if flow_flag /= 'intra' then $ interprocedural analysis
      83
      84	(forall c in callsin{p})
      85	    v  := cessor(c);	$ the block following the call
      86	    p1 := callproc(c);  $ c calls p1
      87
      88	    $ (note that if this routine is modified to include
      89	    $ parameter-passing assignments as part of call blocks,
      90	    $ in the manner mentioned above, then one might manipulate
      91	    $ f_p(p1), the local effect of executing p1, to get
      92	    $ f([c, v]), rather than just assign f_p(p1)
      93	    $ to f([c, v]), as is done below).
      94
      95	    if f([c, v]) /= f_p(p1) then
      96
      97		$ update flow function for call
      98		f([c, v]) := f_p(p1) ? fom;
      99
     100		$ interval containing call must be processed
     101		need_process with:= intof(c);
     102	    end if;
     103	end forall c;
     104
     105	$ if no intervals need be processed then information has
     106	$ stabilized and no re-processing of p need be done.
     107	if need_process = {} then return true; end if;
     108    end if;
     109
     110
     111    p_ints := ints(p);		$ intervals of p in reverse preorder
     112    outint := p_ints(#p_ints);	$ outermost interval
     113    vedges{outint} := {rexit(p)};   $ 'successors' of outint
     114    if (sp := rstop(p)) /= om then
     115	vedges{outint} with:= sp;
     116    end if;
     117
     118    (forall intt = p_ints(k) | intt in need_process)
     119
     120	need_process with:= intof(intt);  $ process containing interval
     121	nodes := int_nodes(intt);   $ nodes of intt in interval order
     122	head := nodes(1);	    $ interval head
     123
     124	$ get successor nodes
     125	cesors := vedges{intt};
     126
     127	$ initialize aux_f for successor nodes.  this trick simplifies
     128	$ subsequent code considerably.
     129	(forall v in cesors)
     130	    aux_f([v, v]) := id;
     131	end forall;
     132$
     133$ three cases are now possible:
     134$ a. intt is proper, but not outermost; then iterate three times.
     135$ b. intt is proper, and is outermost; then iterate once.
     136$ c. intt is improper; iterate indefinitely (1 + 2*number of
     137$    nodes is an adequate upper bound) until convergence.  (here,
     138$    again, a better bound can be used; cf. section 6).
     139$
     140	$ we test for convergence only for improper intervals.
     141	conv_control := intt notin proper_ints;
     142
     143	n_iter :=  $ maximal number of iterations through nodes of intt
     144	    if     intt notin proper_ints then 1 + 2 * #nodes
     145	    elseif intt = outint          then 1
     146    	    else                               3
     147    	    end;
     148
     149	(forall nd in nodes, v in cesors | nd /= v)
     150	    aux_f([nd, v]) := fom;
     151	end forall;
     152
     153	$ iterate through the nodes of intt.
     154	(forall d in [ 1..n_iter ])
     155	    convrgd := conv_control;
     156
     157	    $ iterate thrugh the nodes of intt in reverse interval
     158	    $ order.
     159	    (forall j in [ #nodes, #nodes-1..1 ])
     160		nd := nodes(j);
     161
     162		(forall v in cesors | v /= nd)
     163
     164		    $ since the 'successors' of the outermost interval
     165		    $ are nodes of that interval, we may have nd = v.
     166		    $ in this case it would be erroneouss to compute
     167		    $ aux_f([nd, v]) (which has already been set to
     168		    $ id) using the following 'propagation from
     169		    $ successors' formula, so we just skip such cases.
     170
     171		    ftemp := fom;
     172		    (forall snd in cessor{nd} |
     173				    intof(snd) = intt or snd = v)
     174			ftemp .meetjoin:=
     175			    (f([nd,snd]) .comp aux_f([snd,v]));
     176		    end forall;
     177
     178		    $ note that flow graph edges (virtual or real) are
     179		    $ either edges within an interval, linking two
     180		    $ nodes in the same interval, or edges going out
     181		    $ of an interval, or edges going into an interval
     182		    $ (these last edges are edges from (a target block
     183		    $ of) an interval to its head.  it is this third
     184		    $ kind of edge that we wish to avoid propagating
     185		    $ through in the above formula.
     186		    $ 'intof(snd) = intt' tests for internal edges
     187		    $ and 'snd = v' tests for outgoing edges whose
     188		    $ target is v.
     189
     190		    convrgd and:= (ftemp = aux_f([nd, v]));
     191		    aux_f([nd, v]) := ftemp;
     192		end forall v;
     193	    end forall j;
     194
     195	    if convrgd then quit forall d; end if;
     196	end forall d;
     197	$ (note that no special handling of intt's head is required.)
     198
     199	$ except for the outermost interval, compute f([intt, v]),
     200	$ where v is a successor of some node in intt.
     201	if intt /= outint then
     202	    $ f([intt, v]) is trivially calculated in this case;  we
     203	    $ also remove the dummy aux_f([v, v]) entries.
     204	    (forall v in cesors)
     205		f([intt, v]) :=
     206			f([intt, head]) .comp aux_f([head, v]);
     207		aux_f([v, v]) := om;
     208	    end forall v;
     209	end if;
     210    end forall intt;
     211
     212    f_p(p) := aux_f([head, rexit(p)]); $ head = rentry(p)
     213
     214    $ if p contains a stop block, calculate propogation effect to that
     215    $ block and combine it with 'normal' flow effect.
     216    if rstop(p) /= om then
     217	fzero := aux_f([head, rstop(p)]) .of zero;
     218	f_p(p) := f_p(p) .meetjoin [ fzero, fzero ];
     219	$ note that a constant function c is represented by [c, c]
     220
     221    end if;
     222
     223    $ remove artificial edges added earlier
     224    vedges{outint} := {};
     225
     226    return false;           $ to indicate no convergence
     227
     228    end procedure intraproc_back_eliminate;
     229
     230
       1 .=member axe13j
       2
       3
       4    procedure intra_aux_eliminate(p, f, aux_f, rw fexit);
       5$
       6$ this procedure performs an additional intraprocedural elimination,
       7$ during which we compute, for each node n in p, a map fexit(n) repre-
       8$ senting the effect of flow from the start of n up to an exit of p.
       9$
      10    repr
      11	$ data structures for formal parameters
      12	p:			routine;
      13	f:			remote smap(df_edge) df_map;
      14	aux_f:			remote smap(df_edge) df_map;
      15	fexit:			remote smap(df_node) df_map;
      16
      17	$ data structures for local variables
      18	p_ints:			tuple(df_node);
      19	outint:			df_node;
      20	ep:			df_node;
      21	sp:			df_node;
      22	outnodes:		tuple(df_node);
      23	nd:			df_node;
      24	i:			integer;
      25	fzero:			df_elmt;
      26	ftemp:			df_map;
      27	j:			integer;
      28	intt:			df_node;
      29	cesors:			sparse set(df_node);
      30	nodes:			tuple(df_node);
      31	k:			integer;
      32	v:			df_node;
      33    end repr;
      34
      35    p_ints := ints(p);
      36    outint := p_ints(#p_ints);
      37    ep := rexit(p);
      38    sp := rstop(p);
      39$
      40$ first process nodes of outint
      41$
      42    outnodes := int_nodes(outint);
      43
      44    (forall nd = outnodes(i))
      45
      46	fexit(nd) := aux_f([nd, ep]);  $ get the effect of flow to ep
      47
      48	if sp /= om then	$ if there is also a stop block
      49
      50	    fzero := aux_f([nd, sp]) .of zero;
      51	    ftemp := if fzero = xom then fom else [ fzero, fzero ] end;
      52	    fexit(nd) := fexit(nd) .meetjoin ftemp;
      53
      54	end if;
      55    end forall nd;
      56$
      57$ next process all remaining intervals in outer-to-inner order
      58$
      59    (forall j in [ #p_ints-1, #p_ints-2..1 ])
      60
      61	intt := p_ints(j);
      62	cesors := vedges{intt};
      63
      64	nodes := int_nodes(intt);
      65	(forall nd = nodes(k))
      66	    ftemp := fom;
      67	    (forall v in cesors)
      68		ftemp .meetjoin:= (aux_f([nd,v]) .comp fexit(v));
      69	    end forall;
      70	    fexit(nd) := ftemp;
      71	end forall nd;
      72    end forall j;
      73
      74
      75    end procedure intra_aux_eliminate;
      76
      77
       1 .=member xnf13k
       2
       3
       4    procedure exit_info(f, aux_f, fexit);
       5$
       6$ this function calculates and returns a mapping which sends
       7$ each procedure p into the flow information available at exit
       8$ from p.  it is called (only in the interprocedural case) just
       9$ before we begin the final outer-to-inner propagation phase.
      10$
      11    repr
      12	$ data structures for formal parameters
      13	f:			remote smap(df_edge) df_map;
      14	aux_f:			remote smap(df_edge) df_map;
      15	fexit:			remote smap(df_node) df_map;
      16
      17	$ data structures for local variables
      18	cgf:			smap( tuple(routine, routine) ) df_map;
      19	p, q:			routine;
      20	c:			df_node;
      21	c1:			df_node;
      22	ex_inf:			remote smap(routine) df_elmt;
      23	cgrinv:			mmap(routine) routine;
      24	i:			integer;
      25	scc:			routine;
      26	scc_procs:		tuple(routine);
      27	n:			integer;
      28	convrgd:		boolean;
      29	k:			integer;
      30	temp:			df_elmt;
      31    end repr;
      32$
      33$ first we construct a map 'cgf' assigning, to each edge (p, q)
      34$ of the call graph, a data-propagation map describing the
      35$ propagation effect as control returns from the exit of q to p
      36$ after any call in p to q, and then advances to the exit of p.
      37$
      38    cgf := {};
      39    (forall [ p, q ] in cgraph) cgf([p,q]) := fom; end forall;
      40
      41    (forall q = callproc(c))	$ for all calls within all procedures
      42	p  := routof(c);	$ [p, q] is an edge of the call graph
      43	c1 := cessor(c);	$ c1 is the block following c
      44	cgf([p, q]) := cgf([p, q]) .meetjoin fexit(c1);
      45
      46	$ note that since we are dealing with a  backward  analysis,  we
      47	$ want to propagate data from the exit of the calling  procedure
      48	$ p to the exit of the called procedure q.   this  direction  of
      49	$ propagation, however, makes our problem a forward problem  for
      50	$ the call graph.
      51
      52    end forall;
      53$
      54$ next we iterate through the call graph in 'invocation order', i.e.
      55$ process the strongly connected components in reverse postorder
      56$ and the set of procedures within each strongly connected
      57$ component in reverse postorder also.
      58$
      59    ex_inf := { [ p, xom ] : p in routs };	$ initialize solution
      60    ex_inf(sym_main) := zero;
      61    cgrinv := { [ p, q ] : [ q, p ] in cgraph };
      62
      63    $ pick strongly-connected components in reverse postorder
      64    (forall i in [ 2..#cg_sccs ])
      65
      66	$ note that we assume here that the main program  is  non-recur-
      67	$ sive, so that the first strongly-connected  component  of  the
      68	$ call graph consists of the main program only.   thus  we  need
      69	$ not process it, for the exit value  of  the  main  program  is
      70	$ already assumed known.
      71
      72	scc := cg_sccs(i);
      73	scc_procs := scc_nodes(scc);	$ procs in scc in rev. postorder
      74
      75	(forall n in [ 1..scc_d(scc)+1 ] )
      76	    convrgd := true;
      77	    (forall p = scc_procs(k))
      78		temp := xom;
      79		(forall q in cgrinv{p})
      80		    temp .mjv:= (cgf([q,p]) .of ex_inf(q));
      81		end forall;
      82
      83		$ test for convergence
      84		convrgd and:= (temp = ex_inf(p));
      85		ex_inf(p) := temp;
      86
      87	    end forall p;
      88
      89	    if convrgd then quit forall n; end if;
      90	end forall n;
      91    end forall i;
      92
      93    return ex_inf;
      94
      95    end procedure exit_info;
      96
      97
       1 .=member bpi13l
       2
       3
       4    procedure back_propagate_in(p, fexit, rw soln, ex_val);
       5$
       6$ this procedure performs outer-to-inner back propagation for
       7$ a routine p, using the 'fexit' information.  ex_val is the flow
       8$ information assumed (or known) at the procedure return block,
       9$ where 'zero' is always assumed at the stop block of p (but this
      10$ assumption has already been used in calculating the fexit maps).
      11$
      12    repr
      13	$ data structures for formal parameters
      14	p:			routine;
      15	fexit:			remote smap(df_node) df_map;
      16	soln:			remote smap(df_node) df_elmt;
      17	ex_val:			df_elmt;
      18
      19	$ data structures for local variables
      20	intt:			df_node;
      21	u:			df_node;
      22    end repr;
      23
      24    (forall intt in ints(p), u in int_nodes(intt))
      25	soln(u) := fexit(u) .of ex_val;
      26    end forall;
      27
      28    end procedure back_propagate_in;
      29
      30
      31
      32
      33    procedure intraproc_back_analysis(p, rw f, wr soln,
      34				 id_prm, zero_prm, meet_flag_prm);
      35$
      36$ this is the master routine to perform a specific backward data flow
      37$ analysis intraprocedurally for a routine p whose local variables are
      38$ to be analyzed.  for more details, comments, and description of para-
      39$ meters see the corresponding interprocedural analyser.
      40$
      41    repr
      42	$ data structures for formal parameters
      43	p:			routine;
      44	f:			remote smap(df_edge) df_map;
      45	soln:			remote smap(df_node) df_elmt;
      46	id_prm:			df_map;
      47	zero_prm:		df_elmt;
      48	meet_flag_prm:		boolean;
      49
      50	$ data structures for local variables
      51	aux_f:			remote smap(df_edge) df_map;
      52	f_p:			remote smap(routine) df_map;
      54	fexit:			remote smap(df_node) df_map;
      55    end repr;
      56
      57    id        := id_prm;
      58    zero      := zero_prm;
      59    meet_flag := meet_flag_prm;
      60
      61    aux_f := {};   f_p := {};
      62
      63    intraproc_back_eliminate(p, aux_f, f, f_p, 'intra');
      65
      66    fexit := {};
      67    intra_aux_eliminate(p, f, aux_f, fexit);
      68
      69    soln := {};
      70    back_propagate_in(p, fexit, soln, zero);
      71$
      72$ note that in the intraprocedural case the last two procedures
      73$ can be combined to form a single procedure almost identical
      74$ with 'intra_aux_eliminate', except that this procedure computes the
      75$ 'soln' map directly instead of the 'fexit' maps.
      76$
      77    end procedure intraproc_back_analysis;
      78
      79
      80
      81$
      82$ here are the operators which manipulate the data propagation maps
      83$ and data states.
      84$
      85    op .comp(g, f);   $ functional composition g of f
      86
      87    if f = fom or g = fom then
      88	return fom;
      89    else
      90	return [ f(1) * g(1) + g(2), f(2) * g(1) + g(2) ];
      91    end if;
      92
      93    end op .comp;
      94
      95
      96    op .meetjoin(g, f);   $ functional meet or join
      97
      98    if     f = fom   then return g;
      99    elseif g = fom   then return f;
     100    elseif meet_flag then return [ f(1) * g(1), f(2) * g(2) ];
     101    else             return [ f(1) + g(1), f(2) + g(2) ];
     102    end if;
     103
     104    end op .meetjoin;
     105
     106
     107    op .mjv(x, y);   $ meet or join of lattice elements
     108
     109    if     x = xom   then return y;
     110    elseif y = xom   then return x;
     111    elseif meet_flag then return x * y;
     112    else             return x + y;
     113    end if;
     114
     115    end op .mjv;
     116
     117
     118    operator .of(f, x);   $ functional application
     119    return if x = xom or f = fom then xom
     120	else f(1)*x + f(2)
     121	end;
     122    end operator .of;
     123
     124
     125    drop
     126	.comp,
     127	interproc_fwd_analysis,
     128	intraproc_fwd_analysis,
     129	interproc_back_analysis,
     130	intraproc_back_analysis,
     131	fom,
     132	xom;
     133
     134
     135    end module setl_optimizer - dataflow_solver_syms;
     136
     137
       1 .=member dfo13m
       2
       3
       4    module setl_optimizer - dataflow_solver_ocrs;
       5$
       6$ this module is a duplicate of the preceding module.  it differs in
       7$ that it operates on the base of occurrences (ocrs) rather than on the
       8$ base of symbols (syms).
       9$
      10$ this module contains a package of general purpose routines to solve
      11$ bit vector data flow problems either intraprocedurally or inter-
      12$ procedurally.  we can distinguish between four basic types of such
      13$ analyses, according to the character of the desired analysis:
      14$
      15$ forward  - data is to be propagated in the direction of
      16$            the flow, from procedure entries forward.
      17$
      18$ backward - data is to be propagated in the reverse
      19$            direction of the flow, from exits backward.
      20$
      21$ meet     - whenever two paths converge (for forward analysis)
      22$            or diverge (for backward analysis) take the meet (set
      23$            intersection)  of data values propagated along these
      24$            paths.
      25$
      26$ join     - as in meet, except that the join (set union) of the
      27$            corresponding data values is to be taken.
      28$
      29$ typical examples are: expression availability analysis
      30$ is a forward - meet analysis; unconditional exposure
      31$ of expressions (also known as 'very busy' expressions
      32$ analysis) is a backward - meet analysis; reaching
      33$ definitions analysis is a forward - join analysis, and
      34$ live variables analysis is a backward - join analysis.
      35$
      36$ as noted in chapters 5 and 6, forward and backward analyses
      37$ require substantially different logic, so that each of them
      38$ is executed in a different subpackage; however, the
      39$ difference between meet and join problems turns out to
      40$ be rather minor, so that they both can be handled by
      41$ the same (forward or backward) package, using a switch
      42$ to indicate whether a particular analysis is of meet or
      43$ join type.
      44$
      45$ this module exports the following procedures:
      46$
      47$ interproc_fwd_analysis - call this to solve interprocedural
      48$                   forward data flow analyses.
      49$
      50$ intraproc_fwd_analysis - call this to solve intraprocedural
      51$                   forward data flow analysis for a given
      52$                   procedure.
      53$
      54$ interproc_back_analysis - call this to solve interprocedural
      55$                   backward data flow analysis
      56$
      57$ intraproc_back_analysis - performs intraprocedural backward
      58$                   analysis for a given procedure.
      59$
      60$ this package assumes the following global objects to be
      61$ available:
      62$
      63$ cgraph    - the program call graph, represented as a set
      64$             of edges; an edge (p,q) is in cgraph iff p is a
      65$             procedure which contains a call to the procedure q.
      66$
      67$ routs     - set of all program procedures (i.e. all nodes
      68$             of the call graph).
      69$
      70$ sym_main  - main-program identifier (i.e. the entry node of the
      71$             call graph).
      72$
      73$ routof    - maps each block to the procedure containing it.
      74$
      75$ rentry    - maps each procedure to its entry block.
      76$
      77$ rexit     - maps each procedure to its exit (return) block.
      78$
      79$ rstop     - maps each procedure to its stop block, if any.
      80$
      81$ callsin   - maps each procedure to the set of all call blocks
      82$             in it.
      83$
      84$ callproc  - maps each call block to the procedure it calls.
      85$
      86$ cessor    - the program flow graph, as a union of the flow
      87$             graphs of all procedures. an edge (m, n) is in
      88$             cessor iff either m contains a branch to n, or else
      89$             m is a call block and n is the block immediately
      90$             following n. the nodes of the flow graph are either
      91$             basic blocks or derived intervals (which are
      92$             represented by their target blocks), in which case
      93$             an edge (int, v) in cessor can indicate the possibility
      94$             of a transfer of control from the interval int to a
      95$             successor v of some node in int. these edges are called
      96$             virtual edges (as above; see the interval
      97$             analysis package for more details).
      98$
      99$ pred      - the inverse map of cessor.
     100$
     101$ ints      - maps each procedure to the tuple of its intervals
     102$             in reverse preorder (relative to a depth first
     103$             spanning tree of its flow graph).
     104$
     105$ int_nodes - maps each interval to the sequence of its nodes
     106$             in interval order (i.e., reverse postorder).
     107$
     108$ proper_ints - the set of all proper intervals (those which do
     109$             not contain irreducible nucleii).
     110$
     111$ intof     - maps each flow graph node to the interval containing
     112$             it.
     113$
     114$ vedges    - set of all virtual edges (see the description of
     115$             cessor above).
     116$
     117$ in addition this module uses the following global-within-
     118$ the-module variables, the first three of which are used
     119$ to transmit flags and analysis constants between inner routines,
     120$ while the rest are built by a recursive depth-first search
     121$ procedure during call-graph analysis, and are used later in that
     122$ analysis.
     123$
     124    macro .comp;                   .comp_ocrs                    endm;
     125    macro interproc_fwd_analysis;  interproc_fwd_analysis_ocrs   endm;
     126    macro intraproc_fwd_analysis;  intraproc_fwd_analysis_ocrs   endm;
     127    macro interproc_back_analysis; interproc_back_analysis_ocrs  endm;
     128    macro intraproc_back_analysis; intraproc_back_analysis_ocrs  endm;
     129    macro fom;                     fom_ocrs                      endm;
     130    macro xom;                     xom_ocrs                      endm;
     131
     132    var
     133	id,		$ identity flow map
     134	zero,		$ null data state
     135	meet_flag,	$ true if meet analysis; otherwise false
     136	seen,		$ procedures already in dfst of cgraph
     137	cnpre,		$ current preorder index in dfst
     138	cnpost,		$ current postorder index in dfst
     139	nodeno,		$ preorder numbering map
     140	postno,		$ postorder numbering map
     141	ndescs;		$ no. of descendants map
     142
     143
     144    repr
     145	mode df_elmt:		df_elmt_ocrs;
     146	mode df_map:		df_map_ocrs;
     147
     148	.meetjoin:		operator(df_map, df_map) df_map;
     149	.mjv:			operator(df_elmt, df_elmt) df_elmt;
     150	.of:			operator(df_map, df_elmt) df_elmt;
     151
     152       interproc_fwd_eliminate: procedure(
     153				  remote smap(df_edge) df_map    )
     154				    remote smap(df_node) df_map;
     155       intraproc_fwd_eliminate: procedure(
     156				  routine,
     157				  remote smap(df_node) df_map,
     158				  remote smap(df_edge) df_map,
     159				  string    )
     160				    boolean;
     161	propagate_exposed:	procedure(
     162				  routine,
     163				  remote smap(df_edge) df_map,
     164				  remote smap(df_node) df_map,
     165				  remote mmap{df_node} df_elmt,
     166				  remote mmap{df_node} df_elmt,
     167				  remote mmap{df_node} df_elmt
     168				  );
     169	entry_info:		procedure(
     170				  remote smap(df_edge) df_map,
     171				  remote smap(df_node) df_map,
     172				  boolean,
     173				  remote mmap{df_node} df_elmt    )
     174				    remote smap(routine) df_elmt;
     175	fwd_propagate_in:	procedure(
     176				  routine,
     177				  remote smap(df_edge) df_map,
     178				  remote smap(df_node) df_map,
     179				  remote smap(df_node) df_elmt,
     180				  df_elmt,
     181				  boolean,
     182				  remote mmap{df_node} df_elmt
     183				  );
     184	interproc_back_eliminate:
     185				procedure(remote smap(df_edge) df_map)
     186				    remote smap(df_edge) df_map;
     187	intraproc_back_eliminate:
     188				procedure(
     189				  routine,
     190				  remote smap(df_edge) df_map,
     191				  remote smap(df_edge) df_map,
     192				  remote smap(routine) df_map,
     193				  *    )    $$-- flow_flag
     194				    boolean;
     195	intra_aux_eliminate:	procedure(
     196				  routine,
     197				  remote smap(df_edge) df_map,
     198				  remote smap(df_edge) df_map,
     199				  remote smap(df_node) df_map
     200				  );
     201	exit_info:		procedure(
     202				  remote smap(df_edge) df_map,
     203				  remote smap(df_edge) df_map,
     204				  remote smap(df_node) df_map    )
     205				    remote smap(routine) df_elmt;
     206	back_propagate_in:	procedure(
     207				  routine,
     208				  remote smap(df_node) df_map,
     209				  remote smap(df_node) df_elmt,
     210				  df_elmt
     211				  );
     212
     213
     214	$ data structures for variables global to this module
     215	id:			df_map;
     216	zero:			df_elmt;
     217	meet_flag:		boolean;
     218	cnpre:			integer;
     219	cnpost:			integer;
     220	nodeno:			remote smap(routine) integer;
     221	postno:			remote smap(routine) integer;
     222	ndescs:			remote smap(routine) integer;
     223	seen:			remote set(routine);
     224    end repr;
     225
     226
       1 .=member efa13o
       2
       3    procedure interproc_fwd_analysis(rw f, wr soln, id_prm, zero_prm,
       4				meet_flag_prm, move_code,
       5				rw exposed, wr insert,safe);
       6$
       7$ note declarations of 'read-write' parameters ('rw') and 'write-only'
       8$ parameters ('wr').
       9$
      10$ this is the master routine to perform a specific data flow
      11$ analysis interprocedurally. its parameters are:
      12$
      13$ f   - maps each edge (m, n) in the flow graph to a compact
      14$       representation of its data-propagation map f(m,n).
      15$       initially this information has to be provided only for
      16$       basic blocks (but not for call blocks); the first phase
      17$       of the analysis will fill in the additional entries.
      18$       each f(m,n) is represented as a pair [a, b] in l x l,
      19$       such that for each x in l, f(m,n)(x) = x*a + b, and
      20$       a contains b (this latter condition ensures that the
      21$       representation is unique, and also simplifies some
      22$       functional manipulations).
      23$
      24$ soln- the solution vector for the analysis. soln maps each
      25$       flow graph node to the data found to be known at its
      26$       entry.
      27$
      28$ the next three parameters are transmitted internally between
      29$ subprocedures by assigning them to global variables, as they
      30$ are constant per analysis. the corresponding globals are:
      31$
      32$ id  - the identity map representation. id = [u, {}], where
      33$       u is the universal set over which bitvectors are taken
      34$       in this analysis (e.g. set of all program expressions,
      35$       set of all variables etc.)
      36$
      37$ zero - the initial data value, i.e. flow data assumed at the main
      38$       program entry.
      39$
      40$ meet_flag - a flag indicating whether the analysis is a meet
      41$       analysis or a join analysis.
      42$
      43$ aux_f - these are auxiliary propagation maps. for each flow
      44$       graph node u, aux_f(u) denotes the effect of propagation
      45$       from the entry to i, the interval containing u, through
      46$       i, to the entry of u.
      47$
      48$ move_code - a flag indicating that code motion is required.
      49$
      50$ exposed - this is initially the set of computations (corresponding
      51$       to analysis elements (bits)) exposed at the start of each
      52$       basic block n (i.e. computed with no prior kill in n). the
      53$       inner-to-outer phase of our analysis attaches an 'exposed'
      54$       value to each interval processed. exposed{i} is the set of all
      55$       expressions t for which there exists a computation of t
      56$       within the interval i which would become redundant if and
      57$       only if t became available at the entry to (the target block
      58$       of) i. note, however, that the logical place at which
      59$       computations movable out of an interval i should be inserted
      60$       is the end of the target block of i, rather than its start.
      61$       thus if that target block is nonempty then exposed{i}
      62$       need not represent those movable computations. for this
      63$       reason we provide the parameter 'insert' which gives the
      64$       desired set of movable code.
      65$
      66$ insert - this output parameter will map each interval into
      67$       the set of all computations movable out of its loop,
      68$       which are to be inserted at the end of the target
      69$       block of the interval. the actual insertion should be
      70$       performed by the calling procedure.
      71$
      72$ our analysis procedures makes frequent use of the following
      73$ operators (which could be also written as macros, if it were
      74$ not for the convenience of the infix notation that we prefer
      75$ to use):
      76$
      77$ .comp     - functional composition
      78$ .meetjoin - functional meet or join, depending on meet_flag
      79$ .mjv      - meet or join of lattice values
      80$ .of       - functional application
      81$
      82$ all these operators have elementary set expressions; see below
      83$ for details.
      84$
      85$ note also that these operators must be prepared to handle
      86$ undefined flow values, which will be represented
      87$ by a special constant 'fom'; for example,
      88$        g .comp fom = fom .comp g = fom;
      89$                (concatenation of an undefined flow with a defined
      90$                one is still undefined)
      91$        g .meetjoin fom = fom .meetjoin g = g.
      92$                (a join or a meet of an undefined flow with a defined
      93$                flow yields the defined flow.)
      94$
      95$ another special constant 'xom' is used to denote the undefined data
      96$ state in l.
      97$
      98    repr
      99	$ data structures for parameters
     100	f:			remote smap(df_edge) df_map;
     101	soln:			remote smap(df_node) df_elmt;
     102	id_prm:			df_map;
     103	zero_prm:		df_elmt;
     104	meet_flag_prm:		boolean;
     105	move_code:		boolean;
     106	exposed:		remote mmap{df_node} df_elmt;
     107	insert:			remote mmap{df_node} df_elmt;
     108	safe:			remote mmap{df_node} df_elmt;
     109
     110	$ data structures for local variables
     111	aux_f:			remote smap(df_node) df_map;
     112	ent_inf:		remote smap(routine) df_elmt;
     113	p:			routine;
     114    end repr;
     115$
     116$ transfer constant parameters to globals
     117$
     118    id        := id_prm;
     119    zero      := zero_prm;
     120    meet_flag := meet_flag_prm;
     121$
     122$ the master procedure consists of the following three phases:
     123$
     124$ 1. interprocedural elimination phase
     125$
     126    aux_f := interproc_fwd_eliminate(f);
     127$
     128$ if code motion is required then perform an additional
     129$ phase, computing the sets of movable code.
     130$
     131    if move_code then
     132	insert := {};
     133	(forall p in routs)
     134	    propagate_exposed(p, f, aux_f, exposed, insert, safe);
     135	end forall;
     136    end if;
     137$
     138$ 2. find data at procedure entries
     139$
     140    ent_inf := entry_info(f, aux_f, move_code, insert);
     141$
     142$ 3. final propagation phase
     143$
     144    soln := {};     $ initialize the solution
     145    (forall p in routs)
     146	fwd_propagate_in(p, f, aux_f, soln, ent_inf(p),
     147			move_code, insert);
     148    end forall;
     149
     150    end procedure interproc_fwd_analysis;
     151
     152
       1 .=member efe13p
       2
       3
       4    procedure interproc_fwd_eliminate(rw f);
       5$
       6$ this is the driver routine for the first interprocedural
       7$ inner-to-outer interval pass. procedures are analyzed in
       8$ the following order: we process the strongly connected
       9$ components of the call graph in their postorder; for each
      10$ such component, we iterate through its procedures in their
      11$ postorder, no more than 2*d+1 times, where d is the loop-
      12$ interconnectedness parameter of the component.
      13$
      14    repr
      15	$ data structures for parameters
      16	f:			remote smap(df_edge) df_map;
      17
      18	$ data structures for local variables
      19	aux_f:			remote smap(df_node) df_map;
      20	i:			integer;
      21	scc:			routine;
      22	scc_procs:		tuple(routine);
      23	flow_flag:		string;
      24	j:			integer;
      25	proc_converge:		boolean;
      26	k:			integer;
      27	p:			routine;
      28    end repr;
      29
      30    aux_f := {};   $ initialize auxiliary maps
      31
      32$ iterate through the s.c.c.s of cgraph
      33    (forall i in [ #cg_sccs, #cg_sccs-1..1 ])
      34
      35	scc := cg_sccs(i);   $ get a s.c.c.
      36	scc_procs := scc_nodes(scc);  $ procs in that s.c.c.
      37	flow_flag := 'first_inter'; $ first processing of the scc
      38
      39	(forall j in [ 1..2*scc_d(scc)+1 ])
      40	    proc_converge := true;
      41
      42	    (forall k in [ #scc_procs, #scc_procs-1..1 ])
      43		p := scc_procs(k);
      44		proc_converge :=
      45		    intraproc_fwd_eliminate(p, aux_f, f, flow_flag)
      46		    and proc_converge;
      47$ the intraproc_fwd_eliminate routine analyzes p; its fourth parameter
      48$ indicates whether the analysis is first-time interprocedural, second
      49$ -time interprocedural or intraprocedural; it returns a flag to
      50$ indicate whether information in p has stabilized.
      51	    end forall k;
      52
      53	    flow_flag := 'second_inter'; $ additional passes thru scc
      54
      55	    if proc_converge then quit forall j; end;
      56	end forall j;
      57    end forall i;
      58
      59    return aux_f;
      60
      61    end procedure interproc_fwd_eliminate;
      62
      63
       1 .=member afe13q
       2
       3
       4    procedure intraproc_fwd_eliminate(p, rw aux_f, rw f, flow_flag);
       5$
       6$ this routine performs an intraprocedural elimination phase
       7$ for the procedure p, using interval analysis. the fourth parameter
       8$ indicates whether this routine has been invoked by the
       9$ intraprocedural solver or by the interprocedural solver, and
      10$ in the second case, whether this is the first time p is
      11$ being processed or not.
      12$
      13$ in this pass we iterate through the procedure's intervals
      14$ in an inner-to -outer order (i.e. in reverse preorder of their
      15$ heads in a dfst of the flow graph of p). for each interval
      16$ i processed in this manner we compute a set of data-propagation
      17$ maps of the form f(i, u), where
      18$
      19$ (1) if u is in i, then this map is an auxiliary map (which will
      20$ be denoted as aux_f(u), i being implicit in this case) which
      21$ represents the propagation effect as control advances from
      22$ the start of i, thru i, to the start of u;
      23$
      24$ (2) if u is not in i, then u is a successor of some node in i.
      25$ here the map f(i, u) represents the propagation effect as control
      26$ advances from the start of i, through i, to the start of u;
      27$ in this case f(i, u) is needed for the processing of the
      28$ intervals containing i. note that [i, u] is a virtual edge
      29$ in our flow graph; thus the elimination phase extends the
      30$ map f so as to be defined also on virtual edges.
      31$
      32$ any interval i processed in this routine is either a proper
      33$ strongly connected interval, or, if it contains 'improper'
      34$ nodes (i.e. nucleii of irreducibility), is a single-entry
      35$ strongly connected subgraph.  in the first case we only have to
      36$ iterate thru the nodes of i twice, but in the second case till
      37$ convergence.
      38$
      39$ the outermost 'interval' is either a single entry acyclic
      40$ graph (if it does not contain irreducible nucleii), or a
      41$ general single-entry graph otherwise. for this 'interval' we
      42$ iterate either once in the first case, or till convergence
      43$ otherwise.
      44$
      45$ if the present routine is to be used for interprocedural analysis,
      46$ we first reset the propagation maps for call blocks in p. if none of
      47$ these maps have changed from the last processing of p,
      48$ then obviously analysis of p has stabilized and we can return
      49$ immediately. moreover, intervals need be re-processed if and only
      50$ if they contain a call block whose local effect has changed,
      51$ or, recursively, contain an interval whose local effects
      52$ have changed. in terms of the 'intof' tree, we only have to
      53$ re-analyze intervals lying along some path from the
      54$ root to a call block whose local effect has changed. this
      55$ can make reprocessing of a procedure considerably
      56$ faster than initial processing.
      57$
      58    repr
      59	$ data structures for parameters
      60	p:			routine;
      61	aux_f:			remote smap(df_node) df_map;
      62	f:			remote smap(df_edge) df_map;
      63	flow_flag:		string;
      64
      65	$ data structures for local variables
      66	need_process:		set(df_node);
      67	intt:			df_node;
      68	c:			df_node;
      69	v:			df_node;
      70	p1:			routine;
      71	ep1:			df_node;
      72	p_ints:			tuple(df_node);
      73	outint:			df_node;
      74	k:			integer;
      75	nodes:			tuple(df_node);
      76	head:			df_node;
      77	conv_control:		boolean;
      78	n_iter:			integer;
      79	j:			integer;
      80	d:			integer;
      81	convrgd:		boolean;
      82	nd:			df_node;
      83	ftemp:			df_map;
      84	pnd:			df_node;
      85	pv:			df_node;
      86    end repr;
      87
      88    if flow_flag = 'second_inter' then
      89	$ process only intervals containing calls with new effect
      90	need_process := {};
      91    else
      92	$ process all intervals
      93	need_process := { intt : intt in ints(p) };
      94    end if;
      95
      96    if flow_flag /= 'intra' then
      97	$ interprocedural analysis
      98	(forall c in callsin{p})
      99	    v   := cessor(c);	    $ the block following the call
     100	    p1  := callproc(c);     $ c calls p1
     101	    ep1 := rexit(p1);       $ the return block of p1.
     102$ (note here that if this routine is modified to include parameter-
     103$ passing assignments as part of call blocks, in the manner suggested
     104$ in a concluding remark in section 4, then one might manipulate
     105$ aux_f(ep1), which defines the local effect of executing p1, to get
     106$ f(c,v), rather than just assign the first map to the second one, as
     107$ is done below).
     108
     109	    if f([c, v]) /= aux_f(ep1) then
     110		$ update flow function for call
     111		f([c, v]) := aux_f(ep1) ? fom;
     112
     113		$ interval containing call must be processed
     114		need_process with:= intof(c);
     115	    end if;
     116	end forall c;
     117
     118	$ if no intervals need be processed then information has
     119	$ stabilized and no re-processing of p need be done.
     120	if need_process = {} then return true; end if;
     121    end if;
     122
     123    p_ints := ints(p);		$ intervals of p in reverse preorder
     124    outint := p_ints(#p_ints);  $ outermost interval
     125
     126    (forall intt = p_ints(k) | intt in need_process)
     127	need_process with:= intof(intt);  $ process containing interva
     128	nodes := int_nodes(intt); $ nodes of intt in interval order
     129
     130	head := nodes(1);	$ interval head
     131	aux_f(head) := id;	$ init aux_f of head to the identity
     132$
     133$ note here that the edge [intt, head] is a real edge in the
     134$ flow graph, so that f([intt, head]) will have been pre-computed in
     135$ an initialization phase, along with the flow maps for all other
     136$ real edges, and is therefore available here.
     137$
     138$ three cases are now possible:
     139$
     140$ (1) intt is proper, but not outermost; then iterate twice.
     141$ (2) intt is proper, and is outermost; then iterate once.
     142$ (3) intt is improper; iterate indefinitely (1 + number of
     143$     nodes is an adequate upper bound) until convergence.
     144$     (note that we do not make use of the better upper bound on
     145$     the number of iterations discussed in section 3).
     146$
     147	$ test for convergence only in this case
     148	conv_control := intt notin proper_ints;
     149
     150	n_iter :=       $ maximal number of iterations
     151	    if intt notin proper_ints then #nodes + 1
     152	    elseif intt = outint then 1 else 2 end;
     153$
     154$ for improper intervals, initialize aux_f of all non-head nodes
     155$ to 'fom'.  this is because we cannot guarantee in those cases that
     156$ when propagating data to a node within intt, all its predecessors
     157$ (within intt) have already been processed, so that we have to
     158$ prepare for the case where some of these predecessors still
     159$ have undefined auxiliary data-flow maps.
     160$
     161	if conv_control then
     162	    (forall j in [ 2..#nodes ])
     163		aux_f(nodes(j)) := fom;
     164	    end forall;
     165	end if;
     166
     167	$ iterate through the nodes of intt
     168	(forall d in [ 1..n_iter ])
     169
     170	    convrgd := conv_control;
     171
     172	    $ iterate thrugh the nodes of intt, other than head
     173	    (forall j in [ 2..#nodes ])
     174
     175		nd := nodes(j);
     176		ftemp := fom;
     177		(forall pnd in pred{nd} | intof(pnd) = intt)
     178		    ftemp .meetjoin:= (f([pnd,nd]) .comp aux_f(pnd));
     179		end forall;
     180
     181		convrgd and:= (ftemp = aux_f(nd));
     182		aux_f(nd) := ftemp;
     183
     184	    end forall j;
     185
     186	    $ test if processing of intt has terminated
     187	    if d = n_iter or convrgd then quit forall d; end if;
     188
     189	    $ re-compute aux_f(head), taking back edges into account
     190	    ftemp := fom;
     191	    (forall pnd in pred{head} | intof(pnd) = intt)
     192		ftemp .meetjoin:= (f([pnd,head]) .comp aux_f(pnd));
     193	    end forall;
     194	    ftemp .meetjoin:= aux_f(head);
     195
     196	    if not conv_control then
     197		convrgd := aux_f(head) = ftemp;
     198	    end if;
     199
     200	    aux_f(head) := ftemp;
     201	    if convrgd then quit forall d; end if;
     202	end forall d;
     203
     204$
     205$ compute f([intt, v]), where v is a successor of some node in
     206$ intt; note that this loop will be null for the
     207$ outermost interval.
     208$
     209	(forall v in vedges{intt})
     210	    ftemp := fom;
     211
     212	    (forall pv in pred{v} | intof(pv) = intt)
     213		ftemp .meetjoin:= (f([pv,v]) .comp aux_f(pv));
     214	    end forall;
     215
     216	    f([intt, v]) := ftemp .comp f([intt, head]);
     217	end forall v;
     218    end forall intt;
     219
     220    return false;           $ to indicate no convergence
     221
     222    end procedure intraproc_fwd_eliminate;
     223
     224
       1 .=member pex13r
       2
       3
       4    procedure propagate_exposed(p, rw f, aux_f, rw exposed, rw insert,
       5		    safe);
       6$
       7$ this procedure performs an inner-to-outer pass over all
       8$ intervals to determine the computations which might be moved
       9$ out of the loop of each interval i. as explained above,
      10$ these computations are not necessarily those exposed in i;
      11$ hence, we build up both sets 'exposed' and 'insert'
      12$ simultaneously.
      13$
      14$ in this analysis, the set of computations movable out of the
      15$ loop of i is obtained by taking all computations t with
      16$ the property that there exists a node nd in i such that
      17$ t is exposed in nd and is available at the start of nd iff
      18$ it is available at the end of the target block of i.
      19$
      20$ the movable code is always assumed to be appended to the
      21$ end of the target block of the interval, to avoid any possible
      22$ conflict with code that is already present in the target block.
      23$ however, this appending takes place physically only at the end
      24$ of the elimination phase. thus, we do not attempt to make
      25$ use of the fact that these expressions are potentially
      26$ available at the head of i in updating any flow function.
      27$ this approach is necessary to ensure convergence of our algorithms
      28$ in cases of recursive cycles of interprocedural flow.
      29$
      30    repr
      31	$ data structures for parameters
      32	p:			routine;
      33	f:			remote smap(df_edge) df_map;
      34	aux_f:			remote smap(df_node) df_map;
      35	exposed:		remote mmap{df_node} df_elmt;
      36	insert:			remote mmap{df_node} df_elmt;
      37	safe:			remote mmap{df_node} df_elmt;
      38
      39	$ data structures for local variables
      40	p_ints:			tuple(df_node);
      41	outint:			df_node;
      42	intt:			df_node;
      43	k:			integer;
      44	nodes:			tuple(df_node);
      45	head:			df_node;
      46	itemp:			df_elmt;
      47	nd:			df_node;
      48	ftarg:			df_map;
      49	expfromentry:		df_elmt;
      50    end repr;
      51
      52    p_ints := ints(p);  $ intervals of p in reverse preorder
      53$
      54$ first extend f to indicate null flow from the entry block to
      55$ itself. since the outermost interval has no target block,
      56$ and is therefore identified with its head, this trick unifies
      57$ the treatment of that interval with the treatment of inner
      58$ intervals, as shown below.
      59$
      60    outint := p_ints(#p_ints);
      61    f([outint, outint]) := id;
      62
      63    (forall intt = p_ints(k))
      64	nodes := int_nodes(intt);
      65	head := nodes(1);
      66$
      67$ in computing exposed{intt}, we must reckon with the fact
      68$ that the target block of intt (also denoted by intt)
      69$ might be non-empty, due to prior code motion. this can mean that
      70$ (a) f([intt, head]) is not the identity, and (b) exposed{intt}
      71$ (where intt is treated as a basic block) is not null
      72$ initially.
      73$
      74	$ we proceed as follows: first find all exposed computations
      75	$ in the loop of intt, assuming the target block of intt to
      76	$ be null.  these are the computations movable out of the loop
      77	$ of intt.
      78	itemp := {};
      79	(forall nd in nodes)
      80	    itemp +:= (exposed{nd} * (aux_f(nd)(1) - aux_f(nd)(2)));
      81	end forall;
      82	if safe /= om then itemp := itemp * safe{intt}; end if;
      83	insert{intt} := itemp;
      84
      85	$ next find the new set of computations which are still
      86	$ exposed at the entry to the target block of intt.
      87	ftarg := f([intt, head]);
      88	expfromentry := insert{intt} * (ftarg(1) - ftarg(2));
      89
      90	$ add these computations to those exposed in the target block
      91	exposed{intt} := exposed{intt} + expfromentry;
      92
      93    end forall intt;
      94
      95
      96    end procedure propagate_exposed;
      97
      98
      99
     100
     101    procedure entry_info(f, aux_f, move_code, insert);
     102$
     103$ this function calculates and returns a mapping which sends
     104$ each procedure p into the flow information available at entry
     105$ to p.  it is called (only in the interprocedural case) just
     106$ before we begin the final outer-to-inner propagation phase.
     107$
     108    repr
     109	$ data structures for parameters
     110	f:			remote smap(df_edge) df_map;
     111	aux_f:			remote smap(df_node) df_map;
     112	move_code:		boolean;
     113	insert:			remote mmap{df_node} df_elmt;
     114
     115	$ data structures for local variables
     116	cgf:			smap( tuple(routine, routine) ) df_map;
     117	p, q:			routine;
     118	c:			df_node;
     119	ftemp:			df_map;
     120	iu:			df_node;
     121	hiu:			df_node;
     122	fins:			df_map;
     123	ent_inf:		remote smap(routine) df_elmt;
     124	cgrinv:			mmap(routine) routine;
     125	i:			integer;
     126	scc:			routine;
     127	scc_procs:		tuple(routine);
     128	n:			integer;
     129	convrgd:		boolean;
     130	k:			integer;
     131	temp:			df_elmt;
     132    end repr;
     133$
     134$ first we construct a map 'cgf' assigning to each edge (p, q)
     135$ of the call graph a data-propagation map, describing the
     136$ propagation effect as control advances from the entry of p
     137$ to the entry of q via any call to q from p.
     138$
     139    cgf := {};
     140    (forall [p,q] in cgraph) cgf([p,q]) := fom; end;
     141
     142    (forall q = callproc(c))  $ for all calls within all procedures
     143
     144	p := routof(c);   $ [p, q] is an edge of the call graph
     145
     146	$ compute the local effect as control advances from the entry
     147	$ of p to c.
     148	ftemp := aux_f(c);
     149
     150	(init iu := intof(c); while iu /= rentry(p))
     151
     152	    hiu := int_nodes(iu)(1);   $ head of iu
     153	    fins := id;
     154	    $ add also the effect of code moved out of iu
     155	    if move_code then fins(2) := insert{iu}; end;
     156	    ftemp := ftemp .comp fins .comp f([iu, hiu])
     157				.comp aux_f(iu);
     158
     159	    iu := intof(iu);
     160
     161	end;
     162
     163	cgf([p, q]) := cgf([p, q]) .meetjoin ftemp;
     164
     165    end forall q;
     166$
     167$ next we iterate through the call graph  in  'invocation  order',  i.e.
     168$ process the strongly connected components in reverse postorder and the
     169$ set of procedures within each strongly connected component in  reverse
     170$ postorder also.
     171$
     172    ent_inf := { [ p, xom ] : p in routs};	$ initialize solution
     173    ent_inf(sym_main) := zero;
     174    cgrinv := { [ p, q ] : [ q, p ] in cgraph };
     175
     176    $ pick strongly-connected components in reverse postorder
     177    (forall i in [ 2..#cg_sccs ])
     178
     179	$ nb. here we assume that the main program is non-recursive,  so
     180	$ that the first strongly-connected component of the call  graph
     181	$ consists of the main program only.  thus we can skip  it,  for
     182	$ the entry value of the main program is already assumed  known.
     183
     184	scc := cg_sccs(i);
     185	scc_procs := scc_nodes(scc);	$ procs in scc in rev. postorder
     186
     187	(forall n in [ 1..scc_d(scc)+1 ] )
     188
     189	    convrgd := true;
     190
     191	    (forall p = scc_procs(k))
     192
     193		temp := xom;
     194		(forall q in cgrinv{p})
     195		   temp .mjv:= (cgf([q,p]) .of ent_inf(q));
     196		end forall;
     197
     198		$ test for convergence
     199		convrgd and:= (temp = ent_inf(p));
     200
     201		ent_inf(p) := temp;
     202	    end forall p;
     203
     204	    if convrgd then quit forall n; end if;
     205	end forall n;
     206    end forall i;
     207
     208    return ent_inf;
     209
     210    end procedure entry_info;
     211
     212
       1 .=member fpi13s
       2
       3
       4    procedure fwd_propagate_in(p, rw f, aux_f, rw soln, ent_val,
       5			    move_code, rw insert);
       6$
       7$ this procedure performs outer-to-inner propagation for a
       8$ routine p, using the 'interval-effect' flow functions aux_f
       9$ to modify the solution map 'soln'.  the parameter ent_val
      10$ gives the flow information assumed (or known) at procedure
      11$ entry.
      12$
      13$ if code motion is required, then the computations in insert{i}
      14$ are assumed to be available at the end of the target block
      15$ of an interval i (but only for the purpose of propagation
      16$ inside i).  in addition, computations in insert{i} already
      17$ available at exit from the target block of i are removed from
      18$ insert{i}.
      19$
      20$ note that movable computations are assumed to be such that the
      21$ insertion of any of them will not 'kill' any others.
      22$
      23    repr
      24	$ data structures for parameters
      25	p:			routine;
      26	f:			remote smap(df_edge) df_map;
      27	aux_f:			remote smap(df_node) df_map;
      28	soln:			remote smap(df_node) df_elmt;
      29	ent_val:		df_elmt;
      30	move_code:		boolean;
      31	insert:			remote mmap{df_node} df_elmt;
      32
      33	$ data structures for local variables
      34	p_ints:			tuple(df_node);
      35	outint:			df_node;
      36	k:			integer;
      37	intt:			df_node;
      38	nodes:			tuple(df_node);
      39	soln1:			df_elmt;
      40	u:			df_node;
      41    end repr;
      42
      43    soln(rentry(p)) := ent_val;
      44    p_ints := ints(p);  $ intervals of p in reverse preorder
      45$
      46$ extend f to indicate null flow from the entry block to
      47$ itself.  since the outermost interval has no target block,
      48$ and is therefore identified with its head, this trick unifies
      49$ the treatment of that interval with the treatment of inner
      50$ intervals, as shown below.
      51$
      52    outint := p_ints(#p_ints);
      53    f([outint, outint]) := id;
      54
      55    (forall k in [ #p_ints, #p_ints-1..1 ])
      56
      57	intt := p_ints(k);
      58	nodes := int_nodes(intt);  $ nodes of intt
      59
      60	soln1 := soln(intt);  $ data value at entry to intt
      61
      62	$ convert soln1 to the data attribute value at the end of the
      63	$ target block of intt.
      64	$ propagate through the target block of intt; if
      65	$ intt = outint, the trick noted above will make the following
      66	$ statement a no-op.
      67	soln1 := f([intt, nodes(1)]) .of soln1;
      68
      69	$ if code motion is also required, then update insert{intt}
      70	$ and add it to soln1.
      71	if move_code and intt /= outint then
      72	    insert{intt} := insert{intt} - soln1;
      73	    soln1 := soln1 + insert{intt};
      74	end if;
      75
      76	$ now propagate attributes to the nodes of intt
      77	(forall u in nodes)
      78	    soln(u) := aux_f(u) .of soln1;
      79	end forall;
      80
      81    end forall;
      82
      83
      84    end procedure fwd_propagate_in;
      85
      86
       1 .=member afa13t
       2
       3
       4    procedure intraproc_fwd_analysis(p, rw f, wr soln, id_prm, zero_prm,
       5				meet_flag_prm, move_code,
       6				rw exposed, wr insert, safe);
       7$
       8$ this is the master routine to perform a specific data flow
       9$ analysis intraprocedurally for a given routine p, within which
      10$ local variables are analyzed.
      11$
      12$ for more details and comments and description of parameters see the
      13$ corresponding interprocedural analyser.
      14$
      15
      16    repr
      17	$ data structures for parameters
      18	p:			routine;
      19	f:			remote smap(df_edge) df_map;
      20	soln:			remote smap(df_node) df_elmt;
      21	id_prm:			df_map;
      22	zero_prm:		df_elmt;
      23	meet_flag_parm:		boolean;
      24	move_code:		boolean;
      25	exposed:		remote mmap{df_node} df_elmt;
      26	insert:			remote mmap{df_node} df_elmt;
      27	safe:			remote mmap{df_node} df_elmt;
      28
      29	$ data structures for local variables
      30	aux_f:			remote smap(df_node) df_map;
      32    end repr;
      33
      34    id        := id_prm;
      35    meet_flag := meet_flag_prm;
      36
      37    aux_f := {};
      38
      39    intraproc_fwd_eliminate(p, aux_f, f, 'intra');
      42
      43    if move_code then
      44	insert := {};
      45	propagate_exposed(p, f, aux_f, exposed, insert, safe);
      46    end if;
      47
      48    soln := {};
      49    fwd_propagate_in(p, f, aux_f, soln, zero_prm, move_code, insert);
      50
      51    end procedure intraproc_fwd_analysis;
      52
      53
      54
      55
      56    procedure interproc_back_analysis(rw f, wr soln, id_prm, zero_prm,
      57				  meet_flag_prm);
      58$
      59$ this is the master routine for performing a specific interprocedural
      60$ backward data flow analysis.  see the corresponding forward routine
      61$ for general comments and a description of parameters.  here we comment
      62$ only on differences between the forward and backward algorithms, which
      63$ are as follows:
      64$
      65$ a. functional composition must be computed in reverse order.
      66$
      67$ b. the auxiliary maps used in backward analysis are defined as
      68$    follows:  let i be an interval, u a node in i and v a node outside
      69$    i which is a successor of a node in i.  then aux_f([u, v]) is
      70$    defined to be the propagation effect experienced as control
      71$    advances from the start of u, through  i, to the start of v.
      72$
      73$    to compute this map requires iterating through i in reverse
      74$    interval order three times (if i is proper) or till convergence
      75$    otherwise.
      76$
      77$    since the outermost interval of a procedure p has no successors,
      78$    we regard the blocks rexit(p) and rstop(p) as its successors,
      79$    'hidden' inside that interval.  this is needed to enable us to
      80$    record the effect of the flow through the outermost interval in
      81$    a manner similar to that used for inner intervals.
      82$
      83$ c. in backward analysis we perform an extra step after the
      84$    elimination phase.  in this step we compute an additional set
      85$    'fexit' of auxiliary maps.  for each node u in p, fexit(u)
      86$    represents the propagation effect of the flow from the start
      87$    of u to the return block of p, combined with that of flow from
      88$    the start of u to the stop block of p.
      89$
      90$ d. in our backward analysis code motion issues are completely
      91$    ignored.
      92$
      93$ e. the technical problem concerning endless loops discussed in
      94$    section 5 is assumed to be resolved by preliminary processing
      95$    of the flow graph, in the manner suggested there.
      96$
      97    repr
      98	$ data structures for parameters
      99	f:			remote smap(df_edge) df_map;
     100	soln:			remote smap(df_node) df_elmt;
     101	id_prm:			df_map;
     102	zero_prm:		df_elmt;
     103	meet_flag_prm:		boolean;
     104
     105	$ data structures for local variables
     106	aux_f:			remote smap(df_edge) df_map;
     107	fexit:			remote smap(df_node) df_map;
     108	p:			routine;
     109	ex_inf:			remote smap(routine) df_elmt;
     110    end repr;
     111
     112    $ transfer constant parmeters to globals
     113    id        := id_prm;
     114    zero      := zero_prm;
     115    meet_flag := meet_flag_prm;
     116$
     117$ this master procedure consists of the following four phases:
     118$
     119$ 1. interprocedural elimination phase
     120$
     121    aux_f := interproc_back_eliminate(f);
     122$
     123$ 2. compute auxiliary fexit maps.
     124$
     125    fexit := {};
     126    (forall p in routs)
     127	intra_aux_eliminate(p, f, aux_f, fexit);
     128    end forall p;
     129$
     130$ 3. find data at procedure exits
     131$
     132    ex_inf := exit_info(f, aux_f, fexit);
     133$
     134$ 4. final propagation phase
     135$
     136    soln := {};     $ initialize the solution
     137    (forall p in routs)
     138	back_propagate_in(p, fexit, soln, ex_inf(p));
     139    end forall;
     140
     141    end procedure interproc_back_analysis;
     142
     143
       1 .=member ebe13u
       2
       3
       4    procedure interproc_back_eliminate(rw f);
       5$
       6$ this is the driver routine for the interprocedural first
       7$ inner-to-outer interval pass.  procedures are analyzed in
       8$ the following order: we process the strongly connected
       9$ components of the call graph in their postorder; then, for each
      10$ such component, we iterate through its procedures in their
      11$ postorder, no more than 2*d+1 times, where d is the loop-
      12$ interconnectedness parameter of the component.
      13$
      14    repr
      15	$ data structures for parameters
      16	f:			remote smap(df_edge) df_map;
      17
      18	$ data structures for local variables
      19	aux_f:			remote smap(df_edge) df_map;
      20	f_p:			remote smap(routine) df_map;
      21	i:			integer;
      22	scc:			routine;
      23	scc_procs:		tuple(routine);
      24	flow_flag:		string;
      25	j:			integer;
      26	proc_converge:		boolean;
      27	k:			integer;
      28	p:			routine;
      29    end repr;
      30
      31    aux_f := {};   $ initialize auxiliary maps
      32    f_p := {};     $ propagation effect thru procedures
      33
      34    $ iterate through the s.c.c.s of cgraph
      35    (forall i in [ #cg_sccs, #cg_sccs-1..1 ])
      36	scc := cg_sccs(i);   $ get a s.c.c.
      37	scc_procs := scc_nodes(scc);  $ procs in that s.c.c.
      38	flow_flag := 'first_inter'; $ first processing of the scc
      39
      40	(forall j in [ 1..2*scc_d(scc)+1 ] )
      41	    proc_converge := true;
      42
      43	    (forall k in [ #scc_procs, #scc_procs-1..1 ])
      44		p := scc_procs(k);
      45		proc_converge :=
      46		    intraproc_back_eliminate(p,aux_f,f,f_p,flow_flag)
      47		    and proc_converge;
      48		$ this routine analyzes p;  its fifth parameter
      49		$ indicates whether the analysis is first-time
      50		$ interprocedural, second-time interprocedural or
      51		$ intraprocedural; it returns a flag to indicate
      52		$ whether information has stabilized in p.
      53	    end forall k;
      54
      55	    flow_flag := 'second_inter'; $ additional passes thru scc
      56
      57	    if proc_converge then quit forall j; end if;
      58	end forall j;
      59    end forall i;
      60
      61    return aux_f;
      62
      63    end procedure interproc_back_eliminate;
      64
      65
       1 .=member abe13v
       2
       3
       4    procedure intraproc_back_eliminate(p, rw aux_f, rw f, rw f_p,
       5				flow_flag);
       6$
       7$ this routine performs an intraprocedural elimination phase of a
       8$ backward data flow analysis for a given procedure p.
       9$
      10$ the overall logic is quite similar to its sister routine
      11$ 'intraproc_fwd_eliminate', and the reader should consult comments
      12$ given there.  the differences between these two phases reflects
      13$ mainly the reverse tracing of flow, which implies several minor
      14$ modifications of the forward approach, as follows:
      15$
      16$ a. auxiliary information is computed for each successor of each
      17$    interval.  that is, for each interval i, each node u in i, and
      18$    each successor node v of i, we compute a map aux_f([u, v]),
      19$    representing the flow from u through i to v.  the outermost
      20$    interval has no successors, but we regard the return block of p
      21$    and the stop block of p (if any) as its two successors, even
      22$    though they lie within it.  (note that since these two nodes
      23$    can never lie on a cycle through p, they must belong to the
      24$    outer-most interval).
      25$
      26$ b. nodes of an interval are processed in reverse interval order
      27$    (i.e. postorder);  this is done three times if i is a proper
      28$    inner interval, once if i is a proper outer-most inteval, and
      29$    till convergence otherwise.
      30$
      31$ c. functional composition is taken in reverse edge order.
      32$
      33$ d. an additional data structure f_p is used to hold the propagation
      34$    effect through the whole procedure in the interprocedural case.
      35$    this is because the flow through p is actually combined of two
      36$    flows:  one leading to the return block of p, and another leading
      37$    to the stop block of p, if any.  unlike in the forward case,
      38$    where the second flow can be, and is, actually ignored, here we
      39$    must take it into account.
      40$
      41    repr
      42	$ data structures for formal parameters
      43	p:			routine;
      44	aux_f:			remote smap(df_edge) df_map;
      45	f:			remote smap(df_edge) df_map;
      46	f_p:			remote smap(routine) df_map;
      47	flow_flag:		*;
      48
      49	$ data structures for local variables
      50	need_process:		set(df_node);
      51	intt:			df_node;
      52	c:			df_node;
      53	v:			df_node;
      54	p1:			routine;
      55	p_ints:			tuple(df_node);
      56	outint:			df_node;
      57	sp:			df_node;
      58	k:			integer;
      59	nodes:			tuple(df_node);
      60	head:			df_node;
      61	cesors:			sparse set(df_node);
      62	conv_control:		boolean;
      63	n_iter:			integer;
      64	nd:			df_node;
      65	d:			integer;
      66	convrgd:		boolean;
      67	j:			integer;
      68	ftemp:			df_map;
      69	snd:			df_node;
      70	fzero:			df_elmt;
      71    end repr;
      72
      73
      74    if flow_flag = 'second_inter' then
      75	$ process only intervals containing calls with new effects
      76	need_process := {};
      77    else
      78	$ process all intervals
      79	need_process := { intt : intt in ints(p)}; $ convert to set
      80    end if;
      81
      82    if flow_flag /= 'intra' then $ interprocedural analysis
      83	(forall c in callsin{p})
      84	    v  := cessor(c);	$ the block following the call
      85	    p1 := callproc(c);	$ c calls p1
      86
      87	    $ (note that if this routine is modified to include
      88	    $ parameter-passing assignments as part of call blocks,
      89	    $ in the manner mentioned above, then one might manipulate
      90	    $ f_p(p1), the local effect of executing p1, to get
      91	    $ f([c, v]), rather than just assign f_p(p1)
      92	    $ to f([c, v]), as is done below).
      93
      94	    if f([c, v]) /= f_p(p1) then
      95		$ update flow function for call
      96		f([c, v]) := f_p(p1) ? fom;
      97
      98		$ interval containing call must be processed
      99		need_process with:= intof(c);
     100	    end if;
     101	end forall c;
     102
     103	$ if no intervals need be processed then information has
     104	$ stabilized and no re-processing of p need be done.
     105	if need_process = {} then return true; end if;
     106    end if;
     107
     108
     109    p_ints := ints(p); $ intervals of p in reverse preorder
     110    outint := p_ints(#p_ints);  $ outermost interval
     111    vedges{outint} := {rexit(p)};  $ 'successors' of outint
     112    if (sp := rstop(p)) /= om then
     113	vedges{outint} with:= sp;
     114    end if;
     115
     116    (forall intt = p_ints(k) | intt in need_process)
     117	need_process with:= intof(intt);  $ process containing interva
     118	nodes := int_nodes(intt); $ nodes of intt in interval order
     119	head := nodes(1);  $ interval head
     120
     121	$ get successor nodes
     122	cesors := vedges{intt};
     123
     124	$ initialize aux_f for successor nodes.  this trick simplifies
     125	$ subsequent code considerably.
     126	(forall v in cesors)
     127	    aux_f([v, v]) := id;
     128	end forall v;
     129
     130$
     131$ three cases are now possible:
     132$ a. intt is proper, but not outermost; then iterate three times.
     133$ b. intt is proper, and is outermost; then iterate once.
     134$ c. intt is improper; iterate indefinitely (1 + 2*number of
     135$    nodes is an adequate upper bound) until convergence.  (here,
     136$    again, a better bound can be used; cf. section 6).
     137$
     138	$ we test for convergence only for improper intervals.
     139	conv_control := intt notin proper_ints;
     140
     141	n_iter :=  $ maximal number of iterations thru nodes of intt
     142	    if intt notin proper_ints then 1 + 2 * #nodes
     143	    elseif intt = outint then 1 else 3 end;
     144
     145	(forall nd in nodes, v in cesors | nd /= v)
     146	    aux_f([nd, v]) := fom;
     147	end forall;
     148
     149	$ iterate through the nodes of intt.
     150	(forall d in [ 1..n_iter ])
     151	    convrgd := conv_control;
     152
     153	    $ iterate thrugh the nodes of intt in reverse interval
     154	    $ order.
     155	    (forall j in [ #nodes, #nodes-1..1 ])
     156		nd := nodes(j);
     157
     158		(forall v in cesors | v /= nd)
     159
     160		    $ since the 'successors' of the outermost interval
     161		    $ are nodes of that interval, we may have nd = v.
     162		    $ in this case it would be erroneouss to compute
     163		    $ aux_f([nd, v]) (which has already been set to
     164		    $ id) using the following 'propagation from
     165		    $ successors' formula, so we just skip such cases.
     166
     167		    ftemp := fom;
     168		    (forall snd in cessor{nd} |
     169				    intof(snd) = intt or snd = v)
     170			ftemp .meetjoin:=
     171			    (f([nd,snd]) .comp aux_f([snd,v]));
     172		    end forall;
     173
     174		    $ note that flow graph edges (virtual or real) are
     175		    $ either edges within an interval, linking two
     176		    $ nodes in the same interval, or edges going out
     177		    $ of an interval, or edges going into an interval
     178		    $ (these last edges are edges from (a target block
     179		    $ of) an interval to its head.  it is this third
     180		    $ kind of edge that we wish to avoid propagating
     181		    $ through in the above formula.
     182		    $ 'intof(snd) = intt' tests for internal edges
     183		    $ and 'snd = v' tests for outgoing edges whose
     184		    $ target is v.
     185
     186		    convrgd and:= (ftemp = aux_f([nd, v]));
     187		    aux_f([nd, v]) := ftemp;
     188		end forall;
     189	    end forall;
     190
     191	    if convrgd then quit forall d; end if;
     192	end forall;
     193	$ (note that no special handling of intt's head is required.)
     194
     195	$ except for the outermost interval, compute f([intt, v]),
     196	$ where v is a successor of some node in intt.
     197	if intt /= outint then
     198	    $ f([intt, v]) is trivially calculated in this case;  we
     199	    $ also remove the dummy aux_f([v, v]) entries.
     200	    (forall v in cesors)
     201		f([intt, v]) :=
     202			f([intt, head]) .comp aux_f([head, v]);
     203		aux_f([v, v]) := om;
     204	    end forall;
     205	end if;
     206    end forall;
     207
     208    f_p(p) := aux_f([head, rexit(p)]); $ head = rentry(p)
     209
     210    $ if p contains a stop block, calculate propogation effect to that
     211    $ block and combine it with 'normal' flow effect.
     212    if rstop(p) /= om then
     213	fzero := aux_f([head, rstop(p)]) .of zero;
     214	f_p(p) := f_p(p) .meetjoin [fzero, fzero];
     215	$ note that a constant function c is represented by [c, c]
     216
     217    end if;
     218
     219    $ remove artificial edges added earlier
     220    vedges{outint} := {};
     221
     222    return false;           $ to indicate no convergence
     223
     224    end procedure intraproc_back_eliminate;
     225
     226
       1 .=member axe13w
       2
       3
       4    procedure intra_aux_eliminate(p, f, aux_f, rw fexit);
       5$
       6$ this procedure performs an additional intraprocedural elimination,
       7$ during which we compute, for each node n in p, a map fexit(n) repre-
       8$ senting the effect of flow from the start of n up to an exit of p.
       9$
      10    repr
      11	$ data structures for formal parameters
      12	p:			routine;
      13	f:			remote smap(df_edge) df_map;
      14	aux_f:			remote smap(df_edge) df_map;
      15	fexit:			remote smap(df_node) df_map;
      16
      17	$ data structures for local variables
      18	p_ints:			tuple(df_node);
      19	outint:			df_node;
      20	ep:			df_node;
      21	sp:			df_node;
      22	outnodes:		tuple(df_node);
      23	nd:			df_node;
      24	i:			integer;
      25	fzero:			df_elmt;
      26	ftemp:			df_map;
      27	j:			integer;
      28	intt:			df_node;
      29	cesors:			sparse set(df_node);
      30	nodes:			tuple(df_node);
      31	k:			integer;
      32	v:			df_node;
      33    end repr;
      34
      35    p_ints := ints(p);
      36    outint := p_ints(#p_ints);
      37    ep := rexit(p);
      38    sp := rstop(p);
      39$
      40$ first process nodes of outint
      41$
      42    outnodes := int_nodes(outint);
      43
      44    (forall nd = outnodes(i))
      45
      46	fexit(nd) := aux_f([nd, ep]);  $ get the effect of flow to ep
      47
      48	if sp /= om then	$ if there is also a stop block
      49
      50	    fzero := aux_f([nd, sp]) .of zero;
      51	    ftemp := if fzero = xom then fom else [ fzero, fzero ] end;
      52	    fexit(nd) := fexit(nd) .meetjoin ftemp;
      53
      54	end if;
      55    end forall nd;
      56$
      57$ next process all remaining intervals in outer-to-inner order
      58$
      59    (forall j in [ #p_ints-1, #p_ints-2..1 ])
      60
      61	intt := p_ints(j);
      62	cesors := vedges{intt};
      63
      64	nodes := int_nodes(intt);
      65	(forall nd = nodes(k))
      66	    ftemp := fom;
      67	    (forall v in cesors)
      68		ftemp .meetjoin:= (aux_f([nd,v]) .comp fexit(v));
      69	    end forall;
      70	    fexit(nd) := ftemp;
      71	end forall nd;
      72    end forall j;
      73
      74
      75    end procedure intra_aux_eliminate;
      76
      77
       1 .=member xnf13x
       2
       3
       4    procedure exit_info(f, aux_f, fexit);
       5$
       6$ this function calculates and returns a mapping which sends
       7$ each procedure p into the flow information available at exit
       8$ from p.  it is called (only in the interprocedural case) just
       9$ before we begin the final outer-to-inner propagation phase.
      10$
      11    repr
      12	$ data structures for formal parameters
      13	f:			remote smap(df_edge) df_map;
      14	aux_f:			remote smap(df_edge) df_map;
      15	fexit:			remote smap(df_node) df_map;
      16
      17	$ data structures for local variables
      18	cgf:			smap( tuple(routine, routine) ) df_map;
      19	p, q:			routine;
      20	c, c1:			df_node;
      21	ex_inf:			remote smap(routine) df_elmt;
      22	cgrinv:			mmap(routine) routine;
      23	i:			integer;
      24	scc:			routine;
      25	scc_procs:		tuple(routine);
      26	n:			integer;
      27	convrgd:		boolean;
      28	k:			integer;
      29	temp:			df_elmt;
      30    end repr;
      31$
      32$ first we construct a map 'cgf' assigning, to each edge (p, q)  of  the
      33$ call graph, a data-propagation map describing the  propagation  effect
      34$ as control returns from the exit of q to p after any call in p  to  q,
      35$ and then advances to the exit of p.
      36$
      37    cgf := {};
      38    (forall [ p, q ] in cgraph) cgf([p,q]) := fom; end forall;
      39
      40    (forall q = callproc(c))	$ for all calls within all procedures
      41	p  := routof(c);	$ [p, q] is an edge of the call graph
      42	c1 := cessor(c);	$ c1 is the block following c
      43	cgf([p, q]) := cgf([p, q]) .meetjoin fexit(c1);
      44
      45	$ note that since we are dealing with a  backward  analysis,  we
      46	$ want to propagate data from the exit of the calling  procedure
      47	$ p to the exit of the called procedure q.   this  direction  of
      48	$ propagation, however, makes our problem a forward problem  for
      49	$ the call graph.
      50
      51    end forall;
      52$
      53$ next we iterate through the call graph  in  'invocation  order',  i.e.
      54$ process the strongly connected components in reverse postorder and the
      55$ set of procedures within each strongly connected components in reverse
      56$ postorder also.
      57$
      58    ex_inf := { [ p, xom ] : p in routs };	$ initialize solution
      59    ex_inf(sym_main) := zero;
      60    cgrinv := { [ p, q ] : [ q, p ] in cgraph };
      61
      62    $ pick strongly-connected components in reverse postorder
      63    (forall i in [ 2..#cg_sccs ])
      64
      65	$ note that we assume here that the main program  is  non-recur-
      66	$ sive, so that the first strongly-connected  component  of  the
      67	$ call graph consists of the main program only.   thus  we  need
      68	$ not process it, for the exit value  of  the  main  program  is
      69	$ already assumed known.
      70
      71	scc := cg_sccs(i);
      72	scc_procs := scc_nodes(scc);	$ procs in scc in rev. postorder
      73
      74	(forall n in [ 1..scc_d(scc)+1 ] )
      75	    convrgd := true;
      76	    (forall p = scc_procs(k))
      77		temp := xom;
      78		(forall q in cgrinv{p})
      79		    temp .mjv:= (cgf([q,p]) .of ex_inf(q));
      80		end forall;
      81
      82		$ test for convergence
      83		convrgd and:= (temp = ex_inf(p));
      84		ex_inf(p) := temp;
      85
      86	    end forall p;
      87
      88	    if convrgd then quit forall n; end if;
      89	end forall n;
      90    end forall i;
      91
      92    return ex_inf;
      93
      94    end procedure exit_info;
      95
      96
       1 .=member bpi13y
       2
       3
       4    procedure back_propagate_in(p, fexit, rw soln, ex_val);
       5$
       6$ this procedure performs outer-to-inner back propagation for
       7$ a routine p, using the 'fexit' information.  ex_val is the flow
       8$ information assumed (or known) at the procedure return block,
       9$ where 'zero' is always assumed at the stop block of p (but this
      10$ assumption has already been used in calculating the fexit maps).
      11$
      12    repr
      13	$ data structures for formal parameters
      14	p:			routine;
      15	fexit:			remote smap(df_node) df_map;
      16	soln:			remote smap(df_node) df_elmt;
      17	ex_val:			df_elmt;
      18
      19	$ data structures for local variables
      20	intt:			df_node;
      21	u:			df_node;
      22    end repr;
      23
      24    (forall intt in ints(p), u in int_nodes(intt))
      25	soln(u) := fexit(u) .of ex_val;
      26    end forall;
      27
      28    end procedure back_propagate_in;
      29
      30
      31
      32
      33    procedure intraproc_back_analysis(p, rw f, wr soln,
      34				id_prm, zero_prm, meet_flag_prm);
      35$
      36$ this is the master routine to perform a specific backward data flow
      37$ analysis intraprocedurally for a routine p whose local variables are
      38$ to be analyzed.  for more details, comments, and description of para-
      39$ meters see the corresponding interprocedural analyser.
      40$
      41    repr
      42	$ data structures for formal parameters
      43	p:			routine;
      44	f:			remote smap(df_edge) df_map;
      45	soln:			remote smap(df_node) df_elmt;
      46	id_prm:			df_map;
      47	zero_prm:		df_elmt;
      48	meet_flag_prm:		boolean;
      49
      50	$ data structures for local variables
      51	aux_f:			remote smap(df_edge) df_map;
      52	f_p:			remote smap(routine) df_map;
      54	fexit:			remote smap(df_node) df_map;
      55    end repr;
      56
      57    id        := id_prm;
      58    zero      := zero_prm;
      59    meet_flag := meet_flag_prm;
      60
      61    aux_f := {};   f_p := {};
      62
      63    intraproc_back_eliminate(p, aux_f, f, f_p, 'intra');
      65
      66    fexit := {};
      67    intra_aux_eliminate(p, f, aux_f, fexit);
      68
      69    soln := {};
      70    back_propagate_in(p, fexit, soln, zero);
      71$
      72$ note that in the intraprocedural case the last two procedures
      73$ can be combined to form a single procedure almost identical
      74$ with 'intra_aux_eliminate', except that this procedure computes the
      75$ 'soln' map directly instead of the 'fexit' maps.
      76$
      77    end procedure intraproc_back_analysis;
      78
      79
      80
      81$
      82$ here are the operators which manipulate the data propagation maps
      83$ and data states.
      84$
      85    op .comp(g, f);   $ functional composition g of f
      86
      87    if f = fom or g = fom then
      88	return fom;
      89    else
      90	return [ f(1) * g(1) + g(2), f(2) * g(1) + g(2) ];
      91    end if;
      92
      93    end op .comp;
      94
      95
      96    op .meetjoin(g, f);   $ functional meet or join
      97
      98    if     f = fom   then return g;
      99    elseif g = fom   then return f;
     100    elseif meet_flag then return [ f(1) * g(1), f(2) * g(2) ];
     101    else             return [ f(1) + g(1), f(2) + g(2) ];
     102    end if;
     103
     104    end op .meetjoin;
     105
     106
     107    op .mjv(x, y);   $ meet or join of lattice elements
     108
     109    if     x = xom   then return y;
     110    elseif y = xom   then return x;
     111    elseif meet_flag then return x * y;
     112    else             return x + y;
     113    end if;
     114
     115    end op .mjv;
     116
     117
     118    operator .of(f, x);   $ functional application
     119    return if x = xom or f = fom then xom
     120	else f(1)*x + f(2)
     121	end;
     122    end operator .of;
     123
     124
     125    drop
     126	.comp,
     127	interproc_fwd_analysis,
     128	intraproc_fwd_analysis,
     129	interproc_back_analysis,
     130	intraproc_back_analysis,
     131	fom,
     132	xom;
     133
     134
     135    end module setl_optimizer - dataflow_solver_ocrs;
     136
     137
       1 .=member tfnd14
       2$
       3$ this module determines the 'type' of every occurrence in the program.
       4$ its output is a map called 'typ' which sends each occurrence into a
       5$ tuple with the following fields:
       6$
       7$ 1. grosstyp
       8$
       9$    a set of strings indicating all possible 'real types' an
      10$    object might take on over different program paths.
      11$
      12$    the 'real type' of an occurrence is a string such as 'int'
      13$    or 'real' which we might get by applying the setl 'type'
      14$    operator to the occurence.  the possible real types are:
      15$    'int', 'real', 'string', 'atom', 'tuple', and 'set'.
      16$
      17$ 2. comptyp
      18$
      19$    this field contains recursive information on the component
      20$    types of sets and tuples.  it is interpreted in one of two
      21$    ways depending on the value of 'is_knt' (see below).
      22$
      23$    is_knt = true:	comptyp is a tuple whose i-th component is a
      24$			type descriptor for the i-th component type.
      25$
      26$    is_knt = false:	comptyp is a type descriptor for the component
      27$			type of the set or tuple.
      28$
      29$ 3. is_knt
      30$
      31$    a boolean predicate which is true for known-length tuples.
      32$
      33$ 4. is_om
      34$
      35$    this is a three valued field, indicating whether the object
      36$    is definitely omega, definitely not omega, or possibly omega.
      37$    the values of this field are given by the constants yes, no,
      38$    and maybe.
      39$
      40$    is_om is used as follows:
      41$
      42$    a. a set or tuple is considered to be null iff its component
      43$       type is definitely omega.
      44$
      45$    b. a tuple is considered to be a pair iff its first 2 components
      46$       are definitely not omega and its remaining components
      47$       definitely are.
      48$
      49$    c. a set can be stored as a map iff its elements are definitely
      50$       pairs.
      51$
      52$    the type finder exports three predicates for making the above
      53$    tests.  these predicates are called is_null, is_pair, and
      54$    is_map. like the is_om field they have values of yes, no, and
      55$    maybe.
      56$
      57$ at the end of the algorithm the type of each ovariable is defined by
      58$ the instruction which defines it, while the type of each ivariable
      59$ is a function of its use and the definitions and uses of all
      60$ occurrences it is linked to.
      61$
      62$ we may wind up with two occurrences 'o' and 'i' which are linked by
      63$ bfrom but have different types.  this means that the code generator
      64$ must insert a conversion along the path from 'o' to 'i'.  the type
      65$ fider checks whether such a conversion would be legal, and gives an
      66$ error message if it would not.
      67$
       1 .=member tla14a
       2
       3
       4$ the type lattice
       5$ -----------------
       6
       7$ the best way to understand the type finder is to think about
       8$ a simplified version in which type descriptors are pairs
       9$ [ grosstyp, comptyp ].  these simple type descriptors form a lattice
      10$ of information states, in which 'vagueness' increases towards the
      11$ top.
      12$
      13$ before studying the actual algorithm we will review a few things
      14$ about the lattice:
      15$
      16$ 1. the basic points on the lattice correspond to the standard types
      17$    such as int, real, and string.  the set of type descriptors with a
      18$    given grosstyp form a sublattice.  the lattice is essentially
      19$    infinite.  however, we can make the lattice finite by enforcing a
      20$    nesting limit on type descriptors, and by treating all known-length
      21$    tuples beyond a certain length as unknown length tuples.
      23$
      24$ 2. the basic types such as int and real are somewhere near the bottom
      25$    of the lattice.  'union' types are somewhere near the top.
      27$
      28$ 3. the lattice has a maximal type, called 'type_gen'.  this point
      29$    corresponds to the union of all types.  types belonging to this
      30$    grosstyp are always represented by a set containing all other
      31$    basic types.
      32$
      33$ 4. the lattice also has a minimal type, called 'type_zero'.
      34$    the significance of type_zero is different in different
      35$    parts of the algorithm.
      36$
      37$    at the end of the first or 'forward' pass an occurrence with
      38$    type_zero corresponds to a use of an uninitialized variable.
      39$    at the end of the second or 'backward' pass an occurrence
      40$    with type_zero corresponds to the result of an instruction
      41$    whose input types are incompatible.
      42$
      43$    note that type_zero does not correspond to omega.
      44$
      45$ 5. the 'conjunction'('and', 'intersection') of two lattice elements
      46$    is always a point lower in the lattice.  the 'disjunction'('or',
      47$    'union') is always a point higher on the lattice.
      48$
      49$ problems with the simplified type finder
      50$ ----------------------------------------
      51$
      52$ the type descriptors discussed above give relatively crude information
      53$ about the type of an occurrence.  there are several additional
      54$ attributes which one might consider part of a 'type'.  these include:
      56$
      57$ 1. whether an occurrence is definitely om, possibly om, or definitely
      58$    not om.  this information is useful since it allows us to distin-
      59$    guish between pairs and non-pairs, and thus between sets and maps.
      61$
      62$ 2. the range of values for integers.
      63$
      64$ (1) is extremely important:  we cannot do automatic data structure
      65$ selection without it.  (2) is less important, and is currently
      66$ ignored.
      67$
      68$ the extra attributes can be saved separately, i.e. as separate fields
      69$ of a type descriptor, or can be added as new points on the lattice.
      70$ at first the latter solution seemed to make the lattice too complex
      71$ to understand, but eventually was chosen because it is more elegant
      72$ and also simplifies the the algorithm.
      73$
      74$
      75$ basic algorithm
      76$ ---------------
      77$
      78$ the type finder consists of three passes, called the forward,
      79$ backward, and final passes.  the forward and backward passes do the
      80$ actual type determination using standard workpile propagation
      81$ algorithms.  the final phase does cleanup and error detection.
      82$
      83$ the forward pass starts by initializing the types of all ivariables
      84$ whose values are known.  it then calculates the type of every
      85$ ovariable as a function of its ivariables and the operation which
      86$ creates them. it calculates the type of ivariables i as the
      87$ disjunction of the types of all oi in bfrom{i}.
      88$
      89$ the second or backwards pass refines the information gathered by the
      90$ forward pass.  for example, if we have:
      94$
      95$ (1)	x := i + j;
      96$ (2)	t := [1, 2];
      97$ (3)	print(t(i));
      98$
      99$ then the forward pass will give us:
     100$
     101$    typ(x1) = typ(i1) = typ(j1) = int, real, string, tuple, or set.
     102$    typ(t2) = tuple
     103$    typ(t3) = tuple
     104$    typ(i3) = int, real, string, tuple, or set.
     105$
     106$ backwards analysis will tell us that if the program is correct then
     107$ typ(i3) and therefore typ(i1) must be integer.  furthermore, typ(x1)
     108$ and typ(j1) must be integer as well.
     109$
     110$ as another example,
     111$
     112$ (4)       read(a);
     113$ (5)       b := a + '1';
     114$
     115$ here forward analysis will tell us that typ(b5) is string, and
     116$ backward analysis will tell us that typ(a5) and therefore typ(a4) must
     117$ also be string.  clearly we must check the type of a somewhere between
     118$ between the time it is read and the time it is used.  the mechanism
     119$ for inserting this type test is as follows:
     121$
     122$ in the final version of the "types" map returned by the type finder,
     123$ the type of an ivariable will be its backward type, whereas the type
     124$ of an ovariable will be the type determined only by its forward
     125$ propagation of the final types of its ivariables.  (thus, e.g., read
     126$ ovariables will still have type general.)  thus a4 will receive a
     127$ type of general, and a5 will receive a type of string.  when name
     128$ splitting is performed, we will see that it is necessary to split a
     129$ into two separate variables, "a" with type general, and "a.1" with
     130$ type string.  we will then insert an assignment "a.1 := a" at some
     131$ optimal point between (4) and (5).
     133$
       1 .=member tmn14b
       2
       3
       4    module setl_optimizer - typfind;
       5
       6
       7    var vtyp,		$ maps variables to their given type
smff   1	work,		$ work pile for forward and backward propagation
smff   3	maxtype_sargs,	$ maps system routine arguments to their
smff   4			$  upper bounds.
       8	stck,		$ stack of occurrences in depth-first search
       9	npre,		$ preorder index in depth first search
      10	preorder,	$ preorder map in depth first search
      11	nstck,		$ length of stack
      12	place,		$ virtual place in stack of component roots
      13	nlev,		$ level number for ocuurrences in search
      14	occ_sccs,	$ tuple of strongly-connected comps
      15	occ_graph,	$ flow graph of occurrences
      16	oscc_nodes;	$ maps each s.c.c. to a tuple of its nodes
      17			$ in reverse postorder
      18
      19    const		$ various gross types
      20	grstup = { t_tuple },
      21	grsset = { t_set },
      22	grsmap = { t_map };
      23
      24
      25    repr
      26	vtyp:			sparse smap(symbol) elmt types;
smff   2	work:			set(tuple(string, general));
smff   5	maxtype_sargs:	sparse smap(symbol) tuple(elmt types);
      27	stck:			tuple(occurrence);
      28	npre:			integer;
      29	preorder:		remote smap(occurrence) integer;
      30	nstck:			integer;
      31	place:			remote smap(occurrence) integer;
      32	nlev:			remote smap(occurrence) integer;
      33	occ_sccs:		tuple(occurrence);
      34	occ_graph:		remote mmap(occurrence) occurrence;
      35	oscc_nodes:		smap(occurrence) tuple(occurrence);
      36	grstup, grsset, grsmap:	gross_type;
      37
      38	.con:			operator(elmt types, elmt types)
      39				    elmt types;
      40	.dis:			operator(elmt types, elmt types)
      41				    elmt types;
      42	.sub:			operator(elmt types, elmt types)
      43				    elmt types;
      44
      45	type_forward:		procedure;
      46	type_backward:		procedure;
      47	type_final:		procedure;
      48
      49	forward:		procedure(occurrence) elmt types;
      50	backward:		procedure(elmt insts)
      51				    tuple(elmt types);
      52	type_constant:		procedure(elmt insts) string;
smfe  28
smfe  29	string_length:		procedure(elmt types) integer;
smfd   3	constant_equality:	procedure(elmt types, elmt types)
smfd   4				    boolean;
      53
      54	given_type:		procedure(elmt forms) elmt types;
      55	dfs:			procedure(occurrence);
      56	const_typ:		procedure(general) elmt types;
      57	ntyp:			procedure(
      58				  gross_type,
      59				  elmt types    )
      60				    elmt types;
      61	knt_type:		procedure( tuple(elmt types) )
      62				    elmt types;
      64	pair_type:		procedure(elmt types, elmt types)
      65				    elmt types;
      66	trim:			procedure(elmt types, integer)
      67				    elmt types;
      68	norm:			procedure(elmt types);
      69	ads_type:		procedure(elmt types) elmt types;
      70    end repr;
      71
      72
      73    procedure type_find;
      74$
      75$ this is the main routine of the type finder. it initializes various
      76$ tables then calls the individual passes of the type finder.
      78$
      79    repr
smfg  86	r:			routine;
smfg  87	b:			elmt blocks;
smfg  88	i1, i2:			elmt insts;
smfg  89	oi, vox, voy:		occurrence;
smfg  90	tp:			elmt types;
      83    end repr;
      84
      85    title('cims.setl.' + prog_level + ' - type finder');
      86    printa(term_file, '   - type finder');
      87
      90    $ initialize output object
      91    typ := {};
      92
      93    $ initialize maps global to the module
smff   6    vtyp := {};     work := {};     maxtype_sargs := {};
      95
      96    type_forward;		$ forward analysis
      97$$++
smfc 607    if 't' in dump_string and 'z' in dump_string then
      99	print;
     100	print('variable     occurrence   forward type');
     101	print('--------------------------------------');
     102	prints('',
     103	    [ [ rpad(oi_name(oi),12) + ' ' + rpad(oi_str(oi),12),
     104		format_type(tp) ] : tp = typ(oi)	] );
     105    end if;
     106$$--
     107    type_backward;		$ backward analysis
     108$$++
smfc 608    if 't' in dump_string and 'z' in dump_string then
     110	print;
     111	print('variable     occurrence   backward/forward type');
     112	print('-----------------------------------------------');
     113	prints('',
     114	    [ [ rpad(oi_name(oi),12) + ' ' + rpad(oi_str(oi),12),
     115		format_type(tp) ] : tp = typ(oi)	] );
     116    end if;
     117$$--
     118    type_final;			$ check for type errors and finalize
     119				$ the type of all o-variables.
     120$$++
smfc 609    if 't' in dump_string and 'z' in dump_string then
     122	print;
     123	print('variable     occurrence   final type');
     124	print('------------------------------------');
     125	prints('',
     126	    [ [ rpad(oi_name(oi),12) + ' ' + rpad(oi_str(oi),12),
     127		format_type(tp) ] : tp = typ(oi)	] );
     128    end if;
     129$$--
smfg  91
smfg  92    (forall r in routs)
smfg  93     (for_block(b, r))
smfg  94      i1 := om;
smfg  95      (for_inst(i2, b))
smfg  96	if opcode(i2) = q1_isom or opcode(i2) = q1_notom then
smfg  97	    vox := get_oi(i2, 1);
smfg  98	    (forall voy in bfrom{vox})
smfg  99		ffrom less:= [ voy, vox ];
smfg 100		(forall oi in ffrom{vox})
smfg 101		    bfrom less:= [ oi, vox ];
smfg 102		    bfrom with:= [ oi, voy ]; ffrom with:= [ voy, oi ];
smfg 103		end forall;
smfg 104		if vox in bfrom_dead then bfrom_dead with:= voy; end if;
smfg 105	    end forall;
smfg 106	    bfrom lessf:= vox; ffrom lessf:= vox; bfrom_dead less:= vox;
smfg 107	    typ lessf:= vox;
smfg 108	    del_inst(i2, i1, b);
smfg 109	end if;
smfg 110	i1 := i2;
smfg 111      end;	$ end for_inst;
smfg 112     end;	$ end for_block;
smfg 113    end forall;
     130
     131    (forall tp = typ(oi))
     132	typ(oi) := ads_type(tp);
     133    end forall;
     134
     135
     136    $ delete the static variables global to the module
smff   7    vtyp := om;     work := om;     maxtype_sargs := om;
     138
     139    if 't' in dump_string then
     142	print;
     143	print('variable     occurrence   type');
     144	print('------------------------------');
     145	prints('',
     146	    [ [ rpad(oi_name(oi),12) + ' ' + rpad(oi_str(oi),12),
     147		format_type(tp) ] : tp = typ(oi)	] );
     152    end if;
     153
     154    statistics with:= time;	$ save time for final statistics
     159
     160
     161    end procedure type_find;
     162
     163
       1 .=member tyf14c
       2
       3
       4    procedure type_forward;
       5$
       6$ this is the first, or forward propagation phase of the type finder.
       7$ it consists of two sections.  the first section initializes the work
       8$ pile, and the second propagates types forward through the program
       9$ until the work pile is empty.
      10$
      11$ work pile initialization
      12$ ------------------------
      13$
      14$ the work pile is a set of pairs [ act, oi ] where oi is an occurrence
      15$ whose type is to be calculated, and act is the method of calculating
      16$ oi's type.
      17$
      18$ 1. 'fwd':
      19$
      20$    here oi is an ovariable, and we calculate its type as a function
      21$    of the type of the inputs to the instruction which defines it.
      23$
      24$ 2. 'bfrm'
      25$
      26$    here oi is an ivariable, and we calculate its type as the
      27$    disjunction of all i in bfrom{oi}.
      28$
      29$
      30$ we initialize the workpile by iterating over all occurrences looking
      31$ for three cases:
      32$
      33$ 1. constant ivariables. here we simply set the type of the ivariable.
      34$
      35$ 2. ovariables whose type is uniquely determined by its opcode.  for
      36$    example, if we have 't := # s' then t must be an integer.  in this
      37$    case we set the type of t and make workpile entries of the form
      38$    ['bfrm', i], i in ffrom{t}.
      39$
      40$ 3. ovariables which have at least one constant ivariable.  here we add
      41$    ['fwd', o] to the workpile.
      42$
      43$ the type finder can also take into account user-supplied reprs.  they
      44$ are used as upper bounds for actual computed types.  therefore only
      45$ this forward typefinding phase (in which computed types 'grow' in
      46$ their lattice) and the final type propagation phase need manipulate
      47$ these given types;  the backward propagation phase ignores these
      48$ types, as it only tries to make types smaller in their lattice.
      50$
      51$ we prepare for the handling of these types by computing a map 'vtyp',
      52$ mapping each progam variable to its given type.  this type is computed
      53$ from the form of the variable by the recursive function 'given_type',
      54$ in which some data-form details may be lost.
      56$
smfe  30    init
smfe  31	back_count := 0,$ counts the number of times backward is called.
smfe  32	maxtype := {};	$ maps opcodes to the upper bound for its
smfe  33			$  operand types.
      57    repr
      58	sc:			elmt base_scopes;
      59	v:			symbol;
      60	occ_roots:		sparse set(occurrence);
      61	r:			routine;
      62	b:			elmt blocks;
      63	i:			elmt insts;
      64	opc:			elmt base_opcodes;
      65	iva1:			integer;
      66	var_ivars:		set(occurrence);
      67	j:			integer;
      68	fm:			elmt forms;
      69	voj, vo1:		occurrence;
      70	nam:			symbol;
      71	t:			elmt types;
      72	e, oscc:		occurrence;
      73	fwd_count:		integer;
      74	bfrm_count:		integer;
smfe  34	back_count:		integer;
      75	x:			occurrence;
      76	onodes:			tuple(occurrence);
      77	newoccs:		remote set(occurrence);
      78	convrgd:		boolean;
      79	vo, oi:			occurrence;
      80	newtype, tp:		elmt types;
smfe  35	maxtype:		remote smap(elmt base_opcodes)
smfe  36				    tuple(elmt types);
smfe  37	newtypes:		tuple(elmt types);
smfe  38	k:			integer;
      81    end repr;
      82
      83    (forall sc in scopes)
      84	(for_sym(v, sc))
      85	    vtyp(v) := given_type(form(v));
      86	end;
      87    end forall;
smff   8    (forall v in system_routs)
smff   9	$ redefine the return value type for system routines that cannot
smff  10	$ return omega.
smff  11	vtyp(rretn(v)) :=
smff  12	    case name(v) of
smff  13	      ('open'):     type_boolean,
smff  14	      ('eof'):      type_boolean,
smff  15	      ('getipp'):   type_int,
smff  16	      ('getspp'):   type_string,
smff  17	      ('lpad'):     type_string,
smff  18	      ('rpad'):     type_string
smff  19	      else          vtyp(rretn(v))
smff  20	    end;
smff  21	$ redefine the argument types for system routines that cannot be
smff  22	$ omega.
smff  23	maxtype_sargs(v) :=
smff  24	    case name(v) of
smff  25	      ('read'):     [ type_gen ],
smff  26	      ('print'):    [ type_gen ],
smff  27	      ('reada'):    [ type_string, type_gen ],
smff  28	      ('printa'):   [ type_string, type_gen ],
smff  29	      ('get'):      [ type_string, type_gen ],
smff  30	      ('getb'):     [ type_string, type_gen ],
smff  31	      ('putb'):     [ type_string, type_gen ],
smff  32	      ('getk'):     [ type_string, type_gen ],
smff  33	      ('putk'):     [ type_string, type_gen ]
smff  34	      else          [ type_notom : j in [ 1..rnargs(v) ] ]
smff  35	    end;
smff  36    end forall;
      88$
      89$ initialize the work pile and build the occurrence flow graph
      90$
      91    if 'e' in dump_string then
      92	print('forward propagation');
      93    end if;
      94
      95    occ_graph := ffrom;
      96    occ_roots := {};
      97    (forall r in routs)
      98     (for_block(b, r))
      99      (for_inst(i, b))
     100	opc := opcode(i);
     101	iva1 := first_ivar(opc);
smfe  39	if opc in ops_typeback and opc /= q1_sargin then
smfe  40	    if opc = q1_set or opc = q1_tup then
smfe  41		if maxtype(opc) = om or #maxtype(opc) < #args(i)-1 then
smfe  42		    maxtype(opc) :=
smfe  43			[ type_notom : j in [ iva1..#args(i) ] ];
smfe  44		end if;
smfe  45	    elseif maxtype(opc) = om then
smfe  46		(forall j in [ 1..#args(i) ])
smfe  47		    typ(get_oi(i, j)) := type_gen;
smfe  48		end forall;
smfe  49		maxtype(opc) := backward(i); back_count +:= 1;
smfe  50	    end if;
smfe  51	end if;
     102	var_ivars := {};
     103	(forall j in [ iva1..#args(i) ])
     104	    voj := get_oi(i, j);
     105	    nam := oi_sym(voj);
     106	    if nam notin variables then
     107		if ft_type(form(nam)) /= f_proc and
     108			ft_type(form(nam)) /= f_lab then
     109		    typ(voj) := const_typ(value(nam));
     110		else
     111		    typ(voj) := type_zero;
     112		end if;
     113	    else
     114		typ(voj) := type_zero;
     115		var_ivars with:= voj;
     116	    end if;
     117	end forall;
     118	if opc in ops_ovar then
     119	    vo1 := get_oi(i, 1);	$ the o-variable
     120	    if (t := fixed_typ(opc)) /= om then
     121		typ(vo1) := t .con vtyp(oi_sym(vo1));
     122		occ_roots with:= vo1;
     123	    elseif var_ivars = {} then
     124		typ(vo1) := forward(vo1) .con vtyp(oi_sym(vo1));
     125		occ_roots with:= vo1;
     126	    else
     127		typ(vo1) := type_zero;
     128		occ_graph +:= { [ voj, vo1 ] : voj in var_ivars };
     129	    end if;
     130	end if;
     131      end;
     132     end;
     133    end forall;
     134$
     135$ build depth-first spanning tree for the occurrence flow graph
     136$
     137    occ_sccs := [];   $ strongly connected comp's of occurrence graph
     138    oscc_nodes := {}; $ nodes of each strongly connected component
     139    $ initialize auxiliary variables
     140    stck := [];       nstck := 0;       place := {};
     141    preorder := {};   npre := 0;        nlev := {};
     142
     143    (forall e in occ_roots) dfs(e); end forall;
     144
     145    $ release storage for garbage collection
     146    stck := om;       place := om;
     147    nlev := om;       preorder := om;
     148$
     149$ actual forward propagation
     150$
     151    fwd_count := bfrm_count := 0;
     152    newoccs := {} +/[ occ_graph{x} : x in occ_roots ];
     153    (forall j in [ #occ_sccs, #occ_sccs-1..1 ])
     154	oscc := occ_sccs(j);
     155	onodes := oscc_nodes(oscc);
     156	(until convrgd)
     157	    convrgd := true;  $ flag indicating convergence in oscc
     158	    (forall vo in onodes | vo in newoccs)
     159		convrgd := false;
     160		newoccs less:= vo;
     161		if is_ovar(vo) then
     162		    fwd_count +:= 1;
     163		    newtype := forward(vo) .con vtyp(oi_sym(vo));
     164		elseif is_ivar(vo) then
     165		    bfrm_count +:= 1;
     166		    newtype := type_zero .dis/
smfe  52				    [ typ(vo1) : vo1 in bfrom{vo} ];
smfe  53		    if maxtype(oi_op(vo)) /= om then
smfe  54			k := argno(vo) - first_ivar(oi_op(vo)) + 1;
smff   5			tp := newtype .con maxtype(oi_op(vo))(k);
smff   6			if tp /= newtype then
smff   7			    $ record ffrom propagation for next phase.
smff   8			    $ note that the required bfrom propagation
smff   9			    $ will be done during this phase in the
smff  10			    $ workpile implicit in the o.s.c.c. graph.
smff  11			    work +:= { [ 'ffrm', oi ] :
smff  12					    oi in bfrom{vo} |
smff  13						oi notin bfrom_dead };
smff  14			end if;
smff  15			newtype := tp;
smfe  56		    end if;
     168		else
     169		    continue forall;
     170		end if;
     171		if newtype /= typ(vo) then
     172		    typ(vo) := newtype;
     173		    newoccs +:= occ_graph{vo};
     174		end if;
     175	    end forall;
     176	end until;
     177    end forall;
     178
     179    $ release storage for garbage collection
     180    occ_sccs := om;   occ_graph := om;  oscc_nodes := om;
smfe  57
smfe  58    if 't' in dump_string and 'z' in dump_string then
smfe  59	(forall newtypes = maxtype(opc))
smfe  60	    print(opc);
smfe  61	    (forall tp in newtypes) print('    ', format_type(tp)); end;
smfe  62	end forall;
smfe  63    end if;
     181
     182    if 'e' in dump_string then
     183	print(fwd_count,  'forward propagations');
smfe  64	print(back_count, 'backward propagations');
     184	print(bfrm_count, 'bfrom propagations');
     185    end if;
     186
     187
     188    end procedure type_forward;
     189
     190
     191
     192
     193    procedure given_type(fm);
     194$
     195$ compute a type (lattice point) from a given form.  see section
     196$ 'forms' above for description of data forms.
     197$
     198    repr
     199	fm:			elmt forms;
     200	ftp:			elmt base_ft_types;
     201	fsimtp:			string;
     202	tp, ctp:		elmt types;
     203	fm1:			elmt forms;
     204    end repr;
     205
     206    ftp := ft_type(fm);
     207    fsimtp := simple_type(ftp);
     208
     209    case fsimtp of
     210
     211    ('gen'):	tp := type_gen;
     212    ('int'):	tp := type_int;
     213    ('real'):	tp := type_real;
     214    ('string'):	tp := type_string;
     215    ('atom'):	tp := type_atom;
     216    ('elmt'):	tp := given_type(ft_elmt(ft_base(fm)));
     217    ('set'):	tp := ntyp(grsset, given_type(ft_elmt(fm)));
     218
     219    ('map'):	ctp := given_type(ft_elmt(fm)) .con type_pair;
     220		tp  := ntyp(grsset, ctp .dis type_om);
     221
     222    ('tuple'):
     223	if ftp = f_mtuple then
     224	    tp := knt_type([ given_type(fm1) : fm1 in ft_elmt(fm) ]);
     225	else
     226	    tp := ntyp(grstup, given_type(ft_elmt(fm)));
     227	end if;
     228
     229    else
     230	tp := type_zero;
     231    end case;
     232
     233    return tp .dis type_om;
     234
     235
     236    end procedure given_type;
     237
     238
     239
     240
     241    procedure dfs(x);
     242
     243
     244    repr
     245	x, y, z:		occurrence;
     246	i:			integer;
     247    end repr;
     248
     249
     250    preorder(x) := nlev(x) := (npre +:= 1);
     251    place(x) := nstck;
     252    (forall y in occ_graph{x})
     253	if nlev(y) = om then
     254	    dfs(y);
     255	    if nlev(y) /= -1 then
     256		nstck +:= 1;
     257		stck(nstck) := y;
     258	    end if;
     259	end if;
     260	if nlev(y) /= -1 then
     261	    nlev(x) := nlev(x) min nlev(y);
     262	end if;
     263    end forall;
     264    if nlev(x) = preorder(x) then $ root of a strongly connected comp
     265	occ_sccs with:= x;
     266	oscc_nodes(x) := [ x ];
     267	(forall i in [ nstck, nstck-1..place(x)+1 ])
     268	    z := stck(i);
     269	    oscc_nodes(x) with:= z;
     270	    nlev(z) := -1;
     271	end forall;
     272	nstck := place(x);
     273	nlev(x) := -1;
     274    end if;
     275
     276    end procedure dfs;
     277
     278
       1 .=member tyb14d
       2
       3
       4    procedure type_backward;
       5$
       6$ this is the second, or backwards phase of the type finder.  it
       7$ propagates the type of each ivariable backwards towards its
       8$ definition.
       9$
      10$ as usual, the routine has two sections.  the first initializes the
      11$ work pile, and the second iterates until it is empty.
      12$
      13    repr
      15	r:			routine;
      16	b:			elmt blocks;
      17	inst:			elmt insts;
      18	opc:			elmt base_opcodes;
      19	fwd_count:		integer;
      20	back_count:		integer;
      21	bfrm_count:		integer;
      22	ffrm_count:		integer;
      23	key:			string;
      24	targ:			general;
      25	oi:			occurrence;
      26	newtype:		elmt types;
      27	i:			occurrence;
      28	newtypes:		tuple(elmt types);
      29	j, j1:			integer;
      30	tp:			elmt types;
      31    end repr;
      32$
      33$ work pile initialisation
      34$ ---- ---- --------------
      35$
      36$ the work pile once again consists of pairs [ key, targ ].  we
      37$ initialize the work pile to force backwards propagation of all
      38$ relevant ivariables.
      39$
      40    if 'e' in dump_string then
      41	print;
      42	print('backward propagation');
      43    end if;
      44
      46    (forall r in routs) (for_block(b, r)) (for_inst(inst, b))
      47	if opcode(inst) in ops_typeback then
      48	    work with:= [ 'back', inst ];
      49	end if;
      50    end; end; end;
      51$
      52$ propagation
      53$ -----------
      54$
      55$ in this phase we propagate types in four directions:
      56$
      57$ 1. 'fwd':
      58$
      59$    here we determine the type of an ovariable from those of its
      60$    ivariables.  this uses the same method as employed in type_forward.
      62$
      63$ 2. 'back':
      64$
      65$    this calculates the types of the ivariables of an instruction
      66$    as a function of the types of the other arguments in the same
      67$    instruction.
      68$
      69$ 3. 'bfrm':
      70$
      71$    this corresponds to the 'bfrm' action in type_forward.
      72$
      73$ 4. 'ffrm':
      74$
      75$    this calculates the type of an occurrence oi as the conjunction of
smfh  21$    the types of all i in ffrom, provided, however, that no program
      77$    exit can be reached from oi along a path clear of other occurrences
      78$    of the variable of oi.
      79$
      80    fwd_count := back_count := 0;
      81    bfrm_count := ffrm_count := 0;
      82
      83    (while work /= {})
      84	[ key, targ ] from work;
      85
      86	case key of
      87
      88	('fwd'):	$ forward propagation
      89	    fwd_count +:= 1;
      90	    oi := targ;
      91	    newtype := forward(oi) .con typ(oi);
      92	    if newtype = typ(oi) then continue; end if;
      93	    work +:= { [ 'bfrm', i ]: i in ffrom{oi} };
      94
      95	    $ if this was not a unary operation, propagate back
      96	    $ to the remaining i-variables
      97	    if (opc := oi_op(oi)) notin ops_un and
      98		opc in ops_typeback and
      99		opc notin {q1_asn, q1_argin, q1_argout} then
     100		    work with:= [ 'back', instno(oi) ];
     101	    end if;
     102
     103	    typ(oi) := newtype;
     104
     105	('bfrm'):	$ propagate along bfrom
     106	    bfrm_count +:= 1;
     107	    oi := targ;
     108	    newtype := (type_zero .dis/[ typ(i) : i in bfrom{oi} ])
     109			    .con typ(oi);
     110	    if newtype = typ(oi) then continue; end if;
     111
     112	    work +:= { [ 'bfrm', i ] : i in ffrom{oi} };
     113	    if oi_op(oi) in ops_ovar then
     114		work with:= [ 'fwd', get_ovar(oi) ];
     115	    end if;
     116
     117	    typ(oi) := newtype;
     118
     119	('ffrm'):	$ propagate along ffrom
     120	    ffrm_count +:= 1;
     121	    oi := targ;
     122	    newtype := (type_zero .dis/[ typ(i) : i in ffrom{oi} ])
     123			    .con typ(oi);
     124	    if newtype = typ(oi) then continue; end if;
     125
     126	    if is_ovar(oi) then
     127		if oi_op(oi) in ops_typeback then
     128		    work with:= [ 'back', instno(oi) ];
     129		end if;
     130	    else
     131		work +:= { [ 'ffrm', i ] :
     132			    i in bfrom{oi} | i notin bfrom_dead };
     133		if oi_op(oi) in ops_ovar then
     134		    work with:= [ 'fwd', get_ovar(oi) ];
     135		end if;
     136	    end if;
     137
     138	    typ(oi) := newtype;
     139
     140	('back'):	$ analogous to the 'fwd' case
     141	    back_count +:= 1;
     142	    inst := targ;
     143	    newtypes := backward(inst);
     144
     145	    j1 := first_ivar(opcode(inst));
     146	    (forall j in [ j1..#args(inst) ])
     147		oi := get_oi(inst, j);
     148		newtype := newtypes(j-j1+1) .con typ(oi);
     149		if newtype = typ(oi) then continue forall; end if;
     150
     151		work +:= { [ 'bfrm', i ] : i in ffrom{oi} };
     152		work +:= { [ 'ffrm', i ] : i in bfrom{oi} |
     153						i notin bfrom_dead };
     154
     155		typ(oi) := newtype;
     156	    end forall;
     157
     158
     159	end case;
     160
     161    end while;
     162
     163    if 'e' in dump_string then
     164	print(fwd_count,  'forward propagations');
     165	print(back_count, 'backward propagations');
     166	print(bfrm_count, 'bfrom propagations');
     167	print(ffrm_count, 'ffrom propagations');
     168    end if;
     169
     170
     171    end procedure type_backward;
     172
     173
       1 .=member tfn14e
       2
       3
       4    procedure type_final;
       5$
       6$ this is the final phase of the type finder.  here  we  re-compute  the
       7$ type of each ovariable, from the types of its ivariables, so  that  we
       8$ can detect precisely when a type check is necessary  and  when  it  is
       9$ redundant, as explained above.
      10$
      11$ we also check for type errors.  they can be one of the following:
      12$
      13$ 1. an occurence having a type type_zero.   in  this  case,  for  every
      14$    possible execution of the program,  this  occurence  will  have  an
      15$    error value (or the program will  abort).   this  is  therefore  an
      16$    error.
      17$
      18$ 2. two occurences, linked by the bfrom  map  and  having  incompatible
      19$    types, though none of them has  the  type  type_zero.   this  means
      20$    that there might be an execution  flow,  along  which  one  of  the
      21$    occurences will get an error value, but this need not be  the  case
      22$    for every execution.  consider the following example:
      23$
      24$    (1)     a := [ 1, 2 ];
      25$    (2)     if cond1 then a := 1; end if;
      26$    (3)     if cond2 then x := a(1); end if;
      27$
      28$    here, after re-computation of the type of ovariables, a2 will  have
      29$    type integer, while a3 will have type tuple.  it may indeed be  the
      30$    case that cond1 and cond2 can  never  be  true  simultaneously,  in
      31$    which case the program will never abort.   if,  however,  the  link
      32$    a2 to a3 is ever materialized, we shall have an  error.   thus,  in
      33$    this case, the optimizer should  issue  a  warning,  but  non-fatal
      34$    message.
      35$
      36$ begin by re-computing the types of all ovariables.
      37$ note, however, that in operations like 's := {};' or 't := [];'
      38$ we still want to retain the backward type of s to some extent.
      39$ for example:
      40$               (1)   s := {};
      41$                       ...
      42$               (2)   s with:= int;
      43$ in this case we prefer to have typ(s at 1) = set(int) rather than
      44$ set(general), which will force an unnecessary conversion/check
      45$ between (1) and (2).
      46$
smfi  71    init
smfi  72	errblk := {},	$ blocks with type_zero message.
smfi  73	errstmt := {},	$ statements with type_zero message.
smfk  45	errvars := {},	$ variables with type_zero message.
smfk  46	newstmt := false, newblk := false;
      47    repr
smfi  75	r:			routine;
smfi  76	b:			elmt blocks;
smfi  77	i:			elmt insts;
smfi  78	v:			symbol;
smfi  79	errblk:			set(elmt blocks);
smfi  80	errstmt:		set(integer);
smfi  81	errvars:		set(symbol);
smfk  47	newstmt, newblk:	boolean;
smfi  82	k:			integer 0..65536;
smfi  83
smfi  84	o, oi:			occurrence;
      50	newtype:		elmt types;
smfe  65	tp, t1, t2:		elmt types;
      56
      57	workoccs, seenoccs:	set(occurrence);
smfk  48	precoccs, reloccs:	set(occurrence);
smfk  49	tp_stmts:		mmap{elmt types} set(string);
smfi  85	relstmts:		set(string);
      61	vox, voy, vo1, vo2:	occurrence;
      62	ivs:			tuple(occurrence);
      66	message:		tuple(string);
smfi  86	text, tail:		string;
      68	j:			integer 0..65536;
      69	l:			string;
      70    end repr;
      71
      72$$--(forall o in all_o)
smfi  87    (forall r in routs) (for_block(b, r)) (for_inst(i, b))
smfi  88	if opcode(i) notin ops_ovar then continue; end if;
smfi  89	o := get_oi(i, 1);  $ get the output occurrence
smfi  90	if opcode(i) = q1_asn or opcode(i) = q1_argin then
smfi  91	    v := args(i)(2);
smfi  92	    if is_const(v) = 1 and value(v) = {} then
      77		newtype :=
smfi  93		    (type_zero .dis/[ typ(oi) : oi in ffrom{o} ])
      79			.con type_set;
      80		if newtype /= type_zero then typ(o) := newtype; end if;
smfi  94		continue;
      82
smfi  95	    elseif is_const(v) = 1 and value(v) = [] then
      84		newtype :=
smfi  96		    (type_zero .dis/[ typ(oi) : oi in ffrom{o} ])
      86			.con type_tuple;
      87		if newtype /= type_zero then typ(o) := newtype; end if;
smfi  97		continue;
      89
smfi  98	    elseif v = sym_om then
smfi  99		newtype := type_om .dis/[ typ(oi) : oi in ffrom{o} ];
      92		typ(o) := newtype;
smfi 100		continue;
      94	    end if;
      95	end if;
smfi 101	typ(o) := (fixed_typ(opcode(i)) ? forward(o))
smfi 102			.con vtyp(args(i)(1));
smfi 103    end; end; end forall;
      99
     100    if not debug_flag then return; end if;
     101
smfi 104    (forall r in routs)
smfk  50     (for_block(b, r)) newblk := true;
smfk  51      (for_inst(i, b)) if opcode(i) = q1_stmt then newstmt := true; end;
smfk  52       (forall k in [ 1..#args(i) ])
smfi 108	if (v := args(i)(k)) notin variables then continue forall; end;
smfk  53	if newstmt and newblk then
smfk  54	    errvars := {}; newstmt := false; newblk := false;
smfk  55	end if;
smfi 109	vox := get_oi(i, k);
     103
     104	if typ(vox) = type_zero then
     105
     106	    $ some serious problem: the type finder could not deduce any
     107	    $ type for this occurrence.
     108
smfk  56	    if opcode(i) = q1_isom or opcode(i) = q1_notom then
smfk  57		$ the occurrence will either have been added to errvars
smfk  58		$ in the preceding q1_if, ..., or this block consists
smfk  59		$ exactly this instruction.  in either case we do not
smfk  60		$ want to generate an additional message.
smfk  61		continue forall;
smfk  62	    end if;
smfk  63
smfk  64	    if opcode(i) = q1_free then
smfk  65		$ either the corresponding q1_argin occurrence has
smfk  66		$ type_zero as well, or the invoked routine cannot
smfk  67		$ be completed.  in either case, we prefer to
smfk  68		$ suppress the error message.
smfk  69		errvars with:= oi_sym(vox);
     111		continue forall;
     112	    end if;
     113
     114	    if is_ovar(vox) then
smfi 120		ivs := [ vo1 in occs(i)(2..) |
smfk  70				typ(vo1) = type_zero
smfk  71				    and oi_sym(vo1) notin routs
smfk  72				or typ(vo1) = type_om ];
smfi 123		if ivs = [] then ivs := occs(i)(2..); end if;
     118	    else
     119		ivs := [ vox ];
     120	    end if;
     121
     122	    if exists vo1 in ivs |
smfi 124			    typ(vo1) = type_zero
smfk  73			    and oi_sym(vo1) in errvars
smfk  74			    and ( blockof(i) in errblk
smfk  75				  or stmtof(i) in errstmt ) then
smfi 128		(forall vo1 in ivs) errvars with:= oi_sym(vo1); end;
smfi 129		errvars with:= oi_sym(vox);
     127		continue forall;
     128	    end if;
smfk  76
smfk  77	    if opcode(i) in ops_iter then
smfk  78		if is_ivar(vox) and
smfk  79			opcode(i) = q1_inext or opcode(i) = q1_inextd
smfk  80		then
smfk  81		    t1 := type_zero
smfk  82				.dis/[ typ(vo1) : vo1 in bfrom{vox} ];
smfk  83		    messages{stmtof(i)}{'e'} with:=
smfk  84			[ 'illegal iteration:  "' + name(v) + '" '
smfk  85			  + case t1 of
smfk  86			    (type_zero):    'cannot be evaluated.',
smfk  87			    (type_om):      'is undefined.'
smfk  88			    else    'is ' + format_type(t1) + '.'
smfk  89			    end
smfk  90			];
smfk  91		end if;
smfk  92		errblk with:= blockof(i); errstmt with:= stmtof(i);
smfk  93		errvars with:= oi_sym(vox);
smfk  94		continue forall;
smfk  95	    end if;
     129
     130	    message := [ if is_ovar(vox) then
     131			    'the evaluation of '
smfi 130			    '"' + format_inst(i, om) + '"'
     133			else
smfi 131			    'the use of "' + name(v) + '"'
     135			end +
     136			' will always cause an execution error:' ];
     137
     138	    (forall voy = ivs(j))
     139
     140		if typ(voy) = type_zero then
     141
     142		    $ either none of the definitions preceding this
     143		    $ occurrence could be evaluated, or this occurrence
     144		    $ is part of a set of occurrences which, taken
     145		    $ together, form a set of inconsistent uses.
     146
     147		    workoccs := { voy };$ workpile of prec. occurrences
     148		    seenoccs := {};	$ occurrences already seen
     149		    reloccs  := { voy };$ relevant occurrences
smfk  96		    precoccs := {};	$ prec. non-error occurrences
     150
     151		    (while workoccs /= {})
     152			vo1 from workoccs; seenoccs with:= vo1;
smfk  97			(forall vo2 in bfrom{vo1})
smfk  98			    if typ(vo2) = type_zero
smfk  99				    or typ(vo2) = type_om then
smfk 100				reloccs with:= vo2;
smfk 101				if vo2 notin seenoccs then
smfk 102				    workoccs with:= vo2;
smfk 103				end if;
smfk 104			    else
smfk 105				precoccs with:= vo2;
smfk 106			    end if;
smfk 107			end forall;
     161		    end while;
     162
smfi 134		    workoccs := { vo1 in reloccs | is_ovar(vo1)
smfi 135					and typ(vo1) = type_zero };
smfi 136		    relstmts := { oi_stmt(vo1) : vo1 in workoccs };
smfi 137
smfi 138		    if #relstmts = 0 then
smfi 139			text := om;
smfi 140		    else
smfi 141			text := '"' + oi_name(voy) + '"'
smfi 142				' cannot be evaluated at ';
smfi 143			tail from relstmts;
smfi 144
smfi 145			if #relstmts = 0 then
smfi 146			    text +:= tail;
smfi 147			elseif #relstmts = 1 then
smfi 148			    text +:= arb relstmts + ' and ' + tail;
smfi 149			else
smfi 150			    text := text +/[ l + ', ' : l in relstmts ];
smfi 151			    text +:= 'and ' + tail;
smfi 152			end if;
smfi 153		    end if;
smfi 154
smfi 155		    (while workoccs /= {})
smfi 156			$ remove all occurrences reachable from these
smfi 157			$ definitions.
smfi 158			vo1 from workoccs; reloccs less:= vo1;
smfi 159			(forall vo2 in ffrom{vo1} | vo2 in reloccs)
smfi 160			    reloccs less:= vo2; workoccs with:= vo2;
smfi 161			end forall;
smfi 162		    end while;
smfi 163
smfi 164		    $ next we find all occurrences which will cause
smfi 165		    $ type conflicts at this instruction.
smfi 166
smfi 167		    workoccs := { vo1 in reloccs | typ(vo1) = type_om };
smfi 168$$-- problem with statement numbers:  if statements are numbered
smfi 169$$-- linearly, then any reference to the (implicit) term block will
smfi 170$$-- receive the statement number of the loop header;  if statements
smfi 171$$-- are numbered according to their block order, then any explicit
smfi 172$$-- statement in an step/until/term block will cause the statement
smfi 173$$-- numbering for the entire loop body to be off since these blocks
smfi 174$$-- appear to the parser at the loop header, and are moved behind the
smfi 175$$-- loop body.
smfi 176$$-- the only know place where this causes problems is the use of an
smfi 177$$-- exhausted loop index.
smfi 178$$--		    relstmts := { oi_stmt(vo1) : vo1 in workoccs };
smfi 179
smfi 180		    if #workoccs /= 0 then
smfi 181			if text = om then
smfi 182			    text := '"' + oi_name(voy) + '"'
smfi 183				    ' is om';
smfi 184$$--				    ' is undefined at ';
smfi 185			else
smfi 186			    text +:= ', and is om along some path';
smfi 187$$--			    text +:= ', and is undefined at ';
smfi 188			end if;
smfi 189
smfi 190$$--			tail from relstmts;
smfi 191
smfi 192$$--			if #relstmts = 0 then
smfi 193$$--			    text +:= tail;
smfi 194$$--			elseif #relstmts = 1 then
smfi 195$$--			    text +:= arb relstmts + ' and ' + tail;
smfi 196$$--			else
smfi 197$$--			    text := text +/[ l + ', ' : l in relstmts ];
smfi 198$$--			    text +:= 'and ' + tail;
smfi 199$$--			end if;
smfi 200		    end if;
smfi 201
smfi 202		    (while workoccs /= {})
smfi 203			$ remove all occurrences reachable from these
smfi 204			$ occurrences.
smfi 205			vo1 from workoccs; reloccs less:= vo1;
smfi 206			(forall vo2 in ffrom{vo1} | vo2 in reloccs)
smfi 207			    reloccs less:= vo2; workoccs with:= vo2;
smfi 208			end forall;
smfi 209		    end while;
smfi 210
smfi 211		    $ next we find all occurrences linked to the
smfi 212		    $ remaining occurrences in the forward direction.
smfi 213
smfi 214		    workoccs := reloccs;
smfi 215
smfi 216		    (while workoccs /= {})
smfi 217			vo1 from workoccs; seenoccs with:= vo1;
smfi 218			(forall vo2 in ffrom{vo1} |
smfi 219						typ(vo2) = type_zero)
smfi 220			    reloccs with:= vo2;
smfi 221			    if vo2 notin seenoccs then
smfi 222				workoccs with:= vo2;
smfi 223			    end if;
smfi 224			end forall;
smfi 225		    end while;
smfi 226
smfi 227		    relstmts := { oi_stmt(vo1) : vo1 in reloccs };
smfi 228
smfi 229		    if #relstmts /= 0 then
smfi 230			if text = om then
smfi 231			    text := '"' + oi_name(voy) + '" ';
smfi 232			else
smfi 233			    text := text + ', and ';
smfi 234			end if;
smfi 235
smfi 236			if oi_stmt(voy) in relstmts then
smfi 237			    relstmts less:= oi_stmt(voy);
smfi 238			    tail := 'here';
smfi 239			else
smfi 240			    tail from relstmts;
smfi 241			end if;
smfi 242
smfi 243			if #reloccs = 1 then
smfk 108			    text +:= 'cannot be evaluated';
smfi 245			elseif #relstmts = 0 then
smfi 246			    text +:= 'is used inconsistently here';
smfi 247			elseif #relstmts = 1 then
smfi 248			    text +:= 'is used inconsistently between '
smfi 249					+ arb relstmts + ' and ' + tail;
smfi 250			else
smfi 251			    text +:= 'is used inconsistently between ';
smfi 252			    text := text +/[ l + ', ' : l in relstmts ];
smfi 253			    text +:= 'and ' + tail;
smfi 254			end if;
smfi 255		    end if;
smfk 109
smfk 110		    tp_stmts := { [ typ(vo1), oi_stmt(vo1) ] :
smfk 111						    vo1 in precoccs };
smfk 112		    if #tp_stmts /= 0 then
smfk 113			if text = om then
smfk 114			    text := 'the type of "' + oi_name(voy) + '"'
smfk 115				    ' is ';
smfk 116			else
smfk 117			    text +:= ', and its type is ';
smfk 118			end if;
smfk 119			(forall relstmts = tp_stmts{t1})
smfk 120			    if text(#text) /= ' ' then
smfk 121				text +:= ', ';
smfk 122			    end if;
smfk 123			    tail from relstmts;
smfk 124			    text +:= format_type(t1) + ' at ' +
smfk 125				case #relstmts of
smfk 126				(0):	'',
smfk 127				(1):	arb relstmts + ' and '
smfk 128				else
smfk 129				    '' +/[ l + ', ' : l in relstmts ] +
smfk 130				    'and '
smfk 131				end + tail;
smfk 132			end forall;
smfk 133		    end if;
     188
     189		elseif typ(voy) = type_om then
     190		    text := '"' + oi_name(voy) + '" is undefined';
     191		else
     192		    text :=
     193			if j = 1 then 'the ' else 'the ' end +
     194			'type of "' + oi_name(voy) + '"'
     195			' is ' + format_type(typ(voy));
     196		end if;
     197
     198		text +:= if j = #ivs then '.' else ', ' end;
smfc 618		if j > 1 and #message(#message) + #text < 64 then
     200		    message(#message) +:= text;
     201		else
     202		    message with:= text;
     203		end if;
     260
     261	    end forall;
smfi 256	    messages{stmtof(i)}{'e'} with:= message;
smfi 257	    errstmt with:= stmtof(i); errblk with:= blockof(i);
smfi 258	    (forall vo1 in ivs) errvars with:= oi_sym(vo1); end;
smfi 259	    errvars with:= oi_sym(vox);
     263
     264
     265	elseif is_ivar(vox) and
smfi 260		opcode(i) /= q1_isom and opcode(i) /= q1_notom and
     266		exists voy in bfrom{vox} |
     267			typ(voy) .con typ(vox) /= typ(voy) then
     268
     269	    $ an input occurrence with some kind of  execution  problem:
     270	    $ we find all preceding occurrences which can assume  values
     271	    $ which can cause some execution problem.
     272
     273	    workoccs := { vox };$ workpile of preceding occurrences
     274	    seenoccs := {};	$ occurrences already seen
smfg 115	    reloccs  := {};	$ preceding occurrences
     277
     278	    (while workoccs /= {})
     279
smfg 116		vo1 from workoccs; seenoccs with:= vo1;
     282
     283		(forall vo2 in bfrom{vo1} |
     284			typ(vo2) .con typ(vox) /= typ(vo2))
     285
smfg 117		    if is_ovar(vo2) then reloccs with:= vo2; end if;
     289
     290		    if vo2 notin seenoccs then
     291			workoccs with:= vo2;
     292		    end if;
     293
     294		end forall;
     295
     298	    end while;
     299
smfg 118	    (forall o in reloccs)
     301
smfe  66		t1 := typ(o) .con typ(vox);
smfe  67		t2 := typ(o) .sub typ(vox);
     304
smfe  68		if t1 = type_zero then
     306		    l := 'e';
     307
     308		elseif ( oi_op(o) = q1_asn or oi_op(o) = q1_argin ) and
     309			arg2(instno(o)) = sym_om and
     310			is_notom(typ(vox)) then
     311		    l := 'e';
     312
smfe  69		elseif t2 = type_om and getipp('full=0/1') = 0 and
     314			( (oi_op(o) = q1_sargout and
     315			    name(arg2(instno(o))) in
     316				{ 'read', 'reada',
     317				  'get', 'getb', 'getf' } )	    or
     318			  oi_op(o) = q1_of			    or
     319			  oi_op(o) = q1_arb			) then
     320		    continue forall;
     321
smfe  70		elseif t2 = ntyp(grsset, type_om) and
     323			getipp('full=0/1') = 0 and
     324			oi_op(o) = q1_ofa             then
     325		    continue forall;
     326
     327		else
     328		    l := 'w';
     329		end if;
     330
smfe  71		text := 'error if "' + oi_name(o) + '" is ';
smfe  72		if t1 = type_zero then
smfe  73		    text +:= format_type(t2);
smfe  74		elseif t2 = type_gen then
smfe  75		    text +:= 'not ' + format_type(t1);
smfe  76		elseif string_length(t1) < string_length(t2) then
smfe  77		    text +:= 'not ' + format_type(t1);
smfe  78		else
smfe  79		    text +:= format_type(t2);
smfe  80		end if;
smfe  81		message := [ text + '.' ];
smfi 261		messages{stmtof(i)}{l} with:= message;
     351	    end forall;
     352
     353
smfe  82	elseif is_ovar(vox) and
smfi 262		(text := type_constant(i)) /= om then
smfe  84	    message :=
smfi 263		[ 'expression "' + format_inst(i, om) + '"'
smfe  86		    ' is constant:  ' ];
smfe  87	    text +:= '.';
smfe  88	    if #message(1) + #text < 72 then
smfe  89		message(1) +:= text;
smfe  90	    else
smfe  91		message with:= text;
smfe  92	    end if;
smfi 264	    messages{stmtof(i)}{'w'} with:= message;
smfe  94
smfe  95
smfi 265	elseif v notin itervars and
smfi 266		opcode(i) notin ops_typepred and
smfh  22		#grosstyp( (typ(vox) .con type_notom) ) > 1 and
smfh  23		( ( is_ivar(vox) and notexists voy in bfrom{vox} |
smfh  24			#grosstyp( (typ(voy) .con type_notom) ) > 1 ) or
smfh  25		  ( is_ovar(vox) and ffrom{vox} /= {} and
smfi 267			notexists voy in occs(i)(2..) |
smfh  29			    #grosstyp( (typ(voy) .con type_notom) ) > 1)
smfh  30		) then
smfe 100	    $ we only include o-variables in this test that reach a use.
smfe 101	    $ we ignore the internal iteration variable of iterators,
smfe 102	    $ which always will have type general.
smfi 268	    messages{stmtof(i)}{'i'} with:=
smfi 269	    	[ '"' + name(v) + '" has an ambiguous type.' ];
     361	end if;
smfi 270      end forall;
smfi 271    end; end; end forall;
     363
     364
     365    end procedure type_final;
     366
     367
       1 .=member fwd14f
       2
       3
       4    procedure forward(o);
       5$
       6$ this routine calculates the type of an ovariable 'o' from the types of
       7$ its inputs.
       8$
       9    repr
      10	o:			occurrence;
      11	opc:			elmt base_opcodes;
      12	ivs:			tuple(occurrence);
      13	tps:			tuple(elmt types);
      14	i:			occurrence;
      15	grtps:			tuple(gross_type);
smff  37	i1, i2, i3, i4:		occurrence;
      17	t1, t2, t3, t4:		elmt types;
      18	g1, g2, g3, g4:		gross_type;
      19	g, gx:			gross_type;
      20	tp, tpx:		elmt types;
smff  38	v, v1, v2, v3:		integer;
      22	ct1:			tuple(elmt types);
      23	j:			integer;
      24	ctp:			elmt types;
      25	ctp1, ctp2:		elmt types;
      26	tx, ty, tz:		elmt types;
      27	r:			symbol;
      28    end repr;
      29
      30    opc   := oi_op(o);
      31    ivs   := [ get_oi(instno(o), j) :
      32		j in [ first_ivar(opc)..#args(instno(o)) ] ];
      33    tps   := [ typ(i) : i in ivs ];
      34    grtps := [ grosstyp(typ(i)) : i in ivs ];
      35
      36    [ i1, i2 ] := ivs;
      37    [ t1, t2 ] := tps;
      38    [ g1, g2 ] := grtps;
      39
      40    tp := type_zero;	$ set to default
      41
      42    case opc of
      44$
      45$ binary operators
      46$
      47    (q1_in, q1_notin):
      48	$ if t2 is a set or tuple the result is boolean.
      49	if g2 * str_tup_set /= {} then
      50	    tp := type_boolean;
      51	end if;
      52
      53    (q1_incs):
      54	$ if both inputs are sets the result is boolean
      55	if t_set in g1*g2 then
      56	    tp := type_boolean;
      57	end if;
      58
      59    (q1_eq, q1_ne):
      60	$ relational operators always return a boolean.
      61	tp := type_boolean;
      62
smfh  31    (q1_ge, q1_lt, q1_pos):
      64	$ if the operands are valid, then the result is boolean
      65	if int_real_str * g1 * g2 /= {} then
      66	    tp := type_boolean;
      67	end if;
      68
      69    (q1_with):
      70	$ if t1 is a set or unknown-length tuple, then its type is:
      71	$ grosstyp:   set, tuple, or both, depending on the type of t1
      72	$ comptyp:    disjunction of t2 and the component type of t1
      73	$ nb. with is not defined on known-length tuples.
      74	if t_set in g1 then
      75	    ctp := comptyp(t1) .con type_notom;
      76	    t2  := t2 .con type_notom;
      77	    if ctp /= type_zero or t2 /= type_zero then
      78		tp := ntyp( grsset, ctp .dis t2 );
      79	    else
      80		tp := ntyp( grsset, type_om );
      81	    end if;
      82	end if;
      83	if t_tuple in g1 then
      84	    if is_knt(t1) then norm(t1); end if;
      85	    tp .dis:= ntyp( grstup, comptyp(t1) .dis t2 );
      86	end if;
      87
      88    (q1_less):
      89	$ if t1 is a set, then the result has the same type as t1
      90	if t_set in g1 then
      91	    tp := ntyp( grsset, comptyp(t1) .dis type_om );
      92	end if;
      93
      94    (q1_lessb, q1_lesse):
      95	$ these opcodes are part of the simulation for q1_fromb
      96	$ and frome, resp.
      97	$ nb. fromb and frome are not defined for known-length tuples.
      98	if t_tuple in g1 then
      99	    if is_knt(t1) then norm(t1); end if;
     100	    tp := ntyp( grstup, comptyp(t1) .dis type_om );
     101	end if;
     102
     103    (q1_lessf):
     104	$ if t1 is a set, it must be a map or a set of pairs
     105	if t_set in g1 then
     106	    ctp := comptyp(t1);
     107	    if ctp = type_om then
     108		tp := ntyp( grsset, type_om );
     109	    elseif (ctp .con:= type_pair) /= type_zero then
     110		tp := ntyp( grsset, ctp .dis type_om );
     111	    end if;
     112	end if;
     113
     114    (q1_npow):
     115	$ one input is a set, the other an integer;
     116	$ the result is set(set_type).
     117	if t_set in g1 and t_int in g2 then
     118	    tp := ntyp( grsset, t1 .dis type_om );
     119	end if;
     120	if t_int in g1 and t_set in g2 then
     121	    tp .dis:= ntyp( grsset, t2 .dis type_om );
     122	end if;
     123
     124    (q1_max, q1_min):
     125	tp := t1 .con t2 .con type_int_real_str;
     126
     127    (q1_add):
     128	gx := g1 * g2;
     129	tp := t1 .con t2 .con type_int_real_str;
     130	if t_tuple in gx and is_knt(t1) and is_knt(t2) then
     131	    tp .dis:= knt_type(comptyp(t1) + comptyp(t2));
     132	elseif not is_prim(gx) then
     133	    if is_knt(t1) then norm(t1); end if;
     134	    if is_knt(t2) then norm(t2); end if;
     135	    ctp1 := comptyp(t1);
     136	    ctp2 := comptyp(t2);
     137	    ctp  := ctp1 .dis ctp2;
     138	    if is_notom(ctp1) or is_notom(ctp2) then
     139		ctp .con:= type_notom;
     140	    end if;
     141	    tp .dis:= ntyp( gx*set_tup, ctp );
     142	end if;
     143
     144    (q1_sub):
     145	tp := t1 .con t2 .con type_int_real;
     146	if t_set in g1 and t_set in g2 then
     147	    tp .dis:= ntyp( grsset, comptyp(t1) .dis type_om );
     148	end if;
     149
     150    (q1_mult):
     151	tpx := t1 .con t2;
     152	tp := tpx .con type_int_real;
     153	if t_set in g1 and t_set in g2 then
     154	    tp .dis:= ntyp( grsset, comptyp(tpx) .dis type_om );
     155	end if;
     156	if t_int in g1 then
     157	    if t_string in g2 then
     158		tp .dis:= type_string;
     159	    end if;
     160	    if t_tuple in g2 then
     161		if is_knt(t2) then norm(t2); end if;
     162		tp .dis:= (t2 .con type_tuple);
     163	    end if;
     164	end if;
     165	if t_int in g2 then
     166	    if t_string in g1 then
     167		tp .dis:= type_string;
     168	    end if;
     169	    if t_tuple in g1 then
     170		if is_knt(t1) then norm(t1); end if;
     171		tp .dis:= (t1 .con type_tuple);
     172	    end if;
     173	end if;
     174
     175    (q1_div):
     176	tp := t1 .con t2 .con type_int;
     177
     178    (q1_slash):
     179	if type_int_real .con t1 .con t2 /= type_zero then
     180	    tp := type_real;
     181	end if;
     182
     183    (q1_mod):
     184	if t_set in g1 and t_set in g2 then
     185	    ctp := comptyp(t1) .dis comptyp(t2) .dis type_om;
     186	    tp  := ntyp( grsset, ctp );
     187	end if;
     188	if t_int in g1 and t_int in g2 then
     189	    tp .dis:= type_int;
     190	end if;
     191
     192    (q1_exp):
     193	tp := type_int_real .con t1 .con t2;
     194	if t_real in g1 and t_int in g2 then
     195	    tp .dis:= type_real;
     196	end if;
     197
smff  39    (q1_atan2):
smff  40	tp := t1 .con t2 .con type_real;
     198$
     199$ unary operators
     200$
     201    (q1_not):
     202	if t_atom in g1 then
     203	    tp := type_boolean;
     204	end if;
     205
     206    (q1_even, q1_odd):
     207	if t_int in g1 then
     208	    tp := type_boolean;
     209	end if;
     210
     211    (q1_isint, q1_isreal, q1_isstr, q1_isbool,
     212     q1_isatom, q1_istup, q1_isset, q1_ismap):
     213	tp := type_boolean;
     214
     215    (q1_arb):
     216	$ if t1 is a set, then the result type is the component type.
     217	if t_set in g1 then
     218	    tp := comptyp(t1);
     219	end if;
     220
     221    (q1_arbb, q1_arbe):
     222	$ these opcodes are part of the simulation for q1_fromb
     223	$ and q1_frome, resp.
     224	if t_tuple in g1 then
     225	    if is_knt(t1) then norm(t1); end if;
     226	    tp := comptyp(t1);
     227	end if;
     228
     229    (q1_dom, q1_range):
     230	$ if the input is a set, the result is its domain or image
     231	$ type.
     232	j := if opc = q1_dom then 1 else 2 end;
     233	if t_set in g1 then
     234	    ctp := comptyp(t1);
     235	    if ctp = type_om then
     236		$ no pair type yet: pass null set along
     237		tp  := ntyp( grsset, type_om );
     238	    elseif (ctp .con:= type_pair) /= type_zero then
     239		ct1 := comptyp(ctp);
     240		tp  := ntyp( grsset, ct1(j) .dis type_om );
     241	    end if;
     242	end if;
     243
     244    (q1_pow):
     245	$ if t1 is a set, then the result is set(t1).
     246	if t_set in g1 then
     247	    tp := ntyp( grsset, t1 .con type_set );
     248	end if;
     249
     250    (q1_nelt):
     251	$ for valid input types, the result type is int.
     252	if g1 * str_tup_set /= {} then
     253	    tp := type_int;
     254	end if;
     255
smff  41    (q1_abs):
     257	$ the result type is int or real, depending on the input type
smff  42	$ the result type is int if the input is a string (of length 1).
     258	tp := t1 .con type_int_real;
smff  43	if t_string in g1 then tp .dis:= type_int; end if;
     259
     260    (q1_char):
     261	tp := type_string;
     262
     263    (q1_ceil, q1_floor, q1_fix):
     264	if t_real in g1 then
     265	    tp := type_int;
     266	end if;
     267
     268    (q1_float):
     269	if t_int in g1 then
     270	    tp := type_real;
     271	end if;
     272
     273    (q1_sin,    q1_cos,    q1_tan,
     274     q1_arcsin, q1_arccos, q1_arctan,
     275     q1_tanh,
     276     q1_expf,   q1_log,
     277     q1_sqrt                ):
     278	if t_real in g1 then
     279	    tp := type_real;
     280	end if;
     281
     282    (q1_rand):
     283	$ if t1 is a known length tuple, then the result type is the
     284	$ disjunction of the component types.  if t1 is a set or
     285	$ unknown length tuple, then the result type is the component
     286	$ type.
     287	tp := t1 .con type_int_real_str;
     288	if not is_prim(g1) then
     289	    if is_knt(t1) then norm(t1); end if;
     290	    tp .dis:= comptyp(t1);
     291	end if;
     292
     293    (q1_sign):
     294	if int_real * g1 /= {} then
     295	    tp := type_int;
     296	end if;
     297
     298    (q1_type, q1_str):
     299	tp := type_string;
     300
     301    (q1_val):
     302	$ this operation converts a string representing any setl
     303	$ value to its value, so the result type is general.
     304	if t_string in g1 then
     305	    tp := type_gen;
     306	end if;
     307
smff  44    (q1_umin):
smff  45	$ the result type is int or real, depending on the input type.
smff  46	tp := t1 .con type_int_real;
     308$
     309$ slicing operations
     310$
     311$ nb. these operations are only defined for strings and tuples.
     315$
     316    (q1_subst):
     317	$ t2 and t3 must be integers.
smff  47	[ -, -, i3 ] := ivs;
smff  48	[ -, -, t3 ] := tps;
smff  49	[ -, -, g3 ] := grtps;
smff  50	if t_int in g2 and t_int in g3 then
     323	    if t_tuple in g1 then
smff  51		if is_knt(t1) and
smff  52			is_const_int(i2) and is_const_int(i3) then
smff  53		    ct1 := comptyp(t1);
smff  54		    v2  := oi_val(i2);
smff  55		    v3  := oi_val(i3);
smff  56		    if 1 <= v2 and v2 <= v3+1 and v3 <= #ct1 then
smff  57			tp := knt_type(ct1(v2..v3));
smff  58		    else
smff  59			tp := type_zero;
smff  60		    end if;
smff  61		else
smff  62		    if is_knt(t1) then norm(t1); end if;
smff  63		    tp := ntyp( grstup, comptyp(t1) .dis type_om );
smff  64		end if;
     326	    end if;
smff  65
smff  66	    if t_string in g1 then
smff  67		tp .dis:= type_string;
smff  68	    end if;
     327	end if;
     328
     329    (q1_end):
     330	$ t2 must be an integer.
     331	if t_int in g2 then
     336	    if t_tuple in g1 then
smff  69		if is_knt(t1) and is_const_int(i2) then
smff  70		    ct1 := comptyp(t1); v2 := oi_val(i2);
smff  71		    if 1 <= v2 and v2 <= #ct1 then
smff  72			tp := knt_type(ct1(v2..));
smff  73		    else
smff  74			tp := type_zero;
smff  75		    end if;
smff  76		else
smff  77		    if is_knt(t1) then norm(t1); end if;
smff  78		    tp := ntyp( grstup, comptyp(t1) .dis type_om );
smff  79		end if;
     339	    end if;
smff  80
smff  81	    if t_string in g1 then
smff  82		tp .dis:= type_string;
smff  83	    end if;
     340	end if;
     341
     342    (q1_ssubst):
     343	$ t1 and t2 must be integer,
     344	$ t3 is the right-hand side,
     345	$ t4 is the i-occurrence of the output
     346	[ -, -, t3, t4 ] := tps;
     347	[ -, -, g3, g4 ] := grtps;
     348	if t_int in g1 and t_int in g2 then
     352	    if t_tuple in g3*g4 then
smff  84		if is_knt(t3) and is_knt(t4) and
smff  85			is_const_int(i1) and is_const_int(i2) then
smff  86		    ct1 := comptyp(t4);
smff  87		    v1  := oi_val(i1);
smff  88		    v2  := oi_val(i2);
smff  89		    if 1 <= v1 and v1 <= v2+1 and v2 <= #ct1 then
smff  90			tp := knt_type( ct1(1..v1-1)
smff  91					+ comptyp(t3)
smff  92					+ ct1(v2+1..)    );
smff  93		    else
smff  94			tp := type_zero;
smff  95		    end if;
smff  96		else
smff  97		    if is_knt(t3) then norm(t3); end if;
smff  98		    if is_knt(t4) then norm(t4); end if;
smff  99		    tp := t3 .dis t4;
smff 100		end if;
     356	    end if;
smff 101
smff 102	    if t_string in g3 and t_string in g4 then
smff 103		tp .dis:= type_string;
smff 104	    end if;
     357	end if;
     358
     359    (q1_send):
     360	$ t1 must be an integer.
smff 105	[ -, -, t3 ] := tps;
smff 106	[ -, -, g3 ] := grtps;
     362	if t_int in g1 then
     366	    if t_tuple in g2*g3 then
smff 107		if is_const_int(i1) and is_knt(t2) and is_knt(t3) then
smff 108		    ct1 := comptyp(t3); v1 := oi_val(i1);
smff 109		    if 1 <= v1 and v1-1 <= #ct1 then
smff 110			tp := knt_type( ct1(1..v1-1) + comptyp(t2) );
smff 111		    else
smff 112			tp := type_zero;
smff 113		    end if;
smff 114		else
smff 115		    if is_knt(t2) then norm(t2); end if;
smff 116		    if is_knt(t3) then norm(t3); end if;
smff 117		    tp := t2 .dis t3;
smff 118		end if;
     370	    end if;
smff 119
smff 120	    if t_string in g2 and t_string in g3 then
smff 121		tp .dis:= type_string;
smff 122	    end if;
     371	end if;
     372
     373$
     374$ assigning operators
     375$
     376    (q1_asn, q1_argin):
     377	tp := t1;
     378
     379    (q1_argout):
     380	tp := tps(3);
     381
     382    (q1_sargout):
     383	$ i1 is the routine name
     384	$ i2 is the actual parameter number
     385	r := oi_sym(i1); j := oi_val(i2);
     386	if rvary(r)=1 and rnargs(r) < j then
     387	    $ the routine has a variable number of arguments, and the
     388	    $ current argument has the form of the last formal argument
     389	    j := rnargs(r);
     390	end if;
     391	tp := given_type(ft_elmt(form(r))(j));
smff 123	if maxtype_sargs(r) /= om then
smff 124	    tp .con:= maxtype_sargs(r)(j);
smff 125	end if;
     392
     393    (q1_def):
     394	$ most general definition for external procedure simulation
     395	tp := type_gen;
     396$
     397$ map operations
     398$
     399    (q1_of):
smfb 405	$ the first input can be a string, a tuple, or a set.  we handle
smfb 406	$ each case separately.
     402
     403	if t_string in g1 and t_int in g2 then
     404	    tp := type_string;
     405	end if;
     406
     407	$ next we handle f(x) where f is a known length tuple and x is
     408	$ an integer constant.  there are three possibilities:
     409	$ a. x <= 0:		error.
     410	$ b. 1 <= x <= # f:	set result to proper component type.
     411	$ c. # f < x:		set result to omega type.
     412
     413	if t_tuple in g1 and t_int in g2 then
     414	    if is_knt(t1) and is_const_int(i2) then
     415		v := oi_val(i2);
     416
     417		if 1 <= v and v <= # comptyp(t1) then
     418		    tp .dis:= ctypn(t1, v);
     419		elseif # comptyp(t1) < v then
     420		    tp .dis:= type_om;
     421		end if;
     422
     423	    else
     424		$ handle remaining tuple cases by or-ing in component
     425		$ type
     426		$ nb. the result may be omega.
     427		if is_knt(t1) then norm(t1); end if;
smfd  15		tp .dis:= comptyp(t1) .dis type_om;
     430	    end if;
     431	end if;
     432
     433	$ finally handle sets by 'or'ing in image type.  once again,
     434	$ the result may be omega.
     435
     436	if t_set in g1 then
     437	    ctp := comptyp(t1);
     438	    if ctp = type_om then
     439		$ no pair type yet: keep type small
     440		tp .dis:= type_om;
     441	    elseif (ctp .con:= type_pair) /= type_zero then
     442		ct1 := comptyp(ctp);
     443		tx  := ct1(1) .con t2;
     444		if tx /= type_zero then
smfd  16		    tp .dis:= ct1(2) .dis type_om;
smfi 272		elseif t2 /= type_zero then
     447		    $ index not in map domain: result is omega
     448		    tp .dis:= type_om;
     449		end if;
     450	    end if;
     451	end if;
     452
     453    (q1_ofa):
     454	$ the result is set(image type of f)
     455	if t_set in g1 then
     456	    ctp := comptyp(t1);
     457	    if ctp = type_om then
     458		$ no pair type yet: pass null set along
     459		tp := ntyp( grsset, type_om );
     460	    elseif (ctp .con:= type_pair) /= type_zero then
     461		ct1 := comptyp(ctp);
     462		tx  := ct1(1) .con t2;
     463		if tx /= type_zero then
smfd  17		    tp := ntyp( grsset, ct1(2) .dis type_om );
smfi 273		elseif t2 /= type_zero then
     466		    $ index not in map domain: result is null set
     467		    tp := ntyp( grsset, type_om );
     468		end if;
     469	    end if;
     470	end if;
     471
     472    (q1_sof):
     473	t3 := tps(3);   g3 := grtps(3);
     474
     475	$ first we handle the case where f is a known-length tuple
     476	$ and x is an integer constant.  there are three cases:
     477	$ a. x <= 0:         error.
     478	$ b. 1 <= x <= # f:  set x-th component type of result to x-th
     479	$                    component type of f .dis y
     480	$ c. x > # f:        set result to mixed tuple whose first #f
     481	$                    components have the component types of f
     482	$                    and whose x-th component has the type of
     483	$                    y.
     484
     485	if t_tuple in g3 and t_int in g1 then
     486	    if is_knt(t3) and is_const_int(i1) then
     487		v := oi_val(i1);
     488		ct1 := comptyp(t3);
     489
     490		if 1 <= v and v <= #ct1 then
     491		    tp := t3;
     492		    ctypn(tp, v) := t2;
     493		elseif #ct1 < v then
     494		    tp := t3;
     495		    ctypn(tp, v) := t2;
     496		    (forall j in [ #ct1+1..v-1 ])
     497			ctypn(tp, j) := type_om;
     498		    end forall;
     499		end if;
     500
     501	    else
     502		$ otherwise if f is a tuple then the result is a tuple
     503		$ whose component type is the disjunction of the com-
     504		$ ponent type(s) of f and the type of y.
     505		if is_knt(t3) then norm(t3); end if;
     506		tp := ntyp( grstup, comptyp(t3) .dis t2 );
     507	    end if;
     508	end if;
     509
     510	$ if f can be a set then we 'or' in the type for [x, y].
     511	$ there are two special cases:
     512	$ 1. either x or y are definitely omega.  in this case we
     513	$    shall never insert the pair into f,  so we treat the
     514	$    instruction as a noop.
     515	$ 2. either x or y might be omega.  in this case we shall
     516	$    perform a run-time test and insert the pair only if
     517	$    neither element is omega.  before building the type
     518	$    descriptor for the pair we set both is_om flags to no.
     519
     520	if t_set in g3 then
     521	    $ ctp1 is the map element type derived from x and y
     522	    ctp1 := pair_type(t1, t2);
     523	    if is_notom(t1) and is_om(t2) then
     524		$ cannot say whether a pair is actually inserted
     525		ctp1 .dis:= type_om;
     526	    end if;
     527	    $ ctp2 is the map element type from the i-occurrence of f
     528	    ctp2 := (type_pair .dis type_om) .con comptyp(t3);
     529	    $ ctp is the new map element type
     530	    ctp := ctp1 .dis ctp2;
     531	    if is_notom(ctp1) or is_notom(ctp2) then
     532		ctp .con:= type_notom;
     533	    end if;
     534	    tp .dis:= ntyp( grsset, ctp );
     535	end if;
     536
     537	if t_int in g1 and t_string in g2 and t_string in g3 then
     538	    tp .dis:= type_string;
     539	end if;
     540
     541    (q1_sofa):
     542	$ the output f will always be a map
     543	t3 := tps(3);   g3 := grtps(3);
     544	if t_set in g3 and t_set in g2 then
     545	    tz := t2 .con type_set;	$ range set type
     546	    ty := comptyp(tz);		$ range element type
     547	    $ ctp1 is the map element type derived from x and y
     548	    ctp1 := pair_type(t1, ty);
     549	    if is_notom(t1) and is_om(ty) then
     550		$ cannot say whether a pair is actually inserted
     551		ctp1 .dis:= type_om;
     552	    end if;
     553	    $ ctp2 is the map element type from the i-occurrence of f
     554	    ctp2 := (type_pair .dis type_om) .con comptyp(t3);
     555	    $ ctp is the new map element type
     556	    ctp := ctp1 .dis ctp2;
     557	    if is_notom(ctp1) or is_notom(ctp2) then
     558		ctp .con:= type_notom;
     559	    end if;
     560	    tp .dis:= ntyp( grsset, ctp );
     561	end if;
     562
     563$
     564$ iterators
     565$
     566    (q1_next, q1_inext):
smfb 407	$ the second input, i.e. the object being iterated over,  can be
smfb 408	$ a string, a tuple, or a set.
     571
     572	if opc = q1_next then
     573	    tp := tps(3);
     574	end if;
     575
     576	if t_string in g2 then
     577	    tp .dis:= type_string;
     578	end if;
     579
     580	if not is_prim(g2) then
     581	    if is_knt(t2) then norm(t2); end if;
     582	    tp .dis:= comptyp(t2);
smfe 105	    if t_tuple notin g2 then tp .con:= type_notom; end if;
     583	end if;
     585
     586    (q1_nextd, q1_inextd):
     587	$ here we compute the type for 'x' in 'for y = f(x)'.
     588	$ t2 is the type of f.
     589	$ if t2 is a tuple or string, then x is an integer;
     590	$ if t2 is a set, it must be a map, and consequently the
     591	$ type of x is the type of the first component of the
     592	$ component type of t2.
     593	if str_tup * g2 /= {} then
     594	    tp := type_int;
     595	end if;
     596	if t_set in g2 then
     597	    ctp := comptyp(t2) .con type_pair;
     598	    if ctp /= type_zero then
     599		ct1 := comptyp(ctp);
     600		tp .dis:= ct1(1);
     601	    end if;
     602	end if;
     603
     604    (q1_set):
     605	$ enumerative set former - { x1, x2, x3, ..., xn }
     606	$ the result is set(disjunction of individual elements)
     607	ctp := type_zero .dis/ tps;
     608	tp := ntyp( grsset, ctp .con type_notom );
     609
     610    (q1_set1):
     611	$ iterative set former - {  : x in s | c(x) }
     612	$ the first input argument gives the (see comment above)
     613	$ type of .  the result type is set(t1).
     614	tp := ntyp( grsset, t1 .dis type_om );
     615
     616    (q1_tup):
     617	$ enumerative tuple former - [ x1, x2, x3, ..., xn ]
     618	$ the result is a known-length tuple.
     619	(forall ctp = tps(j))
     620	    tps(j) := ctp .con type_notom;
     621	end forall;
     622	if #tps = 1 then
     623	    tp := ntyp( grstup, tps(1) );
     624	else
     625	    tp := knt_type(tps);
     626	end if;
     627
     628    (q1_tup1):
     629	$ iterative tuple former - [  : x in s | c(x) ]
     630	$ the result type is tuple(t1); see above comment on first
     631	$ argument of iterative set and tuple formers.
     632	tp := ntyp( grstup, t1 .dis type_om );
     633
     634    else
     635	print('*** missing opcode in forward *** ', o, opc);
     636
     637    end case;
     638
     639    return tp;
     640
     641
     642    end procedure forward;
     643
     644
       1 .=member bak14g
       2
       3
       4    procedure backward(inst);
       5$
       6$ this routine computes the type of the ivariables of inst based on how
       7$ they are used.
       8$
       9$ certain operations such as addition are only legal if the inputs are
      10$ not omega.  when we process:
      11$
      12$ (1)	read(x);
      13$ (2)	print(x+1);
      14$
      15$ we have:
      16$
      17$ is_om(x1) = maybe    by forward analysis
      18$ is_om(x2) = no       by backward analysis
      19$
      20$ this means that x1 and x2 have different types, and a conversion
      21$ must be inserted between lines 1 and 2.  this conversion amounts
      22$ to checking that x is not omega.
      23$
      24    repr
      25	inst:			elmt insts;
      26	opc:			elmt base_opcodes;
      27	ivs:			tuple(occurrence);
      28	j:			integer;
      29	tps:			tuple(elmt types);
      30	i:			occurrence;
      31	otyp:			elmt types;
      32	gotyp:			gross_type;
      33	i1, i2:			occurrence;
      34	t1, t2:			elmt types;
      35	outps:			tuple(elmt types);
      36	tp, tpa, tpb, tpx:	elmt types;
      37	tp1, tp2:		elmt types;
      38	ctp:			elmt types;
      39	ct1:			tuple(elmt types);
      40	tx, ty:			elmt types;
      41	c:			general;
      42	v:			integer;
      43	r:			symbol;
      44    end repr;
      45$
      46$ begin by getting the type of the ovariable, etc.
      47$
      48    opc := opcode(inst);
      49    ivs := [ get_oi(inst, j) : j in [ first_ivar(opc)..#args(inst) ] ];
      50    tps   := [ typ(i) : i in ivs ];
      51    otyp  := typ(get_oi(inst, 1));
      52    gotyp := grosstyp(otyp);
      53
      54    [ t1, t2 ] := tps;
      55    outps := tps;
      56
      57    macro change1;	outps(1) := tp			endm;
      58    macro change2;	outps(2) := tp			endm;
      59    macro change3;	outps(3) := tp			endm;
      60
smfc 620$ check whether otyp is type_zero.   this indicates that the instruction
smfc 621$ contains an error.   in this situation we replace otyp by type_general
smfc 622$ to return the mildest constraint  on this instruction.   note that the
smfc 623$ results  of this  routine are  always  conjuncted  with  the  previous
smfc 624$ results;  hence this upper bound will not cause divergence.
smfc 625
smfc 626    if otyp = type_zero then
smfc 627	otyp := type_gen;   gotyp := grosstyp(otyp);
smfc 628    end if;
      66
      67    case opc of
      68$
      69$ binary operators
      70$
      71
      72    (q1_in, q1_notin):
      73	$ we are looking at s in x in s.  s must be a set,
      74	$ string, or tuple.
      75	tp := type_str_tup_set;
      76	change2;
      77
      78    (q1_incs):
      79	tp := type_set;
      80	change1; change2;
      81
smfh  32    (q1_ge, q1_lt, q1_pos):
      83	$ the inputs are integers, reals, or strings.
smfi 274	tp := type_int_real_str;
smfi 275	if t1 /= type_zero then tp .con:= t1; end if;
smfi 276	if t2 /= type_zero then tp .con:= t2; end if;
      85	change1; change2;
      86
      87    (q1_with):
      88	$ s.in has the same type as s.out
      89	$ x.in has the element type of s.out
      90	$ s can not be omega;  x can be omega iff s is a tuple
      91	$ with is not defined for known-length tuples
      92	if t_tuple in gotyp and is_knt(otyp) then norm(otyp); end if;
      93	if not is_prim(gotyp) then
      94	    ctp := comptyp(otyp) .dis type_om;
      95	    tp  := ntyp( gotyp * set_tup, ctp );
      96	else
      97	    tp  := type_zero;
      98	end if;
      99	change1;
     100
     101	tp := comptyp(tp);
     102	if t_tuple notin gotyp then tp .con:= type_notom; end if;
     103	change2;
     104
     105    (q1_less):
     106	$ s.in must be a set
     107	$ s.in can not be omega
     108	tp := if t_set in gotyp then type_set else type_zero end;
     109	change1;
     110
     111    (q1_lesse, q1_lessb):
     112	$ these opcodes are part of the simulation for q1_fromb and
     113	$ q1_frome.
     114	$ t.in must be a tuple
     115	$ t.in can not be omega
     116	tp := if t_tuple in gotyp then type_tuple else type_zero end;
     117	change1;
     118
     119    (q1_lessf):
     120	$ arg2 is a map, arg3 can be anything
     121	if t_set in gotyp then
     122	    tp := ntyp( grsset, type_pair .dis type_om );
     123	end if;
     124	change1;
     125
     126    (q1_npow):
     127	tp := (comptyp(otyp) .con type_set) .dis type_int;
     128	change1; change2;
     129
     130    (q1_add):
     131	tp := otyp .con type_int_real_str;
     132	if not is_prim(gotyp) then
     133	    if is_knt(otyp) then norm(otyp); end if;
     134	    ctp := comptyp(otyp) .dis type_om;
     135	    tp .dis:= ntyp( gotyp*set_tup, ctp );
     136	end if;
     137	change1; change2;
     138
     139    (q1_mult):
     140	tp := otyp .con type_int_real;
     141
     142	if t_set in gotyp then
     143	    tp .dis:= type_set;
     144	end if;
     145
     146	tpx := otyp .con type_str_tup;
     147	tpa := tpb := tp;
     148	if tpx /= type_zero then
     149	    if (tp1 := tpx .con t1) /= type_zero and
smfi 277		    t_int in grosstyp(t2) or t1 = type_zero then
     151		tpa .dis:= tp1;
     152		tpb .dis:= type_int;
     153	    end if;
     154	    if (tp2 := tpx .con t2) /= type_zero and
smfi 278		    t_int in grosstyp(t1) or t2 = type_zero then
     156		tpa .dis:= type_int;
     157		tpb .dis:= tp2;
     158	    end if;
     159	end if;
     160	tp := tpa; change1;
     161	tp := tpb; change2;
     162
     163    (q1_mod, q1_sub):
     164	tp := otyp .con type_int_real;
     165	if t_set in gotyp then
     166	    tp .dis:= type_set;
     167	end if;
     168	change1; change2;
     169
     170    (q1_exp):
     171	tp := otyp .con type_int_real;
     172	change1;
     173
     174	if t_real in gotyp then
     175	    tp .dis:= type_int;
     176	end if;
     177	change2;
     178
     179    (q1_max, q1_min):
     180	tp := type_int_real_str;
     181	change1; change2;
     182
     183    (q1_slash):
     184	tp := type_int_real;
     185	change1; change2;
     186
     187    (q1_div):
     188	tp := type_int;
     189	change1; change2;
     190
smff 126    (q1_atan2):
smff 127	tp := type_real;
smff 128	change1; change2;
     191$
     192$ unary operators
     193$
     194    (q1_not, q1_asrt):
     195	tp := type_boolean;
     196	change1;
     197
     198    (q1_even, q1_odd):
     199	tp := type_int;
     200	change1;
     201
     202    (q1_isint,  q1_isreal, q1_isstr, q1_isbool,
smfe 106     q1_isatom, q1_istup,  q1_isset, q1_ismap):
     204	tp := type_notom;
     205	change1;
     206
     207    (q1_arb):
     208	$ q1_arb is only defined for sets and maps.
     209	$ the input must be set(output type)
     210	tp  := ntyp( grsset, otyp .dis type_om );
     211	change1;
     212
     213    (q1_arbb, q1_arbe):
     214	$ these opcode are part of the simulation of q1_fromb, q1_frome
     215	$ t.in must be a tuple;  t.in can not be omega
     216	tp := ntyp( grstup, otyp .dis type_om );
     217	change1;
     218
     219    (q1_dom):
     220	$ the input is a map with domain type 'otyp' and
     221	$ image type general.
     222	ctp := pair_type(comptyp(otyp), type_gen) .dis type_om;
     223	tp  := ntyp( grsset, ctp );
     224	change1;
     225
     226    (q1_range):
     227	$ the input is a map with domain type general and
     228	$ image type 'otyp'.
     229	ctp := pair_type(type_gen, comptyp(otyp)) .dis type_om;
     230	tp  := ntyp( grsset, ctp );
     231	change1;
     232
     233    (q1_pow):
     234	$ the output will be a set of sets, by forward propagation
     235	tp := comptyp(otyp) .con type_set;
     236	change1;
     237
     238    (q1_nelt):
     239	$ q1_nelt is defined for strings, tuples, and sets.
     240	tp := type_str_tup_set;
     241	change1;
     242
smff 129    (q1_abs):
smff 130	tp := otyp .con type_int_real;
smff 131	if t_int in gotyp then tp .dis:= type_string; end if;
     245	change1;
smff 132
smff 133    (q1_char):
smff 134	tp := type_int;
smff 135	change1;
     246
     247    (q1_ceil, q1_floor, q1_fix):
     248	$ the input must be real.
     249	tp  := type_real;
     250	change1;
     251
     252    (q1_float):
     253	$ the input must be integer.
     254	tp := type_int;
     255	change1;
     256
     257    (q1_sin,    q1_cos,    q1_tan,
     258     q1_arcsin, q1_arccos, q1_arctan,
     259     q1_tanh,
     260     q1_expf,   q1_log,
     261     q1_sqrt                ):
     262	 $ the input must be real.
     263	 tp := type_real;
     264	 change1;
     265
     266    (q1_rand):
     267
     268	tp := (otyp .dis ntyp( set_tup, otyp )) .con type_notom;
     273	change1;
     274
     275    (q1_sign):
     276	tp := type_int_real;
     277	change1;
smfe 107
smfe 108    (q1_type, q1_str):
smfe 109	tp := type_notom;
smfe 110	change1;
     278
     279    (q1_val):
     280	tp := type_string;
     281	change1;
smff 136
smff 137    (q1_umin):
smff 138	tp := otyp .con type_int_real;
smff 139	change1;
     282
smfg 119    (q1_if, q1_ifnot, q1_bif, q1_bifnot):
     284	$ the input is boolean
     285	tp := type_boolean;
     286	change1;
     287
     288    (q1_next, q1_inext):
smfk 134	$ input is set(otyp), tuple(otyp), or string
     290	tp := ntyp( str_tup_set, otyp .dis type_om );
     291	change2;
     292
     293    (q1_nextd, q1_inextd):
     294	$ the first argument is the domain element of the iteration.
     295	ctp := pair_type(otyp, type_gen);
     296	tp  := ntyp( grsset, ctp .dis type_om );
     297	if t_int in gotyp then  $ could be string or tuple iterator
     298	    tp .dis:= type_str_tup;
     299	end if;
     300	change2;
     301
     302    (q1_set):
     303	tp := comptyp(otyp) .con type_notom;
     304	outps := [ tp : j in [ 1..#ivs ] ];
     305
     306    (q1_set1):
     307	tp := comptyp(otyp) .con type_notom;
     309	change1;
     310
     311	tp := type_int;
     312	change2;
     313
     314    (q1_tup):
     315	if is_knt(otyp) then
     316	    ct1 := comptyp(otyp);
     317	    (forall j in [ 1..#ivs ])
     320		outps(j) := ct1(j) .con type_notom;
     321	    end forall;
     322	else
     323	    tp := comptyp(otyp) .con type_notom;
     325	    outps := [ tp : j in [ 1..#ivs ] ];
     326	end if;
     327
     328    (q1_tup1):
     329	$ the input type is the element type of the final tuple.
     330	$ if there are several element types (i.e. for known-length
     331	$ tuples) we take their disjunction.
     332	if is_knt(otyp) then
     333	    tp := type_zero .dis/ comptyp(otyp);
     334	else
     335	    tp := comptyp(otyp);
     336	end if;
     337	tp .con:= type_notom;
     338	change1;
     339
     340	tp := type_int;
     341	change2;
     342
     343$
     344$ slicing operations
     345$
     346    (q1_end, q1_subst):
     347	if t_string in gotyp then
     348	    tp := type_string;
     349	else
     350	    tp := type_zero;
     351	end if;
     352	if t_tuple in gotyp then
     353	    tp .dis:= type_tuple;
     354	end if;
     356	change1;
     357
     358	tp := type_int;
     359	change2;
     360	if opc = q1_subst then change3; end if;
     361
     362    (q1_ssubst, q1_send):
     363	if t_tuple in gotyp then
     364	    if is_knt(otyp) then norm(otyp); end if;
     365	    tp := otyp .con type_notom;
     366	else
     367	    tp := type_zero;
     368	end if;
     369	if t_string in gotyp then
     370	    tp .dis:= type_string;
     371	end if;
     373	j := if opc = q1_ssubst then 4 else 3 end;
smff 140	outps(j) := tp;
smff 141	outps(j-1) := tp;
     376
     377	tp := type_int;
     378	change1;
     379	if opc = q1_ssubst then change2; end if;
     380$
     381$ map operations
     382$
     383    (q1_of):
     384	ctp := pair_type(type_gen, otyp);
smfc 629	if ctp = type_zero then ctp := type_pair; end if;
     385	tp  := ntyp( grsset, ctp .dis type_om );
     386	if t_int in grosstyp(t2) then
     387	    if t_string in gotyp then
     388		tp .dis:= type_string;
     389	    end if;
     390	    if t_tuple in grosstyp(t1) then
     391		i2 := ivs(2);
     392		if is_const_int(i2) and is_knt(t1) then
     393		    v := oi_val(i2);
     394		    c := comptyp(t1);
     395		    c(v) := otyp;
     396		    tp .dis:= knt_type(c);
     397		else
     398		    tp .dis:= type_tuple;
     399		end if;
     400	    end if;
smfi 279	elseif t2 = type_zero then
smfi 280	    tp .dis:= type_str_tup;
     401	end if;
     403	change1;
     404
smfi 281	if t_set in grosstyp(t1) or t1 = type_zero then
     406	    tp := type_notom;
     407	else
     408	    tp := type_int;
     409	end if;
     410	change2;
     411
     412    (q1_ofa):
     413	if t_set in gotyp then
     414	    ctp := pair_type(type_gen, comptyp(otyp));
smfc 630	    if ctp = type_zero then ctp := type_pair; end if;
     415	else
     416	    ctp := type_pair;
     417	end if;
     418	tp := ntyp( grsset, ctp .dis type_om );
     419	change1;
smfe 111	tp := type_notom;
smfe 112	change2;
     420
     421    (q1_sof):
     422	if t_set in gotyp then
     423	    ctp := comptyp(otyp) .con type_pair;
     424	    if ctp /= type_zero then
     425		[ tx, ty ] := comptyp(ctp);
     426	    else
     427		tx := type_notom; ty := type_gen;
     428	    end if;
     429	    tp := tx .con type_notom;
     430	else
     431	    tp := type_zero;
     432	end if;
     433	if str_tup * gotyp /= {} then
     434	    tp .dis:= type_int;
     435	end if;
     437	change1;
     438
     439	if t_string in gotyp then
     440	    tp := type_string;
     441	else
     442	    tp := type_zero;
     443	end if;
     444	if t_set in gotyp then
     446	    tp .dis:= ty .dis type_om;
     447	end if;
     448	if t_tuple in gotyp then
     449	    if is_knt(otyp) then
     450		i1 := ivs(1);
     451		ct1 := comptyp(otyp);
     452		if is_const_int(i1) then
     453		    v := oi_val(i1);
     454		    tp .dis:= ct1(v) .dis type_om;
     455		else
     456		    tp .dis:= (type_om .dis/ ct1);
     457		end if;
     458	    else
     459		tp .dis:= comptyp(otyp) .dis type_om;
     460	    end if;
     461	end if;
     462	change2;
     463
     464	if t_string in gotyp then
     465	    tp := type_string;
     466	else
     467	    tp := type_zero;
     468	end if;
     469	if t_tuple in gotyp then
     470	    if is_knt(otyp) then
     471		ct1 := comptyp(otyp);
     472		(forall ctp = ct1(j))
     473		    ct1(j) := ctp .dis type_om;
     474		end forall;
     475		tp .dis:= knt_type(ct1);
     476	    else
     477		ctp := comptyp(otyp);
     478		tp .dis:= ntyp( grstup, ctp .dis type_om );
     479	    end if;
     480	end if;
     481	if t_set in gotyp then
     482	    tp .dis:= ntyp( grsset, pair_type(tx, ty) .dis type_om );
     483	end if;
     484	change3;
     485
     486    (q1_sofa):
     487	$ the output must be a map, by forward propagation.
     488	ctp := comptyp(otyp) .con type_pair;
     489	if ctp /= type_zero then
     490	    [ tx, ty ] := comptyp(ctp);
     491	else
     492	    tx := type_notom; ty := type_gen;
     493	end if;
     494
     495	tp := tx .con type_notom;
     496	change1;
     497
     498	tp := ntyp( grsset, ty .dis type_om );
     499	change2;
     500
     501	tp := ntyp( grsset, pair_type(tx, ty) .dis type_om );
     502	change3;
     503
     504    (q1_asn, q1_argin):
     505	tp := otyp;
     506	change1;
     507
     508    (q1_argout):
     509	tp := otyp;
     510	change3;
     511
     512    (q1_sargin):
     513	r := args(inst)(2);
     514	j := value(args(inst)(3));
     515	if rvary(r)=1 and rnargs(r) < j then
     516	    $ the routine has a variable number of arguments, and the
     517	    $ current argument has the form of the last formal argument
     518	    j := rnargs(r);
     519	end if;
     520	tp := given_type(ft_elmt(form(r))(j));
smff 142	if maxtype_sargs(r) /= om then
smff 143	    tp .con:= maxtype_sargs(r)(j);
smff 144	end if;
     521	change1;
smfg 120
smfg 121    (q1_isom):
smfg 122	tp := type_om;
smfg 123	change1;
smfg 124
smfg 125    (q1_notom):
smfg 126	tp := type_notom;
smfg 127	change1;
     522
     523    else
     524	print('*** missing opcode in back', opc, inst);
     525    end case;
     526
     527
     528    return outps;
     529
     530
     531    end procedure backward;
     532
     533
       1 .=member tcn14h
       2
       3
       4    procedure type_constant(inst);
       5$
       6$ this procedure checks whether the result of the instruction inst is
       7$ determined by the types of its inputs.
       8$
       9    repr
      10	inst:			elmt insts;
      11	opc:			elmt base_opcodes;
      12	occsi:			tuple(occurrence);
      13	tps:			tuple(elmt types);
      14	grtps:			tuple(gross_type);
      15	i:			occurrence;
      16	t1, t2, t3:		elmt types;
      17	g1, g2, g3:		gross_type;
      18	tx, ty, tp:		elmt types;
      19	ct1:			tuple(elmt types);
      20	ctp:			elmt types;
      21	j:			integer;
      22    end repr;
      23
      24
      25    opc   := opcode(inst);
      26    occsi := [ get_oi(inst, j) : j in [ 1..#args(inst) ] ];
      27    tps   := [ typ(i) : i in occsi ];
      28    grtps := [ grosstyp(tp) : tp in tps ];
smfk 135
smfk 136    if exists tp in tps | tp = type_zero then  return;  end if;
      29
      30    [ t1, t2, t3 ] := tps;
      31    [ g1, g2, g3 ] := grtps;
      32
      33    case opc of
      34
      35    (q1_eq, q1_ne):
      36	$ type a2 = type a3
      37	if t2 = type_om or t3 = type_om then
      38	    if t2 = t3 then
      39		return  'both operands are omega';
      40	    elseif is_notom(t2) then
smff 145		return  'the left operand cannot be omega, '
smff 146			'the right operand is omega';
      43	    elseif is_notom(t3) then
smff 147		return  'the left operand is omega, '
smff 148			'the right operand cannot be omega';
      46	    end if;
smfd  22	elseif constant_equality(t2, t3) then  $ do recursive test
smfd  23	    return  'the operands have different types';
      49	end if;
      50
      51    (q1_in, q1_notin):
      52	$ in:    a1 := exists x in a3 | x = a2
      53	$ notin: a1 := forall x in a3 | x /= a2
      54	$ type a2 = type arb a3
      55	if t_string in g3 then
      56	    if t2 .con t3 .con type_string = type_zero then
      57		return  'both operands should be strings';
      58	    end if;
      59	end if;
      60	if t_tuple in g3 and t2 /= type_om then
      61	    if is_knt(t3) then
      62		ct1 := comptyp(t3);
      63		if forall tx in ct1 |
smfd  24			constant_equality(t2, tx) then
      65		    return  'the left operand cannot be '
      66			    'an element of the right operand';
      67		end if;
      68	    else
      69		tx := comptyp(t3);
smfd  25		if constant_equality(t2, tx) then
      71		    return  'the left operand cannot be '
      72			    'an element of the right operand';
      73		end if;
      74	    end if;
      75	end if;
      76	if t_set in g3 then
      77	    tx := comptyp(t3);
smfd  26	    if constant_equality(t2, tx) then
      79		    return  'the left operand cannot be '
      80			    'an element of the right operand';
      81	    end if;
      82	end if;
      83
      84    (q1_incs, q1_sub, q1_mult, q1_mod):
      85	$ incs:  a1 := forall x in a3 | x in a2
      86	$ sub:   a1 := { x in a2 | x notin a3 }
      87	$ mult:  a1 := { x in a2 | x in a3 }
      88	$ mod:   a1 := ( a2 - a3 ) + ( a3 - a2 )
      89	$ type arb a2 = type arb a3
      90	if t_set in g2 then
      91	    tx := comptyp(t2);
      92	    ty := comptyp(t3);
smfd  27	    if constant_equality(tx, ty) then
smfd  28		return
smfd  29		    case opc of
smfd  30		    (q1_incs):	'the right operand cannot include '
smfd  31				'the left operand',
smfd  32		    (q1_sub):	'the result will be the left operand',
smfd  33		    (q1_mult):  'the result will be a null set',
smfd  34		    (q1_mod):	'the result will be '
smfd  35				'the union of the operands'
smfd  36		    else	'*** error in type_constant ***'
smfd  37		    end;
      95	    end if;
      96	end if;
      97
      98    (q1_less):
      99	$ a1 := { x in a2 | x /= a3 }
     100	$ type arb a2 = type a3
     101	if t_set in g2 then
     102	    tx := comptyp(t2);
smfd  38	    if tx = type_om then
smfd  39		return 'the left operand is a null set';
smfd  40	    end if;
smfd  41	    if constant_equality(tx, t3) then
     104		return  'the right operand cannot be '
     105			'an element of the left operand';
     106	    end if;
     107	end if;
     108
     109    (q1_lessf):
     110	$ a1 := { [ x, y ] in a2 | x /= a3 }
     111	$ type arb domain a2 = type a3
     112	if (t2 .con:= type_map) /= type_zero then
     113	    ctp := comptyp(t2);
     114	    if ctp = type_om then
smfd  42		return  'the left operand is a null map';
     116	    end if;
     117	    ct1 := comptyp(ctp);
     118	    tx  := ct1(1);	$ domain element of map
smfd  43	    if constant_equality(tx, t3) then
     120		return  'the right operand cannot be '
     121			'an element of the left operand''s domain';
     122	    end if;
     123	end if;
     124
     125    (q1_type,   q1_isint,  q1_isreal, q1_isstr,
     126     q1_isbool, q1_isatom, q1_istup,  q1_isset):
     127	$ a2 should have an ambiguous type
     128	if #g2 = 1 then
smfk 137	    return  'operand has a unique type';
     130	end if;
     131
     132    (q1_ismap):
     133	$ a1 := is_set a2 and forall x in a2 |
     134	$			is_tuple x and #x = 2 and x(1) /= om
     135	if g2 = grsset then
     136	    if .is_pair(comptyp(t2)) then
     137		return  'operand is always a map';
     138	    end if;
     139	elseif #g2 = 1 then
     140	    return  'operand cannot be a map';
     141	end if;
     142
     143    (q1_of):
     144	$ type arb domain a2 = type a3
     145	if t_string in g2 or t_tuple in g2 then
     146	    if t3 .con type_int = type_zero then
     147		return  'string or tuple index is not an integer';
     148	    end if;
     149	end if;
     150	if t_set in g2 then
     151	    if (t2 .con:= type_map) /= type_zero then
     152		ctp := comptyp(t2);
     153		if ctp = type_om then
smfd  44		    return  'a retrieval from a null map always yields '
smfd  45			    'omega';
     155		end if;
     156		ct1 := comptyp(ctp);
     157		tx  := ct1(1);	$ domain element of map
smfd  46		if constant_equality(tx, t3) then
smfd  47		    return  'the index is not in the map''s domain';
     160		end if;
     161	    end if;
     162	end if;
     163
     164    (q1_ofa):
     165	$ a1 := { y : [ x, y ] in a2 | x = a3 }
     166	$ type arb domain a2 = type a3
     167	if (t2 .con:= type_map) /= type_zero then
     168	    ctp := comptyp(t2);
     169	    if ctp = type_om then
smfd  48		return  'a retrieval from a null map always yields '
smfd  49			'a null set';
     171	    end if;
     172	    ct1 := comptyp(ctp);
     173	    tx  := ct1(1);	$ domain element of map
smfd  50	    if constant_equality(tx, t3) then
smfd  51		return  'the index is not in the map''s domain';
     176	    end if;
     177	end if;
     178
     179    (q1_case):
     180	$ type arb domain a1 = type a2
     181	if (t1 .con:= type_map) /= type_zero then
     182	    ctp := comptyp(t1);
     183	    if ctp = type_om then
     184		return  'trivial case statement';
     185	    end if;
     186	    ct1 := comptyp(ctp);
     187	    tx  := ct1(1);	$ domain element of map
smfd  52	    if constant_equality(tx, t3) then
     189		return  'expression cannot match any case tag value';
     190	    end if;
     191	end if;
     192
     193    end case;
     194
     195
     196    end procedure type_constant;
     197
     198
smfd  53
smfd  54
smfd  55    procedure constant_equality(t1, t2);
smfd  56$
smfd  57$ this routine performs the recursive test whether the values described
smfd  58$ by t1 and t2 are always equal (not equal) due to their types.
smfd  59$
smfd  60    repr
smfd  61	t1, t2:			elmt types;
smfd  62	g1, g2:			gross_type;
smfd  63	c1, c2:			elmt types;
smfd  64	ct1, ct2:		tuple(elmt types);
smfd  65	i:			integer;
smfd  66    end repr;
smfd  67
smfd  68
smfd  69    g1 := grosstyp(t1);   if t_om in g1 then g1 less:= t_om; end if;
smfd  70    g2 := grosstyp(t2);   if t_om in g2 then g2 less:= t_om; end if;
smfd  71
smfd  72    if g1 * g2 = {} then
smfd  73	$ no common gross type:  this will always evaluate to false.
smfd  74	return true;
smfd  75
smfd  76    elseif #g1 > 1 or #g2 > 1 then
smfd  77	$ ambiguous gross types:  we cannot know which combination of
smfd  78	$ values will be tested.
smfd  79	return false;
smfd  80
smfd  81    elseif is_prim(g1) then
smfd  82	$ here the gross types must be equal:  if they are primitive, no
smfd  83	$ no component type needs to be tested.
smfd  84	return false;
smfd  85
smfd  86    elseif is_knt(t1) and is_knt(t2) then
smfd  87	$ two known-length tuples
smfd  88	$ note that known-length tuples cannot be just null tuples.
smfd  89	ct1 := comptyp(t1);   ct2 := comptyp(t2);
smfd  90	if #ct1 /= #ct2 then
smfd  91	    return false;
smfd  92	else
smfd  93	    return forall i in [ 1..#ct1 ] |
smfd  94			constant_equality(ct1(i), ct2(i));
smfd  95	end if;
smfd  96
smfd  97    else
smfd  98	$ two non-primitive types
smfd  99	if is_knt(t1) then norm(t1); end if;
smfd 100	if is_knt(t2) then norm(t2); end if;
smfd 101
smfd 102	c1 := comptyp(t1);   c2 := comptyp(t2);
smfd 103
smfd 104	$ see if one operand is a null set or null tuple:  the test is
smfd 105	$ constant if the other operand cannot be a null set or tuple.
smfd 106	if c1 = type_om then return not is_om(c2); end if;
smfd 107	if c2 = type_om then return not is_om(c1); end if;
smfd 108
smfd 109	return constant_equality(c1, c2);
smfd 110    end if;
smfd 111
smfd 112
smfd 113    end procedure constant_equality;
smfd 114
smfd 115
       1 .=member knt14i
       2
       3
       4    procedure ntyp(g, comp);
       5$
       6$ this routine builds a new type descriptor for any type except
       7$ 'known length tuple'.  its arguments are:
       8$
       9$ g:	the grosstype of the result
      10$ comp:	the component type of the result
      11$
      12$ this routine always returns a type which is definitely not om,
      13$ so that is_om must be separately set if this assumption is false
      14$
      15    repr
      16	g:			gross_type;
      17	comp:			elmt types;
      18    end repr;
      19$
      20$ we begin by building the tuple for the type descriptor, then
      21$ check that it is not nested to a depth greater than max_depth.
      22$
      23    if g = {} then return type_zero; end if;
      24
      25    if not is_prim(g) and comp = type_zero then
smfe 113	return [ g * int_real_str_atom ];
      27    else
      28	return [ g less t_om, trim(comp, 2), false ];
      29    end if;
      30
      31
      32    end procedure ntyp;
      33
      34
      35
      36
      37    procedure knt_type(tps);
      38$
      39$ this routine builds the type descriptor for a known length tuple.
      40$ 'tps' is a tuple containing the types of the components.
      41$
      42$ in order to make sure that the type lattice is finite, we restrict
      43$ known length tuples to a maximum length.  if #tps exceeds this length,
      44$ we return a type descriptor for a homogeneous tuple.
      48$
      49    repr
      50	tps:			tuple(elmt types);
      51	tp:			elmt types;
      52	i, ii:			integer;
      53    end repr;
      54
      55
      56    if exists tp in tps | tp = type_zero then
      57	return type_zero;
      58
      59    elseif #tps > max_len then
      60	return ntyp(grstup, type_zero .dis/ tps);
      61
      62    elseif exists ii in [ #tps, #tps-1..1 ] | tps(ii) /= type_om then
      63	return
      64	    [ grstup,
      65	      [ trim(tps(i), 2) : i in [ 1..ii ] ],
      66	      true    ];
      67
      68    else
      69	return [ grstup, type_om, false ];
      70    end if;
      71
      72
      73    end procedure knt_type;
      74
      75
       1 .=member par14j
      29
      30
      31    procedure pair_type(t1, t2);
      32
      33$ this routine builds the type descriptor for a pair whose component
      34$ types are t1 and t2.
      35$
      36    repr
smfe 114	t1, t2:			elmt types;
      39    end repr;
      40
smfe 115    return knt_type( [ t1 .con type_notom, t2 .con type_notom ] );
      42
      43    end procedure pair_type;
      44
      45
       1 .=member trm14k
       2
       3
       4    procedure trim(tp, n);
       5$
       6$ this routine walks recursively through the component type of tp.  if
       7$ tp is too deeply nested, it replaces the inner most component type
       8$ with type_gen.  n is the nesting level of the recursive walk.
      10$
      11    repr
      12	t:			elmt types;
      13	tp:			elmt types;
      14	g:			gross_type;
      15	c:			general;
      16	n:			integer;
      17    end repr;
      18
smfe 116    if tp = type_zero then return type_zero; end if;
smfe 117    if tp = type_gen  then return type_gen;  end if;
smfe 118
smfe 119    if n > max_depth  then return type_gen;  end if;
smfe 120
smfe 121    [ g, c ] := tp;
      27
smfe 122    if is_prim(g) then
      29	return tp;
      30
      31    elseif is_knt(tp) then
      32	return [ g, [ trim(t, n+1) : t in c ], true ];
      33
      34    else
      35	return [ g, trim(c, n+1), false ];
      36    end if;
      37
      38    end procedure trim;
      39
      40
      41
      42
      43    procedure norm(rw tp);
      44$
      45$ convert mixed tuple type to tuple.
      46$
      47    repr
      48	tp:			elmt types;
      49    end repr;
      50
      51
      52    tp := ntyp(grosstyp(tp), type_zero .dis/ comptyp(tp));
      53
      54    end procedure norm;
      55
      56
       1 .=member con14l
       2
       3
       4    operator .con(t1, t2);
       5$
smfd 116$ this routine computes the meet (conjunction, 'and') of two types.
       8$
       9    repr
      10	t1, t2, tp:		elmt types;
      11	g1, g2, g:		gross_type;
      12	c1, c2, c:		general;
smfe 123	ct1:			tuple(elmt types);
      14	i:			integer;
      15	can_be_om:		boolean;
      16    end repr;
      17
      18    if t1 = type_zero then return type_zero; end if;
      19    if t2 = type_zero then return type_zero; end if;
smfd 117
smfd 118    if t1 = type_gen then return t2; end if;
smfd 119    if t2 = type_gen then return t1; end if;
smfd 120
smfd 121    if t1 = t2 then return t1; end if;
      20
      21    [ g1, c1 ] := t1;
      22    [ g2, c2 ] := t2;
      23
      24    can_be_om := is_om(t1) and is_om(t2);
      25
smfd 122    if is_prim(g1) or is_prim(g2) then      $ one is primitive
      36	tp := [ g1 * g2 ];
      37
smfd 123    elseif is_knt(t1) and is_knt(t2) then   $ both known length
smfe 124	ct1 := [ ];
      40
      41	(forall i in [ 1..(#c1 min #c2) ])
smfe 125	    ct1(i) := c1(i) .con c2(i);
      43
smfe 126	    if ct1(i) = type_zero then
      45		return if can_be_om then type_om else type_zero end;
      46	    end if;
      47	end forall;
      48
smfe 127	tp := [ g1*g2, ct1, true ];
      50
smfd 124    else				    $ both sets or tuples
      52	g := g1 * g2;
      53	if g = {} then return type_zero; end if;
      54
      55	if is_knt(t1) or is_knt(t2) then
      56	    $ one known-length, one unknown-length tuple
smfe 128	    if is_knt(t2) then c := c2; c2 := c1; c1 := c; end if;
      58	    $ c1 is known-length tuple
smfe 129	    ct1 := [ ];
      60	    (forall i in [ 1..#c1 ])
smfe 130		ct1(i) := c1(i) .con c2;
smfe 131		if ct1(i) = type_zero then
      63		    return if can_be_om then type_om else type_zero end;
      64		end if;
      65	    end forall;
      66
smfe 132	    tp := [ g, ct1, true ];
      68
      69	else
      70	    c := c1 .con c2;
      71	    if c = type_zero then
      72		if t_set notin g then return type_zero; end if;
      73		c := type_om;
      74	    end if;
      75	    tp := [ g, c, false ];
      76	end if;
      77    end if;
      78
smfd 125    assert can_be_om = is_om(tp);
smfd 126    assert can_be_om impl tp /= type_zero;
smfd 127    return tp;
      83
      84
      85    end operator .con;
      86
      87
       1 .=member dis14m
       2
       3
       4    operator .dis(t1, t2);
       5$
smfd 128$ this routine computes the join (disjunction, 'or') of two types.
smfd 129$
smfe 133$ assert t_set in bsctyps;
smfe 134$ assert t_set in grosstyp(tp) impl not is_knt(tp);
smfd 130$ assert is_prim(grosstyp(type_om));
       8$
       9    repr
      10	t1, t2, tp:		elmt types;
smfe 135	g1, g2, g:		gross_type;
smfe 136	c1, c2, c:		general;
smfe 137	ct1:			tuple(elmt types);
      13	i:			integer;
      15    end repr;
      16
      17    if t1 = type_zero then return t2; end if;
      18    if t2 = type_zero then return t1; end if;
smfd 131
smfd 132    if t1 = type_gen then return type_gen; end if;
smfd 133    if t2 = type_gen then return type_gen; end if;
smfd 134
smfd 135    if t1 = t2 then return t1; end if;
      19
      20    [ g1, c1 ] := t1;
      21    [ g2, c2 ] := t2;
      22
smfd 136    if is_prim(g1) and is_prim(g2) then     $ both are primitive
      38	tp := [ g1 + g2 ];
      39
smfd 137    elseif is_prim(g1) then                 $ t1 primitive
smfd 138	tp := [ g1+g2, c2, is_knt(t2) ];
      43
smfd 139    elseif is_prim(g2) then                 $ t2 primitive
smfd 140	tp := [ g1+g2, c1, is_knt(t1) ];
      47
smfd 141    elseif is_knt(t1) and is_knt(t2) then   $ both known length
      49	$ for the following note that if the length of the two
      50	$ tuples differ, we can view the shorter on to have an
      51	$ arbitrary number of type_om components at the end.
smfe 138	ct1 := if #c1 >= #c2 then c1 else c2 end;
      56	(forall i in [ 1..(#c1 min #c2) ])
smfe 139	    ct1(i) := c1(i) .dis c2(i);
      58	end forall;
smfe 140	(forall i in [ (#c1 min #c2)+1..#ct1 ])
smfe 141	    ct1(i) .dis:= type_om;
      61        end forall;
      62
smfe 142	tp := [ g1+g2, ct1, true ];
      64
smfd 142    else                                    $ both sets or tuples
      66	if is_knt(t1) then c1 := type_zero .dis/ c1; end if;
      67	if is_knt(t2) then c2 := type_zero .dis/ c2; end if;
      68
      69	tp := [ g1+g2, c1 .dis c2, false ];
      70    end if;
smfe 143
smfe 144    loop			$ normalise type_gen
smfe 145      doing [ g, c ] := tp;
smfe 146      while g = bsctyps and grosstyp(c) = bsctyps
smfe 147    do
smfe 148	tp := c;
smfe 149    end loop;
      71
smfd 143    assert (is_om(t1) or is_om(t2)) = is_om(tp);
      74    return tp;
      75
      76    end operator .dis;
      77
      78
       1 .=member sub14n
       2
       3
       4    operator .sub(t1, t2);
       5$
       6$ this operator computes the difference between the  types  t1  and  t2.
       7$ the difference between two types is defined to mean the type which  t1
       8$ can assume but t2 cannot.
       9$
      10    repr
      11	t1, t2, c1, c2:		elmt types;
      12	tp1, tp2:		elmt types;
      13	g, gprim, g1, g2:	gross_type;
smfd 144	ct1, ct2, c:		tuple(elmt types);
smfd 145	i:			integer;
      14    end repr;
      15
      16    g1 := grosstyp(t1);
      17    g2 := grosstyp(t2);
      18
      19    if t2 = type_gen then
      20	return type_zero;
      21
      22    elseif t1 = type_om and is_notom(t2) then
      23	return type_om;
      24
      25    elseif is_prim(g1) then
      26	return [ g1 - g2 ];
      27
      28    elseif is_prim(g2) then
      29	return [ g1 - g2, comptyp(t1), is_knt(t1) ];
      30
      31    else
      32	gprim := g1 - g2 - tup_set_map;
      33
smfd 146	if is_knt(t1) and is_knt(t2) then	$ two know-length tuples
smfd 147	    ct1 := comptyp(t1);   ct2 := comptyp(t2);   c := ct1;
smfd 148	    (forall i in [ 1..(#ct1 min #ct2) ])
smfd 149		c(i) := ct1(i) .sub ct2(i);
smfd 150	    end forall;
smfd 151
smfd 152	    return
smfd 153		if forall c1 in c | c1 = type_zero then
smfd 154		    $ this tuple does not describe any value:  don't
smfd 155		    $ include it into the result.
smfd 156		    [ gprim ]
smfd 157		else
smfd 158		    $ recall that the type descriptor for a known-length
smfd 159		    $ tuple cannot describe a set type.
smfd 160		    [ gprim with t_tuple, c, true ]
smfd 161		end;
smfd 162	end if;
smfd 163
      34	if t_tuple in g1 and is_knt(t1) then norm(t1); end if;
      35	if t_tuple in g2 and is_knt(t2) then norm(t2); end if;
      36
      37	c1 := comptyp(t1);
      38	c2 := comptyp(t2);
      39
      40	if (g := g1-g2) * tup_set_map /= {} then
      41
      42	    $ t1 contains a composite type which t2  does  not  contain:
      43	    $ tp1 describes this type.
      44
smfd 164	    tp1 := [ g, c1, false ];
      46
      47	else
      48	    tp1 := type_zero;
      49	end if;
      50
      51	if (g := g1 * g2 * tup_set_map) /= {} then
      52
      53	    $ t1 and t2 have a common composite type: tp2  will  descibe
      54	    $ its difference type.
      55
      56	    if     c1 .con c2 = type_zero then tp2 := t1;
      57	    elseif c1 .con c2 = c1        then tp2 := type_zero;
      58	    else
      59		tp2 := [ g, c1 .sub c2, false ];
      60	    end if;
      61
      62	else
      63	    tp2 := type_zero;
      64	end if;
      65
      66	return [ gprim ] .dis tp1 .dis tp2;
      67
      68    end if;
      69
      70
      71    end operator .sub;
      72
      73
       1 .=member cnt14o
       2
       3
       4    procedure const_typ(v);
       5$
       6$ this routine returns a type descriptor for a constant value.
       7$
       8    repr
       9	x, v:			general;
      10	g:			gross_type;
      11    end repr;
      12
      13    g := {  if     is_integer v	then t_int
      14	    elseif is_real v	then t_real
      15	    elseif is_string v	then t_string
      16	    elseif is_boolean v	then t_atom
      17	    elseif is_tuple v	then t_tuple
      18	    elseif is_set v	then t_set
      19	    else		     t_om
      20	    end };
      21
      22    return
      23	if g = grsset then
      24	    if v = {} then
      25		[ grsset, type_om, false ]
      26	    else
      27		ntyp( grsset, type_zero .dis/[ const_typ(x) : x in v ] )
      28	    end
      29
      30	elseif g = grstup then
      31	    knt_type( [ const_typ(x) : x in v ] )
      32
      33	else
      34	    [ g ]
      35	end;
      36
      37    end procedure const_typ;
      38
      39
smfe 150
smfe 151
smfe 152    procedure string_length(tp);
smfe 153$
smfe 154$ this routine does a recursive tree walk of the type descriptor tp to
smfe 155$ compute a measure for the length of the string formatted by
smfe 156$ format_type.
smfe 157$
smfe 158    repr
smfe 159	tp, tx:			elmt types;
smfe 160	g:			gross_type;
smfe 161	c:			general;
smfe 162    end repr;
smfe 163
smfe 164
smfe 165    if tp = type_zero  then return 1; end if;
smfe 166    if tp = type_gen   then return 1; end if;
smfe 167
smfe 168    if tp = type_notom then return 1; end if;
smfe 169
smfe 170    [ g, c ] := tp;
smfe 171
smfe 172    if c = type_om then
smfe 173	if g = grstup then return 1; end if;
smfe 174	if g = grsset then return 1; end if;
smfe 175	if g = grsmap then return 1; end if;
smfe 176    end if;
smfe 177
smfe 178    return
smfe 179	if is_om(tp) then 1 else 0 end		$ omega
smfe 180	+ #(g * int_real_str_atom)		$ primitive types
smfe 181	+ if t_tuple in g and is_knt(tp) then	$ known-length tuple
smfe 182	    0 +/[ string_length(tx) : tx in c ]
smfe 183	  elseif g * tup_set_map /= {} then	$ set or tuple
smfe 184	    #(g * tup_set_map) * string_length(c)
smfe 185	  else
smfe 186	    0
smfe 187	  end;
smfe 188
smfe 189
smfe 190    end procedure string_length;
smfe 191
smfe 192
      40
      41
      42    operator .is_pair(tp);
      43$
      44$ this operator returns yes or no depending on whether tp is a type
      45$ descriptor for a pair of non-omega values.
      46$
      47    repr
      48	tp:			elmt types;
      49	c:			tuple(elmt types);
      50    end repr;
      51
      52    return
      53	if grosstyp(tp) less t_om = grstup
      54		and is_knt(tp)
      55		and #(c := comptyp(tp)) = 2
      56		and is_notom(c(1))
      57		and is_notom(c(2))
      58	then true
      59	else false
      60	end;
      61
      62    end operator .is_pair;
      63
      64
      65
      66
      67    operator .is_map(tp);
      68$
      69$ this operator returns yes, no, or maybe depending on whether tp is
      70$ a type descriptor for a map.
      71$
      72    repr
      73	tp:			elmt types;
      74    end repr;
      75
      76    if grosstyp(tp) less t_om = grsset then
      77	return .is_pair(comptyp(tp));
      78    else
      79	return false;
      80    end if;
      81
      82
      83    end operator .is_map;
      84
      85
       1 .=member adt14p
       2
       3
       4    procedure ads_type(tp);
       5$
       6$ this procedure (recursively) transforms types into the form desired
       7$ by the automatic data-structure selection module.  the transformations
       8$ are the following:
       9$
      10$ 1. transform the type set(tuple(x,y)) into the type map(tuple(x,y))
      11$ 2. transform the type [ bsctyps [ type_gen ] ] into type_gen
      12$ 3. drop the is_om flag
      13$
      14    repr
      15	tp:			elmt types;
      16	g:			gross_type;
      17	ctp:			elmt types;
      18    end repr;
      19
      20
      21    g := grosstyp(tp) less t_om;
      22
      23    if tp = type_om then
      24	return type_om;
      25
      26    elseif tp = type_gen then
      27	return type_notom;
      28
      29    elseif is_prim(g) then
      30	return [ g ];
      31
      32	elseif g = bsctyps less t_om and
      33		grosstyp(tp(2)) with t_om = bsctyps then
      34	    $ 'normalise' type_gen: since we are about to throw away the
      35	    $ t_om value, this test does what it should.
      36	return ads_type(tp(2));
      37
      38    elseif g = grsset then
      39	return [ if .is_pair(comptyp(tp)) then grsmap else grsset end,
      40		  ads_type(tp(2))    ];
      41
      42    elseif is_knt(tp) then
      43	return [ g, [ ads_type(ctp) : ctp in comptyp(tp) ], true ];
      44
      45    else
      46	return [ g, ads_type(comptyp(tp)), false ];
      47    end if;
      48
      49
      50    end procedure ads_type;
      51
      52
      53    end module setl_optimizer - typfind;
      54
      55
       1 .=member admn15
       2
       3
       4    module setl_optimizer - auto_dstruct;
smfd 165$
smfd 166$ the following automatic data structure  selection  algorithm  uses  an
smfd 167$ approach  to  this  problem differing from that described in 
smfd 168$ and .  although the approach suggested  there  has  a  rather
smfd 169$ simple  structure, it suffers from several deficiencies which have led
smfd 170$ us to an alternative approach.  the  new  approach,  to  be  described
smfd 171$ below,  is closer to ed schonberg's algorithm  and seems to be
smfd 172$ faster than the earlier approach.  in spite of the differences between
smfd 173$ these  two methods, they have a similar overall logic which is simpler
smfd 174$ than  that  of   previously   suggested   algorithms.    among   these
smfd 175$ simplifications  are:   use  of  the  bfrom  and ffrom maps instead of
smfd 176$ value-flow maps;  and elimination of a phase  which  inserts  'locate'
smfd 177$ instructions into the code.
smfd 178$
smfd 179$ we first describe the new automatic data structure selection algorithm
smfd 180$ heuristically:
smfd 181$
smfd 182$ (1) initially, all instructions i in the  code  to  be  processed  are
smfd 183$ analysed  separately.   in  this  analysis  we  proceed  in  a  manner
smfd 184$ depending on the opcode of i and  the  types  of  its  arguments,  and
smfd 185$ generate  bases b1, b2, ..., bn, such that all of the occurrences in i
smfd 186$ can be given a data structure representation such  that  each  of  the
smfd 187$ above  bases appear in at least one such declaration, and such that if
smfd 188$ these representations are used, the execution time of  i  will  either
smfd 189$ remain substantially the same, or else become faster.
smfd 190$
smfd 191$ a base bi is generated only if at least one occurrence in  i  accesses
smfd 192$ its  elements,  and if introduction of this base does not slow i down.
smfd 193$ i could slow down if hashing of a value into bi is required at i (e.g.
smfd 194$ if  a new value of an element of bi may have been created in executing
smfd 195$ i), or if base conversions at i may be  required  (e.g.  if  different
smfd 196$ bases are assigned to the arguments in a set union instruction).
smfd 197$
smfd 198$ a second  property that we require the generated bases to  possess  is
smfd 199$ that  even after the introduction of repred arguments, the instruction
smfd 200$ i should be equivalent to i with its arguments having  their  original
smfd 201$ types  (and  forms).  thus, in an instruction 'c := a + b;', if a is a
smfd 202$ set of integers, b is a set of characters and c is (necessarily) a set
smfd 203$ of  general  elements,  no  bases  are generated, for in order for the
smfd 204$ instruction not to slow down, all three arguments must be based on the
smfd 205$ same  base, whose elements must therefore be of general type.  thus, a
smfd 206$ and b become sets of general elements, overestimating  their  previous
smfd 207$ types.
smfd 208$
smfd 209$ this restriction reflects one of  the  underlying  principles  of  our
smfd 210$ approach,  namely:   the types of variable occurrences, as produced by
smfd 211$ the  type  finder,  should  not  be  modified  during  automatic  data
smfd 212$ structure selection.  such modifications are possible in two cases:
smfd 213$
smfd 214$ (i) during the initial basing pass, if types are converted into  based
smfd 215$ reprs  which are not equivalent to the original types (as in the above
smfd 216$ set union example).
smfd 217$
smfd 218$ (ii) by merging based reprs of two occurrences having different types.
smfd 219$ such  a  merge  may  cause  equivalencing of two bases b1 and b2 whose
smfd 220$ element-modes are not equal, so that the new base will not  be  really
smfd 221$ equivalent either to b1 nor to b2, and consequently the types of reprs
smfd 222$ based on b1 or b2 will have changed.
smfd 223$
smfd 224$ in both cases, types become more general, and never  more  restricted.
smfd 225$ hence,  the new types will over-estimate the actual types, so that the
smfd 226$ code will still be safe.   however,  because  types  may  become  less
smfd 227$ specific,  we  are  apt  to generate less efficient code, in the sense
smfd 228$ that some q2 instructions may become more general (and therefore  more
smfd 229$ time  consuming),  and  extra  type  checks  and  conversions  may  be
smfd 230$ required.
smfd 231$
smfd 232$ for these reasons, we prefer to make sure that cases (i) and (ii) will
smfd 233$ not  occur  in  our  algorithm,  and  so keep the types of occurrences
smfd 234$ unchanged (see also remark (1) below).
smfd 235$
smfd 236$ not all generated bases  actually  speed  up  the  program  execution.
smfd 237$ those  that  do  not  are useless, and, unless we can later merge them
smfd 238$ with more useful bases, will be suppressed (see (4) below).   however,
smfd 239$ we  find it useful to introduce these extra bases since doing so makes
smfd 240$ it easier to propagate basings across instructions (see (3) below).
smfd 241$
smfd 242$ generated bases whose introduction speeds  up  the  execution  of  the
smfd 243$ instruction  in  connection  with  which  they  are introduced will be
smfd 244$ called 'effective bases', and all other generated bases will be called
smfd 245$ 'neutral bases'.
smfd 246$
smfd 247$ examples:
smfd 248$
smfd 249$ (a)	t := s with x;
smfd 250$
smfd 251$ if t and s are sets with elements of the  same  type,  which  is  also
smfd 252$ equal to the type of x, we generate one effective base b, repr s and t
smfd 253$ as set(elmt b), and repr x as elmt b.  if, in addition, we know that s
smfd 254$ is  a  set(tuple(tx, ty)),  and that x is a tuple(tx, ty), we annotate
smfd 255$ the repr for t to mark that t is a potentially multi-valued map.  if s
smfd 256$ and  t  are  homogeneous tuples having the same element type, which is
smfd 257$ also equal to the type of x, we generate  one  neutral  base  b,  with
smfd 258$ reprs analogous to the above.
smfd 259$
smfd 260$ (b)	y := f(x);
smfd 261$
smfd 262$ if f is a map, with a domain type equal to the type of x, and a  range
smfd 263$ type equal to the type of y, we generate one effective base b1 and one
smfd 264$ neutral base b2, and generate the following representations:
smfd 265$
smfd 266$	f: smap(elmt b1) elmt b2;   x: elmt b1;   y: elmt b2;
smfd 267$
smfd 268$ we also annotate the repr for f to indicate that f is involved  in  an
smfd 269$ operation  which  requires  single-valuedness,  for which local basing
smfd 270$ would be most appropriate.
smfd 271$
smfd 272$ if the type of y is not equal to the  range  type  of  f,  we  do  not
smfd 273$ generate  b2,  and if the type of x is not equal to the domain type of
smfd 274$ f, we do not generate b1.
smfd 275$
smfd 276$ if f is a homogeneous tuple, and  the  type  of  y  is  equal  to  the
smfd 277$ component  type  of  f,  we  generate one neutral base b and repr f as
smfd 278$ tuple(elmt b) and y as elmt b.
smfd 279$
smfd 280$ if f is a string or of an ambiguous type, no bases are generated.
smfd 281$
smfd 282$ (c)	y := x;
smfd 283$
smfd 284$ unless the types of x and y are unequal, we generate one neutral  base
smfd 285$ b, and repr x and y as elmt b.
smfd 286$
smfd 287$ note that many of the restrictions imposed in the above examples  will
smfd 288$ be satisfied automatically in view of the action of the final phase of
smfd 289$ the type finder, which assigns to each o-variable the  'forward'  type
smfd 290$ of  its  i-variable.  for example, in (a) above, if s is a set and the
smfd 291$ type of its elements is equal to the type of x, then  the  type  of  t
smfd 292$ will  always be equal to that of s;  similarly, in (c) above, the type
smfd 293$ of y will always be equal to the type of x.  however, we  have  stated
smfd 294$ the  above  restrictions in order to make our data structure selection
smfd 295$ algorithm as independent of the type finder as possible.
smfd 296$
smfd 297$
smfd 298$ (2) after the initial base generation phase, most variable occurrences
smfd 299$ will  have  been  based either on effective bases or on neutral bases.
smfd 300$ our algorithm now assumes that effective bases, as well as bases  that
smfd 301$ can  be merged with effective bases, are advantageous.  moreover, base
smfd 302$ merging  is  performed   by   passing   basing   information   between
smfd 303$ instructions according to the following heuristics:
smfd 304$
smfd 305$ let vo1, vo2 be two occurrences of the same variable which are  linked
smfd 306$ by  the  bfrom  map,  and  suppose  that  we  want  to  merge the base
smfd 307$ information of vo1  with  that  of  vo2.   let  repr1,  repr2  be  the
smfd 308$ generated  reprs  of  vo1, vo2, respectively.  in order to merge these
smfd 309$ reprs, vo1 and vo2 must have the same type.  if this is the case, then
smfd 310$ repr1  and  repr2  describe  objects  having  the  same  type,  and by
smfd 311$ comparing their structures we can either  equivalence  or  find  other
smfd 312$ relations  between  the  bases  which  these  objects involve.  a more
smfd 313$ detailed description of this procedure is given  in  phase  2  of  our
smfd 314$ algorithm below.
smfd 315$
smfd 316$
smfd 317$ (3) the base generation pre-pass described above enables us  to  avoid
smfd 318$ propagation   of  base  information  between  arguments  of  the  same
smfd 319$ instruction,  a  task  which  would  call  for  some  messy  routines,
smfd 320$ resembling  the  'forward' and 'backward' routines of the type finder,
smfd 321$ and  would  also  increase  the  time  consumed   by   our   algorithm
smfd 322$ (see ).   however,  base  propagation  across instructions is
smfd 323$ already performed implicitly within the initial base generation phase.
smfd 324$ subsequent  base  merging  only  needs  to  consider  bfrom links.  to
smfd 325$ convince ourselves that this is indeed the case, we  consider  several
smfd 326$ examples.
smfd 327$
smfd 328$ example a.
smfd 329$
smfd 330$ (i1)	s with:= x;		$ s is a set.
smfd 331$ (i2)	v(i) := x;		$ v is a tuple.
smfd 332$ (i3)	y := v(j);
smfd 333$ (i4)	z := f(y);		$ f is a map.
smfd 334$
smfd 335$ assume that v is a homogeneous tuple.  then the initial basing pass we
smfd 336$ will produce the following basings (where only b1, b4 are effective):
smfd 337$
smfd 338$	s1: set(elmt b1);	x1: elmt b1;
smfd 339$	v2: tuple(elmt b2);	x2: elmt b2;
smfd 340$	y3: elmt b3;		v3: tuple(elmt b3);
smfd 341$	y4: elmt b41;		z4: elmt b42;
smfd 342$	f4: map(elmt b41) elmt b42;
smfd 343$
smfd 344$ then, when bases are merged along bfrom  links,  b1  and  b2  will  be
smfd 345$ merged  (using  the  x-link  from i1 to i2);  b2 and b3 will be merged
smfd 346$ (via the v-link);  b3 and b41 will be merged (via the y-link).  if  we
smfd 347$ did  not  introduce  neutral  bases  for  i2  and i3, we would have to
smfd 348$ propagate basings across i2 and i3 in order to deduce that b1 and  b41
smfd 349$ should be merged.
smfd 350$
smfd 351$ note also that in the steps just described b42  has  not  been  merged
smfd 352$ with  an  effective  base.   if  this  condition persists, b42 will be
smfd 353$ dropped during the base adjustment phase.
smfd 354$
smfd 355$ example b.  (s, u and t are assumed to be sets)
smfd 356$
smfd 357$ (i1)	s with:= x;
smfd 358$ (i2)	u with:= s;
smfd 359$ (i3)	t from u;
smfd 360$ (i4)	y from t;
smfd 361$
smfd 362$ here, after the pre-pass, we would have:
smfd 363$
smfd 364$	s1: set(elmt b1);	x1: elmt b1;
smfd 365$	u2: set(elmt b2);	s2: elmt b2;
smfd 366$	t3: elmt b3;		u3: set(elmt b3);
smfd 367$	y4: elmt b4;		t4: set(elmt b4);
smfd 368$
smfd 369$ using the bfrom links which apply to this fragment of code,  we  would
smfd 370$ first   merge  the  two  reprs  elmt b2  and  set(elmt b1)  of  the  s
smfd 371$ occurrences;  this will give us information about the element mode  of
smfd 372$ b2,  i.e.  elmt b2 = set(elmt b1).   then we equivalence b2 and b3 via
smfd 373$ the bfrom link for u.  finally, using the bfrom link for t, we  deduce
smfd 374$ that elmt b3 = set(elmt b4).  this example shows that repr merging has
smfd 375$ to be done transitively, so that b1 and b4 ought  to  be  equivalenced
smfd 376$ once  b2 and b3 are equivalenced, since the merging of b2 and b3 calls
smfd 377$ for the merging of the  reprs  set(elmt b1)  and  set(elmt b4).   this
smfd 378$ additional merge must also be taken care of during the base adjustment
smfd 379$ phase of our algorithm.
smfd 380$
smfd 381$
smfd 382$ (4) if, after merging, all the effective  bases  in  some  equivalence
smfd 383$ class  of  bases support occurrences of only one composite object, all
smfd 384$ the bases in this class should be  suppressed.   this  remark  applies
smfd 385$ also to the case in which the class contains no effective bases.
smfd 386$
smfd 387$
smfd 388$ (5) a delicate issue  arising  in  previous  automatic  data-structure
smfd 389$ selection algorithms was the insertion of 'locate' operations into the
smfd 390$ code being processed.  these  operations  compute  base  pointers  for
smfd 391$ elements of a base, inserting them into the base when necessary.  this
smfd 392$ problem is still delicate, but we have shifted it to the  (subsequent)
smfd 393$ conversion optimisation phase of the optimiser, where it is treated as
smfd 394$ a special case of a general conversion insertion  algorithm.   we  can
smfd 395$ therefore  ignore  this  problem  completely in the present algorithm,
smfd 396$ simplifying the algorithm considerably.
smfd 397$
smfd 398$
smfd 399$ (6) in our original design of this  algorithm  we  determined  refined
smfd 400$ representations  (such  as  local,  remote, and sparse) during a final
smfd 401$ phase of our algorithm.  our experience, however, has shown  that  the
smfd 402$ selection of set-types (i.e. local, remote, and sparse) as well as the
smfd 403$ selection of map-types (i.e. single-valued map  v.  multi-valued  map)
smfd 404$ can  be  done  naturally  during the pre-pass and the subsequent merge
smfd 405$ phase.  our algorithm now selects during the pre-pass appropriate set-
smfd 406$ and  map-types  (where  applicable),  and our merge phase merges these
smfd 407$ attributes while it merges the base element modes.
smfd 408$
smfd 409
smfd 410$ global variables and abstract data structures of the algorithm
smfd 411$ ------ --------- --- -------- ---- ---------- -- --- ---------
smfd 412
smfd 413$ the above remarks suggest a  rather  simple  automatic  data-structure
smfd 414$ selection algorithm.  the detailed algorithm is given below.
smfd 415$
smfd 416$ the input to this algorithm consists of the data flow maps  bfrom  and
smfd 417$ ffrom,  and  the  type  map typ, which gives the computed type of each
smfd 418$ variable occurrence.
smfd 419$
smfd 420$ the output of the algorithm is  another  map  on  occurrences,  called
smfd 421$ oi_repr,  mapping  each occurrence to a suggested repr.  note that the
smfd 422$ actual form of repred variables is not modified until  the  subsequent
smfd 423$ name-splitting phase.
smfd 424$
smfd 425$ during  automatic  data-structure  selection,  reprs  are  treated  as
smfd 426$ extended  type descriptors.  more precisely, each repr is (at least) a
smfd 427$ four component tuple having the form
smfd 428$
smfd 429$   rpr := [ grosstyp(rpr): set(elmt basic_types, including t_elmt),
smfd 430$	     comptyp(rpr):  repr,
smfd 431$	     is_knt:	    boolean,
smfd 432$	     is_based:	    boolean ]
smfd 433$
smfd 434$ set types (i.e. sets and maps) have a fifth component  indicating  the
smfd 435$ basing  type  (i.e.  local,  remote, or sparse) that should be used if
smfd 436$ this set type becomes a based type.  map  types  in  addition  have  a
smfd 437$ sixth component indicating whether  this map  is  definitively single-
smfd 438$ valued (e.g. f in f(x) which is only defined for  single-valued maps),
smfd 439$ definitively multi-valued (e.g. f in f{x}), or whether we don't know
smfd 440$ so far.
smfd 441$
smfd 442$ note that a repr is represented in much the same way as  a  type,  but
smfd 443$ may  involve  the  additional  gross  type element_of_base (denoted by
smfd 444$ t_elmt) whose component type is the base name.  (see the  type  finder
smfd 445$ for additional information concerning the representation of types).
     291$
     292    const      $  auxiliary repr mnemonics
     293	based = 1, unbased = om;
     294
     295    macro base_of(rpr);	rpr(2)					endm;
     296
     297
     298$ the following global variables are used in this phase:
     299
     300    var
     301	bases,		$ set of all generated bases
     302	repbase,	$ maps each base to its representative base
     303	nbases,		$ maps each representative base to number of
     304			$  bases in its eqivalence class
     305	is_effective,	$ maps each base to an effectiveness indicator
     306	basedoccs,	$ set of all (tentatively) based occurrences
     307	aux_repr;	$ maps each occurrence to its (tentative) repr
     308
     309$ additional various global variables, constants and macros are:
     310
     311    const    $ various tuples of argument indices
     312	tup1   = [ 1 ],
     313	tup2   = [ 2 ],
     314	tup3   = [ 3 ],
     315	tup12  = [ 1, 2 ],
     316	tup13  = [ 1, 3 ],
     317	tup14  = [ 1, 4 ],
     318	tup23  = [ 2, 3 ],
     319	tup123 = [ 1, 2, 3 ],
     320	tup124 = [ 1, 2, 4 ],
     321	tup134 = [ 1, 3, 4 ];
     322
     323    const   $ various gross types
     324	grsset  = { t_set },
     325	grsmap  = { t_map },
     326	grstup  = { t_tuple },
     327	grselmt = { t_elmt };
     328
     329    macro based_pair(ebx, eby);
     330	[ grstup, [ ebx, eby ], true, based ]
     331    endm;
     332
     333    macro basedtup(eb);
     334	[ grstup, eb, false, based ]
     335    endm;
     336
     337    macro basedknt(c);
     338	[ grstup, c, true, based ]
     339    endm;
     340
     341    macro basedset(eb);
     342	[ grsset, eb, om, based ]
     343    endm;
     344
     345    macro basedmap(eb);
     346	[ grsmap, eb, false, based ]
     347    endm;
     348
     349    macro based_map(ebx, eby);
     350	[ grsmap, based_pair(ebx, eby), om, based ]
     351    endm;
     352
     353    var
     354	workpile,	$ used for repr merging
     355	ins,		$ current instruction during base generation
     356	argsi,		$ args of current instruction
     357	droppables,	$ set of all non-effective bases
     358	seendrops;	$ set of all non-effective bases which had all
     359			$ non-effective bases in their element mode
     360			$ (recursively) replaced by the respective
     361			$ element mode of the non-effective base.
     362
     363
     364    repr
     365	bases:			remote set(tent_base);
     366	droppables:		remote set(tent_base);
     367	seendrops:		remote set(tent_base);
     368	repbase:		remote smap(tent_base) tent_base;
     369	nbases:			remote smap(tent_base) integer;
     370	is_effective:		remote smap(tent_base) general;
     371	basedoccs:		remote set(occurrence);
     372	aux_repr:		remote smap(occurrence) elmt types;
     373	ins:			elmt insts;
     374	argsi:			tuple(symbol);
     375	workpile:		set(tuple(elmt types, elmt types));
     376	grselmt:		gross_type;
     377	grstup:			gross_type;
     378	grsset, grsmap:		gross_type;
     379	tup1, tup2, tup3:	tuple(integer);
     380	tup12, tup13, tup14:	tuple(integer);
     381	tup23:			tuple(integer);
     382	tup123, tup124, tup134:	tuple(integer);
     383	basegen:		procedure;
     384	genbases:		procedure;
     385	genabase:		procedure(
     386				  elmt types,
     387				  tuple(integer),
     388				  tuple(integer)    )
     389				    elmt types;
     390	maxscope:		procedure(tuple(elmt base_scopes))
     391				    elmt base_scopes;
     392	basemerge:		procedure;
     393	equibase:		procedure(tent_base, tent_base);
     394	.lim:			operator(tent_base) tent_base;
     395	baseadjust:		procedure;
     396	fancy_output:		procedure;
     397	real_repr:		procedure(elmt types) elmt types;
     398    end repr;
     399
     400
     401
     402    procedure auto_data;
     403$
     404$ this is the main driving routine of our algorithm. it consists
     405$ of calls to the various phases of the algorithm.
     406$
     411    title('cims.setl.' + prog_level + ' - data structure choice');
     412    printa(term_file, '   - data structure selection');
     413
     416    basegen;		$ the base generation pre-pass.
     417    basemerge;		$ the base merging phase.
     418    baseadjust;		$ the base and repr adjustment phase.
     419
     420    $ delete the static variables global to the module
     421    bases := om;        repbase := om;      nbases := om;
     422    is_effective := om; basedoccs := om;    aux_repr := om;
     423    workpile := om;     ins := om;          argsi := om;
     424    seendrops := om;	droppables := om;
     425
     426    statistics with:= time;	$ save time for final statistics
     431
     432
     433    end procedure auto_data;
     434
     435
       1 .=member bgn15a
       2
       3
smfd 446
smfd 447$ 1. the base generation pre-pass
smfd 448$ -- --- ---- ---------- --------
smfd 449
smfd 450$ during this phase  we  iterate  through  the  code,  generating  bases
smfd 451$ whenever  appropriate.   these  bases  are linked across instructions,
smfd 452$ subject to constraints determined by the types of the i-variables  and
smfd 453$ the  instruction.  the output of this phase is the map aux_repr, which
smfd 454$ maps occurrences into (based) reprs.
smfd 455$
smfd 456$ for each instruction ins generate bases as  described  in  (1)  above.
smfd 457$ this  is  done  in a manner depending on the opcode of the instruction
smfd 458$ ins and on the type of its arguments.  for  each  base  generated,  we
smfd 459$ compute  the  form  of its elements from the types of the arguments of
smfd 460$ ins, modify the aux_repr map of the based arguments of ins to show the
smfd 461$ appropriate based representations, and classify each generated base as
smfd 462$ effective or neutral.
smfd 463$
smfd 464$ the following instructions are relevant:
smfd 465$
smfd 466$	q1_in,      q1_notin,   q1_incs,    q1_eq,      q1_ne,
smfd 467$	q1_add,     q1_sub,     q1_mult,    q1_mod,
smfd 468$	q1_with,    q1_less,    q1_lessb,   q1_lesse,   q1_lessf,
smfd 469$	q1_arb,     q1_arbb,    q1_arbe,    q1_dom,     q1_range,
smfd 470$	q1_set,     q1_set1,    q1_tup,     q1_tup1,
smfd 471$	q1_inext,   q1_next,    q1_inextd,  q1_nextd,
smfd 472$	q1_of,      q1_ofa,     q1_subst,   q1_end,
smfd 473$	q1_sof,     q1_sofa,    q1_ssubst,  q1_send,
smfd 474$	q1_asn,     q1_argin,   q1_argout
smfd 475$
smfd 476$ these opcodes generate bases linked across the  instruction  if  their
smfd 477$ argument  types satisfy specific constraints.  otherwise, they use the
smfd 478$ same heuristic  the  remaining  opcodes  use,  namely  that  for  each
smfd 479$ occurrence voi we generate a neutral base which supports only voi.  we
smfd 480$ do this so that basing informations are propagated across a program as
smfd 481$ much  as  possible,  reducing  the  risk of repeated conversions which
smfd 482$ might be needed otherwise, as the following example shows:
smfd 483$
smfd 484$	(1)	s := {};		$ s1: set(elmt b1)
smfd 485$		(while ...)
smfd 486$		    read(x);
smfd 487$	(2)	    if x in s then	$ s2: elmt b2
smfd 488$	(3)		s with:= 2*x;	$ s3: set(elmt b3)
smfd 489$		    end if;
smfd 490$		end while;
smfd 491$
smfd 492$ in this  case,  basing  s2  as  shown  will  finally  base  all  three
smfd 493$ occurrences  of  s  as  set(elmt b), for some base b, but will not add
smfd 494$ input values of x to b, which will force hashing in  instruction  (2).
smfd 495$
smfd 496$ this  will keep b as small as possible.  the other alternative, namely
smfd 497$ to leave s2 unbased, is much worse, as it forces a repeated conversion
smfd 498$ between  the  based and unbased forms of s.  (note that in instruction
smfd 499$ (2) x has the type general, while s has  the  type  set(integer).   in
smfd 500$ this  case,  our heuristic principle for the q1_in instruction forbids
smfd 501$ common basing of x and s in this instruction).
smfd 502$
       6
       7    procedure basegen;
       8$
       9$ this procedure iterates through the code, generating bases whenever
      10$ appropriate.  it builds up initial versions of various maps on bases
      11$ and occurences.
      12$
      13    repr
      14	vo:			occurrence;
      15	tp:			elmt types;
      16	r:			routine;
      17	b:			elmt blocks;
      18    end repr;
      19
      20
      21    aux_repr := typ;	$ maps occurrences to tentively based types:
      22    			$ start with the known (unbased) types of
      23			$ variable occurences, the result of the
      24			$ type finder.
      25    bases := {};	$ set of all bases
      26    elmt_mode := {};	$ a map from bases to their element-mode.
      27    bscope := {};	$ a map from bases to their scope.
      28    userbase := {};	$ a map which sends each base to an
      29			$ equivalent user-supplied base (if any).
      30    is_effective := {}; $ an effectiveness indicator for bases, which
      31			$ can have three kinds of values:
      32			$ (i)	'neutral', if the base is neutral.
      33			$ (ii)	a variable name v, if the base is
      34			$	effective, but the only composite object
      35			$	(set or map) it supports is v.
      36			$ (iii) 'effective', if at least two composite
      37			$       objects are effectively supported by
      38			$	the base.
      39    basedoccs := {};	$ set of all based occurences
      40			$ (see section 'scopes of bases' above)
      41
      42$$$ ???? for efficiency, may want to do a.d.s. for each procedure
      43$$$ ???? separately.  this will, however, complicate the logic of the
      44$$$ ???? following algorithm, and so this possibility is ignored in the
      45$$$ ???? current code
      46
      47    if 'y' in dump_string then
      48	print('  -  base generation phase');
      49    end if;
      50
      51    (forall r in routs)
      52	(for_block(b, r))
      53	    (for_inst(ins, b))
      54		genbases;
      55
      56$ for each instruction ins generate bases as described in (1) above.
      57$ this is done in a manner depending on the opcode of the instruction
      58$ ins and on the type of its arguments.  for each base generated, we
      59$ compute the form of its elements from the types of the arguments of
      60$ ins, modify the aux_repr map of the based arguments of ins to show
      61$ the appropriate based representations, and classify each generated
      62$ as effective or neutral.
      63
      64	    end;	$ end for_inst;
      65	end;		$ end for_block;
      66    end forall;
      67
      68    end procedure basegen;
      69
      70
       1 .=member gnb15b
       2
       3
       4    procedure genbases;
       5$
       6$ this routine analyzes an instruction ins, generates initial bases for
       7$ ins, and sets up appropriate basings for the occurences in ins.  this
       8$ is done using a case statement involving the opcode of ins and the
       9$ types of its arguments.
      10$
      11$ this routine uses an auxiliary routine genabase to generate a new base
      12$ (i.e. a new atom) and to update various maps related to all tentative
      13$ bases (e.g. the set of all bases, bases, and the set of all based
      14$ occurrences, basedoccs).  it takes as arguments the element mode of
      15$ the base to be generated, plus a tuple of integers indicating which
      16$ arguments of the current instruction ins are to be supported by this
      17$ base, plus a tuple of integers indicating which arguments are
      18$ supported effectively (i.e. composite objects such as sets or maps for
      19$ which the introduction of the base would eliminate a hashing
      20$ operation).
      21$
      22    macro locspr_of(b);	set_type(elmt_mode(base_of(b)))		endm;
      23    macro maptyp_of(b);	map_type(elmt_mode(base_of(b)))		endm;
      24
      25
      26    repr
      27	j:			integer 0..65536;
      28	v:			symbol;
      29	ivs:			tuple(occurrence);
      30	tps:			tuple(elmt types);
      31 	grtps:			tuple(gross_type);
      32	vo1, vo2, vo3, vo4:	occurrence;
      33	i:			occurrence;
      34	typ1, typ2, typ3, typ4:	elmt types;
      35	g1, g2, g3, g4:		gross_type;
      36	opc:			elmt base_opcodes;
      37	jbig, jsml, k, q:	integer;
      38	comps2, comps3, bcomps2, bcomps3,
      39	comps:			tuple(elmt types);
      40	ind:			integer;
      41	tp, tpc, tpx:		elmt types;
      42	voj:			occurrence;
      43	typj:			elmt types;
      44	tupj:			tuple(integer);
      45	ebx, eby, ebz,
      46	eb, eb1, eb2, eb3:	elmt types;
      47    end repr;
      48
      49    opc   := opcode(ins);
      50    argsi := args(ins);
      51    ivs   := [ get_oi(ins, j) :
      52		    j in [ 1..#argsi ] | get_oi(ins, j) in all_oi ];
      53    tps   := [ typ(i) : i in ivs ];
      54    grtps := [ grosstyp(tp) : tp in tps ];
      55
      56    [ vo1, vo2, vo3 ] := ivs;
      57    [ typ1, typ2, typ3 ] := tps;
      58    [ g1, g2, g3 ] := grtps;
      59
     100    case opc of
     101
     102    (q1_with, q1_less):
     103
     104	case g1 of
     105
     106	(grsmap):
     107
     108$ it follows from the logic of the type finder that in this case
     109$ both vo1 and vo2 are maps and vo3 is a pair.
     110$ in this case we generate two bases for ins; one for the domain
     111$ and one for the image of these maps.
     112$ i.e. if 'ins' is 'f := g with p' then we interpret it as something
     113$ like 'f := g; f{p(1)} with:= p(2);'. this means that ins would
     114$ ordinarily be executed using two hashing operations. nevertheless,
     115$ only the domain base is assumed to be effective, as we suspect
     116$ that the range of these maps will tend to be sparse over its
     117$ would-be base.
     118	    if typ1 = typ2 and typ3 = comptyp(typ1) then
     119
     120		$ nb. only the first two arguments are effectively
     121		$ supported by the domain base ebx.
     122		ebx := genabase(domtyp(typ1),   tup123, tup12);
     123		eby := genabase(rangetyp(typ1), tup123, []   );
     124
     125		if opc = q1_with then
     126		    $ ebz is the range set type for the multi-valued map
     127		    ebz := genabase(basedset(eby), [], []);
     128		    locspr_of(ebz) := sprse;
     129
     130		    eb1 := genabase(based_map(ebx, ebz), [], []);
     131		    maptyp_of(eb1) := ft_mmap;
     132		else    $ opc = q1_less
     133		    eb1 := genabase(based_map(ebx, eby), [], []);
     134		    maptyp_of(eb1) := ft_map;
     135		end if;
     136
     137		$ if ov = iv1, then local basing is advantageous,
     138		$ and we link the two (neutral) bases to reduce the
     139		$ chance that a conversion might be required.
     140		$ otherwise, a value transfer between ov and iv1 takes
     141		$ place, and local basing would require a full conver-
     142		$ sion.  hence remote basing is more advantageous.
     143		if argsi(1) = argsi(2) then
     144		    locspr_of(eb1) := locl;
     145
     146		    eb2 := eb1;
     147
     148		else
     149		    locspr_of(eb1) := remt;
     150
     151		    eb2 := genabase(based_map(ebx, eby), [], []);
     152		    locspr_of(eb2) := remt;
     153		    maptyp_of(eb2) := ft_map;
     154		end if;
     155
     156		aux_repr(vo1) := eb1;
     157		aux_repr(vo2) := eb2;
     158		aux_repr(vo3) := based_pair(ebx, eby);
     159	    end if;
     160
     161	(grsset):
     162
     163	    if typ1 = typ2 and comptyp(typ1) = typ3 then
     164
     165		ebx := genabase(typ3, tup123, tup12);
     166
     167		if argsi(1) = argsi(2) then
     168		    eb1 := genabase(basedset(ebx), [], []);
     169		    locspr_of(eb1) := locl;
     170
     171		    eb2 := eb1;
     172
     173		else
     174		    eb1 := genabase(basedset(ebx), [], []);
     175		    locspr_of(eb1) := remt;
     176
     177		    eb2 := genabase(basedset(ebx), [], []);
     178		    locspr_of(eb2) := remt;
     179		end if;
     180
     181		aux_repr(vo1) := eb1;
     182		aux_repr(vo2) := eb2;
     183		aux_repr(vo3) := ebx;
     184	    end if;
     185
     186	(grstup):
     187
     188$ generate a neutral base (several bases for known length tuples) and
     189$ make the involved tuples into tuples of elements of this base(s)
     190	    if is_knt(typ1) then
     191
     192$ find the index of the larger tuple (jbig) and that of the smaller one
     193		jbig := if opc = q1_with then 1 else 2 end;
     194		jsml := 3 - jbig;  $ 1 for less, 2 for with
     195		comps := comptyp(typ(get_oi(ins, jbig)));
     196
     197		if comps(#comps) = typ3 then
     198
     199		    (forall k in [ 1..#comps-1 ])
     200			comps(k) := genabase(comps(k), tup12, []);
     201		    end forall;
     202
     203		    comps(#comps) := aux_repr(vo3) :=
     204			genabase(comps(#comps), [ jbig, 3 ], []);
     205		    aux_repr(get_oi(ins, jbig)) :=
     206			genabase(basedknt(comps), [], []);
     207		    aux_repr(get_oi(ins, jsml)) :=
     208			genabase(
     209			    basedknt(comps(1..#comps-1)),
     210			    [],
     211			    []    );
     212
     213		end if;
     214
     215	    else  $ homogeneous tuple
     216
     217		if typ1 = typ2 and typ3 = comptyp(typ1) then
     218
     219		    ebx := genabase(typ3, tup123, []);
     220
     221		    aux_repr(vo1) := genabase(basedtup(ebx),[],[]);
     222		    aux_repr(vo2) := genabase(basedtup(ebx),[],[]);
     223		    aux_repr(vo3) := ebx;
     224
     225		end if;
     226	    end if;
     227	end case;
     228
     229
     230    (q1_lessb, q1_lesse):	$ a1 := a2 less a3;   a2 must be a tuple
     231
     232	if grosstyp(typ2) = grstup then
     233	    if is_knt(typ2) then
     234		comps2 := comptyp(typ2);
     235		if forall tpc in comps2 | tpc = typ3 then
     236		    ebx := genabase(typ3, tup123, []);
     237
     238		    eb1 := genabase(
     239			    basedknt( [ ebx : j in [ 1..#comps-1 ] ] ),
     240			    [],
     241			    []    );
     242		    eb2 := genabase(
     243			    basedknt( [ ebx : j in [ 1..#comps ] ] ),
     244			    [],
     245			    []    );
     246
     247		    aux_repr(vo1) := eb1;
     248		    aux_repr(vo2) := eb2;
     249		    aux_repr(vo3) := ebx;
     250		end if;
     251	    else
     252		ebx := genabase(typ3, tup123, []);
     253		eb1 := genabase(basedtup(ebx), [], []);
     254
     255		aux_repr(vo1) := eb1;
     256		aux_repr(vo2) := eb1;
     257		aux_repr(vo3) := ebx;
     258	    end if;
     259	end if;
     260
     261
     262    (q1_lessf):
     263
     264	if grosstyp(typ1) = grsmap and
     265		typ1 = typ2 and domtyp(typ1) = typ3 then
     266
     267	    ebx := genabase(domtyp(typ1),   tup123, tup12);
     268	    eby := genabase(rangetyp(typ1), tup12,  []   );
     269
     270	    if argsi(1) = argsi(2) then
     271		eb1 := genabase(based_map(ebx, eby), [], []);
     272		locspr_of(eb1) := locl;
     273		maptyp_of(eb1) := ft_map;
     274
     275		eb2 := eb1;
     276
     277	    else
     278		eb1 := genabase(based_map(ebx, eby), [], []);
     279		locspr_of(eb1) := remt;
     280		maptyp_of(eb1) := ft_map;
     281
     282		eb2 := genabase(based_map(ebx, eby), [], []);
     283		locspr_of(eb2) := remt;
     284		maptyp_of(eb2) := ft_map;
     285	    end if;
     286
     287	    aux_repr(vo1) := eb1;
     288	    aux_repr(vo2) := eb2;
     289	    aux_repr(vo3) := ebx;
     290	end if;
     291
     292    (q1_of):		$ a1 := a2(a3)
     293
     294$ here a2 is a map or tuple (or char. string, which case we ignore
     295$ since it has no consequences for basing)
     296
     297	case g2 of
     298
     299	(grsmap):
     300
     301	    if domtyp(typ2) = typ3 and rangetyp(typ2) = typ1 then
     302
     303		ebx := genabase(domtyp(typ2),   tup23, tup2);
     304		eby := genabase(rangetyp(typ2), tup12, []  );
     305
     306		eb2 := genabase(based_map(ebx, eby), [], []);
     307		locspr_of(eb2) := locl;
     308		maptyp_of(eb2) := ft_smap;
     309
     310		aux_repr(vo1) := eby;
     311		aux_repr(vo2) := eb2;
     312		aux_repr(vo3) := ebx;
     313	    end if;
     314
     315	(grstup) :
     316	    if is_knt(typ2) then
     317
     318		comps := comptyp(typ2);
     319
     320		if is_const(arg3(ins))=1 then
     321
     322		    ind := value(arg3(ins));
     323
     324		    if 1 <= ind and ind <= #comps then
     325
     326			if typ1 = comps(ind) then
     327
     328$ here a2 is a known length tuple and a3 is an integer constant
     329$ falling within range of a2. we generate one base for each
     330$ component of a2, and construct the appropriate basings. the base
     331$ for the component being retrieved is used also to base a1.
     332			    aux_repr(vo1) := comps(ind) :=
     333				genabase(typ1, tup12, []);
     334
     335			    (forall j in [ 1..#comps ] | j /= ind)
     336				comps(j) :=
     337				    genabase(comps(j), tup2, []);
     338			    end forall;
     339
     340			    aux_repr(vo2) :=
     341				genabase(basedknt(comps), [], []);
     342
     343			end if;
     344
     345		    end if;
     346
     347		else
     348
     349$ mixed tuple with non-constant index; meaningful basings can
     350$ still be generated, provided that all components of a2 have
     351$ the same type.
     352		    if (forall tpc = comps(j) | tpc = typ1) then
     353			ebx := genabase(typ1, tup12, []);
     354			aux_repr(vo1) := ebx;
     355			aux_repr(vo2) :=
     356			    basedknt( [ ebx : q in [1..#comps] ] );
     357		    end if;
     358		end if;
     359	    else   $ homogeneous tuple
     360
     361		if typ1 = comptyp(typ2) then
     362
     363		    ebx := genabase(typ1, tup12, []);
     364		    aux_repr(vo1) := ebx;
     365		    aux_repr(vo2) := basedtup(ebx);
     366
     367		end if;
     368
     369	    end if;
     370
     371	end case;
     372
     373    (q1_sof):      $ f(a2) := a3; a4 is f before this operation
     374		   $ and a1 is f afterwards.
     375
     376$ here a1,a4 are maps or tuples (or char. strings, which case we ignore
     377$ since it has no consequences for basing)
     378
     379	vo4 := ivs(4); typ4 := tps(4);
     380
     381	case g1 of
     382
     383	(grsmap):
     384
     385	    if domtyp(typ1) = typ2	    and
     386		    rangetyp(typ1) = typ3   and
     387		    typ1 = typ4			then
     388
     389		ebx := genabase(domtyp(typ1),   tup124, tup14);
     390		eby := genabase(rangetyp(typ1), tup134, []   );
     391
     392		eb1 := genabase(based_map(ebx, eby), [], []);
     393		locspr_of(eb1) := locl;
     394		maptyp_of(eb1) := ft_smap;
     395
     396		aux_repr(vo1) := aux_repr(vo4) := eb1;
     397		aux_repr(vo2) := ebx;
     398		aux_repr(vo3) := eby;
     399
     400	    else
     401		$ there is no conversion possible between a1 and a4:
     402		$ make sure that this does not happen by linking their
     403		$ neutral bases.
     404		ebx := genabase(domtyp(typ1),   tup14, tup14);
     405		eby := genabase(rangetyp(typ1), tup14, []   );
     406
     407		eb1 := genabase(based_map(ebx, eby), [], []);
     408		locspr_of(eb1) := locl;
     409		maptyp_of(eb1) := ft_smap;
     410
     411		aux_repr(vo1) := eb1;
     412		aux_repr(vo4) := eb1;
     413
     414	    end if;
     415
     416	(grstup):
     417
     418	    if is_knt(typ1) and typ1 = typ4 then
     419
     420		comps := comptyp(typ1);
     421
     422		if is_const(arg2(ins))=1 then
     423
     424		    $ mixed tuple with constant index:  meaningful
     425		    $ basings can be generated if the index is in range.
     426
     427		    ind := value(arg2(ins));
     428
     429		    if 1 <= ind and ind <= #comps and
     430			    typ3 = comps(ind)		then
     431
     432			(forall j in [ 1..#comps ] | j /= ind)
     433			    comps(j) := genabase(comps(j), tup14, []);
     434			end forall;
     435
     436			ebx := genabase(typ3, tup134, []);
     437			comps(ind) := ebx;
     438
     439			eb1 := genabase(basedknt(comps), [], []);
     440
     441			aux_repr(vo1) := eb1;
     442			aux_repr(vo3) := ebx;
     443			aux_repr(vo4) := eb1;
     444		    end if;
     445
     446		else
     447		    $ mixed tuple with non-constant index:  meaningful
     448		    $ basings can still be generated, provided that all
     449		    $ components of a1 have the same type.
     450
     451		    if (forall tpc = comps(j) | tpc = typ3) then
     452			ebx := genabase(typ3, tup134, []);
     453			eb1 := genabase(
     454				basedknt([ ebx : q in [ 1..#comps ] ]),
     455				[], []);
     456			aux_repr(vo1) := eb1;
     457			aux_repr(vo3) := ebx;
     458			aux_repr(vo4) := eb1;
     459		    end if;
     460		end if;
     461
     462	    elseif typ1 = typ4 then   $ homogeneous tuple
     463
     464		if typ3 = comptyp(typ1) then
     465		    ebx := genabase(typ3, tup134, []);
     466		    eb1 := genabase(basedtup(ebx), [], []);
     467
     468		    aux_repr(vo1) := eb1;
     469		    aux_repr(vo3) := ebx;
     470 		    aux_repr(vo4) := eb1;
     471		end if;
     472
     473	    end if;
     474
     475	end case;
     476
     477    (q1_ofa):			$ a1 := a2{a3};   a2 must be a map
     478
     479	    if grosstyp(typ2) = grsmap and
     480		    domtyp(typ2) = typ3 and
     481		    rangetyp(typ2) = comptyp(typ1) then
     482
     483		ebx := genabase(domtyp(typ2),   tup23, tup23);
     484		eby := genabase(rangetyp(typ2), tup12, []   );
     485
     486		$ ebz is the range set type of the multi-valued map.
     487		ebz := genabase(basedset(eby),  [],    []   );
     488		locspr_of(ebz) := sprse;
     489
     490		eb2 := genabase(based_map(ebx, ebz), [], []);
     491		locspr_of(eb2) := locl;
     492		maptyp_of(eb2) := ft_mmap;
     493
     494		aux_repr(vo1) := ebz;
     495		aux_repr(vo2) := eb2;
     496		aux_repr(vo3) := ebx;
     497	    end if;
     498
     499
     500    (q1_sofa):			$ a1{a2} := a3;   a4 is the input a1
     501
     502	typ4 := tps(4);   vo4 := ivs(4);
     503
smfd 503	if grosstyp(typ1) = grsmap then
smfd 504	    if typ1 = typ4 and domtyp(typ1) = typ2 and
smfd 505		    rangetyp(typ1) = comptyp(typ3)	then
smfd 506
smfd 507		ebx := genabase(domtyp(typ1),   tup124, tup14);
smfd 508		eby := genabase(rangetyp(typ1), tup134, []   );
smfd 509
smfd 510		$ ebz is the range set type of the multi-valued map.
smfd 511		ebz := genabase(basedset(eby),  [],     []   );
smfd 512		locspr_of(ebz) := sprse;
smfd 513
smfd 514		eb1 := genabase(based_map(ebx, ebz), [], []);
smfd 515		locspr_of(eb1) := locl;
smfd 516		maptyp_of(eb1) := ft_mmap;
smfd 517
smfd 518		aux_repr(vo1) := aux_repr(vo4) := eb1;
smfd 519		aux_repr(vo2) := ebx;
smfd 520		aux_repr(vo3) := ebz;
smfd 521
smfd 522	    else
smfd 523		$ there is no conversion possible between a1 and a4:
smfd 524		$ make sure that this does not happen by linking their
smfd 525		$ neutral bases.
smfd 526		ebx := genabase(domtyp(typ1),   tup14, tup14);
smfd 527		eby := genabase(rangetyp(typ1), tup14, []   );
smfd 528
smfd 529		eb1 := genabase(based_map(ebx, eby), [], []);
smfd 530		locspr_of(eb1) := locl;
smfd 531		maptyp_of(eb1) := ft_mmap;
smfd 532
smfd 533		aux_repr(vo1) := aux_repr(vo4) := eb1;
smfd 534	    end if;
smfd 535
smfd 536	else
smfd 537	    $ there is some error here, but no conversion is possible
smfd 538	    $ between a1 and a4:  make sure that this does not happen by
smfd 539	    $ linking their neutral bases.
smfd 540	    eb1 := genabase(typ1, tup14, []);
smfd 541	    aux_repr(vo1) := aux_repr(vo4) := eb1;
smfd 542	end if;
     537
     538
     539    (q1_in, q1_notin):		$ a1 := (a2 in a3);  (or notin)
     540
     541	case g3 of
     542
     543	(grsset) :
     544
     545	    if typ2 = comptyp(typ3) then
     546		ebx := genabase(typ2, tup23, tup3);
     547
     548		eb3 := genabase(basedset(ebx), [], []);
     549		locspr_of(eb3) := locl;
     550
     551	    else
     552		ebx := genabase(typ2, tup2, []);
     553
     554		eb3 := genabase(typ3, tup3, []);
     555		locspr_of(eb3) := locl;
     556	    end if;
     557
     558	    aux_repr(vo2) := ebx;
     559	    aux_repr(vo3) := eb3;
     560
     561	(grsmap):
     562$ the test 'a2 in a3' is in this case a test of 'pair in map'
     563$ which suggests introduction of two bases, an effective base
     564$ b and a neutral base b1, and repr a2 as tuple(elmt b, elmt b1)
     565$ and a3 as a map (elmt b) elmt b1.
     566	    if typ2 = comptyp(typ3) then
     567
     568		ebx := genabase(domtyp(typ3),   tup23, tup3);
     569		eby := genabase(rangetyp(typ3), tup23, []  );
     570
     571		eb2 := genabase(based_pair(ebx, eby), [], []);
     572
     573		eb3 := genabase(based_map(ebx, eby), [], []);
     574		locspr_of(eb3) := locl;
     575		maptyp_of(eb3) := ft_map;
     576
     577		aux_repr(vo2) := eb2;
     578		aux_repr(vo3) := eb3;
     579
     580	    end if;
     581
     582	end case;
     583
     584
     585    (q1_asn, q1_argin):		$ a1 := a2;
     586				$ formal parameter := actual parameter;
     587	if typ1 = typ2 then	$ link the bases
     588	    eb1 := genabase(typ1, tup12, []);
     589	    eb2 := eb1;
     590	else	$ still check for nullset/nullmap assignments
     591	    eb1 := genabase(typ1, tup1,  []);
     592	    eb2 := om;
     593	end if;
     594
     595	if is_const(v := oi_sym(vo2))=1 and value(v) = {} then
     596	    $ nullset or nullmap
     597	    locspr_of(eb1) := if opc=q1_asn then neutrl else sprse end;
     598	    if grosstyp(typ1) = grsmap then
     599		maptyp_of(eb1) := ft_smap;
     600	    end if;
     601
     602	else
     603	    if grosstyp(typ1) = grsset then
     604		locspr_of(eb1) := sprse;
     605	    end if;
     606	    if grosstyp(typ1) = grsmap then
     607		locspr_of(eb1) := sprse;
     608		maptyp_of(eb1) := ft_map;
     609	    end if;
     610	end if;
     611
     612	aux_repr(vo1) := eb1;
     613	aux_repr(vo2) := eb2;
     614
     615    (q1_argout):		$ actual parameter := formal parameter
     616
     617	if typ1 = tps(4) then
     618	    eb1 := genabase(typ1, tup14, []);
     619	    aux_repr(vo1)    := eb1;
     620	    aux_repr(ivs(4)) := eb1;
     621	end if;
     622
     623    (q1_add, q1_sub, q1_mod, q1_mult):	$ a1 := a2 op a3;
     624
     625	case g1 of
     626
     627	(grsset):
     628
     629	    if typ1 = typ2 and typ2 = typ3 then
     630
     631		ebx := genabase(comptyp(typ1), tup123, tup123);
     632
     633		eb1 := genabase(basedset(ebx), [], []);
     634		locspr_of(eb1) := remt;
     635
     636		eb2 := genabase(basedset(ebx), [], []);
     637		locspr_of(eb2) := remt;
     638
     639		eb3 := genabase(basedset(ebx), [], []);
     640		locspr_of(eb3) := remt;
     641
     642		aux_repr(vo1) := eb1;
     643		aux_repr(vo2) := eb2;
     644		aux_repr(vo3) := eb3;
     645	    end if;
     646
     647
     648	(grsmap):
     649
     650	    if typ1 = typ2 and typ2 = typ3 then
     651
     652		ebx := genabase(domtyp(typ1),   tup123, tup123);
     653		eby := genabase(rangetyp(typ1), tup123, []    );
     654
     655		$ ebz is the range set type of the multi-valued map
     656		ebz := genabase(basedset(eby),  [],     []    );
     657		locspr_of(ebz) := sprse;
     658
     659		eb1 := genabase(based_map(ebx, ebz), [], []);
     660		locspr_of(eb1) := remt;
     661		maptyp_of(eb1) := ft_mmap;
     662
     663		eb2 := genabase(based_map(ebx, eby), [], []);
     664		locspr_of(eb2) := remt;
     665		maptyp_of(eb2) := ft_map;
     666
     667		eb3 := genabase(based_map(ebx, eby), [], []);
     668		locspr_of(eb3) := remt;
     669		maptyp_of(eb3) := ft_map;
     670
     671		aux_repr(vo1) := eb1;
     672		aux_repr(vo2) := eb2;
     673		aux_repr(vo3) := eb3;
     674	    end if;
     675
     676
     677	(grstup):
     678	    if opc = q1_add then
     679		if is_knt(typ2) then
     680		    comps2 := comptyp(typ2);
     681		    if is_knt(typ3) then
     682			comps3 := comptyp(typ3);
     683			bcomps2 := [];
     684			bcomps3 := [];
     685			(forall tpc = comps2(j))
     686			     bcomps2 with:= genabase(tpc, tup12,[]);
     687			end forall;
     688			aux_repr(vo2) :=
     689			    genabase(basedknt(bcomps2), [], []);
     690			(forall tpc = comps3(j))
     691			    bcomps3 with:= genabase(tpc, tup13, []);
     692			end forall;
     693			aux_repr(vo3) :=
     694			    genabase(basedknt(bcomps3), [], []);
     695			aux_repr(vo1) :=
     696			    genabase(basedknt(bcomps2 + bcomps3),
     697					[], []);
     698		    else
     699			if (forall tpc = comps2(j) |
     700				tpc = comptyp(typ3)) then
     701			    eb := genabase(comptyp(typ3), tup123, []);
     702			    aux_repr(vo1) := aux_repr(vo3) :=
     703				genabase(basedtup(eb), [], []);
     704			    aux_repr(vo2) :=
     705				genabase( basedknt(
     706				  [ eb : q in [1..#comps2] ]),
     707					[], []);
     708			end if;
     709		    end if;
     710		else
     711		    if is_knt(typ3) then
     712			comps3 := comptyp(typ3);
     713			if (forall tpc = comps3(j) |
     714				tpc = comptyp(typ2) ) then
     715			    eb := genabase(comptyp(typ2),tup123,[]);
     716			    aux_repr(vo1) := aux_repr(vo2) :=
     717				genabase(basedtup(eb), [], []);
     718			    aux_repr(vo3) :=
     719				genabase( basedknt(
     720				  [ eb : q in [1..#comps3] ]),
     721					[], []);
     722			end if;
     723		    else
     724			if (tpc := comptyp(typ2)) = comptyp(typ3) then
     725			    eb := genabase(tpc, tup123, []);
     726			    aux_repr(vo1) := aux_repr(vo2) :=
     727				aux_repr(vo3) :=
     728				    genabase(basedtup(eb), [], []);
     729			end if;
     730		    end if;
     731		end if;
     732	    end if;
     733
     734	end case;
     735
     736    (q1_nextd, q1_inextd):
     737
     738$ iteration over a tuple or a map (or a string, which case we ignore)
     739$ this is not a pro-basing instruction in either case, but neutral
     740$ bases are introduced here to facilitate later basing propagation
     741$ (see the base merging phase for details)
     742
     743	case g3 of
     744
     745	(grsmap):
     746
     747	    ebx := genabase(domtyp(typ3),   tup13, []);
     748	    eby := genabase(rangetyp(typ3), tup3,  []);
     749
     750	    eb3 := genabase(based_map(ebx, eby), [], []);
     751	    locspr_of(eb3) := sprse;
     752	    maptyp_of(eb3) := ft_map;
     753
     754	    aux_repr(vo1) := ebx;
     755	    aux_repr(vo3) := eb3;
     756
     757	(grstup):
     758
     759	    if is_knt(typ3) then
     760		comps := comptyp(typ3);
     761		if (forall tpc = comps(j) | tpc = comps(1)) then
     762		    ebx := genabase(comps(1), tup3, []);
     763
     764		    eb3 := genabase(
     765				basedknt([ ebx : q in [ 1..#comps ] ]),
     766				[],
     767				[]    );
     768
     769		    aux_repr(vo3) := eb3;
     770		end if;
     771	    else
     772		ebx := genabase(comptyp(typ3), tup3, []);
     773		aux_repr(vo3) := basedtup(ebx);
     774	    end if;
     775
     776	end case;
     777
     778    (q1_next, q1_inext):
     779
     780	case g3 of
     781
     782	(grsset):
     783
     784	    ebx := genabase(comptyp(typ3), tup13, []);
     785
     786	    eb3 := genabase(basedset(ebx), [],    []);
     787	    locspr_of(eb3) := sprse;
     788
     789	    aux_repr(vo1) := ebx;
     790	    aux_repr(vo3) := eb3;
     791
     792	(grsmap):
     793
     794	    ebx := genabase(domtyp(typ3),   tup13, []);
     795	    eby := genabase(rangetyp(typ3), tup13, []);
     796
     797	    eb3 := genabase(based_map(ebx, eby),  [], []);
     798	    locspr_of(eb3) := sprse;
     799	    maptyp_of(eb3) := ft_map;
     800
     801	    aux_repr(vo1) := based_pair(ebx, eby);
     802	    aux_repr(vo3) := eb3;
     803
     804	(grstup):
     805
     806	    if is_knt(typ3) then   $ probably rather unlikely
     807		comps := comptyp(typ3);
     808		if (forall tpc = comps(j) | tpc = typ1) then
     809		    ebx := genabase(typ1, tup13, []);
     810
     811		    eb3 := genabase(
     812				basedknt([ ebx : q in [ 1..#comps ] ]),
     813				[],
     814				[]    );
     815
     816		    aux_repr(vo1) := ebx;
     817		    aux_repr(vo3) := eb3;
     818		end if;
     819	    else
     820		ebx := genabase(comptyp(typ3), tup13, []);
     821		aux_repr(vo1) := ebx;
     822		aux_repr(vo3) := basedtup(ebx);
     823	    end if;
     824
     825	end case;
     826
     827	if opc = q1_next and vo1 in basedoccs then
     828	    basedoccs with:= (vo4 := ivs(4));
     829	    aux_repr(vo4) := aux_repr(vo1);
     830	end if;
     831
     832    (q1_set1):			$ iterative set former
     833
     834	case g1 of
     835
     836	(grsset):
     837
     838	    ebx := genabase(typ2, tup12, tup1);
     839
     840	    eb1 := genabase(basedset(ebx), [], []);
     841	    locspr_of(eb1) := neutrl;
     842
     843	    aux_repr(vo1) := eb1;
     844	    aux_repr(vo2) := ebx;
     845
     846	(grsmap):
     847
     848	    ebx := genabase(domtyp(typ1),   tup12, tup1);
     849	    eby := genabase(rangetyp(typ1), tup12, []  );
     850
     851	    $ ebz is the range set type for the multi-valued map.
     852	    ebz := genabase(basedset(eby),  [],    []  );
     853	    locspr_of(ebz) := sprse;
     854
     855	    eb1 := genabase(based_map(ebx, ebz), [], []);
     856	    locspr_of(eb1) := neutrl;
     857	    maptyp_of(eb1) := ft_mmap;
     858
     859	    aux_repr(vo1) := eb1;
     860	    aux_repr(vo2) := based_pair(ebx, eby);
     861
     862	end case;
     863
     864
     865    (q1_tup1):			$ iterative tuple former
     866
     867	ebx := genabase(typ2, tup12, []);
     868	aux_repr(vo1) := basedtup(ebx);
     869	aux_repr(vo2) := ebx;
     870
     871
     872    (q1_dom):			$ a1 := domain a2
     873
     874	if grosstyp(typ2) = grsmap then
     875	    ebx := genabase(domtyp(typ2),   tup12, tup1);
     876	    eby := genabase(rangetyp(typ2), tup12, []  );
     877
     878	    eb1 := genabase(basedset(ebx), [], []);
     879	    locspr_of(eb1) := neutrl;
     880
     881	    eb2 := genabase(based_map(ebx, eby), [], []);
     882	    locspr_of(eb2) := sprse;
     883	    maptyp_of(eb2) := ft_map;
     884
     885	    aux_repr(vo1) := eb1;
     886	    aux_repr(vo2) := eb2;
     887	end if;
     888
     889    (q1_range):			$ a1 := range a2
     890
     891	if grosstyp(typ2) = grsmap then
     892	    ebx := genabase(domtyp(typ2),   tup12, []  );
     893	    eby := genabase(rangetyp(typ2), tup12, tup1);
     894
     895	    eb1 := genabase(basedset(eby), [], []);
     896	    locspr_of(eb1) := neutrl;
     897
     898	    eb2 := genabase(based_map(ebx, eby), [], []);
     899	    locspr_of(eb2) := sprse;
     900	    maptyp_of(eb2) := ft_map;
     901
     902	    aux_repr(vo1) := eb1;
     903	    aux_repr(vo2) := eb2;
     904	end if;
     905
     906    (q1_incs):
     907
     908	if typ2 = typ3 then
     909	    case g2 of
     910
     911	    (grsset):
     912
     913		ebx := genabase(comptyp(typ2), tup23, tup23);
     914
     915		eb2 := genabase(basedset(ebx), [], []);
     916		locspr_of(eb2) := sprse;
     917
     918		eb3 := genabase(basedset(ebx), [], []);
     919		locspr_of(eb3) := locl;
     920
     921		aux_repr(vo2) := eb2;
     922		aux_repr(vo3) := eb3;
     923
     924	    (grsmap):
     925
     926		ebx := genabase(domtyp(typ2),   tup23, tup23);
     927		eby := genabase(rangetyp(typ2), tup23, []   );
     928
     929		eb2 := genabase(based_map(ebx, eby), [], []);
     930		locspr_of(eb2) := sprse;
     931		maptyp_of(eb2) := ft_map;
     932
     933		eb3 := genabase(based_map(ebx, eby), [], []);
     934		locspr_of(eb3) := locl;
     935		maptyp_of(eb3) := ft_map;
     936
     937		aux_repr(vo2) := eb2;
     938		aux_repr(vo3) := eb3;
     939
     940	    end case;
     941	end if;
     942
     943    (q1_arb):
     944
     945	case g2 of
     946
     947	(grsset):
     948
     949	    ebx := genabase(typ1, tup12, []);
     950
     951	    eb2 := genabase(basedset(ebx), [], []);
     952	    locspr_of(eb2) := sprse;
     953
     954	    aux_repr(vo1) := ebx;
     955	    aux_repr(vo2) := eb2;
     956
     957	(grsmap):
     958
     959	    ebx := genabase(domtyp(typ2),   tup12, []);
     960	    eby := genabase(rangetyp(typ2), tup12, []);
     961
     962	    eb1 := genabase(based_pair(ebx, eby), [], []);
     963
     964	    eb2 := genabase(based_map(ebx, eby), [], []);
     965	    locspr_of(eb2) := sprse;
     966	    maptyp_of(eb2) := ft_map;
     967
     968	    aux_repr(vo1) := eb1;
     969	    aux_repr(vo2) := eb2;
     970
     971	end case;
     972
     973
     974    (q1_arbb, q1_arbe):		$ a1 := arb a2;   a2 must be a tuple
     975
     976	if grosstyp(typ2) = grstup then
     977
     978	    if is_knt(typ2) then
     979
     980		comps2 := comptyp(typ2);
     981
     982		if forall tpc in comps2 | tpc = typ1 then
     983		    ebx := genabase(typ1, tup12, []);
     984
     985		    eb2 := genabase(
     986			      basedknt( [ ebx : j in [1..#comps2] ] ),
     987			      [],
     988			      []    );
     989
     990		    aux_repr(vo1) := ebx;
     991		    aux_repr(vo2) := eb2;
     992		end if;
     993
     994	    elseif typ1 = comptyp(typ2) then
     995
     996		ebx := genabase(typ1, tup12, []);
     997		aux_repr(vo1) := ebx;
     998		aux_repr(vo2) := genabase(basedtup(ebx), [], []);
     999
    1000	    end if;
    1001	end if;
    1002
    1003
    1004    (q1_eq, q1_ne):
    1005
    1006	if typ2 = typ3 then
    1007	    eb := genabase(typ2, tup23, []);
    1008	    aux_repr(vo2) := eb;
    1009	    aux_repr(vo3) := eb;
    1010	end if;
    1011
    1012
    1013    (q1_tup):			$ enumerative tuple former
    1014
    1015	if grosstyp(typ1) = grstup then
    1016	    if #ivs = 2 then	$ treat as homogeneous tuple
    1017
    1018		ebx := genabase(typ2, tup12, []);
    1019		aux_repr(vo1) := genabase(basedtup(ebx), [], []);
    1020		aux_repr(vo2) := ebx;
    1021
    1022	    else		$ must be known-length tuple
    1023
    1024		comps := [];
    1025		(forall j in [ 2..#ivs ])
    1026		    voj := ivs(j);
    1027
    1028		    ebx := genabase(tps(j), [ 1, j ], []);
    1029		    comps with:= ebx;
    1030		    aux_repr(voj) := ebx;
    1031		end forall;
    1032
    1033		aux_repr(vo1) := genabase(basedknt(comps), [], []);
    1034	    end if;
    1035	end if;
    1036
    1037
    1038    (q1_set):			$ enumerative set former
    1039
    1040	case g1 of
    1041
    1042	(grsset):
    1043
    1044	    if (forall j in [ 2..#ivs ] |
    1045				tps(j) = comptyp(typ1)) then
    1046		ebx := genabase(comptyp(typ1), [ 1..#ivs ], []);
    1047
    1048		eb1 := genabase(basedset(ebx), [], []);
    1049		locspr_of(eb1) := neutrl;
    1050
    1051		aux_repr(vo1) := eb1;
    1052
    1053		(forall j in [ 2..#ivs ])
    1054		    aux_repr(ivs(j)) := ebx;
    1055		end forall;
    1056	    end if;
    1057
    1058	(grsmap):
    1059	    if (forall j in [ 2..#ivs ] |
    1060				tps(j) = comptyp(typ1)) then
    1061		ebx := genabase(domtyp(typ1),   [ 1..#ivs ], []);
    1062		eby := genabase(rangetyp(typ1), [ 1..#ivs ], []);
    1063
    1064		if #ivs > 2 then
    1065		    $ potentially multi-valued result
    1066		    ebz := genabase(basedset(eby), [], []);
    1067		    locspr_of(ebz) := sprse;
    1068
    1069		    eb1 := genabase(based_map(ebx, ebz), [], []);
    1070		    locspr_of(eb1) := neutrl;
    1071		    maptyp_of(eb1) := ft_mmap;
    1072
    1073		else
    1074		    eb1 := genabase(based_map(ebx, eby), [], []);
    1075		    locspr_of(eb1) := neutrl;
    1076		    maptyp_of(eb1) := ft_smap;
    1077		end if;
    1078
    1079		aux_repr(vo1) := eb1;
    1080
    1081		eb2 := genabase(based_pair(ebx, eby), [], []);
    1082
    1083		(forall j in [ 2..#ivs ])
    1084		    aux_repr(ivs(j)) := eb2;
    1085		end forall;
    1086	    end if;
    1087
    1088	end case;
    1089
    1090    (q1_subst, q1_end, q1_ssubst, q1_send):
    1091	[ voj, typj, tupj ] :=
    1092	    if opc = q1_subst or opc = q1_end then
    1093		[ vo2, typ2, tup12 ]
    1094	    elseif opc = q1_send then
    1095		[ vo3, typ3, tup13 ]
    1096	    else
    1097		[ ivs(4), tps(4), tup14 ]
    1098	    end;
    1099
    1100	if grosstyp(typj) = grstup then
    1101	    if is_knt(typj) then
    1102		comps := comptyp(typj);
    1103		if (forall tpc = comps(j) | tpc = comptyp(typ1)) then
    1104		    eb := genabase(comptyp(typ1), tupj, []);
    1105		    aux_repr(vo1) := genabase(basedtup(eb), [], []);
    1106		    aux_repr(voj) :=
    1107			genabase(
    1108			    basedknt( [ eb : q in [ 1..#comps ] ] ),
    1109			    [],
    1110 			    []    );
    1111		end if;
    1112	    else
    1113		ebx := genabase(comptyp(typj), tupj, []);
    1114
    1115		aux_repr(vo1) := genabase(basedtup(ebx), [], []);
    1116		aux_repr(voj) := genabase(basedtup(ebx), [], []);
    1117	    end if;
    1118	end if;
    1119
    1120
    1121    (q1_case):			$ t := a1(a2); if t /= om then go to t;
    1122
    1123	if grosstyp(typ1) = grsmap and domtyp(typ1) = typ2 then
    1124	    ebx := genabase(typ2,     tup12, tup1);
    1125	    eby := genabase(type_gen, tup1,  []  );
    1126
    1127	    eb1 := genabase(based_map(ebx, eby), [], []);
    1128	    locspr_of(eb1) := remt;
    1129	    maptyp_of(eb1) := ft_smap;
    1130
    1131	    aux_repr(vo1) := eb1;
    1132	    aux_repr(vo2) := ebx;
    1133	end if;
    1134
    1135
    1136    end case;
    1137
    1138$ if no bases have been introduced, we assign a neutral base
    1139$ for each occurrence in the instruction.
    1140
    1141    (forall voj = ivs(j) |
    1142		is_ivar(voj) and
    1143		voj notin basedoccs and is_const(argsi(j)) = om    )
    1144
    1145	eb := genabase((typj := tps(j)), [ j ], []);
    1146
    1147	if t_set in grosstyp(typj) then
    1148	    locspr_of(eb) := neutrl;
    1149	end if;
    1150
    1151	if t_map in grosstyp(typj) then
    1152	    locspr_of(eb) := neutrl;
    1153	    maptyp_of(eb) := ft_map;
    1154	end if;
    1155
    1156	aux_repr(voj) := eb;
    1157    end forall;
    1158
    1159    end procedure genbases;
    1160
    1161
       1 .=member gab15c
       2
       3
       4    procedure genabase(tp, boccs, effoccs);
       5$
       6$ this routine generates a temporary base (= blank atom), with
       7$ 'tp' as its element-mode. 'boccs' is a tuple of indices of
       8$ arguments of the current instruction which are to be based on
       9$ this base, and 'effoccs' is a tuple of indices of arguments
      10$ which are to be effectively based on this base (i.e. composite
      11$ objects for which this base eliminates a hash operation).
      12$
      13    repr
      14	tp:			elmt types;
      15	boccs, effoccs:		tuple(integer);
      16
      17	b:			tent_base;
      18	effvars:		sparse set(symbol);
      19	j:			integer;
      20    end repr;
      21
      22    b := newat;
      23    bases with:= b;
      24    elmt_mode(b) := tp;
      25
      26$ note that at this phase all base element modes are unbased (so
      27$ that the fifth component of 'tp' (= om) need not be changed.
      28
      29$ note additional based occurrences
      30    basedoccs +:= { get_oi(ins, j) : j in boccs};
      31$ note that the current instruction, here called 'ins', is passed
      32$ globally.
      33
      34    bscope(b) := maxscope([scope(argsi(j)) : j in boccs]);
      35    $ (see explanatory section on 'scopes of bases' at the start of
      36    $ this module for more details.)
      37
      38    effvars := {argsi(j) : j in effoccs};
      39    is_effective(b) :=
      40	if     effvars = {} then 'neutral'
      41	elseif #effvars = 1 then arb effvars  $ see preceeding comment
      42	else   'effective' end;  $ on the desired map value in this case
      43
      44    return [ grselmt, b, om, based ];
      45
      46    end procedure genabase;
      47
      48
      49
      50
      51    procedure maxscope(tup_scps);
      52$
      53$ this routine computes the maximal scope in a tuple 'tup_scps'
      54$ of scopes which are contained within each other.
      55$ the following types of scopes can appear together:
      56$ 1. 'sc_proc', 'sc_mod', 'sc_dir'
      57$ 2. 'sc_proc', 'sc_prog', 'sc_dir'
      58$ 3. 'sc_proc', 'sc_lib'
      59$
      60$ see comment 'scopes of bases' above.
      61$
      62    repr
      63	tup_scps:		tuple(elmt base_scopes);
      64
      65	scp:			elmt base_scopes;
      66	maxscp:			elmt base_scopes;
      67    end repr;
      68
      69$ maxscp is the largest containing scope found so far
      70    maxscp := om;
      71
      72    (forall scp in tup_scps | scp /= om)
      73	if maxscp = om  then maxscp := scp;   end if;
      74	if maxscp = scp then continue forall; end if;
      75
      76	case sc_type(scp) of
      77
      78	(sc_sys, sc_lib):		return sym_sys;
      79
      80	(sc_dir, sc_prog, sc_mod):
      81	    case sc_type(maxscp) of
      82	    (sc_sys, sc_lib):		return sym_sys;
      83	    (sc_dir, sc_prog, sc_mod):	maxscp := sym_dir;
      84	    (sc_proc):
      85		$ account for the fact that the main program is part  of
      86		$ the system scope
      87		if maxscp = sym_main then
      88		    maxscp := maxscope( [ sym_prog,      scp ] );
      89		else
      90		    maxscp := maxscope( [ scope(maxscp), scp ] );
      91		end if;
      92	    end case;
      93
      94	(sc_proc):
      95	    $ account for the fact that the main program is part of  the
      96	    $ system scope
      97	    if scp = sym_main then
      98		maxscp := maxscope( [ sym_prog,   maxscp ] );
      99	    else
     100		maxscp := maxscope( [ scope(scp), maxscp ] );
     101	    end if;
     102
     103	end case;
     104    end forall;
     105
     106    return maxscp;
     107
     108    end procedure maxscope;
     109
     110
       1 .=member bsm15d
       2
       3
smfd 543
smfd 544$ 2. base merging and adjustment
smfd 545$ -- ---- ------- --- ----------
smfd 546
smfd 547$ in this phase we merge based reprs of all pairs of occurrences  linked
smfd 548$ by  a  bfrom  link.   this merging operation proceeds approximately as
smfd 549$ follows:
smfd 550$
smfd 551$ let vo and vo1 be two occurrences which have the same type  and  which
smfd 552$ are  linked  by  bfrom.   it  follows  from  the mechanism of the base
smfd 553$ generation pre-pass that any repr rpr generated at this phase can only
smfd 554$ have one of the following three forms:
smfd 555$
smfd 556$ (i)	rpr can be unbased.
smfd 557$
smfd 558$ (ii)	rpr can have the form 'elmt b'.
smfd 559$
smfd 560$ (iii)	rpr can have the form
smfd 561$		composite(elmt b)
smfd 562$			(for sets and homogeneous tuples), or the form
smfd 563$		composite(elmt b1, elmt b2, ..., elmt bn)
smfd 564$			(for maps (then n = 2) and mixed tuples).
smfd 565$
smfd 566$ these initial reprs will not be modified during the base  merging  and
smfd 567$ adjustment  phase.   consequently,  only the following cases can arise
smfd 568$ when merging the reprs of vo and vo1:
smfd 569$
smfd 570$ 1.  if one of these reprs is unbased, do nothing.
smfd 571$
smfd 572$ 2.  if both reprs  are  of  the  second  category,  the  merge  simply
smfd 573$     equivalences  the  corresponding bases.  this equivalencing action
smfd 574$     calls for the merging of the element-modes of the bases, thus repr
smfd 575$     merging is a recursive (or transitive) process.  for more details,
smfd 576$     see below.
smfd 577$
smfd 578$ 3.  if both reprs are of the third  category,  then  their  structures
smfd 579$     must  be  identical, but may possibly involve different bases.  in
smfd 580$     this case the merge equivalences all pairs of corresponding  bases
smfd 581$     in these reprs, as is done in (2)).
smfd 582$
smfd 583$ 4.  if one repr is elmt b, and the other is  of  the  third  category,
smfd 584$     then  if  elmt_mode(b)  is  unbased we replace elmt_mode(b) by the
smfd 585$     second repr, and if elmt_mode(b) is based, we merge  it  with  the
smfd 586$     second  repr  (this is another source of transitive closure in the
smfd 587$     merging process).
smfd 588$
smfd 589$ we use the following implementation:  the set 'bases' of all generated
smfd 590$ bases  is  represented  as a forest in which each equivalence class of
smfd 591$ bases is a tree whose root is the representing base  for  that  class.
smfd 592$ we   can   then   use  a  highly-efficient  compressed  balanced  tree
smfd 593$ representation to  manipulate  this  forest.   for  this  purpose  let
smfd 594$ 'repbase'   denote   the  father  mapping  in  this  forest,  and  let
smfd 595$ repbase .lim b denote the root mapping (see ).  in addition to
smfd 596$ repbase  we  also  maintain  an auxiliary map 'nbases' which maps each
smfd 597$ root of  the  forest  to  its  number  of  descendents,  and  the  map
smfd 598$ 'elmt_mode',  which  has  to be kept only for the roots of the forest.
smfd 599$ since elmt_mode(b) has to be kept iff repbase(b) is  undefined,  these
smfd 600$ two maps can be merged into one, to obtain a compact data-structure.
smfd 601$
smfd 602$ for the suppression of useless bases  we  also  need  to  maintain  an
smfd 603$ 'is_effective' map at the roots of the forest, combining its values at
smfd 604$ the roots of two trees which are to be merged in  order  to  determine
smfd 605$ the  effectivity of the merged tree.  this map can only have the three
smfd 606$ kinds of  values  outlined  above,  and  according  to  our  heuristic
smfd 607$ principle (4), all classes for which is_effective of their root is not
smfd 608$ true will be suppressed in a subsequent phase of our algorithm.
smfd 609$
smfd 610$ essentially, only two operations need to be performed on this forest:
smfd 611$
smfd 612$ 1.  root determination:  to compute the root of a given base, we apply
smfd 613$     the lim operator.  this is explained in , except that here
smfd 614$     the 'virtual forest' mentioned in  can be  identical  with
smfd 615$     the  actual  one, so that path compression can be applied directly
smfd 616$     to repbase.   note,  however,  that  or  treatment  of  map  types
smfd 617$     requires that whenever we merge two map types where one designates
smfd 618$     a multi-valued map and the other does not, the  root  of  the  new
smfd 619$     tree  must  be the multi-valued map type.  this is due to the fact
smfd 620$     that a multi-valued map type carries information about  the  range
smfd 621$     set  type (which also contains information about the range element
smfd 622$     type), while the other map types contain  information  only  about
smfd 623$     the range element type.
smfd 624$
smfd 625$ 2.  base equivalencing:  this is accomplished by a balanced linking of
smfd 626$     two  trees into one, but with the following additional operations:
smfd 627$     (a) the set types of elmt_mode's  are  merged,  according  to  the
smfd 628$     heuristic  outlined  below;   (b)  the  map types of map reprs are
smfd 629$     merged;  and (c) the elmt_mode's of the roots of the linked  trees
smfd 630$     are  merged.   to  perform  this  latter  operation we may have to
smfd 631$     update the elmt_mode of the  new  root.   this  is  required  when
smfd 632$     elmt_mode(root  of  larger tree) is unbased, and elmt_mode(root of
smfd 633$     smaller tree) is based.  in this case we replace the unbased  mode
smfd 634$     by  the  based  one.   note  that  this can induce additional base
smfd 635$     equivalences.
smfd 636$
smfd 637$
smfd 638$ user-declared basings are partly reflected in the typ  map,  available
smfd 639$ at  the  start  of  the  automatic data structure selection algorithm.
smfd 640$ however, they raise several  problems  concerning  which  the  current
smfd 641$ implementation has made somewhat arbitrary decisions.  for example, it
smfd 642$ is not clear whether we ever want to merge two user-supplied bases, or
smfd 643$ always  keep  them distinct.  an argument for not merging them is that
smfd 644$ by doing so we may cause some based objects to become sparse over  the
smfd 645$ merged base, which may well have been the reason why the user supplied
smfd 646$ two distinct bases instead of one.  thus we have chosen not  to  merge
smfd 647$ user-supplied  bases,  though  in other cases it might be better to do
smfd 648$ so.
smfd 649$
smfd 650$ to avoid such merging, we maintain a map at the roots of  our  forest,
smfd 651$ called  'userbase',  indicating which user-supplied base, if any, is a
smfd 652$ member of the corresponding class.  in this way, we can avoid  linking
smfd 653$ two classes together if they contain different user-supplied bases.
smfd 654$
smfd 655$ note that currently the userbase map is  not  initialised  during  the
smfd 656$ base  generation  pre-pass.   this calls for some modifications of the
smfd 657$ pre-pass.  consequently the comment just made can  be  ignored.   note
smfd 658$ that  the  equibase routine given below will not equivalence bases for
smfd 659$ which different user bases have been declared.
smfd 660$
smfd 661$ let us emphasise again that our algorithm merges basings only when  it
smfd 662$ encounters  occurrences of the same type.  this is a restriction which
smfd 663$ simplifies the logic of the algorithm,  avoiding  several  troublesome
smfd 664$ issues  that would arise otherwise.  see also remark (1) at the end of
smfd 665$ the present module.
smfd 666$
smfd 667$ however,  we may  want to  consider some relaxations,  e.g. tuple  vs.
smfd 668$ known-length tuple.
smfd 669$
     127    procedure basemerge;
     128
     129
     130    repr
     131	vo, vo1:		occurrence;
     132	rpr, rpr1, rpr2:	elmt types;
     133	grstyp1, grstyp2:	basic_type;
     134	i:			integer;
     135	mptp1, mptp2:		elmt base_ft_mapcs;
     136	temp1, temp2:		elmt types;
     137	b, rb1, rb2:		tent_base;
     138	sc:			elmt base_scopes;
     139    end repr;
     140
     141
     142$ initially,
     143
     144    repbase := {};
     145    nbases := { [ b, 1 ] : b in bases};
     146
     147    if 'y' in dump_string then
     148 	print('  -  base merging phase');
     149    end if;
     150    if 'x' in dump_string then
     151	prints('aux_repr =',
     152	    [ [ rpad(oi_name(vo), 20) + rpad(oi_str(vo), 10), rpr ] :
     153					rpr = aux_repr(vo)	    ] );
     154	prints('elmt_mode =', [ [ str b, rpr ] : rpr = elmt_mode(b) ] );
     155	prints('bscope',      [ [ str b, sc ] : sc = bscope(b) ] );
     156    end if;
     157
     158    (forall vo in basedoccs, vo1 in bfrom{vo} |
     159	    vo1 in basedoccs and typ(vo) = typ(vo1)    )
     160
     161$ let us emphasize again that our algorithm merges basings only  when it
     162$ encounters  occurences of the same type.   this is a restriction which
     163$ simplifies the  logic of the  algorithm, avoiding several  troublesome
     164$ issues that would arise otherwise.   see also remark (1) at the end of
     165$ the present module.
     166$$$ ???? may want however to consider some relaxations, e.g. tuple
     167$$$ ???? vs. known-length tuple
     168$
     169	workpile := { [ aux_repr(vo), aux_repr(vo1) ] };
     170
     171	(while workpile /= {})
     172	    [ rpr1, rpr2 ] from workpile;
     173	    if 'x' in dump_string then
     174		print;
     175		print('merge representation', rpr1);
     176		print('                with', rpr2);
     177	    end if;
     178
     179	    if not is_based(rpr1) then continue; end if;
     180	    if not is_based(rpr2) then continue; end if;
     181
     182$ otherwise both reprs are based, so that their conjunction may yield
     183$ additional merging actions.
     184
     185	    grstyp1 := arb grosstyp(rpr1);
     186	    grstyp2 := arb grosstyp(rpr2);
     187$ note that based occurrences will have only one basic type in their
     188$ 'grosstyp' field.  this is because the base generation prepass would
     189$ not have generated bases for occurrences having ambiguous types.
     190
     191	    if grstyp1 = grstyp2 then
     192
     193		if grstyp1 = 'elmt' then
     194
     195$ both reprs are element-of-base.  equivalence their bases, which are
     196$ the component-types of these reprs.  this equivalencing may trigger
     197$ the merging of the element-modes of these bases.
     199
     200		    equibase(base_of(rpr1), base_of(rpr2));
     201
     202		elseif grstyp1 = 'map' then
     203
     204$ if a map is repred as a based map, its domain type and range type are
     205$ both element-of-base types, and we have to equivalence these bases.
     207
     208		    equibase(base_of(domtyp(rpr1)),
     209			     base_of(domtyp(rpr2)));
     210
     211		    mptp1 := map_type(rpr1);
     212		    mptp2 := map_type(rpr2);
     213
     214		    if mptp1 = ft_mmap and mptp2 /= ft_mmap then
     215			rb1   := .lim base_of(rangetyp(rpr1));
     216			temp1 := comptyp(elmt_mode(rb1));
     217			$ nb. it follows from the logic of the pre-pass
     218			$ that the element mode of rb1 is based.
     219
     220			equibase(base_of(temp1),
     221				 base_of(rangetyp(rpr2))    );
     222
     223			$ nb. it follows from the logic of the
     224			$ pre-pass and the equibase routine that rpr2
     225			$ is updated correctly.
     226			$ rangetyp(rpr2) :=
     227			$	[ { t_elmt }, rb1, om, based ];
     228			$ map_type(rpr2) := ft_mmap;
     229
     230		    elseif mptp1 /= ft_mmap and mptp2 = ft_mmap then
     231			rb2   := .lim base_of(rangetyp(rpr2));
     232			temp2 := comptyp(elmt_mode(rb2));
     233			$ nb. it follows from the logic of the pre-pass
     234			$ that the element mode of rb2 is based.
     235
     236			equibase(base_of(rangetyp(rpr1)),
     237				 base_of(temp2)	     );
     238
     239			$ nb. it follows from the logic of the
     240			$ pre-pass and the equibase routine that rpr1
     241			$ is updated correctly.
     242			$ rangetyp(rpr1) :=
     243			$	[ { t_elmt }, rb2, om, based ];
     244			$ map_type(rpr1) := ft_mmap;
     245
     246		    else
     247			equibase(base_of(rangetyp(rpr1)),
     248				 base_of(rangetyp(rpr2))    );
     249		    end if;
     250
     251		elseif grstyp1 = t_tuple and is_knt(rpr1) then
     252		    $ equivalence all the components of these
     253		    $ mixed tuples
     254		    (forall i in [ 1..#comptyp(rpr1) ])
     255			equibase(base_of(ctypn(rpr1, i)),
     256				 base_of(ctypn(rpr2, i)));
     257		    end forall;
     258
     259		else
     260		    $ for sets and homogeneous tuples, only one
     261		    $ base equivalencing need be performed
     262
     263		    temp1 := comptyp(rpr1);
     264		    temp2 := comptyp(rpr2);
     265		    equibase(base_of(temp1), base_of(temp2));
     266		end if;
     267
     268	    elseif grstyp1 = t_elmt then
     269$ here we merge 'elmt b' with a composite repr.  this calls for merging
     270$ the element-mode of b with the other repr.  however, if as yet the
     271$ element mode of b is not based, we simply change it to the second
     272$ (necessarily based) repr.
     273
     274		rb1 :=  .lim base_of(rpr1);
     275
     276		if not is_based(elmt_mode(rb1)) then
     277$$--  here bscope is not updated correctly:  if the scope of rpr1 is
     278$$--  greater than the scope of rpr2, then this information is lost.
     279$$--  for as long as we allocate all bases in the system scope, this
     280$$--  does not matter.
     281		    elmt_mode(rb1) := rpr2;
     282		else
     283		    workpile with:= [ elmt_mode(rb1), rpr2 ];
     284		end if;
     285
     286	    elseif grstyp2 = t_elmt then
     287
     288		rb2 :=  .lim base_of(rpr2);
     289
     290		if not is_based(elmt_mode(rb2)) then
     291$$--  here bscope is not updated correctly:  if the scope of rpr2 is
     292$$--  greater than the scope of rpr1, then this information is lost.
     293$$--  for as long as we allocate all bases in the system scope, this
     294$$--  does not matter.
     295		    elmt_mode(rb2) := rpr1;
     296		else
     297		    workpile with:= [ elmt_mode(rb2), rpr1 ];
     298		end if;
     299	    end if;
     300
     301	end while;
     302    end forall;
     303
     304    typ := om;			$ free for garbage collection
     305
     306    end procedure basemerge;
     307
     308
       1 .=member eqb15e
       2
       3
       4    procedure equibase(b1, b2);
       5$
       6$ this is our base equivalencing routine.  most of its code performs
       7$ standard tree-balancing, but "elmt_mode", "is_effective", "bscope",
       8$ and "userbase" also need to be adjusted appropiately.
       9$
      10$ the 'workpile' variable is global.
      11$
      12    repr
      13	b1, b2:			tent_base;
      14
      15	rb1, rb2, root, desc:	tent_base;
      16	ubase:			symbol;
      17	eff, eff1, eff2:	general;
      18	lcsp, lcsp1, lcsp2:	elmt base_based_modes;
      19	mptp, mptp1, mptp2:	elmt base_ft_mapcs;
      20	bscp:			elmt base_scopes;
      21    end repr;
      22
      23    rb1 := .lim b1;
      24    rb2 := .lim b2;
      25
      26    if rb1 = rb2 then return; end if;
      27
      28$
      29$ first determine the user-declared base of the equivalence class,
      30$ if there exists such a base.
      31$
      32    if (ubase := userbase(rb1)) = om then
      33	ubase := userbase(rb2);
      34    elseif userbase(rb2) /= om and userbase(rb2) /= ubase then
      35	return;  $ do not merge classes with different user bases
      36    end if;
      37$
      38$ next compute the effectivity of the new class
      39$
      40    eff1 := is_effective(rb1);
      41    eff2 := is_effective(rb2);
      42
      43    eff := case eff1 of
      44	    ('neutral'):	eff2,
      45	    ('effective'):	'effective'
      46	    else		$ eff1 is now a variable name
      47		case eff2 of
      48		('neutral'):	eff1,
      49		('effective'):	'effective'
      50		else		$ both are variable names
      51		    if eff1 = eff2 then eff1 else 'effective' end
      52		end
      53	    end;
      54$
      55$ next compute the maptyp and locspr entries for the new class
      56$
      57    lcsp1 := set_type(elmt_mode(rb1));
      58    lcsp2 := set_type(elmt_mode(rb2));
      59
      60    if lcsp1 = lcsp2 then
      61	lcsp := lcsp1;
      62    else
      63	if lcsp1 = om then lcsp1 := sprse; end;
      64	if lcsp2 = om then lcsp2 := sprse; end;
      65	lcsp := if lcsp1 = neutrl then lcsp2
      66		elseif lcsp2 = neutrl then lcsp1
      67		elseif lcsp1 = lcsp2 then sprse
      68		else remt end;
      69    end if;
      70
      71    mptp1 := map_type(elmt_mode(rb1));
      72    mptp2 := map_type(elmt_mode(rb2));
      73
      74    if mptp1 /= mptp2 and mptp1 /= ft_mmap and mptp2 /= ft_mmap then
      75	mptp := if     mptp1 = ft_smap then ft_smap
      76		elseif mptp2 = ft_smap then ft_smap
      77		else			    ft_map
      78		end;
      79    else
      80	mptp := om;
      81    end if;
      82
      83    bscp := maxscope([bscope(rb1), bscope(rb2)]);
      84$
      85$ determine the new root, balancing the resulting tree whenever
      86$ possible
      87$
      88    if mptp1 = ft_mmap and mptp2 /= ft_mmap then
      89	root := rb1;   desc := rb2;
      90
      91    elseif mptp1 /= ft_mmap and mptp2 = ft_mmap then
      92	root := rb2;   desc := rb1;
      93
      94    elseif nbases(rb1) > nbases(rb2) then
      95	root := rb1;   desc := rb2;
      96    else
      97	root := rb2;   desc := rb1;
      98    end if;
      99
     100    repbase(desc) := root;
     101
     102    nbases(root) +:= nbases(desc);
     103    is_effective(root) := eff;
     104    userbase(root)     := ubase;
     105    bscope(root)       := bscp;
     106
     107    set_type(elmt_mode(root)) := lcsp;
     108    set_type(elmt_mode(desc)) := lcsp;
     109
     110    if mptp /= om then
     111	map_type(elmt_mode(root)) := mptp;
     112	map_type(elmt_mode(desc)) := mptp;
     113    end if;
     114
     115    if is_based(elmt_mode(desc)) then
     116	if not is_based(elmt_mode(root)) then
     117$$--  here bscope is not updated correctly:  if the scope of root is
     118$$--  greater than the scope of desc, then this information is lost.
     119$$--  for as long as we allocate all bases in the system scope, this
     120$$--  does not matter.
     121	    elmt_mode(root) := elmt_mode(desc);
     122	else
     123	    $ both are based, so additional equivalencing is needed
     124	    workpile with:= [ elmt_mode(root), elmt_mode(desc) ];
     125	end if;
     126    end if;
     127
     128    if 'x' in dump_string then
     129	print('    new root', root,
     130			'with element mode', elmt_mode(root),
     131			'has', nbases(root), 'descendents.'    );
     132	print('        its scope is', bscp,
     133			'and its user base is', ubase);
     134	print('        its effective indicator is', eff);
     135    end if;
     136
     137
     138    end procedure equibase;
     139
     140
       1 .=member rpb15f
       2
       3
       4    op .lim(b);
       5$
       6$ this routine computes the root of b in our forest, and applies
       7$ "path compression".
       8$
       9    repr
      10	b:			tent_base;
      11
      12	rb1, rb2, rbx:		tent_base;
      13	s1:			remote set(tent_base);
      14    end repr;
      15
      16    rb1 := repbase(b);
      17
      18    if rb1 = om then
      19	return b;
      20
      21    elseif (rb2 := repbase(rb1)) = om then
      22	return rb1;
      23
      24    else
      25	s1 := {b};
      26
      27	(while (rbx := repbase(rb2)) /= om)
      28	    s1 with:= rb1;
      29	    rb1 := rb2;
      30	    rb2 := rbx;
      31	end while;
      32
      33	(forall rb1 in s1)
      34	    repbase(rb1) := rb2;
      35	end forall;
      36
      37	return rb2;
      38    end if;
      39
      40    end op .lim;
      41
      42
      43
       1 .=member baj15g
       2
       3
smfd 670$ 3. base and repr adjustment phase
smfd 671$ -- ---- --- ---- ---------- -----
smfd 672
smfd 673$ this phase is a 'clean-up' phase which suppresses useless  bases,  and
smfd 674$ computes the oi_repr map for all occurrences.  thus it consists of the
smfd 675$ following two subphases:
smfd 676$
smfd 677$ (a) we first suppress (equivalence classes of)  bases  that  have  not
smfd 678$ turned  out  to  be  useful,  according to the heuristic principle (4)
smfd 679$ above.  each droppable equivalence class is flagged as such,  and  any
smfd 680$ other  repr containing a base b1 in such a class should be modified so
smfd 681$ that   each   elmt b1   appearance    in    it    is    replaced    by
smfd 682$ elmt_mode(repbase .lim b1).   the  output  of  this  phase  is  a  set
smfd 683$ droppables containing all droppable bases.
smfd 684$
smfd 685$ (b) next, we iterate over all occurrences, computing the oi_repr  map.
smfd 686$ for  each  occurrence  vo,  oi_repr(vo)  is  an  actual  repr which is
smfd 687$ obtained   from   aux_repr(vo)   by   replacing   bases    by    their
smfd 688$ representatives,  or  dropping them as described in (a) above.  during
smfd 689$ this step we also enforce certain compile restriction,  such  as  that
smfd 690$ the  result of a value creating operation is a value;  if such a value
smfd 691$ is  wanted  in  a  based  form,  it  must  be  converted  to  such   a
smfd 692$ representation  explicitly.   again note that at this point we compute
smfd 693$ repr on an occurrence bases, so if we have 's := s1 + s2' and  require
smfd 694$ s to have the form elmt b, then the above restriction would give s the
smfd 695$ repr elmt_mode(b), and the subsequent conversion analysis phase  would
smfd 696$ insert a locate instruction at some appropriate point to ensure that s
smfd 697$ would be in the elmt b format.
smfd 698$
smfd 699$ (c) finally we dertermine the set of surviving  representative  bases,
smfd 700$ which is passed to the next phase, the conversion analsysis phase.
       6
       7    procedure baseadjust;
       8
       9$ this phase is a "clean-up" phase which suppresses useless bases,
      10$ computes the oi_repr map for all occurences, and enters the
      11$ surviving bases into the symbol table.  thus it consists of
      12$ the following three subphases:
      13
      22    repr
      23	rb:			tent_base;
      24	rpr:			elmt types;
      25	vo:			occurrence;
      26	opc:			elmt base_opcodes;
      27	bmode:			elmt types;
      28	repbases:		remote set(tent_base);
      29	vorpr:			elmt types;
      30    end repr;
      31
      32    if 'y' in dump_string then
      33	print('  -  base adjustment phase');
      34    end if;
      35
      36    repbases := { rb in bases | repbase(rb) = om };
      37    droppables :=
      38	{ rb in repbases | is_effective(rb) /= 'effective'};
      39
      47    oi_repr   := {};
      48    seendrops := {};	$ 'seendrops' is the set of all droppable bases
      49			$ b for which the real elmt_mode(b) has already
      50			$ been computed.
      51
      52    (forall rpr = aux_repr(vo))
      53	if vo in basedoccs then
      54	    rpr := real_repr(rpr);
      55	    if grosstyp(rpr) = grselmt then
smfd 701		opc := oi_op(vo);
      57		if (is_ovar(vo) and
      58			opc in ops_ovar and opc notin ops_iter and
      59			(opc = q1_ofa or opc notin ops_nonewval))
      60		    or
      61			$ nb. opc in ops_sin and argno(vo) = 1 is part
      62			$ of preceding "is_ovar(vo) and ..." test
      63			(opc in ops_sin and argno(vo) = 4)
      64		    or
      65			(opc in ops_iter and argno(vo) = 3)
      66$$-- nb. we also need to check that if opc in { q1_nextd, q1_inextd }
      67$$-- and argno(vo) = 3 and grosstyp(rpr) = grsset then error: conversion
      68$$-- will be attempted at q1_inextd, a3 will be changed
      69		then
      70		    rpr := real_repr(elmt_mode(base_of(rpr)));
      71		end if;
      72	    end if;
      73	end if;
      74	oi_repr(vo) := rpr;
      75    end forall;
      76
      77    if 'y' in dump_string then
      78	prints('oi_repr =',
      79	    [ [ rpad(oi_name(vo), 20) + rpad(oi_str(vo), 10), vorpr ] :
      80					vorpr = oi_repr(vo)     ] );
      81    end if;
      82
      83    aux_repr := om;	$ free space for garbage collection
      84
      92    actual_bases := repbases - droppables;
      93$$$ ???? for garbage collection, it may be advantageous to
      94$$$ ???? delete all map entries on all bases other than those
      95$$$ ???? in actual_bases.
      96    if 'y' in dump_string then
      97	print;
      98	print('actual bases and their element forms are');
      99    end if;
     100
     101    (forall rb in actual_bases)
     102	if is_based(elmt_mode(rb)) then
     103	    elmt_mode(rb) := real_repr(elmt_mode(rb));
     104	end if;
     105	if 'y' in dump_string then
     106	    print(rb, elmt_mode(rb));
     107	end if;
     108    end forall;
     109
     110    if 'd' in dump_string then fancy_output; end if;
     111
     112    end procedure baseadjust;
     113
     114
       1 .=member fpr15h
       2
       3
       4    procedure fancy_output;
       5$
       6$ this routine  prints the repr information collected in this phase in a
       7$ format resembling that of the  data-representation  sublanguage,  only
       8$ that a variable may be  assigned several different reprs in  different
       9$ occurrences of it.  we print each repr of each variable togoether with
      10$ the list of all occurrences of that variable having that repr.
      11$
      12    repr
      13	v:			symbol;
      14	vo:			occurrence;
      15	rpr:			elmt types;
      16	b:			tent_base;
      17	vreprs:			sparse mmap{symbol}
      18				    sparse mmap{elmt types}
      19					sparse set(occurrence);
      20	r_occs:			sparse mmap{elmt types}
      21				    sparse set(occurrence);
      22	v_occs:			sparse set(occurrence);
      23    end repr;
      24
      25
      26    vreprs := {};
      27    (forall rpr = oi_repr(vo) |
      28	    (v := oi_sym(vo)) in variables and is_internal(v) = om)
      29	vreprs{v}{rpr} with:= vo;
      30    end forall;
      31
      32    print;   print;
      33    print('suggested data structures:');
      34    print;   print;
      35
      36    (forall b in actual_bases)
      37	print(rpad('base ads' + str b + ':', 24),
      38		 format_repr(elmt_mode(b)) + ';'    );
      39    end forall;
      40
      41    print;
      42
      43    (forall r_occs = vreprs{v}, v_occs = r_occs{rpr} |
      44	    ( exists vo in v_occs | ffrom{vo} /= {}) )
      45	print(rpad(name(v) + ': ', 24), format_repr(rpr) + ';' );
      46	print('			          $ at occurences '
      47				+/[ ' ' + oi_str(vo) : vo in v_occs ] );
      48    end forall;
      49
      50
      51    end procedure fancy_output;
      52
      53
       1 .=member rrp15i
       2
       3
       4    procedure real_repr(rpr);
       5$
       6$ this routine transforms a based repr rpr into a new repr in the
       7$ following way:
       8$ each appearance of a droppable base b in this repr is replaced
       9$ (recursively) by its element mode;
      10$ each appearance of an effective base b in this repr is replaced
      11$ by the actual base representing b.
      12$
      13    repr
      14	rpr:			elmt types;
      15	grs:			basic_type;
      16	temp5:			tuple(elmt types);
      17	rb:			tent_base;
      18	rprx:			elmt types;
      19	i:			integer;
      20    end repr;
      21
      22
      23    $ it follows from the logic of the base generation pass that
      24    $ ambiguous types can not have based reprs.  consequently we
      25    $ take an immediate exit.
      26    if # grosstyp(rpr) /= 1 then return rpr; end if;
      27
      28    grs := arb grosstyp(rpr);
      29
      30    case grs of
      31
      32    (t_elmt):
      33$ get representing base and check whether it is droppable
      34	rb := .lim base_of(rpr);
      35	if rb in droppables then
      36$ if droppable, but already processed, return its element mode
      37$ (in which all required replacements have already taken place)
      38	    if rb in seendrops then
      39		return elmt_mode(rb);
      40	    else
      41$ otherwise note this base as processed, get its element mode
      42$ and transform it recursively if based.
      43		seendrops with:= rb;
      44		rprx := elmt_mode(rb);
      45		if not is_based(rprx) then
      46		    return elmt_mode(rb) := rprx;
      47		else
      48		    return elmt_mode(rb) := real_repr(rprx);
      49		end if;
      50	    end if;
      51	else
      52$ if not droppable, return 'elmt of representing base'
      53	    return [ grselmt, rb ];
      54	end if;
      55
      56    (t_tuple):
      57$ return a tuple repr, with transformed component reprs
      58	if is_knt(rpr) then
      59	    temp5:=comptyp(rpr);
      60	    return
      61		[ grstup,
      62		  [ real_repr(temp5(i)) : i in [ 1..#temp5 ] ],
      63		  true    ];
      64	else
      65	    return [ grstup, real_repr(comptyp(rpr)), false ];
      66	end if;
      67
      68    (t_map):
      69$ return a map repr, with transformed element repr
      70	return
      71	    [ grsmap,
      72	      [ grstup,
      73		[ real_repr(domtyp(rpr)), real_repr(rangetyp(rpr)) ],
      74		true    ],
      75	      om,
      76	      om,
      77	      set_type(rpr),
      78	      map_type(rpr)    ];
      79
      80    (t_set):
      81$ return a set repr, with transformed element repr
      82	return
      83	    [ grsset,
      84	      real_repr(comptyp(rpr)),
      85	      om,
      86	      om,
      87	      set_type(rpr)    ];
      88
      89    else
      90	return rpr;
      91
      92    end case;
      93
      94    end procedure real_repr;
      95
      96
      97
smfd 702
smfd 703$ remarks
smfd 704$ -------
smfd 705
smfd 706$ (1) the transitive closure of base equivalences carried out during the
smfd 707$ merging  procedure  always  relates  'more  composite'  bases to 'more
smfd 708$ primitive' ones.  equivalencing  two  bases  whose  element-modes  are
smfd 709$ composite  can cause bases appearing in these modes to be equivalenced
smfd 710$ too, as in example b above.  however, equivalencing is not induced  in
smfd 711$ the opposite direction.  for example:
smfd 712$
smfd 713$ example c
smfd 714$
smfd 715$	s with:= x;	$ s: set(elmt b1);  x: elmt b1;
smfd 716$	u with:= s;	$ u: set(elmt b2);  s: elmt b2;
smfd 717$	t with:= x;	$ t: set(elmt b3);  x: elmt b3;
smfd 718$	v with:= t;	$ v: set(elmt b4);  t: elmt b4;
smfd 719$
smfd 720$ in this example, b1 and b3 are equivalenced in view of the x-link, but
smfd 721$ b2  and b4 are not merged.  this approach is probably desirable, since
smfd 722$ such a merging would not improve  the  execution  of  the  above  code
smfd 723$ fragment,  but  might  make  u  and  v sparse over the merged base (of
smfd 724$ course, further information may make us  merge  b2  and  b4,  e.g.  an
smfd 725$ instruction such as 'if s in v then ...').
smfd 726$
smfd 727$ (2) as with any recursive or  transitive-closure  mechanism,  we  must
smfd 728$ guarantee  convergence  of  the  merging process.  since the number of
smfd 729$ generated bases is finite, divergence could occur only if there  exist
smfd 730$ cyclic  dependencies  between  bases,  the simplest of which could be:
smfd 731$ base b1: set(elmt b1).  if such a configuration occurred and  b1  were
smfd 732$ equivalenced  with  base b2: set(elmt b2),  then  the  merging process
smfd 733$ would repeat equivalencing operations involving b1 and  b2  infinitely
smfd 734$ many  times.   also,  during  the  base-dropping  phase,  if  b1  were
smfd 735$ droppable then we might attempt to replace each elmt b1 appearance  in
smfd 736$ a repr by set(elmt b1), which would obviously lead to endless looping.
smfd 737$
smfd 738$ we claim, however, that such situations will never  occur,  indeed,  a
smfd 739$ cyclic dependency could only be derived by base merging along a cyclic
smfd 740$ execution path, and only if there is a cyclic  type  dependency  along
smfd 741$ this path, as in the loop
smfd 742$
smfd 743$	(forall ...) x with:= x; end forall;
smfd 744$
smfd 745$ but in this situation the type finder will produce different types for
smfd 746$ the  o-variable  and the i-variable of the statement in the loop, e.g.
smfd 747$ set(general) and general, respectively (recall  that  o-variables  are
smfd 748$ assigned  the  forward type of their i-variables in the final phase of
smfd 749$ the type finder).  hence, no base merging will take place  along  such
smfd 750$ loops.
smfd 751$
smfd 752$ it can also be noted that if the base  generated  for  this  statement
smfd 753$ (call  it  b1) is not dropped, then the conversion analysis phase will
smfd 754$ split the variable x into two variable x.1 and x.2, and will transform
smfd 755$ the above loop into
smfd 756$
smfd 757$	(forall ...) x.2 := x.1; x.1 with:= x.2; end forall;
smfd 758$
smfd 759$ where we have:
smfd 760$
smfd 761$	b1: base(general);   x.2: elmt b1;   x.1: set(elmt b1);
smfd 762$
smfd 763$ and the assignment x.2 := x.1;  is a locate of the value of x.1 in b1.
smfd 764$
smfd 765$ it should also be noted that in order to ensure  proper  operation  of
smfd 766$ the  type  finder,  its  above-mentioned  final  phase  should compute
smfd 767$ o-variable types without applying the standard artificial limit on the
smfd 768$ complexity  of  generated  types,  so  as to avoid any accidental type
smfd 769$ identification.
smfd 770$
smfd 771$ note in this connection that if we process the loop
smfd 772$
smfd 773$	(forall ...) x := { x }; end forall;
smfd 774$
smfd 775$ both x occurrences would  get  the  type  set(set(...set(general)...))
smfd 776$ with  a maximal nesting level, unless, in the final phase, we increase
smfd 777$ the nesting level of the o-variable by 1.
smfd 778$
smfd 779$ (3) return for the moment to example c  above,  where  there  are  two
smfd 780$ linked  occurrences  of s, one of which is repred set(elmt b1) and the
smfd 781$ other elmt b2.  at a first glance it seems that we ought to produce  a
smfd 782$ common  repr  for  these  occurrences, but a better choice is to leave
smfd 783$ these reprs as they are.  then, after base merging and name-splitting,
smfd 784$ the code will be transformed into:
smfd 785$
smfd 786$		sa with:= x;	$ sa: set(elmt b1);  x:  elmt b1;
smfd 787$	(a1)	sb := sa;
smfd 788$		u with:= sb;	$ u:  set(elmt b2);  sb: elmt b2;
smfd 789$		tb from u;	$ u:  set(elmt b2);  tb: elmt b2;
smfd 790$	(a2)	ta := tb;
smfd 791$		y from ta;	$ ta: set(elmt b1);  y:  elmt b1;
smfd 792$
smfd 793$ where a1 is a base locate  of  the  value  of  sa  in  b2  and  a2  is
smfd 794$ essentially  a  dereferencing of the value of tb, originally a pointer
smfd 795$ to an element of b2, but after dereferencing  a  pointer  to  the  set
smfd 796$ value  of  ta  (note  that  here type checking is necessary unless the
smfd 797$ element mode of b2 is set(elmt b1)).
smfd 798$
smfd 799$ this approach again reflects the basic philosophy of the final  phases
smfd 800$ of  the  optimiser,  namely:   reprs  and  types should be assigned to
smfd 801$ occurrences in such a way that each instruction will  be  executed  in
smfd 802$ the most efficient manner, and any type or repr checks and conversions
smfd 803$ which must precede an instruction should be moved  and  inserted  into
smfd 804$ the code in an appropriate place preceding that instruction.
smfd 805$
smfd 806$ final remarks
smfd 807$ ----- -------
smfd 808$
smfd 809$ (1) our algorithm merges reprs only if they have the  same  type,  and
smfd 810$ consequently   equivalences   bases   only   if  they  have  the  same
smfd 811$ element-type.   for  example,  set(integers)  and   set(general)   are
smfd 812$ considered  as distinct types.  hence, even if there is a link between
smfd 813$ two occurrences having such types, their bases will not be merged, and
smfd 814$ eventually we shall have to convert from one base to the other.  it is
smfd 815$ not clear whether this approach is to be preferred, and there may be a
smfd 816$ point  in  merging  bases  of  this kind, even though this can lead to
smfd 817$ creation of additional type checks and  conversions  which  would  not
smfd 818$ have  been  otherwise needed.  at any rate, our approach is simple and
smfd 819$ should be quite acceptable in most cases.
smfd 820$
smfd 821$ (2) we  expect  the  present  data  structure  algorithm  to  be  more
smfd 822$ efficient  than  the variant algorithm described in .  in the
smfd 823$ present algorithm, base propagation is accomplished by a  single  pass
smfd 824$ through the bfrom links between based occurrences, with very efficient
smfd 825$ processing of each such link.  however, a time consuming part  of  the
smfd 826$ present  algorithm  is the manipulation of completely useless and thus
smfd 827$ droppable bases, and corresponding based occurrences.  it is not clear
smfd 828$ how  to  estimate this additional time usage, which depends heavily on
smfd 829$ the nature of the program being analysed.
smfd 830$
smfd 831$ since it generates these additional bases, the present algorithm  will
smfd 832$ require  more  space than the previous one.  this space usage could be
smfd 833$ reduced by somewhat more intricate programming (e.g.  by  folding  the
smfd 834$ pre-pass  into  the  base merging phase), but then the algorithm would
smfd 835$ lose some of its clarity.
smfd 836$
smfd 837$ note,  however,  that  the  space  required  by  the  older  automatic
smfd 838$ data-structure  selection  algorithms (of schonberg, schwartz and liu)
smfd 839$ which use value-flow, is at least the cardinality  of  the  value-flow
smfd 840$ maps,  in  comparison  with which the space requirement of the present
smfd 841$ algorithm is rather modest.
     245
     246
     247    end module setl_optimizer - auto_dstruct;
     248
     249
       1 .=member cnv15j
       2
       3    module setl_optimizer - conversion_analysis;
       4$
       5$ this module performs data-structure conversion analysis.  this  is  a
       6$ necessary supplementary phase to be  performed  after  the  preceding
       7$ type analysis and automatic data-structure selection phases have com-
       8$ puted data types and representations for the variable occurrences  in
       9$ the program being analyzed.
      10$
      11$ this phase performs the following tasks:
      12$
      13$ (a) name-splitting:
      14$
      15$     each variable v whose occurrences do not get all the same  repre-
      16$     sentation, is 'split' into several variables, one for  each  pos-
      17$     sible data representation computed for occurrences  of  v.   each
      18$     occurrence of v is then replaced by an occurrence of the  corres-
      19$     ponding split-variable.  all the split variables of v are entered
      20$     into the symbol table as storage-sharing variables.   the problem
      21$     with this transformation is that  conversions  between  different
      22$     variables split from the same variable still have to be  inserted
      23$     into the code, to avoid situations in which one such variable  is
      24$     defined and then another split variable is used.  this  is  taken
      25$     care of by the following conversion analysis subphase.
      26$
      27$ (b) conversion analysis:
      28$
      29$     in this phase we perform three bit-vectoring data  flow  analyses
      30$     to determine where and when to insert conversions from one  split
      31$     variable to another.  the rationale of these analyses is
      32$     discussed in section 9 of the tech. report, and is mentioned here
      33$     with only little detail.
      34$
      35$     the first analysis being performed is a  'backward-union'  safety
      36$     analysis whose purpose is to determine which conversions can  oc-
      37$     cur at a given program point (to be mainly an interval preheader,
      38$     into which we try to move such conversions).
      39$
      40$     the second analysis is a 'forward-intersection' availability ana-
      41$     lysis, which, using the safety  information  available  from  the
      42$     previous analysis, moves conversions out of  loops  if  possible,
      43$     and determines whether a conversion  is  required  prior  to  any
      44$     given use of a split variable.  the actual  conversion  insertion
      45$     takes place later on in this module.
      46$
      47$     the third analysis is a 'forward-union' reachability analysis, in
      48$     which we determine, for each basic block n, the  set  mayreach(n)
      49$     of all split variables which can reach the start of n.  this will
      50$     enable us to emit appropriate conversions as follows:  if we want
      51$     to insert at a certain point a conversion to a split variable vx,
      52$     we compute the set of all variables vy split from the same origi-
      53$     nal variable as vx, which can reach the conversion.   if this set
      54$     consists of exactly one variable vy, then we emit a conversion of
      55$     vy to vx;  if there is more than one such variable  vy,  then  we
      56$     emit a conversion from a type-general  variable  sharing  storage
      57$     with vx to vx.
      58$
      59    macro .comp;                   .comp_syms                   endm;
      60    macro df_base;                 df_base_syms                 endm;
      61    macro interproc_fwd_analysis;  interproc_fwd_analysis_syms  endm;
      62    macro intraproc_fwd_analysis;  intraproc_fwd_analysis_syms  endm;
      63    macro interproc_back_analysis; interproc_back_analysis_syms endm;
      64    macro intraproc_back_analysis; intraproc_back_analysis_syms endm;
      65    macro fom;                     fom_syms                     endm;
      66    macro xom;                     xom_syms                     endm;
      67
      68    var
      69	all_splits,	$ set of all split variables
      70	split_vars,	$ maps each variable v to all of its split
      71			$ variables
      72	split_from,	$ maps each split variable to original variable
      73	forminv,	$ maps each tuple of form attributes and a
      74			$ scope to a form in this scope having those
      75			$ attributes
      76	can_convert;	$ a relation containing [ fm1, fm2 ] iff any
      77			$ value having form fm1 can be converted to
      78			$ form fm2
      79
      80
      81    macro base_of(rpr);  userbase(rpr(2))   endm;
      82
      83$ the following macro constructs a tuple of form attributes from a form
      84
      85    macro form_maps(f);
      86	[ ft_type(f),
      87	  ft_mapc(f),
      88	  ft_elmt(f),
      89	  ft_dom(f),
      90	  ft_im(f),
      91	  ft_base(f),
      92	  ft_lim(f),
      93	  ft_tup(f),
      94	  ft_hashok(f),
      95	  ft_neltok(f),
      96	  ft_pos(f),
      97	  ft_num(f)    ]
      98    endm;
      99
     100    macro ft_type_;		nfm_maps(1)		endm;
     101    macro ft_mapc_;		nfm_maps(2)		endm;
     102    macro ft_elmt_;		nfm_maps(3)		endm;
     103    macro ft_dom_;		nfm_maps(4)		endm;
     104    macro ft_im_;		nfm_maps(5)		endm;
     105    macro ft_base_;		nfm_maps(6)		endm;
     106    macro ft_lim_;		nfm_maps(7)		endm;
     107    macro ft_tup_;		nfm_maps(8)		endm;
     108    macro ft_hashok_;		nfm_maps(9)		endm;
     109    macro ft_neltok_;		nfm_maps(10)		endm;
     110    macro ft_pos_;		nfm_maps(11)		endm;
     111    macro ft_num_;		nfm_maps(12)		endm;
     112
     113    const null_ft_num =
     114       { [ f_lset,  0 ],
     115	 [ f_lmap,  0 ],
     116	 [ f_limap, 0 ],
     117	 [ f_lpmap, 0 ],
     118	 [ f_lrmap, 0 ] };
     119
     120    const		$ various gross types
     121	grselt = { t_elmt },
     122	grstup = { t_tuple },
     123	grsset = { t_set },
     124	grsmap = { t_map };
     125
     126
     127    repr
     128	mode df_elmt:		df_elmt_syms;
     129	mode df_map:		df_map_syms;
     130
     131        base splitvars:		symbol;
     132        mode splitvar:		elmt splitvars;
     133
     134	all_splits:		remote set(splitvar);
     135	split_vars:		remote mmap{splitvar}
     136				    sparse set(splitvar);
     137	split_from:		remote smap(splitvar) splitvar;
     138
     139	forminv:		mmap{elmt base_scopes}
     140				    smap(tuple(general)(12))
     141					elmt forms;
     142	can_convert:		mmap{elmt forms} set(elmt forms);
     143	grselt:			gross_type;
     144	grstup:			gross_type;
     145	grsset, grsmap:		gross_type;
     146
     147	.meet:			operator(df_map, df_map) df_map;
     148	.join:			operator(df_map, df_map) df_map;
     149	compute_splits:		procedure;
     150	place_conversions:	procedure;
     151	conv_blockmaps:		procedure(routine, df_elmt)
     152				    tuple(
     153				      remote smap(df_edge) df_map,
     154				      remote smap(df_edge) df_map,
     155				      remote smap(df_edge) df_map,
     156				      remote mmap{df_node} df_elmt
     157				      );
     158	insert_convs:		procedure(
     159				  routine,
     160				  remote smap(df_node) df_elmt,
     161				  remote mmap{df_node} df_elmt,
     162				  remote smap(df_node) df_elmt,
     163				  df_elmt
     164				  );
     165	sharp_form:		procedure(
     166				  elmt forms,
     167				  elmt types,
     168				  elmt base_scopes    )
     169				    elmt forms;
     170	newform:		procedure(
     171				  tuple(general)(12),
     172				  elmt base_scopes    )
     173				    elmt forms;
     174	elmt_type:		procedure(elmt types) elmt types;
     175	insert_base:		procedure(tent_base, elmt base_scopes);
     176	add_conv:		procedure(
     177				  splitvar,
     178				  elmt insts,
     179				  df_elmt
     180				  );
     181	add_split:		procedure(splitvar) splitvar;
     182    end repr;
     183
     184
     185    procedure conv_optimize;
     186$
     187$ this is the main driver routine for conversion analysis.  it consists
     188$ of the following phases:
     189$
     190$ 1. base insertion:  during this phase, we actually insert the  effec-
     191$    tive bases into the symbol table.
     192$
     193$ 2. computation of split variables:  for each variable occurrence,  we
     194$    find (a possibly new) variable with the form for the  variable  at
     195$    the occurrence, and substitute the original variable by the  newly
     196$    variable.
     197$
     198$ 3. conversion insertion:  during this phase, we solve the  data  flow
     199$    problems metioned above, and insert the conversions required  bet-
     200$    ween variables within each equivalence class.
     201$
     202    repr
     203	entry_time:		integer;
     204    end repr;
     205
     206    title('cims.setl.' + prog_level + ' - conversion analysis');
     207    printa(term_file, '   - conversion analysis');
     208
     209    entry_time := time;
     210
     211    all_splits := {};	$ set of all variables being split
     212    split_vars := {};	$ maps each variable v to all of its split
     213			$ variables
     214    split_from := {};	$ maps each split variable to original variable
     215
     216
     217    compute_splits;	$ generate the needed split variables
     218    place_conversions;	$ find low-frequency places for conversions
     219
     220
     221    $ delete the static variables global to this module
     222    all_splits := om;   split_vars := om;   split_from := om;
     223    forminv := om;      can_convert := om;
     224
     225    statistics with:= time;	$ save time for final statistics
     226
     227    if 'e' in dump_string then
     228	print;
     229	print(time - entry_time, 'msecs spent in conversion analysis');
     230    end if;
     231
     232
     233    end procedure conv_optimize;
     234
     235
     236    procedure compute_splits;
     237$
     238$ this routine does the actual insertion of the effective bases into
     239$ the symbol table.
     240$
     241$
     242$ this routine computes the equivalence classes for  each  variable  in
     243$ the program.
     244$
     245    init
     246	memo_form := {};
     247    init
     248	argin_inst := {},	argout_inst := {},
     249	argin_form := {},	argout_form := {};
     250
     251    repr
     252	sc:			elmt base_scopes;
     253	b:			tent_base;
     254	fm, nfm:		elmt forms;
     255	fm1, fm2:		elmt forms;
     256	v:			symbol;
     257	vx, vy:			splitvar;
     258	vo:			occurrence;
     259	rpr:			elmt types;
     260	vforms:			sparse set(elmt forms);
smfc 631	nfm_maps:		tuple(general)(12);
     262	memo_form:		smap(
     263				  tuple(elmt forms, elmt types, symbol)
     264				    ) elmt forms;
smfk 138	new_occsof:		sparse mmap{symbol}
smfk 139				    sparse set(occurrence);
smfk 140	voccs:			sparse set(occurrence);
     265
     266	r:			routine;
     267	inst:			elmt insts;
     268	argins:			sparse set(elmt insts);
     269	argin_inst:		sparse mmap(symbol) elmt insts;
     270	argout_inst:		sparse mmap(symbol) elmt insts;
     271	argin_form:		sparse mmap(symbol) elmt forms;
     272	argout_form:		sparse mmap(symbol) elmt forms;
     273	split_time:		integer;
     274    end repr;
     275
     276
     277    split_time := time;
     278
     279    forminv := {};
     280    (forall sc in scopes)
     281
     282	$ build forminv, which sends each scope and vector of form
     283	$ attributes to its form table entry.
     284
     285$$--  we do not compute the scope of tentative bases correctly at the
     286$$--  moment:  consequently we move all forms into the system scope
     287$$--  here.  if the scoping was done correctly, the following (disabled
     288$$--  i.e. commented-out) code would suffice.  the corrective code has
     289$$--  has been marked as such.
     290
     291$$-- 	(for_form(fm, sc))
     292$$-- 	    if not is_fbase(fm) then
     293$$-- 		forminv{sc}(form_maps(fm)) := fm;
     294$$-- 	    end if;
     295$$-- 	end;
     296
     297$$--  start of corrective code
     298	(for_form(fm, sc))
     299	    if is_fbase(fm) then
     300		if sc_type(sc) /= sc_sys then
     301		    ermsg('cannot yet handle user-defined bases');
     302		end if;
     303	    else
     304		if forminv{sc}(form_maps(fm)) = om then
     305		    if sc_type(sc) /= sc_sys then
     306			last_form(sym_sys) :=
     307				next_form(last_form(sym_sys)) := fm;
     308		    end if;
     309		    forminv{sym_sys}(form_maps(fm)) := fm;
     310		end if;
     311	    end if;
     312	end;	$ end for_form;
     313
     314	if sc_type(sc) /= sc_sys then
     315	    first_form lessf:= sc; last_form lessf:= sc;
     316	end if;
     317	next_form lessf:= last_form(sym_sys);
     318    end forall;
     319
     320    (forall sc in scopes)
     321$$--   end of corrective code
     322
     323	$ insert the actual bases of this scope into the symbol table.
     324
     325$$-- 	(forall b in actual_bases |
     326$$-- 			bscope(b) = sc and userbase(b) = om)
     327	(forall b in actual_bases | userbase(b) = om)
     328	    insert_base(b, sym_sys);
     329
     330$$--  note that we allocate all bases in the system scope
     331
     332$$--  if userbase(b) is not om, or not in this scope, we must assure
     333$$--  that maxscope([ scope(userbase(b)), bscope(b) ]) =
     334$$--  scope(userbase(b)), i.e. that the userbase is in a larger scope
     335$$--  than b, and furthermore that the ft_elmt(form(userbase(b))) is
     336$$--  consistent with the elmt_mode(b).  this is currently not done.
     337
     338	end forall;
     339
     340	$ finally compute all forms for this scope
smfk 141
smfk 142	new_occsof := {};  $ occurrences of new split variables.
     341
     342	(for_sym(v, sc))
     343	    if v notin variables then continue; end if;
     344
smfk 143	    $ assert domain occsof = variables;  except as follows:
smfk 144	    $ 1. there exist variables which are not in domain(occsof):
smfk 145	    $    these are dead variables, generated e.g. by available
smfk 146	    $    expression analysis when merging redundant assignments.
smfk 147	    $ 2. there are some constants added to occsof when instruc-
smfk 148	    $    tions are added.
     346
     347	    (forall vo in occsof{v})
     348		rpr := oi_repr(vo) ? type_zero;
     349		if rpr = type_zero then continue; end if;
     350		if is_repr(v) = 1 then
     351		    fm := form(v);
     352		else
     353		    fm := std_form(f_gen);
     354		end if;
     355$
     356$ now 'merge' the given form 'fm' of v and the suggested repr 'rpr'
     357$ at the occurrence vo, to obtain a new form 'nfm' which is
     358$ more specific than fm and is compatible with rpr.  this new form
     359$ is also inserted into the form table of the appropriate scope
     360$ if not there already. all these is carried out by the routine
     361$ 'sharp_form'
     362$
     363		if (nfm := memo_form( [ fm, rpr, v ] )) = om then
     364		    nfm := sharp_form(fm, rpr, sym_sys);
     365$$--  note that we allocate all forms in the system scope
     366		    memo_form( [ fm, rpr, v ] ) := nfm;
     367		end if;
     368
     369	        if form(v) = nfm then
     370		    vx := v;
     371		    split_vars{vx} with:= vx;
     372		    split_from(vx)   :=   vx;
     373
     374		elseif exists vx in split_vars{v} |
     375					form(vx) = nfm then
     376		    pass;
     377
     378		elseif split_from(v) = om and not is_repr(v)=1 then
     379		    form(v) := nfm;
     380
     381		    vx := v;
     382		    split_vars{vx} with:= vx;
     383		    split_from(vx)   :=   vx;
     384
     385		elseif exists r in routs | v = rretn(r) then
     386		    $ this could be handles somewhat more efficient...
     387		    form(v) := std_form(f_gen);
     388
     389		    vx := v;
     390		    split_vars{vx} with:= vx;
     391		    split_from(vx)   :=   vx;
     392
     393		elseif oi_op(vo) = q1_argin and is_ovar(vo) and
     394			name( rptyps(args(instno(vo))(3))
     395				(value(args(instno(vo))(4))) ) = 'wr'
     396		then
     397		    $ recall that the third operand of a q1_argin gives
     398		    $ the routine name, and the fourth operand gives the
     399		    $ argument number in the call:  if this is a wr
     400		    $ parameter, ignore it as far as generation of split
     401		    $ variables is concerned.
     402
     403		    $ assert args(instno(vo))(2) = sym_om;
     404
     405		    vx := v;
     406		else
     407		    vx := add_split(v);
     408		    form(vx) := nfm;
     409		end if;
     410
smfk 149		if v /= vx then
smfk 150		    args(instno(vo))(argno(vo)) := vx;
smfk 151		    occsof{v} less:= vo; new_occsof{vx} with:= vo;
smfk 152		end if;
     412
     413		if oi_op(vo) = q1_argin and is_ovar(vo) then
     414		    argin_inst{v} with:= instno(vo);
     415		    argin_form{v} with:= form(vx);
     416
     417		elseif oi_op(vo) = q1_argout and is_ivar(vo) then
     418		    argout_inst{v} with:= instno(vo);
     419		    argout_form{v} with:= form(vx);
     420		end if;
     421	    end forall vo;
     422	end;	$ end for_sym;
smfk 153
smfk 154	(forall voccs = new_occsof{v})  occsof{v} +:= voccs;  end;
smfk 155	new_occsof := om;  $ free storage.
smfk 156
     423    end forall sc;
     424
     430
     431$ formal parameters of procedures must be handled differently during
     432$ the generation of split variables, for the following two reasons:
     433$
     434$ (1) if a write-parameter (ie. a parameter with a rw or wr declaration)
     435$ requires a conversion, our general algorithm would insert the conver-
     436$ sion before the instruction which requires the conversion, i.e. the
     437$ q1_argout instruction.  this is the wrong place, because at this point
     438$ the actual parameter is still on the stack, and consequently a conver-
     439$ sion of the symbol table entry's value would produce the wrong result.
     440$ note that the proper place for this conversion is in the called
     441$ procedures exit block.
     442$
     443$ (2) the code generator uses the form of the procedure to determine the
     444$ conversions required between actual and formal parameters, plus the
     445$ conversion which might be required for the procedure's return value.
     446$ to compute the proper procedure form we need to know which of the
     447$ possibly existing split variables was actually used in the q1_argin
     448$ and q1_argout instructions, to then use their forms to build the
     449$ procedure form.  (note that since setl does not provide generic
     450$ procedures, the form of an ambigous formal parameter becomes general)
     451$
     452$ we then handle formal parameters as follows:  whenever we generate a
     453$ split variable for the formal parameter of a q1_argin or q1_argout
     454$ instruction, we update two maps:  the first maps each formal
     455$ parameter to all the forms it assumes in a q1_argin or q1_argout
     456$ instruction;  the second maps each formal parameter to all q1_argin
     457$ or q1_argout instructions in which it appears.  if, after generating
     458$ all split variables, we find that some formal parameter is found with
     459$ more than one form, we generate an additional split variable of form
     460$ general, and use the second map to modify all q1_argin and q1_argout
     461$ instructions to use this variable (note that such a split might
     462$ already exist).  we then update the routine parameter list, rparams,
     463$ to reflect any change.  finally, we generate the new procedure form.
     464$ (nb. we really keep separate maps for the q1_argin and q1_argout cases
     465$ to simplify the update process.)
     466
     467    $ at this point, we are done with the ads_maps: delete them
     468    actual_bases := om; userbase := om;     bscope := om;
     469    oi_repr := om;	elmt_mode := om;
     470
     471    (forall argins = argin_inst{v})
     472	if # (argin_form{v} + argout_form{v}) > 1 then
     473
     474	    if ft_type(form(v)) = f_gen then
     475		vx := v;
     476		split_vars{vx} with:= vx;
     477		split_from(vx)   :=   vx;
     478
     479	    elseif exists vx in split_vars{v} |
     480			ft_type(form(vx)) = f_gen then
     481		is_param(vx) := 1;
     482
     483	    else
     484		vx := add_split(v);
     485		form(vx) := std_form(f_gen);
     486	    end if;
     487
     488	    (forall inst in argins)
     489		args(inst)(1) := vx;
smfk 157		if v /= vx then
smfk 158		    vo := get_oi(inst, 1);
smfk 159		    occsof{v} less:= vo; occsof{vx} with:= vo;
smfk 160		end if;
     490	    end forall;
     491
     492	    (forall inst in argout_inst{v})
     493		args(inst)(4) := vx;
smfk 161		if v /= vx then
smfk 162		    vo := get_oi(inst, 4);
smfk 163		    occsof{v} less:= vo; occsof{vx} with:= vo;
smfk 164		end if;
     494	    end forall;
     495
     496	elseif args(arb argins)(1) = v then
     497	    continue forall;
     498
     499	else
     500	    vx := args(arb argins)(1);
     501	end if;
     502
     503	inst := arb argins;
     504	rparams(args(inst)(3))(value(args(inst)(4))) := vx;
     505    end forall;
     506
     507    (forall r in routs)
     508	nfm_maps := [];
     509	ft_type_ := f_proc;
     510	ft_elmt_ := [ form(v) : v in rparams(r) ] with form(rretn(r));
     511	ft_lim_  := #rparams(r) + 1;
     512
     513	if forall fm in ft_elmt_ | ft_type(fm) = f_gen then
     514	    form(r) := std_form(f_proc);
     515	else
     516$$--cf. above comment relating to the scope of forms
     517	    form(r) := newform(nfm_maps, sym_sys);
     518	end if;
     519    end forall;
     520
     521    all_splits := { vx : vx = split_from(vy) | #split_vars{vx} > 1 };
     522
     523    argin_inst := om;   argout_inst := om;
     524    argin_form := om;   argout_form := om;
     525$
     526$ compute the relation can_convert
     527$
     528    can_convert := {};
     529    (forall vx in all_splits)
     530	vforms := { form(vy) : vy in split_vars{vx} };
     531	(forall fm1 in vforms, fm2 in vforms | can_conv(fm1, fm2))
     532	    can_convert with:= [ fm1, fm2 ];
     533	end forall;
     534    end forall;
     535
     536    if 'e' in dump_string then
     537	print(time - split_time, 'msecs to compute split variables');
     538    end if;
     539
     540    end procedure compute_splits;
     541
     542
     543
     544
     545    procedure place_conversions;
     546$
     547$ this routine solves the data flow problems and computes  the  maps  to
     548$ insert the required conversions.
     549$
     550$ note that in the data structures selected below we reflected  that  we
     551$ use the results of an analysis as soon as it becomes available.   this
     552$ led us to use the data flow base for most of our work,  as  this  base
     553$ should be smaller than the set of all split variables.
     554$
     555    repr
     556	globsplits, locsplits:	df_elmt;
     557
     558	zero:			df_elmt;
     559	id:			df_map;
     560
     561	maysafe:		remote smap(df_node) df_elmt;
     562	avail:			remote smap(df_node) df_elmt;
     563	exposed:		remote mmap{df_node} df_elmt;
     564	insert:			remote mmap{df_node} df_elmt;
     565	safe:			remote mmap{df_node} df_elmt;
     566	mayreach:		remote smap(df_node) df_elmt;
     567	dum1, dum2, dum3:	remote mmap{df_node} df_elmt;
     568
     569	ffwd, ffwdj, fbak:	remote smap(df_edge) df_map;
     570
     571	r:			routine;
     572	intt, hd:		elmt blocks;
     573	v, vy:			splitvar;
     574	vx:			elmt df_base;
     575	ksplits, gsplits:	df_elmt;
     576	fnewcnvs:		df_map;
     577	usym1, usym2:		symbol;
     578	df_time:		integer;
     579    end repr;
     580
     581
     582    df_time := time;
     583$
     584$ construct the undefined flow values for the dataflow_solver routines.
     585$
     586    xom := { usym1 := newat };
     587    fom := [ { usym1 := newat }, { usym2 := newat } ];
     588
     589$ conversion analysis for global variables (and formal parameters)
     590
     591    globsplits := {};
     592    (forall v in globalvars | v in all_splits)
     593	globsplits +:= split_vars{v};
     594    end forall;
     595    (forall r in routs, v in rparams(r) |
     596				split_from(v) in all_splits    )
     597	globsplits +:= split_vars{split_from(v)};
     598    end forall;
     599
     600    if globsplits = {} then
     601	pass;
     602
     603    else
     604	zero := globsplits;     $ analysis data state at exits
     605	id   := [ zero, {} ];   $ identity map for analysis
     606
     607    $ get the data_flow maps for both analyses and the 'exposed' map
     608    [ffwd, ffwdj, fbak, exposed] := conv_blockmaps(om, globsplits);
     609
     610    $ invoke the interprocedural analyzers
     611    interproc_back_analysis(fbak, maysafe, id, zero, false);
     612    fbak := om;			$ free storage
     613
     614$ before calling the forward analyzer, convert the 'maysafe' map
     615$ produced by the backward analyzer to the form required by the
     616$ forward analyzer. (see section 9 of the tech. report.)
     617
     618    safe := {};
     619    (forall r in routs, intt in ints(r) |
     620	    (hd := int_nodes(intt)(1)) /= intt)
     621	safe{intt} :=
     622	    { vx in globsplits |
     623		(forall vy in split_vars{split_from(vx)} |
     624		    vy in maysafe(hd) and
     625		    form(vx) in can_convert{form(vy)}    )    };
     626    end forall;
     627    maysafe := om;		$ free storage
     628
     629    zero := {};   $ forward analysis data state at entries
     630    interproc_fwd_analysis(ffwd, avail, id, zero, true,
     631			   true, exposed, insert, safe);
     632    ffwd := om;			$ free storage
     633
     634$ next update the flow maps 'ffwdj' of the third analysis to take
     635$ into account conversions moved out of loops
     636    (forall r in routs, intt in ints(r) |
     637	    (hd := int_nodes(intt)(1)) /= intt)
     638	fnewcnvs := id;
     639	(forall vx in insert{intt})
     640	    ksplits  := split_vars{split_from(vx)} less vx;
     641	    gsplits  := { vx };
     642	    fnewcnvs := [ id(1) - ksplits, gsplits ] .comp fnewcnvs;
     643	end forall;
     644	ffwdj([intt, hd]) := fnewcnvs .comp ffwdj([intt, hd]);
     645    end forall;
     646
     647    interproc_fwd_analysis(ffwdj, mayreach, id, zero, false,
     648			   false, dum1, dum2, dum3);
     649    ffwdj := om;		$ free storage
     650
     651$ finally, perform the actual conversion insertion
     652    insert_convs(om, avail, insert, mayreach, globsplits);
     653
     654    $ free storage
     655    avail := om;        insert := om;       mayreach := om;
     656    globsplits := om;
     657
     658    end if;
     659
     660$ repeat the above procedure for the local variables of each
     661$ procedure r
     662
     663    (forall r in routs)
     664
     665	locsplits := {};
     666	(forall v in localvars{r} |
     667		v in all_splits and
     668		forall vy in split_vars{v} | vy notin rparams(r)  )
     669	    locsplits +:= split_vars{v};
     670	end forall;
     671
     672	if locsplits = {} then continue forall; end if;
     673
     674	zero := locsplits;     $ analysis data state at exits
     675	id   := [ zero, {} ];  $ identity map for analysis
     676
     677	[ ffwd, ffwdj, fbak, exposed ] :=
     678	    conv_blockmaps(r, locsplits);
     679
     680	intraproc_back_analysis(r, fbak, maysafe, id, zero, false);
     681	fbak := om;		$ free storage
     682
     683	safe := {};
     684	(forall intt in ints(r) | (hd := int_nodes(intt)(1)) /= intt)
     685	    safe{intt} :=
     686		{ vx in locsplits |
     687		    (forall vy in split_vars{split_from(vx)} |
     688			vy in maysafe(hd) and
     689			form(vx) in can_convert{form(vy)}   )   };
     690	end forall;
     691	maysafe := om;		$ free storage
     692
     693	zero := {};
     694
     695	intraproc_fwd_analysis(r, ffwd, avail, id, zero, true,
     696			       true, exposed, insert, safe);
     697	ffwd := om;		$ free storage
     698
     699$ next update the flow maps 'ffwdj' of the third analysis to take
     700$ into account conversions moved out of loops
     701	(forall intt in ints(r) |
     702		(hd := int_nodes(intt)(1)) /= intt)
     703	    fnewcnvs := id;
     704	    (forall vx in insert{intt})
     705		ksplits  := split_vars{split_from(vx)} less vx;
     706		gsplits  := { vx };
     707		fnewcnvs := [ id(1)-ksplits, gsplits ] .comp fnewcnvs;
     708	    end forall;
     709	    ffwdj([intt, hd]) := fnewcnvs .comp ffwdj([intt, hd]);
     710	end forall;
     711
     712	intraproc_fwd_analysis(r, ffwdj, mayreach, id, zero, false,
     713			       false, dum1, dum2, dum3);
     714	ffwdj := om;		$ free storage
     715
     716	insert_convs(r, avail, insert, mayreach, locsplits);
     717
     718	$ free storage
     719	avail := om;    insert := om;       mayreach := om;
     720	locsplits := om;
     721    end forall;
     722
     723    if 'e' in dump_string then
     724	print(time - df_time, 'msecs to solve dataflow problem');
     725    end if;
     726
     727
     728    end procedure place_conversions;
     729
     730
       1 .=member cbm15k
       2
       3
       4    procedure conv_blockmaps(p, splits);
       5$
       6$ this procedure computes data flow maps and exposed representations for
       7$ the backward and forward analyses required in conversion optimisation.
       8$ the first parameter 'p' is either a routine to be scanned, or, if p is
       9$ omega, then all routines have to be scanned.   the  second  parameter,
      10$ 'splits', is the set of all split variables relevant for the analysis.
      11$
      12    repr
      13	$ data structures for parameters
      14	p:			routine;
      15	splits:			df_elmt;
      16
      17	$ data structures for return values
      18	ffwd, ffwdj, fbak:	remote smap(df_edge) df_map;
      19	exposed:		remote mmap{df_node} df_elmt;
      20
      21	$ data structures for local variables
      22	todo:			sparse set(routine);
      23	r:			routine;
      24	b:			df_node;
      25	i:			elmt insts;
      26	opc:			elmt base_opcodes;
      27	argsi:			tuple(symbol);
      28
      29	v:			splitvar;
      30	vx:			symbol;
      31	vx1:			splitvar;
      32	vx2:			elmt df_base;
      33	vy:			elmt df_base;
      34	fmx:			elmt forms;
      35	iva1:			integer;
      36	k:			integer;
      37
      38	fblkfwd, fblkbak:	df_map;
      39	inpvars:		df_elmt;
      40	killed:			df_elmt;
      41	fwdgen, bakgen:		df_elmt;
      42	can_expose:		df_elmt;
      43	vsplits:		df_elmt;
      44
      45	sblks:			sparse set(df_node);
      46	lb:			symbol;
      47	b1:			df_node;
      48    end repr;
      49
      50    if p = om then todo := routs; else todo := { p }; end if;
      51
      52    ffwd := {};       ffwdj := {};      fbak := {};
      53    exposed := {};
      54
      55    (forall r in todo)
      56	(for_block(b, r))
      57	    fblkfwd := fblkbak := [splits, {}];
      58
      59	    (for_inst(i, b))
      60		opc := opcode(i);
      61		argsi := args(i);
      62		iva1 := first_ivar(opc);
      63$$$ ???? need to worry about two input arguments of i being different
      64$$$ ???? split variables of the same original variable.
      65$$$ ???? this case should never happen, and we assume here that it
      66$$$ ???? indeed does not occur
      67		inpvars := {};  $ set of all input arguments of i
      68
      69		killed := fwdgen := bakgen := {};
      70$ these sets are defined as follows:
      71$ killed - the set of all split variables whose original variable has
      72$	   appeared so far in i
      73$ fwdgen - the set of all split variables occurring in i (where the
      74$	   output occurrence in i suppresses any input occurrences in i
      75$	   of the same original variable from appearing in this set.
      77$ bakgen - set of all split variables vx split from some v such that
      78$	   either v originally occurred in i as an input argument,
      79$	   actually being represented by another split variable vx1
      80$	   such that one can always convert from vx to vx1, or, if this
      81$	   is not the case, v occurs in i as its output argument.
      82
      83		can_expose := fblkfwd(1) - fblkfwd(2);
      84		(forall k in [ #argsi, #argsi-1..iva1 ] |
      85			(vx2 := vx := argsi(k)) in splits)
      86		    v := split_from(vx);
      87		    inpvars with:= v;
      88		    vsplits := split_vars{v};
      89		    fmx := form(vx);
      90
      91		    if vx2 in can_expose then
      92			exposed{b} with:= vx2;
      93		    end if;
      94
      95		    killed +:= vsplits;
      96		    fwdgen with:= vx2;
      97		    bakgen +:= { vy in vsplits |
      98				    fmx in can_convert{form(vy)}    };
      99
     100		end forall;
     101
     102		if opc in ops_ovar and
     103			(vx2 := vx := argsi(1)) in splits then
     104		    v := split_from(vx);
     105		    vsplits := split_vars{v};
     106		    killed +:= vsplits;
     107		    fwdgen := fwdgen - vsplits + { vx2 };
     108		    if v notin inpvars then bakgen +:= vsplits; end;
     109		end if;
     110
     111		fblkfwd :=
     112		    [ splits-killed+fwdgen, fwdgen ] .comp fblkfwd;
     113
     114		fblkbak :=
     115		    fblkbak .comp [ splits-killed+bakgen, bakgen ];
     116
     117		if opc in ops_goto then
     118		    if opc = q1_case then
     119			sblks := { blockof(value(lb)) :
     120					lb in range value(argsi(1)) };
     121		    else
     122			sblks := { blockof(value(argsi(#argsi))) };
     123		    end if;
     124		    (forall b1 in sblks)
     125			ffwd([b,b1])  := fblkfwd .meet ffwd([b,b1]);
     126			ffwdj([b,b1]) := fblkfwd .join ffwd([b,b1]);
     127			fbak([b,b1])  := fblkbak .join fbak([b,b1]);
     128		    end forall;
     129		end if;
     130	    end;	$ end for_inst
     131	end;		$ end for_block
     132    end forall;
     133
     134    return [ ffwd, ffwdj, fbak, exposed ];
     135
     136    end procedure conv_blockmaps;
     137
     138
     139
     140
     141    operator .meet(f, g);
     142$
     143$ this is a general routine, used here with the following data
     144$ structures:
     145$
     146    repr
     147	f, g:			df_map;
     148    end repr;
     149
     150    if g = om then
     151	return f;
     152    else
     153	return [ f(1) * g(1), f(2) * g(2) ];
     154    end if;
     155
     156    end operator .meet;
     157
     158
     159    operator .join(f, g);
     160$
     161$ this is a general routine, used here with the following data
     162$ structures:
     163$
     164    repr
     165	f, g:			df_map;
     166    end repr;
     167
     168    if g = om then
     169	return f;
     170    else
     171	return [ f(1) + g(1), f(2) + g(2) ];
     172    end if;
     173
     174    end operator .join;
     175
     176
       1 .=member inc15l
       2
       3
       4    procedure insert_convs(p, avail, insert, mayreach, splits);
       5$
       6$ this procedure scans each basic block and determines  whether  conver-
       7$ sions between split variables are required, based on the global  avail
       8$ information.  it also inserts conversions into interval preheaders.
       9$
      10$ the  logic  of  this  routine  is  quite  similar  to  the   preceding
      11$ conv_blockmaps routine, and more extensive comments can be found there
      12$
      13    repr
      14	$ data structures for parameters
      15	p:			routine;
      16	avail:			remote smap(df_node) df_elmt;
      17	insert:			remote mmap{df_node} df_elmt;
      18	mayreach:		remote smap(df_node) df_elmt;
      19	splits:			df_elmt;
      20
      21	$ data structures for local variables
      22	todo:			sparse set(routine);
      23	r:			routine;
      24	b:			df_node;
      25	i, iprev:		elmt insts;
      26	opc:			elmt base_opcodes;
      27	argsi:			tuple(symbol);
      28	v:			splitvar;
      29	vx:			symbol;
      30	vx1:			splitvar;
      31	vx2:			elmt df_base;
      32	iva1:			integer;
      33	k:			integer;
      34	availb, mayreachb:	df_elmt;
      35	insertb:		df_elmt;
      36	killed, gen:		df_elmt;
      37	vsplits, vreach:	df_elmt;
      38    end repr;
      39
      40
      41    if p = om then todo := routs; else todo := { p }; end if;
      42
      43    (forall r in todo)
      44	(for_block(b, r))
      45	    availb := avail(b);
      46	    if availb = om then continue; end if;
      47	    mayreachb := mayreach(b);
      48	    iprev := om;
      49
      50	    (for_inst(i, b))
      51		opc := opcode(i);
      52		argsi := args(i);
      53		iva1 := first_ivar(opc);
      54
      55		killed := gen := {};   $ only for forward propagation
      56		(forall k in [ #argsi, #argsi-1..iva1 ] |
      57			(vx2 := vx := argsi(k)) in splits)
      58
      59		    if vx2 notin availb then
      60			killed +:= split_vars{split_from(vx1 := vx)};
      61			if opc /= q1_argout then
      62			    $ nb. conversions for formal paramters are
      63			    $ inserted in the called routine's exit
      64			    $ block (below), and consequently excluded
      65			    $ here.
      66			    add_conv(vx1, iprev, mayreachb);
      67			end if;
      68			gen with:= vx2;
      69		    end if;
      70		end forall;
      71
      72		if opc in ops_ovar and
      73			(vx2 := vx := argsi(1)) in splits then
      74		    v := split_from(vx);
      75		    vsplits := split_vars{v};
      76		    killed +:= vsplits;
      77		    gen := gen - vsplits +{vx2};
      78		end if;
      79
      80		availb    := availb - killed + gen;
      81		mayreachb := mayreachb - killed + gen;
      82
      83		$ is this the last instruction in a preheader ?
      84		if i = last_inst(b) and
      85			(insertb := insert{b}) /= {} then
      86
      87		    $ see comment above relating to formal parameters
      88		    $ assert opc /= q1_argout;
      89		    (forall vx in insertb)
      90			add_conv(vx, iprev, mayreachb);
      91		    end forall;
      92		end if;
      93
      94		if opc = q1_exit then
      95		    (forall vx in rparams(r) | (vx2 := vx) in splits
      96				and is_write(vx) = 1)
      97			if vx2 notin availb then
      98			    add_conv(vx, iprev, mayreachb);
      99			end if;
     100		    end forall;
     101		end if;
     102
     103		iprev := i;
     104	    end;	$ end for_inst
     105	end;		$ end for_block
     106    end forall;
     107
     108    end procedure insert_convs;
     109
     110
     111
     112
     113    procedure add_conv(vx, rw iprev, mayreachb);
     114
     115    repr
     116	vx:			splitvar;
     117	iprev:			elmt insts;
     118	mayreachb:		df_elmt;
     119	v, vy, vz:		splitvar;
     120	vsplits, vreach:	set(splitvar);
     121	str1, str2, str3:	string;
     122    end repr;
     123
     124    v := split_from(vx);
     125    vsplits := split_vars{v};
     126    vreach := { vy in vsplits | vy in mayreachb };
     127
     128    if #vreach = 1 then
     129	vy := arb vreach;
     130
     131    elseif ft_type(form(v)) = f_gen then
     132	vy := v;
     133
     134    elseif exists vy in vsplits | ft_type(form(vy)) = f_gen then
     135	pass;
     136
     137    else
     138	vy := add_split(v);
     139	form(vy) := std_form(f_gen);
     140    end if;
     141
     142    if vx = vy then return; end if;
     143
     144    if is_temp(vx) = 1 then
     145	(forall vz in split_vars{v}) is_temp(vz) := om; end forall;
     146    end if;
     147
     148    insert_ins(iprev, q1_asn, vx, vy);
     149
     150    str1 := 'convert "' + name(v) + '"';
     151    str2 := ' from "'   + format_form(form(vy)) + '"';
     152    str3 := ' to "'     + format_form(form(vx)) + '".';
     153
     154    if #str1 + #str2 + #str3 < 72 then
smfc 632	messages{stmtof(iprev)}{'s'} with:= [ str1 + str2 + str3 ];
     156    elseif #str1 + # str2 < 72 then
smfc 633	messages{stmtof(iprev)}{'s'} with:= [ str1 + str2, str3 ];
     159    else
smfc 634	messages{stmtof(iprev)}{'s'} with:= [ str1, str2, str3 ];
     162    end if;
     163
     164
     165    end procedure add_conv;
     166
     167
     168
     169
     170    procedure add_split(v2);
     171$
     172$ this routine adds a new split variable vy to the scope of v.
     173$ nb. form(vy) is undefined on exit of this routine.
     174$
     175    repr
     176	v1, vy1:		symbol;
     177	v2, vy2:		splitvar;
     178    end repr;
     179
     180
     181    vy1 := add_var(scope(v1 := v2));
     182
     183    name(vy1)        := name(v1) + '.' + str # split_vars{v2};
     184    value(vy1)       := value(v1);
     185
     186    alias(vy1)       := v1;
     187    is_store(vy1)    := om;
     188
     189    is_read(vy1)     := is_read(v1);
     190    is_write(vy1)    := is_write(v1);
     191    is_param(vy1)    := is_param(v1);
     192    is_stk(vy1)      := is_stk(v1);
     193    is_temp(vy1)     := is_temp(v1);
     194    is_internal(vy1) := is_internal(v1);
     195    is_const(vy1)    := is_const(v1);
     196
     197    split_vars{v2} with:= (vy2 := vy1);
     198    split_from(vy2)  :=   v2;
     199
     200    if v1 in variables then variables with:= vy1; end if;
     201    if v1 in uservars  then uservars  with:= vy1; end if;
     202
     203    return vy2;
     204
     205
     206    end procedure add_split;
     207
     208
     209
     210
     211    procedure can_conv(fm1, fm2);
     212$
     213$ this routine computes a flag indicating whether a value with form  fm1
     214$ can be converted to the form fm2.
     215$
     216    repr
     217	fm1, fm2:		elmt forms;
     218	tp1, tp2:		elmt base_ft_types;
     219	simtp1, simtp2:		string;
     220	comps1, comps2:		tuple(elmt forms);
     221	cfm1:			elmt forms;
     222	j:			integer;
     223    end repr;
     224
     225    tp1 := ft_type(fm1);	$ get the basic types of the forms
     226    tp2 := ft_type(fm2);
     227
     228    simtp1 := simple_type(tp1);
     229    simtp2 := simple_type(tp2);
     230
     231    if simtp2 = 'gen' then	$ fm2 is a type general
     232	return true;
     233
     234    elseif simtp2 = 'elmt' then
     235	return can_conv(fm1, ft_elmt(ft_base(fm2)));
     236
     237    elseif simtp1 = 'elmt' then
     238	return can_conv(ft_elmt(ft_base(fm1)), fm2);
     239
     240    elseif simtp1 = 'gen' then
     241	return false;
     242
     243$ at this point, both fm1 and fm2 should have the same basic type,
     244$ if conversion is to succeed, except for the types 'map' and 'set'.
     245    elseif simtp1 /= simtp2 then
     246	if { simtp1, simtp2 } /= { 'map', 'set' } then
     247	    return false;
     248	end if;
     249    end if;
     250
     251    case simtp1 of
     252
     253    ('set', 'map'):
     254	$ nb. a conversion from a multi-valued map to a single-valued
     255	$ map is not save, and consequently we assume here that is is
     256	$ not possible.
     257	if ft_mapc(fm2) = ft_smap and ft_mapc(fm1) /= ft_smap then
     258	    return false;
     259	end if;
     260
     261	$ note that the conversion from set to map is possible iff
     262	$ the conversion between their elements is possible
     263	return can_conv(ft_elmt(fm1), ft_elmt(fm2));
     264
     265    ('tuple'):
     266	if tp1 = f_mtuple then
     267	    if tp2 = f_mtuple then
     268		if #(comps1 := ft_elmt(fm1)) <=
     269			#(comps2 := ft_elmt(fm2)) then
     270$$$ ???? note that we assume that it is possible to convert e.g.
     271$$$ ???? [ int ] to [ int, int ]
     272		    return (forall cfm1 = comps1(j) |
     273			can_conv(cfm1, comps2(j)));
     274		else
     275		    return false;
     276		end if;
     277	    else
     278		return (forall cfm1 in ft_elmt(fm1) |
     279		    can_conv(cfm1, ft_elmt(fm2)));
     280	    end if;
     281
     282	elseif tp2 = f_mtuple then
     283	    return false;
     284	else
     285	    return can_conv(ft_elmt(fm1), ft_elmt(fm2));
     286	end if;
     287
     288$$$ ???? for simplicity we assume below that any primitive type
     289$$$ ???? can be converted to any other such type having the same
     290$$$ ???? 'simple type'.  this assumption is not true in general
     291$$$ ???? and should be modified later.
     292    else
     293	return true;
     294
     295    end case;
     296
     297    end procedure can_conv;
     298
     299
       1 .=member sfm15m
       2
       3
       4    procedure sharp_form(fm, rpr, sc);
       5$
       6$ this recursive procedure gets as input a form fm, a computed repr rpr,
       7$ and a scope sc.  it computes a new form nfm such that:
       8$
       9$ 1. nfm is more specific than, or equivalent to fm
      10$ 2. nfm is compatible with rpr, that is converting nfm into a repr  (in
      11$    the format used in our automatic  data  structure  selection  algo-
      12$    rithm) would yield rpr.
      13$ 3. nfm belongs to the form table of sc, or the form table of a contai-
      14$    ning scope.
      15$
      16$ note that nfm may point to other (component) forms.  if these forms do
      17$ not already exist, they are also generated, and placed into the appro-
      18$ priate form table in a place preceding that of nfm.   (this is  compa-
      19$ tible with the original structure of the form tables.)
      20$
      21$ the code below is rather complex.  moreover, it may not be  completely
      22$ accurate due to the following reasons:
      23$
      24$ --- some important design decisions have so far been left out.   these
      25$     decisions concern the way in which we want  to  incorporate  user-
      26$     supplied information, and  whether  such  information  has  always
      27$     higher precedence over the reprs computed by the optimiser.  a few
      28$     issues of this sort are mentioned  below,  but  the  choices  made
      29$     below are rather arbitrary, and should be carefully reviewed.
      30$
      31$ since user-supplied information is already incorporated in our type
      32$ analysis phase, where it serves as an upper bound on computed types,
      33$ we can assume here that rpr is always more specific than, or
      34$ equivalent to fm, but only in the attributes considered in our
      35$ data-type and structure computations.  other attributes, currently
      36$ ignored in those analyses, such as range of integers, short vs. long
      37$ primitive types, etc. which are currently missing in rpr have to be
      38$ taken from fm.
      39$
      40    repr
      41	fm:			elmt forms;
      42	rpr:			elmt types;
      43	sc:			elmt base_scopes;
      44
      45	tp:			elmt base_ft_types;
      46	simtp:			string;
      47	grs:			gross_type;
      48	lcsp:			elmt base_based_modes;
      49	mptp:			elmt base_ft_mapcs;
      50	g:			basic_type;
      51	fmt:			elmt forms;
      52	ftp:			elmt base_ft_types;
      53	fm1, fm2, fm3:		elmt forms;
      54	comps:			tuple(elmt types);
      55	crpr:			elmt types;
      56	j:			integer;
      57	fmx:			elmt forms;
      58	b:			tent_base;
      59	bx:			symbol;
      60	bfm, dfm, ifm:		elmt forms;
      61	rstp, rtp:		elmt types;
      62	nfm_maps, nfmx_maps:	tuple(general)(12);
      63	nfm, nfmx:		elmt forms;
      64    end repr;
      65
      66
      67
      68    tp := ft_type(fm);
      69    simtp := simple_type(tp);
      70    grs := grosstyp(rpr);
      71    lcsp := set_type(rpr);
      72    mptp := map_type(rpr);
      73$ if gross type is ambiguous, or is null (designating 'om'), return
      74$ the original form.
      75    if #grs /= 1 then return fm; end if;
      76
      77    g := arb grs;  $ otherwise get the gross type
      78
      79$ first, if fm is a general form, we create 'nfm' only from 'rpr'
      80    if simtp = 'gen' then
      81
      82	case g of
      83
      84	(t_int):	return std_form(f_int);
      85
      86	(t_real):	return std_form(f_real);
      87
      88	(t_string):	return std_form(f_string);
      89
      90	(t_atom):	return std_form(f_atom);
      91
      92	(t_set):
      93$ first get the component form. then create a tuple 'nfm_maps'
      94$ consisting of all relevant form attributes of nfm (see the macro
      95$ 'form_maps' above). this tuple will then be used to construct
      96$ nfm and insert it into the properform table.
      97	    fm1 := sharp_form(fm, comptyp(rpr), sc);
      98	    nfm_maps := [];
      99	    ftp := f_uset;
     100	    if lcsp /= om and ft_type(fm1) = f_elmt and
     101		    (bfm := ft_base(fm1)) /= om then
     102		if lcsp = locl then
     103		    ftp := localtp(ftp);
     104		    ft_pos_ := (ft_num(bfm)(ftp) +:= 1);
     105		    ft_base_ := bfm;
     106		elseif lcsp = remt then
     107		    ftp := remotetp(ftp);
     108		    ft_base_ := bfm;
     109		end if;
     110	    end if;
     111	    ft_type_ := ftp;
     112	    ft_elmt_ := fm1;
     113
     114	(t_map):
     115
     116	    fm1 := sharp_form(fm, domtyp(rpr), sc);
     117
     118	    if mptp = ft_smap then
     119		fm2 := sharp_form(fm, rangetyp(rpr), sc);
     120		fm3 := sharp_form(fm, comptyp(rpr), sc);
     121
     122	    elseif mptp = ft_mmap then
     123		rstp := rangetyp(rpr);	$ the range set type
     124		if grosstyp(rstp) = grselt then
     125		    $ nb. the range set type of an mmap can not
     126		    $ have the form 'elmt b':  transform it here
     127		    $ if it has.
     128		    rstp := elmt_mode(rstp(2));
     129		end if;
     130		$ nb. the range set type rstp is a set type, and conse-
     131		$ quently could be an mmap-type;  in this case, the
     132		$ element type of rstp is not necessarily the component
     133		$ type of rstp.
     134		rtp := elmt_type(rstp);
     135		fm2 := sharp_form(fm, rstp, sc);
     136		fm3 := sharp_form(
     137			    fm,
     138			    [ grstup,
     139			      [ domtyp(rpr), rtp ],
     140			      true    ],
     141			    sc    );
     142
     143	    else    $ map_type(rpr) = ft_map: convert to ft_mmap
     144		fm2 := sharp_form(
     145			    fm,
     146			    [ grsset,
     147			      rangetyp(rpr),
     148			      om,
     149			      om,
     150			      sprse    ],
     151			    sc    );
     152		fm3 := sharp_form(fm, comptyp(rpr), sc);
     153		mptp := ft_mmap;
     154	    end if;
     155
     156	    if lcsp = remt and ft_type(fm1) = f_elmt and
     157		    (bfm := ft_base(fm1)) /= om then
     158$ first generate the embedded tuple form
     159		nfm_maps := [];
     160		ft_type_ := f_tuple;
     161		ft_elmt_ := fm2;
     162		fmt := newform(nfm_maps, sc);
     163	    end if;
     164	    nfm_maps := [];
     165	    ftp := f_umap;
     166	    if lcsp /= om and ft_type(fm1) = f_elmt and
     167		    (bfm := ft_base(fm1)) /= om then
     168		if lcsp = locl then
     169		    ftp := localtp(ftp);
     170		    ft_pos_ := (ft_num(bfm)(ftp) +:= 1);
     171		    ft_base_ := bfm;
     172		elseif lcsp = remt then
     173		    ftp := remotetp(ftp);
     174		    ft_base_ := bfm;
     175		    ft_tup_ := fmt;
     176		end if;
     177	    end if;
     178	    ft_type_ := ftp;
     179	    ft_mapc_ := mptp;
     180	    ft_elmt_ := fm3;
     181	    ft_dom_  := fm1;
     182	    ft_im_   := fm2;
     183
     184	(t_tuple):
     185	    if is_knt(rpr) then
     186		comps := comptyp(rpr);
     187		nfm_maps := [];
     188		ft_type_ := f_mtuple;
smfh  33		ft_elmt_ := [ sharp_form(fm, crpr, sc): crpr in comps ];
     190		ft_lim_  := #comps;
     194
     195	    else
     197		nfm_maps := [];
     198		ft_type_ := f_tuple;
smfh  34		ft_elmt_ := sharp_form(fm, comptyp(rpr), sc);
     200		ft_lim_  := 0;
     201	    end if;
     202
     203	    $ the nelt field of tuples is maintained:
     204	    ft_neltok_ := 1;
     205
     206	(t_elmt):
     207	    if base_of(rpr) = om then insert_base(rpr(2), sc); end if;
     208	    nfm_maps := [];
     209	    ft_type_ := f_elmt;
     210	    ft_base_ := form(base_of(rpr));
     211
     212	(t_om):		return std_form(f_gen);
     213
     214	end case;
     215
     216    elseif simtp = 'elmt' and g /= t_elmt then
     217	return sharp_form(ft_elmt(ft_base(fm)), rpr, sc);
     218
     219    else
     220$ here fm is a non-general type. we begin by copying into 'nfm_maps'
     221$ all attributes of fm. these will then be modified depending on the
     222$ information available in 'rpr'.
     223	nfm_maps := form_maps(fm);
     224
     225	case g of
     226
     227	(t_int, t_real, t_string, t_atom):
     228	    return fm;
     229$$$ ???? what if fm is 'elmt b'? are we to override this user-supplied
     230$$$ ???? repr and replace it by the primitive type itself?
     231
     232	(t_elmt):
     233	    if base_of(rpr) = om then insert_base(rpr(2), sc); end if;
     234	    if simtp = 'elmt' then
     235		if ft_base_ = form(base_of(rpr)) then
     236		    return fm;
     237		else
     238		    print('** form and repr have different bases',
     239			    fm, rpr);
     240		end if;
     241	    else
     242		nfm_maps := [];
     243		ft_type_ := f_elmt;
     244		ft_base_ := form(base_of(rpr));
     245	    end if;
     246
     247	(t_set):
     248	    if simtp = 'map' then
     249		$ since we assume rpr to be more specific than fm,
     250		$ this case cannot occur.
     251		print('form is a map but repr is a set', fm, rpr);
     252	    else
     253		fm1 := sharp_form(ft_elmt_, comptyp(rpr), sc);
     254		ftp := f_uset;
     255		if ftp = ft_type_ and lcsp /= om and
     256			ft_type(fm1) = f_elmt and
     257			(bfm := ft_base(fm1)) /= om then
     258		    if lcsp = locl then
     259			ftp := localtp(ftp);
     260			ft_pos_ := (ft_num(bfm)(ftp) +:= 1);
     261			ft_base_ := bfm;
     262		    elseif lcsp = remt then
     263			ftp := remotetp(ftp);
     264			ft_base_ := bfm;
     265		    end if;
     266		end if;
     267		ft_type_ := ftp;
     268		ft_elmt_ := fm1;
     269	    end if;
     270
     271	(t_map):
     272
     273	    if simtp = 'map' then
     274		ft_dom_  := sharp_form(ft_dom_, domtyp(rpr), sc);
     275		if ft_mapc_ = ft_smap then
     276		    if mptp = ft_mmap then
     277			rstp := rangetyp(rpr);	$ the range set type
     278			if grosstyp(rstp) = grselt then
     279			    $ nb. the range set type of an mmap can not
     280			    $ have the form 'elmt b':  transform it here
     281			    $ if it has.
     282			    rstp := elmt_mode(rstp(2));
     283			end if;
     284			$ nb. the range set type rstp is a set type, and
     285			$ consequently could be an mmap-type;  in this
     286			$ case, the element type of rstp is not neces-
     287			$ sarily the component type of rstp.
     288			rtp := elmt_type(rstp);
     289		    else
     290			rtp := rangetyp(rpr);
     291		    end if;
     292		    ft_im_ := sharp_form(ft_im_, rtp, sc);
     293		    ft_elmt_ := sharp_form(
     294				    ft_elmt_,
     295				    [ grstup,
     296				      [ domtyp(rpr), rtp ],
     297				      true    ],
     298				    sc	  );
     299		    mptp := ft_smap;
     300
     301		elseif mptp = ft_mmap then
     302		    assert ft_mapc_ = ft_mmap;
     303		    rstp := rangetyp(rpr);  $ the range set type
     304		    if grosstyp(rstp) = grselt then
     305			$ nb. the range set type of an mmap can not
     306			$ have the form 'elmt b':  transform it here
     307			$ if it has.
     308			rstp := elmt_mode(rstp(2));
     309		    end if;
     310		    $ nb. the range set type rstp is a set type, and
     311		    $ consequently could be an mmap-type;  in this
     312		    $ case, the element type of rstp is not neces-
     313		    $ sarily the component type of rstp.
     314		    rtp := elmt_type(rstp);
     315		    ft_im_   := sharp_form(ft_im_, rstp, sc);
     316		    ft_elmt_ := sharp_form(
     317				    ft_elmt_,
     318				    [ grstup,
     319				      [ domtyp(rpr), rtp ],
     320				      true    ],
     321				    sc	  );
     322
     323		else	$ map_type(rpr) = ft_smap or ft_map,
     324		    assert ft_mapc_ = ft_mmap;
     325		    $ so convert the map to an mmap.
     326		    ft_im_ := sharp_form(
     327				    ft_im_,
     328				    [ grsset,
     329				      rangetyp(rpr),
     330				      om,
     331				      om,
     332				      sprse    ],
     333				    sc	  );
     334		    ft_elmt_ := sharp_form(ft_elmt_, comptyp(rpr), sc);
     335		    mptp := ft_mmap;
     336		end if;
     337
     338	    else    $ simtp = 'set'
     339		fm1 := ft_elmt_;
     340$ check whether the element form of fm is definitely a pair. if so
     341$ we may improve the resulting domain and image forms of the new
     342$ map, by taking the component forms of this pair into account.
     343		if ft_type(fm1) = f_mtuple and ft_lim(fm1) = 2 then
     344		    dfm := ft_elmt(fm1)(1);
     345		    ifm := ft_elmt(fm1)(2);
     346		else
     347		    dfm := ifm := std_form(f_gen);
     348		end if;
     349
     350		ft_dom_ := sharp_form(dfm, domtyp(rpr), sc);
     351
     352		if mptp = ft_mmap then
     353		    rstp := rangetyp(rpr);   $ the range set type
     354		    if grosstyp(rstp) = grselt then
     355			$ nb. the range set type of an mmap can not
     356			$ have the form 'elmt b':  transform it here
     357			$ if it has.
     358			rstp := elmt_mode(rstp(2));
     359		    end if;
     360		    $ nb. the range set type rstp is a set type, and
     361		    $ consequently could be an mmap-type;  in this
     362		    $ case, the element type of rstp is not neces-
     363		    $ sarily the component type of rstp.
     364		    rtp := elmt_type(rstp);
     365		else
     366		    rtp := rangetyp(rpr);
     367		end if;
     368
     369		fmx := sharp_form(ifm, rtp, sc);   $ range element form
     370
     371		nfmx_maps     := [];
     372		nfmx_maps(1)  := f_uset;	$ ft_type
     373		nfmx_maps(3)  := fmx;		$ ft_elmt
     374
     375		ft_im_   := newform(nfmx_maps, sc);   $ range set form
     376		ft_elmt_ := sharp_form(
     377				ft_elmt_,
     378				[ grstup,
     379				  [ domtyp(rpr), rtp ],
     380				  true    ],
     381				sc    );
     382		ft_type_ := f_umap;
     383		ft_mapc_ := ft_mmap;
     384		mptp     := ft_mmap;
     385	    end if;
     386	    ftp := f_umap;
     387	    if ftp = ft_type_ then
     388		if lcsp = remt and ft_type(ft_dom_) = f_elmt and
     389			(bfm := ft_base(ft_dom_)) /= om then
     390		    $ first generate the embedded tuple form
     391		    nfmx_maps := [];
     392		    nfmx_maps(1) := f_tuple;
     393		    nfmx_maps(3) := ft_im_;
     394		    fmt := newform(nfmx_maps, sc);
     395		end if;
     396
     397		if lcsp /= om and ft_type(ft_dom_) = f_elmt and
     398			(bfm := ft_base(ft_dom_)) /= om then
     399		    if lcsp = locl then
     400			ftp := localtp(ftp);
     401			ft_pos_ := (ft_num(bfm)(ftp) +:= 1);
     402			ft_base_ := bfm;
     403		    elseif lcsp = remt then
     404			ftp := remotetp(ftp);
     405			ft_base_ := bfm;
     406			ft_tup_ := fmt;
     407		    end if;
     408		end if;
     409		ft_type_ := ftp;
     410		ft_mapc_ := if ft_mapc_ = ft_smap then
     411				ft_smap
     412			    elseif mptp = ft_smap then
     413				ft_smap
     414			    else
     415				ft_mmap
     416			    end;
     417	    end if;
     418
     419	(t_tuple):
     420	    if is_knt(rpr) then
     421		comps := comptyp(rpr);
     422		if tp = f_mtuple then
     423		    if # ft_elmt_ /= # comps then
     424			print('fm and rpr are diff. length mtuples',
     425				fm, rpr);
     426		    else
     427			(forall j in [ 1..#ft_elmt_ ])
     428			    fm1 := ft_elmt_(j);
     429			    fm2 := sharp_form(fm1, comps(j), sc);
     430			    ft_elmt_(j) := fm2;
     431			end forall;
     432		    end if;
     433		else
     434		    ft_type_ := f_mtuple;
     435		    ft_lim_  := # comps;
     436		    fm1      := ft_elmt_;
     437		    ft_elmt_ := [];
     438		    (forall crpr = comps(j))
     439			fm2 := sharp_form(fm1, crpr, sc);
     440			ft_elmt_ with:= fm2;
     441		    end forall;
     442		end if;
     443	    elseif tp = f_mtuple then
     444		print('fm is a mtuple, rpr is a tuple', fm, rpr);
     445	    else
     446		ft_elmt_ := sharp_form(ft_elmt_, comptyp(rpr), sc);
     447	    end if;
     448
     449	    $ the nelt field of tuples is maintained:
     450	    ft_neltok_ := 1;
     451
     452	(t_om):		return fm;
     453
     454	end case;
     455    end if;
     456
     457$ at this point, the tuple 'nfm_maps' contains the attributes of the
     458$ new form. using the map 'forminv', which maps each such tuple and
     459$ a scope to a form in this scope having these attributes (if such
     460$ a form exists there), we try to locate 'nfm' in 'sc' or in a
     461$ containing scope. if unable to find it, we insert nfm into the
     462$ form table of sc.
     463
smfh  35    return newform(nfm_maps, sc);
     467
     468    end procedure sharp_form;
     469
     470
     471
     472
     473    procedure newform(nfm_maps, sc);
     474$
     475$ this routine checks, given the new form maps, whether such a form
     476$ exists already in the scope sc.  if it finds such a form, it returns
     477$ it;  otherwise it returns a new form.
     478$
     479    repr
     480	nfm_maps:		tuple(general)(12);
     481	sc, scx:		elmt base_scopes;
     482	nfm, f1:		elmt forms;
     483    end repr;
     484
     485
     486    if exists scx in cont_scopes(sc) |
     487			forminv{scx}(nfm_maps) /= om then
     488	return forminv{scx}(nfm_maps);
     489    end if;
     490
     491$ no form has been found
     492
     493    nfm := add_form(sc);
     494    form_maps(nfm)    := nfm_maps;
     495    forminv{sc}(nfm_maps) := nfm;
     496
     497    (init f1 := nfm; while ft_type(f1) = f_elmt)
     498	if ft_type(ft_base(f1)) = f_pbase then quit; end if;
     499	f1 := ft_elmt(ft_base(f1));
     500    end init;
     501    ft_deref(nfm) := f1;
     502
     503    return nfm;
     504
     505
     506    end procedure newform;
     507
     508
     509
     510
     511    procedure elmt_type(rpr);
     512$
     513$ this procedure recursively builds the element form for a map repr.
     514$
     515    repr
     516	rpr:			elmt types;
     517	rstp:			elmt types;
     518    end repr;
     519
     520
     521    if grosstyp(rpr) = grsmap and map_type(rpr) = ft_mmap then
     522
     523	rstp := rangetyp(rpr);	$ the range set type
     524
     525	if grosstyp(rstp) = grselt then
     526	    $ nb. the range set type of an mmap can not have the
     527	    $ form 'elmt b':  transform it here if it has.
     528	    rstp := elmt_mode(rstp(2));
     529	end if;
     530
     531	return [ grstup, [ domtyp(rpr), elmt_type(rstp) ], true ];
     532
     533    else
     534	return comptyp(rpr);
     535    end if;
     536
     537
     538    end procedure elmt_type;
     539
     540
     541    procedure insert_base(b, sc);
     542$
     543    repr
     544	b:			tent_base;
     545	sc:			elmt base_scopes;
     546	fm, xfm:		elmt forms;
     547	v:			symbol;
     548    end repr;
     549
     550
     551    sc  := sym_sys;
     552$$--  we really ought to use the maxscope of sc and bscope(b) here -
     553$$--  at the moment, thoght, this is a little pointless, since we
     554$$--  allocate all forms in the system scope
     555$$--  should be make this change, recall that maxscope is local to
     556$$--  auto_dstruct, hence needs to be exported/imported to get here.
     557$$--  sc  := maxscope([ sc, bscope(b) ]);
     558    xfm := sharp_form(std_form(f_gen), elmt_mode(b), sc);
     559
     560    fm := add_form(sc);
     561    ft_type(fm) := f_base;
     562    ft_elmt(fm) := xfm;
     563    ft_num(fm)  := null_ft_num;
     564
     565    (while ft_type(xfm) = f_elmt)
     566	if ft_type(ft_base(xfm)) = f_pbase then quit; end if;
     567	xfm := ft_elmt(ft_base(xfm));
     568    end while;
     569    ft_deref(fm) := xfm;
     570
     571    v := add_sym(sc);
smfk 165    name(v) := 'opt#' + str(#basesymb + 1);	is_internal(v) := om;
     573    form(v) := fm;
     574    is_read(v)  := 1;	is_write(v)  := 1;
     575    is_repr(v)  := 1;	is_store(v)  := 1;
     576    userbase(b) := v;	basesymb(fm) := v;
     577
     578
     579    end procedure insert_base;
     580
     581
     582    drop
     583	.comp,
     584	interproc_fwd_analysis,
     585	intraproc_fwd_analysis,
     586	interproc_back_analysis,
     587	intraproc_back_analysis,
     588	fom,
     589	xom;
     590
     591
     592    end module setl_optimizer - conversion_analysis;
     593
     594
       1 .=member copy18
       2
       3
       4    module setl_optimizer - copy_optimization;
       5$
       6$ this module performs copy optimization using an algorithm which
       7$ approximates the more complicated value-flow analysis technique
       8$ suggested by j. schwartz.  it results in a simplified approach
       9$ which is likely to be much more efficient than the value-flow
      10$ approach, but which is still based on essentially the same value
      11$ relationships computed by value-flow.  having calculated these
      12$ relationships, our algorithm can then determine which potentially
      13$ destructive operations can be performed without having to copy by
      14$ using live-dead information about the program variable occurrences.
      15$
      16$ let us first describe briefly our modified approach to value-flow
      17$ analysis. the purpose of that analysis is to determine, for each
      18$ potentially destructive use vo, the set of all variable occurrences
      19$ vo' whose value can contain the value of vo as a member (or be equal
      20$ to this value). this set is significant in that the values of
      21$ occurrences in it are the only values that can possibly contain
      22$ pointers to the value that we wish to destroy at vo. using standard
      23$ arguments taken from value-flow analysis as originally described,
      24$ we can show that vo' and vo must be related in the following way:
      25$ there exists an occurrence vo'' which precedes both vo and vo'
      26$ in execution flow, and contains vo as a member.  (vo'' may be vo or
      27$ vo').  moreover, this membership relationship is realized by a series
      28$ of operations which retrieve vo from vo'', and by another series of
      29$ operations which, through retrievals, imbeddings and assignments,
      30$ create vo' from vo''.  in addition, the relationships between vo' and
      31$ vo'' and between vo'' and vo' must be such that their composition
      32$ still makes vo a member of vo' (or equal to it).
      33$
      34$ using these facts, we carry out our analysis as follows:  start at
      35$ each destructive use vo;  perform an upward propagation, tracking
      36$ membership relationships from vo to other preceding occurrences,
      37$ thereby finding all occurrences vo'' mentioned before.  then by a
      38$ downward propagation step find all occurrences vo' mentioned above by
      39$ propagating membership relationships from the vo''s detected earlier,
      40$ and ensuring that vo' can still contain vo.
      41
      42$ the following macros are used to check the memo functions, and invoke
      43$ the routine if the function has not yet been evaluated
      44
      45    macro must_copy(r, fm);
      46	(must_copy_memo(r, fm) ? must_copy_rout(r, fm))
      47    endm;
      48
      49    macro rel_comp(r, rx);
      50	(rel_comp_memo(r, rx) ? rel_comp_rout(r, rx))
      51    endm;
      52
      53    macro inv(r);
      54	(inv_memo(r) ? inv_rout(r))
      55    endm;
      56
      57    macro rel_inst(vo);
      58	(rel_inst_memo(vo) ? rel_inst_rout(vo))
      59    endm;
      60
      61$ the following global variables are used in this module:
      62
      63    var
      64	contain,	$ maps each pot. destructive use to
      65			$ set of containing occurrences
      66	all_reldefs,	$ definitions that can contain destructively
      67			$ used values as their parts
      68	globreldefs,	$ the subset of all_reldefs which must be
      69			$ analysed inter-procedurally
      70	psoccsof,	$ maps each destructive use to preceding
      71			$ occurrences of the same variable,
      72			$ which can set the share bit.
      73	puoccsof,	$ maps each destructive use to preceding
      74			$ occurrences of the same variable that
      75			$ definitely yields an unshared value for it.
      76	destconsts,	$ set of constant occurrences appearing in
      77			$ value-flow.
      78
      79	must_copy_memo,	$ memo map for must_copy predicate
      80	rel_comp_memo,	$ memo map for relationship composition
      81	inv_memo,	$ memo map for relationship inversion
      82	rel_inst_memo,	$ memo map for output-input relationship
      83			$ in an instruction
      84
      85	livethru,	$ maps each potentially destructive use n to the
      86			$ set of all definitions which are live at n
      87	destuses,	$ destructive uses at which copy may be
      88			$ required
      89	potdestuses,	$ set of all potentially destructive uses
      90	dstuseini;	$ maps each instruction i of potdestuses to a
      91			$ potentially destructive use in i.
      92
      93$ the following constants are used in this module:
      94
      95$ the first group contains various strings which denote elementary
      96$ membership relationships between setl objects (see procedure
      97$ value_flow for more details).
      98
      99    const
     100	elt	= 'elmt',	eltinv     = 'elmt-1',
     101	cmp	= 'comp',	cmpinv     = 'comp-1',
     102	ncmp1	= 'comp1',	ncmp1inv   = 'comp1-1',
     103	ncmp2	= 'comp2',	ncmp2inv   = 'comp2-1',
     104	ncmp3	= 'comp3',	ncmp3inv   = 'comp3-1',
     105	ncmp4	= 'comp4',	ncmp4inv   = 'comp4-1',
     106	ncmp5	= 'comp5',	ncmp5inv   = 'comp5-1',
     107	ncmp6	= 'comp6',	ncmp6inv   = 'comp6-1',
     108	ncmp7	= 'comp7',	ncmp7inv   = 'comp7-1',
     109	ncmp8	= 'comp8',	ncmp8inv   = 'comp8-1',
     110	ncmp9	= 'comp9',	ncmp9inv   = 'comp9-1',
     111	rngmmap	= 'mmap_range',	rngmmapinv = 'mmap_range-1',
     112	anymb	= 'anymemb',
     113	illeg	= 'illegal';
     114
     115    const
     116	elem_memb_rel =
     117	    { elt,    eltinv,    cmp,    cmpinv,
     118	      ncmp1,  ncmp1inv,  ncmp2,  ncmp2inv,  ncmp3,  ncmp3inv,
     119	      ncmp4,  ncmp4inv,  ncmp5,  ncmp5inv,  ncmp6,  ncmp6inv,
     120	      ncmp7,  ncmp7inv,  ncmp8,  ncmp8inv,  ncmp9,  ncmp9inv,
     121	      rngmmap, rngmmapinv,
     122	      anymb,  illeg },
     123
     124	inverses =
     125	    { eltinv,       cmpinv,
     126	      ncmp1inv,     ncmp2inv,     ncmp3inv,
     127	      ncmp4inv,     ncmp5inv,     ncmp6inv,
     128	      ncmp7inv,     ncmp8inv,     ncmp9inv,
     129	      rngmmapinv },
     130
     131	ncmpis =
     132	    { ncmp1,    ncmp2,    ncmp3,
     133	      ncmp4,    ncmp5,    ncmp6,
     134	      ncmp7,    ncmp8,    ncmp9 },
     135
     136	ncmpi_invs =
     137	    { ncmp1inv, ncmp2inv, ncmp3inv,
     138	      ncmp4inv, ncmp5inv, ncmp6inv,
     139	      ncmp7inv, ncmp8inv, ncmp9inv },
     140
     141	ncmpofi =
     142	    [ ncmp1,    ncmp2,    ncmp3,
     143	      ncmp4,    ncmp5,    ncmp6,
     144	      ncmp7,    ncmp8,    ncmp9 ];
     145
     146
     147    const
     148	rid = [],        $ encodes the identity relationship
     149	anymemb = [ anymb ], $ encodes anymember relationship
     150	illegal = [ illeg ], $ encodes illegal relationship
     151	nestlim = 10;    $ maximal allowed nesting of
     152			 $ elementary relatonships
     153
     154    const
     155	inverse =
     156	    { [  elt,      eltinv      ],  [  eltinv,     elt      ],
     157	      [  cmp,      cmpinv      ],  [  cmpinv,     cmp      ],
     158	      [  ncmp1,    ncmp1inv    ],  [  ncmp1inv,   ncmp1    ],
     159	      [  ncmp2,    ncmp2inv    ],  [  ncmp2inv,   ncmp2    ],
     160	      [  ncmp3,    ncmp3inv    ],  [  ncmp3inv,   ncmp3    ],
     161	      [  ncmp4,    ncmp4inv    ],  [  ncmp4inv,   ncmp4    ],
     162	      [  ncmp5,    ncmp5inv    ],  [  ncmp5inv,   ncmp5    ],
     163	      [  ncmp6,    ncmp6inv    ],  [  ncmp6inv,   ncmp6    ],
     164	      [  ncmp7,    ncmp7inv    ],  [  ncmp7inv,   ncmp7    ],
     165	      [  ncmp8,    ncmp8inv    ],  [  ncmp8inv,   ncmp8    ],
     166	      [  ncmp9,    ncmp9inv    ],  [  ncmp9inv,   ncmp9    ],
     167	      [  rngmmap,  rngmmapinv  ],  [  rngmmapinv, rngmmap  ],
     168	      [  anymb,    anymb       ],  [  illeg,      illeg    ] };
     169
     170    const
     171	iofncmp =
     172	    { [ ncmp1, 1 ], [ ncmp2, 2 ], [ ncmp3, 3 ],
     173	      [ ncmp4, 4 ], [ ncmp5, 5 ], [ ncmp6, 6 ],
     174	      [ ncmp7, 7 ], [ ncmp8, 8 ], [ ncmp9, 9 ] };
     175
     176
     177    repr
     178	base elem_memb_rel:	string;
     179	mode vf_elem_rel:	elmt elem_memb_rel;
     180$
     181$ for storage savings we keep all value flow relations in a base.
     182$
     183	base vf_relations:	tuple(vf_elem_rel);
     184	mode vf_relation:	elmt vf_relations;
     185
     186	elt,   eltinv,   cmp,   cmpinv,
     187	ncmp1, ncmp1inv, ncmp2, ncmp2inv, ncmp3, ncmp3inv,
     188	ncmp4, ncmp4inv, ncmp5, ncmp5inv, ncmp6, ncmp6inv,
     189	ncmp7, ncmp7inv, ncmp8, ncmp8inv, ncmp9, ncmp9inv,
     190	rngmmap, rngmmapinv, anymb, illeg:
     191				vf_elem_rel;
     192
     193	nestlim:		integer;
     194	inverses:		local set(vf_elem_rel);
     195	ncmpis:			local set(vf_elem_rel);
     196	ncmpi_invs:		local set(vf_elem_rel);
     197	ncmpofi:		tuple(vf_elem_rel);
     198	inverse:		local smap(vf_elem_rel) vf_elem_rel;
     199	iofncmp:		local smap(vf_elem_rel) integer;
     200
     201	rid, anymemb:		vf_relation;
     202	illegal:		vf_relation;
     203
     204	mode destuse:		occurrence;
     205	mode reldef:		occurrence;
     206	mode relocc:		occurrence;
     207
     208	potdestuses:		set(destuse);
     209$$--	potdestuses:		remote set(destuse);
     210	dstuseini:		sparse smap(elmt insts) destuse;
     211	all_reldefs:		set(reldef);
     212$$--	all_reldefs:		remote set(reldef);
     213	globreldefs:		sparse set(reldef);
     214	puoccsof, psoccsof:	mmap{destuse} set(relocc);
     215$$--	puoccsof, psoccsof:	remote mmap{destuse} set(relocc);
     216	destconsts:		sparse set(relocc);
     217
     218	must_copy_memo:		smap(vf_relation, elmt forms) boolean;
     219	inv_memo:		smap(vf_relation)
     220				    vf_relation;
     221	rel_comp_memo:		smap(vf_relation, vf_relation)
     222				    vf_relation;
     223	rel_inst_memo:		smap(occurrence)
     224				    mmap{occurrence}
     225					set(vf_relation);
     226
     227	contain:		mmap{destuse} sparse set(relocc);
     228	livethru:		mmap{destuse} sparse set(reldef);
     229$$--	contain:		remote mmap{destuse}
     230$$--				    sparse set(relocc);
     231$$--	livethru:		remote mmap{destuse}
     232$$--				    sparse set(reldef);
     233	destuses:		set(destuse);
     234$$--	destuses:		remote set(destuse);
     235
     236	value_flow:		procedure;
     237	rel_comp_rout:		procedure(vf_relation, vf_relation)
     238				    vf_relation;
     239	inv_rout:		procedure(vf_relation) vf_relation;
     240	rel_inst_rout:		procedure(relocc)
     241				    sparse mmap{relocc}
     242					set(vf_relation);
     243	must_copy_rout:		procedure(vf_relation, elmt forms)
     244				    boolean;
     245
     246	live_dead_analysis:	procedure;
     247	.ofx_s:			operator(df_map_syms, df_elmt_syms)
     248				    df_elmt_syms;
     249	.ofx_o:			operator(df_map_ocrs, df_elmt_ocrs)
     250				    df_elmt_ocrs;
     251	block_flowmaps:		procedure(routine, df_elmt_ocrs)
     252				    tuple(
     253				      remote smap(df_edge) df_map_ocrs,
     254				      remote smap(df_edge) df_map_syms,
     255				      smap(destuse) df_map_ocrs,
     256				      smap(
     257					tuple(destuse, df_node)  )
     258					  df_map_syms
     259				    );
     260	.join_s:		operator(df_map_syms, df_map_syms)
     261				    df_map_syms;
     262	.join_o:		operator(df_map_ocrs, df_map_ocrs)
     263				    df_map_ocrs;
     264	copy_eliminate:		procedure;
     265	copy_share_improve:	procedure;
     266    end repr;
     267
     268    procedure copy_optimize;
     269$
     270$ this is the master procedure for copy optimization. it consists of the
     271$ following phases:
     272$
     273$ 1. value relationship computation: for each  potentially destructive
     274$    use we compute the set of all variable occurrences which may
     275$    contain the value being used at this point as a part.
     276$
     277$ 2. live-dead analysis: we perform live-dead analysis using our
     278$    bit-vectoring data flow analysis package.  for efficiency, we carry
     279$    out this analysis only for occurrences participating in the
     280$    relationships built in phase 1 (in typical programs there should be
     281$    relatively few such occurrences).
     282$
     283$ 3. copy elimination: using the results of phases 1 and 2, we determine
     284$    which potentially destructive uses definitely do not require
     285$    copying.  appropriate copy flags are set accordingly.
     286$
     287$ 4. additional (relatively minor) optimizations can then be carried out
     288$    using the bitvectoring approach outlined in cims rep #17.  these
     289$    include: suppression of share-bit setting, changing conditional
     290$    copies to unconditional copies, and motion of copies out of loops.
     291$
     292$$$ ???? the set potdestuses of potentially destructive uses is computed
     293$$$ ???? here, but in practice this should probably be moved to an
     294$$$ ???? earlier phase.
     295$
smfi 282    init
smfi 283	du_count := 0;	$ counts the destructive uses.
     296    repr
     297	r:			routine;
     298	b:			elmt blocks;
     299	i:			elmt insts;
     300	opc:			elmt base_opcodes;
     301	dvo:			occurrence;
smfi 284	du_count:		integer 0..65536;
     302	entry_time:		integer;
     303    end repr;
     304
     305    title('cims.setl.' + prog_level + ' - copy optimization');
     306    printa(term_file, '   - copy optimisation');
     307
     308    entry_time := time;
     309$
     310$ compute the set potdestuses of all potentially destructive uses
     311$
     312    potdestuses := {};
     313    dstuseini := {};
     314    (forall r in routs)
     315      (for_block(b, r))
     316	(for_inst(i, b))
     317	    opc := opcode(i);
     318$ determine the argument potentially subject to destructive use
     319$ ops_destuse1 (defined in the directory) contains opcodes potentially
     320$ destroying their first ivariable (i.e. their second argument);
     321$ ops_destuse3 and ops_destuse4 have similar meanings.
     322	    if opc in ops_destuse1 then
     323		dvo := get_oi(i, 2);
     324	    elseif opc in ops_destuse3 then
     325		if  opc = q1_next
     326		    $ only the iteration value of a map is used
     327		    $ destructively:  don't analyse remaining cases
     328		    and not is_fmap(ft_deref(form(args(i)(3))))
     329		    and not ft_type(ft_deref(form(args(i)(3)))) = f_gen
     330		then
     331		    continue;
     332		end if;
     333		dvo := get_oi(i, 4);
     334	    elseif opc in ops_destuse4 then
     335		dvo := get_oi(i, 5);
     336	    else
     337		continue;
     338	    end if;
     339
     340$ check the form of dvo to determine whether this is really a
     341$ potentially destructive use (addition of integers is certainly not a
     342$ destructive use, but addition of sets is).
     343$
     344$ the test that we use is somewhat coarse, but should serve as a good
     345$ approximation to find potentially destructive uses:  simply test
     346$ whether the form of the variable of dvo is a 'long' object, i.e. is a
     347$ set, map or tuple (type general is also considered to be long).
     348
smff 149	    if not is_fprim(ft_deref(oi_form(dvo))) or
smff 150		    ft_type(ft_deref(oi_form(dvo))) = f_string then
smff 151		if ft_type(oi_form(dvo)) = f_elmt or
smff 152			ft_type(oi_form(dvo)) = f_string then
     351		    copy_flag(i) := copy_yes;
smfi 285		    du_count +:= 1;
smff 153		    messages{stmtof(i)}{'s'} with:=
     353			[ 'an unconditional copy is required for '
     354			  '"' + oi_name(dvo) + '".' ];
     355		else
     356		    potdestuses  with:= dvo; $ use is potentially dest.
     357		    dstuseini(i)   :=   dvo;
smfi 286		    du_count +:= 1;
     358		    if oi_sym(dvo) in uservars and
     359			    oi_sym(dvo) in globalvars then
     360			globals_du{r} with:= dvo;
     361		    end if;
     362		end if;
     363	    end if;
     364	end;	$ end for_inst;
     365      end;	$ end for_block;
     366    end forall;
smfi 287
smfi 288    if 'e' in dump_string then
smfi 289	print('#all_oi =',           #all_oi,
smfi 290	     ' #all_o =',            #all_o,
smfi 291             ' #all_i =',            #all_i,
smfi 292	     ' #destructive uses =', du_count);
smfi 293	print;
smfi 294    end if;
     367
     368    value_flow;		$ value relationship computation
     369    live_dead_analysis;	$ live-dead analysis
     370    copy_eliminate;	$ copy elimination phase
     371    copy_share_improve;	$ 'bookkeeping' optimisations
     372
     373    $ delete the static variables global to the module
     374    contain := om;      all_reldefs := om;  psoccsof := om;
     375    puoccsof := om;     destconsts := om;   rel_comp_memo := om;
     376    inv_memo := om;     rel_inst_memo := om;
     377    livethru := om;     destuses := om;     potdestuses := om;
     378    dstuseini := om;    globreldefs := om;  must_copy_memo := om;
     379
     380    statistics with:= time;	$ save time for final statistics
     381
     382    if 'e' in dump_string then
     383	print(time - entry_time, 'msecs spent in copy optimization');
     384    end if;
     385
     386
     387    end procedure copy_optimize;
     388
     389
       1 .=member vfl18a
       2
       3
       4    procedure value_flow;
       5$
       6$ this routine accomplishes phase 1 of our copy optimization.  here, for
       7$ each potentially destructive use vo, we compute the set of all
       8$ variable occurrences vo' whose value can contain the value of vo as a
       9$ part at the point of use.  to this end we build up a collection of
      10$ nodes having the form [vo1, r1], where vo1 is a variable occurrence
      11$ and r is a value-relationship indicating how vo1 is related to some
      12$ other value which is a part of vo1.
      13$
      14$ r is represented as a tuple of elementary relationships, and stands
      15$ for their composition.  these elementary relationships are:
      16$
      17$ elt    - element of a set
      18$
      19$ cmp    - component of a tuple
      20$
      21$ ncmpi  - the i-th component of a known length tuple
      22$          note that only the first 9 components of such a tuple
      23$          are handled explicitly; the rest are treated as 'cmp'
      24$
      25$ we begin our analysis with nodes [vo, []], where vo can be any
      26$ potentially destructive use (i.e. belongs to potdestuses).  then,
      27$ tracing bfrom links and ouput-input links within instructions, we
      28$ collect all other nodes which can be linked to such a vo by a series
      29$ of forward links.  then a forward propagation from these new nodes
      30$ will yield all other nodes that can be linked to a potentially
      31$ destructive use by a valid membership relationship.  (see an
      32$ accompanying report for explanation and justification of the facts
      33$ used here).
      34$
      35$ the algorithm is organized so that it does this tracing separately for
      36$ each potentially destructive use.  this simplifies the algorithm, at
      37$ the slight expense of duplicating some value-flow propagations in case
      38$ several potentially destructive uses are linked to the same preceding
      39$ occurrences.
      40$
      41$ this routine computes the gobal object contain, which maps each
      42$ potentially destructive use to the set of all occurrences which
      43$ may contain it as a member (or be equal to it).
      44$
smfh  36    init
smfi 295	sr1 := 0.0,	$ summation of relationship lengths.
smfi 296	sr2 := 0.0,	$ summation of squares of relationship lengths.
smfi 297	sr3 := 0.0;	$ number of relationships.
      45    repr
      46	voxoccs:		sparse set(relocc);
      47	precsoccs, precuoccs:	set(relocc);
      48	allpoccs:		mmap{destuse} set(relocc);
      49$$--	allpoccs:		remote mmap{destuse} set(relocc);
      50	seenoccs:		set(relocc);
      51$$--	seenoccs:		remote set(relocc);
      52	workoccs:		sparse set(relocc);
      53	all_reloccs:		set(relocc);
      54$$--	all_reloccs:		remote set(relocc);
      55	globreloccs:		sparse set(relocc);
      56
      57	relnodes:		set( tuple(relocc, vf_relation) );
      58	uppile, downpile:	set( tuple(relocc, vf_relation) );
      59	inst_props:		set( tuple(relocc, vf_relation) );
      60	node, node1:		tuple(relocc, vf_relation);
      61
      62	opc:			elmt base_opcodes;
      63	r, r1, rx, rx_inv:	vf_relation;
      64	v, vv:			symbol;
      65	vo, vo1:		occurrence;
      66	vox:			destuse;
      67	voy, voz:		relocc;
      68	rin:			sparse mmap{relocc} set(vf_relation);
      69	x:			destuse;
      70	y:			sparse set(relocc);
smfc 635	z:			relocc;
smfi 298	sr1, sr2, sr3:		real;
smfi 299	tr1, tr2, tr3:		real;
smfi 300	mu, sigma:		real;
smfi 301	m1, s1:			integer;
      71	entry_time:		integer;
      72    end repr;
      73
      74    entry_time := time;
      75
      76$ begin by initializing the various memo maps and propagation related
      77$ objects.
      78
      79
      80$ the four following maps are used to store the results computed by
      81$ the routines must_copy, rel_comp, rel_inst and inv, respectively,
      82$ in order to avoid recomputation.
      83$
      84$ must_copy examines a form under a value relationship to determine
      85$ whether a value under this relationship is an element of a base.
      86$ in such a case we must copy unconditionally the value before using
      87$ it destructively, as bases are considered live throughout a program.
      88$
      89$ rel_comp computes the composition of two membership relationships
      90$ (in practice, the second one will always be a relationship between
      91$ output and input arguments of an instruction);
      92
      93$ rel_inst computes the membership/containment relationships between
      94$ the arguments of a given instruction;
      95
      96$ inv computes the inverse of a relationship computed by rel_inst.
      97
      98    must_copy_memo := {};
      99    rel_comp_memo := {};
     100    rel_inst_memo := {};
     101    inv_memo := {};
     102
     103$ in order to track all occurrences and membership relationships that a
     104$ potentially destructive use can be linked to, we can think of the
     105$ algorithm as implicitly constructing two (virtual) graphs upgraph and
     106$ downgraph, whose nodes are pairs of the form
     107$	[ occurrence, relationship ],
     108$ and whose edges constitute direct links between these pairs.  a direct
     109$ link between the pairs [ vo1, r1 ] and [ vo2, r2 ] exists either when
     110$ vo1 and vo2 are linked by bfrom (and r1 = r2), or when vo1 and vo2
     111$ are an input and an output occurrences within the same instruction.
     112$ upgraph would consist of all such links collected during the first
     113$ (upward) propagation phase of the algorithm, while downgraph would
     114$ consist of links collected during the second, downward propagation
     115$ phase.
     116
     117$ initialize the output map of this analysis, as defined above.
     118    contain := {};
     119
     120    all_reloccs := {};	$ relevant occurrences collected by value flow
     121    globreloccs := {};	$ subset of all_reloccs to be analysed globally
     122
     123    psoccsof := {};	$ maps each destructive use to preceding
     124			$ occurrences of the same variable
     125    puoccsof := {};
     126    allpoccs := {};	$ set of all occurrences preceding some
     127			$ destructive use
     128$ process each potentially destructive use
     129    (forall vox in potdestuses)
     130	precsoccs := {};	$ preceding occurrences which can set
     131				$ the share bit
     132	precuoccs := {};	$ preceding occurrences yielding
     133				$ unshared values.
     134	workoccs := {vox};	$ workpile of preceding occurrences
     135	seenoccs := {};		$ occurrences allready seen
     136	(while workoccs /= {})
     137	    voy from workoccs;
     138	    seenoccs with:= voy;
     139	    (forall voz in bfrom{voy} | voz notin seenoccs)
smfd 842		opc := oi_op(voz);
     141		if (case argno(voz) of
     142			(1): opc in ops_share1,
     143			(2): opc in ops_share2,
     144			(3): opc in ops_share3,
     145			(4): opc in ops_share4
     146			else false
     147		    end)
     148		then
     149		    if opc = q1_asn and
     150			    argno(voz) = 1 and
     151			    is_const(vv := arg2(instno(voz))) = 1 and
     152			    (value(vv) = {} or value(vv) = []) then
     153			precuoccs with:= voz;
     154		    else
     155			precsoccs with:= voz;
     156		    end if;
     157
     158		elseif is_ovar(voz) and opc notin ops_nonewval then
     159		    precuoccs with:= voz;
     160
     161		else
     162		    workoccs with:= voz;
     163		end if;
     164	    end forall;
     165	end while;
     166	psoccsof{vox} := precsoccs;
     167	puoccsof{vox} := precuoccs;
     168	allpoccs{vox} := precsoccs + precuoccs;
     169    end forall;
     170
     171
     172    (forall [ voy, vox ] in allpoccs)
smfc 636	if 'p' in dump_string and 'z' in dump_string then
smfc 637	    print('start new batch at ', time);
smfc 638	    print('  destructive use:', oi_str(voy), '=', oi_name(voy));
smfc 639	    print('  prec occurrence:', oi_str(vox), '=', oi_name(vox));
smfc 640	end if;
     173
     174	$ start the propagation at potentially destructive use vox
     175	node := [ vox, rid ];
     176	$ initialize relnodes, uppile and downpile.
     177	$ relnodes is the set of all nodes encountered so far
     178	relnodes := { node };
     179$ the elements of uppile are pairs of the form
     180$	    [ occ, rel ]
     181$ indicating a desired propagation from occ and rel to
     182$ preceding occurrences. if occ is an ovariable, then rel should
     183$ be propagated to ivariables of the instruction containing occ;
     184$ if occ is an ivariable then rel should be propagated to previous
     185$ occurrences of the same variable linked to occ by bfrom.
     186
     187	uppile   := { node };
     188
     189$ downpile is a similar workpile for downward propagation; it consists
     190$ of pairs like those appearing in uppile.  each such pair
     191$ [ occ, rel ] indicates a desired propagation from occ in the
     192$ direction of execution flow.  such a propagation would be
     193$ to other occurrences of the same varible linked to occ by ffrom,
     194$ and, if occ is an ivariable, also to the ovariable of its
     195$ instruction.
     196$
     197$ in order to avoid that extra propagation in cases where the
     198$ reverse propagation (from ovariable to ivariable) has already
     199$ taken place during the upward propagation phase, we maintain an
     200$ additional set inst_props of all such pairs [ occ, rel ] where
     201$ occ is an ivariable and rel is relationship that has been propagated
     202$ to occ from its ovariable. see below for the use of that set.
     203
     204	inst_props := {};
     205
     206	downpile := { node };
     207$
     208$ carry out upward propagation
     209$
     210	(while uppile /= {})
     211
smfc 641	    node from uppile;
smfc 642	    [ vo, r ] := node;
smfc 643
smfc 644	    if 'p' in dump_string and 'z' in dump_string then
smfc 645		print(' uppile:', oi_str(vox), r, oi_str(vo), '=',
smfc 646			oi_name(vo));
smfc 647	    end if;
     213
     214	    if is_ivar(vo) then
     215
     216		(forall vo1 in bfrom{vo} | vo1 /= vo)
     217		    if (node := [ vo1, r ]) notin relnodes then
smfc 648			$ new node for propagation
     219			relnodes with:= node;
     220
     221			uppile   with:= node;
     222			downpile with:= node;
     223		    end if;
     224		end forall;
smfc 649
     225	    elseif is_ovar(vo) then
     226
smfc 650		$ call a memo routine to obtain the output-input value
smfc 651		$ relationships for the instruction of vo.
     229		rin := rel_inst(vo);
     230
     231		(forall [ vo1, rx ] in rin)  $ vo1 is ivar of this inst
smfc 652		    $ call another memo routine to compose r with rx.
     233		    r1 := rel_comp(r, rx);
     234
     235		    if r1 /= illegal then
smfc 653			$ composition yields a valid membership
smfc 654			$ relationship r1.
     237			node := [ vo1, r1 ];
smfc 655
smfc 656			$ check if node has not been traced yet.
     239			if node notin relnodes then $ new node for pro
     240			    relnodes with:= node;
     241
     242$ put node in inst_props to record the fact that propagation from vo
     243$ and r to vo1 and r1 has already taken place.  note that we assume
     244$ here that this propagation is one-to-one, so that in particular it
     245$ is fully determined by .  this is generally the case, except
     246$ for cases involving ambiguous memb relationships (see comments in
     247$ rel_comp), or cases where the maximal nesting level has been exceeded.
     248$ in this cases backward propagation from vo1 and r1 to vo might result
     249$ in a relationship r' which is always an overestimation of r.  thus
     250$ the use of inst_props can help us in avoiding that overestimation.
     251
     252			    inst_props with:= node;
     253
     254			    uppile   with:= node;
     255			    downpile with:= node;
     256			end if;
     257
     258		    end if;
     259		end forall;
     260
     261	    end if;
     262	end while;
     263$
     264$ now perform downward propagation
     265$
     266$ the logic of the downward propagation step is quite similar to that
     267$ of the upward propagation step; see that step for more comments.
     269$
     270	(while downpile /= {})
     271	    node from downpile;
     272	    [ vo, r ] := node;
smfc 657
smfc 658	    if 'p' in dump_string and 'z' in dump_string then
smfc 659		print('  downpile:', oi_str(vox), r, oi_str(vo), '=',
smfc 660			oi_name(vo));
smfc 661	    end if;
     273	    if is_ivar(vo) and node notin inst_props then
     274		opc := oi_op(vo);   $ get the opcode
     275		if opc in ops_ovar then
     276$ vo's instruction has an ovariable. propagate relationship to it
     277		    vo1 := get_ovar(vo);  $ get the o-variable
     278		    inst_props with:= node;
     279		    rin := rel_inst(vo1);
     280		    (forall rx in rin{vo})
     281$ compose r with the inverse of rx to get the relation at vo1
     282			rx_inv := inv(rx);
     283			r1     := rel_comp(r, rx_inv);
     284			if r1 /= illegal then
     285			    node1 := [ vo1, r1 ];
     286			    if node1 notin relnodes then
     287				relnodes with:= node1;
     288				downpile with:= node1;
     289			    end if;
     290			end if;
     291		    end forall;
     292		end if;
     293	    end if;
     294
     295	    $ in any case, propagate forward via ffrom
     296	    (forall vo1 in ffrom{vo})
     297		if (node := [ vo1, r ]) notin relnodes then
     298		    relnodes with:= node;
     299		    downpile with:= node;
     300		end if;
     301	    end forall;
     302	end while;
     303
smfi 302	if 'e' in dump_string then
smfi 303	  tr1 := tr2 := tr3 := 0.0;
smfi 304	  (forall [ vo, r ] in relnodes)
smfi 305		sr1 +:= float(#r); sr2 +:= float(#r) ** 2; sr3 +:= 1.0;
smfi 306		tr1 +:= float(#r); tr2 +:= float(#r) ** 2; tr3 +:= 1.0;
smfi 307	  end forall;
smfi 308	  mu    := tr1 / tr3;
smfi 309	  sigma := sqrt( (tr2 - tr1**2/tr3) / tr3 );
smfi 310	  m1 := fix(mu * 1000.0); s1 := fix(sigma * 1000.0);
smfi 311	  print('#rels =', fix tr3, '=', #relnodes,
smfi 312	    ' min =',  min/[ #r : [ -, r ] in relnodes ],
smfi 313	    ' max =',  max/[ #r : [ -, r ] in relnodes ],
smfi 314	    ' mean =', str(m1 div 1000)+'.'+str(m1 mod 1000),
smfi 315	    ' sdev =', str(s1 div 1000)+'.'+str(s1 mod 1000),
smfi 316	    ' cv =',   if mu /= 0.0 then 100.0*sigma/mu else 0 end, '%'
smfi 317	    );
smfi 318	end if;
     304
smfh  40        if exists [ vo, r ] in relnodes |
smfh  41                                must_copy(r, oi_form(vo)) then
     306	    copy_flag(instno(voy)) := copy_yes;
smfc 662	    messages{stmtof(instno(voy))}{'s'} with:=
     308		[ 'an unconditional copy is required for '
     309		  '"' + oi_name(voy) + '".' ];
     310	    potdestuses less:= voy;
     311	    dstuseini(instno(voy)) := om;
     312	else
     313	    voxoccs      := domain relnodes;
     314	    contain{vox} := voxoccs;
     315	    all_reloccs +:= voxoccs;
     316	    globreloccs +:= { vo in voxoccs |
     317				(v := oi_sym(vo)) in globalvars
     318				or is_param(v)=1
     319				or scope(v) /= scope(oi_sym(vox))    };
     320	end if;
     321    end forall;
     322
     323    if 'p' in dump_string then
smfc 663	prints('contain =',
smfc 664	    [ [ oi_str(x), { oi_str(z) : z in y } ] : y = contain{x} ]
smfc 665	    );
     325    end if;
     326
     327    $ reldefs is the set of relevant definitions collected by this phase
     328    all_reldefs := { vo in all_reloccs | is_ovar(vo) };
     329
     330    $ globreldefs is the subset of reldefs to be analysed globally
     331    globreldefs := { vo in all_reldefs | vo in globreloccs };
     332
     333    $ destconsts is the set of constants involved in the analysis
     334    destconsts  := { vo in all_reloccs |
     335			    is_const(v := oi_sym(vo))=1 and
     336			    value(v) /= {} and value(v) /= []    };
     337
     338    $ free some space to be garbage collected
     339    rel_comp_memo  := om;
     340    inv_memo       := om;
     341    rel_inst_memo  := om;
     342    must_copy_memo := om;
     343
     344    if 'e' in dump_string then
smfi 319	if sr3 > 0.0 then
smfi 320	  print;
smfi 321	  mu    := sr1 / sr3;
smfi 322	  sigma := sqrt( (sr2 - sr1**2/sr3) / sr3 );
smfi 323	  m1 := fix(mu * 1000.0); s1 := fix(sigma * 1000.0);
smfi 324	  print('#rels =', fix sr3,
smfi 325	    ' mean =', str(m1 div 1000)+'.'+str(m1 mod 1000),
smfi 326	    ' sdev =', str(s1 div 1000)+'.'+str(s1 mod 1000),
smfi 327	    ' cv =',   if mu /= 0.0 then 100.0*sigma/mu else 0 end, '%'
smfi 328	    );
smfi 329	end if;
smfh  46	print;
     345	print(time - entry_time, 'msecs for value flow');
     346    end if;
     347
     348    end procedure value_flow;
     349
     350
     351
     352
     353    procedure rel_comp_rout(r, rx);
     354$
     355$ this routine computes the composition of the membership relationship
     356$ r, given as a tuple of elementary membership relationships (such as
     357$ elt, cmp, ncmpi etc.) with the relationship rx, which designates a
     358$ value relationship between output and input arguments of an instruc-
     359$ tion.  rx is also given as a tuple, but each component of rx can
     360$ designate either a membership relationship or its inverse (i.e. a
     361$ containment relationship such as eltinv, cmpinv, ncmpiinv, etc.).
     363$
     364$ to ensure convergence of our algorithm we impose a nesting level
     365$ limit nestlim on membership relatioships.  any relation r containing
     366$ more than nestlim elementary components is crudely represented as the
     367$ symbol anymemb, indicating at least nestlim levels of elementary
     368$ memberships.  anymemb relationships do not change by composition with
     369$ any other relationship.  this is an overestimation which is safe in
     370$ the sense that it cannot cause a possible membership relationship to
     371$ disappear (although it can add spurious membership relationships).
     373$
     374$ in some cases of ambiguous types (e.g. 'a set or a tuple'), rx may
     375$ contain ambiguous membership relationships, (e.g. 'an element of a
     376$ set or a component of a tuple').  in these cases we keep the set of
     377$ all valid membership relationships in a given relationship rx.  for
     378$ example, in 'y := f(x)' where f can be either a map or a tuple, y can
     379$ be either a cmp of f or a ncmp2 of an elt of f.  in such cases we
     380$ represent the relationship as n consecutive memb's, where n is the
     381$ maximal possible number of nested elementary relationships that can
     383$ constitute that relationship (2 in the above example).
     384$
     385$ a problem can arise in the above treatment of ambiguous level of
     386$ membership.  consider for example a relationship r having the form
     387$ elt.cmp;  suppose that we compose r with a relationship
     388$ rx = memb.memb which indicates either one or two possible levels of
     389$ membership.  this will produce the relationship elt.cmp.memb.memb;
     390$ now suppose that we want to compose it first with the inverse of rx
     391$ (a relationship representing either one or two levels of containment)
     392$ and then with the inverse of r.  to play safe, we must represent the
     394$ inverse of rx as memb-1 (using the minimal possible level of
     395$ containment, for otherwise we run into the risk of removing too many
     396$ levels of membership, which may make us treat certain valid membership
     397$ relationships as invalid), so that the first composition, if treated
     398$ casually, will yield elt.cmp.memb, and then the second composition of
     399$ this relationship with cmp-1.elt-1 will be found to be illegal, due
     400$ to a failure to match direct relationships correctly.
     402$
     403$ the solution that we will use is as follows:  whenever a relationship
     404$ is composed with memb or memb-1, we first convert it by replacing each
     405$ component by memb, and then performing the composition using standard
     406$ rules.  thus, in the above example the composition of r with rx will
     407$ yield memb.memb.memb.memb and the next two compositions can then be
     408$ carried out safely resulting in the relationship memb.
     410$
     411$ to make this routine more efficient, we maintain a 'memo' map which
     412$ records all previously computed compositions.
     413$
     414    repr
     415	r, r1, rx:		vf_relation;
     416	rxi, last:		vf_elem_rel;
     417	i, ir1:			integer;
     418    end repr;
     419
     420    r1 := r;
     421    (forall rxi = rx(i))
     422	if rxi notin inverses then
     423	    if # r1 = nestlim then $ convert to anymemb repr
     424		r1 := anymemb;
     425	    elseif r1 = anymemb then
     426$ r already has the anymemb representation; leave it unchanged
     427		quit forall;
     428	    else    $ normal case
     429		r1 with:= rxi;  $ append new membership to r1
     430	    end if;
     431	else    $ a containment relationship
     432	    if r1 = [] then
     433		r1 := illegal;
     434		quit forall;
     435	    else    $ normal case
     436$ remove the last elementary subrelationship from r1 and check that it
     437$ matches the current subrelationship of rx.  (we allow matching of
     438$ memb with any relationship, and also matching of cmp with any ncmpi.)
     439
     440		last frome r1;
     441		if inverse(last) /= rxi and
     442			(last /= cmp or rxi notin ncmpi_invs) and
     443			(rxi /= cmpinv or last notin ncmpis) then
     444		    r1 := illegal;
     445		    quit forall;
     446		end if;
     447	    end if;
     448	end if;
     449    end forall;
     450
     451    return rel_comp_memo(r, rx) := r1;
     452
     453    end procedure rel_comp_rout;
     454
     455
     456
     457
     458    procedure inv_rout(rx);
     459$
     460$ compute the inverse of rx.  this simply reverses the components of rx
     461$ and the flag bits which these components may contain.
     463$
     464    repr
     465	rx, ry:			vf_relation;
     466	i:			integer;
     467    end repr;
     468
     469
     470    ry := [ inverse(rx(i)) : i in [ #rx, #rx-1..1 ] ];
     471
     472    return inv_memo(rx) := ry;
     473
     474    end procedure inv_rout;
     475
     476
       1 .=member rln18b
       2
       3
       4    procedure rel_inst_rout(vo);
       5$
       6$ this routine computes the output-input relationships for an
       7$ instruction whose output occurrence is vo.  it returns a map rin
       8$ which maps each input occurrence iv in that instruction to the
       9$ relationship of the value of vo to the value of iv, given in the form
      10$ described in the comments associated with the routine rel_comp.
      12$
      13$ for efficiency, this routine uses a memo map to record the
      14$ relationships computed for previously processed instructions.
      15$
      16$ the following macros are used in this procedure:
      17$
      22    macro maybe_tup(fm);   (is_ftup(fm) or ft_type(fm) = f_gen)   endm;
      23    macro maybe_set(fm);   (is_fset(fm) or ft_type(fm) = f_gen)   endm;
      24    macro maybe_map(fm);   (is_fmap(fm) or ft_type(fm) = f_gen)   endm;
      25
      26    repr
      27	vo, voj:		occurrence;
      28	rin:			mmap{occurrence}
      29				    set(vf_relation);
      30	inst:			elmt insts;
      31	opc:			elmt base_opcodes;
      32	argsi:			tuple(symbol);
      33	ivs:			tuple(occurrence);
      34	iv1, iv2, iv3, iv4:	occurrence;
      35	a1, a2, a3, a4:		symbol;
      36	fm:			elmt forms;
      37	ncmpi, ncmpj:		vf_elem_rel;
      38	j:			integer;
      39    end repr;
      40
      41
      42    rin   := {};
      43    inst  := instno(vo);
      44    opc   := opcode(inst);
      45    argsi := args(inst);
      46    [ a1, a2, a3, a4 ] := argsi;
      47
      48    $ nb. none of the operators of interest in this routine are in
      49    $ ops_ivar (ie. operators whose first argument is an i-variable):
      50    $ hence the following loop has a lower bound of two.
      51    ivs := [ get_oi(inst, j) : j in [ 2..#argsi ] ];
      52    [ iv1, iv2, iv3, iv4 ] := ivs;
      53
      54    case opc of
      55
      56    (q1_asn, q1_argin):		$ vo = iv1
      57	rin{iv1} with:= rid;
      58
      59    (q1_argout):		$ vo = iv3
      60	rin{iv3} with:= rid;
      61
      62    (q1_arb, q1_rand):
      63	$ vo elt iv1   if iv1 is a set or map;
      64	$ vo cmp iv1   if a tuple
      65	fm := ft_deref(form(a2));
      66	if maybe_set(fm) then
      67	    rin{iv1} with:= [ elt ];
      68	end if;
      69
      70	if maybe_tup(fm) then
      71	    rin{iv1} with:= [ cmp ];
      72	end if;
      73
      74    (q1_with):
      75	$ vo elt-1.elt iv1   if vo is a set or a map; i.e. vo contain
      76	$ elements that are also elements of iv1. also vo elt-1 iv2.
      77	$ similar relationships apply for tuples and ambiguous types.
      78	fm := ft_deref(form(a1));
      79	if maybe_set(fm) then
      80	    rin{iv1} with:= [ eltinv, elt ];
      81	    rin{iv2} with:= [ eltinv ];
      82	end if;
      83
      84	if maybe_tup(fm) then
      85	    rin{iv1} with:= [ cmpinv, cmp ];
      86	    rin{iv2} with:= [ cmpinv ];
      87	end if;
      88
      89    (q1_of):
      90	$ vo cmp iv1, if iv1 is a tuple;
      91	$ vo ncmpi iv1, if in addition the value of iv2 = i is known
      92	$		and less than 9
      93	$ vo ncmp2.elt iv1, if iv1 is a map;
      94	fm := ft_deref(form(a2));
      95	if maybe_tup(fm) then
      96	    if ft_type(fm) = f_mtuple and
      97		    is_const(oi_sym(iv2)) = 1 and
      98		    ft_type(oi_form(iv2)) = f_sint and
      99		    (ncmpi := ncmpofi(oi_val(iv2))) /= om then
     100		rin{iv1} with:= [ ncmpi ];
     101	    else
     102		rin{iv1} with:= [ cmp ];
     103	    end if;
     104	end if;
     105
     106	if maybe_set(fm) then
     107	    rin{iv1} with:= [ ncmp2, elt ];
     108	end if;
     109
     110    (q1_sof):
     111	$ vo cmp-1 (or ncmpi-1) iv2, and
     112	$ vo cmp-1.cmp iv3, if vo is a tuple;
     113	$ vo elt-1.ncmp1-1 iv1,
     114	$ vo elt-1.ncmp2-1 iv2, and
     115	$ vo elt-1.elt iv3, if vo is a map;
     116	fm := ft_deref(form(a1));
     117	if maybe_tup(fm) then
     118	    if ft_type(fm) = f_mtuple and
     119		    is_const(oi_sym(iv1)) = 1 and
     120		    ft_type(oi_form(iv1)) = f_sint and
     121		    (ncmpi := ncmpofi(oi_val(iv1))) /= om then
     122		rin{iv2} with:= [ inverse(ncmpi) ];
     123	    else
     124		rin{iv2} with:= [ cmpinv ];
     125	    end if;
     126	    rin{iv3} with:= [ cmpinv, cmp ];
     127	end if;
     128
     129	if maybe_set(fm) then
     130	    rin{iv1} with:= [ eltinv, ncmp1inv ];
     131	    rin{iv2} with:= [ eltinv, ncmp2inv ];
     132	    rin{iv3} with:= [ eltinv, elt ];
     133	end if;
     134
     135    (q1_ofa):
     136	$ vo elt-1.ncmp2.elt iv1, if iv1 is a map
     137	fm := ft_deref(form(a2));
     138	if maybe_set(fm) then
     139	    rin{iv1} := { [ eltinv, ncmp2, elt ], [ rngmmap ] };
     140	end if;
     141
     142    (q1_sofa):
     143	$ vo elt-1.ncmp2-1.elt iv2,
     144	$ vo elt-1.ncmp1-1 iv1, and
     145	$ vo elt-1.elt iv3, if vo is a map;
     146	fm := ft_deref(form(a1));
     147	if maybe_set(fm) then
     148	    rin{iv1} with:= [ eltinv, ncmp1inv ];
     149	    rin{iv2} := { [ eltinv, ncmp2inv, elt ], [ rngmmapinv ] };
     150	    rin{iv3} with:= [ eltinv, elt ];
     151	end if;
     152
     153    (q1_add):
     154	$ vo elt-1.elt iv1 and iv2, if they are sets or maps;
     155	$ vo cmp-1.cmp iv1 and iv2, if tuples.
     156	fm := ft_deref(form(a1));
     157	if maybe_set(fm) then
     158	    rin{iv1} with:= [ eltinv, elt ];
     159	    rin{iv2} with:= [ eltinv, elt ];
     160	end if;
     161
     162	if maybe_tup(fm) then
     163	    rin{iv1} with:= [ cmpinv, cmp ];
     164	    rin{iv2} with:= [ cmpinv, cmp ];
     165	end if;
     166
     167    (q1_sub):
     168	$ same as q1_add for sets and maps
     169	fm := ft_deref(form(a1));
     170	if maybe_set(fm) then
     171	    rin{iv1} with:= [ eltinv, elt ];
     172	end if;
     173
     174    (q1_mult):
     175	$ vo elt-1.elt iv1 and iv2, if they are sets or maps
     176	$ for vo a tuple, interpret as tuple repitition.  the
     177	$ vo cmp-1.cmp iv can hold for any ivariable iv which can be
     178	$ a tuple.
     179	fm := ft_deref(form(a1));
     180	if maybe_set(fm) then
     181	    rin{iv1} with:= [ eltinv, elt ];
     182	    rin{iv2} with:= [ eltinv, elt ];
     183	end if;
     184
     185	if maybe_tup(fm) then
     186	    if maybe_tup(ft_deref(form(a2))) then
     187		rin{iv1} with:= [ cmpinv, cmp ];
     188	    end if;
     189	    if maybe_tup(ft_deref(form(a3))) then
     190		rin{iv2} with:= [ cmpinv, cmp ];
     191	    end if;
     192	end if;
     193
     194    (q1_less):
     195	$ same as q1_with, but only for iv1 and only for sets/maps.
     196	fm := ft_deref(form(a1));
     197	if maybe_set(fm) then
     198	    rin{iv1} with:= [ eltinv, elt ];
     199	end if;
     200
     201    (q1_lesse, q1_lessb):
     202	$ same as q1_with, but only for iv1 and only for tuples.
     203	rin{iv1} with:= [ cmpinv, cmp ];
     204
     205    (q1_lessf):
     206	$ same as q1_with, but only for iv1 and only for maps.
     207	fm := ft_deref(form(a1));
     208	if maybe_set(fm) then
     209	    rin{iv1} with:= [ eltinv, elt ];
     210	end if;
     211
     212    (q1_pow):
     213	$ vo elt-1.elt-1.elt iv1
     214	rin{iv1} with:= [ eltinv, eltinv, elt ];
     215
     216    (q1_npow):
     217	$ vo elt-1.elt-1.elt iv2
     218	rin{iv2} with:= [ eltinv, eltinv, elt ];
     219
     220    (q1_dom):
     221	$ vo elt-1.ncmp1.elt iv1
     222	rin{iv1} with:= [ eltinv, ncmp1, elt ];
     223
     224    (q1_range):
     225	$ vo elt-1.ncmp2.elt iv1
     226	rin{iv1} with:= [ eltinv, ncmp2, elt ];
     227
     228    (q1_end, q1_subst):
     229	$ vo cmp-1.cmp iv1, if they are tuples.
     230	fm := ft_deref(form(a1));
     231	if maybe_tup(fm) then
     232	    rin{iv1} with:= [ cmpinv, cmp ];
     233	end if;
     234
     235    (q1_send):
     236	$ vo cmp-1.cmp iv2 and iv3, if tuples
     237	fm := ft_deref(form(a1));
     238	if maybe_tup(fm) then
     239	    rin{iv2} with:= [ cmpinv, cmp ];
     240	    rin{iv3} with:= [ cmpinv, cmp ];
     241	end if;
     242
     243    (q1_ssubst):
     244	$ same as in q1_send, for iv3 and iv4
     245	fm := ft_deref(form(a1));
     246	if maybe_tup(fm) then
     247	    rin{iv3} with:= [ cmpinv, cmp ];
     248	    rin{iv4} with:= [ cmpinv, cmp ];
     249	end if;
     250
     251    (q1_set):
     252	$ vo elt-1 ivj, for j = 2,...
     253	(forall j in [ 2..#argsi ])
     254	    voj := get_oi(inst, j);
     255	    rin{voj} with:= [ eltinv ];
     256	end forall;
     257
     258    (q1_tup):
     259	$ vo ncmpj-1 (or cmp-1) ivj, for j = 2,...
     260	(forall j in [ 2..#argsi ])
     261	    voj := get_oi(inst, j);
     262	    if (ncmpj := ncmpofi(j-1)) /= om then
     263		rin{voj} with:= [ inverse(ncmpj) ];
     264	    else
     265		rin{voj} with:= [ cmpinv ];
     266	    end if;
     267	end forall;
     268
     269    (q1_set1):
     270	$ vo elt-1 iv1
     271	rin{iv1} with:= [ eltinv ];
     272
     273    (q1_tup1):
     274	$ vo cmp-1 iv1
     275	rin{iv1} with:= [ cmpinv ];
     276
     277    (q1_inext, q1_next):
     278	$ vo.ncmpj-1.ncmpj.elt.iv2, j = 1,2, if iv2 is a map
     279	$ vo.rid.iv3, if iv2 is a map and opc = q1_next (see below)
     280	$ vo.elt.iv2, if iv2 is a set
     281	$ vo.cmp.iv2, if iv2 is a tuple
     282	$ in the current implementation, q1_inext creates a new pair
     283	$ for the map elements, and q1_next uses this pair destruc-
     284	$ tively in order to create the next map element.  iv3 is an
     285	$ additional argument introduced by the optimiser, and desi-
     286	$ gnates the destructive use of the output variable.
     287	fm := ft_deref(form(a3));
     288	if maybe_map(fm) then
     289	    rin{iv2} := { [ ncmp1inv, ncmp1, elt ],
     290			  [ ncmp2inv, ncmp2, elt ] };
     291	    if opc = q1_next then
     292		rin{iv3} with:= rid;
     293	    end if;
     294	end if;
     295
     296	if maybe_set(fm) and not is_fmap(fm) then
     297	    rin{iv2} with:= [ elt ];
     298	end if;
     299
     300	if maybe_tup(fm) then
     301	    rin{iv2} with:= [ cmp ];
     302	end if;
     303
     304    (q1_inextd, q1_nextd):
     305	$ vo ncmp1.elt iv2, if iv2 is a map
     306	fm := ft_deref(form(a3));
     307	if maybe_set(fm) then
     308	    rin{iv2} with:= [ ncmp1, elt ];
     309	end if;
     310
     311    (q1_arbb, q1_arbe):
     312	$ vo cmp iv1, if iv1 is a tuple
     313	rin{iv1} with:= [ cmp ];
     314
     315    end case;
     316
     317    return rel_inst_memo(vo) := rin;
     318
     319
     320    end procedure rel_inst_rout;
     321
     322
     323
     324
     325    procedure must_copy_rout(r, fm);
     326$
     327$ this procedure examines the form fm under the value relationship r.
     328$ an unconditional copy is required if the containment expressed in r
     329$ involves a base element.  this is a slight overestimate, since bases
     330$ are asumed to be always live.  it simplifies, however, our algoritm
     331$ considerably.
     332$
     333    repr
     334	r:			vf_relation;
     335	fm:			elmt forms;
     336
     337	r1:			vf_relation;
     338	xfm:			elmt forms;
     339	rx:			vf_elem_rel;
     340    end repr;
     341
     342
     343    if ft_type(fm)= f_elmt and is_fprim(ft_deref(fm)) then
     344	return must_copy_memo(r, fm) := false;
     345
     346    elseif ft_type(fm) = f_elmt then
     347	return must_copy_memo(r, fm) := true;
     348
     349    elseif ft_type(fm) = f_gen then
     350	return must_copy_memo(r, fm) := false;
     351
     352    elseif r = rid then
     353	return must_copy_memo(r, fm) := false;
     354
     355    else
     356	r1 := r;   rx frome r1;
     357
     358	return
     359	    must_copy_memo(r, fm) := case rx of
     360
     361	    (elt):	if is_fset(fm) then
     362			    must_copy(r1, ft_elmt(fm))
     363			else
     364			    false
     365			end,
     366
     367	    (cmp):	if ft_type(fm) = f_mtuple then
     368			    if exists xfm in ft_elmt(fm) |
     369						must_copy(r1, xfm) then
     370				true
     371			    else
     372				false
     373			    end
     374			elseif is_ftup(fm) then
     375			    must_copy(r1, ft_elmt(fm))
     376			else
     377			    false
     378			end,
     379
     380	    (arb ncmpis):
     381			if ft_type(fm) = f_mtuple then
     382			    must_copy(r1, ft_elmt(fm)(iofncmp(rx)))
     383			elseif is_ftup(fm) then
     384			    must_copy(r1, ft_elmt(fm))
     385			else
     386			    false
     387			end,
     388
     389	    (rngmmap):	if is_fmap(fm) and ft_mapc(fm) = ft_mmap then
     390			    must_copy(r1, ft_im(fm))
     391			else
     392			    false
     393			end,
     394
     395	    (anymb):	if ft_type(fm) = f_mtuple then
     396			    if exists xfm in ft_elmt(fm) |
     397						must_copy(r, xfm) then
     398				true
     399			    else
     400				false
     401			    end
     402			elseif is_ftup(fm) or is_fset(fm) then
     403			    must_copy(r, ft_elmt(fm))
     404			else
     405			    false
     406			end
     407
     408	    else
     409		expr
     410		    print;
     411		    print('error in must_copy: r =', r, 'form =', fm);
     412		    stop;
     413		    yield false;
     414		end
     415	    end;
     416    end if;
     417
     418    end procedure must_copy_rout;
     419
     420
       1 .=member lva18c
       2
       3
       4    procedure live_dead_analysis;
       5$
       6$ this routine performs live-dead analysis for all variable occurrences
       7$ in reloccs. an occurrence vo of a variable v is said to be live at a
       8$ given point n if there exists a path from vo to a use of v which
       9$ passes through n and which is free of any modifications of v.
      10$
      11$ for simplicity we break the analysis into two subphases:  first, for
      12$ each point n within a potentially destructive use, we compute the set
      13$ of all occurrences in reloccs which can reach n (this is done in a way
      14$ resembling our method of bfrom computation.  for efficiency we
      15$ restrict this analysis only to variable definitions belonging to
      16$ reloccs.  note that it is sufficient to consider only definitions
      17$ rather than both definitions and uses in reloccs for the simple reason
      18$ that if a use in reloccs can reach a given program point n, then there
      19$ must exist a definition of the same variable preceding the use which
      20$ also belongs to reloccs and can reach n (assuming no uninitialized
      21$ variables)).
      22$
      23$ then we compute the set of all variables v which have occurrences in
      24$ reloccs and which are live at n (in the usual sense of liveness at a
      25$ point).  combination of the results of these two analyses gives us the
      26$ information we need.  we caution that a slight overestimation may
      27$ occur in the interprocedural case (in the analysis of global
      28$ variables), since the existence of two interprocedurally valid
      29$ subpaths (from an occurrence vo of a global variable v to a
      30$ potentially destructive operation n and then from n to a use of v)
      31$ does not necessarily imply that their concatenation is also
      32$ interproceduraly valid.
      33$
      34$ liveness information is returned in a map livethru which maps each
      35$ potentially destructive use n to the set of all definitions in reloccs
      36$ which are live at n.
      37$
      38$ it should be noted that our copy optimization algorithm avoids an
      39$ important issue that would have arisen if we were to use a simpler
      40$ approach based on bitvectoring data-flow analysis, such as in setl
      41$ nl. 195.  this is the issue of 'globalization' of share-bit setting.
      42$ suppose that a variable v which will later be used destructively is
      43$ passed as a parameter to some procedure p. this valuetransfer already
      44$ causes v to be shared with the corresponding formal parameter, and v
      45$ may also be shared with other local variables of p.  however, unless
      46$ the value of v became part of a global object (or a write parameter)
      47$ during the execution of p, the call to p should not be viewed as
      48$ sharing the value of v after the call has been completed.  this fact,
      49$ which is very difficult to pick up by using a bitvectoring scheme, is
      50$ handled implicitly by the live analysis used by our algorithm.  this
      51$ comment has been included here as a reminder and warning if an attempt
      52$ is made to replace the value-flow based algorithm by a simpler
      53$ bitvectoring scheme.  this issue also needs to be considered carefully
      54$ in the bitvectoring 'bookkeeping optimization' phase (see procedure
      55$ copy_share_improve below).
      56$
      57    repr
      58	freach:			remote smap(df_edge) df_map_ocrs;
      59	flive:			remote smap(df_edge) df_map_syms;
      60	frdestuse:		smap(destuse) df_map_ocrs;
      61	fldestuse:		smap( tuple(destuse, df_node) )
      62				    df_map_syms;
      63	zero_o:			df_elmt_ocrs;
      64	id_o:			df_map_ocrs;
      65	zero_s:			df_elmt_syms;
      66	id_s:			df_map_syms;
      67	dum1, dum2:		remote mmap{df_node} df_elmt_ocrs;
      68	usym1, usym2:		symbol;
      69	uocrs1, uocrs2:		occurrence;
      70
      71	reach:			remote smap(df_node) df_elmt_ocrs;
      72	canreach:		mmap{destuse} df_elmt_ocrs;
      73	fvo:			df_map_ocrs;
      74	globrelvars:		df_elmt_syms;
      75	livat:			remote smap(df_node) df_elmt_syms;
      76	bvo:			elmt blocks;
      77	w:			df_node;
      78	livatvo:		df_elmt_syms;
      79	vo:			destuse;
      80	vo1:			elmt df_base_ocrs;
      81	vo2:			occurrence;
      82	r:			routine;
      83	p:			symbol;
      84	locreldefs:		df_elmt_ocrs;
      85	locrelvars:		df_elmt_syms;
      86	x:			destuse;
      87	y:			sparse set(reldef);
smfg 128	z:			reldef;
      88	entry_time:		integer;
      89    end repr;
      90
      91    entry_time := time;
      92
      93$
      94$ initialise a special data flow value and map which denote the effect
      95$ of an undefined (unreachable) data state and an undefined (untrace-
      96$ able) data flow, respectively.
      97$
      98    xom_syms := { usym1 := newat };
      99    fom_syms := [ { usym1 := newat }, { usym2 := newat } ];
     100
     101    xom_ocrs := { uocrs1 := newat };
     102    fom_ocrs := [ { uocrs1 := newat }, { uocrs2 := newat } ];
     103$
     104$ initialize the output map livethru
     105$
     106    livethru := {};
     107$
     108$ first perform interprocedural analysis
     109$
     110$ initialize the block mappings required by our standard data-flow
     111$ package, and a few auxiliary mappings.  for efficiency, one scan
     112$ through the code is used to compute the mappings for both forward
     113$ (reachability) and backward (liveness) analyses.
     114$ see block_flowmaps for details.
     115$
smfk 166    if globreldefs /= {} then
smfk 167
     116    [ freach, flive, frdestuse, fldestuse ] :=
     117	block_flowmaps(om, globreldefs);
     118$
     119$ reachability analysis
     120$
     121    zero_o := {};
     122    id_o   := [ globreldefs, zero_o ];
     123
     124    interproc_fwd_analysis_ocrs
     125	(freach, reach, id_o, zero_o, false, false, dum1, dum2, om);
     126    freach := om;	$ free storage
     127$
     128$ next compute the map canreach which maps each potentially
     129$ destructive use vo to the set of all relevant definitions
     130$ which can reach vo. this is done by propagating reach
     131$ through the appropriate portion of the block containing vo.
     132$
     133    canreach := {};
     134    (forall fvo = frdestuse(vo))
     135	$ ofx is a variant of the functional application operator
     136	canreach{vo} := fvo .ofx_o reach(blockof(instno(vo)));
     137    end forall;
     138
     139    frdestuse := om;    reach := om;	$ free storage
     140$
     141$ live analysis
     142$
     143    globrelvars := { oi_sym(vo2) : vo2 in globreldefs };
     144    zero_s := {};
     145    id_s   := [ globrelvars, zero_s ];
     146
     147    interproc_back_analysis_syms
     148	(flive, livat, id_s, zero_s, false);
     149    flive := om;	$ free storage
     150$
     151$ next compute the livethru map, combining reachability and liveness
     152$
     153    (forall vo in potdestuses)
     154	bvo := blockof(instno(vo));
     155$ compute livatvo - the set of all variables live at vo
     156$ see a description of fldestuse in procedure block_flowmaps.
     157	livatvo := zero_s +/[ fldestuse([vo,w]) .ofx_s livat(w) :
     158				w in cessor{bvo}];
     159$ then livethru(vo) is computed as the set of all definitions
     160$ that can reach vo whose variable is in livatvo
     161	livethru{vo} :=
     162	    { vo1 in canreach{vo} | oi_sym(vo1) in livatvo };
     163    end forall;
     164    $ free storage
     165    fldestuse := om;    canreach := om;
     166    livat := om;        livatvo := om;
     167
     168    if 'q' in dump_string then
     169	prints('livethru =', [ [ str x, y ] : y = livethru{x} ] );
     170    end if;
smfk 168
smfk 169    end if;
     171$
     172$ next perform the corresponding intraprocedural analysis
     173$ for each procedure
     174$
     175    (forall r in routs)
     176
     177	locreldefs := { vo2 in all_reldefs |
     178				vo2 notin globreldefs
     179				and oi_sym(vo2) in localvars{r}    };
smfk 170
smfk 171	if locreldefs = {} then  continue forall;  end if;
     180
     181	[ freach, flive, frdestuse, fldestuse ] :=
     182	    block_flowmaps(r, locreldefs);
     183
     184	zero_o := {};
     185	id_o   := [ locreldefs, zero_o ];
     186
     187	intraproc_fwd_analysis_ocrs(r, freach, reach, id_o, zero_o,
     188	    		false, false, dum1, dum2, om);
     189	freach := om;	$ free storage
     190
     191	canreach := {};
     192	(forall fvo = frdestuse(vo))
     193	    canreach{vo} := fvo .ofx_o reach(blockof(instno(vo)));
     194	end forall;
     195
     196	reach := om;	frdestuse := om;	$ free storage
     197
     198	locrelvars := { oi_sym(vo2) : vo2 in locreldefs };
     199	zero_s := {};
     200	id_s   := [ locrelvars, zero_s ];
     201
     202	intraproc_back_analysis_syms
     203	    (r, flive, livat, id_s, zero_s, false);
     204	flive := om;	$ free storage
     205
     206	(forall vo in potdestuses)
     207	    bvo := blockof(instno(vo));
     208	    livatvo := zero_s +/[ fldestuse([vo,w]) .ofx_s livat(w) :
     209				    w in cessor{bvo}];
     210	    livethru{vo} +:=
     211		{ vo1 in canreach{vo} | oi_sym(vo1) in livatvo };
     212	end forall;
     213
     214	$ free storage
     215	fldestuse := om;    canreach := om;
     216	livat := om;        livatvo := om;
     217    end forall;
     218
     219    if 'p' in dump_string then
smfg 129	prints('livethru =',
smfh  47            [ [ oi_str(x), { oi_str(z): z in y } ] : y = livethru{x} ]
smfg 131	    );
     221    end if;
     222
     223    if 'e' in dump_string then
     224	print(time - entry_time, 'msecs for live analysis');
     225    end if;
     226
     227    end procedure live_dead_analysis;
     228
     229
     230
     231
     232    operator .ofx_s(f, x);
     233
     234    repr
     235	f:			df_map_syms;
     236	x:			df_elmt_syms;
     237    end repr;
     238
     239    if f = om then return {}; else return f(1) * x + f(2); end if;
     240
     241    end operator .ofx_s;
     242
     243
     244    operator .ofx_o(f, x);
     245
     246    repr
     247	f:			df_map_ocrs;
     248	x:			df_elmt_ocrs;
     249    end repr;
     250
     251    if f = om then return {}; else return f(1) * x + f(2); end if;
     252
     253    end operator .ofx_o;
     254
     255
     256    procedure block_flowmaps(p, rldefs);
     257
     258$ the rldefs parameter is the set of all definitions of variables
     259$ (i.e. ovariables) that are linked to potentially destructive
     260$ uses considered in a particular invocation of this routine
     261$ (i.e. global variables or local variables of some procedure).
     262$
     263$ this routine builds up four kinds of data flow maps
     264$ by scanning the code, either in all routines (when p = om,
     265$ indicating interprocedural analysis), or just in the routine
     266$ p. the maps built are:
     267$
     268$ freach    - maps each edge in the flow graph to its
     269$             effect on reachability information
     270$
     271$ flive     - maps each edge in the flow graph to its effect
     272$             on liveness information.
     273$
     274$ recall that the data-flow functions needed for our analyses
     275$ i.e. the functions which express the data-flow effect of particular
     276$ parts of the program flow graph, such as edges, intervals, portions
     277$ of basic blocks etc., can be represented as follows:
     278$
     279$ for reachability:
     280$
     281$ f = (thru, gen), where thru is the set of all definitions which, if
     282$ reaching the start of the flow described by f, can still reach its
     283$ end, and where gen is the set of definitions which occur during that
     284$ flow and can reach its end.
     285$ (this comment applies to the data-flow function frblk used below.)
     286$
     287$ for liveness:
     288$
     289$ f = (thru, exp), where thru is the set of all variables which, if live
     290$ at the end of the flow described by f, are still live at its start,
     291$ and where exp is the set of all variables which have an upward-exposed
     292$ use within that flow, and are therefore unconditionally live at the
     293$ start of that flow.
     294$ (this comment applies to the data-flow functions flblk, flins, flaft,
     295$ flbef and fluse used below.)
     296$
     297$ two additional objects are computed in this routine to eliminate the
     298$ need for a second scan of the code after carrying out the data-flow
     299$ analyses.  without these objects available we would have to scan
     300$ basic blocks once more, in order to propagate the information
     301$ computed by the data flow analysis, which only gives data at block
     302$ entries and exits, to the program points at which this information is
     303$ actually needed.  since in our case we know these points, namely the
     304$ potentially destructive uses, in advance, we can compute the data-flow
     305$ effects of the flow between these points and the entry and exits of
     306$ the blocks containing them in advance.  specifically, the objects
     307$ computed are:
     308$
     309$ frdestuse - maps each potentially destructive use to the data-flow
     310$             map representing the effect on reachability of the flow
     311$             from the start of the basic block containing that use to
     312$             a point logically placed between the input arguments
     313$             and the output argument of that use ('midpoint' of that
     314$             use).
     315$
     316$ fldestuse - maps each pair consisting of a potentially destructive
     317$             use vo and a successor block sb of the block containing
     318$             vo to a data-flow function representing the effect on
     319$             liveness of the flow from the 'midpoint' of the use at
     320$             vo to the start of sb.
     321$
     322$ the reason for computing flow effects up to (or from) a 'midpoint'
     323$ of a potentially destructive operation are illustrated by the
     324$ following example:
     325$
     326$      v := v with x;
     327$
     328$ if we considered variable liveness just before that instruction,
     329$ we would conclude that v is live there (since it is used
     330$ immediately thereafter). likewise, if we considered liveness
     331$ just after that instruction, v might be seen as live due to a
     332$ subsequent use. the 'right' place for considering liveness is
     333$ the midpoint of the instruction, between input and output, where
     334$ v will be found to be dead.
     335$
     336    repr
     337	$ data structures for parameters
     338	p:			routine;
     339	rldefs:			df_elmt_ocrs;
     340
     341	$ data structures for returned variables
     342	freach:			remote smap(df_edge) df_map_ocrs;
     343	flive:			remote smap(df_edge) df_map_syms;
     344	frdestuse:		smap(destuse) df_map_ocrs;
     345	fldestuse:		smap( tuple(destuse, df_node) )
     346				    df_map_syms;
     347
     348	$ data structure for local variables
     349	todo:			sparse set(routine);
     350	rlvars:			df_elmt_syms;
     351	defofvars:		mmap{symbol} df_elmt_ocrs;
     352	vo:			occurrence;
     353	v:			symbol;
     354	id1:			df_map_ocrs;
     355	id2:			df_map_syms;
     356	r:			routine;
     357	b:			elmt blocks;
     358	i:			elmt insts;
     359	opc:			elmt base_opcodes;
     360	argsi:			tuple(symbol);
     361	frblk:			df_map_ocrs;
     362	flblk:			df_map_syms;
     363	dstusesinb:		sparse set(occurrence);
     364	fluse:			smap(occurrence) df_map_syms;
     365	used:			df_elmt_syms;
     366	j:			integer;
     367	flbef:			df_map_syms;
     368	ov:			occurrence;
     369	flaft:			df_map_syms;
     370	flins:			df_map_syms;
     371	vo1:			occurrence;
     372	sblks:			sparse set(elmt blocks);
     373	lb:			symbol;
     374	b1:			elmt blocks;
     375    end repr;
     376
     377    if p = om then todo := routs; else todo := { p }; end if;
     378$
     379$ compute rlvars - the set of all variables appearing in rldefs
     380$ and defofvars - a map from each such variable to its definitions
     381$ in rldefs.
     382$
     383    rlvars := {};    defofvars := {};
     384    (forall vo in rldefs)
     385	rlvars with:= (v := oi_sym(vo));
     386	defofvars with:= [ v, vo ];
     387    end forall;
     388
     389    id1 := [ rldefs, {} ];	$ identity map for reachability anal.
     390    id2 := [ rlvars, {} ];	$ identity map for live analysis
     391
     392    freach := {};       flive := {};
     393    frdestuse := {};    fldestuse := {};
     394
     395    (forall r in todo)
     396	(for_block(b, r))
     397$ initialize maps that summarize the data-flow through the block b
     398$ so far (frblk for reachability and flblk for liveness).
     399	    frblk := id1;
     400	    flblk := id2;
     401	    dstusesinb := {};  $ set of pot. destructive uses in b
     402$ fluse maps each use vo in dstusesinb to the data-flow effect on
     403$ liveness of the flow from the midpoint of vo onward within b.
     404	    fluse := {};
     405
     406	    (for_inst(i, b))  $ iterate over instructions of block
     407		opc := opcode(i);
     408		argsi := args(i);
     409		used := { v : j in [ first_ivar(opc)..#argsi ] |
     410					(v := argsi(j)) in rlvars    };
     411$ flbef represents the effect on liveness of the right-hand side of i
     412$ (i.e. of the appearances of the input arguments in i).
     413		flbef := [ rlvars, used ];
     414
     415$ check whether i contains a relevant pot. destructive use vo
     416		if (vo := dstuseini(i)) /= om then
     417$ record effect on reachability of flow up to that use
     418		    frdestuse(vo) := frblk;
     419$ add to collection of destructive uses in b
     420		    dstusesinb with:= vo;
     421		end if;
     422
     423$ check whether i has an ovariable
     424		if opc in ops_ovar then
     425		    v := argsi(1);
     426$ if v is in rlvars update frblk and flaft by the effects of this
     427$ definition.
     428		    if v in rlvars then
     429			ov := get_oi(i, 1);
     430$ the effect on reachability: ov can now reach the current point
     431$ in the block, whereas all other definitions of v cannot
     432
     433$ note: the use of the map composition operator .comp (imported
     434$ from the data-flow solver package) makes the tracing of flow
     435$ through the block very simple to calculate; otherwise
     436$ an explicit computation would be required.
     437			frblk :=
     438			    [ rldefs-defofvars{v}+{ov}, {ov} ]
     439				    .comp_ocrs frblk;
     440$ the effect on liveness: v becomes dead, and nothing else
     441$ becomes live
     442			flaft := [ rlvars - {v}, {} ];
     443		    end if;
     444		else
     445$ in this case the left hand side of i has no effect on liveness
     446$ of the relevant variables.
     447		    flaft := id2;
     448		end if;
     449$ if there is a pot. destructive use vo in i (i.e. if vo as
     450$ computed earlier is not om), initialize fluse(vo).
     451		if vo /= om then
     452		    fluse(vo) := flaft;
     453		end if;
     454$ get the effect of i on liveness
     455		flins := flbef .comp_syms flaft;
     456$ update the flblk map by the effect of i on liveness
     457		flblk := flblk .comp_syms flins;
     458
     459$ update fluse of previously encountered destructive uses in b
     460$ note: an alternative approach might have been to propagate
     461$ liveness information backwards through b. while this would
     462$ eliminate the need to maintain a separate data-flow function
     463$ for each destructive use in b (the fluse map), it would require
     464$ maintainance of a separate data-flow function for each
     465$ successor of b. moreover, this alternative approach would require
     466$ us to process b in two different directions, instead of a single
     467$ pass over b, as is done here.
     468
     469		(forall vo1 in dstusesinb | vo1 /= vo)
     470		      fluse(vo1) := fluse(vo1) .comp_syms flins;
     471		end forall;
     472
     473$ if i is a branch instruction, use the current frblk, flblk etc.
     474$ to update the various edge mappings that we wish to compute
     475		if opc in ops_goto then
     476$ get blocks that can be reached by this jump
     477		    if opc = q1_case then
     478			sblks := { blockof(value(lb)) :
     479				    lb in range value(argsi(1)) };
     480		    else
     481			sblks := { blockof(value(argsi(#argsi))) };
     482		    end if;
     483		    (forall b1 in sblks)
     484
     485$ update freach and flive using the current frblk and flblk maps
     486$ the values are join'ed together, since both analyses determine
     487$ facts that may happen (rather than must happen) as execution
     488$ reaches (or leaves) a given program point.
     489			freach([b, b1]) :=
     490			    frblk .join_o:= freach([b, b1]);
     491			flive([b, b1]) :=
     492			    flblk .join_s:= flive([b, b1]);
     493
     494$ update fldestuse using the current fluse maps
     495			(forall vo in dstusesinb)
     496			    fldestuse([vo,b1]) :=
     497			      fluse(vo) .join_s fldestuse([vo, b1]);
     498			end forall;
     499		    end forall;
     500		end if;
     501	    end;     $ end for_inst
     502	end;         $ end for_block
     503    end forall r;
     504
     505    return [ freach, flive, frdestuse, fldestuse ];
     506
     507    end procedure block_flowmaps;
     508
     509
     510
     511
     512    operator .join_s(f, g);
     513
     514    repr
     515	f, g:			df_map_syms;
     516    end repr;
     517
     518    if g = om then
     519	return f;
     520    else
     521	return [ f(1) + g(1), f(2) + g(2) ];
     522    end if;
     523
     524    end operator .join_s;
     525
     526
     527    operator .join_o(f, g);
     528
     529    repr
     530	f, g:			df_map_ocrs;
     531    end repr;
     532
     533    if g = om then
     534	return f;
     535    else
     536	return [ f(1) + g(1), f(2) + g(2) ];
     537    end if;
     538
     539    end operator .join_o;
     540
     541
       1 .=member cel18d
       2
       3    procedure copy_eliminate;
       4
       5$ in this routine we use the value relationships and the liveness
       6$ information computed in the preceding phases to determine
       7$ which potentially destructive operations can be performed
       8$ without having to copy the object whose value is being destroyed
       9
      10$ the general rule is as follows:
      11
      12$ copy elimination rule: let n be the 'midpoint' of
      13$ a potentially destructive operation, and let vo denote the
      14$ potential destructive use there. let containvo denote the set
      15$ of all variable occurrences vo' for which there exists
      16$ a membership relationship r such that [vo', r] can be reached
      17$ from [vo, rid] by a path through (the virtual) upgraph followed by
      18$ a path through (the virtual) downgraph. suppose that each vo'
      19$ in containvo is dead at n. (recall that liveness is computed on a
      20$ 'per occurrence' basis.) then no copy is required at n.
      21
      22$ the actual graph traversals have been accomplished in the
      23$ preliminary value-flow algorithm (see value_flow). the map
      24$ contain produced by that algorithm can be used to obtain
      25$ containvo directly.
      26$
      27$ another application of copy elimination is to optimize
      28$ iterations. currently (unless the diter flag is turned on)
      29$ if an object s is to be iterated over it is first copied
      30$ to another object s', and then iteration is performed
      31$ over s'. this is done because if s is modified during iteration
      32$ we want to continue iteration over its old value. this however
      33$ can be checked by our copy elimination procedure. indeed,
      34$ let "s' := s" be the assignment of s to s' before the iteration.
      35$ suppose that the occurrence of s' in this statement can
      36$ reach some potentially destructive use of this value, and
      37$ that s' is live at that use. only in this case the value
      38$ of s will have to be copied before or during the iteration
      39$ and so direct iteration over s is impossible. on the other
      40$ hand, if this case does not arise, then it is safe to
      41$ iterate over s directly.
      42
      43$ this optimization can be accomplished as follows: s' will
      44$ always appear at exactly four q1 instructions:
      45
      46$ (1) q1_asn    s'   s
      47$ (2) q1_inext  (or q1_inextd)
      48$ (3) q1_next   (or q1_nextd)
      49$ (4) q1_asn    s'   om     (at the end of iteration).
      50
      51$ by iterating over all q1_next and q1_nextd appearing in
      52$ the code being analyzed, and by tracing bfrom and ffrom
      53$ links from it, we can collect all such quadruples. then,
      54$ during copy elimination, we check, for each destructive
      55$ use iv whether the corresponding contain entries include
      56$ any occurrence of an s' in its defining assignment (1).
      57$ if so, and if that occurrence is live at iv, then we
      58$ tag this quadruple as not being amenable to optimization.
      59$ after elimination has been completed, all untagged quadruples
      60$ can then be optimized, the optimization simply being the
      61$ deletion of statements (1) and (4) and substitution of s
      62$ in place of s' in statements (2) and (3).
      63$
      64$ we use the following data structures:
      65$
      66$ iter_asns:	set of all occurrences of a s' in assignments
      67$		of the form (1).
      68$
      69$ other_insts:	maps each such assignment to the three statements
      70$		(2) - (4).
      71$
      72    repr
      73	vo:			occurrence;
      74	containvo:		df_elmt_ocrs;
      75	liveconts:		df_elmt_ocrs;
      76	livevo:			df_elmt_ocrs;
      77	precuoccs:		df_elmt_ocrs;
      78	vox:			occurrence;
      79	instx:			elmt insts;
      80	share_insts:		sparse set(elmt insts);
      81	copy_cond, copy_fl:	boolean;
      82	copy_text:		string;
      83    end repr;
      84
      85$   copy_iters := {};
      86    destuses := {};    $ destructive uses where copy may be required
      87
      88$ process each potentially destructive use vo.
      89    (forall vo in potdestuses)
      90	livevo := livethru{vo} + destconsts;
      91	copy_fl := false;
      92	copy_cond := false;
      93	share_insts := {};
      94
      95	(forall vox in psoccsof{vo})
      96$           vo_copy := contain{vox} * livevo;
      97	    if contain{vox} * livevo /= {} then
      98		copy_fl := true;   $ vo requires copying
      99		share_insts with:= instno(vox);
     100$               if (vo_copy_iters := iter_asns * vo_copy) /= {} then
     101$                   copy_iters +:= vo_copy_iters;
     102$               end if;
     103	    else
     104		copy_cond := true;
     105	    end if;
     106	end forall;
     107	precuoccs := puoccsof{vo};
     108	if precuoccs * livevo /= {} then
     109	    copy_cond := false;
     110	    copy_fl := true;
     111	elseif precuoccs /= {} then
     112	    copy_cond := true;
     113	end if;
     114
     115	if not copy_fl then
     116	    copy_flag(instno(vo)) := copy_no;
     117	    copy_text := 'no';
     118	else
     119	    destuses with:= vo;
     120	    if copy_cond then
     121		$ a conditional copy; set share bits
     122		copy_flag(instno(vo)) := copy_test;
     123		copy_text := 'a conditional';
     124		(forall instx in share_insts)
     125		    share_flag(instx) := 1;
     126		end forall;
     127	    else       $ unconditional copy; no share bit setting
     128		copy_flag(instno(vo)) := copy_yes;
     129		copy_text := 'an unconditional';
     130	    end if;
     131	end if;
smfc 666	messages{stmtof(instno(vo))}{'s'} with:=
     133	    [ copy_text + ' copy is required for '
     134		'"' + oi_name(vo) + '".' ];
     135    end forall;
     136
     137$ we now perform the iteration optimization described above.
     138$   (forall vox in iter_asns - copy_iters)
     139$       (forall [ inxt, nxt, asnom ] in other_insts(vox))
     140$           del_insx(i := instno(vox));
     141$           del_insx(asnom);
     142$           arg3(inxt) := arg3(nxt) := arg2(i);
     143$       end forall;
     144$   end forall;
     145
     146    end procedure copy_eliminate;
     147
     148
       1 .=member csi18e
       2
       3
       4    procedure copy_share_improve;
       5$
       6$ this routine performs (?) various bookkeeping optimizations
       7$ related to copying, such as suppression of share-bit settings,
       8$ changing conditional copying into unconditional copying, and
       9$ moving copy operations out of loops.
      10$
      11$ for the time being this is an empty procedure.
      12
      13    pass;
      14
      15    end procedure copy_share_improve;
      16
      17
      18    end module setl_optimizer - copy_optimization;
      19
      20
       1 .=member util16
       2
       3
       4    module setl_optimizer - util;
       5
       6$ this library contains various utility routines
       7
       8
       1 .=member sym16a
       2
       3
       4$ utilities for symbol table manipulation
       5$ ---------------------------------------
       6
       7
       8    procedure add_sym(sc);
       9$
      10$ allocate a new symbol and add it to the end of the list of symbols
      11$ in scope 'sc'.
      12$
      13    repr
      14	sc:			elmt base_scopes;
      15	s:			symbol;
      16    end repr;
      17
      18    s := newat;
      19
      20    if first_sym(sc) = om then
      21	first_sym(sc) := last_sym(sc) := s;
      22    else
      23	last_sym(sc) := next_sym(last_sym(sc)) := s;
      24    end if;
      25
      26    name(s)        := str s;
      27    scope(s)       := sc;
      28    is_internal(s) := 1;
      29
      30    return s;
      31
      32    end procedure add_sym;
      33
      34
      35
      36
      37    procedure add_var(sc);
      38$
      39$ add a variable to the scope 'sc'.
      40$
      41    repr
      42	sc:			elmt base_scopes;
      43	s:			symbol;
      44    end repr;
      45
      46    s := add_sym(sc);
      47
      48    form(s)     := std_form(f_gen);
      49    is_read(s)  := 1;
      50    is_write(s) := 1;
      51
      52    return s;
      53
      54    end procedure add_var;
      55
      56
      57
      58
      59    procedure add_int(sc, i);
      60$
      61$ add an integer constant with value 'i' to scope 'sc'
      62$
      63    repr
      64	sc:			elmt base_scopes;
      65	i:			integer;
      66	fm:			elmt forms;
      67$$--	old:			symbol;
      68	s:			symbol;
      69    end repr;
      70
      71    fm := std_form(f_int);
      72$$-- value_inv is undefined here
      73$$--old := value_inv(i, sc, fm);
      74$$--if old /= om then return old; end;
      75
      76    s := add_sym(sc);
      77
      78    name(s)     := str i;
      79    form(s)     := fm;
      80    value(s)    := i;
      81    is_const(s) := 1;
      82
      83    return s;
      84
      85    end procedure add_int;
      86
      87
      88
      89
      90    procedure add_label(sc);
      91$
      92$ add a label to scope sc.
      93$
      94    repr
      95	sc:			elmt base_scopes;
      96	l:			symbol;
      97    end repr;
      98
      99    l := add_sym(sc);
     100
     101    form(l)     := std_form(f_lab);
     102    is_const(l) := 1;
     103$$$ ???? art-this needs more comment.  also, where is the value
     104$$$ ???? of the label defined.
     105
     106    return l;
     107
     108    end procedure add_label;
     109
     110
     111
     112
     113    procedure del_sym(sym, presym, sc);
     114$
     115$ this routine deletes 'sym' from the symbol table of 'sc',
     116$ where 'presym' is the symbol preceding sym in this table.
     117$
     118    repr
     119	sym:			symbol;
     120	presym:			symbol;
     121	sc:			elmt base_scopes;
     122
     123	s, nextsym:		symbol;
     124    end repr;
     125
     126$ we first update the 'next_sym', 'first_sym' and 'last_sym'
     127$ maps, and then remove 'sym' from the domain of all symbol-
     128$ table maps.
     129
     130    if presym = om then
     131	(for_sym(s, sc))
     132	    if s = sym then quit; end if;
smfc 667	    presym := s;
     134	end;	$ end for_sym
     135    end if;
     136
     137    nextsym := next_sym(sym);
     138    if presym /= om then
     139	if nextsym /= om then
     140	    next_sym(presym) := nextsym;
     141	else
     142	    next_sym(presym) := om;
     143	    last_sym(sc) := presym;
     144	end if;
     145    else
     146	if nextsym /= om then
     147	    first_sym(sc) := nextsym;
     148	else  $ sym is the only symbol in sc
     149	    first_sym(sc) := om;
     150	    last_sym(sc)  := om;
     151	end if;
     152    end if;
     153
     154    name	lessf:= sym;
     155    scope	lessf:= sym;
     156    form	lessf:= sym;
     157    value	lessf:= sym;	is_const	lessf:= sym;
     158    alias	lessf:= sym;	is_store	lessf:= sym;
     159    is_temp	lessf:= sym;	is_internal	lessf:= sym;
     160    is_read	lessf:= sym;	is_write	lessf:= sym;
     161    is_stk	lessf:= sym;	is_param	lessf:= sym;
     162    is_repr	lessf:= sym;	is_init		lessf:= sym;
     163    is_seen	lessf:= sym;	is_back		lessf:= sym;
     164    is_rec	lessf:= sym;
     165    next_sym	lessf:= sym;
     166
     167    end procedure del_sym;
     168
     169
       1 .=member frm16b
       2
       3
       4    procedure add_form(sc);
       5$
       6$ this routine adds a new form (plex base member) to the scope 'sc'.
       7$
       8    repr
       9	sc:			elmt base_scopes;
      10	fm:			elmt forms;
      11    end repr;
      12
      13    fm := newat;
      14
      15    if first_form(sc) = om then
      16	first_form(sc) := last_form(sc) := fm;
      17    else
      18	last_form(sc) := next_form(last_form(sc)) := fm;
      19    end if;
      20
      21    return fm;
      22
      23    end procedure add_form;
      24
      25
       1 .=member blk16c
       2
       3
       4    procedure add_block(pb, sc, isafter);
       5$
       6$ allocate a new block and add it to the scope sc either after
       7$ the block pb (if isafter = true) or before pb otherwise.
       8$
       9    repr
      10	pb:			elmt blocks;
      11	sc:			elmt base_scopes;
      12	isafter:		boolean;
      13	b, qb, rb:		elmt blocks;
      14    end repr;
      15
      16$ if isafter = false, iterate through the blocks of sc to find
      17$ the block preceding pb
      18
      19    if not isafter then
      20	qb := om;
      21	(for_block(b, sc))
      22	    if b = pb then quit; end;
      23	    qb := b;
      24	end;
      25    else
      26	qb := pb;
      27    end if;
      28
      29    b := newat;
      30
      31    if qb = om then	$ insert at end
      32	if first_block(sc) = om then
      33	    first_block(sc) := last_block(sc) := b;
      34	else
      35	    last_block(sc) := next_block(last_block(sc)) := b;
      36	end if;
      37    else		$ insert after qb
      38	if (rb := next_block(qb)) = om then   $ qb is last
      39	    last_block(sc) := next_block(qb) := b;
      40	else
      41	    next_block(b) := rb;
      42	    next_block(qb) := b;
      43	end if;
      44    end if;
      45
      46    routof(b) := sc;
      47
      48    return b;
      49
      50    end procedure add_block;
      51
      52
      53
      54
      55    procedure del_block(b, pb, r);
      56$
      57$ deletes a block b from the scope r. pb is the block preceding
      58$ b in this scope.
      59$
      60    repr
      61	b,pb,nb:		elmt blocks;
      62	i,pi:			elmt insts;
      63	r:			elmt base_scopes;
      64    end repr;
      65
      66    pi := om;
      67    (for_inst(i, b))
      68	if pi = om then
      69	    pi := i;
      70	else
      71	    del_inst(i, pi, b);
      72	end if;
      73    end;
      74
      75$ delete the label of the block from the symbol table
      76    dead_labs with:= arg1(pi);
      77
      78    del_inst(pi, om, b);
      79
      80    nb := next_block(b);
      81    if nb = om then
      82	if pb = om then
      83	    first_block(r) := om;
      84	    last_block(r) := om;
      85	else
      86	    next_block(pb) := om;
      87	    last_block(r) := pb;
      88	end if;
      89    else
      90	if pb = om then
      91	    first_block(r) := nb;
      92	else
      93	    next_block(pb) := nb;
      94	end if;
      95    end if;
      96
      97
      98    end procedure del_block;
      99
     100
       1 .=member ins16d
       2
       3
       4    procedure add_inst(b, opc, a(*));
smfi 330$
smfi 331$ add a new instruction at the end of block b.
       5$
       6$ the final, variable-length group of parameters of this routine are
       7$ the arguments of the instruction being added.  note that this
       8$ instruction may not be a call or label.
smfi 332$ this instruction may not be a call or label because inserting such
smfi 333$ an instruction requires that various maps on blocks are updated.
      11$
      15    repr
      16	b:			elmt blocks;
      17	opc:			elmt base_opcodes;
      18	a:			tuple(symbol);
      19
      20	i:			elmt insts;
      21	v:			symbol;
      22	oi:			occurrence;
      23	occsi:			tuple(occurrence);
      24	iva1, j:		integer 0..65536;
      25    end repr;
      26
      27    i := newat;
      28
      29    if first_inst(b) = om then
smfk 172	stmtof(i) := 65535;
      30	first_inst(b) := last_inst(b) := i;
      31    else
smfi 335	stmtof(i) := stmtof(last_inst(b));
      32	last_inst(b) := next_inst(last_inst(b)) := i;
      33    end if;
      34
      35    blockof(i) := b;
      36
      37$ update all_o etc.
      38    iva1  := first_ivar(opc);
      39    occsi := [];
      40
      41    (forall v = a(j))
      42	oi := newat;
      43	instno(oi) := i;
      44	argno(oi)  := j;
      45	occsi(j) := oi;
      46
      47	if j = 1 and opc in ops_ovar then all_o with:= oi; end if;
      48	if j >= iva1 then	 	  all_i with:= oi; end if;
      49
smfk 173	all_oi with:= oi;
smfk 174
smfk 175	if is_const(v) = om and v /= sym_om then
smfk 176	    occsof{v} with:= oi;
smfk 177	end if;
      52    end forall;
      53
      54    opcode(i) := opc;
      55    args(i)   := a;
      56    occs(i)   := occsi;
      57
      58    return i;
      59
      60    end procedure add_inst;
      61
      62
      63
      64
      65    procedure insert_ins(rw old, opc, a(*));
      66
      67    repr
      68        old:			elmt insts;
      69        opc:			elmt base_opcodes;
      70        a:			tuple(symbol);
      71    end repr;
      72
      73    insert_ins1(old, opc, a);
      74
      75    end procedure insert_ins;
      76
      77
      78
      79
      80    procedure insert_ins1(rw old, opc, a);
      81
      82$ add a new instruction after instruction 'i'.
      83
      84    repr
      85	old:			elmt insts;
      86	opc:			elmt base_opcodes;
      87	a:			tuple(symbol);
      88
      89	new:			elmt insts;
      90	b:			elmt blocks;
      91	v:			symbol;
      92	oi:			occurrence;
      93	occsi:			tuple(occurrence);
      94	iva1, j:		integer 0..65536;
      95    end repr;
      96
      97    new := newat;
      98
      99    next_inst(new) := next_inst(old);
     100    next_inst(old) := new;
     101
     102    b              := blockof(old);
     103    blockof(new)   := b;
     104    stmtof(new)    := stmtof(old);
     105
     106    if last_inst(b) = old then last_inst(b) := new; end if;
     107
     108$ update oi_sets and oi_maps.
     109    iva1  := first_ivar(opc);
     110    occsi := [];
     111
     112    (forall v = a(j))
     113	oi := newat;
     114	instno(oi) := new;
     115	argno(oi)  := j;
     116	occsi(j) := oi;
     117
     118	if j = 1 and opc in ops_ovar then all_o with:= oi; end if;
     119	if j >= iva1 then	 	  all_i with:= oi; end if;
     120
smfk 178	all_oi with:= oi;
smfk 179
smfk 180	if is_const(v) = om and v /= sym_om then
smfk 181	    occsof{v} with:= oi;
smfk 182	end if;
     123    end forall;
     124
     125    opcode(new) := opc;
     126    args(new)   := a;
     127    occs(new)   := occsi;
     128
     129    old := new;
     130
     131    end procedure insert_ins1;
     132
     133
     134
     135
     136    procedure del_inst(rw i, pi, b);
     137$
     138$ this routine deletes an instruction from the q1 code.
     139$ i is the instruction to be deleted and pi is the instruction
     140$ preceding i in its basic block b.
     141$ it resets i to pi, so that, if we iterate over the block b using
     142$ the for_inst macro, we step to the instruction following i.
     143$
     144$ nb. this routine can not be used to delete the first instruction
     145$ of a block while iterating through a block using the for_inst
     146$ macro, since the step block of the iteration would look for
     147$ next_inst(om), which yields an error.
     148$
     149
     150    repr
     151	i:			elmt insts;
     152	pi:			elmt insts;
     153	b:			elmt blocks;
     154
     155	inst, ni:		elmt insts;
     156        opc:			elmt base_opcodes;
     157	argsi:			tuple(symbol);
     158	v:			symbol;
     159	oi:			occurrence;
     160	iva1, j:		integer 0..65536;
     161    end repr;
     162
     163
     164    if pi = om then
     165	(for_inst(inst, b))
     166	    if inst = i then quit; end if;
     167	    pi := inst;
     168	end;	$ end for_inst
     169    end if;
     170
     171    ni := next_inst(i);
     172    if pi /= om then
     173	if ni /= om then
     174	    next_inst(pi) := ni;
     175	else
     176	    next_inst(pi) := om;
     177	    last_inst(b) := pi;
     178	end if;
     179    else
     180	if ni /= om then
     181	    first_inst(b) := ni;
     182	else
     183	    first_inst(b) := om;
     184	    last_inst(b)  := om;
     185	end if;
     186    end if;
     187
     188    argsi := args(i);
     189    opc   := opcode(i);
     190    iva1  := first_ivar(opc);
     191
     192    (forall v = argsi(j))
     193	oi := get_oi(i, j);
     194
     195	if j = 1 and opc in ops_ovar then all_o less:= oi; end if;
     196	if j >= iva1 then	 	  all_i less:= oi; end if;
     197
     198	all_oi    less:= oi;
     199	occsof{v} less:= oi;
     200    end forall;
     201
     202    i := pi;
     203
     204    end procedure del_inst;
     205
     206
       1 .=member pru16e
       2
       3
       4    procedure ermsg(s);
       5
       6$ print error message 's'
       7
       8    print('**** error', s, '****');
       9
      10    end procedure ermsg;
      11
      12
      13
      14
      15    procedure abort(s);
      16
      17$ print error message and abort
      18
      19    ermsg(s);
      20    stop;
      21
      22    end procedure abort;
      23
      24
      25
      26
      27    procedure prints(hdr, t);
      28$
      29$ this utility routine prints its second argument sorted.  this is a
      30$ tuple 't' of pairs [ c, x ], where c is a string and x can be any
      31$ object.  we first sort t in lexicographical order of the string
      32$ components, and then print it one pair per line.  we use a simple
      33$ version of heapsort to do the sort.
      34$
      35    repr
      36	hdr:			string;
      37	t:			tuple(tuple(string, general));
      38	x:			tuple(string, general);
      39	j, k, l, m, n:		integer 0..65536;
      40    end repr;
      41
      42
      43    macro before(l, r);		$ defines partial order
      44	( t(l)(1) < t(r)(1) )
      45    endm;
      46
      47
      48    print;
      49    print(hdr);
      50
      51    if #t = 0 then return t; end if;	$ trivial case
      52
      53    $ sort the pairs lexographically by their first component, using
      54    $ heap sort
      55    (init n := #t; j := n div 2; while j >= 1 step j -:= 1;)
      56	(init k := j; while (l := k+k) <= n)
      57	    $ which child will be promoted ?
      58	    m := if l < n and before(l, l+1) then l+1 else l end;
      59
      60	    $ will a child be promoted ?
      61	    if before(k, m) then
      62		x := t(k);  t(k) := t(m);  t(m) := x;  k := m;
      63	    else
      64		quit init k;
      65	    end if;
      66	end init k;
      67    end init n;
      68
      69    (init j := n; while j > 1)
      70	x := t(j);  t(j) := t(1);  t(1) := x;  j -:= 1;
      71	(init k := 1; while (l := k+k) <= j)
      72	    $ which child will be promoted ?
      73	    m := if l < j and before(l, l+1) then l+1 else l end;
      74
      75	    $ will a child be promoted ?
      76	    if before(k, m) then
      77		x := t(k);  t(k) := t(m);  t(m) := x;  k := m;
      78	    else
      79		quit init k;
      80	    end if;
      81	end init k;
      82    end init j;
      83
      84    (forall x in t) print(x(1), x(2)); end forall;
      85
      86
      87    end procedure prints;
      88
      89
      90
      91
smfe 193    procedure format_type(tp);
smfe 194$
smfe 195$ this routine returns a string corresponding to the type tp.
smfe 196$
smfe 197$ assert is_string arb grosstyp(tp);
smfe 198$ assert grosstyp(tp) subset bsctyps;
smfe 199$ assert tp = type_zero or #grosstyp >= 1;
smfe 200$
smfe 201    const
smfe 202	grstup = { t_tuple },
smfe 203	grsset = { t_set },
smfe 204	grsmap = { t_map };
smfe 205
smfe 206    repr
smfe 207	tp, tx:			elmt types;
smfe 208	g:			gross_type;
smfe 209	c:			general;
smfe 210	ct1:			tuple(elmt types);
smfe 211	x:			basic_type;
smfe 212	text:			string;
smfe 213	j:			integer;
smfe 214	grstup, grsset, grsmap:	gross_type;
smfe 215    end repr;
smfe 216
smfe 217
smfe 218    if tp = type_zero  then return '-';       end if;
smfe 219    if tp = type_gen   then return 'general'; end if;
smfe 220
smfe 221    if tp = type_notom then return 'not-om';  end if;
smfe 222
smfe 223    [ g, c ] := tp;
smfe 224
smfe 225    if c = type_om then
smfe 226	if g = grstup then return 'nulltup'; end if;
smfe 227	if g = grsset then return 'nullset'; end if;
smfe 228	if g = grsmap then return 'nullmap'; end if;
smfe 229    end if;
smfe 230
smfe 231    if g*tup_set_map /= {} and
smfe 232	    (t_tuple in g impl not is_knt(tp)) and is_om(c) then
smfe 233	(forall x in g | x in tup_set_map)
smfe 234	    if text = om then
smfe 235		text := 'null' + x;
smfe 236	    else
smfe 237		text +:= ' | null' + x;
smfe 238	    end;
smfe 239	end forall;
smfe 240	if c = type_gen then	$ c .con:= type_notom;
smfe 241	    c := type_notom;
smfe 242	else
smfe 243	    grosstyp(c) less:= t_om;
smfe 244	end if;
smfe 245	if grosstyp(c) = {} then g -:= tup_set_map; end if;
smfe 246	tp := [ g, c, false ];
smfe 247    end if;
smfe 248
smfe 249    (forall x in g)
smfe 250
smfe 251	if text = om then text := x; else text +:= ' | ' + x; end;
smfe 252
smfe 253	case x of
smfe 254
smfe 255	(t_set):
smfe 256	    text +:= '(' + format_type(comptyp(tp)) + ')';
smfe 257
smfe 258	(t_map):
smfe 259	    text +:= '(' + format_type(domtyp(tp)) + ') '
smfe 260			    + format_type(rangetyp(tp));
smfe 261
smfe 262	(t_tuple):
smfe 263	    if is_knt(tp) then
smfe 264		ct1 := comptyp(tp);
smfe 265		text +:= '(' +/[ format_type(tx) +
smfe 266				    if j = #ct1 then ')' else ', ' end :
smfe 267					tx = ct1(j)    ];
smfe 268	    else
smfe 269	        text +:= '(' + format_type(comptyp(tp)) + ')';
smfe 270	    end if;
smfe 271
smfe 272	$ note that the primitive types fall into the else-clause of
smfe 273	$ this case statement.
smfe 274
smfe 275	end case;
smfe 276
smfe 277    end forall;
smfe 278
smfe 279    return if '|' in text then '{ ' + text + ' }' else text end;
smfe 280
smfe 281
smfe 282    end procedure format_type;
     140
     141
     142
     143
     144    procedure format_repr(rpr);
     145$
     146$ this routine returns a string containing the description of 'rpr'
     147$ in the syntax of the setl data-representation sublanguage.
     148$
     149    repr
     150	g:			gross_type;
     151	fr:			basic_type;
     152	comps:			tuple(elmt types);
     153	j:			integer;
     154	rpr, crpr:		elmt types;
     155	brckts:			string;
     156    end repr;
     157
     158
     159    g := grosstyp(rpr);
     160    if #g /= 1 then return 'general'; end if;
     161
     162    fr := arb g;
     163    case fr of
     164
     165    (t_om):	return 'omega';
     166    (t_int):	return 'integer';
     167    (t_real):	return 'real';
     168    (t_string):	return 'string';
     169    (t_atom):	return 'atom';
     170    (t_elmt):	return 'elmt ads' + str rpr(2);
     171
     172    (t_set):	return case set_type(rpr) of
     173		(locl):     'local set(',
     174		(remt):     'remote set(',
     175		(sprse):    'sparse set('
     176		else        'set('
     177		end + format_repr(comptyp(rpr)) + ')';
     178
     179    (t_map):	return
     180		case set_type(rpr) of
     181		(locl):     'local ',
     182		(remt):     'remote ',
     183		(sprse):    'sparse '
     184		else        ''
     185		end     +
     186		case map_type(rpr) of
     187		(ft_smap):  'smap(' + format_repr(domtyp(rpr)) + ') ',
     188		(ft_mmap):  'mmap{' + format_repr(domtyp(rpr)) + '} '
     189		else        'map('  + format_repr(domtyp(rpr)) + ') '
     190		end + format_repr(rangetyp(rpr));
     191
     192    (t_tuple):
     193	if is_knt(rpr) then
     194	    comps := comptyp(rpr);
     195	    brckts := (+/[ format_repr(crpr) +
     196				(if j = #comps then ')' else ', ' end)
     197					: crpr = comps(j)    ]);
     198	    return
     199		if brckts = om then 'tuple' else 'tuple('+brckts end;
     200	else
     201	    return 'tuple(' + format_repr(comptyp(rpr)) + ')';
     202	end if;
     203
     204    else
     205	return ' (error in format_repr) ';
     206    end case;
     207
     208
     209    end procedure format_repr;
     210
     211
     212
     213
     214    procedure format_form(fm);
     215$
     216$ this routine formats a form table entry into a human-readable string.
     217$
     218    repr
     219	fm:			elmt forms;
     220	t:			tuple(elmt forms);
     221	j, n:			integer;
     222    end repr;
     223
     224
     225    return
     226	case ft_type(fm) of
     227
     228(f_gen):	'general',
     229
     230(f_sint):	'integer ' + str ft_low(fm) + '..' +
     231		    if ft_lim(fm) /= om and ft_lim(fm) /= 0 then
     232			str ft_lim(fm)
     233		    else
     234			'maxsi'
     235		    end,
     236
     237(f_sstring):	'string',
     238(f_atom):	'atom',
     239(f_latom):	'atom',
     240(f_elmt):	'elmt ' + name(basesymb(ft_base(fm))),
     241(f_uint):	'untyped integer',
     242(f_ureal):	'untyped real',
     243(f_int):	'integer',
     244(f_string):	'string',
     245(f_real):	'real',
     246(f_ituple):	'tuple(untyped integer)',
     247(f_rtuple):	'tuple(untyped real)',
     248(f_ptuple):	'packed tuple(' + format_form(ft_elmt(fm)) + ')',
     249
     250(f_tuple):	'tuple(' + format_form(ft_elmt(fm)) + ')' +
     251		    if ft_lim(fm) /= om and ft_lim(fm) /= 0 then
     252			'(' + str ft_lim(fm) + ')'
     253		    else
     254			''
     255		    end,
     256
     257(f_mtuple):	'tuple(' +/
     258		    [ format_form(ft_elmt(fm)(j)) +
     259			if j = #ft_elmt(fm) then ')' else ', ' end :
     260			    j in [ 1..#ft_elmt(fm) ] ],
     261
     262(f_uset):	if ft_type(ft_elmt(fm)) = f_elmt then
     263		    'sparse '
     264		else
     265		    ''
     266		end	+
     267		    'set(' + format_form(ft_elmt(fm)) + ')',
     268
     269(f_lset):	'local set(' + format_form(ft_elmt(fm)) + ')',
     270
     271(f_rset):	'remote set(' + format_form(ft_elmt(fm)) + ')',
     272
     273(f_umap):	if ft_type(ft_dom(fm)) = f_elmt then
     274		    'sparse '
     275		else
     276		    ''
     277		end	+
     278		case ft_mapc(fm) of
     279		(ft_map):     'map('  + format_form(ft_dom(fm)) + ') ',
     280		(ft_smap):    'smap(' + format_form(ft_dom(fm)) + ') ',
     281		(ft_mmap):    'mmap{' + format_form(ft_dom(fm)) + '} '
     282		else om end +
     283		format_form(ft_im(fm)),
     284
     285(f_lmap):	'local ' +
     286		case ft_mapc(fm) of
     287		(ft_map):     'map('  + format_form(ft_dom(fm)) + ') ',
     288		(ft_smap):    'smap(' + format_form(ft_dom(fm)) + ') ',
     289		(ft_mmap):    'mmap{' + format_form(ft_dom(fm)) + '} '
     290		else om end +
     291		format_form(ft_im(fm)),
     292
     293(f_rmap):	'remote ' +
     294		case ft_mapc(fm) of
     295		(ft_map):     'map('  + format_form(ft_dom(fm)) + ') ',
     296		(ft_smap):    'smap(' + format_form(ft_dom(fm)) + ') ',
     297		(ft_mmap):    'mmap{' + format_form(ft_dom(fm)) + '} '
     298		else om end +
     299		format_form(ft_im(fm)),
     300
     301(f_lpmap):	'packed local ' +
     302		case ft_mapc(fm) of
     303		(ft_map):     'map('  + format_form(ft_dom(fm)) + ') ',
     304		(ft_smap):    'smap(' + format_form(ft_dom(fm)) + ') '
     305		else om end +
     306		format_form(ft_im(fm)),
     307
     308(f_limap, f_lrmap):
     309		'local ' +
     310		case ft_mapc(fm) of
     311		(ft_map):     'map('  + format_form(ft_dom(fm)) + ') ',
     312		(ft_smap):    'smap(' + format_form(ft_dom(fm)) + ') '
     313		else om end +
     314		format_form(ft_im(fm)),
     315
     316(f_rpmap):	'packed remote ' +
     317		case ft_mapc(fm) of
     318		(ft_map):     'map('  + format_form(ft_dom(fm)) + ') ',
     319		(ft_smap):    'smap(' + format_form(ft_dom(fm)) + ') '
     320		else om end +
     321		format_form(ft_im(fm)),
     322
     323(f_rimap, f_rrmap):
     324		'remote ' +
     325		case ft_mapc(fm) of
     326		(ft_map):     'map('  + format_form(ft_dom(fm)) + ') ',
     327		(ft_smap):    'smap(' + format_form(ft_dom(fm)) + ') '
     328		else om end +
     329		format_form(ft_im(fm)),
     330
     331(f_base):	'base(' + format_form(ft_elmt(fm)) + ')',
     332
     333(f_pbase):	'plex base',
     334
     335(f_uimap, f_urmap):
     336		if ft_type(ft_dom(fm)) = f_elmt then
     337		    'sparse '
     338		else
     339		    ''
     340		end	+
     341		case ft_mapc(fm) of
     342		(ft_map):     'map('  + format_form(ft_dom(fm)) + ') ',
     343		(ft_smap):    'smap(' + format_form(ft_dom(fm)) + ') '
     344		else om end +
     345		format_form(ft_im(fm)),
     346
     347(f_error):	'error',
     348
     349(f_proc):	'procedure' +
     350		if (n := #(t := ft_elmt(fm))) /= 0 then
     351		    '(' +/[ format_form(t(j)) +
     352				if j = n-1 then '' else ', ' end :
     353				    j in [ 1..n-1 ] ] +
     354		    ') ' + format_form(t(n))
     355		else
     356		    ''
     357		end,
     358
     359(f_memb):	'member',
     360
     361(f_lab):	'label'
     362
     363	else
     364		' (error in format_form) '
     365	end;
     366
     367
     368    end procedure format_form;
     369
     370
     371
     372
     373    procedure format_inst(i, aivs);
     374$
     375$ this routine attempts to re-build the source text corresponding to the
     376$ instruction i.  aivs, if given, is a tuple with the new arguments for
     377$ the instruction.
     378$
     379    repr
     380	i:			elmt insts;
     381	aivs:			tuple(symbol);
     382	opc:			elmt base_opcodes;
smfc 673	a1, a2, a3:		symbol;
smfc 674	name1, name2, name3:	string;
smfc 675	pname1, pname2, pname3:	string;
     386    end repr;
     387
     388
     389    opc := opcode(i);
     390    assert opc in ops_ovar;
     391    assert first_ivar(opc) = 2;
smfc 676    aivs := aivs ? args(i)(2..); [ a1, a2, a3 ] := aivs;
     393
     394    name1 := if #name(a1) > 2 and name(a1)(1) = 't' and
     395		    (name(a1)(2) = '.' or name(a1)(2) = '#') then
     396		''
     397	    else
     398		name(a1)
     399	    end;
     400    pname1 := if is_internal(a1) /= om then
     401		'(' + name1 + ')'
     402	    else
     403		name1
     404	    end;
     405
     406    if a2 /= om then
     407	name2 := if #name(a2) > 2 and name(a2)(1) = 't' and
     408		    (name(a2)(2) = '.' or name(a2)(2) = '#') then
     409		''
     410	    else
     411		name(a2)
     412	    end;
     413	pname2 := if is_internal(a2) /= om then
     414		'(' + name2 + ')'
     415	    else
     416		name2
     417	    end;
     418    else
     419	name2 := pname2 := '***';
     420    end if;
smfc 681
smfc 682    if a3 /= om then
smfc 683	name3 := if #name(a3) > 2 and name(a3)(1) = 't' and
smfc 684		    (name(a3)(2) = '.' or name(a3)(2) = '#') then
smfc 685		''
smfc 688	    else
smfc 689		name(a3)
smfc 690	    end;
smfc 691	pname3 := if is_internal(a3) /= om then
smfc 692		'(' + name3 + ')'
smfc 693	    else
smfc 694		name3
smfc 695	    end;
smfc 696    else
smfc 697	name3 := pname3 := '***';
smfc 698    end if;
     421
     422    return case opc of
     423
     424(q1_in):	pname1 + ' in '    + pname2,
     425(q1_notin):	pname1 + ' notin ' + pname2,
     426(q1_incs):	pname1 + ' incs '  + pname2,
     427(q1_eq):	pname1 + ' = '     + pname2,
     428(q1_ne):	pname1 + ' /= '    + pname2,
     429(q1_lt):	pname1 + ' < '     + pname2,
smfh  48(q1_pos):	pname1 + ' > '     + pname2,
     430(q1_ge):	pname1 + ' >= '    + pname2,
     431
     432(q1_add):	pname1 + ' + '     + pname2,
     433(q1_sub):	pname1 + ' - '     + pname2,
     434(q1_mult):	pname1 + ' * '     + pname2,
     435(q1_slash):	pname1 + ' / '     + pname2,
     436(q1_div):	pname1 + ' div '   + pname2,
     437(q1_mod):	pname1 + ' mod '   + pname2,
     438(q1_exp):	pname1 + ' ** '    + pname2,
     439(q1_atan2):	pname1 + ' atan2 ' + pname2,
     440(q1_max):	pname1 + ' max '   + pname2,
     441(q1_min):	pname1 + ' min '   + pname2,
     442(q1_npow):	pname1 + ' npow '  + pname2,
     443(q1_from):	pname1 + ' from '  + pname2,
     444(q1_fromb):	pname1 + ' fromb ' + pname2,
     445(q1_frome):	pname1 + ' frome ' + pname2,
     446(q1_with):	pname1 + ' with '  + pname2,
     447(q1_less):	pname1 + ' less '  + pname2,
     448(q1_lessb):	pname2 + ' fromb ' + pname1,
     449(q1_lesse):	pname2 + ' frome ' + pname1,
     450(q1_lessf):	pname1 + ' lessf ' + pname2,
     451
     452(q1_not):	'not '		+ pname1,
     453(q1_even):	'even '		+ pname1,
     454(q1_odd):	'odd '		+ pname1,
     455(q1_isint):	'is_integer '	+ pname1,
     456(q1_isreal):	'is_real'	+ pname1,
     457(q1_isstr):	'is_string '	+ pname1,
     458(q1_isbool):	'is_boolean '	+ pname1,
     459(q1_isatom):	'is_atom '	+ pname1,
     460(q1_istup):	'is_tuple '	+ pname1,
     461(q1_isset):	'is_set '	+ pname1,
     462(q1_ismap):	'is_map '	+ pname1,
     463
     464(q1_arb):	'arb '		+ pname1,
     465(q1_arbb):	' fromb '	+ pname1,
     466(q1_arbe):	' frome '	+ pname1,
     467(q1_dom):	'domain '	+ pname1,
     468(q1_range):	'range '	+ pname1,
     469(q1_pow):	'pow '		+ pname1,
     470(q1_nelt):	'# '		+ pname1,
     471(q1_abs):	'abs '		+ pname1,
     472(q1_char):	'char '		+ pname1,
     473(q1_ceil):	'ceil '		+ pname1,
     474(q1_floor):	'floor '	+ pname1,
     475(q1_fix):	'fix '		+ pname1,
     476(q1_float):	'float '	+ pname1,
     477(q1_sin):	'sin '		+ pname1,
     478(q1_cos):	'cos '		+ pname1,
     479(q1_tan):	'tan '		+ pname1,
     480(q1_arcsin):	'asin '		+ pname1,
     481(q1_arccos):	'acod '		+ pname1,
     482(q1_arctan):	'atan '		+ pname1,
     483(q1_tanh):	'tanh '		+ pname1,
     484(q1_expf):	'exp '		+ pname1,
     485(q1_log):	'log '		+ pname1,
     486(q1_sqrt):	'sqrt '		+ pname1,
     487(q1_sign):	'sign '		+ pname1,
     488(q1_type):	'type '		+ pname1,
     489(q1_str):	'str '		+ pname1,
     490(q1_val):	'val '		+ pname1,
     491(q1_umin):	'-'		+ pname1,
     492(q1_rand):	'random '	+ pname1,
     493
     494(q1_newat):	'newat',
     495(q1_time):	'time',
     496(q1_date):	'date',
     497(q1_na):	'nargs',
     498
     499(q1_set):	'{ ' +
     500		if #aivs >= 1 then name1        else '' end +
     501		if #aivs >= 2 then ', ' + name2 else '' end +
     502		if #aivs >= 3 then ', ...'      else '' end +
     503		' }',
     504
     505(q1_set1):	'{ ' + name1 + ' :  }',
     506
     507(q1_tup):	'[ ' +
     508		if #aivs >= 1 then name1        else '' end +
     509		if #aivs >= 2 then ', ' + name2 else '' end +
     510		if #aivs >= 3 then ', ...'      else '' end +
     511		' ]',
     512
     513(q1_tup1):	'[ ' + name1 + ' :  ]',
     514
     515(q1_inext, q1_next, q1_inextd, q1_nextd):
     516		'',
     517
     518(q1_of):	pname1 + '(' + name2 + ')',
     519(q1_ofa):	pname1 + '{' + name2 + '}',
smfc 699(q1_subst):	pname1 + '(' + name2 + '..' + name3 + ')',
     521(q1_end):	pname1 + '(' + name2 + '..)',
     522
smfc 700(q1_sof):	pname3 + '(' + name1 + ')',
smfc 701(q1_sofa):	pname3 + '{' + name1 + '}',
smfc 702(q1_ssubst):	'(' + name1 + '..' + name2 + ')',
smfc 703(q1_send):	pname3 + '(' + name1 + '..)',
     527
     528(q1_asn):	name1,
     529(q1_argin):	name1
     530
     531else		''
     532
     533    end;
     534
     535
     536    end procedure format_inst;
     537
     538
     539
     540
     541    end module setl_optimizer - util;
     542
     543
       1 .=member dmps17
       2
       3
       4    module setl_optimizer - dumps;
       5
       6$ this module contains procedures to dump the q1 code and various
       7$ graphs.
       8
       9    var
      10	line,		$ current line number in segment
      11	outint;		$ outermost interval of routine being dumped
      12
      13    var
      14	all_bases;	$ all bases in scope
      15
      16    const
      17	line_size         = 130,  $ linesize of output file
      18	lines_per_segment = 54;   $ lines per segment
      19
      20    var
smfk 183	act_exposd,	$ globals actually used in a scope before they
smfk 184			$  are defined by that member
smfk 185	act_reads,	$ globals actually used by a member
      25	act_writes,	$ globals actually changed by a member
      26	act_calls,	$ routines actually called by a member
smfk 186	globals,	$ maps each member to the globals it defines
smfk 187	routines,	$ maps each member to the routines it defines
      27	seen;		$ member has been processed before
      28
      29    init
smfk 188	act_exposd := {},   act_reads := {},    act_writes := {},
smfk 189	act_calls := {},    globals := {},      routines := {},
smfk 190	seen := {};
      33
      34    repr
      35	line:			integer 0..lines_per_segment;
      36	outint:			elmt blocks;
      37	all_bases:		tuple(symbol);
      38
      39	symdmp:			procedure(elmt base_scopes);
      40	formdmp:		procedure(elmt base_scopes);
      41	codedmp:		procedure(elmt base_scopes);
      42	intdmp:			procedure(elmt base_scopes);
      43	dmp_int:		procedure(elmt blocks, integer);
      44
      45	base members:		elmt base_scopes;
      46	mode member:		elmt members;
      47
      48	globals:		local mmap(member) symbol;
      49	routines:		local mmap(member) routine;
      50
smfk 191	act_exposd:		local mmap(member) symbol;
      51	act_reads:		local mmap(member) symbol;
      52	act_writes:		local mmap(member) symbol;
      53	act_calls:		local mmap(member) routine;
      54
      55	seen:			local set(member);
      56
      57	print_dir_summary:	procedure(elmt base_scopes, string);
      58	print_memb_summary:	procedure(elmt base_scopes, string);
      59	print_member_interface:	procedure(member, integer 0..65536);
      60	print_proc_summary:	procedure(routine);
      61	print_decls:		procedure(
      62				    elmt base_scopes,
      63				    integer 0..65536    );
      64	print_reprs:		procedure(
      65				    elmt base_scopes,
      66				    integer 0..65536    );
      67	sort_by_name:		procedure(tuple(symbol))
      68				    tuple(symbol);
      69	sort_by_occs:		procedure(tuple(occurrence))
      70				    tuple(occurrence);
      71    end repr;
      72
      73
      74    procedure dmp(scp, tables(*));
      75$
      76$ this is the main dump routine. its arguments are:
      77$
      78$ scp:       name of scope to be dumped. if 'scope' is omega we dump
      79$            all scopes.
      80$
      81$ tables:    a tuple of strings giving the tables to be dumped.
      82$
      83     repr
      84	 scp:			elmt base_scopes;
      85	 tables:		tuple(string);
      86	 todo:			tuple(elmt base_scopes);
      87	 t:			string;
      88	 sc:			elmt base_scopes;
      89     end repr;
      90
      91    if scp = om then todo := scopes; else todo := [ scp ]; end if;
      92
      93    (forall t in tables)
      94
      95	case t of
      96
      97	('symtab'):   (forall sc in todo) symdmp(sc);  end;
      98	('formtab'):  (forall sc in todo) formdmp(sc); end;
      99	('codetab'):  (forall sc in todo) codedmp(sc); end;
     100	('igraph'):   (forall sc in todo) intdmp(sc);  end;
     101	end case;
     102    end forall;
     103
     104    end procedure dmp;
     105
     106
     107
     108
     109    procedure symdmp(sc);
     110$
     111$ this routine dumps the symbols of the scope sc.
     112$
     113$ assert if is_atom x then # str x <= 6 else true end;
     114$
     115    repr
     116	sc:			elmt base_scopes;
     117	s:			symbol;
     118	t, undrs:		string;
     119    end repr;
     120
     121    title('symbol table dump for ' + name(sc));
     122
     123    undrs := line_size * '-';
     124    line  := lines_per_segment;
     125
     126    (for_sym(s, sc))
     127	if line >= lines_per_segment then
     128	    print('s      name      form   scope  alias',
     129		'tm in rd wr cn st sk pr rp in sn rc value'    );
     130	    print(undrs);
     131	    print;
     132	    line := 3;
     133	else
     134	    line +:= 1;
     135	end if;
     136
     137	print(
     138	  rpad(str s,         6),
     139	  if #(t := name(s)) > 9 then t(1..9) else rpad(t, 9) end,
     140	  rpad(str form(s),   6),
     141	  rpad(str scope(s),  6),
     142	  rpad(str alias(s),  6),
     143	  if is_temp(s)     = om then '- ' else '+ ' end,
     144	  if is_internal(s) = om then '- ' else '+ ' end,
     145	  if is_read(s)     = om then '- ' else '+ ' end,
     146	  if is_write(s)    = om then '- ' else '+ ' end,
     147	  if is_const(s)    = om then '- ' else '+ ' end,
     148	  if is_store(s)    = om then '- ' else '+ ' end,
     149	  if is_stk(s)      = om then '- ' else '+ ' end,
     150	  if is_param(s)    = om then '- ' else '+ ' end,
     151	  if is_repr(s)     = om then '- ' else '+ ' end,
     152	  if is_init(s)     = om then '- ' else '+ ' end,
     153	  if is_seen(s)     = om then '- ' else '+ ' end,
     154	  if is_rec(s)      = om then '- ' else '+ ' end,
     155	  if #(t:=str value(s)) > 52 then t(1..52) else t end
     156	  );
     157
     158	if line >= lines_per_segment then eject; end if;
     159    end;
     160
     161    end procedure symdmp;
     162
     163
     164
     165
     166    procedure formdmp(sc);
     167$
     168$ this routine dumps the forms of the scope sc.
     169$
     170$ assert if is_atom x then # str x <= 6 else true end;
     171$ assert is_string ft_type(fm);
     172$ assert # ft_type(fm) <= 9;
     173$ assert if ft_mapc(fm) /= om then is_string ft_mapc(fm) else true end;
     174$ assert if ft_mapc(fm) /= om then # ft_mapc(fm) <= 7 else true end;
     175$
     176    repr
     177	sc:			elmt base_scopes;
     178	fm:			elmt forms;
     179	el:			general;
     180	t, undrs:		string;
     181    end repr;
     182
     183
     184    title('form table dump for ' + name(sc));
     185
     186    undrs := line_size * '-';
     187    line  := lines_per_segment;
     188
     189    (for_form(fm, sc))
     190	if line >= lines_per_segment then
     191	    print('form   type      mapc    elmt   dom    im    ',
     192		'base   lim    tup    hash nelt low  pos  num/elmt');
     193	    print(undrs);
     194	    print;
     195	    line := 3;
     196	else
     197	    line +:= 1;
     198	end if;
     199
     200	print(
     201	  rpad(str fm,      6),
     202	  rpad(ft_type(fm), 9),
     203	  if (t:=ft_mapc(fm)) = om then '       ' else rpad(t,7) end,
     204
     205	  if is_atom (el:=ft_elmt(fm)) then
     206	      rpad(str el, 6)
     207	  else
     208	      '      '
     209	  end,
     210
     211	  rpad(str ft_dom(fm),  6),
     212	  rpad(str ft_im(fm),   6),
     213	  rpad(str ft_base(fm), 6),
     214	  if #(t:=str ft_lim(fm)) > 6 then t(1..6) else rpad(t,6) end,
     215	  rpad(str ft_tup(fm),  6),
     216	  if ft_hashok(fm)  = om then '-   ' else '+   ' end,
     217	  if ft_neltok(fm)  = om then '-   ' else '+   ' end,
     218	  if #(t:=str ft_low(fm)) > 4 then t(1..4) else rpad(t,4) end,
     219	  if #(t:=str ft_pos(fm)) > 4 then t(1..4) else rpad(t,4) end,
     220
     221	  if is_fbase(fm) then
     222	      if #(t:=str ft_num(fm)) > 42 then t(1..42) else t end
     223	  elseif not is_atom el then
     224	      if #(t:=str el) > 42 then t(1..42) else t end
     225	  else
     226	      rpad(str ft_deref(fm), 6)
     227	  end
     228	  );
     229
     230	if line >= lines_per_segment then eject; end if;
     231    end;
     232
     233    end procedure formdmp;
     234
     235
     236
     237
     238    procedure print_summary(todo);
     239$
     240$ this routine prints the summary for scopes todo.  the summary contains
     241$ a interface description and the representations chosen for  all  local
     242$ variables.  consequently, the information printed by  print_symtab  is
     243$ properly contained in the information printed by print_summary.
     244$
     245    init
     246	header := '';
     247
     248    repr
     249	todo:			sparse set(elmt base_scopes);
     250	sc:			elmt base_scopes;
     251	header:			string;
     252    end repr;
     253
     254
     255    (forall sc in scopes | sc in todo)
     256
     257	if sc_type(sc) /= sc_proc and header /= '' then
     258	    print;
     259	    print('end', header);
     260	end if;
     261
     262	print;
     263
     264	case sc_type(sc) of
     265
     266	(sc_sys):		$ system scope
     267
     268	    print_reprs(sc, 1);
     269
     270	(sc_lib):		$ library scope
     271
     272	    header := 'library ' + name(sc) + ';';
     273	    print_memb_summary(sc, header);
     274
     275	(sc_dir):		$ directory scope
     276
     277	    header := 'directory ' + name(sc) + ';';
     278	    print_dir_summary(sc, header);
     279
     280	(sc_prog):		$ program scope
     281
     282	    header := 'program '+name(sym_dir)+' - '+name(sc)+';';
     283	    print_memb_summary(sc, header);
     284
     285	(sc_mod):		$ module scope
     286
     287	    header := 'module '+name(sym_dir)+' - '+name(sc)+';';
     288	    print_memb_summary(sc, header);
     289
     290	(sc_proc):		$ procedure scope
     291
     292	    print_proc_summary(sc);
     293
     294	end case;
     295
     296
     297    end forall;
     298
     299    if header /= '' then
     300	print;
     301	print('end', header);
     302    end if;
     303
     304
     305    end procedure print_summary;
     306
     307
     308
     309
     310    procedure print_dir_summary(sc, header);
     311$
     312$ this routine prints the summary for the directory d.
     313$
     314    repr
     315	sc:			elmt base_scopes;
     316	header:			string;
     317
     318	d, m:			member;
     319	p:			routine;
     320	v:			symbol;
     321    end repr;
     322
     323
     324    print;
     325    print(header);
     326
     327    d := sc;
     328
     329    (forall m in all_modules | m notin seen)
     330	globals{m}  := { v in globalvars |
     331				    v in uservars and scope(v) = m };
smfk 192	if m = d then  continue forall;  end if;
smfk 193
smfk 194	$ recall that value(m)(5) are the exported procedures of m.
smfk 195	routines{m} := { p in routs | membof(p) = m } + value(m)(5);
smfk 196	if sc_type(m) = sc_prog then routines{m} with:= sym_main; end;
     333
smfk 197	act_exposd{m} := {}+/[ globals_e{p}: p in routines{m} ];
     334	act_reads{m}  := {}+/[ globals_r{p}: p in routines{m} ];
     335	act_writes{m} := {}+/[ globals_w{p}: p in routines{m} ];
     336	act_calls{m}  := {}+/[ cgraph{p}:    p in routines{m} ];
     337
     338	seen with:= m;
     339    end forall;
     340
smfk 198    act_exposd{d} := {} +/[ act_exposd{m} : m in all_modules ];
     341    act_reads{d}  := {} +/[ act_reads{m} :  m in all_modules ];
     342    act_writes{d} := {} +/[ act_writes{m} : m in all_modules ];
     343    act_calls{d}  := {} +/[ act_calls{m} :  m in all_modules ];
     344
     345    seen with:= d;
     346
     347    print_decls(sc, 1);
     348
     349    print;
     350    print('    program', name(sym_dir), '-', name(sym_prog) + ':');
     351    print_member_interface(sym_prog, 2);
     352
     353    (forall m in scopes | sc_type(m) = sc_mod)
     354	print;
     355	print('    module', name(sym_dir), '-', name(m) + ':');
     356	print_member_interface(m, 2);
     357    end forall;
     358
     359    print_reprs(sc, 1);
     360
     361
     362    end procedure print_dir_summary;
     363
     364
     365
     366
     367    procedure print_memb_summary(sc, header);
     368$
     369$ this routine prints the summary for the member m, where  m  is  not  a
     370$ directory.
     371$
     372    repr
     373	sc:			elmt base_scopes;
     374	header:			string;
     375
     376	m:			member;
     377	p:			routine;
     378	v:			symbol;
     379    end repr;
     380
     381
     382    print;
     383    print(header);
     384
     385    if (m := sc) notin seen then
     386	globals{m}  := { v in globalvars |
     387				    v in uservars and scope(v) = sc };
     388	routines{m} := { p in routs | membof(p) = sc };
     389
smfk 199	act_exposd{m} := {}+/[ globals_e{p}: p in routines{m} ];
     390	act_reads{m}  := {}+/[ globals_r{p}: p in routines{m} ];
     391	act_writes{m} := {}+/[ globals_w{p}: p in routines{m} ];
     392	act_calls{m}  := {}+/[ cgraph{p}:    p in routines{m} ];
     393
     394	seen with:= m;
     395    end if;
     396
smfk 200    if sym_dir notin seen then  print_member_interface(m, 1);  end if;
smfk 201
     398    print_decls(m, 1);
     399    print_reprs(m, 1);
     400
     401
     402    end procedure print_memb_summary;
     403
     404
     405
     406
     407    procedure print_member_interface(m, indent);
     408$
     409$ this routine prints the interface descriptions for member m.
     410$
     411    repr
     412	m:			member;
     413	indent:			integer 0..65536;
     414
     415	libs:			sparse set(elmt base_scopes);
     416	rds, rds_d, wrts_d:	sparse set(symbol);
     417	imps, exps:		sparse set(routine);
     418	l:			elmt base_scopes;
     419	t:			tuple(symbol);
     420	p, v:			symbol;
     421	j:			integer 0..65536;
     422	fill1, fill2:		string;
     423    end repr;
     424
     425
     426    $ the value of a member is a quintuple, giving (in this  order)  the
     427    $ libraries referenced, the globals read, the globals  written,  the
     428    $ procedures imported, and the procedures exported.
     429    [ libs, rds_d, wrts_d, imps, exps ] := value(m);
     430
     431    $ the imports list of a module is really the union of  its  declared
     432    $ imports list and of all the procedure exported  by  the  libraries
     433    $ of its libraries list.
     434    imps := imps +/[ value(l)(5) : l in libs ];
     435
     436
     437    fill2 := (indent*4+3) * ' ';   fill1 := fill2(5..#fill2);
     438
     439    if libs /= {} then		$ print libraries list
     440	print;
     441	print(fill1, 'libraries');
     442
     443	t := sort_by_name( [ v : v in libs ] );
     444
     445	(forall v in t)
     446	    print(
     447		fill2,
     448		rpad(name(v) + if v = t(#t) then ';' else ',' end,
     449		    (39-indent*4)    ),
     450		if forall p in value(v)(5) |
     451				p notin act_calls{m} then
smfk 202		    '$ declared but not used.'
     453		else
     454		    ''
     455		end
     456		);
     457	end forall;
     458    end if;
     459
     460
     461    rds := rds_d + { v in act_reads{m} |
     462			v notin globals{m} and is_param(v) = om };
     463    if rds /= {} then		$ print reads list
     464	print;
     465	print(fill1, 'reads');
     466
     467	t := sort_by_name( [ v : v in rds ]);
     468
     469	(forall v in t)
     470	    print(
     471		fill2,
     472		rpad(name(scope(v)) + '.' + name(v) +
     473			if v = t(#t) then ';' else ',' end,
     474		    (39-indent*4)    ),
     475		if v notin act_reads{m} then
smfk 203		    '$ declared but not used.'
smfk 204		elseif v notin act_exposd{m} then
smfk 205		    '$ not used before its first definition.'
     477		elseif v notin rds_d and v notin wrts_d then
     478		    '$ ===used but not declared==='
     479		else
     480		    ''
     481		end
     482		);
     483	end forall;
     484    end if;
     485
     486
     487    if wrts_d /= {} then	$ print writes list
     488	print;
     489	print(fill1, 'writes');
     490
     491	t := sort_by_name( [ v : v in wrts_d ] );
     492
     493	(forall v in t)
     494	    print(
     495		fill2,
     496		rpad(name(scope(v)) + '.' + name(v) +
     497			if v = t(#t) then ';' else ',' end,
     498		    (39-indent*4)    ),
     499		if v notin act_writes{m} then
     500		    if v in act_reads{m} then
smfk 206			'$ writes declared but only reads used.'
     502		    else
smfk 207			'$ declared but not used.'
     504		    end
     505		else
     506		    ''
     507		end
     508		);
     509	end forall;
     510    end if;
     511
     512
     513    if imps /= {} then		$ print imports list
     514	print;
     515	print(fill1, 'imports');
     516
     517	t := sort_by_name( [ v : v in imps ] );
     518
     519	(forall p in t)
     520	    print(
     521		fill2,
     522		rpad(name(membof(p)) + '.' + name(p) +
     523			'(' +/[ case name(rptyps(p)(j)) of
     524				('rd'): 'rd', ('wr'): 'wr', ('rw'): 'rw'
     525				else om end +
     526			if j = rnargs(p) then
     527			    if rvary(p) /= om then '(*)' else '' end
     528			else
     529			    ', '
     530			end : j in [ 1..rnargs(p) ]	 ] + ')' +
     531			if p = t(#t) then ';' else ',' end,
     532		    (39-indent*4)    ),
     533		if p notin act_calls{m} then
smfk 208		    '$ imported but not used.'
     535		else
     536		    ''
     537		end
     538		);
     539	end forall;
     540    end if;
     541
     542
     543    if exps /= {} then		$ print exports list
     544	print;
     545	print(fill1, 'exports');
     546
     547	t := sort_by_name( [ v : v in exps ] );
     548
     549	(forall p in t)
     550	    print(
     551		fill2,
     552		name(p) +
     553		    '(' +/[ case name(rptyps(p)(j)) of
     554			    ('rd'): 'rd', ('wr'): 'wr', ('rw'): 'rw'
     555			    else om end +
     556			if j = rnargs(p) then
     557			    if rvary(p) /= om then '(*)' else '' end
     558			else
     559			    ', '
     560			end : j in [ 1..rnargs(p) ]	 ] + ')' +
     561		    if p = t(#t) then ';' else ',' end
     562		);
     563	end forall;
     564    end if;
     565
     566
     567    end procedure print_member_interface;
     568
     569
     570
     571
     572    procedure print_proc_summary(p);
     573$
     574$ this routine prints the summary for the procedure p.
     575$
     576    repr
     577	p, q:			routine;
     578	t:			tuple(symbol);
     579	v:			symbol;
     580	o:			tuple(occurrence);
     581	dvo:			occurrence;
     582	j:			integer 0..65536;
     583    end repr;
     584
     585
     586    print('    procedure', name(p) + ';');
     587
smfk 209    if exists v in globals_e{p} | is_param(v) = om then
     589	print;
     590	print('        reads');
     591
     592	t := sort_by_name(
smfk 210		    [ v : v in globals_e{p} | is_param(v) = om ] );
     594
     595	(forall v in t)
     596	    print(
     597		'           ',
     598		name(scope(v)) + '.' + name(v) +
     599		if v = t(#t) then ';' else ',' end
     600		);
     601	end forall;
     602    end if;
     603
     604
     605    if exists v in globals_w{p} | is_param(v) = om then
     606	print;
     607	print('        writes');
     608
     609	t := sort_by_name(
     610		    [ v : v in globals_w{p} | is_param(v) = om ] );
     611
     612	(forall v in t)
     613	    print(
     614		'           ',
     615		name(scope(v)) + '.' + name(v) +
     616		if v = t(#t) then ';' else ',' end
     617		);
     618	end forall;
     619    end if;
     620
     621
     622    if cgraph{p} /= {} then	$ print imports list
     623	print;
     624	print('        imports');
     625
     626	t := sort_by_name( [ q : q in cgraph{p} ] );
     627
     628	(forall q in t)
     629	    print(
     630		'           ',
     631		name(membof(q)) + '.' + name(q) +
     632		'(' +/[ case name(rptyps(q)(j)) of
     633			('rd'): 'rd', ('wr'): 'wr', ('rw'): 'rw'
     634			else om end +
     635		    if j = rnargs(q) then
     636			if rvary(q) /= om then '(*)' else '' end
     637		    else
     638			', '
     639		    end : j in [ 1..rnargs(q) ]    ] + ')' +
     640		if q = t(#t) then ';' else ',' end
     641		);
     642	end forall;
     643    end if;
     644
     645
     646    $ print the representations of the local variables
     647    print_reprs(p, 2);
     648
     649
     650    if globals_du{p} /= {} then
     651	print;
     652	o := sort_by_occs( [ dvo : dvo in globals_du{p} ] );
     653
     654	(forall dvo in o)
     655	    print(
     656		'       ',
     657		name(scope(oi_sym(dvo))) + '.' +
     658		name(alias(oi_sym(dvo)) ? oi_sym(dvo)),
     659		'is used destructively at', oi_stmt(dvo)
     660		);
     661	end forall;
     662    end if;
     663
     664    print;
     665    print('    end procedure', name(p) + ';');
     666
     667
     668    end procedure print_proc_summary;
     669
     670
     671
     672
     673    procedure print_decls(sc, indent);
     674$
     675$ this routine prints the global variables defined in scope sc  together
     676$ with their forms.  sc is a static scope, i.e. a  librar-,  directory-,
     677$ program-, or module scope.
     678$
     679    repr
     680	sc:			elmt base_scopes;
     681	indent:			integer 0..65536;
     682
     683	m:			member;
     684	t:			tuple(symbol);
     685	v:			symbol;
     686
     687	fill1, fill2:		string;
     688    end repr;
     689
     690
     691    if globals{m := sc} = {} then return; end if;
     692
     693    fill2 := (indent*4+3) * ' ';   fill1 := fill2(5..#fill2);
     694
     695    print;
     696    print(fill1, 'var');
     697
     698    t := sort_by_name( [ v : v in globals{m} ] );
     699
     700    (forall v in t)
     701	print(
     702	    fill2,
     703	    rpad(name(v) +
     704		if value(v) /= om then ' := ' + value(v) else '' end +
     705		if v = t(#t) then ';' else ',' end, (39-indent*4)),
     706	    if v notin act_reads{m} and v notin act_writes{m} then
smfk 211		'$ declared but not used.'
     708	    else
     709		''
     710	    end
     711	    );
     712    end forall;
     713
     714
     715    end procedure print_decls;
     716
     717
     718
     719
     720    procedure print_reprs(sc, indent);
     721$
     722$ this procedure prints the local variables of  the  scope  sc  together
     723$ with their forms.  the list is sorted alphabetically,  and  takes  the
     724$ form of a  declaration.
     725$
     726    repr
     727	sc:			elmt base_scopes;
     728	indent:			integer 0..65536;
     729
     730	v:			symbol;
     731	t:			tuple(symbol);
smfk 212	vo:			occurrence;
     732
     733	fill1, fill2:		string;
     734    end repr;
     735
     736
     737    all_bases := [];		$ set of all bases
     738
     739    $ build a tuple with all variables of sc
     740    t := [];
     741    (for_sym(v, sc))
     742	if is_fbase(form(v)) then
     743	    all_bases with:= v;
smff 154	elseif '(' in name(v) or '$' in name(v) then
     745	    pass;   $ system internal name
     746	elseif v = sym_main then
     747	    pass;
     748	elseif v in variables and is_internal(v) = om then
smfk 213	    if occsof{v} /= {}
smfk 214		    and forall vo in occsof{v} | argno(vo) = 1
smfk 215			    and oi_op(vo) = q1_asn
smfk 216			    and arg2(instno(vo)) = sym_om
smfk 217			    and ffrom{vo} = {}
smfk 218	    then
smfk 219		continue;
smfk 220	    end if;
     749	    t with:= v;
     750	elseif v in routs then
     751	    t with:= v;
     752	end if;
     753    end;	$ end for_sym
     754
     755    $ for program and module scopes,  we  repeat  the  declarations  for
     756    $ exported procedures.  for  library  and  directory  scopes,  these
     757    $ symbols have already been added to t in the preceding loop.
     758    if sc_type(sc) = sc_prog or sc_type(sc) = sc_mod then
     759	$ (the value of a member is a quintuple, giving  (in this order)
     760	$ the libraries referenced, the globals read, the globals  writ-
     761	$ ten, the procedures imported, and the procedures exported.)
     762	(forall v in value(sc)(5)) t with:= v; end forall;
     763    end if;
     764
     765    if #all_bases = 0 and #t = 0 then return; end if;
     766
     767    fill2 := (indent*4+3) * ' ';   fill1 := fill2(5..#fill2);
     768    print;
     769    print(fill1, 'repr');
     770
     771    (forall v in all_bases)
     772	print(
     773	    fill2,
     774	    'base',
     775	    rpad(name(v) + ':', (18-indent*4)),
     776	    format_form(ft_elmt(form(v))) + ';'
     777	    );
     778    end forall;
     779
     780    if #all_bases > 0 and #t > 0 then print; end if;
     781
     782    (forall v in sort_by_name(t))
     783	print(
     784	    fill2,
     785	    rpad(name(v) + ':', (23-indent*4)),
     786	    format_form(form(v)) + ';'
     787	    );
     788    end forall;
     789
     790    print(fill1, 'end repr;');
     791
     792
     793    end procedure print_reprs;
     794
     795
     796
     797
     798    procedure sort_by_name(t);
     799$
     800$ this function returns the tuple t of symbols sorted  by  the  variable
     801$ name of the symbol.
     802$
     803    repr
     804	t:			tuple(symbol);
     805	sym:			symbol;
     806	j, k, m, n, l:		integer 0..65536;
     807    end repr;
     808
     809
     810    macro before(l, r);		$ defines partial order
     811	( name(t(l)) < name(t(r)) )
     812    endm;
     813
     814
     815    if #t = 0 then return t; end if;	$ trivial case
     816
     817    $ sort the variables alphabetically, using heap sort
     818    (init n := #t; j := n div 2; while j >= 1 step j -:= 1;)
     819	(init k := j; while (l := k+k) <= n)
     820	    $ which child will be promoted ?
     821	    m := if l < n and before(l, l+1) then l+1 else l end;
     822
     823	    $ will a child be promoted ?
     824	    if before(k, m) then
     825		sym := t(k);  t(k) := t(m);  t(m) := sym;  k := m;
     826	    else
     827		quit init k;
     828	    end if;
     829	end init k;
     830    end init n;
     831
     832    (init j := n; while j > 1)
     833	sym := t(j);   t(j) := t(1);   t(1) := sym;   j -:= 1;
     834	(init k := 1; while (l := k+k) <= j)
     835	    $ which child will be promoted ?
     836	    m := if l < j and before(l, l+1) then l+1 else l end;
     837
     838	    $ will a child be promoted ?
     839	    if before(k, m) then
     840		sym := t(k);  t(k) := t(m);  t(m) := sym;  k := m;
     841	    else
     842		quit init k;
     843	    end if;
     844	end init k;
     845    end init j;
     846
     847    return t;
     848
     849
     850    end procedure sort_by_name;
     851
     852
     853
     854
     855    procedure sort_by_occs(t);
     856$
     857$ this function returns  the  tuple  t  of  occurrences  sorted  by  the
     858$ variable name and the statement number  of  the  occurrence.   aliased
     859$ variables are grouped by their original name.
     860$
     861    repr
     862	t:			tuple(occurrence);
     863	oi:			occurrence;
     864	j, k, m, n, l, r:	integer 0..65536;
     865    end repr;
     866
     867
     868    macro before(l, r);		$ defines partial order
     869	( ( name(alias(oi_sym(t(l))) ? oi_sym(t(l))) <
     870		name(alias(oi_sym(t(r))) ? oi_sym(t(r))) )
     871	  or
     872	  ( ( name(alias(oi_sym(t(l))) ? oi_sym(t(l))) =
     873		  name(alias(oi_sym(t(r))) ? oi_sym(t(r))) )
     874	    and
     875	    ( stmtof(instno(t(l))) < stmtof(instno(t(r))) ) ) )
     876    endm;
     877
     878
     879    if #t = 0 then return t; end if;	$ trivial case
     880
     881    $ sort the variables alphabetically, using heap sort
     882    (init n := #t; j := n div 2; while j >= 1 step j -:= 1;)
     883	(init k := j; while (l := k+k) <= n)
     884	    $ which child will be promoted ?
     885	    m := if l < n and before(l, l+1) then l+1 else l end;
     886
     887	    $ will a child be promoted ?
     888	    if before(k, m) then
     889		oi := t(k);  t(k) := t(m);  t(m) := oi;  k := m;
     890	    else
     891		quit init k;
     892	    end if;
     893	end init k;
     894    end init n;
     895
     896    (init j := n; while j > 1)
     897	oi := t(j);   t(j) := t(1);   t(1) := oi;   j -:= 1;
     898	(init k := 1; while (l := k+k) <= j)
     899	    $ which child will be promoted ?
     900	    m := if l < j and before(l, l+1) then l+1 else l end;
     901
     902	    $ will a child be promoted ?
     903	    if before(k, m) then
     904		oi := t(k);  t(k) := t(m);  t(m) := oi;  k := m;
     905	    else
     906		quit init k;
     907	    end if;
     908	end init k;
     909    end init j;
     910
     911    return t;
     912
     913
     914    end procedure sort_by_occs;
     915
     916
     917
     918
     919    procedure codedmp(sc);
     920$
     921$ this routine dumps the code for the scope sc.
     922$
     923$ assert if is_atom x then # str x <= 6 else true end;
     924$ assert is_string opcode(i);
     925$ assert # opcode(i) <= 10;
     926$ assert is_string copy_flag(i);
     927$ assert # copy_flag(i) <= 9;
     928$
     929    repr
     930	sc:			elmt base_scopes;
     931	b:			elmt blocks;
     932	i:			elmt insts;
     933	v:			symbol;
     934	t, undrs:		string;
     935	j1, j2:			integer 0..65536;
     936	cstmt_count:		integer;
     937	ustmt_count:		integer;
     938    end repr;
     939
     940    title('code table dump for ' + name(sc));
     941
     942    undrs := 80 * '-';
     943    line  := 0;
     944
     945    cstmt_count := ustmt_count := sc_estmt_ct(sc);
     946
     947    (for_block(b, sc))
     948	print('routine:',   rpad(name(routof(b)), 10),
     949	    '  interval:',  rpad(str intof(b),     6),
     950	    '  block:',     rpad(str b,            6),
     951	    '  statement:', cstmt_count-ustmt_count+1
     952	    );
     953	print;
     954	print('i      opcode     copy_flag shr arguments');
     955	print(undrs);
     956	line +:= 4;
     957
     958	(for_inst(i, b))
     959	    if opcode(i) = q1_stmt then
     960		cstmt_count +:= 1;
     961		t := rpad(str (cstmt_count-ustmt_count+1), 10) + '  ' +
     962			rpad(str cstmt_count, 10) + '  ';
     963	    else
     964		t := '' +/[ rpad(name(v), 10) + '  ' : v in args(i) ];
     965	    end if;
     966
     967	    print(
     968		rpad(str i,               6),
     969		rpad(opcode(i),          10),
     970		rpad(copy_flag(i) ? '',   9),
     971		if share_flag(i) = om then '   ' else '+  ' end,
     972		t(1..(48 min #t))
     973		);
     974
     975	    if line >= lines_per_segment then
     976		eject;
     977		print('i      opcode     copy_flag shr arguments');
     978		print(undrs);
     979		line := 2;
     980	    else
     981		line +:= 1;
     982	    end if;
     983
     984	    loop init j1 := 1;   j2 := 48;
     985		doing j1 +:= 48; j2 +:= 48;
     986		while j1 <= #t
     987	    do
     988		print(rpad('', 31), t(j1..(j2 min #t)));
     989
     990		if line >= lines_per_segment then
     991		    eject;
     992		    print('i      opcode     copy_flag shr arguments');
     993		    print(undrs);
     994		    line := 2;
     995		else
     996		    line +:= 1;
     997		end if;
     998
     999	    end loop;
    1000
    1001	end;	$ end for_inst;
    1002
    1003	if lines_per_segment - line <= 8 then
    1004	    eject;
    1005	    line := 0;
    1006	else
    1007	    print; print;
    1008	    line +:= 2;
    1009	end if;
    1010
    1011    end;	$ end for_block;
    1012
    1013    end procedure codedmp;
    1014
    1015
    1016
    1017
    1018    procedure intdmp(sc);
    1019
    1020$ this routine dumps the interval graph for scope 'sc'
    1021
    1022    repr
    1023	sc:			elmt base_scopes;
    1024    end repr;
    1025
    1026    if sc notin routs then return; end if;
    1027
    1028    title('interval graph dump for ' + name(sc));
    1029    line := lines_per_segment;
    1030
    1031$ walk the graph recursively starting with the entry point
    1032    outint := rentry(sc);
    1033    dmp_int(rentry(sc), 0);
    1034
    1035    end procedure intdmp;
    1036
    1037
    1038
    1039
    1040    procedure dmp_int(i, indent);
    1041$
    1042$ this routine dumps the interval graph for the inteval i.
    1043$
    1044    repr
    1045	i:			elmt blocks;
    1046	m, n:			elmt blocks;
    1047	t, undrs:		string;
    1048	j1, j2:			integer 0..65536;
    1049    end repr;
    1050
    1051    undrs := 80 * '-';
    1052
    1053    (forall n in int_nodes(i))
    1054
    1055 	if line >= lines_per_segment then
    1056	    print('interval nodes    cessors');
    1057	    print(undrs);
    1058	    line := 2;
    1059	end if;
    1060
    1061	t := '' +/[ rpad(str m, 9) : m in cessor{n} |
    1062					intof(m) /= n or n = outint ];
    1063	print(
    1064	    lpad(rpad(str i, 8), ((indent+1) min 6)*9-1),
    1065	    rpad(str n, 6), ':',
    1066	    t(1..( (80 - ((indent+2) min 8)*9) min #t) )
    1067	    );
    1068	line +:= 1;
    1069
    1070 	if line >= lines_per_segment then
    1071	    eject;
    1072	    print('interval nodes    cessors');
    1073	    print(undrs);
    1074	    line := 2;
    1075	end if;
    1076
smff 155	loop init j1 := 1;
smff 156	    doing j1 +:= (80-((indent+2) min 8)*9);
    1080	    while j1 <= #t
    1081	do
    1082	    print(
    1083		rpad('', ((indent+2) min 8) * 9 - 1),
smff 157		t(j1..(j1 + (80-((indent+2) min 8)*9)) min #t)
    1085		);
    1086	    line +:= 1;
    1087
    1088	    if line >= lines_per_segment then
    1089		eject;
    1090		print('interval nodes    cessors');
    1091		print(undrs);
    1092		line := 2;
    1093	    end if;
    1094	end loop;
    1095
    1096	$ descend recursively
    1097	if n /= outint and int_nodes(n) /= om then
    1098	    dmp_int(n, indent+1);
    1099	end if;
    1100
    1101    end forall;
    1102
    1103    end procedure dmp_int;
    1104
    1105
    1106    end module setl_optimizer - dumps;
    1107
    1108

« March 2024 »
Su Mo Tu We Th Fr Sa
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
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: