[Scummvm-cvs-logs] SF.net SVN: scummvm: [28075] tools/branches/gsoc2007-decompiler
brixxie at users.sourceforge.net
brixxie at users.sourceforge.net
Sat Jul 14 19:30:45 CEST 2007
Revision: 28075
http://scummvm.svn.sourceforge.net/scummvm/?rev=28075&view=rev
Author: brixxie
Date: 2007-07-14 10:30:44 -0700 (Sat, 14 Jul 2007)
Log Message:
-----------
Changed code to make use of the digraph egg,
moved purely graph related procedures to graph.scm
Modified Paths:
--------------
tools/branches/gsoc2007-decompiler/README
tools/branches/gsoc2007-decompiler/antipasto.scm
tools/branches/gsoc2007-decompiler/cfgg.scm
Added Paths:
-----------
tools/branches/gsoc2007-decompiler/graph.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:42
+ 489ca303-0d3d-4dc1-a57d-017c7912a06a:/local/gsoc2007-decompiler:43
Modified: tools/branches/gsoc2007-decompiler/README
===================================================================
--- tools/branches/gsoc2007-decompiler/README 2007-07-14 17:29:58 UTC (rev 28074)
+++ tools/branches/gsoc2007-decompiler/README 2007-07-14 17:30:44 UTC (rev 28075)
@@ -21,6 +21,9 @@
- syntax-case.egg
- numbers.egg
+ - digraph.egg
+ (has own dependencies which should be resolved by
+ chicken-setup automatically)
To obtain these execute
Modified: tools/branches/gsoc2007-decompiler/antipasto.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/antipasto.scm 2007-07-14 17:29:58 UTC (rev 28074)
+++ tools/branches/gsoc2007-decompiler/antipasto.scm 2007-07-14 17:30:44 UTC (rev 28075)
@@ -2,7 +2,7 @@
;;; Antipasto - Scumm Script Disassembler Prototype (version 5 scripts)
;;; Copyright (C) 2007 Andreas Scholta
-;;; Time-stamp: <2007-07-10 20:27:13 brx>
+;;; Time-stamp: <2007-07-13 22:16:52 brx>
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
@@ -18,9 +18,10 @@
;;; 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 posix numbers srfi-1)
+(require-extension srfi-1 posix numbers digraph)
(include "util.scm")
+(include "graph.scm")
(include "cfgg.scm")
(define current-script-file #f)
Modified: tools/branches/gsoc2007-decompiler/cfgg.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/cfgg.scm 2007-07-14 17:29:58 UTC (rev 28074)
+++ tools/branches/gsoc2007-decompiler/cfgg.scm 2007-07-14 17:30:44 UTC (rev 28075)
@@ -2,7 +2,7 @@
;;; Antipasto - Scumm Script Disassembler Prototype
;;; Copyright (C) 2007 Andreas Scholta
-;;; Time-stamp: <2007-07-10 20:25:19 brx>
+;;; Time-stamp: <2007-07-14 02:17:58 brx>
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
@@ -18,171 +18,118 @@
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
-(define-record basic-block type range preds succs)
+(define-record-type basic-block
+ (basic-block type range)
+ basic-block?
+ (type bb-type set-bb-type!)
+ (range bb-range set-bb-range!))
(define-record-printer (basic-block x out)
- (fprintf out
- "#,(basic-block ~S ~S ~S ~S)"
- (basic-block-type x)
- (basic-block-range x)
- (map basic-block-range (basic-block-preds x))
- (map basic-block-range (basic-block-succs x))))
+ (fprintf out "#,(basic-block ~S ~S)" (bb-type x) (bb-range x)))
-(define (create-basic-block type range)
- (make-basic-block type range '() '()))
+(define (bb-update! bb #!key type range)
+ (when type (set-bb-type! bb type))
+ (when range (set-bb-range! bb range))
+ bb)
-(define (basic-block-type-smart block)
- (let ((type (basic-block-type block)))
- (if (pair? type)
- (car type)
- type)))
-
-(define (update-basic-block! block #!key type range preds succs)
- (when type (basic-block-type-set! block type))
- (when range (basic-block-range-set! block range))
- (when preds (basic-block-preds-set! block preds))
- (when succs (basic-block-succs-set! block succs))
- block)
-
-(define (basic-block-connect! pred succ)
- (basic-block-succs-set! pred (cons succ (basic-block-succs pred)))
- (basic-block-preds-set! succ (cons pred (basic-block-preds succ)))
- succ)
-
-(define (remove-opcodes-from-disassembly disassembly)
- (map (lambda (instruction)
- (cons (car instruction)
- (cddr instruction)))
- disassembly))
-
(define (get-trivial-block instructions)
(let get-trivial ((addrs '())
(instrs instructions))
(if (null? instrs)
- (values (create-basic-block 'return
- (reverse addrs))
+ (values (basic-block 'return (reverse addrs))
'())
- (let ((instr (car instrs)))
- (case (cadr instr)
+ (match-let (((addr . op-info) (car instrs)))
+ (case (car op-info)
((goto goto-unless)
- (values (create-basic-block (cdr instr)
- (reverse (cons (car instr)
- addrs)))
+ (values (basic-block op-info (reverse (cons addr addrs)))
(cdr instrs)))
(else
- (get-trivial (cons (car instr) addrs)
- (cdr instrs))))))))
+ (get-trivial (cons addr addrs) (cdr instrs))))))))
-(define (generate-trivial-blocks disassembly blocks connect?)
+(define (generate-trivial-blocks disassembly)
(if (null? disassembly)
- (reverse blocks)
- (receive (trivial-block rest)
+ '()
+ (receive (block rest)
(get-trivial-block disassembly)
- (when connect? (basic-block-connect! (car blocks) trivial-block))
- (generate-trivial-blocks
- rest
- (cons trivial-block blocks)
- (not
- (eq? 'goto
- (basic-block-type-smart trivial-block)))))))
+ (cons block (generate-trivial-blocks rest)))))
-(define (rewire-preds! block new-succ)
- (for-each (lambda (pred)
- (basic-block-succs-set!
- pred
- (cons new-succ
- (delete block (basic-block-succs pred) eq?))))
- (basic-block-preds block)))
-
-(define (splice-block! block pivot pred)
+(define (splice-block! block pivot)
(receive (fall-range rest-range)
- (partition (cut < <> pivot)
- (basic-block-range block))
- (let ((fall-block (make-basic-block 'fall fall-range
- (basic-block-preds block)
- (list block))))
- (rewire-preds! block fall-block)
- (values
- fall-block
- (basic-block-connect! pred
- (update-basic-block! block
- range: rest-range
- preds: (list fall-block)))))))
+ (partition (cut < <> pivot) (bb-range block))
+ (let ((fall-block (basic-block 'fall fall-range)))
+ (values fall-block
+ (bb-update! block range: rest-range)))))
-(define (find/splice-block! block jump-addr fblocks)
+(define (find/splice-block-at! jump-addr fblocks)
(if (null? fblocks)
'()
(let* ((fblock (car fblocks))
- (fblock-range (basic-block-range fblock)))
- (cond ((eq? (car fblock-range) jump-addr)
- (cons (basic-block-connect! block fblock)
- (cdr fblocks)))
+ (fblock-range (bb-range fblock)))
+ (cond ((eq? (car fblock-range) jump-addr) fblocks)
((memq jump-addr fblock-range)
(call-with-values
(lambda ()
- (splice-block! fblock jump-addr block))
+ (splice-block! fblock jump-addr))
(cut cons* <> <> (cdr fblocks))))
(else
(cons fblock
- (find/splice-block! block
- jump-addr
- (cdr fblocks))))))))
+ (find/splice-block-at! jump-addr (cdr fblocks))))))))
-(define (correct-trivial-blocks! trivial-blocks fixed-blocks)
- (if (null? trivial-blocks)
- fixed-blocks
- (let* ((block (car trivial-blocks))
- (type (basic-block-type block))
- (smart-type (basic-block-type-smart block)))
- (if (or (eq? 'goto-unless smart-type)
- (eq? 'goto smart-type))
- (correct-trivial-blocks! (cdr trivial-blocks)
- (find/splice-block! block
- (cadr type)
- fixed-blocks))
- (correct-trivial-blocks! (cdr trivial-blocks)
- fixed-blocks)))))
+(define (correct-blocks! blocks)
+ (let loop ((blocks blocks)
+ (fixed-blocks blocks))
+ (if (null? blocks)
+ fixed-blocks
+ (match (bb-type (car blocks))
+ (((or 'goto-unless 'goto) jump-addr . _)
+ (loop (cdr blocks)
+ (find/splice-block-at! jump-addr fixed-blocks)))
+ (else
+ (loop (cdr blocks) fixed-blocks))))))
-(define (find-interval interval basic-blocks)
- (let ((new-interval-nodes (partition (lambda (block)
- (and (not (memq block interval))
- (every (cut memq <> interval)
- (basic-block-preds block))))
- basic-blocks)))
- (if (null? new-interval-nodes)
- interval
- (find-interval (append interval
- new-interval-nodes)
- basic-blocks))))
+(define (blocks->cfg blocks)
+ (define (target-block-index jump-addr)
+ (list-index (o (cut memq jump-addr <>)
+ bb-range)
+ blocks))
+ (let ((g (make-digraph 'cfg "control flow graph"))
+ (ii (list-tabulate (length blocks) identity)))
+ (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)
+ (target-block-index jump-addr)))
+ (('goto jump-addr)
+ (list (target-block-index jump-addr)))
+ ('fall
+ (list (add1 i)))
+ (else
+ #f))))
+ (when outs
+ (for-each (g 'add-edge!)
+ (map (lambda (out)
+ (list i
+ out
+ (cons b (list-ref blocks out))))
+ outs)))))
+ ii
+ blocks)
+ g))
-(define (generate-intervals unprocessed-headers headers basic-blocks)
- (if (null? unprocessed-headers)
- '()
- (let* ((new-interval (find-interval (list (car unprocessed-headers))
- basic-blocks))
- (new-headers (partition (lambda (block)
- (and (not (memq block headers))
- (not (memq block new-interval))
- (any (cut memq <> new-interval)
- (basic-block-preds block))))
- basic-blocks)))
- (cons new-interval
- (generate-intervals (append (cdr unprocessed-headers)
- new-headers)
- (append headers
- new-headers)
- basic-blocks)))))
-
(define (generate-control-flow-graph disassembly)
- (let* ((trivial-blocks
- (generate-trivial-blocks
- (remove-opcodes-from-disassembly disassembly) '() #f))
- (basic-blocks (correct-trivial-blocks! trivial-blocks
- trivial-blocks)))
- (values basic-blocks
- (generate-intervals (list (car basic-blocks))
- (list (car basic-blocks))
- basic-blocks))))
+ (let ((cfg
+ (blocks->cfg
+ (correct-blocks!
+ (generate-trivial-blocks
+ (map (lambda (instruction)
+ (cons (car instruction) (cddr instruction)))
+ disassembly))))))
+ (values ((cfg 'nodes))
+ (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")
Added: tools/branches/gsoc2007-decompiler/graph.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/graph.scm (rev 0)
+++ tools/branches/gsoc2007-decompiler/graph.scm 2007-07-14 17:30:44 UTC (rev 28075)
@@ -0,0 +1,52 @@
+;;;; graph.scm
+
+;;; Antipasto - Scumm Script Disassembler Prototype
+;;; Copyright (C) 2007 Andreas Scholta
+;;; Time-stamp: <2007-07-14 02:21:16 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 (find-interval nodes immed-preds interval)
+ (let ((new-inodes
+ (partition (lambda (n)
+ (if (memq n interval)
+ #f
+ (let ((ipreds (immed-preds n)))
+ (and (not (null? ipreds))
+ (every (cut memq <> interval) ipreds)))))
+ nodes)))
+ (if (null? new-inodes)
+ interval
+ (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)))))))
Property changes on: tools/branches/gsoc2007-decompiler/graph.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