"Fossies" - the Fresh Open Source Software Archive

Member "heaplayers-351/benchmarks/mudlle/inference.mud" (15 Oct 2003, 30839 Bytes) of package /linux/misc/old/heaplayers_3_5_1.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 /* Simple type inference for mudlle
    2 
    3   Based on a "constraint model":
    4     - a first pass deduces the constraints on the types of variables induced
    5       by each intermediate instruction
    6     - a second pass solves these constraints, using standard data-flow
    7       techniques (the constraints are such that this is possible)
    8       this produces possible types for each variable at the start of each
    9       block, this can then easily be used in the code generation phase to
   10       generate better code for the intermediate instructions
   11 
   12   A constraint expresses the idea that if the arguments of an instruction
   13   follow certain type relations, the result will follow some (possibly
   14   distinct) relation.
   15 
   16   Types
   17   -----
   18 
   19   This simple type inference scheme has a simple notion of the "possible type"
   20   of a variable: a subset of the base mudlle types. To simplify things,
   21   some types that are considered distinct by the implementation are merged
   22   into a single type. So the possible type is actually a subset of:
   23 
   24    { function (= { closure, primitive, varargs, secure })
   25      integer
   26      string
   27      vector
   28      null
   29      symbol
   30      table
   31      pair
   32      other (= { object, character, gone, private })
   33    }
   34 
   35   'function' is a group as the differences between these types are
   36   supposed to be invisible (hmm).
   37 
   38   'other' represents types that are both not usefully inferred (see below),
   39   and which can not be distinguished anyway (values of type character or
   40   object can mutate into values of type gone, invisibly)
   41 
   42   So for example, the possible type of variable x after:
   43 
   44     if (a) x = 3
   45     else x = "fun";
   46 
   47   is: { integer, string }
   48 
   49   If a variable is used as an argument and has an empty type set then the
   50   function contains a type error. One special type set is important: 
   51   "any", ie all the above types.
   52 
   53   The inferred types serve only to improve the code for branch and
   54   compute operations:
   55     - primitives are written in C, making specialised versions without
   56       (some) type-checking would be prohibitive
   57     - global mudlle variables may change at anytime after compile & link, 
   58       thus nothing useful can be done with calls to their contents
   59     - the compiler does no inter-procedural analysis
   60 
   61 
   62   Constraints
   63   -----------
   64 
   65   Back to constraints: for each instruction, a set of constraints is
   66   generated, the instruction will produce no type error if any of them
   67   is satisfied (this reflects the fact that operators and functions may
   68   be dynamically overloaded). All constraints are of the following form:
   69 
   70     condition1 & condition2 & ... => consequence
   71 
   72   where a condition is:
   73 
   74     var1 /\ var2 /\ ... /\ constant-set
   75 
   76   and a consequence:
   77 
   78     destvar contains (var1 /\ var2 /\ ... /\ constant-set)
   79 
   80   /\ is set-intersection. The conditions are a test that the
   81   result of the intersection is not the empty set, thus the
   82   two common conditions:
   83 
   84     var /\ { integer }: means var can be an integer
   85     var1 /\ var2: means var1 can be the same type as var2
   86 
   87   The number of conditions can be 0, the consequence can be absent
   88   (for branches).
   89 
   90   An example should help:
   91 
   92     a = b + c
   93 
   94   generates:
   95 
   96     b /\ { integer } & c /\ { integer } => a contains { integer }
   97     b /\ { string } & c /\ { string } => a contains { string }
   98 
   99   (with /\ = set intersection, and an implicit comparison to the
  100   empty set in each test). This means that if b can be an integer
  101   and c can be an integer, then after this instruction a can be an
  102   integer (and the same for 'string'). But, importantly it also
  103   implies: if before the instriuction b and c could be integers then
  104   after the instruction, b and c can also be integers (the main
  105   consequence of this apparent tautology is that if before the +
  106   b could be an integer or a string, and c just a string, then
  107   afterwards b can only be a string).
  108 
  109   The semantics of the set of constraints for an instruction is thus
  110   the following:
  111 
  112     let f be a function which uses variables v1, ..., vn,
  113     containing instruction i with constraints c1, ..., ck.
  114 
  115     let type_before(i, v) represent the possible type for v
  116     before instruction i, and type_after(i, v) the possible
  117     type afterwards.
  118 
  119     the contraints specify the relation between type_before and
  120     type_after, as follows:
  121 
  122       a) forall v not mentioned in c1, ..., ck .
  123            type_after(i, v) = type_before(i, v)
  124 
  125       b) for each constraint ci = 'cond1 & ... & condj => v contains cond'
  126          the following equations hold:
  127 
  128 	   A(cond1) and ... and A(condj) ==> v contains B(cond)
  129 	   for each condition l which refers to variables w1, ..., wm
  130 	   and each of these variables w:
  131 	     A(cond1) and ... and A(condj) ==> w contains B(condl)
  132 
  133            for all variables u mentioned in c1, ..., ck but not
  134   	   mentioned in condition of ci:
  135   	     A(cond1) and ... and A(condj) ==> u contains u
  136 	   (ie constraints need not constrain all variables)
  137 
  138 	   where A(cond) is B(cond) != empty-set
  139 	   and B(x1 /\ ... /\ xp /\ constant) is
  140 	     type_before(i, x1) /\ ... /\ type_before(i, xp) /\ constant
  141 
  142 	 (ommited consequences and constants behave naturally)
  143 
  144       c) type_after(i, v) contains only those elements implied by the
  145          equations in b, thus the definition of type_after(i, v) is
  146 	 really:
  147 
  148 	   type_after(i, v) =
  149 	     union{cond = {condition} ==> v contains S and
  150 	           condition is satisified} S
  151 
  152     explanation:
  153       a) means that there are no hidden effects on the types of
  154          variables not mentioned in the constraints
  155       b) summarises the consequence on the types of the variables
  156          present in the instruction
  157       c) means that all possible types of the variables are
  158          covered by the constraints
  159 
  160   Solving constraints
  161   -------------------
  162 
  163   The constraints are solved by a standard data-flow framework, which
  164   computes for each basic_block b, type_entry(b, v) and type_exit(b, v),
  165   the possible types for each variable v at entry and exit to the block.
  166 
  167   Given type_entry(b, v) it is possible to compute type_exit(b, v) by
  168   iteratively applying the constraints of the instructions in the block:
  169 
  170     type_before(first instruction of b, v) = type_entry(b, v)
  171     type_before(successor instruction i, v) = type_after(i, v)
  172     type_exit(b, v) = type_after(last instruction of b, v)
  173 
  174   The type inference is a forward data-flow problem (see the notes below
  175   for some justifications), with in(b) = type_entry(b), out(b) = type_exit(b)
  176   (ie the type sets for all variables of the function). The following
  177   equations must be satisfied:
  178 
  179     in(b) = union{p:predecessor of b} out(p)
  180     out(b) = result of applying constraints of b to in(b) (see above)
  181     in(entry) = all variables have type set "any"
  182 
  183   The union above is done per-variable type set, of course. Initialising
  184   all type sets to the empty set (except for in(entry)) and applying 
  185   the standard iterative data-flow solution leads to minimal type
  186   sets satisfying all the equations [PROOF NEEDED...].  
  187 
  188 
  189   Generating constraints
  190   ----------------------
  191 
  192   Each class of instruction will be considered separately.
  193 
  194   First, compute instructions:
  195 
  196     dest = op v1, ..., vn
  197 
  198   Each operation op has constraint templates, expressed in terms
  199   of its arguments and destinations. These templates are simply
  200   instantiated with the arguments and destination the actual
  201   instruction to produce the real constraints.
  202 
  203   Branches: like compute instructions, these have constraint
  204   templates. The only difference is that their constraints have
  205   no consequence component (see also the "Some notes" section
  206   below for a possible improvement).
  207 
  208   Traps: like branches.
  209 
  210   Memory: these are added after the optimisation phase, so can
  211   be ignored.
  212 
  213   Closure: in the absence of inter-procedural optimisation these
  214   just generate the constraint
  215 
  216     => dest contains { function }
  217 
  218   (Optimisation of calls to known functions, ie those within the
  219   same module which cannot change, is best handled by a separate
  220   algorithm)
  221 
  222   Return: no constraints.
  223 
  224   Call: function calls can be separated into 3 categories:
  225 
  226     a) those about which nothing is known (eg calls to functions passed
  227     as parameters, or to functions stored in global variables)
  228 
  229     b) calls to primitives, except those belonging to category c.
  230 
  231     c) calls to primitives that are known to cause no global side
  232     effects (most primitives except those like 'lforeach' which
  233     call a function passed as parameter, but also includes those
  234     that modify the 'actor' variable for instance ...)
  235 
  236   For a call instruction
  237 
  238     i: dest = call f, v1, ..., vn
  239 
  240   the constraints depend on the category of function f:
  241 
  242     if f belongs to categories a or b:
  243       forall v in ambvars(i) - { dest } .
  244         => v contains { "any" }
  245 
  246   This reflects the fact that all ambiguous variables may be assigned
  247   when an unknown function is called.
  248 
  249     if f belongs to categories b or c:
  250       f has some constraint templates which are instantiated as usual.
  251 
  252     if f belongs to category a:
  253       => dest contains { "any" }
  254 
  255 
  256   A final note about the instantiation of constants in constraint
  257   templates: they are simply replaced by '{ the-constants-type }',
  258   and all constants in the constraint are merged.
  259 
  260 
  261   Some notes
  262   ----------
  263 
  264   The system does purely forward type inference. Moving type checks
  265   backward in the code is tricky as possible globally visible
  266   side effects must be considered (the whole system does not stop
  267   at the first type error ...). This is similar to problems with
  268   exceptions.
  269 
  270   Consequences: type checks cannot be moved out of loops if they
  271   are not valid at the first iteration. There are however two
  272   possible ways to reduce these problems:
  273 
  274   a) the programmer can annotate function definitions with type
  275   information (which is good for documentation anyway), this
  276   reduces the number of loops were that information is missing
  277   b) the first iteration of a loop could be unrolled (not done)
  278 
  279   Another possible improvement is to generate different type_exit()
  280   sets for all the exits of a block (this is useful, eg if the block
  281   terminates with a test of a == b. Success implies that a and b are
  282   equal and therefore have the same type set, while failure implies
  283   nothing).
  284 
  285   The framework does not consider the use of the same variable
  286   as multiple arguments (eg a[i] = i). Consider. (Correct solution
  287   appears to be that typeset for var is *intersection* of the 
  288   consequences that concern it from a given constraint, and *union*
  289   between those from different constraints - cf semantics of constraints.
  290   Hmm, can lead to variables with no type after an operation ... 
  291   Probably constraint conditions should be merged - is the obvious method
  292   correct?)
  293 
  294 */
  295 
  296 
  297 /* Implementation notes.
  298 
  299    Type sets are represented by integers, this makes all the set manipulations
  300     simple and efficient.
  301 
  302    The itype_xxx constants represent the masks for the various types
  303    (itype_any being the "full" set, itype_none the empty set).
  304 
  305    The type_before/after/etc relations are represented by vectors indexed
  306    by the variable number, as produced by recompute_vars. Only type_entry/exit
  307    are explicitly kept (with the basic blocks, along with the rest of the
  308    data-flow information).
  309 
  310    constraint templates are represented in a form designed to make their
  311    entry easy. This form is different from that of the instantiated constraints,
  312    which is designed to make evaluation efficient.
  313 
  314    The type representation for constraints is as follows:
  315 
  316      block_constraints = list of instruction_constraints
  317 
  318      instruction_constraints =
  319        sequence(instruction,
  320 		list of integer, // the variables concerned by the constraint
  321 		list of constraint)
  322 
  323      constraint =
  324        sequence(list of condition,
  325 		integer,	// consequence variable (false if absent)
  326 		condition)	// consequence condition
  327 
  328      condition = pair(itypeset,
  329 		      list of integer) // variables of condition
  330 
  331      itypeset = integer		// set built from the itype_xxx values
  332 
  333    variables are always identified by their index(number)
  334 
  335    See runtime.h for a description of the constraint template representation.
  336 */
  337 
  338 library inference // type inference
  339 requires system, misc, sequences, graph,
  340   compiler, vars, flow, optimise, ins3
  341 defines mc:infer_types, mc:show_type_info, mc:constant?, mc:itypemap,
  342   itype_none, itype_function, itype_integer, itype_string, itype_vector,
  343   itype_null, itype_symbol, itype_table, itype_pair, itype_other, itype_any
  344 reads mc:verbose
  345 writes tnargs, tncstargs, tnfull, tnpartial
  346 [
  347   | op_types, branch_types, typesets, make_condition0, make_condition1,
  348     make_condition2, instantiate_constraint, build_iconstraint, new_typesets,
  349     generate_constraints, evaluate_condition, apply_iconstraint, typeset_eq?,
  350     typeset_union!, extract_types, show_typesets, showset, show_constraints,
  351     show_constraint, show_c, show_condition |
  352 
  353   itype_none = 0;		// no type
  354 
  355   itype_function = 1;
  356   itype_integer = 2;
  357   itype_string = 4;
  358   itype_vector = 8;
  359   itype_null = 16;
  360   itype_symbol = 32;
  361   itype_table = 64;
  362   itype_pair = 128;
  363   itype_other = 256;
  364 
  365   itype_any = 511;		// "any" type
  366 
  367   op_types = // indexed by mc:b_xxx
  368     '[("xx.n") // or
  369       ("xx.n") // and
  370       ()
  371       ()
  372       ("xx.n") // ==
  373       ("xx.n") // !=
  374       ("nn.n") // <
  375       ("nn.n") // <=
  376       ("nn.n") // >
  377       ("nn.n") // >=
  378       ("nn.n") // |
  379       ("nn.n") // ^
  380       ("nn.n") // &
  381       ("nn.n") // <<
  382       ("nn.n") // >>
  383       ("nn.n" "ss.s") // +
  384       ("nn.n") // -
  385       ("nn.n") // *
  386       ("nn.n") // /
  387       ("nn.n") // %
  388       ("n.n") // -
  389       ("x.n") // not
  390       ("n.n") // ~
  391       ()
  392       ()
  393       ()
  394       ()
  395       ("vn.x" "sn.x" "ts.x" "os.x" "ns.x") // ref
  396       ()
  397       ("xx.k") // .
  398       ("x.1") // =
  399       ("k.x") // car
  400       ("k.x") // cdr
  401       ("s.n") // string_length
  402       ("v.n") // vector_length
  403       ("nn.n") // integer addition
  404     ];
  405 
  406   branch_types = // indexed by mc:branch_xxx
  407     '[() // never
  408       () // always
  409       () // true
  410       () // false
  411       () // or
  412       () // nor
  413       () // and
  414       () // nand
  415       () // ==
  416       () // !=
  417       ("nn") // <
  418       ("nn") // >=
  419       ("nn") // <=
  420       ("nn") // >
  421      ];
  422 
  423   typesets = make_vector(128); // index from character to typeset
  424   vector_fill!(typesets, itype_any); // play safe...
  425   typesets[?f] = itype_function;
  426   typesets[?n] = itype_integer;
  427   typesets[?s] = itype_string;
  428   typesets[?v] = itype_vector;
  429   typesets[?l] = itype_pair | itype_null;
  430   typesets[?k] = itype_pair;
  431   typesets[?t] = itype_table;
  432   typesets[?y] = itype_symbol;
  433   typesets[?x] = itype_any;
  434   typesets[?o] = itype_other;
  435   typesets[?S] = itype_string | itype_integer;
  436   protect(typesets);
  437 
  438   mc:itypemap = sequence // map from type_xxx/stype_xxx -> itype typesets
  439     (itype_other,
  440      itype_function,
  441      itype_other,
  442      itype_other,
  443      itype_function,
  444      itype_function,
  445      itype_function,
  446      itype_integer,
  447      itype_string,
  448      itype_vector,
  449      itype_pair,
  450      itype_symbol,
  451      itype_table,
  452      itype_other,
  453      itype_other,
  454      itype_other,
  455      itype_other,
  456      itype_other,
  457      itype_other,
  458      itype_null,
  459      itype_none,
  460      itype_any,
  461      itype_function,
  462      itype_pair | itype_null);
  463   
  464   // traps are handled explicitly (only trap_type is of interest and
  465   // it is special)
  466 
  467   mc:constant? = fn (v)
  468     // Types: v: var
  469     // Returns: false if v is not a constant
  470     //   an appropriate itype_xxx otherwise
  471     [
  472       | vclass |
  473 
  474       vclass = v[mc:v_class];
  475       if (vclass == mc:v_constant)
  476 	mc:itypemap[typeof(v[mc:v_kvalue])]
  477       else if (vclass == mc:v_global_constant) 
  478 	mc:itypemap[typeof(global_value(v[mc:v_goffset]))]
  479       else
  480 	false
  481     ];
  482 
  483   make_condition0 = fn (constant) // makes "constant" condition
  484     constant . null;
  485 
  486   make_condition1 = fn (constant, v) // makes condition v /\ constant
  487     [
  488       | type |
  489 
  490       if (type = mc:constant?(v)) constant & type . null
  491       else constant . v[mc:v_number] . null
  492     ];
  493 
  494   make_condition2 = fn (constant, v1, v2) // makes condition v1 /\ v2 /\ constant
  495     [
  496       | type, vars |
  497 
  498       if (type = mc:constant?(v1))
  499 	constant = constant & type
  500       else vars = v1[mc:v_number] . vars;
  501 
  502       if (type = mc:constant?(v2))
  503 	constant = constant & type
  504       else vars = v2[mc:v_number] . vars;
  505 
  506       constant . vars
  507     ];
  508 
  509   instantiate_constraint = fn (template, args, dest)
  510     // Types: template: type signature (string)
  511     //        args: list of var
  512     //	      dest: var (or false)
  513     // Requires: llength(args) = #arguments in template
  514     // Returns: the constraint produced by instantiating template with
  515     //   args and dest (if not false)
  516     // TBD: Prune constraints which contain a condition with itype_none.
  517     [
  518       | dvar, consequence, conditions, nargs, type, sargs, i |
  519 
  520       // Build conditions of constraint
  521       nargs = llength(args);
  522       i = 0;
  523       sargs = args;
  524       while (i < nargs)
  525 	[
  526 	  | arg, tsets |
  527 
  528 	  arg = car(sargs);
  529 	  type = template[i];
  530 
  531 	  if (type >= ?1 && type <= ?9)
  532 	    [
  533 	      | ref, nref, cond |
  534 
  535 	      ref = nth(type - ?0, args);
  536 	      nref = ref[mc:v_number];
  537 
  538 	      // if ref is already in some condition, just add arg there
  539 	      if (cond = lexists?(fn (c) memq(nref, cdr(c)), conditions))
  540 		set_cdr!(cond, ref . cdr(cond))
  541 	      else
  542 		conditions = make_condition2(itype_any, ref, arg) . conditions
  543 	    ]
  544 	  else //if ((tsets = typesets[type]) != itype_any)
  545 	    conditions = make_condition1(typesets[type], arg) . conditions;
  546 
  547 	  i = i + 1;
  548 	  sargs = cdr(sargs);
  549 	];
  550 
  551       // Build consequence
  552       if (dest)
  553 	[
  554 	  | l |
  555 
  556 	  dvar = dest[mc:v_number];
  557 
  558 	  l = string_length(template);
  559 	  if ((type = template[l - 1]) == ?.)
  560 	    // destination is undefined, ie type_none
  561 	    consequence = make_condition0(itype_none)
  562 	  else if (type >= ?1 && type <= ?9)
  563 	    [
  564 	      | ref, nref, cond |
  565 
  566 	      ref = nth(type - ?0, args);
  567 	      nref = ref[mc:v_number];
  568 
  569 	      // if ref is already in some condition, use same condition
  570 	      if (cond = lexists?(fn (c) memq(nref, cdr(c)), conditions))
  571 		consequence = cond
  572 	      else
  573 		consequence = make_condition1(itype_any, ref);
  574 	    ]
  575 	  else 
  576 	    consequence = make_condition0(typesets[type]);
  577 	]
  578       else
  579         dvar = false;
  580 
  581       // Finally assemble constraint
  582       sequence(conditions, dvar, consequence)
  583     ];
  584 
  585   build_iconstraint = fn (il, cl)
  586     // Returns: A constraints list for instruction il, given its
  587     //   constraint list (extracts all vars referred to)
  588     [
  589       | vars, addvar, scl |
  590 
  591       addvar = fn (v) if (!memq(v, vars)) vars = v . vars;
  592 
  593       scl = cl;
  594       while (scl != null)
  595 	[
  596 	  | ovars, c |
  597 
  598 	  c = car(scl);
  599 	  ovars = vars;
  600 	  lforeach(fn (cond) lforeach(addvar, cdr(cond)), c[0]);
  601 	  if (c[1])
  602 	    [
  603 	      addvar(c[1]);	// add dest
  604 	      // but not its condition (cf semantics)
  605 	    ];
  606 	  
  607 	  /* Semantics: unused variables in conditions are unaffected.
  608 	     Instead of coding this implicitly, add `u /\ any' conditions
  609 	     for  such variables.
  610 	     The variables between vars & ovars were not present in 
  611 	     constraints prior to c. Add the pseudo-conditions to them. */
  612 /*
  613 	  if (scl != cl && ovars != vars)
  614 	    [
  615 	      | searly, early, add, svars |
  616 
  617 	      svars = vars;
  618 	      while (svars != ovars)
  619 		[
  620 		  add = itype_any . car(svars) . null;
  621 		  svars = cdr(svars);
  622 		];
  623 	      searly = cl;
  624 	      while (searly != scl)
  625 		[
  626 		  early = car(searly);
  627 		  early[0] = lappend(add, early[0]);
  628 		  searly = cdr(searly);
  629 		];
  630 	    ];
  631 */
  632 	  scl = cdr(scl);
  633 	];
  634       
  635       sequence(il, vars, cl)
  636     ];
  637   
  638   generate_constraints = fn (il, ambiguous, constraints)
  639     // Types: il: instruction
  640     // Returns: (constraints for instruction il) . constraints
  641     [
  642       | ins, class, new, args, dest, op |
  643 
  644       ins = il[mc:il_ins];
  645       class = ins[mc:i_class];
  646       if (class == mc:i_compute)
  647 	[
  648 	  args = ins[mc:i_aargs];
  649 	  dest = ins[mc:i_adest];
  650 	  new = lmap(fn (sig) instantiate_constraint(sig, args, dest),
  651 		     op_types[ins[mc:i_aop]]);
  652 	]
  653       else if (class == mc:i_branch)
  654 	[
  655 	  args = ins[mc:i_bargs];
  656 	  op = ins[mc:i_bop];
  657 	  if (op < vector_length(branch_types))
  658 	    new = lmap(fn (sig) instantiate_constraint(sig, args, false),
  659 		       branch_types[op]);
  660 	]
  661       else if (class == mc:i_call)
  662 	[
  663 	  | escapes, f, prim, ndest |
  664 
  665 	  dest = ins[mc:i_cdest];
  666 	  ndest = dest[mc:v_number];
  667 	  args = ins[mc:i_cargs];
  668 	  f = car(args); args = cdr(args);
  669 	  escapes = true;
  670 
  671 	  // Call to known function ?
  672 	  if (f[mc:v_class] == mc:v_global_constant &&
  673 	      primitive?(prim = global_value(f[mc:v_goffset])) &&
  674 	      primitive_nargs(prim) == llength(args))
  675 	    [
  676 	      | types |
  677 
  678 	      if ((types = primitive_type(prim)) != null)
  679 		new = lmap(fn (sig) instantiate_constraint(sig, args, dest), types);
  680 	      if (primitive_flags(prim) & OP_NOESCAPE) escapes = FALSE;
  681 	    ]
  682 	  else
  683 	    [
  684 	      // destination is any
  685 	      new = sequence(null, ndest, make_condition0(itype_any)) . null;
  686 	    ];
  687 
  688 	  if (escapes) // note global side effects
  689 	    bforeach
  690 	      (fn (i) if (i != ndest)
  691 	         new = sequence(null, i, make_condition0(itype_any)) . new,
  692 	       ambiguous);
  693 	]
  694       else if (class == mc:i_trap)
  695 	[
  696 	  if (ins[mc:i_top] == mc:trap_type)
  697 	    [
  698 	      args = ins[mc:i_targs];
  699 	      dest = car(args)[mc:v_number];
  700 	      new = sequence (null, dest,
  701 			      make_condition0(mc:itypemap[mc:var_value(cadr(args))]))
  702 	        . null;
  703 	    ]
  704 	]
  705       else if (class == mc:i_closure)
  706 	[
  707 	  dest = ins[mc:i_fdest][mc:v_number];
  708 	  new = sequence(null, dest, make_condition0(itype_function)) . null;
  709 	];
  710 
  711       if (new != null) build_iconstraint(il, new) . constraints
  712       else constraints
  713     ];
  714 
  715   evaluate_condition = fn (condition, typeset)
  716     // Types: condition: condition
  717     //        typeset: vector of typesets
  718     // Returns: Result of condition given types in typeset
  719     [
  720       | x |
  721 
  722       x = car(condition);
  723       condition = cdr(condition);
  724       while (condition != null)
  725 	[
  726 	  x = x & typeset[car(condition)];
  727 	  condition = cdr(condition);
  728 	];
  729       x
  730     ];
  731 
  732   apply_iconstraint = fn (iconstraint, typeset)
  733     // Types: iconstraint: instruction_constraint
  734     //        typeset: vector of itypeset
  735     // Returns: The typeset resulting from the application of constraint
  736     //   to typeset
  737     [
  738       | new, apply_constraint |
  739 
  740       // clear modified vars
  741       new = vcopy(typeset);
  742       lforeach(fn (v) new[v] = itype_none, iconstraint[1]);
  743       
  744       apply_constraint = fn (c)
  745 	[
  746 	  | results, conditions |
  747 	  
  748 	  //display(format("applying %s\n", c));
  749 	  conditions = c[0];
  750 	  while (conditions != null)
  751 	    [
  752 	      | x |
  753 	      
  754 	      x = evaluate_condition(car(conditions), typeset);
  755 	      if (x == itype_none) exit<function> 0; // constraint failed
  756 	      results = x . results;
  757 	      conditions = cdr(conditions);
  758 	    ];
  759 	  //display(format("success %s\n", results));
  760 	  
  761 	  // condition successful, modify new typesets
  762 	  // first, destination:
  763 	  if (c[1])
  764 	    new[c[1]] = new[c[1]] | evaluate_condition(c[2], typeset);
  765 	  
  766 	  // then all concerned variables
  767 	  conditions = lreverse(c[0]); // same order as results
  768 	  while (conditions != null)
  769 	    [
  770 	      | x |
  771 
  772 	      x = car(results);
  773 	      lforeach(fn (arg) new[arg] = new[arg] | x, cdar(conditions));
  774 	      conditions = cdr(conditions);
  775 	      results = cdr(results);
  776 	    ];
  777 	];
  778 
  779       lforeach(apply_constraint, iconstraint[2]);
  780       new
  781     ];
  782 
  783   new_typesets = fn (ifn)
  784     // Returns: A new sequence of typesets initialised to itype_none
  785     [
  786       | v |
  787 
  788       vector_fill!(v = make_vector(ifn[mc:c_fnvars]), itype_none);
  789       v
  790     ];
  791 
  792   typeset_eq? = fn (ts1, ts2)
  793     // Returns: True if all the typesets in ts1 are equal to those in ts2
  794     [
  795       | l |
  796 
  797       l = vector_length(ts1);
  798       while ((l = l - 1) >= 0)
  799 	if (ts1[l] != ts2[l]) exit<function> false;
  800       
  801       true
  802     ];
  803 
  804   typeset_union! = fn (ts1, ts2)
  805     // Effects: ts1 = ts1 U ts2 (per variable)
  806     // Modifies: ts1
  807     [
  808       | l |
  809 
  810       l = vector_length(ts1);
  811       while ((l = l - 1) >= 0) ts1[l] = ts1[l] | ts2[l];
  812     ];
  813 
  814   extract_types = fn (ifn)
  815     // Types: ifn: intermediate function
  816     // Modifies: ifn
  817     // Effects: Sets the type fields of ifn's instructions
  818     [
  819       | fg, nargs, ncstargs, npartial, nfull, compute_types |
  820 
  821       fg = ifn[mc:c_fvalue];
  822       nargs = ncstargs = npartial = nfull = 0;
  823 
  824       compute_types = fn (il, types)
  825 	[
  826 	  | ins, class, vtype, qvtype, iconstraint, typeset |
  827 
  828 	  ins = il[mc:il_ins];
  829 	  class = ins[mc:i_class];
  830 	  typeset = car(types);
  831 
  832 	  vtype = fn (v)
  833 	    [
  834 	      | type |
  835 
  836 	      nargs = nargs + 1;
  837 	      if (type = mc:constant?(v))
  838 		[
  839 		  ncstargs = ncstargs + 1;
  840 		  type
  841 		]
  842 	      else
  843 		[
  844 		  type = typeset[v[mc:v_number]];
  845 		  assert(v[mc:v_number] != 0);
  846 		  if (memq(type, '(1 2 4 8 16 32 64 128 256)))
  847 		    nfull = nfull + 1
  848 		  else if (type != itype_any)
  849 		    npartial = npartial + 1;
  850 
  851 		  type
  852 		]
  853 	    ];
  854 
  855 	  qvtype = fn (v)
  856 	    [
  857 	      | type |
  858 
  859 	      if (type = mc:constant?(v)) type
  860 	      else typeset[v[mc:v_number]]
  861 	    ];
  862 
  863 	  if (class == mc:i_compute)
  864 	    if (ins[mc:i_aop] != mc:b_assign)
  865 	      ins[mc:i_atypes] = lmap(vtype, ins[mc:i_aargs])
  866 	  else if (class == mc:i_branch)
  867 	    if (ins[mc:i_bop] >= mc:branch_lt)
  868 	      ins[mc:i_btypes] = lmap(vtype, ins[mc:i_bargs])
  869 	    else 0
  870 	  else if (class == mc:i_trap && ins[mc:i_top] == mc:trap_type)
  871 	    ins[mc:i_ttypes] = lmap(vtype, ins[mc:i_targs]);
  872 
  873 	  if (cdr(types) != null && (iconstraint = cadr(types))[0] == il)
  874 	    // this instruction has a constraint
  875 	    apply_iconstraint(iconstraint, typeset) . cddr(types)
  876 	  else
  877 	    types
  878 	];
  879 
  880       graph_nodes_apply
  881         (fn (n)
  882 	 [
  883 	   | block, types |
  884 
  885 	   block = graph_node_get(n);
  886 	   types = block[mc:f_types];
  887 	   dreduce(compute_types, types[mc:flow_in] . types[mc:flow_gen],
  888 		   block[mc:f_ilist]);
  889 	 ], cdr(fg));
  890 
  891       if (mc:verbose >= 3)
  892 	[
  893 	  display("Type inference results:"); newline();
  894 	  display(format("%s args, of which %s constant, %s fully inferred, %s partially.", nargs, ncstargs, nfull, npartial));
  895 	  newline();
  896 	];
  897       tnargs = tnargs + nargs;
  898       tncstargs = tncstargs + ncstargs;
  899       tnfull = tnfull + nfull;
  900       tnpartial = tnpartial + npartial;
  901     ];
  902 
  903   mc:infer_types = fn (ifn)
  904     // Types: ifn: intermediate function
  905     // Modifies: ifn
  906     // Effects: infers types for the variables of ifn
  907     [
  908       | fg, entry, nvars, change, globals, icount, merge_block |
  909 
  910       if (mc:verbose >= 3)
  911 	[
  912 	  display(format("Inferring %s", mc:fname(ifn)));
  913 	  newline();
  914 	];
  915       mc:recompute_vars(ifn, true);
  916       mc:flow_ambiguous(ifn);
  917 
  918       fg = ifn[mc:c_fvalue];
  919       nvars = ifn[mc:c_fnvars];
  920       // Defined globals do not change across functin calls
  921       globals = mc:set_vars!(mc:new_varset(ifn), ifn[mc:c_fclosure]);
  922       mc:set_vars!(globals, lfilter(fn (v) v[mc:v_class] != mc:v_global_define,
  923 				    ifn[mc:c_fglobals]));
  924 
  925       graph_nodes_apply
  926 	(fn (n)
  927 	 [
  928 	   | block |
  929 
  930 	   block = graph_node_get(n);
  931 	   block[mc:f_types] = vector
  932 	     (lreverse!(mc:scan_ambiguous(generate_constraints, null,
  933 					  block, globals)),
  934 	      null, // kill is unused (complex gen)
  935 	      new_typesets(ifn),
  936 	      new_typesets(ifn)); // no map
  937 	 ], cdr(fg));
  938 
  939       // solve data-flow problem
  940 
  941       // init entry node:
  942       entry = graph_node_get(car(fg));
  943       lforeach(fn (arg) entry[mc:f_types][mc:flow_in][arg[mc:v_number]] = itype_any,
  944 	       ifn[mc:c_fargs]);
  945       lforeach(fn (arg) entry[mc:f_types][mc:flow_in][arg[mc:v_number]] = itype_any,
  946 	       ifn[mc:c_fglobals]);
  947       lforeach(fn (arg) entry[mc:f_types][mc:flow_in][arg[mc:v_number]] = itype_any,
  948 	       ifn[mc:c_fclosure]);
  949 
  950       // iterate till solution found
  951 
  952       merge_block = fn (n)
  953 	[
  954 	  | node, types, new_in, new_out |
  955 
  956 	  node = graph_node_get(n);
  957 	  types = node[mc:f_types];
  958 
  959 	  // compute in as 'union' of out's of predecessors
  960 	  new_in = types[mc:flow_in];
  961 	  graph_edges_in_apply(fn (predecessor) typeset_union!(new_in, graph_node_get(graph_edge_from(predecessor))[mc:f_types][mc:flow_out]), n);
  962 	  types[mc:flow_in] = new_in;
  963 
  964 	  // compute new out
  965 	  //display("APPLY"); newline();
  966 	  //show_constraints(types[mc:flow_gen]);
  967 	  //display("TO "); show_typesets(new_in); newline();
  968 	  if (types[mc:flow_gen] == null) new_out = vcopy(new_in)
  969 	  else new_out = lreduce(apply_iconstraint, new_in, types[mc:flow_gen]);
  970 	  //display("-> "); show_typesets(new_out); newline();
  971 	  assert(new_out != types[mc:flow_out]);
  972 	  if (!typeset_eq?(new_out, types[mc:flow_out]))
  973 	    [
  974 	      types[mc:flow_out] = new_out;
  975 	      change = true
  976 	    ]
  977 	];
  978 
  979       icount = 0;
  980       loop
  981 	[
  982 	  change = false;
  983 	  //display(format("*ITERATION %s*", icount + 1)); newline();
  984 	  graph_nodes_apply(merge_block, cdr(fg));
  985 	  icount = icount + 1;
  986 	  if (!change) exit 0;
  987 	];
  988       if (mc:verbose >= 3)
  989 	[
  990 	  display(format("Type inference iterations %s", icount));
  991 	  newline();
  992 	];
  993 
  994       extract_types(ifn);
  995 
  996       mc:clear_dataflow(ifn);
  997     ];
  998 
  999   mc:show_type_info = fn (types)
 1000     if (types)
 1001       [
 1002 	display("Types:\n");
 1003 	show_constraints(types[mc:flow_gen]);
 1004 	display("in:"); show_typesets(types[mc:flow_in]); newline();
 1005 	display("out:"); show_typesets(types[mc:flow_out]); newline();
 1006       ];
 1007 
 1008   show_typesets = fn (typeset)
 1009     for(1, vector_length(typeset) - 1,
 1010 	fn (v) display(format(" %s(%s)", v, showset(typeset[v]))));
 1011 
 1012   showset = fn (tset)
 1013     if (tset == itype_none) "none"
 1014     else if (tset == itype_any) "any"
 1015     else
 1016       [
 1017 	| s |
 1018 
 1019 	s = "";
 1020 
 1021 	if (tset & itype_function) s = s + "f";
 1022 	if (tset & itype_integer) s = s + "n";
 1023 	if (tset & itype_string) s = s + "s";
 1024 	if (tset & itype_vector) s = s + "v";
 1025 	if (tset & itype_null) s = s + "0";
 1026 	if (tset & itype_symbol) s = s + "y";
 1027 	if (tset & itype_table) s = s + "t";
 1028 	if (tset & itype_pair) s = s + "k";
 1029 	if (tset & itype_other) s = s + "o";
 1030 
 1031 	s
 1032       ];
 1033 
 1034   show_constraints = fn (constraints)
 1035     [
 1036       | i |
 1037 
 1038       i = 0;
 1039       while (constraints != null)
 1040 	[
 1041 	  display(format("constraint %s\n", i));
 1042 	  show_constraint(car(constraints));
 1043 	  i = i + 1;
 1044 	  constraints = cdr(constraints);
 1045 	];
 1046     ];
 1047 
 1048   show_constraint = fn (constraint)
 1049     [
 1050       display(format("  vars: %s", concat_words(lmap(itoa, constraint[1]), " ")));
 1051       newline();
 1052       lforeach(show_c, constraint[2]);
 1053     ];
 1054 
 1055   show_c = fn (c)
 1056     [
 1057       display(format("  %s", concat_words(lmap(show_condition, c[0]), " & ")));
 1058       if (c[1])
 1059 	display(format(" => %s contains %s", c[1], show_condition(c[2])));
 1060       newline();
 1061     ];
 1062 
 1063   show_condition = fn (cond)
 1064     [
 1065       | s |
 1066 
 1067       s = showset(car(cond));
 1068       lforeach(fn (v) s = s + format(" /\\ %s", v), cdr(cond));
 1069       s
 1070     ];
 1071 ];