[Scummvm-cvs-logs] SF.net SVN: scummvm: [28576] tools/branches/gsoc2007-decompiler

brixxie at users.sourceforge.net brixxie at users.sourceforge.net
Mon Aug 13 05:32:00 CEST 2007


Revision: 28576
          http://scummvm.svn.sourceforge.net/scummvm/?rev=28576&view=rev
Author:   brixxie
Date:     2007-08-12 20:32:00 -0700 (Sun, 12 Aug 2007)

Log Message:
-----------
added graph-dfs egg requirement, added pseudo.scm and structuring.scm, described loop structuring algorithm in control_structures.txt

Modified Paths:
--------------
    tools/branches/gsoc2007-decompiler/Makefile
    tools/branches/gsoc2007-decompiler/README
    tools/branches/gsoc2007-decompiler/antipasto.scm
    tools/branches/gsoc2007-decompiler/cfgg.scm
    tools/branches/gsoc2007-decompiler/docs/control_structures.txt
    tools/branches/gsoc2007-decompiler/graph.scm

Added Paths:
-----------
    tools/branches/gsoc2007-decompiler/pseudo.scm
    tools/branches/gsoc2007-decompiler/structuring.scm

Property Changed:
----------------
    tools/branches/gsoc2007-decompiler/


Property changes on: tools/branches/gsoc2007-decompiler
___________________________________________________________________
Name: svk:merge
   - 489ca303-0d3d-4dc1-a57d-017c7912a06a:/local/gsoc2007-decompiler:60
   + 489ca303-0d3d-4dc1-a57d-017c7912a06a:/local/gsoc2007-decompiler:63

Modified: tools/branches/gsoc2007-decompiler/Makefile
===================================================================
--- tools/branches/gsoc2007-decompiler/Makefile	2007-08-13 02:55:19 UTC (rev 28575)
+++ tools/branches/gsoc2007-decompiler/Makefile	2007-08-13 03:32:00 UTC (rev 28576)
@@ -32,7 +32,7 @@
 desword2$(EXEEXT): desword2.o util.o
 	$(CXX) $(LDFLAGS) -o $@ $+
 
-antipasto$(EXEEXT): antipasto.scm util.scm cfgg.scm graph.scm
+antipasto$(EXEEXT): antipasto.scm util.scm cfgg.scm graph.scm structuring.scm pseudo.scm
 	csc $< -o $@ -postlude [main]
 
 descumm.o descumm6.o descumm-common.o descumm-tool.o: descumm.h

Modified: tools/branches/gsoc2007-decompiler/README
===================================================================
--- tools/branches/gsoc2007-decompiler/README	2007-08-13 02:55:19 UTC (rev 28575)
+++ tools/branches/gsoc2007-decompiler/README	2007-08-13 03:32:00 UTC (rev 28576)
@@ -23,7 +23,8 @@
   - numbers
   - vector-lib
   - dyn-vector
-  - digraph (use the fixed egg from eggs/)
+  - digraph
+  - graph-dfs
 
 To obtain these execute
 

Modified: tools/branches/gsoc2007-decompiler/antipasto.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/antipasto.scm	2007-08-13 02:55:19 UTC (rev 28575)
+++ tools/branches/gsoc2007-decompiler/antipasto.scm	2007-08-13 03:32:00 UTC (rev 28576)
@@ -2,7 +2,7 @@
 
 ;;; Antipasto - Scumm Script Disassembler Prototype (version 5 scripts)
 ;;; Copyright (C) 2007 Andreas Scholta
-;;; Time-stamp: <2007-07-15 05:50:37 brx>
+;;; Time-stamp: <2007-07-31 18:30:48 brx>
 
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License
@@ -18,11 +18,13 @@
 ;;; along with this program; if not, write to the Free Software
 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 
-(require-extension srfi-1 posix numbers digraph)
+(require-extension srfi-1 posix numbers digraph graph-dfs)
 
 (include "util.scm")
 (include "graph.scm")
 (include "cfgg.scm")
+(include "structuring.scm")
+(include "pseudo.scm")
 
 (define current-script-file #f)
 (define current-script-port #f)
@@ -816,7 +818,19 @@
   (let ((disassembly (decode-ops '())))
     (receive (cfg intervals)
         (generate-control-flow-graph disassembly)
-      (print-dot cfg disassembly intervals)))
+;;       (print-dot cfg disassembly intervals)
+;;       (newline)
+      ;; (for-each (lambda (dgs)
+;;                   (let ((dg (car dgs))
+;;                         (ivs (cdr dgs)))
+;;                     (print "==")
+;;                     (for-each pretty-print
+;;                               (map (lambda (iv)
+;;                                      (append-map (dg 'node-info) iv))
+;;                                    ivs))))
+;;                 (generate-derived-graph-sequence cfg intervals))
+      (structure-loops! cfg (generate-derived-graph-sequence cfg intervals))
+      (structure-2-way! cfg)))
   (close-input-port current-script-port)
   (set! current-script-port #f)
   (set! current-script-file #f)

Modified: tools/branches/gsoc2007-decompiler/cfgg.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/cfgg.scm	2007-08-13 02:55:19 UTC (rev 28575)
+++ tools/branches/gsoc2007-decompiler/cfgg.scm	2007-08-13 03:32:00 UTC (rev 28576)
@@ -2,7 +2,7 @@
 
 ;;; Antipasto - Scumm Script Disassembler Prototype
 ;;; Copyright (C) 2007 Andreas Scholta
-;;; Time-stamp: <2007-07-15 05:51:48 brx>
+;;; Time-stamp: <2007-07-31 21:19:30 brx>
 
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License
@@ -18,14 +18,33 @@
 ;;; along with this program; if not, write to the Free Software
 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 
+;; (test-run "/home/brx/code/gsoc2007-decompiler/M1.scummV5/81.cu_bar_2.0092")
+;; (test-run "/home/brx/code/gsoc2007-decompiler/M2.scummV5/entry-4.dmp")
+;; (test-run "/home/brx/code/gsoc2007-decompiler/M2.scummV5/room-15-203.dmp")
+;; (test-run "/home/brx/code/gsoc2007-decompiler/M1.scummV5/01.beach.0201")
+
+(define-record-type loop-info
+  (make-loop-info head latch type follow)
+  loop-info?
+  (head loop-head set-loop-head!)
+  (latch loop-latch set-loop-latch!)
+  (type loop-type set-loop-type!)
+  (follow loop-follow set-loop-follow!))
+
 (define-record-type basic-block
-  (basic-block type range)
+  (make-basic-block type range post-order loop-info follow)
   basic-block?
   (type bb-type set-bb-type!)
-  (range bb-range set-bb-range!))
+  (range bb-range set-bb-range!)
+  (post-order post-order set-post-order!)
+  (loop-info loop-info set-loop-info!)
+  (follow bb-follow set-bb-follow!))
 
+(define basic-block
+  (cut make-basic-block <> <> #f (make-loop-info #f #f #f #f) #f))
+
 (define-record-printer (basic-block x out)
-  (fprintf out "(basic-block ~A ~A)" (bb-type x) (bb-range x)))
+  (fprintf out "(basic-block ~A ~A ~A)" (post-order x) (bb-type x) (bb-range x)))
 
 (define (bb-update! bb #!key type range)
   (when type (set-bb-type! bb type))
@@ -94,7 +113,10 @@
                 blocks))
   (let ((g (make-digraph 'cfg "control flow graph"))
         (ii (list-tabulate (length blocks) identity)))
-    (for-each (cut (g 'add-node!) <> <>) ii blocks)
+    (for-each (lambda (i block)
+                ((g 'add-node!) i (list i block)))
+              ii
+              blocks)
     (for-each (lambda (i b)
                 (let ((outs (match (bb-type b)
                               (('goto-unless jump-addr _)
@@ -115,6 +137,16 @@
               blocks)
     g))
 
+(define (inject-post-order! cfg)
+  (let ((ninfo (cfg 'node-info))
+        (po 0))
+    (define (get-po!) (set! po (add1 po)) po)
+    (for-each (lambda (npo)
+                (let ((node (second (ninfo (first npo)))))
+                  (set-post-order! node (get-po!))))
+              (graph-postorder cfg 0))
+    cfg))
+
 (define (generate-control-flow-graph disassembly)
   (let ((cfg
          (remove-isolated!
@@ -124,7 +156,8 @@
              (map (lambda (instruction)
                     (cons (car instruction) (cddr instruction)))
                   disassembly)))))))
-    (values cfg (generate-intervals cfg (list 0)))))
+    (values (inject-post-order! cfg)
+            (generate-intervals cfg (list 0)))))
 
 ;; (test-run "/home/brx/code/gsoc2007-decompiler/M1.scummV5/81.cu_bar_2.0092")
 ;; (test-run "/home/brx/code/gsoc2007-decompiler/M2.scummV5/entry-4.dmp")

Modified: tools/branches/gsoc2007-decompiler/docs/control_structures.txt
===================================================================
--- tools/branches/gsoc2007-decompiler/docs/control_structures.txt	2007-08-13 02:55:19 UTC (rev 28575)
+++ tools/branches/gsoc2007-decompiler/docs/control_structures.txt	2007-08-13 03:32:00 UTC (rev 28576)
@@ -127,9 +127,36 @@
        D = D' = BJ1 = GP1
 
 
-                  Generic Set of Control Structures
-                  ---------------------------------
+                          Graph Structuring
+                          -----------------
 
 Antipasto structures control flow graphs using the set of generic
 control structures D' + goto = {1,2,3,4,5,6,7,12}.
 REn, RECn, DREn and DRECn can be simulated via the use of goto.
+
+Structuring Loops:
+
+ Given an interval I(h_j) with header h_j, there is a loop rooted at
+ h_j if there is a back-edge to the header node h_j from a latching
+ node n_k \in I(h_j).
+
+ Once a loop has been found, the type of loop (e.g. pre-tested,
+ post-tested, endless) is determined according to the type of header
+ and latching nodes. Nodes belonging to the loop are flagged in order
+ to prevent nodes from belonging to two different loops as would be
+ the case in overlapping or multientry loops.
+
+ Given a control flow graph G = G1 with interval information, the
+ derived sequence of graphs G1, ..., Gn of G, and the set of intervals
+ of these Graphs, I1 ... In, an algorithm to find loops is as follows:
+ each header node of an interval in G1 is checked for having a
+ back-edge from a latching node that belongs to the same interval. If
+ so, a loop has been found, its type is determined and the nodes that
+ belong to it are marked. next the intervals of G2, I2 are checked for
+ loops and the process is repeated until intervals in In have been
+ checked. Whenever there is a potential loop that has its header or
+ latching node marked as belonging to another loop, the loop is
+ disregarded as it belongs to an unstructured loop. These loops always
+ generate goto jumps during code generation.
+ This algorithm finds the loops in the appropriate nesting level, from
+ innermost to outermost loop.

Modified: tools/branches/gsoc2007-decompiler/graph.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/graph.scm	2007-08-13 02:55:19 UTC (rev 28575)
+++ tools/branches/gsoc2007-decompiler/graph.scm	2007-08-13 03:32:00 UTC (rev 28576)
@@ -2,7 +2,7 @@
 
 ;;; Antipasto - Scumm Script Disassembler Prototype
 ;;; Copyright (C) 2007 Andreas Scholta
-;;; Time-stamp: <2007-07-15 06:16:24 brx>
+;;; Time-stamp: <2007-07-31 21:04:36 brx>
 
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License
@@ -22,8 +22,9 @@
 (define (print-dot g disassembly intervals)
   (define (quote-string str)
     (string-translate* str '(("\"" . "\\\""))))
-  (print "digraph G { node [shape = box, fontsize = 10, fontname = Courier]")
-  (let ((nodes ((g 'nodes))))
+  (let ((nodes ((g 'nodes)))
+        (edges ((g 'edges))))
+    (print "digraph G { node [shape = box, fontsize = 10, fontname = Courier]")
     (for-each (lambda (n)
                 (match-let (((n block) n))
                   (print* "    n"
@@ -47,43 +48,72 @@
                                 ", shape=ellipse, style=filled]")
                                (else "]")))))
               nodes)
-    (newline)
     (when intervals
       (for-each
        (lambda (interval iter)
-         (print "subgraph cluster" (car interval) " {")
-         (print "    label = \"I(" iter ")\"")
-         (for-each
-          (lambda (i)
-            (print "    n" i)
-            #;
-            (receive (intern ext)
-            (partition (cut member <> interval)
-            (map second ((g 'out-edges) i)))
-            (for-each (lambda (ij)
-            (print "    n" i " -> n" ij))
-            intern)
-            (set! extern (append extern (map (cut cons i <>) ext)))))
-            interval)
-          (print "}"))
-         intervals
-         (list-tabulate (length intervals) identity))))
-  (for-each (lambda (e)
-              (match-let (((i j _) e))
-                (print "    n" i " -> n" j)))
-            ((g 'edges)))
-  (print "}"))
+         (print "    subgraph cluster" (car interval) " {")
+         (print "        label = \"I(" iter ")\"")
+         (for-each (cut print "        n" <>) interval)
+         (print "    }"))
+       intervals
+       (list-tabulate (length intervals) identity)))
+    (for-each (lambda (e) (print "    n" (first e) " -> n" (second e))) edges)
+    (print "}")))
 
 (define (remove-isolated! g)
-  (let loop ()
-    (let ((repeat? #f))
-      (for-each (lambda (root)
-                  ((g 'remove-node!) root)
-                  (set! repeat? #t))
-                (delete 0 ((g 'roots)) eq?))
-      (when repeat? (loop))))
+  (let loop ((repeat? #f))
+    (for-each (lambda (root)
+                ((g 'remove-node!) root)
+                (set! repeat? #t))
+              (delete 0 ((g 'roots)) eq?))
+    (when repeat? (loop #f)))
   g)
 
+(define (get-dominator-alist g)
+  (let ((pred (g 'pred))
+        (fen (g 'foreach-node))
+        (dalist
+         (cons (list 0 0)
+               (map (lambda (n)
+                      (cons (first n)
+                            (list-copy (unzip1 ((g 'nodes))))))
+                    (remove (o zero? first)
+                            ((g 'nodes)))))))
+    (let loop ((changed #f))
+      (for-each (lambda (da)
+                  (let* ((preds (pred (car da)))
+                         (pre-doms (map (o cdr (cut assq <> dalist)) preds))
+                         (new-doms
+                          (lset-adjoin eq?
+                                       (if (null? (cdr pre-doms))
+                                           (car pre-doms)
+                                           (apply lset-intersection eq? pre-doms))
+                                       (car da))))
+                    (unless (eq? (length new-doms)
+                                 (length (cdr da)))
+                      (set! changed #t)
+                      (set-cdr! da new-doms))))
+                (cdr dalist))
+      (when changed
+        (loop #f)))
+    (map (lambda (da)
+           (cons (car da)
+                 (delete (car da) (cdr da) eq?)))
+         (cdr dalist))))
+
+(define (get-immed-dominator-alist g)
+  (let ((tninfo (o second (g 'node-info))))
+    (map (lambda (da)
+           (cons (car da)
+                 (fold (lambda (a z)
+                         (if (> (post-order (tninfo a))
+                                (post-order (tninfo z)))
+                             a
+                             z))
+                       (cadr da)
+                       (cddr da))))
+         (get-dominator-alist g))))
+
 (define (find-interval nodes immed-preds interval)
   (let ((new-inodes
          (partition (lambda (n)
@@ -117,7 +147,6 @@
                   (loop (append headers new-headers)
                         (append (cdr unproc-headers) new-headers))))))))
 
-
 (define (get-neighbour-intervals interval intervals neighbours selector)
   (delete-duplicates
    (map (lambda (n)
@@ -140,7 +169,12 @@
     (cut get-neighbour-intervals <> ivs <> <>))
   (let* ((g+1 (make-digraph 'derived-graph (cons g ivs)))
          (ii (list-tabulate (length ivs) identity)))
-    (for-each (cut (g+1 'add-node!) <> <>) ii ivs)
+    (for-each (cute (g+1 'add-node!) <> <>)
+              ii
+              (map (lambda (iv)
+                     (cons (car ((g 'node-info) (car iv)))
+                           (append-map (o cdr (g 'node-info)) iv)))
+                   ivs))
     (for-each (lambda (i iv)
                 (let ((sipreds (get-neigh-ivs iv (g 'in-edges) first))
                       (sisuccs (get-neigh-ivs iv (g 'out-edges) second)))
@@ -155,3 +189,11 @@
               ii
               ivs)
     (values g+1 (generate-intervals g+1 (list 0)))))
+
+(define (generate-derived-graph-sequence g ivs)
+  (cons (cons g ivs)
+        (receive (g+1 ivs+1)
+            (derive-graph g ivs)
+          (if (eq? ((g+1 'order)) ((g 'order)))
+              '()
+              (generate-derived-graph-sequence g+1 ivs+1)))))

Added: tools/branches/gsoc2007-decompiler/pseudo.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/pseudo.scm	                        (rev 0)
+++ tools/branches/gsoc2007-decompiler/pseudo.scm	2007-08-13 03:32:00 UTC (rev 28576)
@@ -0,0 +1,24 @@
+;;;; pseudo.scm
+
+;;; Antipasto - Scumm Script Disassembler Prototype
+;;; Copyright (C) 2007 Andreas Scholta
+;;; Time-stamp: <2007-07-31 14:39:25 brx>
+
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+(define (pseudo-out out cfg disassembly)
+  (define (output ind str . args)
+    (apply printf (string-append (make-string ind) str) args))
+  #f)


Property changes on: tools/branches/gsoc2007-decompiler/pseudo.scm
___________________________________________________________________
Name: svn:mime-type
   + text/plain
Name: svn:eol-style
   + native

Added: tools/branches/gsoc2007-decompiler/structuring.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/structuring.scm	                        (rev 0)
+++ tools/branches/gsoc2007-decompiler/structuring.scm	2007-08-13 03:32:00 UTC (rev 28576)
@@ -0,0 +1,177 @@
+;;;; structuring.scm
+
+;;; Antipasto - Scumm Script Disassembler Prototype
+;;; Copyright (C) 2007 Andreas Scholta
+;;; Time-stamp: <2007-07-31 21:21:37 brx>
+
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+(define (po->nn g node)
+  (let ((po (post-order node))
+        (ns ((g 'nodes))))
+    (first (find (lambda (n)
+                   (= po (post-order (second (second n)))))
+                 ns))))
+
+;;; Loop Structuring
+
+(define (maybe-get-latching g header ivn)
+  (let ((ninfo (g 'node-info)))
+    (let find-latching ((ins (unzip1 ((g 'in-edges) header))))
+      (cond ((null? ins) #f)
+            ((memq (second (ninfo (car ins))) ivn) (second (ninfo (car ins))))
+            (else (find-latching (cdr ins)))))))
+
+(define (mark-nodes! latching header ivn)
+  (let ((header-po (post-order header))
+        (latching-po (post-order latching)))
+    (let mark ((ivn ivn)
+               (loop-nodes '()))
+      (if (null? ivn)
+          loop-nodes
+          (let* ((node (car ivn))
+                 (linfo (loop-info node)))
+            (if (<= header-po (post-order node) latching-po)
+                (begin
+                  (when (not (loop-head linfo))
+                    (set-loop-head! linfo header)
+                    (set-loop-latch! linfo latching))
+                  (mark (cdr ivn) (cons node loop-nodes)))
+                (mark (cdr ivn) loop-nodes)))))))
+
+(define (choose-loop-type! latching header hnum nodes-in-loop g)
+  (let ((oedges (g 'out-edges))
+        (ninfo (g 'node-info)))
+    (set-loop-type! (loop-info header)
+                    (match (cons (bb-type latching) (bb-type header))
+                      ((('goto-unless . _) . ('goto-unless . _))
+                       (let ((oe (map second (oedges hnum))))
+                         (if (and (memq (second (ninfo (first oe))) nodes-in-loop)
+                                  (memq (second (ninfo (second oe))) nodes-in-loop))
+                             'post-tested
+                             'pre-tested)))
+                      ((('goto-unless . _) . (or ('goto . _) 'fall 'return))
+                       'post-tested)
+                      (((or ('goto . _ ) 'fall 'return) . ('goto-unless . _))
+                       'pre-tested)
+                      (((or ('goto . _) 'fall 'return) . (or ('goto . _) 'fall 'return))
+                       'endless)))))
+
+(define (choose-loop-follow! latching lnum header hnum nodes-in-loop g)
+  (let ((oedges (g 'out-edges))
+        (ninfo (g 'node-info)))
+    (set-loop-follow! (loop-info header)
+                      (case (loop-type (loop-info header))
+                        ((pre-tested)
+                         (let ((oe (map second (oedges hnum))))
+                           (if (memq (second (ninfo (first oe))) nodes-in-loop)
+                               (second (ninfo (second oe)))
+                               (second (ninfo (first oe))))))
+                        ((post-tested)
+                         (let ((oe (map second (oedges lnum))))
+                           (if (memq (second (ninfo (first oe))) nodes-in-loop)
+                               (second (ninfo (second oe)))
+                               (second (ninfo (first oe))))))
+                        (else
+                         (let ((fol (expt 2 32))
+                               (cn #f))
+                           (for-each (lambda (twn)
+                                       (let ((oe (map second (oedges (po->nn g twn)))))
+                                         (cond
+                                           ((and (not (memq (second (ninfo (first oe)))
+                                                            nodes-in-loop))
+                                                 (< (post-order (second (ninfo (first oe)))) fol))
+                                            (set! cn (second (ninfo (second oe))))
+                                            (set! fol (post-order (second (ninfo (first oe))))))
+                                           ((and (not (memq (second (ninfo (second oe)))
+                                                            nodes-in-loop))
+                                                 (< (post-order (second (ninfo (second oe)))) fol))
+                                            (set! cn (second (ninfo (second oe))))
+                                            (set! fol (post-order (second (ninfo (second oe)))))))))
+                                     (filter (lambda (node)
+                                               (match (bb-type node)
+                                                 (('goto-unless . _) #t)
+                                                 (else #f)))
+                                             nodes-in-loop))
+                           cn))))))
+
+(define (structure-loops! top-graph dgs)
+  (if (null? dgs)
+      (void)
+      (match-let ((((g . ivs) . rest) dgs))
+        (for-each (lambda (iv)
+                    (let* ((iv-nodes (append-map (o cdr (g 'node-info)) iv))
+                           (header (car iv-nodes))
+                           (hnum (car ((g 'node-info) (car iv))))
+                           (latching (maybe-get-latching top-graph hnum iv-nodes)))
+                      (when latching
+                        (let ((nodes-in-loop (mark-nodes! latching header iv-nodes)))
+                          (choose-loop-type! latching
+                                             header
+                                             hnum
+                                             nodes-in-loop
+                                             top-graph)
+                          (choose-loop-follow! latching
+                                               (po->nn top-graph latching)
+                                               header
+                                               hnum
+                                               nodes-in-loop
+                                               top-graph)))))
+                  ivs)
+        (structure-loops! top-graph rest))))
+
+;;; Conditionals Structuring
+
+(define (head-or-latch? node)
+  (let ((linfo (loop-info node)))
+    (or (eq? (loop-head linfo) node)
+        (eq? (loop-latch linfo) node))))
+
+(define (structure-2-way! top-graph)
+  (let ((ninfo (o second (top-graph 'node-info)))
+        (idoms (get-immed-dominator-alist top-graph)))
+    (let loop ((nodes (unzip1
+                       (sort (graph-postorder top-graph 0)
+                             (lambda (a b)
+                               (< (second a) (second b))))))
+               (unresolved '()))
+      (if (null? nodes)
+          (void)
+          (let ((node (car nodes)))
+            (if (not (head-or-latch? (ninfo node)))
+                (let ((ns (unzip1 (partition (lambda (idom)
+                                               (eq? node (cdr idom)))
+                                             idoms))))
+                  (if (null? ns)
+                      (loop (cdr nodes)
+                            (cons node unresolved))
+                      (let ((m (car
+                                (sort ns
+                                      (lambda (a b)
+                                        (> (post-order (ninfo a))
+                                           (post-order (ninfo b))))))))
+                        (for-each (lambda (ur)
+                                    (set-bb-follow! (ninfo ur)
+                                                    (ninfo m)))
+                                  unresolved)
+                        (set-bb-follow! (ninfo node)
+                                        (ninfo m))
+                        (loop (cdr nodes) '()))))
+                (loop (cdr nodes) unresolved)))))))
+
+;; (test-run "/home/brx/code/gsoc2007-decompiler/M1.scummV5/81.cu_bar_2.0092")
+;; (test-run "/home/brx/code/gsoc2007-decompiler/M2.scummV5/entry-4.dmp")
+;; (test-run "/home/brx/code/gsoc2007-decompiler/M2.scummV5/room-15-203.dmp")
+;; (test-run "/home/brx/code/gsoc2007-decompiler/M1.scummV5/01.beach.0201")


Property changes on: tools/branches/gsoc2007-decompiler/structuring.scm
___________________________________________________________________
Name: svn:mime-type
   + text/plain
Name: svn:eol-style
   + native


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.




More information about the Scummvm-git-logs mailing list