PreviousUpNext

15.4.354  src/lib/compiler/back/low/regor/iterated-register-coalescing.pkg

## iterated-register-coalescing.pkg

# Compiled by:
#     src/lib/compiler/back/low/lib/lowhalf.lib

# Based on the paper:
#            Iterated register coalescing
#            Lal George, Andrew W. Appel
#            TOPLAS 1996
#            Volume 18 Issue 3, May 1996
#            http://www.cs.cmu.edu/afs/cs/academic/class/15745-s07/www/papers/george.pdf
#
#
# Overview
# ========
# This implementation of iterated coalescing differs from the old one in
# various substantial ways:
#
# 1. The move list is prioritized.  Higher ranking moves are coalesced first.
#    This tends to favor coalescing of moves that has higher priority.
#
# 2. The freeze list is prioritized.  Lower ranking nodes are unfrozen
#    first.  Since freeze disable moves, this tends to disable moves
#    of low priority.
#
# 3. The simplify worklist is not kept explicitly during the 
#    simplify/coalesce/freeze phases.  Instead, whenever a non-move
#    related node with degree < K is discovered, we call simplify
#    to remove it from the graph immediately.  
#
#    I think this has a few advantages.
#    (a) There is less bookkeeping.
#    (b) Simplify adds coalescable moves to the move list.
#        By doing simplify eagerly, moves are added to the move list
#        faster, allowing higher ranking moves to ``preempt'' low
#        ranking moves.
#
# 4. Support for register pairs
#
# Important Invariants
# ====================
#   1. Adjacency list
#      a. All nodes on the adjacency list are distinct
#      b. nodes with color ALIASED or REMOVED are NOT consider to be
#         on the adjacency list
#      c. If a node x is cig::COLORED, then we DON'T keep track of 
#         its adjacency list 
#      d. When a node has been removed, there aren't any moves associated
#         with it.    
#   2. Moves
#      a. Moves marked cig::WORKLIST are on the worklist.
#      b. Moves marked MOVE are NOT on the worklist.
#      c. Moves marked LOST are frozen and are in fact never considered again.
#      d. Moves marked CONSTRAINED cannot be coalesced because the src and dst
#         interfere
#      e. Moves marked COALESCED have been coalesced.  
#      f. The movecnt in a node is always the number of nodes 
#         currently marked as cig::WORKLIST or MOVE, i.e. the moves that
#         are associated with the node.  When this is zero, the node is
#         considered to be non-move related.
#      g. Moves on the move worklist are always distinct.
#   3.
#
# Allen.


###           "If you want to build a ship,
###            don't drum up people together
###            to collect wood and don't assign
###            them tasks and work, but rather
###            teach them to long for the endless
###            immensity of the sea."
###
###                -- Antoine de Saint-Exupery


stipulate
    package f8b =  eight_byte_float;                                            # eight_byte_float                      is from   src/lib/std/eight-byte-float.pkg
    package fil =  file__premicrothread;                                        # file__premicrothread                  is from   src/lib/std/src/posix/file--premicrothread.pkg
    package geh =  graph_by_edge_hashtable;                                     # graph_by_edge_hashtable               is from   src/lib/std/src/graph-by-edge-hashtable.pkg
    package iht =  int_hashtable;                                               # int_hashtable                         is from   src/lib/src/int-hashtable.pkg
    package lem =  lowhalf_error_message;                                       # lowhalf_error_message                 is from   src/lib/compiler/back/low/control/lowhalf-error-message.pkg
    package lhc =  lowhalf_control;                                             # lowhalf_control                       is from   src/lib/compiler/back/low/control/lowhalf-control.pkg
    package lms =  list_mergesort;                                              # list_mergesort                        is from   src/lib/src/list-mergesort.pkg
    package rkj =  registerkinds_junk;                                          # registerkinds_junk                    is from   src/lib/compiler/back/low/code/registerkinds-junk.pkg
    package rwv =  rw_vector;                                                   # rw_vector                             is from   src/lib/std/src/rw-vector.pkg
    package w   =  unt;                                                         # unt                                   is from   src/lib/std/unt.pkg
    package w8  =  one_byte_unt;                                                # one_byte_unt                          is from   src/lib/std/one-byte-unt.pkg

    # For debugging, uncomment unsafe. 
    #
    package uwv = unsafe::rw_vector; 
    package uw8a= unsafe::rw_vector_of_one_byte_unts;                           # unsafe                                is from   src/lib/std/src/unsafe/unsafe.pkg
herein

    # This package gets referenced in:
    #
    #     src/lib/compiler/back/low/regor/register-spilling-g.pkg
    #     src/lib/compiler/back/low/regor/register-spilling-with-renaming-g.pkg
    #     src/lib/compiler/back/low/regor/register-spilling-per-chaitin-heuristic.pkg
    #     src/lib/compiler/back/low/regor/register-spilling-per-chow-hennessy-heuristic.pkg
    #     src/lib/compiler/back/low/regor/register-spilling-per-improved-chaitin-heuristic-g.pkg
    #     src/lib/compiler/back/low/regor/register-spilling-per-improved-chow-hennessy-heuristic-g.pkg
    #     src/lib/compiler/back/low/regor/register-spilling-per-improved-chow-hennessy-heuristic-g.pkg
    #
    #     src/lib/compiler/back/low/regor/cluster-regor-g.pkg
    #     src/lib/compiler/back/low/regor/solve-register-allocation-problems-by-recursive-partition-g.pkg
    #     src/lib/compiler/back/low/regor/solve-register-allocation-problems-by-iterated-coalescing-g.pkg
    #     src/lib/compiler/back/low/regor/regor-ram-merging-g.pkg
    #     src/lib/compiler/back/low/regor/regor-deadcode-zapper-g.pkg
    #
    #     src/lib/compiler/back/low/main/pwrpc32/backend-lowhalf-pwrpc32.pkg
    #     src/lib/compiler/back/low/main/sparc32/backend-lowhalf-sparc32.pkg
    #
    package   iterated_register_coalescing
    : (weak)  Iterated_Register_Coalescing                                      # Iterated_Register_Coalescing          is from   src/lib/compiler/back/low/regor/iterated-register-coalescing.api
    {
        # Export to client packages:
        #
        package cig =  codetemp_interference_graph;                             # codetemp_interference_graph           is from   src/lib/compiler/back/low/regor/codetemp-interference-graph.pkg

        #
        debug = FALSE;
        tally = FALSE; 

        verbose       = lhc::make_bool ("verbose", "Register-allocator chattiness");

        ra_spill_coalescing
            =
            lhc::make_counter (
                "ra_spill_coalescing",
                "RA spill coalescing counter"
            );

        ra_spill_propagation
            =
            lhc::make_counter (
                "ra_spill_propagation",
                "RA spill propagation counter"
            );

      /*
        good_briggs   = LowhalfControl::getCounter "good_briggs"
        bad_briggs    = LowhalfControl::getCounter "bad_briggs"
        good_george   = LowhalfControl::getCounter "good_george"
        bad_george    = LowhalfControl::getCounter "bad_george"
        good_freeze   = LowhalfControl::getCounter "good_freeze"
        bad_freeze    = LowhalfControl::getCounter "bad_freeze"
       */

        no_optimization     = 0ux0;
        biased_selection    = 0ux1;
        dead_copy_elim      = 0ux2;
        compute_span        = 0ux4;
        save_copy_temps     = 0ux8; 
        has_parallel_copies = 0ux10;
        spill_coalescing    = 0ux100;
        spill_coloring      = 0ux200;
        spill_propagation   = 0ux400;

        memory_coalescing
            = 
            spill_coalescing + spill_coloring + spill_propagation;


        stipulate
            fun is_on (flag, mask)
                =
                unt::bitwise_and (flag, mask) != 0u0;

            fun error msg
                =
                lem::error("iterated_register_coalescing", msg);

            fun cat ([],    b) =>  b;
                cat (x ! a, b) =>  cat (a, x ! b);
            end;
        herein

            package fz
                =
                regor_leftist_tree_priority_queue_g (                   # regor_leftist_tree_priority_queue_g           is from   src/lib/compiler/back/low/regor/regor-leftist-tree-priority-queue-g.pkg

                    Element = cig::Node; 

                    fun less ( cig::NODE { movecost=>REF p1, ... },
                               cig::NODE { movecost=>REF p2, ... }
                             )
                        =
                        p1 <= p2;
                );

            package mv
                =
                regor_leftist_tree_priority_queue_g (                   # regor_leftist_tree_priority_queue_g           is from   src/lib/compiler/back/low/regor/regor-leftist-tree-priority-queue-g.pkg

                    Element = cig::Move; 

                    fun less ( cig::MOVE_INT { cost=>p1, ... },
                               cig::MOVE_INT { cost=>p2, ... }
                             )
                        =
                        p1 >= p2;
                );

            Move_Queue   =  mv::Priority_Queue;
            Freeze_Queue =  fz::Priority_Queue;



            # Utility functions
            #
            fun chase (cig::NODE { color=>REF (cig::ALIASED r), ... } )
                    =>
                    chase r;

                chase x => x;
            end;

            fun register_id (rkj::CODETEMP_INFO { id, ... } ) = id;

            fun col2s col
                =
                case col
                    #                  
                    cig::CODETEMP         =>  "";
                    cig::REMOVED        =>  "r";
                    cig::ALIASED _      =>  "a";
                    cig::COLORED c      =>  "[" + int::to_string c + "]";
                    cig::RAMREG (_, m)  =>  "m" + "{ " + rkj::register_to_string m + "}";
                    cig::SPILLED        =>  "s";
                    cig::SPILL_LOC c    =>  "s" + "{ " + int::to_string c + "}";
                esac;

            fun node2s (cig::NODE { register, color, ... } )
                =
                int::to_string (register_id register) + col2s *color;

            fun show _ (node as cig::NODE { priority, ... } )
                = 
                node2s node + if *verbose   "(" + f8b::to_string *priority + ")";
                              else          "";
                              fi;


            # Dump the interference graph
            #
            fun dump_codetemp_interference_graph (cig as cig::CODETEMP_INTERFERENCE_GRAPH { node_hashtable, show_reg, hardware_registers_we_may_use, ... } ) stream
                =
                {   fun pr s =   fil::write (stream, s);
                    #   
                    show = show cig;

                    fun pr_move (cig::MOVE_INT { src_reg, dst_reg, status=>REF (cig::WORKLIST | cig::BRIGGS_MOVE | cig::GEORGE_MOVE), cost, ... } )
                            => 
                            pr (node2s (chase dst_reg) + " <- " + node2s (chase src_reg) + "(" + f8b::to_string (cost) + ") ");

                        pr_move _ => ();
                    end;

                    fun pr_interferes_with (n, n' as cig::NODE { interferes_with, degree, uses, defs, color, movecnt, movelist, ... } )
                        =
                        {   pr (show n');

                            if *verbose   pr(" deg=" + int::to_string *degree);   fi;

                            case *color
                                #                              
                                cig::ALIASED n
                                    =>
                                    {   pr " => ";
                                        pr (show n);
                                        pr "\n";
                                    };

                                _   =>
                                    {   pr(" <-->");

                                        apply
                                            (fn n = { pr " "; pr (show n);})
                                            *interferes_with;

                                        pr "\n";

                                        if (*verbose and *movecnt > 0)
                                            #
                                            pr("\tmoves " + int::to_string *movecnt + ": ");
                                            apply  pr_move  *movelist;
                                            pr "\n";
                                        fi;
                                    };
                            esac;
                       };

                    pr("=========== hardware_registers_we_may_use=" + int::to_string hardware_registers_we_may_use + " ===========\n");

                    apply
                        pr_interferes_with
                        #
                        (lms::sort_list
                            #
                            (fn ((x, _), (y, _)) = x > y)
                            #
                            (iht::keyvals_list  node_hashtable)
                        );
                };



            # Function to create new nodes.
            # Note: it is up to the caller to remove all
            # globally allocated registers (such as esp and edi on intel32):
            #
            fun new_nodes (cig::CODETEMP_INTERFERENCE_GRAPH { node_hashtable, codetemp_id_if_above,  ... } )
                =
                def_use
                where

                    getnode =  iht::get  node_hashtable;
                    addnode =  iht::set  node_hashtable;

                    fun color_of (rkj::CODETEMP_INFO { color => REF (rkj::MACHINE r), ... } )
                            =>
                            r;

                        color_of (rkj::CODETEMP_INFO { id, ... } )
                            =>
                            id;
                    end;

                    fun get_node (register as rkj::CODETEMP_INFO { color, ... } )
                        = 
                        (getnode (color_of register))
                        except
                            _ = {   reg = color_of register;

                                    color =   case *color 
                                                  #
                                                  rkj::MACHINE r =>  cig::COLORED r;
                                                  rkj::CODETEMP  =>  cig::CODETEMP;
                                                  rkj::ALIASED _ =>  error "get_node: cig::ALIASED";
                                                  rkj::SPILLED   =>  error "get_node: cig::SPILLED";
                                              esac;

                                    node =  cig::NODE
                                              { id              => reg,
                                                register,
                                                #
                                                color           =>  REF color,
                                                degree          =>  REF 0,
                                                movecnt         =>  REF 0,
                                                #
                                                movecost        =>  REF 0.0,
                                                priority        =>  REF 0.0,
                                                #
                                                interferes_with =>  REF [],
                                                movelist        =>  REF [],
                                                defs            =>  REF [],
                                                uses            =>  REF []
                                              };

                                    addnode (reg, node);

                                    node;
                                };


                    fun def_use { defs, uses, pt, cost }
                        =
                        {
                            fun def register
                                =
                                {   (get_node  register) ->   node as cig::NODE { priority, defs, ... };

                                    priority  :=  *priority + cost;

                                    defs :=  pt ! *defs;

                                    node;
                                };

                            fun use register
                                =
                                {   (get_node  register) ->   node as cig::NODE { priority, uses, ... };

                                    priority  :=  *priority + cost;
                                    uses :=  pt ! *uses;
                                };

                            list::apply use uses;
                            list::map def defs;     
                      };
                end;


            # Add an edge (x, y) to the interference graph.
            # Nop if the edge already exists.
            # Note: adjacency lists of colored nodes are not stored 
            #       within the interference graph to save space.
            # Now we allow spilled node to be added to the edge; these do not
            # count toward the degree. 
            #
            fun add_edge (cig::CODETEMP_INTERFERENCE_GRAPH { edge_hashtable, ... } )
                = 
                {   insert_edge =  geh::insert_edge  *edge_hashtable;

                    fn (x as cig::NODE { id=>xn, color=>colx, interferes_with=>adjx, degree=>degx, ... }, 
                        y as cig::NODE { id=>yn, color=>coly, interferes_with=>adjy, degree=>degy, ... }
                       )
                        => 
                        if (xn == yn)
                            ();
                        elif (insert_edge (xn, yn) )
                            #
                            case (*colx, *coly)   
                                (cig::CODETEMP,      cig::CODETEMP) => { adjx := y ! *adjx; degx := *degx+1;
                                                           adjy := x ! *adjy; degy := *degy+1;};
                                (cig::CODETEMP,   cig::COLORED _) => { adjx := y ! *adjx; degx := *degx+1;};
                                (cig::CODETEMP,    cig::RAMREG _) => { adjx := y ! *adjx; adjy := x ! *adjy;};
                                (cig::CODETEMP, cig::SPILL_LOC _) => { adjx := y ! *adjx; adjy := x ! *adjy;};
                                (cig::CODETEMP,     cig::SPILLED) => ();
                                (cig::COLORED _,   cig::CODETEMP) => { adjy := x ! *adjy; degy := *degy+1;};
                                (cig::COLORED _, cig::COLORED _) => (); #  x!=y, can't alias 
                                (cig::COLORED _, cig::RAMREG _) => (); #  x!=y, can't alias 
                                (cig::COLORED _, cig::SPILL_LOC _) => (); #  x!=y, can't alias 
                                (cig::COLORED _,   cig::SPILLED) => ();
                                (cig::RAMREG _,    cig::CODETEMP) => { adjx := y ! *adjx; adjy := x ! *adjy;};
                                (cig::RAMREG _, cig::COLORED _) => ();   #  x!=y, can't alias 
                                (cig::RAMREG _,  cig::RAMREG _) => ();   #  x!=y, can't alias 
                                (cig::RAMREG _, cig::SPILL_LOC _) => (); #  x!=y, can't alias 
                                (cig::RAMREG _,   cig::SPILLED) => ();
                                (cig::SPILL_LOC _, cig::CODETEMP) => { adjx := y ! *adjx; adjy := x ! *adjy;};
                                (cig::SPILL_LOC _, cig::COLORED _) => ();     #  x!=y, can't alias 
                                (cig::SPILL_LOC _, cig::RAMREG _) => ();    #  x!=y, can't alias 
                                (cig::SPILL_LOC _, cig::SPILL_LOC _) => (); #  x!=y, can't alias 
                                (cig::SPILL_LOC _, cig::SPILLED) => (); #  x!=y, can't alias 
                                (cig::SPILLED,  _) => ();
                                (colx, coly) => 
                                   error("addEdge x=" + int::to_string xn + col2s colx + " y=" + int::to_string yn + col2s coly);
                            esac;

                         #  edge already there 
                        fi;
                  end;
                };

            fun is_fixed_mem (cig::SPILL_LOC _) =>  TRUE;
                is_fixed_mem (cig::RAMREG _)    =>  TRUE;
                is_fixed_mem (cig::SPILLED)     =>  TRUE;
                is_fixed_mem _             =>  FALSE;
            end;

            fun is_fixed (cig::COLORED _) => TRUE;
                is_fixed c => is_fixed_mem (c);
            end; 


            # Initialize a list of worklists
            #
            fun init_work_lists 
                ( cig::CODETEMP_INTERFERENCE_GRAPH { node_hashtable, hardware_registers_we_may_use, edge_hashtable, pseudo_count, codetemp_id_if_above, dead_copies, mem_moves, mode, ... } )
                { moves }
                =
                { 
                    # Filter moves that already have an interference
                    # Also initialize the movelist and
                    # movecnt fields:
                    #   
                    edge_exists =  geh::edge_exists  *edge_hashtable;

                    fun set_info (cig::NODE { color=>REF cig::CODETEMP, movecost, movecnt, movelist, ... }, 
                                mv, cost)
                             =>
                             { movelist := mv ! *movelist; 
                               movecnt := *movecnt + 1;
                               movecost := *movecost + cost;
                             };

                        set_info _ => ();
                     end;


                    # Filter moves that cannot be coalesced 
                    #
                    fun filter ([], mvs', mem)
                            =>
                            (mvs', mem);

                        filter ( (mv as cig::MOVE_INT { src_reg as cig::NODE { id=>x, color=>REF col_src, ... },
                                                        dst_reg as cig::NODE { id=>y, color=>REF col_dst, ... }, 
                                                        cost,
                                                        ... 
                                                      }
                                 ) ! mvs, 

                                 mvs',
                                 mem
                               )
                            =>
                            if (is_fixed col_src  and  is_fixed col_dst)
                                #
                                filter (mvs, mvs', mem);

                            elif (is_fixed_mem col_src  or  is_fixed_mem col_dst)

                                filter (mvs, mvs', mv ! mem);

                            elif (edge_exists (x, y))

                                filter (mvs, mvs', mem); 

                            else 
                                set_info (src_reg, mv, cost);
                                set_info (dst_reg, mv, cost);
                                filter (mvs, mv::add (mv, mvs'), mem);
                            fi;
                    end;

                    # Like filter but does dead copy elimination:
                    #
                    fun filter_dead ([], mvs', mem, dead)
                            =>
                            (mvs', mem, dead);

                        filter_dead
                            (  (mv as 
                                cig::MOVE_INT
                                  { src_reg as cig::NODE { id=>x, color as REF col_src, priority, interferes_with, uses, ... },
                                    dst_reg as cig::NODE { id=>y, color=>REF col_dst, register=>registery, defs=>dst_defs, uses=>dst_uses, ... },
                                    cost,
                                    ... 
                                 }
                               ) ! mvs, 

                               mvs',
                               mem,
                               dead
                            )
                            =>  
                            if (is_fixed col_src and is_fixed col_dst) 

                              filter_dead (mvs, mvs', mem, dead);

                            elif (is_fixed_mem col_src or is_fixed_mem col_dst )

                              filter_dead (mvs, mvs', mv ! mem, dead);

                            else
                                case (col_src, col_dst, dst_defs, dst_uses)
                                    #
                                    (_, cig::CODETEMP, REF [pt], REF [])
                                        => 
                                        # Eliminate dead copy:
                                        # 
                                        {   fun dec_degree []
                                                    =>
                                                    ();

                                                dec_degree (cig::NODE { color=>REF cig::CODETEMP, degree, ... } ! interferes_with)
                                                    =>
                                                    {   degree := *degree - 1;
                                                        dec_degree interferes_with;
                                                    };
                                                dec_degree(_ ! interferes_with)
                                                    =>
                                                    dec_degree interferes_with;
                                            end;

                                            fun elim_uses ([], _, uses, priority, cost)
                                                    =>
                                                    (uses, priority);

                                                elim_uses (pt ! pts, pt': cig::Program_Point, uses, priority, cost)
                                                    =>
                                                    if (pt == pt')  elim_uses (pts, pt',      uses, priority-cost, cost);
                                                    else            elim_uses (pts, pt', pt ! uses, priority,      cost);
                                                    fi;
                                            end;

                                            my (uses', priority')
                                                =
                                                elim_uses(*uses, pt, [], *priority, cost);

                                            priority :=  priority';
                                            uses     :=  uses';
                                            color    :=  cig::ALIASED  src_reg;

                                            dec_degree *interferes_with;

                                            filter_dead (mvs, mvs', mem, registery ! dead);
                                        };

                                    _   =>
                                        # Normal moves 
                                        #
                                        if (edge_exists (x, y))                         #  moves that interfere 
                                            #
                                            filter_dead (mvs, mvs', mem, dead); 
                                        else
                                            set_info (src_reg, mv, cost);
                                            set_info (dst_reg, mv, cost);
                                            filter_dead (mvs, mv::add (mv, mvs'), mem, dead);
                                        fi;
                                 esac;
                              fi;
                    end;


                    # Scan all nodes in the graph and check
                    # which worklist they should go in:
                    #
                    fun collect ([], simp, fz, moves, spill, pseudos)
                            =>
                            {   pseudo_count := pseudos;

                                { simplify_worklist => simp,
                                  move_worklist     => moves,
                                  freeze_worklist   => fz,
                                  spill_worklist    => spill
                                };
                            };

                        collect (node ! rest, simp, fz, moves, spill, pseudos)
                            => 
                            case node   
                                #
                                cig::NODE { color=>REF cig::CODETEMP, movecnt, degree, ... }
                                    =>
                                    if (*degree >= hardware_registers_we_may_use)
                                        #
                                        collect (rest, simp, fz, moves, node ! spill, pseudos+1);

                                    elif (*movecnt > 0)

                                        collect (rest, simp, fz::add (node, fz), 
                                               moves, spill, pseudos+1);

                                    else

                                        collect (rest, node ! simp, fz, moves, spill, 
                                               pseudos+1);
                                    fi;

                               _   =>
                                   collect (rest, simp, fz, moves, spill, pseudos);
                             esac;
                    end;

                    # First build the move priority queue:
                    #
                    my (mvs, mem)
                        = 
                        if (is_on (mode, dead_copy_elim))

                            my (mvs, mem, dead) = filter_dead (moves, mv::EMPTY, [], []);
                            dead_copies := dead; (mvs, mem);
                        else
                            filter (moves, mv::EMPTY, []);
                        fi;

                    mem_moves := mem;  #  memory moves 

                    collect (iht::vals_list node_hashtable, [], fz::EMPTY, mvs, [], 0);
                };


            # Return a regmap that returns the current spill location
            # during spilling.
            #
            fun spill_loc (cig::CODETEMP_INTERFERENCE_GRAPH { node_hashtable, ... } )
                = 
                get'
                where
                    getnode =   iht::get  node_hashtable;

                    fun num (cig::NODE { color=>REF (cig::ALIASED n),     ... }) =>  num n;
                        num (cig::NODE { color=>REF (cig::SPILLED), id,   ... }) =>  id;
                        num (cig::NODE { color=>REF (cig::SPILL_LOC s),   ... }) =>  -s;
                        num (cig::NODE { color=>REF (cig::RAMREG (m, _)), ... }) =>  m;
                        num (cig::NODE { id,                              ... }) =>  id;
                    end;

                    fun get' r
                        =
                        num (getnode r)
                        except
                            _ = r;
                end;

            fun spill_loc_to_string (cig::CODETEMP_INTERFERENCE_GRAPH { node_hashtable, ... } )
                = 
                get'
                where
                    getnode = iht::get  node_hashtable;

                    fun num (cig::NODE { color=>REF (cig::ALIASED n),         ... }) =>   num n;
                        num (cig::NODE { color=>REF (cig::SPILLED), register, ... }) =>   "spilled " + rkj::register_to_string  register;
                        num (cig::NODE { color=>REF (cig::SPILL_LOC s),       ... }) =>   "frame "   + int::to_string  s;
                        num (cig::NODE { color=>REF (cig::RAMREG(_, m)),      ... }) =>   "memreg "  + rkj::register_to_string  m; 
                        num (cig::NODE { id,                                  ... }) =>   "error " + int::to_string id;
                    end;

                    fun get' r
                        =
                        num (getnode r); 
                end;


            # Core phases:
            #   Simplify, coalesce, freeze.
            #
            # NOTE: When a node's color is REMOVED or cig::ALIASED, 
            #       it is not considered to be part of the interferes_with list
            #
            #  1.  The move list has no duplicates.
            #  2.  The freeze list may have duplicates.
            #
            fun iterated_coalescing_phases
                 (cig as cig::CODETEMP_INTERFERENCE_GRAPH { hardware_registers_we_may_use, edge_hashtable, spill_flag, trail, mode, pseudo_count,  ... } )
                =
                {   edge_exists =  geh::edge_exists  *edge_hashtable;
                    add_edge = add_edge cig;
                    show = show cig;
                    memory_coalescing_on = is_on (mode, memory_coalescing);


                    # SIMPLIFY node:
                    #   Precondition: Node must be part
                    #   of the interference graph (cig::CODETEMP)
                    #   
                    fun simplify
                          ( node as cig::NODE { color, interferes_with, degree, /*pair,*/... },
                            mv, fz, stack
                          )
                        =
                        {   if debug  print("Simplifying " + show node + "\n"); fi;

                            fun forall_interferes_with ([], mv, fz, stack)
                                    =>
                                    (mv, fz, stack);

                                forall_interferes_with ((n as cig::NODE { color=>REF cig::CODETEMP, degree as REF d, ... } ) ! interferes_with,
                                          mv, fz, stack)
                                    =>
                                    if (d == hardware_registers_we_may_use)
                                        #
                                        (low_degree (n, mv, fz, stack))
                                            ->
                                            (mv, fz, stack);

                                        forall_interferes_with (interferes_with, mv, fz, stack);
                                    else
                                        degree := d - 1;
                                        forall_interferes_with (interferes_with, mv, fz, stack);
                                    fi;

                                forall_interferes_with (_ ! interferes_with, mv, fz, stack)
                                    =>
                                    forall_interferes_with (interferes_with, mv, fz, stack);
                            end;

                            color := cig::REMOVED;
                            pseudo_count := *pseudo_count - 1;

                            forall_interferes_with (*interferes_with, mv, fz, node ! stack);            # Push onto stack. 
                        }                                                       # fun simplify 

                    also
                    fun simplify_all ([], mv, fz, stack)
                            =>
                            (mv, fz, stack);

                        simplify_all (node ! simp, mv, fz, stack)
                            =>
                            {   my (mv, fz, stack)
                                    =
                                    simplify (node, mv, fz, stack);

                                simplify_all (simp, mv, fz, stack);
                             };
                    end 


                    # Decrement the degree of a pseudo node.
                    #   precondition: node must be part of the interference graph
                    #   If the degree of the node is now k-1.
                    #   Then if (a) the node is move related, freeze it.
                    #           (b) the node is non-move related, simplify it
                    #
                    #   node  -- the node to decrement degree
                    #   mv    -- queue of move candidates to be coalesced
                    #   fz    -- queue of freeze candidates
                    #   stack -- stack of removed nodes
                    #   
                    also
                    fun low_degree
                        (node as cig::NODE { degree as REF d, movecnt, interferes_with, color, ... }, /* FALSE, */ mv, fz, stack)
                         = 
                         # Normal edge. 
                         {   if debug  print("DecDegree " + show node + " d=" + int::to_string (d - 1) + "\n"); fi; 

                             degree := hardware_registers_we_may_use - 1;

                             #  node is now low degree!!! 

                             mv = enable_moves (*interferes_with, mv);

                             if (*movecnt > 0)  (mv, fz::add (node, fz), stack);         # Move related. 
                             else               simplify (node, mv, fz, stack);          # Non-move related, simplify now.
                             fi;
                         }


#                     | decDegree (node as cig::NODE { degree as REF d, movecnt, interferes_with, color, ... },
#                                 TRUE, mv, fz, stack) = #  register pair edge 
#                       (degree := d - 2;
#                        if d >= k and *degree < k then 
#                          #  node is now low degree!!! 
#                          let mv = enableMoves (node ! *interferes_with, mv)
#                          in  if *movecnt > 0 then #  move related 
#                                 (mv, fz::add (node, fz), stack)
#                              else #  non-move related, simplify now! 
#                                 simplify (node, mv, fz, stack)
#                          end
#                        else
#                          (mv, fz, stack)
#                       )



                    # Enable moves:
                    #   given: a list of nodes (some of which are not in the graph)
                    #   do:    all moves associated with these nodes are inserted
                    #          into the move worklist
                    #
                    also
                    fun enable_moves ([], mv)
                            =>
                            mv;

                        enable_moves (n ! ns, mv)
                            =>
                            {   # Add valid moves onto the worklist.
                                # There are no duplicates on the move worklist.
                                #
                                fun add_mv ([], ns, mv)
                                        =>
                                        enable_moves (ns, mv);

                                    add_mv((m as cig::MOVE_INT { status, hicount as REF hi, ... } ) ! rest, ns, mv)
                                        => 
                                        case *status   

                                            (cig::BRIGGS_MOVE | cig::GEORGE_MOVE)
                                                => 
                                                #  Decrements hi, when hi <= 0 enable move 
                                                if (hi <= 1)
                                                    status := cig::WORKLIST;
                                                    add_mv (rest, ns, mv::add (m, mv));
                                                else
                                                    hicount := hi - 1;
                                                    add_mv (rest, ns, mv);
                                                fi;
                                            _   =>
                                                add_mv (rest, ns, mv);
                                        esac;
                                end;

                                # Make sure the nodes are
                                # actually in the graph:
                                # 
                                case n
                                    #
                                    cig::NODE { movelist, color=>REF cig::CODETEMP, movecnt, ... }
                                        =>
                                        if (*movecnt > 0)                       # Is it move related? 
                                            add_mv (*movelist, ns, mv);
                                        else
                                            enable_moves (ns, mv);
                                        fi;

                                    _   => enable_moves (ns, mv);
                                esac;
                            };
                    end;                        # fun enable_moves 


                    #  Brigg's conservative coalescing test:
                    #    given: an unconstrained move (x, y)  
                    #    return: TRUE or FALSE
                    #
                    fun conservative (hicount,
                                     x as cig::NODE { degree=>REF dx, interferes_with=>xadj, /* pair=px, */ ... },
                                     y as cig::NODE { degree=>REF dy, interferes_with=>yadj, /* pair=py, */ ... } )
                        =
                        dx + dy < hardware_registers_we_may_use
                        or
                        {   # hi -- is the number of nodes with deg > k (without duplicates)
                            # n -- the number of nodes that have deg = k but not neighbors
                            #        of both x and y
                            # We use the movecnt as a flag indicating whether
                            # a node has been visited.  A negative count is used to mark
                            # a visited node.
                            #   
                            fun undo ([], extra_hi)
                                    => 
                                    extra_hi <= 0 or { hicount := extra_hi; FALSE;};

                                undo (movecnt ! tr, extra_hi)
                                    => 
                                    {   movecnt := -1 - *movecnt;
                                        undo (tr, extra_hi);
                                    };
                            end;

                            fun loop ([],   [], hi, n, tr) =>  undo (tr, (hi + n) - hardware_registers_we_may_use + 1);
                                loop ([], yadj, hi, n, tr) =>  loop (yadj, [], hi, n, tr);

                                loop (cig::NODE { color, movecnt as REF m, degree=>REF deg, ... } ! vs, yadj, hi, n, tr)
                                    =>
                                    case *color   
                                        #
                                        cig::COLORED _
                                            =>
                                            if (m < 0)
                                                 #  node has been visited before 
                                                 loop (vs, yadj, hi, n, tr);
                                            else
                                                 movecnt := -1 - m;  #  mark as visited 
                                                 loop (vs, yadj, hi+1, n, movecnt ! tr);
                                            fi;

                                        cig::CODETEMP
                                            =>
                                            if (deg < hardware_registers_we_may_use)
                                                #
                                                loop (vs, yadj, hi, n, tr);

                                            elif (m >= 0)

                                                # Node has never been visited before:

                                                movecnt := -1 - m;              # Mark as visited. 

                                                if (deg == hardware_registers_we_may_use)  loop (vs, yadj, hi, n+1, movecnt ! tr);
                                                else                                       loop (vs, yadj, hi+1, n, movecnt ! tr);
                                                fi;

                                               #  node has been visited before 
                                            elif (deg == hardware_registers_we_may_use)   loop (vs, yadj, hi, n - 1, tr);
                                            else                                          loop (vs, yadj, hi, n, tr);
                                            fi;

                                        _ => loop (vs, yadj, hi, n, tr); #  REMOVED/cig::ALIASED 
                                    esac;
                            end;

                            loop (*xadj, *yadj, 0, 0, []);
                        };                                      # fun conservative 


                    #  Heuristic used to determine whether a codetemp and hardware register     
                    #  can be coalesced. 
                    #  Precondition:
                    #     The two nodes are assumed not to interfere.
                    #
                    fun safe (hicount, reg, cig::NODE { interferes_with, ... } )
                        =
                        loop (*interferes_with, 0)
                        where
                            fun loop ([], hi)
                                    =>
                                    hi == 0   or   { hicount := hi; FALSE;};

                                loop (n ! interferes_with, hi)
                                    =>
                                    case n   
                                        # Note: We only have to consider pseudo nodes and not
                                        # nodes that are removed, since removed nodes either have
                                        # deg < k or else optimistic spilling must be in effect:
                                        #       
                                        cig::NODE { degree, id, color=>REF (cig::CODETEMP | cig::REMOVED), ... }
                                            => 
                                            (*degree < hardware_registers_we_may_use
                                            or edge_exists (reg, id))
                                                ??  loop (interferes_with, hi  )
                                                ::  loop (interferes_with, hi+1);

                                        _   => loop (interferes_with, hi);
                                    esac;
                            end;
                       end;


                    # Decrement the active move count of a node.
                    # When the move count reaches 0 and the degree < k
                    # simplify the node immediately.    
                    #      Precondition: node must be a node in the interference graph
                    #      The node can become a non-move related node.
                    #
                    fun dec_move_count
                            ( node as cig::NODE { movecnt, color=>REF cig::CODETEMP, degree, movecost, ... }, 
                              count, cost, mv, fz, stack
                            )
                            =>
                            {   new_count = *movecnt - count;

                                movecnt  := new_count;
                                movecost := *movecost - cost;

                                if (new_count == 0
                                and *degree < hardware_registers_we_may_use)                            #  low degree and movecnt == 0 
                                    #
                                    (simplify (node, mv, fz, stack));
                                else
                                    (mv, fz, stack);
                                fi;
                            };

                       dec_move_count(_, _, _, mv, fz, stack)
                           =>
                           (mv, fz, stack);
                    end;


                    # Combine two nodes u and v into one.
                    #   v is replaced by u  
                    #   u is the new combined node
                    #   Precondition: u != v and u and v must be unconstrained
                    #
                    #  u, v   -- two nodes to be merged, must be distinct!
                    #  coloingv -- is u a colored node?
                    #  mvcost -- the cost of the move that has been eliminated
                    #  mv     -- the queue of moves
                    #  fz     -- the queue of freeze candidates
                    #  stack  -- stack of removed nodes
                    #
                    fun combine (u, v, coloringv, mvcost, mv, fz, stack)
                        =
                        {   v ->  cig::NODE { color=>vcol, priority=>pv, movecnt=>cntv, movelist=>movev, interferes_with=>adjv, defs=>defsv, uses=>usesv, degree=>degv, ... };
                            u ->  cig::NODE { color=>ucol, priority=>pu, movecnt=>cntu, movelist=>moveu, interferes_with=>adju, defs=>defsu, uses=>usesu, degree=>degu, ... };

                            # Merge movelists together,
                            # taking the opportunity
                            # to prune the lists:
                            #
                            fun merge_move_list ([], mv)
                                    =>
                                    mv;

                                merge_move_list ((m as cig::MOVE_INT { status, hicount, src_reg, dst_reg, ... } ) ! rest, mv)
                                    => 
                                    case *status   
                                        #
                                        cig::BRIGGS_MOVE
                                            =>  
                                            # If we are changing a copy from v <-> w to uv <-> w
                                            # makes sure we reset its trigger count, so that it
                                            # will be tested next.
                                            #
                                            {   if coloringv  
                                                    status := cig::GEORGE_MOVE; 
                                                    hicount := 0;
                                                    if debug print ("New george " + show src_reg + "<->" + show dst_reg + "\n"); fi;
                                                fi;

                                                merge_move_list (rest, m ! mv);
                                            };

                                        cig::GEORGE_MOVE
                                            => 
                                            # If u is colored and v is not,
                                            # then the move  v <-> w
                                            # becomes       uv <-> w
                                            # where w is colored.
                                            # This can always be discarded.
                                            #
                                            if coloringv  merge_move_list (rest,     mv);
                                            else          merge_move_list (rest, m ! mv);
                                            fi;

                                        cig::WORKLIST
                                            =>
                                            merge_move_list (rest, m ! mv);

                                        _   =>
                                            merge_move_list (rest, mv);
                                    esac;
                            end;

                            # Form combined node.
                            # Add the interferes_with list of v to u:
                            #
                            fun union ([], mv, fz, stack)
                                    =>
                                    (mv, fz, stack);

                                union((t as cig::NODE { color, degree, ... } ) ! interferes_with, mv, fz, stack)
                                    =>
                                    case *color
                                        #
                                        (cig::COLORED _ | cig::SPILL_LOC _ | cig::RAMREG _ | cig::SPILLED)
                                            => 
                                            {   add_edge (t, u);
                                                union (interferes_with, mv, fz, stack);
                                            };

                                        cig::CODETEMP
                                            =>
                                            {   add_edge (t, u);

                                                d = *degree;

                                                if (d == hardware_registers_we_may_use)
                                                    #
                                                    my (mv, fz, stack)
                                                        =
                                                        low_degree (t, mv, fz, stack);

                                                    union (interferes_with, mv, fz, stack);

                                                else
                                                    degree := d - 1;

                                                    union (interferes_with, mv, fz, stack);
                                                fi;

                                            }; 
                                        _ => union (interferes_with, mv, fz, stack);
                                    esac;
                            end;

                            vcol := cig::ALIASED u; 
                                 #
                                 # Combine the priority of both: 
                                 # Note that since the mvcost has been counted twice
                                 # in the original priority, we substract it twice
                                 # from the new priority.

                            pu   := *pu + *pv - mvcost - mvcost;
                                 #
                                 # Combine the def/use pts of both nodes.
                                 # Strictly speaking, the def/use points of the move
                                 # should also be removed.  But since we never spill
                                 # a coalesced node and only spilling makes use of these
                                 # def/use points, we are safe for now.  
                                 #
                                 # New comment: with spill propagation, it is necessary
                                 # to keep track of the spilled program points.

                            if memory_coalescing_on 

                                defsu := cat (*defsu, *defsv); 
                                usesu := cat (*usesu, *usesv);

                            fi;

                            case *ucol   
                                #
                                cig::CODETEMP
                                    => 
                                    {   if (*cntv > 0)  moveu := merge_move_list(*movev, *moveu);   fi; 

                                        movev := [];                    #  XXX kill the list to free space 
                                        cntu  := *cntu + *cntv;
                                    };

                                _   => ();
                            esac;

                            cntv := 0;

                            removing_hi
                                =
                                *degv >= hardware_registers_we_may_use
                                and
                                (*degu >= hardware_registers_we_may_use or coloringv); 

                            # Update the move count of the combined node:
                            #   
                            my (mv, fz, stack)
                                =
                                union(*adjv, mv, fz, stack);

                            my (mv, fz, stack)
                                = 
                                dec_move_count (u, 2, mvcost + mvcost, mv, fz, stack);  

                            # If either v or u are high degree then at least one high degree
                            # node is removed from the neighbors of uv after coalescing
                            #   
                            mv = if removing_hi  enable_moves(*adju, mv); else mv;fi;

                            coalesce (mv, fz, stack);
                        }


                    #  COALESCE:
                    #    Repeat coalescing and simplification until mv is empty.
                    #
                    also
                    fun coalesce (mv::EMPTY, fz, stack)
                            =>
                            (fz, stack);

                        coalesce (mv::TREE (cig::MOVE_INT { src_reg, dst_reg, status, hicount, cost, ... }, _, l, r), fz, stack)
                            => 
                            {   # coalesce_count := *coalesce_count + 1 

                                (chase src_reg) ->   u;
                                (chase dst_reg) ->   v as cig::NODE { color=>REF vcol, ... };

                                # Make u the colored one:
                                #        
                                my  ( u as cig::NODE { id=>u', color=>REF ucol, ... },
                                      v as cig::NODE { id=>v', color=>REF vcol, ... }
                                    )
                                    = 
                                    case vcol   cig::COLORED _ => (v, u);
                                                _         => (u, v);
                                    esac;

                                if debug   print ("Coalescing " + show u + "<->" + show v +  " (" + f8b::to_string cost + ")");  fi;

                                mv = mv::merge (l, r);

                                fun coalesce_it (status, v)
                                    = 
                                    {   status := cig::COALESCED;

                                        if *spill_flag  trail := cig::UNDO (v, status, *trail);  fi;
                                   };

                                if (u' == v')                   # Trivial move 
                                    #
                                    if debug  print(" Trivial\n");   fi;

                                    coalesce_it (status, v);
                                    coalesce (dec_move_count (u, 2, cost+cost, mv, fz, stack));

                                else 
                                    case vcol   

                                        cig::COLORED _
                                            => 
                                            # Two colored nodes cannot be coalesced:
                                            # 
                                            {   status := cig::CONSTRAINED;

                                                if debug  print(" Both Colored\n");  fi; 

                                                coalesce (mv, fz, stack);
                                            };

                                        _   =>
                                            if (edge_exists (u', v') ) 
                                                #
                                                # U and v interfere. 

                                                status := cig::CONSTRAINED;
                                                if debug  print(" Interfere\n");  fi;  

                                                my (mv, fz, stack) = (dec_move_count (u, 1, cost, mv, fz, stack));
                                                coalesce             (dec_move_count (v, 1, cost, mv, fz, stack));
                                            else
                                                case ucol
                                                    #
                                                    cig::COLORED _                                              # u is colored, v is not 
                                                        =>
                                                        if (safe (hicount, u', v) ) 

                                                           if debug  print(" Safe\n");  fi; 

                                                           # if tally then good_george := *good_george+1 

                                                           coalesce_it (status, v);
                                                           combine (u, v, TRUE, cost, mv, fz, stack);

                                                        else

                                                           # Remove it from the move list:


                                                           status := cig::GEORGE_MOVE;

                                                           # if tally then bad_george := *bad_george + 1 

                                                           if debug  print(" Unsafe\n");  fi; 

                                                           coalesce (mv, fz, stack);
                                                        fi;

                                                    _   =>                                                      # u, v are not colored 
                                                        if (conservative (hicount, u, v) ) 
                                                            #
                                                            if debug  print(" OK\n");  fi; 

                                                            # if tally then good_briggs := *good_briggs+1 

                                                            coalesce_it (status, v);
                                                            combine (u, v, FALSE, cost, mv, fz, stack);

                                                        else
                                                            # Conservative test failed. 
                                                            # Remove it from the move list:

                                                            status := cig::BRIGGS_MOVE;

                                                            # if tally then bad_briggs := *bad_briggs + 1 

                                                            if debug  print(" Non-conservative\n");  fi; 
                                                            coalesce (mv, fz, stack);
                                                        fi;
                                                esac;
                                            fi;
                                    esac;
                                fi;
                            };
                     end;                               # fun coalesce 

                    # Mark a node n as frozen: 
                    #  Go thru all the moves (n, m), decrement the move count of m
                    #  precondition: degree must be < k
                    #                movecnt must be > 0
                    #    node  -- the node to be frozen
                    #    fz    -- a queue of freeze candidates
                    #    stack -- stack of removed nodes
                    #
                    fun mark_as_frozen
                        (
                          node as cig::NODE { id=>me, degree, interferes_with, movelist, movecnt as REF mc, ... },
                          fz, stack
                        )
                        = 
                        {   if debug  print("Mark as frozen " + int::to_string me + "\n"); fi;

                            # Eliminate all moves,
                            # return a list of nodes that
                            # can be simplified:
                            #
                            fun elim_moves ([], simp)
                                    =>
                                    simp;

                                elim_moves (cig::MOVE_INT { status, src_reg, dst_reg, ... } ! mvs, simp)
                                    =>
                                    case *status    
                                        #
                                        cig::WORKLIST
                                            =>
                                            error "elimMoves";

                                        (cig::BRIGGS_MOVE | cig::GEORGE_MOVE)           # Mark move as lost.
                                            => 
                                            {   status := cig::LOST;

                                                (chase src_reg) ->   src as cig::NODE { id=>s, ... };

                                                you  =  (s == me)  ??  chase dst_reg
                                                                   ::        src;
                                                case you
                                                    #
                                                    cig::NODE { color=>REF (cig::COLORED _), ... }
                                                        => 
                                                        elim_moves (mvs, simp);

                                                    cig::NODE { movecnt as REF c, degree, ... } #  pseudo 
                                                        =>
                                                        {   movecnt := c - 1; 

                                                            (c == 1 and *degree < hardware_registers_we_may_use)  
                                                                ??  elim_moves (mvs, you ! simp)
                                                                ::  elim_moves (mvs, simp);
                                                        };
                                                esac;
                                            };

                                        _   => elim_moves (mvs, simp);
                                    esac;
                            end;

                            # Note:
                            # We are removing a high degree node,
                            # so try to enable all moves 
                            # associated with its neighbors.
                            #   
                            mv =   if (*degree >= hardware_registers_we_may_use)   enable_moves (*interferes_with, mv::EMPTY); 
                                   else                                                                            mv::EMPTY;
                                   fi;

                            if (mc == 0)
                                #
                                simplify (node, mv, fz, stack);
                            else 
                                movecnt := 0; 
                                simplify_all (node ! elim_moves(*movelist, []), mv, fz, stack);
                            fi;
                        };


                    # FREEZE: 
                    #   Repeat picking 
                    #   a node with degree < k from the freeze list and freeze it.
                    #   fz    -- queue of freezable nodes 
                    #   stack -- stack of removed nodes
                    #   undo  -- trail of coalesced moves after potential spill
                    #
                    fun freeze (fz, stack)
                        = 
                        loop (fz, fz::EMPTY, stack)
                        where
                            fun loop (fz::EMPTY, fz::EMPTY, stack)
                                    =>
                                    stack;

                                loop (fz::EMPTY, new_fz, _)
                                    =>
                                    error "no freeze candidate";

                                loop (fz::TREE (node, _, l, r), new_fz, stack)
                                    =>
                                    {   fz = fz::merge (l, r);

                                        case node   
                                            #
                                            # This node has not been simplified 
                                            # This must be a move-related node.
                                            #
                                            cig::NODE { color=>REF cig::CODETEMP, degree, ... }
                                                =>
                                                if (*degree >= hardware_registers_we_may_use)                                   #  Can't be frozen yet? 
                                                    #
                                                    # if tally then bad_freeze := *bad_freeze+1;  fi;

                                                    loop (fz, fz::add (node, new_fz), stack);

                                                else
                                                    # Freeze node. 

                                                    if debug  print("Freezing " + show node + "\n");  fi;

                                                    #  if tally then good_freeze := *good_freeze + 1

                                                    my (mv, fz, stack)
                                                        =
                                                        mark_as_frozen (node, fz, stack);

                                                    my (fz, stack)
                                                        =
                                                        coalesce (mv, fz, stack);

                                                    # print("[freezing again "  + int::to_string *blocked  +  "]");

                                                    loop (fz::merge (fz, new_fz), fz::EMPTY, stack);
                                                fi;

                                            _   => 
                                                {   # if tally then bad_freeze := *bad_freeze + 1 

                                                    loop (fz, new_fz, stack);
                                                };
                                        esac;
                                    };
                            end;

                            # print("[freezing "  +  int::to_string *blocked  +  "]"); 

                        end;


                    # Sort simplify worklist in increasing degree.
                    # Matula and Beck suggest that we should always
                    # first remove the node with the lowest degree.
                    # This is an approximation of that idea. 


#                   buckets = rwv::rw_vector (k, []) : rwv::Rw_Vector(  List( cig::node ) )
#                   fun sortByDegree nodes =
#                   let fun insert [] = ()
#                         | insert((n as cig::NODE { degree=REF deg, ... } ) ! rest) =
#                           (uwv::set (buckets, deg, n ! uwv::sub (buckets, deg)); insert rest)
#                       fun collect (-1, L) = L
#                         | collect (deg, L) = collect (deg - 1, cat (uwv::sub (buckets, deg), L))
#                   in  insert nodes; 
#                       collect (k - 1, [])
#                   end



                    # Iterate over simplify, coalesce, freeze
                    #
                    fun iterate { simplify_worklist, move_worklist, freeze_worklist, stack }
                        =
                        {   # Simplify everything:
 
                            my (mv, fz, stack)
                                = 
                                simplify_all( /* sort_by_degree */ simplify_worklist, move_worklist, freeze_worklist, stack);

                            my (fz, stack)
                                =
                                coalesce (mv, fz, stack);

                            stack = freeze (fz, stack);

                            { stack };
                        };

                    { mark_as_frozen, iterate };
                };


            # The main entry point for the
            # iterated coalescing algorithm:
            #   
            fun iterated_coalescing  codetemp_interference_graph
                = 
                (iterated_coalescing_phases  codetemp_interference_graph).iterate;



            # Potential Spill:
            #   Find some node on the spill list and just optimistically
            # remove it from the graph.
            #
            fun potential_spill_node (cig as cig::CODETEMP_INTERFERENCE_GRAPH { spill_flag, ... } )
                =
                {
                    my { mark_as_frozen, ... }
                         =
                         iterated_coalescing_phases cig;

                    fn { node, cost, stack }
                        =
                        {   spill_flag := TRUE;         # Potential spill found.

                            my (mv, fz, stack)
                                =
                                mark_as_frozen (node, fz::EMPTY, stack);

                            if (cost < 0.0)

                                 my cig::NODE { color, ... } = node;
                                 color := cig::SPILLED;
                            fi;

                            { move_worklist=>mv, freeze_worklist=>fz, stack };
                        };
                };




            #  SELECT: 
            #    Using optimistic spilling
            #
            fun select
                    (cig as cig::CODETEMP_INTERFERENCE_GRAPH { pick_available_hardware_register, trail, codetemp_id_if_above,  spill_flag, register_is_taken,true_value, mode, ... } )
                    { stack }
                =
                {   fun undo_coalesced cig::END
                            =>
                            ();

                        undo_coalesced (cig::UNDO (cig::NODE { id, color, ... }, status, trail))
                            =>
                            {   status := cig::BRIGGS_MOVE;

                                if (id >= codetemp_id_if_above)   color := cig::CODETEMP;   fi;

                                undo_coalesced trail;
                            };
                    end;

                    show = show cig;

                    # Fast coloring, assume no spilling can occur 
                    #
                    fun fastcoloring ([], true_value)
                            =>
                            ([], true_value);

                        fastcoloring((node as cig::NODE { color, /* pair, */ interferes_with, ... } ) ! stack, true_value)
                            =>
                            {   # Set up the register_is_taken rw_vector:
                                # 
                                fun fill_in__register_is_taken__vector []
                                        =>
                                        ();

                                    fill_in__register_is_taken__vector (r ! rs)
                                        => 
                                        mark r
                                        where
                                            fun mark (cig::NODE { color=>REF (cig::COLORED c), ... } )
                                                    =>
                                                    {   uwv::set (register_is_taken, c, true_value);
                                                        fill_in__register_is_taken__vector rs;
                                                    };

                                                mark (cig::NODE { color=>REF (cig::ALIASED n), ... } )
                                                    =>
                                                    mark n;

                                                mark _
                                                    =>
                                                    fill_in__register_is_taken__vector rs;
                                            end;
                                        end;
                                end;

                                fill_in__register_is_taken__vector *interferes_with;

                                color :=    cig::COLORED
                                                (pick_available_hardware_register                       # pick_available_hardware_register_by_round_robin_g             is from   src/lib/compiler/back/low/regor/pick-available-hardware-register-by-round-robin-g.pkg
                                                  {
                                                    preferred_registers =>  [],
                                                    register_is_taken,
                                                    true_value
                                                  }
                                                );

                                fastcoloring (stack, true_value+1); 
                            };
                    end;

                    #  Briggs' optimistic spilling heuristic 
                    #
                    fun optimistic ([], spills, true_value)
                            =>
                            (spills, true_value);

                        optimistic((node as cig::NODE { color=>REF (cig::SPILLED), ... } ) ! stack, spills, true_value)
                            =>
                            optimistic (stack, node ! spills, true_value);

                        optimistic((node as cig::NODE { color as REF cig::REMOVED, /* pair, */ interferes_with, ... } ) ! stack, spills, true_value)
                            =>
                            {   # Set up the register_is_taken rw_vector:
                                # 
                                fun fill_in__register_is_taken__vector []
                                        =>
                                        ();

                                    fill_in__register_is_taken__vector (r ! rs)
                                        => 
                                        mark r
                                        where
                                            fun mark (cig::NODE { color=>REF (cig::COLORED c), ... } )
                                                    =>
                                                    {   uwv::set (register_is_taken, c, true_value);
                                                        fill_in__register_is_taken__vector rs;
                                                    };

                                                mark (cig::NODE { color=>REF (cig::ALIASED n), ... } )
                                                    =>
                                                    mark n;

                                                mark _ => fill_in__register_is_taken__vector rs;
                                            end;
                                        end;
                                end;

                                fill_in__register_is_taken__vector *interferes_with;

                                spills
                                    =
                                    {   color' =  pick_available_hardware_register              # pick_available_hardware_register_by_round_robin_g     is from   src/lib/compiler/back/low/regor/pick-available-hardware-register-by-round-robin-g.pkg
                                                      {
                                                        preferred_registers =>  [],
                                                        register_is_taken,
                                                        true_value
                                                      };

                                        color :=  cig::COLORED  color';

                                        spills;
                                    }
                                    except
                                        _ = node ! spills;

                                optimistic (stack, spills, true_value+1); 
                            };

                        optimistic _
                            =>
                            error "optimistic";
                    end;

                    # Briggs' optimistic spilling heuristic, with biased coloring:
                    # 
                    fun biased_coloring ([], spills, true_value)
                            =>
                            (spills, true_value);

                        biased_coloring((node as cig::NODE { color=>REF (cig::SPILLED), ... } ) ! stack, spills, true_value)
                            =>
                            biased_coloring (stack, node ! spills, true_value);

                        biased_coloring((node as cig::NODE { color=>REF (cig::SPILL_LOC _), ... } ) ! stack, spills, true_value)
                            =>
                            biased_coloring (stack, node ! spills, true_value);

                        biased_coloring((node as cig::NODE { color=>REF (cig::RAMREG _), ... } ) ! stack, spills, true_value)
                            =>
                            biased_coloring (stack, node ! spills, true_value);

                        biased_coloring
                            (
                              (node as cig::NODE { id, color, interferes_with, /* pair, */ movecnt, movelist, ... } ) ! stack, 
                              spills,
                              true_value
                            )
                            =>
                            {   # Set up the register_is_taken rw_vector:
                                # 
                                fun fill_in__register_is_taken__vector []
                                        =>
                                        ();

                                    fill_in__register_is_taken__vector (r ! rs)
                                        => 
                                        case (chase r)   
                                            #
                                            cig::NODE { color=>REF (cig::COLORED c), ... }
                                                => 
                                                {   uwv::set (register_is_taken, c, true_value);
                                                    fill_in__register_is_taken__vector rs;
                                                };

                                            _   =>
                                                fill_in__register_is_taken__vector rs;
                                        esac;
                                end;

                                # Look at lost moves and
                                # see if it is possible to 
                                # color the move with the same color
                                #
                                fun get_pref ([], pref)
                                        =>
                                        pref;

                                    get_pref (cig::MOVE_INT { status=>REF (cig::LOST | cig::BRIGGS_MOVE | cig::GEORGE_MOVE), src_reg, dst_reg, ... } ! mvs, pref)
                                        =>
                                        {   (chase src_reg) ->   src as cig::NODE { id=>s, ... };

                                            other =   (s == id)   ??   chase dst_reg
                                                                  ::         src;
                                            case other   
                                                #
                                                cig::NODE { color=>REF (cig::COLORED c), ... }
                                                    =>
                                                    get_pref (mvs, c ! pref);

                                                _   =>
                                                    get_pref (mvs, pref);
                                            esac;
                                        };

                                    get_pref(_ ! mvs, pref)
                                        =>
                                        get_pref (mvs, pref);
                                end;

                                fill_in__register_is_taken__vector *interferes_with;

                                pref = get_pref (*movelist,[]);

                                spills
                                    =
                                    {   color' =    pick_available_hardware_register                    # pick_available_hardware_register_by_round_robin_g             is from   src/lib/compiler/back/low/regor/pick-available-hardware-register-by-round-robin-g.pkg
                                                      {
                                                        preferred_registers =>  [],
                                                        register_is_taken,
                                                        true_value
                                                      };

                                        color :=  cig::COLORED  color';

                                        spills;
                                    }
                                    except
                                        _ = node ! spills;

                                biased_coloring (stack, spills, true_value+1);
                            };
                    end;                                # fun biased_coloring

                    my (spills, new_true_value)
                        = 
                        if   (is_on (mode, biased_selection))  biased_coloring (stack, [], *true_value);
                        elif *spill_flag                       optimistic      (stack, [], *true_value);
                        else                                   fastcoloring    (stack,     *true_value);
                        fi;

                    true_value := new_true_value;

                    case spills
                        #                      
                        [] => { spills => [] };

                        spills
                            => 
                            {   fun undo []
                                        =>
                                        ();

                                    undo (cig::NODE { color, ... } ! nodes)
                                        =>
                                        {   color := cig::CODETEMP;
                                            undo nodes;
                                        };
                                end;

                                undo stack;
                                undo_coalesced *trail;

                                trail := cig::END;

                                { spills };
                            };
                    esac;

                };                      # fun select


            # Incorporate memory<->register moves
            # into the interference graph:
            #
            fun init_mem_moves (cig::CODETEMP_INTERFERENCE_GRAPH { mem_moves, ... } )
                =
                {   fun move (cig::NODE { movelist, movecost, ... }, mv, cost)
                        = 
                        {   movelist := mv ! *movelist;
                            movecost := cost + *movecost;
                        };

                    fun set_move (dst, src, mv, cost)
                        = 
                        {   move (dst, mv, cost);
                            move (src, mv, cost);
                        };

                    fun init []
                            =>
                            ();

                        init ((mv as cig::MOVE_INT { dst_reg, src_reg, cost, ... } ) ! mvs)
                            => 
                            {   (chase dst_reg) ->  dst as cig::NODE { color=>REF dst_col, ... };
                                (chase src_reg) ->  src as cig::NODE { color=>REF src_col, ... };

                                if (is_fixed_mem (src_col) and is_fixed_mem (dst_col) )
                                    set_move (dst, src, mv, cost);
                                else
                                    case (src_col, dst_col)

                                        (cig::CODETEMP, _)
                                            =>
                                            if (is_fixed_mem dst_col)  set_move (dst, src, mv, cost); 
                                            else                       error "init_mem_moves";
                                            fi;

                                        (_, cig::CODETEMP)
                                            => 
                                            if (is_fixed_mem src_col)  set_move (dst, src, mv, cost); 
                                            else                       error "init_mem_moves";
                                            fi;

                                        (cig::COLORED _, _) => if (not (is_fixed_mem dst_col))  error "init_mem_moves"; fi;
                                        (_, cig::COLORED _) => if (not (is_fixed_mem src_col))  error "init_mem_moves"; fi;
                                        _              =>                                  error "init_mem_moves";
                                   esac;
                                 fi;

                                 init mvs;
                            };
                    end;

                    moves = *mem_moves; 

                    mem_moves := [];

                    init moves;
                };                              # fun init_mem_moves



            # Compute savings due to memory<->register moves
            #
            fun move_savings (cig::CODETEMP_INTERFERENCE_GRAPH { mem_moves=>REF [], ... } )
                    =>
                    (fn node = 0.0);

                move_savings (cig::CODETEMP_INTERFERENCE_GRAPH { mem_moves, edge_hashtable, ... } )
                    => 
                    {   exception SAVINGS;

                        savings_map = iht::make_hashtable  { size_hint => 32,  not_found_exception => SAVINGS }
                                    : iht::Hashtable  { pinned: Int,
                                                        cost:   cig::Cost
                                                      };

                        savings =  iht::find savings_map;

                        savings =  fn r = case (savings r)    NULL  => { pinned=> -1, cost=>0.0 };
                                                              THE s => s;
                                          esac;

                        add_savings = iht::set  savings_map;

                        edge_exists = geh::edge_exists  *edge_hashtable;

                        fun inc_savings (u, v, c)
                            =
                            {   (savings u) ->   { pinned, cost };

                                if (pinned != -1 and v != pinned or edge_exists(u, v))
                                     ();
                                else 
                                     add_savings (u, { pinned=>v, cost=>cost + c + c } );
                                fi;
                            };

                        fun compute_savings []
                                =>
                                ();

                            compute_savings (cig::MOVE_INT { dst_reg, src_reg, cost, ... } ! mvs)
                                =>
                                {   (chase src_reg) ->  src as cig::NODE { id=>u, color=>cu, ... };
                                    (chase dst_reg) ->  dst as cig::NODE { id=>v, color=>cv, ... };

                                    case (*cu, *cv) 
                                        #
                                        (cu, cig::CODETEMP) => if (is_fixed_mem cu) inc_savings (v, u, cost); fi;
                                        (cig::CODETEMP, cv) => if (is_fixed_mem cv) inc_savings (u, v, cost); fi;
                                        _            => ();
                                    esac;

                                    compute_savings mvs;
                                };
                        end;

                        compute_savings *mem_moves;

                        fn node =  (savings node).cost;
                    };
             end;               # fun move_savings


            # Update the color of registers:
            #
            fun update_register_colors (cig::CODETEMP_INTERFERENCE_GRAPH { node_hashtable, dead_copies, ... } )
                = 
                iht::apply  recolor_node  node_hashtable
                where
                    fun color_register (rkj::CODETEMP_INFO { color, ... }, new_color)
                        =
                        color :=  new_color;

                    fun register_of (cig::NODE { register, ... } )
                        =
                        register;

                    fun recolor_node (cig::NODE { register, color=>REF (cig::COLORED c),     ... } ) =>  color_register (register, rkj::MACHINE c);
                        recolor_node (cig::NODE { register, color=>REF (cig::ALIASED alias), ... } ) =>  color_register (register, rkj::ALIASED (register_of alias));
                        recolor_node (cig::NODE { register, color=>REF (cig::SPILLED),       ... } ) =>  color_register (register, rkj::SPILLED);
                        recolor_node (cig::NODE { register, color=>REF (cig::SPILL_LOC s),   ... } ) =>  color_register (register, rkj::SPILLED);
                        recolor_node (cig::NODE { register, color=>REF (cig::RAMREG (m, _)), ... } ) =>  color_register (register, rkj::MACHINE m);
                        #
                        recolor_node (cig::NODE { register, color=>REF (cig::CODETEMP),        ... } ) =>  ();
                        recolor_node (_)                                                            =>  error ("update_register_colors");
                    end;
                end;


            # Update aliases before spill rewriting:
            #
            fun update_register_aliases (cig::CODETEMP_INTERFERENCE_GRAPH { node_hashtable, dead_copies, ... } )
                = 
                {   fun enter (rkj::CODETEMP_INFO { color, ... }, c)
                        =
                        color := c;


                    fun register_of (cig::NODE { register, ... } )
                        =
                        register;


                    fun set (cig::NODE { register, color=>REF (cig::COLORED c), ... } )
                            =>
                            ();

                        set (cig::NODE { register, color=>REF (cig::ALIASED alias), ... } )
                            => 
                            enter (register, rkj::ALIASED (register_of alias));

                        set (cig::NODE { register, color=>REF (cig::SPILLED),     ... } ) =>  ();
                        set (cig::NODE { register, color=>REF (cig::SPILL_LOC s), ... } ) =>  ();
                        set (cig::NODE { register, color=>REF (cig::RAMREG _),    ... } ) =>  ();
                        set (cig::NODE { register, color=>REF  cig::CODETEMP,        ... } ) =>  ();

                        set (_)
                            =>
                            error "updateRegisterAliases";
                    end;

                    iht::apply  set  node_hashtable;
                };

            fun mark_dead_copies_as_spilled (cig::CODETEMP_INTERFERENCE_GRAPH { dead_copies, ... } )
                = 
                case *dead_copies
                    #                 
                    [] => ();
                    #
                    dead_copies' =>  apply   (fn r = color_register (r, rkj::SPILLED))
                                             dead_copies';
                esac
                where
                    fun color_register (rkj::CODETEMP_INFO { color, ... }, new_color)
                        =
                        color :=  new_color;
                end; 


            # Clear the interference graph
            # but keep the nodes:
            #
            fun clear_graph
                (cig::CODETEMP_INTERFERENCE_GRAPH { edge_hashtable, get_next_codetemp_id_to_allot, trail, spill_flag, dead_copies, mem_moves, copy_tmps, ... }
                )
                =
                {   hashchains_count_hint =   geh::get_hashchains_count   *edge_hashtable;
                    #
                    trail       :=  cig::END;
                    spill_flag  :=  FALSE;

                    dead_copies :=  [];
                    mem_moves   :=  [];
                    copy_tmps   :=  [];

                    edge_hashtable  :=  geh::empty_graph;       # WTF?
                    edge_hashtable  :=  cig::make_edge_hashtable { hashchains_count_hint, max_codetemp_id=>get_next_codetemp_id_to_allot() };
                }; 

            fun clear_nodes (cig::CODETEMP_INTERFERENCE_GRAPH { node_hashtable, ... } )
                =
                iht::keyed_apply  init  node_hashtable
                where
                    fun init (_, cig::NODE { priority, degree, interferes_with, movecnt, movelist, movecost, defs, uses, ... } )
                        =
                        {   priority            := 0.0;
                            movecost            := 0.0;

                            degree              := 0;
                            movecnt             := 0;

                            interferes_with     := [];
                            movelist            := [];
                            defs                := [];
                            uses                := [];
                        };
                end;

        end;                    # stipulate
    };                          # package iterated_register_coalescing
end;                            # stipulate


## COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2013,
## released per terms of SMLNJ-COPYRIGHT.


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext