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

brixxie at users.sourceforge.net brixxie at users.sourceforge.net
Sat Jul 14 22:36:26 CEST 2007


Revision: 28079
          http://scummvm.svn.sourceforge.net/scummvm/?rev=28079&view=rev
Author:   brixxie
Date:     2007-07-14 13:36:26 -0700 (Sat, 14 Jul 2007)

Log Message:
-----------
Added derived graph sequencing algorithm, added fixed digraph egg,
updated README

changed properties..

Modified Paths:
--------------
    tools/branches/gsoc2007-decompiler/README
    tools/branches/gsoc2007-decompiler/antipasto.scm
    tools/branches/gsoc2007-decompiler/cfgg.scm
    tools/branches/gsoc2007-decompiler/graph.scm

Added Paths:
-----------
    tools/branches/gsoc2007-decompiler/eggs/
    tools/branches/gsoc2007-decompiler/eggs/digraph-fix.patch
    tools/branches/gsoc2007-decompiler/eggs/digraph.egg

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


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

Modified: tools/branches/gsoc2007-decompiler/README
===================================================================
--- tools/branches/gsoc2007-decompiler/README	2007-07-14 18:26:43 UTC (rev 28078)
+++ tools/branches/gsoc2007-decompiler/README	2007-07-14 20:36:26 UTC (rev 28079)
@@ -17,18 +17,19 @@
 
 Build procedure:
 
-Two CHICKEN libraries ("eggs") are needed to compile Antipasto:
+These CHICKEN libraries ("eggs") are needed to compile Antipasto:
 
-  - syntax-case.egg
-  - numbers.egg
-  - digraph.egg
-    (has own dependencies which should be resolved by
-     chicken-setup automatically)
+  - syntax-case
+  - numbers
+  - vector-lib
+  - dyn-vector
+  - digraph (use the fixed egg from eggs/)
 
 To obtain these execute
 
   $ chicken-setup syntax-case
   $ chicken-setup numbers
+  ...
 
 in your favorite shell. Afterwards a simple
 

Modified: tools/branches/gsoc2007-decompiler/antipasto.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/antipasto.scm	2007-07-14 18:26:43 UTC (rev 28078)
+++ tools/branches/gsoc2007-decompiler/antipasto.scm	2007-07-14 20:36:26 UTC (rev 28079)
@@ -2,7 +2,7 @@
 
 ;;; Antipasto - Scumm Script Disassembler Prototype (version 5 scripts)
 ;;; Copyright (C) 2007 Andreas Scholta
-;;; Time-stamp: <2007-07-13 22:16:52 brx>
+;;; Time-stamp: <2007-07-14 19:09:42 brx>
 
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License

Modified: tools/branches/gsoc2007-decompiler/cfgg.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/cfgg.scm	2007-07-14 18:26:43 UTC (rev 28078)
+++ tools/branches/gsoc2007-decompiler/cfgg.scm	2007-07-14 20:36:26 UTC (rev 28079)
@@ -2,7 +2,7 @@
 
 ;;; Antipasto - Scumm Script Disassembler Prototype
 ;;; Copyright (C) 2007 Andreas Scholta
-;;; Time-stamp: <2007-07-14 02:17:58 brx>
+;;; Time-stamp: <2007-07-14 19:15:00 brx>
 
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License
@@ -25,7 +25,7 @@
   (range bb-range set-bb-range!))
 
 (define-record-printer (basic-block x out)
-  (fprintf out "#,(basic-block ~S ~S)" (bb-type x) (bb-range x)))
+  (fprintf out "(basic-block ~A ~A)" (bb-type x) (bb-range x)))
 
 (define (bb-update! bb #!key type range)
   (when type (set-bb-type! bb type))
@@ -94,11 +94,8 @@
                 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 b)
-                ((g 'add-node!) i b))
-              ii
-              blocks)
-    (for-each (lambda (i b)
                 (let ((outs (match (bb-type b)
                               (('goto-unless jump-addr _)
                                (list (add1 i)
@@ -110,24 +107,24 @@
                               (else
                                #f))))
                   (when outs
-                    (for-each (g 'add-edge!)
-                              (map (lambda (out)
-                                     (list i
-                                           out
-                                           (cons b (list-ref blocks out))))
-                                   outs)))))
+                    (for-each (lambda (out)
+                                (unless ((g 'has-edge) i out)
+                                  ((g 'add-edge!)
+                                   (list i out #f))))
+                              outs))))
               ii
               blocks)
     g))
 
 (define (generate-control-flow-graph disassembly)
   (let ((cfg
-         (blocks->cfg
-          (correct-blocks!
-           (generate-trivial-blocks
-            (map (lambda (instruction)
-                   (cons (car instruction) (cddr instruction)))
-                 disassembly))))))
+         (remove-isolated!
+          (blocks->cfg
+           (correct-blocks!
+            (generate-trivial-blocks
+             (map (lambda (instruction)
+                    (cons (car instruction) (cddr instruction)))
+                  disassembly)))))))
     (values ((cfg 'nodes))
             (generate-intervals cfg (list 0)))))
 

Added: tools/branches/gsoc2007-decompiler/eggs/digraph-fix.patch
===================================================================
--- tools/branches/gsoc2007-decompiler/eggs/digraph-fix.patch	                        (rev 0)
+++ tools/branches/gsoc2007-decompiler/eggs/digraph-fix.patch	2007-07-14 20:36:26 UTC (rev 28079)
@@ -0,0 +1,59 @@
+--- digraph.scm	2007-05-30 05:12:18.000000000 +0200
++++ digraph-fixed.scm	2007-07-14 17:48:36.296839726 +0200
+@@ -108,13 +108,13 @@
+     (define (remove-pred elst j ax)
+       (match elst 
+ 	     (() (dynvector-set! pred j ax))
+-	     (((i1 . _) . es)  (let ((e (car elst)))
+-				 (remove-pred es j (if (fx= i1 i) es (cons e es)))))
++	     (((i1 _ _) . es)  (let ((e (car elst)))
++				 (remove-pred es j (if (fx= i1 i) ax (cons e ax)))))
+ 	     (else   (digraph:error 'remove-pred ": invalid edge list " elst))))
+ 
+     (define (remove-edge e)
+       (match e 
+-	     ((i1 j . _)  (begin
++	     ((i1 j _)  (begin
+ 			    (if (not (fx= i i1)) (digraph:error 'set-out-edges))
+ 			    (remove-pred (dynvector-ref pred j) j (list))))
+ 	     (else (digraph:error 'remove-edge ": invalid edge " e))))
+@@ -134,16 +134,16 @@
+   (define (set-in-edges! j edges)
+     (define (remove-succ elst i ax)
+       (match elst 
+-	     (() (dynvector-set! pred j ax))
++	     (() (dynvector-set! succ i ax))
+ 	     (((_ j1 _) . es)  (let ((e (car elst)))
+-				 (remove-succ es i (if (fx= j1 j) es (cons e es)))))
++				 (remove-succ es i (if (fx= j1 j) ax (cons e ax)))))
+ 	     (else   (digraph:error 'remove-succ ": invalid edge list " elst))))
+ 
+     (define (remove-edge e)
+       (match e 
+-	     ((i j1 . _)  (begin
++	     ((i j1 _)  (begin
+ 			    (if (not (fx= j j1)) (digraph:error 'set-in-edges))
+-			    (remove-succ (dynvector-ref pred i) i (list))))
++			    (remove-succ (dynvector-ref succ i) i (list))))
+ 	     (else (digraph:error 'remove-edge ": invalid edge " e))))
+ 
+     (define (add-succ e)
+@@ -230,11 +230,16 @@
+ 	((foreach-node)      foreach-node)
+         ((foreach-edge)      foreach-edge)
+ 	((roots)             (lambda ()
+-			       (filter-map (lambda (n) (if (null? (in-edges (car n))) (car n) #f)) 
++			       (filter-map (lambda (n)
++                                             (if (null?
++                                                  ;; check only edges from other nodes
++                                                  (remove (o (cut fx= <> (car n)) car)
++                                                          (in-edges (car n))))
++                                                 (car n)
++                                                 #f))
+ 					   (get-nodes))))
+ 	((debug)             (list (cons nodes (dynvector->list nodes))
+ 				   (cons succ (dynvector->list succ))
+ 				   (cons pred (dynvector->list pred))))
+         (else
+           (digraph:error 'selector ": unknown message " selector " sent to a graph"))))))
+-


Property changes on: tools/branches/gsoc2007-decompiler/eggs/digraph-fix.patch
___________________________________________________________________
Name: svn:mime-type
   + text/plain
Name: svn:eol-style
   + native

Added: tools/branches/gsoc2007-decompiler/eggs/digraph.egg
===================================================================
(Binary files differ)


Property changes on: tools/branches/gsoc2007-decompiler/eggs/digraph.egg
___________________________________________________________________
Name: svn:mime-type
   + application/x-gzip

Modified: tools/branches/gsoc2007-decompiler/graph.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/graph.scm	2007-07-14 18:26:43 UTC (rev 28078)
+++ tools/branches/gsoc2007-decompiler/graph.scm	2007-07-14 20:36:26 UTC (rev 28079)
@@ -2,7 +2,7 @@
 
 ;;; Antipasto - Scumm Script Disassembler Prototype
 ;;; Copyright (C) 2007 Andreas Scholta
-;;; Time-stamp: <2007-07-14 02:21:16 brx>
+;;; Time-stamp: <2007-07-14 18:02:02 brx>
 
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License
@@ -18,6 +18,16 @@
 ;;; along with this program; if not, write to the Free Software
 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 
+(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))))
+  g)
+
 (define (find-interval nodes immed-preds interval)
   (let ((new-inodes
          (partition (lambda (n)
@@ -32,21 +42,58 @@
         (find-interval nodes immed-preds (append interval new-inodes)))))
 
 (define (generate-intervals g headers)
-  (let loop ((headers headers)
-             (unproc-headers headers))
-    (if (null? unproc-headers)
-        '()
-        (let* ((nodes (unzip1 ((g 'nodes))))
-               (immed-preds (o unzip1 (g 'in-edges)))
-               (new-interval
-                (find-interval nodes immed-preds (list (car unproc-headers))))
-               (new-headers
-                (partition (lambda (n)
-                             (and (not (memq n headers))
-                                  (not (memq n new-interval))
-                                  (any (cut memq <> new-interval)
-                                       (immed-preds n))))
-                           nodes)))
-          (cons new-interval
-                (loop (append headers new-headers)
-                      (append (cdr unproc-headers) new-headers)))))))
+  (let ((nodes (unzip1 ((g 'nodes))))
+        (immed-preds (o unzip1 (g 'in-edges))))
+    (let loop ((headers headers)
+               (unproc-headers headers))
+      (if (null? unproc-headers)
+          '()
+          (let* ((new-interval
+                  (find-interval nodes immed-preds (list (car unproc-headers))))
+                 (new-headers
+                  (partition (lambda (n)
+                               (and (not (memq n headers))
+                                    (not (memq n new-interval))
+                                    (any (cut memq <> new-interval)
+                                         (immed-preds n))))
+                             nodes)))
+            (cons new-interval
+                  (loop (append headers new-headers)
+                        (append (cdr unproc-headers) new-headers))))))))
+
+
+(define (get-neighbour-intervals interval intervals neighbours selector)
+  (delete-duplicates
+   (map (lambda (n)
+          (let ((ind (list-index (cut member n <>) intervals)))
+            ;; assert that n IS part of an interval ...
+            (assert ind)
+            ind))
+        (lset-difference eq?
+                         (delete-duplicates
+                          (append-map (o (cut map selector <>) neighbours)
+                                      interval)
+                          eq?)
+                         interval))
+   eq?))
+
+(define (derive-graph g ivs)
+  (define get-neigh-ivs
+    (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 (lambda (i iv)
+                (let ((sipreds (get-neigh-ivs iv (g 'in-edges) first))
+                      (sisuccs (get-neigh-ivs iv (g 'out-edges) second)))
+                  (for-each (lambda (j)
+                              (unless ((g+1 'has-edge) j i)
+                                ((g+1 'add-edge!) (list j i #f))))
+                            sipreds)
+                  (for-each (lambda (j)
+                              (unless ((g+1 'has-edge) i j)
+                                ((g+1 'add-edge!) (list i j #f))))
+                            sisuccs)))
+              ii
+              ivs)
+    (values g+1 (generate-intervals g+1 (list 0)))))


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