sched.pl

#!/usr/bin/perl

###################################
#   Perl scheduler for ScaffCC
###################################
#   By: Jeff Heckey
#   Copyright: 2014 UCSB
#   NOT INTENDED FOR PUBLIC DISTRIBUTION
###################################
#
# Status (2/Jul/14):
#   Added width to RCP
# Status (3/Jun/14):
#   Added move counts to metrics output
# Status (26/May/14):
#   RCP optimizations round 1
# Status (22/May/14):
#   Added "true" printing, which prints the op schedule of each simd region at a given timestep
# Status (13/May/14):
#   Added tgate counts, modified output metrics to include more raw data
#   Added flags for pretty print
#   Minor optimizations (variable localization)
# Status (10/May/14):
#   update_moves optimized
#   other misc optimizations
# Status (7/May/14):
#   find_lp now uses $obj->{ops} to iterate instead of ACPA schedule. ~33% system time speedup
# Status (5/May/14):
#   Modified lpfs update ready to use hash instead of arrays (>10x speed up!)
# Status (2/May/14):
#   Got rid of moves from stalled SIMD regions
#   LPFS will SIMD sched opp regions
#   Tested SIMD L=1, K=2; L=1, K=4
#   Update 2: regression proofing for reschedule
# Status (1/May/14):
#   Improved find_lp algorithm, now much faster
# Status (29/Apr/14):
#   Enhancements to work with BWT (div/0 errors)
#   Profiled code to speed it up (find_LP() is longest runtime)
# Status (26/Apr/14):
#   Added metrics
# Status (25/Apr/14):
#   RCP now using update_moves and revised update RCPQ and general clean up
#   Update 2: Find next LP for completed SIMD region
#   Update 3: Opportunistic SIMD scheduling added
# Status (24/Apr/14):
#   Some partial fixes to schedule object for repeated passes.
# Status (23/Apr/14):
#   Finished LPFS with moves and cleaned up
# Status (8/Apr/14):
#   Finished a first pass of the LPFS scheduling
#   Non-optimal - could recalculate longest paths from present point if a path is completed.
# Status (18/Mar/14):
#   Contains CPR code for evaluating potential conflicts in SIMD regions
#   Partially completed RCP code, in more structured form
#
#TODO:
#   Finish clean up for repeat schedules
#   Look for movement optimization in LPFS
#   Modify to deal with registers
#   

#use 5.012;

package Qubit;

sub new {
    my $class = shift;
    my $qubit = { 'name'      => "",
                  'index'     => 0,
                  'size'      => 1,
                  'loc'       => 0,  # RCP [-1 = unalloc, 0 = mem, 1-n = simd-n]
                  'last_op'   => -1,
                  'ops'       => [] };
    $qubit->{name} = shift;
    if ( $qubit->{name} =~ /(.*?)(\d+)/ ) {
        $qubit->{index} = $2;
    } else {
        $qubit->{index} = -1;
    }
    bless $qubit, $class;
    return $qubit;
}

sub add_dep {
    my $qubit = shift;
    push ( @{ $qubit->{ops} }, shift );
}

sub get_dep {
    my $qubit = shift;
    my $idx = shift || -1;  # return last element by default
    return $qubit->{ops}->[$idx];
}

# Fetches qubit at latest timestep
# Return: 1 if qubit needs to be moved, 0 otherwise
sub rcp_fetch_qubit {
    my $qubit = shift;
    my $ts = shift;
    my $simd = shift;
    my $op = shift;
    $qubit->{last_op}++;
    if ( !defined $qubit->{ops}->[ $qubit->{last_op} ] ) {
        printf "E: looking at $qubit->{name} out of range\n";
    } elsif ( ::refaddr( $op ) != ::refaddr( $qubit->{ops}->[$qubit->{last_op}] ) ) {
        printf "E: Out of order scheduling of qubit %s ops '%s' and '%s'\n",
                $qubit->{name}, $op->{text}, $qubit->{ops}->[$qubit->{last_op}]->{text};
    }
    $qubit->{last_ts} = $ts;
    if ( $qubit->{loc} != -1 and $qubit->{loc} != $simd ) {
        $qubit->{loc} = $simd;
        return 1;
    }
    $qubit->{loc} = $simd;
    return 0;
}

# Moves qubit back to memory if it is not used in this timestep
# Return: 1 if qubit returns to memory
sub rcp_store_qubit {
    my $qubit = shift;
    my $curr_ts = shift;
    if ( $qubit->{last_ts} != $curr_ts ) {
        $qubit->{loc} = 0;  # move to memory
        return 1;
    }
    return 0;   # Used in current timestep, so do not move to memory
}


package Op;

my $id = 1;

sub new {
    my $class = shift;
    my $op = {  'op'        => '',
                'rank'      => 0,
                'length'    => 1,
                'dist'      => -1,
                'top'       => 1,
                'bottom'    => 1,
                'args'      => [],
                'text'      => '',
                'id'        => 0,
                'slack'     => 0,
                'asap'      => {'ts'    => -1},
                'alap'      => {
                                'ts'    => -1,
                                'sched' => 0
                            },
                'acap'      => {
                                'ts'    => -1,
                                'sched' => 0
                            },
                'lpfs'      => {
                                'tag'       => 0,
                                'path'      => 0,
                                'followed'  => 0,
                                'simd'      => -1,
                                'ts'        => -1
                            },
                'rcp'       => {
                                'simd'      => -1,
                                'ts'        => -1
                            },
                'p_chaco'   => -1,
                'in_edges'  => [],
                'out_edges' => [] };
    $op->{op} = shift;
    $op->{rank} = shift;
    $op->{length} = shift || 1;
    $op->{id} = $id++   if ( $op->{op} ne "MOV" );
    $op->{text} = "$op->{id}: $op->{op}";
    bless $op, $class;
    return $op;
}

# Add new args and updated dependencies as needed
sub add_qubit {
    my $op = shift;
    my $qubit = shift;
    push @{ $op->{args} }, $qubit;
    if ( my $dep = $qubit->get_dep(-2) ) {
        push ( @{ $op->{'in_edges'} }, $dep );
        push ( @{ $dep->{'out_edges'} }, $op );
        $op->{top} = 0;
        $dep->{bottom} = 0;
    }
    $op->{'text'} .= " $qubit->{name}";
}

sub print_fields {
    my $op = shift;
    foreach my $field ( @_ ) {
        print  "$op->{$field} ";
    }
    print  "\n";
}

sub op_ready {
    my $op = shift;
    my $sched = shift;
    my $ready = 1;
    foreach my $parent ( @{ $op->{in_edges} } ) {
        $ready = 0  if ( ! defined $parent->{$sched}->{ts} or $parent->{$sched}->{ts} == -1 );
    }
    return $ready;
}

sub get_ready_children {
    my $op = shift;
    my $sched = shift;
    my @ready = ();
    foreach my $child ( @{ $op->{out_edges} } ) {
        push @ready, $child     if ( $child->op_ready($sched) );
    }
    return @ready;
}

sub take_path {
    my $op = shift;
    my $path = shift;
    $op->{lpfs}->{dist} = 0;   # Clear distance for next path finding
    $op->{lpfs}->{path} = $path;
    $op->{lpfs}->{simd} = $path;
    $op->{lpfs}->{followed} = 1;
}

# Fetch op's qubits if needed
# Return: list of qubits that need to move
sub rcp_fetch_op {
    my $op = shift;
    my $ts = shift;
    my $simd = shift;
    my @moves = ();
    $op->{rcp}->{ts} = $ts;
    $op->{rcp}->{simd} = $simd;
    foreach my $qubit ( @{ $op->{args} } ) {
        push @moves, $qubit     if ( $qubit->rcp_fetch_qubit($ts, $simd, $op) );
    }
    return @moves;
}

# Store op's qubits if needed
# Return: list of qubits that need to move
sub rcp_store_op {
    my $op = shift;
    my $ts = shift;
    my @moves = ();
    foreach my $qubit ( @{ $op->{args} } ) {
        push @moves, $qubit     if ( $qubit->rcp_store_qubit($ts) );
    }
    return @moves;
}


package Schedule;

sub new {
    my $class = shift;
    my $obj = ();
    $obj->{function} = shift;
    bless $obj, $class;
    $obj->{twidth} = 0; # cell width for printing
    $obj->{threads} = 0; # max number of parallel ops
    $obj->{length} = 0;
    $obj->{top} = [];
    $obj->{bottom} = {};
    $obj->{first_op} = 0;
    $obj->{last_op} = 0;
    $obj->{op_cnt} = 0;
    $obj->{qubits} = ();
    $obj->{active_qubits} = {};
    $obj->{ops} = [];
    $obj->{asap} = {threads => 0};
    $obj->{alap} = {threads => 0};
    $obj->{ss} = $obj->new_ss();
    $obj->{lpfs} = $obj->new_lpfs();
    $obj->{rcp} = $obj->new_rcp();
    return $obj;
}

sub new_ss {
    my $obj = shift;
    my $k = shift || $::SIMD_K;
    my $d = shift || $::SIMD_D;
    return {
                    op_cnt      => 0,   # counts gates and moves
                    moves       => 0,   # counts each move op
                    mts         => 0,   # counts only timesteps with moves
                    len         => 0,   # total time
                    tgates      => 0,   # timesteps that have a T gate
                    width       => 0,   # max SIMD regions
                    simd_k      => $k,
                    simd_d      => $d
                  };
}

sub new_lpfs {
    my $obj = shift;
    my $k = shift || $::SIMD_K;
    my $d = shift || $::SIMD_D;
    my $l = shift || $::SIMD_L;
    my $refill = shift || $::refill;
    my $opp = shift || $::opp;
    foreach my $op ( @{ $obj->{ops} } ) { $op->{lpfs}->{followed} = 0; }
    return {
                    op_cnt      => 0,   # counts gates and moves
                    moves       => 0,   # counts each move op
                    mts         => 0,   # counts only timesteps with moves
                    len         => 0,   # total time
                    tgates      => 0,   # timesteps that have a T gate
                    width       => 0,   # max SIMD regions
                    simd_k      => $k,
                    simd_d      => $d,
                    simd_l      => $l,  # simd regions to allocate only to paths
                    refill_simd => $refill,
                    opp_simd    => $opp,
                    path        => 1    # starting path id
                  };
}

sub new_rcp {
    my $obj = shift;
    my $k = shift || $::SIMD_K;
    my $d = shift || $::SIMD_D;
    my $w_op = shift || $::w_op;
    my $w_dist = shift || $::w_dist;
    my $w_slack = shift || $::w_slack;
    return {
                    op_cnt  => 0,   # counts gates and moves
                    moves   => 0,   # counts each move op
                    mts     => 0,   # counts only timesteps with moves
                    len     => 0,   # last timestep
                    tgates  => 0,   # timesteps that have a T gate
                    width   => 0,   # max SIMD regions
                    simd_k  => $k,
                    simd_d  => $d,
                    w_op    => $w_op,
                    w_dist  => $w_dist,
                    w_slack => $w_slack
                  };
}

# Add an operation to the function
# Operation will be ASAP scheduled
sub add_op {
    my $obj = shift;
    my $op = shift;
    my $time = 0;
    my $dist = 1;
    push @{ $obj->{ops} }, $op;
    if ( $op->{top} ) {
        push @{ $obj->{top} }, $op;
        $op->{dist} = $dist;
    } else {
        foreach my $pre ( @{$op->{in_edges}} ) {
            print  "W: '$pre->{text}'\@$pre->{asap}->{ts} not assigned\n"  if ($pre->{asap}->{ts} == -1);
            $time = ($time, $pre->{asap}->{ts} + $pre->{length})[$time < $pre->{asap}->{ts} + $pre->{length}];
            $dist = ($dist, $pre->{dist} + 1)[$dist < $pre->{dist} + 1];
            $pre->{bottom} = 0  if ( $pre->{bottom} );
            delete $obj->{bottom}->{$pre};
        }
        $op->{dist} = $dist;
    }
    $obj->{bottom}->{$op} = $op   if ( $op->{bottom} );
    $op->{asap}->{ts} = $time;
    $op->{lpfs}->{dist} = $dist;
    push @{ $obj->{asap}->{$time} }, $op;
    #$obj->{asap}->{threads} = ::max ($obj->{asap}->{threads}, scalar @{ $obj->{asap}->{$time} });
    $obj->{first_op} = $op      if ( $obj->{asap}->{first_op} == 0 );
    $obj->{last_op} = $op;
    $obj->{twidth} = ::max ($obj->{twidth}, length $op->{text});
    $obj->{length} = ($obj->{length}, $time+$op->{length})[$obj->{length} < $time+$op->{length}];
    $obj->{asap}->{op_cnt}++;
    $obj->{op_cnt}++;
}

sub draw_graph {
    my $obj = shift;
    my $file = shift;
    my @colors = qw(white red orange yellow green blue indigo violet pink 
                    darkorange gold limegreen cyan navy magenta coral 
                    orangered darkgoldenrod chartreuse skyblue turquoise 
                    plum);
    open DOT, ">$file" or die "Unable to open Dot file $file\n";
    # Print some header stuff
    # Make the function name the root node and an "exit" node
    print DOT <<HEADING;
digraph $obj->{function} {
    graph [ rankdir=LR ];

    Top \t[ label=\"$obj->{function}\", rank=0 ];
    Bottom\t[ label=\"Return\", rank=$obj->{length} ];
HEADING
    # Loop over {ops} for all intermediate nodes
    foreach my $op ( @{ $obj->{ops} } ) {
        #print DOT "    $op->{id}\t[ label=\"$op->{op}\" ];\n";
        print DOT "    $op->{id}\t[ label=\"$op->{op}$op->{id}\"";
        print DOT ", style=filled, fillcolor=$colors[$op->{lpfs}->{path}]";
        print DOT ", rank=$op->{dist}";
        print DOT " ];\n";
    }
    print DOT "\n";
    # Loop over all qubits for each edge (safer than trying to infer/rebuild from op perspective)
    while ( my ($name, $qubit) = each %{ $obj->{qubits} } ) {
        my $last = {'id' => 'Top'};
        foreach my $op ( @{ $qubit->{ops} } ) {
            print DOT "    $last->{id} -> $op->{id}\t[ label=\"$name\" ];\n";
            $last = $op;
        }
        print DOT "    $last->{id} -> Bottom\t[ label=\"$name\" ];\n";
    }
    print DOT "}";
    close DOT;
}

# Start by sceduling all of the bottom-most times
# Then recursively call all available dependencies
sub alap {
    my $obj = shift;
    my @recurse = ();
    $obj->{alap}->{op_cnt} = 0;
    foreach my $op_ref ( keys $obj->{bottom} ) {
        my $op = $obj->{bottom}->{$op_ref};
        $op->{alap}->{sched} = 1;
        $op->{alap}->{ts} = $obj->{length} - $op->{length};
        $op->{slack} = $op->{alap}->{ts} - $op->{asap}->{ts};
        print "W: $op->{text} has negative slack $op->{slack} (ASAP: $op->{asap}->{ts}, ALAP: $op->{alap}->{ts})\n" if ( $op->{slack} < 0 );
        push @{ $obj->{alap}->{$op->{alap}->{ts}} }, $op;
        $obj->{alap}->{threads} = ::max ($obj->{alap}->{threads}, scalar @{ $obj->{alap}->{$op->{alap}->{ts}} });
        $obj->{alap}->{op_cnt}++;
        foreach my $pre ( @{ $op->{in_edges} } ) {
            my $next = 1;
            foreach my $dep ( @{ $pre->{out_edges} } ) {
                $next &= $dep->{alap}->{sched};
            }
            if ( $next ) {
                $pre->{alap}->{ts} = $obj->{length};
                # Search preferred to hash because most lists will be short 
                # (<3 elements, max <20)
                push(@recurse, $pre) unless grep{$_ == $pre} @recurse;
            }
        }
    }
    $obj->alap_recurse("alap",@recurse);
    if ($obj->{op_cnt} != $obj->{alap}->{op_cnt}) {
        print  "W: $obj->{function} op counts mismatch (Sched: $obj->{op_cnt}, ALAP: $obj->{alap}->{op_cnt})\n";
    }
}

sub alap_recurse {
    my $obj = shift;
    my $type = shift;
    my @recurse = ();
    foreach my $op ( @_ ) {
        $op->{$type}->{sched} = 1;
        foreach my $dep ( @{ $op->{out_edges} } ) {
            $op->{$type}->{ts} = min ($op->{$type}->{ts}, $dep->{$type}->{ts} - $op->{length});
        }
        if ($type eq "alap") {
            $op->{slack} = $op->{alap}->{ts} - $op->{asap}->{ts};
            print "W: $op->{text} has negative slack $op->{slack} (ASAP: $op->{asap}->{ts}, ALAP: $op->{alap}->{ts})\n" if ( $op->{slack} < 0 );
        }
        push @{ $obj->{$type}->{$op->{$type}->{ts}} }, $op;
        $obj->{$type}->{threads} = ::max ($obj->{$type}->{threads}, scalar @{ $obj->{$type}->{$op->{$type}->{ts}} });
        $obj->{$type}->{op_cnt}++;
        foreach my $pre ( @{ $op->{in_edges} } ) {
            my $next = 1;
            foreach my $dep ( @{ $pre->{out_edges} } ) {
                $next &= $dep->{$type}->{sched};
            }
            if ( $next ) {
                $pre->{$type}->{ts} = $obj->{length};
                # Search preferred to hash because most lists will be short (<3 elements)
                push(@recurse, $pre) unless grep{$_ == $pre} @recurse;
            }
        }
    }
    $obj->alap_recurse($type,@recurse)    if ( scalar @recurse );
}

# As Centered As Possble scheduling
sub acap {
    my $obj = shift;
    my $type = "acap";
    my $mid = $obj->{length} >> 1;  # divide by two, without decimal
    my @recurse = ();
    # Copy second half of ASAP schedule to end of ACAP schedule
    for (my $ts=$mid; $ts < $obj->{length}; $ts++) {
        foreach my $op ( @{ $obj->{asap}->{$ts} } ) {
            push @{ $obj->{$type}->{$ts} }, $op;
            $op->{$type}->{ts} = $ts;
            $op->{$type}->{sched} = 1;
            $obj->{$type}->{threads} = ::max ($obj->{$type}->{threads}, scalar @{ $obj->{$type}->{$ts} });
            $obj->{$type}->{op_cnt}++;
            # Build recursive list of next operations
            foreach my $pre ( @{ $op->{in_edges} } ) {
                if ( ! $pre->{acap}->{sched} ) {
                    my $next = 1;
                    foreach my $dep ( @{ $pre->{out_edges} } ) {
                        $next &= $dep->{$type}->{sched};
                    }
                    if ( $next ) {
                        $pre->{$type}->{ts} = $obj->{length};
                        # Search preferred to hash because most lists will be short 
                        # (<3 elements, max <20) and hashes are expensive in memory
                        push(@recurse, $pre) unless grep{$_ == $pre} @recurse;
                    }
                }
            }
        }
    }
    $obj->alap_recurse($type,@recurse)    if ( scalar @recurse );
}

# LPFS Longest Path First Scheduling. Performs a breadth first search to 
# find the longest path(s) in the graph and assign those directly to SIMD 
# regions. All other operations are scheduled to remaining SIMD regions 
# as available.
sub lpfs {
    my $obj = shift;
    my $ts = 0;
    my $op_cnt = 0; # only ops, no moves
    my $tgate = 0; # set if T/Tdag found
    my $t_cnt = 0; # count of timesteps with a T/Tdag
    my $width = 0;
    my $ready = {};
    my $simds = {};
    my $pathsearch = 1;    # 0 if all paths are discovered
    my $simd_l = $obj->{lpfs}->{simd_l};
    my $opp_simd = $obj->{lpfs}->{opp_simd};
    my $refill = $obj->{lpfs}->{refill_simd};
    # Find longest paths
    for ( my $i=1; $pathsearch and $i<=$simd_l; $i++ ) {
        @{ $simds->{$i} } = $obj->find_lp( $obj->{top} );
        $pathsearch = 0    if ( ! @{ $simds->{$i} } );
    }
    $ready = $obj->lpfs_init();
    while ( ( keys %$ready ) or $op_cnt < $obj->{op_cnt} ) {
        $tgate = 0;
        if ( $ts > $obj->{op_cnt} ) {
            print "E: LPFS timestep $ts > op count $obj->{op_cnt}. Aborting.\n";
            return;
        }
        my $next = {};
        # Schedule all assigned paths if ready
        foreach my $simd ( 1..$simd_l ) {
            if ( $pathsearch and $refill and ! scalar @{ $simds->{$simd} } ) {
                @{ $simds->{$simd} } = $obj->find_lp( ref values $ready );
                $pathsearch = 0    if ( ! @{ $simds->{$simd} } );
            }
            my $op = $simds->{$simd}->[0];
            if ( $obj->sched_op( "lpfs", $op, $ts, $simd ) ) {
                shift @{ $simds->{$simd} };
                $width = ($width,$simd)[$width < $simd];
                $op_cnt++;
                $tgate |= ( $op->{op} =~ /^(?:T|Tdag)$/ );
                # add opportunistic scheduling to a scehduled simd region already doing the same op
                if ( $opp_simd ) {
                    foreach ( $obj->lpfs_extract_optype( "lpfs", $op->{op}, $ready ) ) {
                        $obj->sched_op( "lpfs", $_, $ts, $simd );
                        $op_cnt++;
                    }
                }
            }
        }
        # Schedule any remaing ready tasks
        for ( my $simd=$simd_l+1; $simd<=$obj->{lpfs}->{simd_k}; $simd++ ) {
            # Remove all longest path ops from the front
            my $scheduled = 0;
            while ( ! $scheduled and ( keys $ready ) ) {
                my $id = 0;
                while ( $id = ::min(keys %$ready) and $ready->{$id}->{followed} ) {
                    print "W: followed!\n";
                    delete $ready->{$id};
                }
                if ( $opp_simd ) {
                    foreach ( $obj->lpfs_extract_optype( "lpfs", $ready->{$id}->{op}, $ready ) ) {
                        $obj->sched_op( "lpfs", $_, $ts, $simd );
                        $width = ($width,$simd)[$width < $simd];
                        $scheduled = 1;
                        $op_cnt++;
                        $tgate |= ( $_->{op} =~ /^(?:T|Tdag)$/ );
                    }
                } else {
                    $scheduled = $obj->sched_op( "lpfs", $ready->{$id}, $ts, $simd );
                    if ( $scheduled ) {
                        $op_cnt++;
                        $tgate |= ( $ready->{$id}->{op} =~ /^(?:T|Tdag)$/ );
                        delete $ready->{$id};
                        $width = ($width,$simd)[$width < $simd];
                    }
                }
            }
        }
        # Update data moves
        $obj->{lpfs}->{$ts}->{0} = $obj->update_moves("lpfs", $ts);
        # Update ready list
        $ready = $obj->lpfs_update_ready( $ts, $ready );
        $ts++;
        $t_cnt += $tgate;
    }
    print "E: ops mis-scheduled ($op_cnt out of $obj->{op_cnt})\n"   if ( $op_cnt != $obj->{op_cnt} );
    $obj->{lpfs}->{len} = $ts;
    $obj->{lpfs}->{tgates} = $t_cnt;
    $obj->{lpfs}->{width} = $width;
}

sub lpfs_init {
    my $obj = shift;
    my $ready = {};
    $obj->{lpfs}->{op_cnt} = 0;
    foreach $op ( @{ $obj->{top} } ) {
        $ready->{$op->{id}} = $op   if ( ! $op->{lpfs}->{followed} );
    }
    foreach my $op ( @{ $obj->{ops} } ) {
        $op->{lpfs}->{ts}    = -1;
        $op->{lpfs}->{simd}  = -1;
        $op->{lpfs}->{dist}  = 0;
        $op->{lpfs}->{tag}   = 0;
    }
    while ( my ($q, $qubit) = each %{ $obj->{qubits} } ) {
        $qubit->{loc}       = 0;
        $qubit->{last_op}   = -1;
    }
    return $ready;
}

sub lpfs_update_ready {
    my $obj = shift;
    my $ts = shift;
    my $ready = shift;
    my $next = {};
    foreach my $simd ( keys %{ $obj->{lpfs}->{$ts} } ) {
        if ( $simd != 0 ) {
            foreach my $op ( @{ $obj->{lpfs}->{$ts}->{$simd} } ) {
                foreach my $child ( $op->get_ready_children("lpfs") ) {
                    $ready->{$child->{id}} = $child    if ( ! $child->{lpfs}->{followed} );
                }
            }
        }
    }
    return $ready;
}

sub lpfs_extract_optype {
    my $obj = shift;
    my $sched = shift;
    my $optype = shift;
    my $ready = shift;
    my @ret = ();
    my $cnt = 0;
    foreach $id ( keys %$ready ) {
        if ( $ready->{$id}->{op} eq $optype and $cnt < $obj->{$sched}->{simd_d} ) {
            push @ret, $ready->{$id};
            delete $ready->{$id};
            $cnt++;
        }
    }
    return @ret;
}


sub find_lp {
    my $obj = shift;
    my $top = shift;
    return ()   if ( ! @$top );
    my @path = ();
    my $id = 0x7fffffff;
    my $op = ();
    foreach my $op ( @{ $obj->{ops} } ) {
        $op->{lpfs}->{dist} = 1     if ( ! $op->{lpfs}->{followed} );
    };
    foreach $op ( @$top ) {
        $id = ($id, $op->{id})[$id > $op->{id}];
    };
    foreach $op ( @{ $obj->{ops} } ) {
        if ( $op->{id} >= $id ) {
            if ( $op->{lpfs}->{followed} ) {
                $op->{lpfs}->{dist} = 0;
            } else {
                foreach my $child ( @{ $op->{out_edges} } ) {
                    my $dist = $op->{lpfs}->{dist} + 1;
                    $child->{lpfs}->{dist} = ($dist, $child->{lpfs}->{dist})[$dist < $child->{lpfs}->{dist}]
                }
            }
            $path[0] = $op  if ( ! $op->{lpfs}->{followed} 
                                 and $op->{lpfs}->{dist} > $path[0]->{lpfs}->{dist} );
        }
    }
    return  if ( ! @path );
    PATH: while ( $path[0]->{lpfs}->{dist} > 1 ) {
        my $dist = $path[0]->{lpfs}->{dist} - 1;
        $path[0]->take_path( $obj->{lpfs}->{path} );
        foreach my $parent ( @{ $path[0]->{in_edges} } ) {
            if ( $parent->{lpfs}->{dist} == $dist ) {
                unshift @path, $parent;
                next PATH;
            }
        }
        print "E: unable to find path from $path[0]->{text} (dist: $path[0]->{lpfs}->{dist})\n";
    }
    $path[0]->take_path( $obj->{lpfs}->{path} );
    $obj->{lpfs}->{path}++;
    return @path;
}

sub find_lp_orig {
    my $obj = shift;
    my $top = shift;
    return ()   if ( ! @$top );
    my $next = ();
    my $curr = ();
    my $tag = 0;
    my @path = ();
    my $ops = 0;
    my $children = 0;
    my $parents = 0;
    my $acc = 0;
    my $maxfan = 0;
    @$next = @$top; # copy list instead of modifying
    # Reset all distances before recomputing
    foreach my $op ( @{ $obj->{ops} } ) {
        $op->{lpfs}->{dist} = 1     if ( ! $op->{lpfs}->{followed} );
        $op->{lpfs}->{tag} = 0;
    };
    while ( (my $len = scalar @$next) > 0 ) {
        $acc += $len;
        $max_fan = ($max_fan, $len)[$max_fan < $len];
        $tag++;
        $curr = $next;
        $next = ();
        foreach my $op ( @{ $curr } ) {
            $ops++;
            my $dist = $op->{lpfs}->{dist} + 1;
            foreach my $child ( @{ $op->{out_edges} } ) {
                $children++;
                if ( ! $child->{lpfs}->{followed} ) {
                    $child->{lpfs}->{dist} = ($dist, $child->{lpfs}->{dist})[$dist < $child->{lpfs}->{dist}];
                }
                if ( ! $child->{lpfs}->{tag} ) {
                    $child->{lpfs}->{tag} = $tag;
                    push @$next, $child;
                }
            }
            $path[0] = $op  if ( ! $op->{lpfs}->{followed} 
                                 and $op->{lpfs}->{dist} > $path[0]->{lpfs}->{dist} );
        }
        print "Total ops: $obj->{op_cnt}; visited ops: $ops; children: $children; parents: $parents\n";
        print "Levels: $tag; avg: ".($acc/$tag)."; max: $max_fan\n";
    }
    return  if ( ! @path );
    PATH: while ( $path[0]->{lpfs}->{dist} > 1 ) {
        my $dist = $path[0]->{lpfs}->{dist} - 1;
        $path[0]->take_path( $obj->{lpfs}->{path} );
        foreach my $parent ( @{ $path[0]->{in_edges} } ) {
            $parents++;
            if ( $parent->{lpfs}->{dist} == $dist ) {
                unshift @path, $parent;
                $dist--;
                next PATH;
            }
        }
        print "E: unable to find path from $path[0]->{text} (dist: $path[0]->{lpfs}->{dist})\n";
    }
    if ( $::DEBUG > 20 ) {
        print "Total ops: $obj->{op_cnt}; visited ops: $ops; children: $children; parents: $parents\n";
        print "Levels: $tag; avg: ".($acc/$tag)."; max: $max_fan\n";
    }
    $path[0]->take_path( $obj->{lpfs}->{path} );
    $obj->{lpfs}->{path}++;
    return @path;
}

sub sched_op {
    my $obj = shift;
    my $sched = shift;
    my $op = shift;
    my $ts = shift;
    my $simd = shift;
    if ( defined $op and $op->op_ready($sched) ) {
        push @{ $obj->{$sched}->{$ts}->{$simd} }, $op;
        $obj->{$sched}->{op_cnt}++;
        $op->{$sched}->{simd} = $simd;
        $op->{$sched}->{ts} = $ts;
        $op->{$sched}->{followed} = 1   if ( $sched eq "lpfs" );
        return 1;
    }
    return 0;
}

sub extract_optype {
    my $obj = shift;
    my $sched = shift;
    my $optype = shift;
    my $ready = shift;
    my $i = 0;
    # Sort the ready list by optype and scan for start and end of desired optype
    @$ready = sort {$a->{op} cmp $b->{op}} @$ready;
    while ( $i < scalar @$ready and $ready->[$i]->{op} ne $optype ) { $i++; }
    return  if ( $i >= scalar @$ready );
    my $s = $i;
    # Make sure that we don't schedule too many ops to the SIMD region
    my $size = scalar @{ $ready->[$i]->{args} };
    my $cnt = $size;
    while ( $i < scalar @$ready 
            and $ready->[$i]->{op} eq $optype 
            and $cnt+$size < $obj->{$sched}->{simd_d} ) {
        $i++;
        $cnt += $size;
    }
    my $l = $i - $s;
    return splice @$ready, $s, $l;
}

sub update_moves {
    my $obj = shift;
    my $sched = shift;
    my $ts = shift;
    my $s = $obj->{$sched};
    my $simd = 1;
    my $op = ();
    my $qubit = ();
    my $moves = ();
    my $active = $obj->{active_qubits};
    my $curr = {};
    my $next = {};
    my @simd_active = (0) x ($s->{simd_k}+1);
    # Get all current 
    foreach $simd ( 1..$s->{simd_k} ) {
        $simd_active[$simd] = 1  if ( scalar @{ $s->{$ts}->{$simd} } );
        foreach $op ( @{ $s->{$ts}->{$simd} } ) {
            foreach $qubit ( @{ $op->{args} } ) {
                $curr->{$qubit->{name}} = $simd;
            }
        }
    }
    foreach my $name ( keys %$active ) {
        my $src = $active->{$name};
        my $dst = $curr->{$name} || 0;
        if ( $dst ) {
            # qubit is reused, keep it
            $next->{$name} = $dst;
            delete $curr->{$name};  # remove for fetching
        }
        if ( ! $dst and ! $simd_active[ $src ] ) {
            # Qubit doesn't need to move
            $next->{$name} = $src;
        }
        if ( ( ( $dst ) and $dst != $src )
             or ( ( ! $dst ) and $simd_active[ $src ] ) ) {
            # Moved into new location or SIMD is active and need to move to memory
            $qubit = $obj->{qubits}->{$name};
            push @$moves, bless({
                'op'    => 'MOV',
                'src'   => $src,
                'dst'   => $dst,
                'text'  => "MOV $dst $src $name",
                'args'  => [$qubit]
            },'Op');
            $qubit->{loc} = $dst;
            $s->{op_cnt}++;
            $s->{moves}++;
        }
    }
    foreach my $name ( keys %$curr ) {
        # Qubit not active, fetch from mem
        my $dst = $curr->{$name};
        $next->{$name} = $dst;
        $qubit = $obj->{qubits}->{$name};
        push @$moves, bless({
            'op'    => 'MOV',
            'src'   => 0,
            'dst'   => $dst,
            'text'  => "MOV $dst 0 $name",
            'args'  => [$qubit]
        },'Op');
        $qubit->{loc} = $dst;  # Qubit moved to SIMD
        $s->{op_cnt}++;
        $s->{moves}++;
    }
    $s->{mts}++     if ( @$moves );
    $obj->{active_qubits} = $next;
    @$moves = sort { $a->{text} cmp $b->{text} } @$moves;
    return $moves;
}

sub update_moves_hold_for_stall {
    my $obj = shift;
    my $sched = shift;
    my $ts = shift;
    my $s = $obj->{$sched};
    my $simd = 1;
    my $op = ();
    my $qubit = ();
    my $moves = ();
    my $curr = {};
    my $prev = {};
    foreach $simd ( 1..$s->{simd_k} ) {
        my $pts = $ts-1;
        # Find previous non-empty timestep for this simd region
        while ( $pts >= 0 and ! scalar @{ $s->{$pts}->{$simd} } ) { $pts--; }
        # get all previous qubits
        if ( $pts >= 0 ) {
            foreach $op ( @{ $s->{$pts}->{$simd} } ) {
                foreach $qubit ( @{ $op->{args} } ) {
                    $prev->{$qubit->{name}} = $qubit->{loc};
                }
            }
        }
        # get all current qubits
        foreach $op ( @{ $s->{$ts}->{$simd} } ) {
            foreach $qubit ( @{ $op->{args} } ) {
                $curr->{$qubit->{name}} = [ $simd, $qubit->{loc} ]; #dst, src
            }
        }
    }
    foreach my $name ( sort keys %$curr ) {
        my $src = $curr->{$name}->[1];
        my $dst = $curr->{$name}->[0];
        $qubit = $obj->{qubits}->{$name};
        if ( $src != $dst ) {
            push @$moves, bless({
                'op'    => 'MOV',
                'src'   => $src,
                'dst'   => $dst,
                'args'  => ($qubit),
                'text'  => "MOV $dst $src $name",
                'args'  => [$qubit]
            },'Op');
            $qubit->{loc} = $dst;  # Qubit moved to SIMD
            $obj->{$sched}->{op_cnt}++;
            $obj->{$sched}->{moves}++;
        }
        delete $prev->{$name}   if ( exists $prev->{$name} );
    }
    foreach my $name ( sort {$b cmp $a} keys %$prev ) {
        my $src = $prev->{$name};
        my $dst = 0;
        $qubit = $obj->{qubits}->{$name};
        if ( @{ $s->{$ts}->{$src} } ) {
            push @$moves, bless({
                'op'    => 'MOV',
                'src'   => $src,
                'dst'   => $dst,
                'args'  => ($qubit),
                'text'  => "MOV $dst $src $name",
                'args'  => [$qubit]
            },'Op');
            $qubit->{loc} = $dst;  # Qubit moved to SIMD
            $obj->{$sched}->{op_cnt}++;
            $obj->{$sched}->{moves}++;
        }
    }
    $obj->{$sched}->{mts}++     if ( @$moves );
    @$moves = sort { $a->{text} cmp $b->{text} } @$moves;
    return $moves;
}

sub update_moves_orig {
    my $obj = shift;
    my $sched = shift;
    my $ts = shift;
    my $moves = ();
    my $prev = {};
    # Get qubits from previous timestep
    if ( $ts > 0 ) {
        foreach my $simd ( sort keys %{ $obj->{$sched}->{$ts-1} } ) {
            if ( $simd > 0 and scalar @{ $obj->{$sched}->{$ts}->{$simd} } ) {
                foreach my $op ( @{ $obj->{$sched}->{$ts-1}->{$simd} } ) {
                    foreach my $qubit ( @{ $op->{args} } ) {
                        $prev->{$qubit->{name}} = $qubit;
                    }
                }
            }
        }
    }
    foreach my $simd ( sort keys %{ $obj->{$sched}->{$ts} } ) {
        foreach my $op ( @{ $obj->{$sched}->{$ts}->{$simd} } ) {
            foreach my $qubit ( @{ $op->{args} } ) {
                delete $prev->{$qubit->{name}}; # remove if used in previous timestep
                if ( $qubit->{loc} == -1 ) {
                    #print STDERR "alloc\n";
                    $qubit->{loc} = $simd;  # Qubit allocated to first SIMD use
                } elsif ( $qubit->{loc} != $simd ) {
                    #print STDERR "moved#\n";
                    push @$moves, {
                        'op'    => 'MOV',
                        'src'   => $qubit->{loc},
                        'dst'   => $simd,
                        'args'  => ($qubit),
                        'text'  => "MOV $simd $qubit->{loc} $qubit->{name}",
                        'args'  => [$qubit]
                    };
                    $qubit->{loc} = $simd;  # Qubit moved to SIMD
                    $obj->{$sched}->{op_cnt}++;
                    $obj->{$sched}->{moves}++;
                }
            }
        }
    }
    # Any remaining qubits from previous timestep should be moved to memory
    foreach my $q ( keys %$prev ) {
        my $qubit = $prev->{$q};
        push @$moves, {
            'text'  => "MOV 0 $qubit->{loc} $qubit->{name}",
            'args'  => [$qubit]
        };
        $qubit->{loc} = 0;  # Qubit moved to memory
        $obj->{$sched}->{op_cnt}++;
        $obj->{$sched}->{moves}++;
    }
    $obj->{$sched}->{mts}++     if ( @$moves );
    return $moves;
}

sub print_rcpq {
    my $obj = shift;
    foreach my $op ( @{ $obj->{rcp}->{rcpq} } ) {
        print "$op->{text}\n";
    }
}

sub rcp {
    my $obj = shift;
    my $s = $obj->{rcp};
    my $ts = 0;
    my $op_cnt = 0; # Track gates ops (not moves) scheduled
    my %simds = ();
    my $tgate = 0;
    my $t_cnt = 0;
    my $rcpq = $obj->rcp_init();
    while ( ( keys %{ $rcpq } ) && $op_cnt < $obj->{op_cnt} ) {
        $tgate = 0;
        if ( $ts > $obj->{op_cnt} ) {
            print "E: RCP timestep $ts > op count $obj->{op_cnt}. Aborting.\n";
            return;
        }
        #if ( $::DEBUG > 50 ) {
        #    print "\nRCPQ @ $ts\n-------------\n";
        #    $obj->print_rcpq();
        #}
        foreach ( 1..$s->{simd_k} ) { $simds{$_} = 1; }
        while ( scalar keys %{ $rcpq } && scalar keys %simds ) {
            my $simd = $obj->rcp_sched_next_simd( $rcpq, $ts, keys %simds );
            $op_cnt += scalar @{ $s->{$ts}->{$simd} };
            $tgate |= ( $s->{$ts}->{$simd}->[0]->{op} =~ /^(?:T|Tdag)$/ );
            delete $simds{$simd};
        }
        print "E: Scheduled too many ops ($op_cnt instead of $obj->{op_cnt})\n" if ( $op_cnt > $obj->{op_cnt} );
        $s->{$ts}->{0} = $obj->update_moves( "rcp", $ts );
        $rcpq = $obj->rcpq_update( $ts, $rcpq );
        $ts++;
        $t_cnt += $tgate
    }
    $s->{len} = $ts;
    $s->{width} = $obj->{rcp}->{simd_k};
    $s->{tgates} = $t_cnt;
}

# Initialize RCPQ
# Update: RCPQ
sub rcp_init {
    my $obj = shift;
    my $s = $obj->{rcp};
    my $rcpq = ();
    # copy top to RCPQ
    $s->{op_cnt} = 0;
    foreach my $op ( @{ $obj->{top} } ) {
        $rcpq->{$op->{id}} = $op;
    }
    foreach my $op ( @{ $obj->{ops} } ) {
        $s->{ts}    = -1;
        $s->{simd}  = -1;
    }
    while ( my ($q, $qubit) = each %{ $obj->{qubits} } ) {
        $qubit->{loc}       = 0;
        $qubit->{last_op}   = -1;
    }
    return $rcpq;
}

# Calculate all weights in the RCPQ
# Input: available SIMD regions
# Return: \%{$simd} = {$max, $op, %weights{op} = $weight}
sub rcp_calc_weights {
    my $obj = shift;
    my $rcpq = shift;
    my $ret = {};
    # init $ret
    foreach my $simd (@_) {
        $ret->{$simd} = {
                            max => -2**63,  # set to very low value
                            op  => ''
                        };
    }
    foreach my $op ( values %$rcpq ) {
        my $tmp = $obj->rcp_op_weight( $op, @_ );
        while ( my ($simd, $weight) = each %$tmp ) {
            my $tmp = $ret->{$simd};
            $tmp->{ $op->{op} } += $weight;
            if ( $tmp->{ $op->{op} } > $tmp->{max} ) {
                $tmp->{max} = $tmp->{ $op->{op} };
                $tmp->{op} = $op->{op};
            }
        }
    }
    return $ret;
}

# Calculate operation weight for a simd region
# Inputs: $op = Op, @simd = available SIMD regions
# Return: $weight
sub rcp_op_weight {
    my $obj = shift;
    my $op = shift;
    my $w_op = $obj->{rcp}->{w_op};
    my $w_slack = $obj->{rcp}->{w_slack};
    my $w_dist = $obj->{rcp}->{w_dist};
    my $ret = {};
    foreach my $simd (@_) {
            # Weight for the communication distance
            my $dist = 1;
            foreach my $qubit ( @{ $op->{args} } ) {
                # Check that all qubits are in the current simd region
                $dist &= ($qubit->{loc} == -1 || $qubit->{loc} == $simd);
            }
            my $weight = $w_op +
                         $w_slack * $op->{slack} +
                         $w_dist * $dist;
            #$op->{rcp}->{simd_weight}->{$simd} = $weight;
            $ret->{$simd} = $weight;
    }
    return $ret;
}

# Get the next highest SIMD weight
# Input: timestep
# Side-effect: Schedule next highest SIMD region to timestep
#   $obj->{rcp}->{$ts}->{$simd} is populated
# Return: SIMD region populated
sub rcp_sched_next_simd {
    my $obj = shift;
    my $rcpq = shift;
    my $ts = shift;
    my $weights = $obj->rcp_calc_weights( $rcpq, @_ );
    # Sort by highest weight, then by lowest simd_k region
    my $simd = (sort { $weights->{a}->{max} <=> $weights->{b}->{max} || $a <=> $b } keys %$weights )[0];
    print "E: $simd already scheduled at timestep $ts!\n"  if ( @{ $obj->{rcp}->{$ts}->{$simd} } );
    foreach my $op ( $obj->rcpq_extract_optype( $rcpq, $weights->{$simd}->{op} ) ) {
        $obj->sched_op( "rcp", $op, $ts, $simd );
    }
    return $simd;
}

# Gets all operations of the requested type from the RCPQ and removes matches 
# from RCPQ
# Input: $optype
# Update: RCPQ
# Return: \@ = [Op]
sub rcpq_extract_optype {
    my $obj = shift;
    my $rcpq = shift;
    my $optype = shift;
    my $i = 0;
    my $size = 0;
    my $simd_d = $obj->{rcp}->{simd_d};
    my @ret = ();
    while ( ( my ($id, $op) = each %$rcpq ) and
            $size * ( 1 + scalar @ret ) < $simd_d ) {
        if ( $op->{op} eq $optype ) {
            $size |= scalar @{ $op->{args} };
            push @ret, $op;
            delete $rcpq->{$id};
        }
    }
    return @ret;
    # Sort the RCPQ by optype and scan for start and end of desired optype
    #@{$obj->{rcp}->{rcpq}} = sort {$a->{op} cmp $b->{op}} @{ $obj->{rcp}->{rcpq} };
    #while ( $i < scalar @{$obj->{rcp}->{rcpq}} and $obj->{rcp}->{rcpq}->[$i]->{op} ne $optype ) { $i++; }
    #my $s = $i;
    ## Make sure that we don't schedule too many ops to the SIMD region
    #my $size = scalar @{ $obj->{rcp}->{rcpq}->[$i]->{args} };
    #my $cnt = $size;
    #while ( $i < scalar @{$obj->{rcp}->{rcpq}} 
    #        and $obj->{rcp}->{rcpq}->[$i]->{op} eq $optype 
    #        and $cnt+$size < $obj->{rcp}->{simd_d} ) {
    #    $i++;
    #    $cnt += $size;
    #}
    #my $l = $i - $s;
    #return splice @{$obj->{rcp}->{rcpq}}, $s, $l;
}

# Checks all scheduled ops and adds them to the RCPQ
# Input: $ts, $rcpq pointer
# Update: RCPQ
# Return: null
sub rcpq_update {
    my $obj = shift;
    my $ts = shift;
    my $rcpq = shift;
    my $s = $obj->{rcp};
    my $simd_k = $s->{simd_k};
    foreach my $simd ( 1..$simd_k ) {
        foreach my $op ( @{ $s->{$ts}->{$simd} } ) {
            foreach my $child ( $op->get_ready_children("rcp") ) {
                $rcpq->{$child->{id}} = $child;
            }
        }
    }
    return $rcpq;
}

# Determine fetches from memory and other simd regions
# Input: current timestep and SIMD region
# Side-effect: propagates scheduling to operations
# Output: @[Qubit] = all qubits moving to SIMD region
sub rcp_simd_fetch {
    my $obj = shift;
    my $ts = shift;
    my $simd = shift;
    my @qubits = ();
    foreach my $op ( @{ $obj->{rcp}->{$ts}->{$simd} } ) {
        push @qubits, $op->rcp_fetch_op( $ts, $simd );
    }
    return @qubits;
}

# Determine stores to memory
# NOTE: must be run after rcp_simd_fetch - depends on scheduling information 
#       for current cycle
# Input: current timestep
# Output: @[Qubit] = all qubits moving out of SIMD region
sub rcp_simd_store {
    my $obj = shift;
    my $ts = shift;
    my $simd = shift;
    my @qubits = ();
    # look at the previous cycle's ops in the simd region and remove the ones
    # that aren't scheduled for this cycle
    $ts--;
    if ( exists $obj->{rcp}->{$ts} ) {
        foreach my $op ( @{ $obj->{rcp}->{$ts}->{$simd} } ) {
            push @qubits, $op->rcp_store_op( $ts );
        }
    }
    return @qubits;
}

sub ss_init {
    my $obj = shift;
    foreach my $op ( @{ $obj->{ops} } ) {
        $op->{ss}->{ts}     = -1;
        $op->{ss}->{simd}   = -1;
    }
    while ( my ($q, $qubit) = each %{ $obj->{qubits} } ) {
        $qubit->{loc}       = 0;
        $qubit->{last_op}   = -1;
    }
}

sub ss {
    my $obj = shift;
    my $ss = $obj->{ss};
    my $len = 0;
    my $width = 0;
    $obj->ss_init();
    foreach my $op ( @{ $obj->{ops} } ) {
        my $ts = $op->{rank}-1;
        my $simd = 1;
        my $done = 0;
        while ( ! $done and $simd <= $ss->{simd_k} ) {
            if ( ! @{ $ss->{$ts}->{$simd} } 
                 or ( scalar @{ $ss->{$ts}->{$simd} } < $ss->{simd_d}
                 and $ss->{$ts}->{$simd}->[0]->{op} eq $op->{op} ) ) {
                $done = $obj->sched_op( "ss", $op, $ts, $simd );;
                $width = ($width, $simd)[$width < $simd]    if ($done);
            }
            $simd++;
        }
        print "E: unable to place $op->{text} at $ts\n"     if ( ! $done );
        $len = ::max($len, $ts+1);
    }
    for ( my $ts=0; $ts < $len; $ts++ ) {
        $ss->{$ts}->{0} = $obj->update_moves("ss", $ts);
    }
    $ss->{len} = $len;
    $ss->{width} = $width;
    $obj->tgate_cnt("ss");
}

sub tgate_cnt {
    my $obj = shift;
    my $sched = shift;
    my $s = $obj->{$sched};
    my $tgate = 0;
    my $t_cnt = 0;
    foreach my $ts ( 0..( $s->{len}-1 ) ) {
        $tgate = 0;
        foreach my $simd ( 1..$s->{simd_k} ) {
            if ( defined $s->{$ts}->{$simd}->[0] and
                 $s->{$ts}->{$simd}->[0]->{op} =~ /^(?:T|Tdag)$/ ) {
                $tgate = 1;
            }
        }
        $t_cnt += $tgate;
    }
    $s->{tgates} = $t_cnt;
}

sub cpr {
    my $obj = shift;
    my $threshold = shift || 4;
    my @qconflicts = ();
    my @conflicts = ();
    my %stats = (
        'count'     => 0,
        'mean'      => 0,
        'median'    => 0,
        'mode'      => 0,
        'mode_cnt'  => 0,
        'hist'      => {},
        'var'       => 0,
        'min'       => 2147483647,
        'max'       => 0,
        'range'     => 0,
        'acc'       => 0,
        'raw'       => []
    );
    # Calculate cpr for each qubits' ops, collect intermediate stats on the way
    foreach my $qref ( keys %{ $obj->{qubits} } ) {
        my $qubit = $obj->{qubits}->{$qref};
        $qubit->{cpr}->[0] = 0;
        $qubit->{last_op} = 0;
        for ( my $i=1; $i<scalar @{ $qubit->{ops} }; $i++ ) {
            $qubit->{cpr}->[$i] = $qubit->{ops}->[$i]->{asap}->{ts} - $qubit->{ops}->[$i-1]->{asap}->{ts};
            $stats{acc} += $qubit->{cpr}->[$i];
            push @{ $stats{raw} }, $qubit->{cpr}->[$i];
            $stats{min} = ::min( $stats{min}, $qubit->{cpr}->[$i] );
            $stats{max} = ::max( $stats{max}, $qubit->{cpr}->[$i] );
            $stats{count}++;
        }
        if ( scalar @{$qubit->{cpr}} != scalar @{$qubit->{ops}} ) {
            printf "Warning: CPR count doesn't match op count (%d != %d)\n", scalar @{$qubit->{cpr}}, scalar @{$qubit->{ops}};
        }
    }
    # Calculate remaining stats
    if ( $stats{count} > 0 ) {
        $stats{mean} = $stats{acc} / $stats{count};
        $stats{median} = $stats{raw}->[int ( $stats{count}/2 + 0.5 )];
        foreach my $cpr ( @{ $stats{raw} } ) {
            $stats{var} += (abs ($cpr - $stats{mean}))**2;
            $stats{hist}->{$cpr}++;
            if ( $stats{hist}->{$cpr} > $stats{mode_cnt} ) {
                $stats{mode} = $cpr;
                $stats{mode_cnt} = $stats{hist}->{$cpr};
            }
        }
        $stats{var} /= $stats{count};
        $stats{range} = $stats{max} - $stats{min};
    }
    # Check ops for conflicts
    foreach my $ts ( sort {$a <=> $b} keys %{ $obj->{asap} } ) {
        if ( $ts =~ /^-?\d+$/ ) {
            foreach my $op ( @{ $obj->{asap}->{$ts} } ) {
                # If there are more than two arguments, check for a move conflict
                if ( scalar @{ $op->{args} } > 1 ) {
                    # Foreach qubit, check that the CPR value for the current operation is below the threshold and add it to @qconflict
                    foreach my $qubit ( @{ $op->{args} } ) {
                        my $idx = $qubit->{last_op};
                        if ( ::refaddr($op) == ::refaddr($qubit->{ops}->[$idx]) ) {
                            $qubit->{last_op}++;
                        } else {
                            # Start at next index and search through list - it's probably after the current one, not before
                            $idx++;
                            while ( $idx != $qubit->{last_op} && ::refaddr($op) != ::refaddr($qubit->{ops}->[$idx]) ) {
                                $idx = ($idx + 1) % scalar @{ $qubit->{ops} };
                            }
                            die "Qubit $qubit->{name} not found in operation '$op->{text}'\n"   if ( $idx == $qubit->{last_op} );
                            $qubit->{last_op} = $idx+1;
                        }
                        push @qconflicts, $qubit    if ( $qubit->{cpr}->[$idx] > 0 && $qubit->{cpr}->[$idx] <= $threshold );
                    }
                    # If $#qconflict > 0, add operation to @conflict
                    push @conflicts, $op    if ( scalar @qconflicts > 1 );
                }
                undef @qconflicts;  # free memory
            }
        }
    }
    # Print results
    my $msg = "$obj->{function}:";
    print "$msg\n";
    $msg =~ s/./-/g;
    print "$msg\n";
    foreach ( qw(mean median mode var range) ) { printf "%9s = %d\n", $_, $stats{$_}; }
    print "Histogram:\n";
    foreach ( sort {$a <=> $b} keys %{ $stats{hist} } ) { printf "%9s = %d\n", $_, $stats{hist}->{$_}; }
    printf "%s (%d / %d):\n", "conflicts", scalar @conflicts, $obj->{op_cnt};
    foreach my $op ( @conflicts ) { print "    $op->{text}\n"; }
    print "\n";
}

sub sched_check {
    my $obj = shift;
    my $type = shift || "asap";
    foreach my $ts ( sort keys %{ $obj->{$type} } ) {
        if ( $ts =~ /^-?\d+$/ ) {
            foreach my $op ( @{ $obj->{$type}->{$ts} } ) {
                foreach my $pre ( @{ $op->{in_edges} } ) {
                    print  "E: Dependency error; '$op->{text}'\@$op->{$type}->{ts}, not after '$pre->{text}'\@$pre->{$type}->{ts}\n"
                            if ( $pre->{$type}->{ts} >= $op->{$type}->{ts} );
                }
            }
        }
    }
}

sub header_print {
    my $obj = shift;
    my $sched = shift;
    my $msg = "Function: $obj->{function} ";
    $msg .= "(sched: $sched, op_cnt: $obj->{$sched}->{op_cnt}, ";
    $msg .= "k: $obj->{$sched}->{simd_k}, d: $obj->{$sched}->{simd_d}";
    $msg .= ", l: $obj->{$sched}->{simd_l}"           if ( $sched eq "lpfs" );
    $msg .= ", opp: $obj->{$sched}->{opp_simd}"       if ( $sched eq "lpfs" );
    $msg .= ", refill: $obj->{$sched}->{refill_simd}" if ( $sched eq "lpfs" );
    $msg .= ", w_op: $obj->{$sched}->{w_op}"          if ( $sched eq "rcp" );
    $msg .= ", w_dist: $obj->{$sched}->{w_dist}"      if ( $sched eq "rcp" );
    $msg .= ", w_slack: $obj->{$sched}->{w_slack}"    if ( $sched eq "rcp" );
    $msg .= ")";
    print "$msg\n";
    $msg =~ s/./=/g;
    print "$msg\n";
}

sub metrics_print {
    my $obj = shift;
    my $sched = shift;
    my $s = $obj->{$sched};
    my $k = $s->{simd_k};
    my $d = $s->{simd_d};
    my $w = $s->{width};
    my $ops = $s->{op_cnt} - $s->{moves};
    my $t1 = $obj->{op_cnt} * 2.0;
    my $w1 = $obj->{op_cnt} * 3.0;
    my $tinf = $obj->{length}; # inf means no comms.?
    my $tk = $s->{tk} = $s->{len} + 4*$s->{mts};
    my $wk = $s->{wk} = $s->{op_cnt};
    my $sk = $s->{sk} = $t1 / $tk;
    my $ek = $s->{ek} = $t1 / ($k * $tk);
    my $uk = $s->{uk} = $wk / ($k * $tk);
    my $qk = $s->{qk} = $t1**3 / ($k * $tk**2 * $wk);
    my $ck = $s->{ck} = 100.0 * $s->{moves} / $s->{op_cnt};
    my $sav = 200/3 - $ck;
    my $avg = $s->{avg} = ($s->{mts}) ? $s->{moves} / $s->{mts} : "inf";
    my $max = 0;
    my @moves = ();
    foreach my $ts ( 0..($s->{len} - 1) ) {
        push( @moves, scalar @{ $s->{$ts}->{0} } );
        $max = ( $max, $moves[-1] )[$max < $moves[-1]];
    }
    $s->{max} = $max;
    print "ops = $ops\n";
    print "moves = $s->{moves}\n";
    print "total = $s->{op_cnt}\n";
    print "ots = $s->{len}\n";
    print "mts = $s->{mts}\n";
    print "ts = $tk\n";
    print "SIMDs = $w\n";
    print "tgates = $s->{tgates}\n";
    print "T(1) = $t1\n";
    print "T(inf) = $tinf\n";
    print "T($k,$d) = $tk\n";
    print "Speedup = $sk\n";
    print "Efficiency = $ek\n";
    print "Utility = $uk\n";
    print "Quality = $uk\n";
    print "Overhead = $ck% (reduction: $sav)\n";
    print "Avg load = $avg\n";
    print "Peak load = $max\n";
    print "mlist = ".(join " ", @moves)."\n";
    print "\n";
}

sub sched_print {
    my $obj = shift;
    my $sched = shift;
    my $op_cnt = 0;
    my $i = 0;
    foreach my $ts ( 0..$obj->{$sched}->{len} ) {
        foreach my $simd ( 0..$obj->{$sched}->{simd_k} ) {
            foreach my $op ( sort { $a->{text} cmp $b->{text} } @{ $obj->{$sched}->{$ts}->{$simd} } ) {
                print "$ts,$simd $op->{text}\n";
                $op_cnt++;
            }
        }
    }
    print "E: Printed $op_cnt, expected $obj->{$sched}->{op_cnt}\n"  if ( $op_cnt != $obj->{$sched}->{op_cnt} );
    print "\n";
}

sub sched_pretty_print {
    my $obj = shift;
    my $sched = shift;
    my $op_cnt = 0;
    my $i = 0;
    my $cw = 1 + $obj->{twidth};
    my @ts = undef;
    if ( @_ ) {
        @ts = @_;
    } else {
        @ts = sort {$a <=> $b} keys %{ $obj->{$sched} };
    }
    my $at = ::max( 4, length sprintf "%d", $ts[-1] ); # 4 is length of string "Time"
    # Print column headings
    $msg = sprintf "%${at}s | %-${cw}s", "Time", "Moves";
    for ($i=1; $i<=$obj->{$sched}->{simd_k}; $i++) {
        $msg .= sprintf "| %-${cw}s", "SIMD $i";
    }
    print "$msg\n";
    $msg =~ s/./-/g;
    print "$msg\n";
    foreach my $time ( @ts ) {
        if ( $time =~ /^-?\d+$/ ) {
            my $rows = 0;
            my $ts = $time;
            # Determine number of rows that will be printed for this timestep
            for ($i=0; $i<=$obj->{$sched}->{simd_k}; $i++) {
                $rows = ::max( $rows, scalar @{$obj->{$sched}->{$ts}->{$i}} );
            }
            # Print each operation in the proper SIMD column
            for ($i=0; $i<$rows; $i++) {
                printf "%${at}s ", $time;
                $op_cnt++   if ( defined $obj->{$sched}->{$ts}->{0}->[$i] );
                printf "| %-${cw}s", $obj->{$sched}->{$ts}->{0}->[$i]->{text} || "";
                for (my $simd=1; $simd<=$obj->{$sched}->{simd_k}; $simd++) {
                    $op_cnt++   if ( defined $obj->{$sched}->{$ts}->{$simd}->[$i] );
                    printf "| %-${cw}s", $obj->{$sched}->{$ts}->{$simd}->[$i]->{text} || "";
                }
                print "\n";
                $time = ""; # only print $time on first row
            }
            print "$msg\n";
        }
    }
    print "E: Printed $op_cnt, expected $obj->{$sched}->{op_cnt}\n"  if ( $op_cnt != $obj->{$sched}->{op_cnt} );
    print "\n";
}

sub sched_true_print {
    my $obj = shift;
    my $sched = shift;
    my $s = $obj->{$sched};
    my $simd_k = $s->{simd_k};
    my $op = '';
    my $simd = 0;
    # real timestep - includes moves
    my $rts = 0;
    foreach my $fts ( 0..$s->{len} ) {
        my $curr = $s->{$fts};
        if ( exists $curr->{0} && scalar @{ $curr->{0} } ) {
            # Track all source and dest moves
            my @m_src = (0) x ( $simd_k + 1 );
            my @m_dst = (0) x ( $simd_k + 1 );
            foreach my $mov ( @{ $curr->{0} } ) {
                $m_src[$mov->{src}] = 1;
                $m_dst[$mov->{dst}] = 1;
            }
            # Print 3 timesteps where src is active (ignore memory SIMD)
            #foreach $op ( qw(H CNOT MEAS) ) {
            foreach $op ( qw(H CNOT) ) {
                foreach $simd ( 1..$simd_k ) {
                    print "$rts $simd MOV($op)\n"    if ( $m_src[$simd] );
                }
                $rts++;
            }
            # Print 2 timestep where dest is active
            foreach $op ( qw(X Z) ) {
                foreach $simd ( 1..$simd_k ) {
                    print "$rts $simd MOV($op)\n"    if ( $m_dst[$simd] );
                }
                $rts++;
            }
        }
        foreach $simd ( 1..$simd_k ) {
            # Print operation of the current SIMD for current timestep
            print "$rts $simd $curr->{$simd}->[0]->{op}\n"  if ( UNIVERSAL::isa( $curr->{$simd}->[0], "Op" ) );
        }
        $rts++;
    }
}

sub print {
    my $obj = shift;
    my $sched = shift || "asap";
    my $msg = "Function: $obj->{function} (op_cnt: $obj->{$sched}->{op_cnt}, max: $obj->{$sched}->{threads})";
    my @ts = sort {$a <=> $b} keys %{ $obj->{$sched} };
    my $op_cnt = 0;
    #print join " ", @ts;
    #print "\n";
    my $at = length sprintf "%d", $ts[-1];
    my $cw = 3 + $obj->{twidth};
    print "$msg\n";
    $msg =~ s/./=/g;
    print "$msg\n";
    foreach my $time ( @ts ) {
        if ( $time =~ /^-?\d+$/ ) {
            printf "%${at}d ", $time;
            @{$obj->{$sched}->{$time}} = sort { $a->{id} <=> $b->{id} } @{ $obj->{$sched}->{$time} };
            my $i=0;
            # Print operations
            foreach my $op ( @{$obj->{$sched}->{$time}} ) {
                printf "%-${cw}s", "| $op->{text}";
                $i++;
                $op_cnt++;
            }
            # Print formatting for unscheduled ops
            for (; $i<$obj->{$sched}->{threads}; $i++) {
                printf "%-${cw}s", "| "
            }
            print "\n";
        }
    }
    print "E: Printed $op_cnt, expected $obj->{$sched}->{op_cnt}\n"  if ( $op_cnt != $obj->{$sched}->{op_cnt} );
    print "\n";
}


package main;

use Getopt::Long;
use List::Util qw(max min);
use Scalar::Util qw(refaddr);
use Data::Dumper;
sub dm {$Data::Dumper::Maxdepth = shift || 3};

# Schedule parameters
$::DEBUG = 100;
$::SIMD_K = 4;
$::SIMD_D = 1024;
$::SIMD_L = 2;  # Number of SIMD regions allocated to longest paths
$::refill = 0;
$::opp = 0;
$::w_op = 1;
$::w_dist = -1;
$::w_slack = 1;
my $name = "lpfs";
my $metrics = 0;
my $schedule = 0;
my $pretty = 0;
my $true = 0;
my $dot = 0;
my $all = 0;
our %opts = (
    'asap'          => 0,
    'alap'          => 0,
    'acap'          => 0,
    'ss'            => 0,
    'rcp'           => 0,
    'lpfs'          => 0,
    'lpfs_debug'    => 0,
    'cpr'           => 0,
    'dot'           => 0,
    'leaves_only'   => 1,
    'conflict'      => 0
);

GetOptions ("d=i"       => \$::SIMD_D,
            "k=i"       => \$::SIMD_K,
            "l=i"       => \$::SIMD_L,
            "refill"    => \$::refill,
            "opp"       => \$::opp,
            "op:i"      => \$::w_op,
            "dist:i"    => \$::w_dist,
            "slack:i"   => \$::w_slack,
            "n=s"       => \$name,
            "g"         => \$dot,
            "m"         => \$metrics,
            "s"         => \$schedule,
            "p"         => \$pretty,
            "t"         => \$true,
            "a"         => \$all,
            "DEBUG=i"   => \$::DEBUG);
if ( $::SIMD_L >= $::SIMD_K ) {
    $::SIMD_L = $::SIMD_K >> 1; # half, rounded down
}
if ( $all ) { $metrics = 1; $schedule = 1; }
if ( ! ( $metrics or $schedule or $pretty or $dot or $true ) ) { $metrics = 1; }
if ( $::DEBUG >= 10 ) {
    print "M: \$::SIMD_K=$::SIMD_K; \$::SIMD_D=$::SIMD_D; \$::SIMD_L=$::SIMD_L\n";
}
if ( ! exists $opts{$name} ) {
    die "Invalid sched name $name!\n";
} else {
    $opts{$name} = 1;
}

our %func_sched = (
    'START'   => {'length' => 0},
    'END'     => {'length' => 0},
    'PrepZ'   => {'length' => 1},
    'MeasX'   => {'length' => 1},
    'MeasZ'   => {'length' => 1},
    'CNOT'    => {'length' => 1},
    'H'       => {'length' => 1},
    'S'       => {'length' => 1},
    'Sdag'    => {'length' => 1},
    'T'       => {'length' => 1},
    'Tdag'    => {'length' => 1},
    'X'       => {'length' => 1},
    'Y'       => {'length' => 1},
    'Z'       => {'length' => 1}
);
our @func_names = ();

sub max_key {
    my $hash = shift;
    my ($max, $ret) = each %$hash;
    while ( my ($k, $v) = each %$hash ) {
        if ( $max < $v ) {
            $max = $v;
            $ret = $k;
        }
    }
    return $ret;
}

sub main {
    my $file = $ARGV[0];
    my $function = '';

    open SCHED, $ARGV[0] or die "Unable to open file '$ARGV[0]': $!\n";

    while (<SCHED>) {
        chomp;
        if (/#Function (\w+)/) {
            $function = $1;
            push @func_names, $function;
            $func_sched{$function} = Schedule->new($function);

        } elsif (/#EndFunction/) {
            if ( $opts{asap} ) {
                print  "ASAP:\n";
                $func_sched{$function}->sched_check("asap");
                $func_sched{$function}->print("asap");
            }
            if ( $opts{alap} ) {
                print  "ALAP:\n";
                $func_sched{$function}->alap();
                $func_sched{$function}->sched_check("alap");
                $func_sched{$function}->print("alap");
            }
            if ( $opts{acap} ) {
                print  "ACAP:\n";
                $func_sched{$function}->acap();
                #print ::Dumper $func_sched{$function}->{acap};
                $func_sched{$function}->sched_check("acap");
                $func_sched{$function}->print("acap");
                $function = '';
            }
            if ( $opts{ss} ) {
                print  "SS:\n";
                $func_sched{$function}->ss();
                $func_sched{$function}->header_print("ss")          if ( $metrics or $schedule or $pretty or $true );
                $func_sched{$function}->metrics_print("ss")         if ( $metrics );
                $func_sched{$function}->sched_print("ss")           if ( $schedule );
                $func_sched{$function}->sched_pretty_print("ss")    if ( $pretty );
                $func_sched{$function}->sched_true_print("ss")      if ( $true );
            }
            if ( $opts{rcp} ) {
                print  "RCP:\n";
                $func_sched{$function}->rcp();
                $func_sched{$function}->header_print("rcp")         if ( $metrics or $schedule or $pretty or $true );
                $func_sched{$function}->metrics_print("rcp")        if ( $metrics );
                $func_sched{$function}->sched_print("rcp")          if ( $schedule );
                $func_sched{$function}->sched_pretty_print("rcp")   if ( $pretty );
                $func_sched{$function}->sched_true_print("rcp")     if ( $true );
            }
            if ( $opts{lpfs} ) {
                print  "LPFS:\n";
                $func_sched{$function}->lpfs();
                $func_sched{$function}->header_print("lpfs")        if ( $metrics or $schedule or $pretty or $true );
                $func_sched{$function}->metrics_print("lpfs")       if ( $metrics );
                $func_sched{$function}->sched_print("lpfs")         if ( $schedule );
                $func_sched{$function}->sched_pretty_print("lpfs")  if ( $pretty );
                $func_sched{$function}->sched_true_print("lpfs")    if ( $true );

            }
            if ( $opts{lpfs_debug} ) {
                my @path = $func_sched{$function}->find_lp( $func_sched{$function}->{top} );
	 	$func_sched{$function}->header_print("lpfs"); 
                while ( 3 < scalar @path ) {
                    foreach my $op ( @path ) {
                        print "$op->{dist} - $op->{text}\n";
                    }
		    @path = $func_sched{$function}->find_lp( $func_sched{$function}->{top} );
		    $func_sched{$function}->header_print("lpfs");
                }
                foreach my $op ( @path ) {
                    print "$op->{dist} - $op->{text}\n";
                }
                print "\n";
            }
            if ( $opts{cpr} ) {
                print  "Critical Path Report:\n";
                $func_sched{$function}->cpr();
            }
            if ( $opts{dot} ) {
                $func_sched{$function}->draw_graph("$ARGV[0]\.$function\.dot");
            }
            if ( $opts{conflict} ) {
            }
            if ( $opts{leaves_only} ) {
                # If only processing leaves, do not keep old functions
                delete $func_sched{$function};
            }
            #print "\n";

        # Check for defined function region, parse command, and verify that the command is defined
        } elsif ($function ne '' and /^\d+/ ) {
            my ($rank, $oper, @args) = split / /;
            if (! exists $func_sched{$oper}) {
                print  "Unknown command in function $function: $oper (line: $_)\n";
                next;
            }
            my $op = Op->new($oper, $rank, $func_sched{$oper}->{length});
            foreach my $arg (@args) {
                if ( ! exists($func_sched{$function}->{qubits}->{$arg}) ) {
                    $func_sched{$function}->{qubits}->{$arg} = Qubit->new($arg);
                }
                $func_sched{$function}->{qubits}->{$arg}->add_dep($op);
                $op->add_qubit($func_sched{$function}->{qubits}->{$arg});
            }
            $func_sched{$function}->add_op( $op );

        } elsif (/^#/ or /^\s*$/) {
            # comment or blank line, do nothing

        } else {
            print  "Unparsed line(func: $function, cmd: $1): $_\n";
        }
    }
    close SCHED;
}

dm();
main();