[Scummvm-cvs-logs] SF.net SVN: scummvm: [27982] tools/branches/gsoc2007-decompiler
brixxie at users.sourceforge.net
brixxie at users.sourceforge.net
Mon Jul 9 01:38:34 CEST 2007
Revision: 27982
http://scummvm.svn.sourceforge.net/scummvm/?rev=27982&view=rev
Author: brixxie
Date: 2007-07-08 16:38:33 -0700 (Sun, 08 Jul 2007)
Log Message:
-----------
Added (fixed) Basic Block generation code
Modified Paths:
--------------
tools/branches/gsoc2007-decompiler/Makefile
tools/branches/gsoc2007-decompiler/antipasto.scm
tools/branches/gsoc2007-decompiler/cfgg.scm
tools/branches/gsoc2007-decompiler/util.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:38
+ 489ca303-0d3d-4dc1-a57d-017c7912a06a:/local/gsoc2007-decompiler:39
Modified: tools/branches/gsoc2007-decompiler/Makefile
===================================================================
--- tools/branches/gsoc2007-decompiler/Makefile 2007-07-08 23:38:03 UTC (rev 27981)
+++ tools/branches/gsoc2007-decompiler/Makefile 2007-07-08 23:38:33 UTC (rev 27982)
@@ -32,7 +32,7 @@
desword2$(EXEEXT): desword2.o util.o
$(CXX) $(LDFLAGS) -o $@ $+
-antipasto$(EXEEXT): antipasto.scm util.scm
+antipasto$(EXEEXT): antipasto.scm util.scm cfgg.scm
csc $< -o $@ -postlude [main]
descumm.o descumm6.o descumm-common.o descumm-tool.o: descumm.h
Modified: tools/branches/gsoc2007-decompiler/antipasto.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/antipasto.scm 2007-07-08 23:38:03 UTC (rev 27981)
+++ tools/branches/gsoc2007-decompiler/antipasto.scm 2007-07-08 23:38:33 UTC (rev 27982)
@@ -2,7 +2,7 @@
;;; Antipasto - Scumm Script Disassembler Prototype (version 5 scripts)
;;; Copyright (C) 2007 Andreas Scholta
-;;; Time-stamp: <2007-07-07 01:11:26 brx>
+;;; Time-stamp: <2007-07-08 20:34:50 brx>
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
@@ -21,6 +21,7 @@
(require-extension posix numbers srfi-1)
(include "util.scm")
+(include "cfgg.scm")
(define current-script-file #f)
(define current-script-port #f)
@@ -689,8 +690,7 @@
(register-123-op 'band! #x17 handle-sarith 1)
(define (calc-abs-jump relative)
- (sprintf "~X" ;only for testing purposes with intermediary format
- (band #x7fff (+ relative current-script-offset))))
+ (band #x7fff (+ relative current-script-offset)))
(register-opcode 'goto
#x18
@@ -812,16 +812,19 @@
(set! current-script-port (open-input-file current-script-file))
(set! current-script-offset 0)
(parse-header)
- (let print-decoded ((decoded (decode-ops '())))
- (unless (or (null? decoded)
- (not decoded)
- (not (car decoded)))
- (printf "[~X] (~X) "
- (caar decoded)
- (cadar decoded))
- (write (cddar decoded))
- (newline)
- (print-decoded (cdr decoded))))
+ (let ((decoded (decode-ops '())))
+ (let print-decoded ((decoded decoded))
+ (unless (or (null? decoded)
+ (not decoded)
+ (not (car decoded)))
+ (printf "[~A] (~X) "
+ (caar decoded)
+ (cadar decoded))
+ (write (cddar decoded))
+ (newline)
+ (print-decoded (cdr decoded))))
+ (for-each (cut printf "~S\n" <>)
+ (generate-control-flow-graph decoded)))
(close-input-port current-script-port)
(set! current-script-port #f)
(set! current-script-file #f)
@@ -829,7 +832,7 @@
;; (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/M2.scummV5/room-15-203.dmp")
;; (test-run "/home/brx/code/gsoc2007-decompiler/M1.scummV5/01.beach.0201")
(define (main)
Modified: tools/branches/gsoc2007-decompiler/cfgg.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/cfgg.scm 2007-07-08 23:38:03 UTC (rev 27981)
+++ tools/branches/gsoc2007-decompiler/cfgg.scm 2007-07-08 23:38:33 UTC (rev 27982)
@@ -2,7 +2,7 @@
;;; Antipasto - Scumm Script Disassembler Prototype
;;; Copyright (C) 2007 Andreas Scholta
-;;; Time-stamp: <2007-07-07 20:06:40 brx>
+;;; Time-stamp: <2007-07-09 01:31:43 brx>
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
@@ -17,3 +17,139 @@
;;; 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-record basic-block type range preds succs)
+
+(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))))
+
+(define (create-basic-block type range)
+ (make-basic-block type range '() '()))
+
+(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))
+ '())
+ (let ((instr (car instrs)))
+ (case (cadr instr)
+ ((goto goto-unless)
+ (values (create-basic-block (cdr instr)
+ (reverse (cons (car instr)
+ addrs)))
+ (cdr instrs)))
+ (else
+ (get-trivial (cons (car instr) addrs)
+ (cdr instrs))))))))
+
+(define (generate-trivial-blocks disassembly blocks connect?)
+ (if (null? disassembly)
+ (reverse blocks)
+ (receive (trivial-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)))))))
+
+(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)
+ (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)))))))
+
+(define (find/splice-block! block 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)))
+ ((memq jump-addr fblock-range)
+ (call-with-values
+ (lambda ()
+ (splice-block! fblock jump-addr block))
+ (cut cons* <> <> (cdr fblocks))))
+ (else
+ (cons fblock
+ (find/splice-block! block
+ 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 (generate-control-flow-graph disassembly)
+ (let ((trivial-blocks
+ (generate-trivial-blocks
+ (remove-opcodes-from-disassembly disassembly) '() #f)))
+ (correct-trivial-blocks! trivial-blocks trivial-blocks)))
+
+;; (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")
Modified: tools/branches/gsoc2007-decompiler/util.scm
===================================================================
--- tools/branches/gsoc2007-decompiler/util.scm 2007-07-08 23:38:03 UTC (rev 27981)
+++ tools/branches/gsoc2007-decompiler/util.scm 2007-07-08 23:38:33 UTC (rev 27982)
@@ -2,7 +2,7 @@
;;; Antipasto - Scumm Script Disassembler Prototype
;;; Copyright (C) 2007 Andreas Scholta
-;;; Time-stamp: <2007-07-07 01:11:13 brx>
+;;; Time-stamp: <2007-07-08 20:45:42 brx>
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
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