## -*- tcl -*- # # ## ### ##### ######## ############# ##################### ## Copyright (c) 2007 Andreas Kupries. # # This software is licensed as described in the file LICENSE, which # you should have received as part of this distribution. # # This software consists of voluntary contributions made by many # individuals. For exact contribution history, see the revision # history and logs, available at http://fossil-scm.hwaci.com/fossil # # ## ### ##### ######## ############# ##################### ## This file provides a helper package for the passes 6 and 7 which ## contains the common code of the cycle breaking algorithm. # # ## ### ##### ######## ############# ##################### ## Requirements package require Tcl 8.4 ; # Required runtime. package require snit ; # OO system. package require struct::graph ; # Graph handling. package require struct::list ; # Higher order list operations. package require vc::tools::dot ; # User feedback. DOT export. package require vc::tools::log ; # User feedback. package require vc::tools::trouble ; # Error reporting. package require vc::tools::misc ; # Text formatting. package require vc::fossil::import::cvs::project::rev ; # Project level changesets package require vc::fossil::import::cvs::project::revlink ; # Cycle links. package require vc::fossil::import::cvs::integrity ; # State integrity checks. # # ## ### ##### ######## ############# ##################### ## snit::type ::vc::fossil::import::cvs::cyclebreaker { # # ## ### ##### ######## ############# ## Public API typemethod precmd {cmd} { ::variable myprecmd $cmd return } typemethod savecmd {cmd} { ::variable mysavecmd $cmd return } typemethod breakcmd {cmd} { ::variable mybreakcmd $cmd return } # # ## ### ##### ######## ############# typemethod dotsto {path} { ::variable mydotdestination $path return } typemethod watch {id} { ::variable mywatchids lappend mywatchids $id } typemethod dot {label changesets} { ::variable mydotprefix $label ::variable mydotid 0 set dg [Setup $changesets 0] Mark $dg $dg destroy return } typemethod mark {graph suffix {subgraph {}}} { Mark $graph $suffix $subgraph return } # # ## ### ##### ######## ############# typemethod run {label changesetcmd} { ::variable myat 0 ::variable mydotprefix $label ::variable mydotid 0 # We create a graph of the revision changesets, using the file # level dependencies to construct a first approximation of the # dependencies at the project level. Then we look for cycles # in that graph and break them. # 1. Create nodes for all relevant changesets and a mapping # from the revisions to their changesets/nodes. set changesets [uplevel #0 $changesetcmd] set dg [Setup $changesets] # 3. Lastly we iterate the graph topologically. We mark off # the nodes which have no predecessors, in order from # oldest to youngest, saving and removing dependencies. If # we find no nodes without predecessors we have a cycle, # and work on breaking it. log write 3 cyclebreaker {Traverse changesets} InitializeCandidates $dg set k 0 set max [llength [$dg nodes]] while {1} { while {[WithoutPredecessor $dg n]} { log progress 2 cyclebreaker $k $max ; incr k MarkWatch $dg ProcessedHook $dg $n $myat $dg node delete $n incr myat ShowPendingNodes } if {![llength [$dg nodes]]} break BreakCycleHook $dg InitializeCandidates $dg MarkWatch $dg } $dg destroy log write 3 cyclebreaker Done. ClearHooks # Reread the graph and dump its final form, if graph export # was activated. ::variable mydotdestination if {$mydotdestination eq ""} return set dg [Setup [uplevel #0 $changesetcmd] 0] Mark $dg -done $dg destroy return } # # ## ### ##### ######## ############# typemethod break-segment {graph} { BreakSegment $graph $path "segment ([project::rev strlist $path])" return } typemethod break {graph} { set cycle [FindCycle $graph] set label "cycle ([project::rev strlist $cycle])" # NOTE: cvs2svn uses the sequence "end-1, cycle, 0" to create # the path from the cycle. The only effect I can see is # that this causes the link-triples to be generated in a # sightly different order, i.e. one link rotated to the # right. This should have no effect on the search for # the best of all. lappend cycle [lindex $cycle 0] [lindex $cycle 1] BreakSegment $graph $cycle $label return } typemethod replace {graph n replacements} { Replace $graph $n $replacements return } # # ## ### ##### ######## ############# ## Internal methods proc Setup {changesets {log 1}} { if {$log} { log write 3 cyclebreaker "Creating graph of changesets" } set dg [struct::graph dg] set n 0 set max [llength $changesets] foreach cset $changesets { log progress 2 cyclebreaker $n $max set tr [$cset timerange] $dg node insert $cset $dg node set $cset timerange $tr $dg node set $cset label "[$cset str]\\n[join [struct::list map $tr {::clock format}] "\\n"]" $dg node set $cset __id__ [$cset id] $dg node set $cset shape [expr {[$cset bysymbol] ? "ellipse" : "box"}] incr n } if {$log} { log write 3 cyclebreaker "Has [nsp [llength $changesets] changeset]" } # 2. Find for all relevant changeset their revisions and their # dependencies. Map the latter back to changesets and # construct the corresponding arcs. set n 0 foreach cset $changesets { log progress 2 cyclebreaker $n $max foreach succ [$cset successors] { # Changesets may have dependencies outside of the # chosen set. These are ignored if {![$dg node exists $succ]} continue $dg arc insert $cset $succ integrity assert { $succ ne $cset } {[$cset reportloop 0]Changeset loop was not detected during creation} } incr n } if {$log} { log write 3 cyclebreaker "Has [nsp [llength [$dg arcs]] dependency dependencies]" } # Run the user hook to manipulate the graph before # consummation. if {$log} { Mark $dg -start } MarkWatch $dg PreHook $dg MarkWatch $dg return $dg } # Instead of searching the whole graph for the degree-0 nodes in # each iteration we compute the list once to start, and then only # update it incrementally based on the outgoing neighbours of the # node chosen for commit. proc InitializeCandidates {dg} { # bottom = list (list (node, range min, range max)) ::variable mybottom foreach n [$dg nodes] { if {[$dg node degree -in $n]} continue lappend mybottom [linsert [$dg node get $n timerange] 0 $n] } ScheduleCandidates ShowPendingNodes return } proc WithoutPredecessor {dg nv} { ::variable mybottom upvar 1 $nv n if {![llength $mybottom]} { return 0 } set n [lindex [lindex $mybottom 0] 0] set mybottom [lrange $mybottom 1 end] set changed 0 # Update list of nodes without predecessor, based on the # outgoing neighbours of the chosen node. This should be # faster than iterating of the whole set of nodes, finding all # without predecessors, sorting them by time, etc. pp. foreach out [$dg nodes -out $n] { if {[$dg node degree -in $out] > 1} continue # Degree-1 neighbour, will have no predecessors after the # removal of n. Put on the list. lappend mybottom [linsert [$dg node get $out timerange] 0 $out] set changed 1 } if {$changed} { ScheduleCandidates } # We do not delete the node immediately, to allow the Save # procedure to save the dependencies as well (encoded in the # arcs). return 1 } proc ScheduleCandidates {} { ::variable mybottom # Sort by cset object name, lower border of timerange, at last # by the upper border. set mybottom [lsort -index 2 -integer [lsort -index 1 -integer [lsort -index 0 -dict $mybottom]]] return } proc ShowPendingNodes {} { if {[log verbosity?] < 10} return ::variable mybottom log write 10 cyclebreaker "Pending..............................." foreach item [struct::list map $mybottom [myproc FormatPendingItem]] { log write 10 cyclebreaker "Pending: $item" } return } proc FormatPendingItem {item} { join [list [[lindex $item 0] str] [clock format [lindex $item 1]] [clock format [lindex $item 2]]] } proc FindCycle {dg} { # This procedure is run if and only the graph is not empty and # all nodes have predecessors. This means that each node is # either part of a cycle or (indirectly) depending on a node # in a cycle. We can start at an arbitrary node, follow its # incoming edges to its predecessors until we see a node a # second time. That node closes the cycle and the beginning is # its first occurence. Note that we can choose an arbitrary # predecessor of each node as well, we do not have to search. # We record for each node the index of the first appearance in # the path, making it easy at the end to cut the cycle from # it. # Choose arbitrary node to start our search at. set start [lindex [$dg nodes] 0] # Initialize state, path of seen nodes, and when seen. set path {} array set seen {} while {1} { # Stop searching when we have seen the current node # already, the circle has been closed. if {[info exists seen($start)]} break lappend path $start set seen($start) [expr {[llength $path]-1}] # Choose arbitrary predecessor set start [lindex [$dg nodes -in $start] 0] } return [struct::list reverse [lrange $path $seen($start) end]] } proc BreakSegment {dg path label} { # The path, usually a cycle, we have gotten is broken by # breaking apart one or more of the changesets in the # cycle. This causes us to create one or more changesets which # are to be committed, added to the graph, etc. pp. set bestlink {} set bestnode {} foreach \ prev [lrange $path 0 end-2] \ cset [lrange $path 1 end-1] \ next [lrange $path 2 end] { # Each triple PREV -> CSET -> NEXT of changesets, a # 'link' in the cycle, is analysed and the best # location where to at least weaken the cycle is # chosen for further processing. set link [project::revlink %AUTO% $prev $cset $next] if {$bestlink eq ""} { set bestlink $link set bestnode $cset } elseif {[$link betterthan $bestlink]} { $bestlink destroy set bestlink $link set bestnode $cset } else { $link destroy } } log write 5 cyclebreaker "Breaking $label by splitting changeset [$bestnode str]" set ID [$bestnode id] Mark $dg -${ID}-before set newcsets [$bestlink break] $bestlink destroy # At this point the old changeset (BESTNODE) is gone # already. We remove it from the graph as well and then enter # the fragments generated for it. Replace $dg $bestnode $newcsets Mark $dg -${ID}-after return } # TODO: This should be a graph method. proc HasArc {dg a b} { #8.5: return [expr {$b in [$dg nodes -out $a]}] if {[lsearch -exact [$dg nodes -out $a] $b] < 0} { return 0 } return 1 } proc Mark {dg {suffix {}} {subgraph {}}} { ::variable mydotdestination if {$mydotdestination eq ""} return ::variable mydotprefix ::variable mydotid set fname $mydotdestination/${mydotprefix}${mydotid}${suffix}.dot file mkdir [file dirname $fname] dot write $dg $mydotprefix$suffix $fname $subgraph incr mydotid log write 5 cyclebreaker ".dot export $fname" return } proc Replace {dg n replacements} { # NOTE. We have to get the list of incoming neighbours and # recompute their successors after the new nodes have been # inserted. Their outgoing arcs will now go to one or both of # the new nodes, and not redoing them may cause us to forget # circles, leaving them in, unbroken. set pre [$dg nodes -in $n] $dg node delete $n foreach cset $replacements { set tr [$cset timerange] $dg node insert $cset $dg node set $cset timerange $tr $dg node set $cset label "[$cset str]\\n[join [struct::list map $tr {::clock format}] "\\n"]" $dg node set $cset __id__ [$cset id] $dg node set $cset shape [expr {[$cset bysymbol] ? "ellipse" : "box"}] } foreach cset $replacements { foreach succ [$cset successors] { # The new changesets may have dependencies outside of # the chosen set. These are ignored if {![$dg node exists $succ]} continue $dg arc insert $cset $succ integrity assert { $succ ne $cset } {[$cset reportloop 0]Changeset loop was not detected during creation} } } foreach cset $pre { foreach succ [$cset successors] { # Note that the arc may already exist in the graph. If # so ignore it. The new changesets may have # dependencies outside of the chosen set. These are # ignored if {![$dg node exists $succ]} continue if {[HasArc $dg $cset $succ]} continue;# TODO should be graph method. $dg arc insert $cset $succ } } return } # # ## ### ##### ######## ############# ## Callback invokation ... proc PreHook {graph} { # Give the user of the cycle breaker the opportunity to work # with the graph between setup and consummation. ::variable myprecmd if {![llength $myprecmd]} return uplevel #0 [linsert $myprecmd end $graph] Mark $graph -pre-done return } proc ProcessedHook {dg cset pos} { # Give the user of the cycle breaker the opportunity to work # with the changeset before it is removed from the graph. ::variable mysavecmd if {![llength $mysavecmd]} return uplevel #0 [linsert $mysavecmd end $dg $pos $cset] return } proc BreakCycleHook {graph} { # Call out to the chosen algorithm for cycle breaking. Finding # a cycle if no breaker was chosen is an error. ::variable mybreakcmd if {![llength $mybreakcmd]} { trouble fatal "Found a cycle, expecting none." exit 1 } uplevel #0 [linsert $mybreakcmd end $graph] return } proc ClearHooks {} { ::variable myprecmd {} ::variable mysavecmd {} ::variable mybreakcmd {} return } # # ## ### ##### ######## ############# proc MarkWatch {graph} { ::variable mywatchids set watched [Watched $graph $mywatchids] if {![llength $watched]} return set neighbours [eval [linsert $watched 0 $graph nodes -adj]] #foreach n $neighbours { log write 6 cyclebreaker "Neighbor [$n id] => $n" } Mark $graph watched [concat $watched $neighbours] return } proc Watched {graph watchids} { set res {} foreach id $watchids { set nl [$graph nodes -key __id__ -value $id] if {![llength $nl]} continue lappend res $nl #log write 6 breakrcycle "Watching $id => $nl" $graph node set $nl fontcolor red } return $res } # # ## ### ##### ######## ############# typevariable myat 0 ; # Counter for commit ids for the # changesets. typevariable mybottom {} ; # List of the candidate nodes for # committing. typevariable myprecmd {} ; # Callback, change graph before walk. typevariable mysavecmd {} ; # Callback, for each processed node. typevariable mybreakcmd {} ; # Callback, for each found cycle. typevariable mydotdestination {} ; # Destination directory for the # generated .dot files. typevariable mydotprefix {} ; # Prefix for dot files when # exporting the graphs. typevariable mydotid 0 ; # Counter for dot file name # generation. typevariable mywatchids {} ; # Changesets to watch the # neighbourhood of. # # ## ### ##### ######## ############# ## Configuration pragma -hasinstances no ; # singleton pragma -hastypeinfo no ; # no introspection pragma -hastypedestroy no ; # immortal # # ## ### ##### ######## ############# } namespace eval ::vc::fossil::import::cvs { namespace export cyclebreaker namespace eval cyclebreaker { namespace import ::vc::fossil::import::cvs::integrity namespace eval project { namespace import ::vc::fossil::import::cvs::project::rev namespace import ::vc::fossil::import::cvs::project::revlink } namespace import ::vc::tools::misc::* namespace import ::vc::tools::log namespace import ::vc::tools::trouble namespace import ::vc::tools::dot log register cyclebreaker } } # # ## ### ##### ######## ############# ##################### ## Ready package provide vc::fossil::import::cvs::cyclebreaker 1.0 return