From 18582cb23f01b945f15e26f5829c28803bd1af4f Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Wed, 27 Jul 2011 18:11:37 -0400
Subject: [PATCH] still working on this...

---
 js-assembler/assemble-structs.rkt |   2 +-
 js-assembler/fracture.rkt         | 129 +++++++++++++++++++++---------
 2 files changed, 90 insertions(+), 41 deletions(-)

diff --git a/js-assembler/assemble-structs.rkt b/js-assembler/assemble-structs.rkt
index 6422808..8da1d60 100644
--- a/js-assembler/assemble-structs.rkt
+++ b/js-assembler/assemble-structs.rkt
@@ -18,7 +18,7 @@
 
 
 
-(define-struct: ComputedJump ([label : (U  Reg
+(define-struct: ComputedJump ([label : (U Reg
                                           ModuleEntry
                                           CompiledProcedureEntry)])
   #:transparent)
diff --git a/js-assembler/fracture.rkt b/js-assembler/fracture.rkt
index ceb4823..2818706 100644
--- a/js-assembler/fracture.rkt
+++ b/js-assembler/fracture.rkt
@@ -17,16 +17,20 @@
 ;; blocks.
 ;;
 ;; A basic block consists of a name, a sequence of straight-line statements,
-;; followed by a branch (or the absence of a branch).
+;; followed by a Jump (conditional, direct, or end-of-program).
 
 (provide fracture)
 
 
 
 
-;; fracture: (listof stmt) -> (listof basic-block)
-(: fracture ((Listof Statement) -> (Listof BasicBlock)))
-(define (fracture stmts)
+;; Make sure:
+;;
+;; The statements are non-empty, by adding a leading label if necessary
+;; Filter out statements that are unreachable by jumps.
+;; Eliminate redundant GOTOs.
+(: cleanup-statements ((Listof Statement) -> (Listof Statement)))
+(define (cleanup-statements stmts)
   (let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
                                                (symbol? (first stmts)))
                                           (first stmts)
@@ -37,41 +41,86 @@
                                           stmts)]
           [jump-targets : (Listof Symbol)
                         (cons first-block-label (collect-general-jump-targets stmts))])
-         (let: loop : (Listof BasicBlock)
-               ([name : Symbol first-block-label]
-                [acc : (Listof UnlabeledStatement) '()]
-                [basic-blocks  : (Listof BasicBlock) '()]
-                [stmts : (Listof Statement) stmts]
-                [last-stmt-goto? : Boolean #f])
-               (cond
-                 [(null? stmts)
-                  (reverse (cons (make-BasicBlock name (reverse acc))
-                                 basic-blocks))]
-                 [else
+    stmts))
+         
 
-                  (: do-on-label (Symbol -> (Listof BasicBlock)))
-                  (define (do-on-label label-name)
-                    (loop label-name
-                          '()
-                          (cons (make-BasicBlock 
-                                 name  
-                                 (if last-stmt-goto? 
-                                     (reverse acc)
-                                     (reverse (append `(,(make-GotoStatement (make-Label label-name)))
-                                                      acc))))
-                                basic-blocks)
-                          (cdr stmts)
-                          last-stmt-goto?))
 
-                  (let: ([first-stmt : Statement (car stmts)])
-                    (cond
-                     [(symbol? first-stmt)
-                      (do-on-label first-stmt)]
-                     [(LinkedLabel? first-stmt)
-                      (do-on-label (LinkedLabel-label first-stmt))]
-                     [else
-                      (loop name
-                            (cons first-stmt acc)
-                            basic-blocks
-                            (cdr stmts)
-                            (GotoStatement? (car stmts)))]))]))))
+
+
+
+
+;; ;; fracture: (listof stmt) -> (listof basic-block)
+;; (: fracture ((Listof Statement) -> (Listof BasicBlock)))
+;; (define (fracture stmts)
+;;   (let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
+;;                                                (symbol? (first stmts)))
+;;                                           (first stmts)
+;;                                           (make-label 'start))]
+;;           [stmts : (Listof Statement) (if (and (not (empty? stmts))
+;;                                                (symbol? (first stmts)))
+;;                                           (rest stmts)
+;;                                           stmts)]
+;;           [jump-targets : (Listof Symbol)
+;;                         (cons first-block-label (collect-general-jump-targets stmts))])
+;;          (let: loop : (Listof BasicBlock)
+;;                ([name : Symbol first-block-label]
+;;                 [acc : (Listof UnlabeledStatement) '()]
+;;                 [basic-blocks  : (Listof BasicBlock) '()]
+;;                 [stmts : (Listof Statement) stmts])
+;;                (cond
+;;                  [(null? stmts)
+;;                   (reverse (cons (make-BasicBlock name (reverse acc) #f)
+;;                                  basic-blocks))]
+;;                  [else
+
+;;                   (: do-on-label (Symbol -> (Listof BasicBlock)))
+;;                   (define (do-on-label label-name)
+;;                     (loop label-name
+;;                           '()
+;;                           (cons (make-BasicBlock 
+;;                                  name  
+;;                                  (reverse acc)
+;;                                  (make-DirectJump label-name))
+;;                                 basic-blocks)
+;;                           (cdr stmts))
+;;                     )
+
+;;                   (let: ([first-stmt : Statement (car stmts)])
+;;                     (cond
+;;                      [(symbol? first-stmt)
+;;                       (do-on-label first-stmt)]
+
+;;                      [(LinkedLabel? first-stmt)
+;;                       (do-on-label (LinkedLabel-label first-stmt))]
+
+;;                      [(GotoStatement? first-stmt)
+;;                       (let ([target (GotoStatement-target first-stmt)])
+;;                         (cond
+;;                          [(Label? target)
+;;                           (loop ...?
+;;                                 '()
+;;                                 (cons (make-BasicBlock 
+;;                                        name  
+;;                                        (reverse acc)
+;;                                        (make-DirectJump label-name))
+;;                                       basic-blocks)
+;;                                 (cdr stmts))]
+;;                          [else
+;;                           (loop ...?
+;;                                 '()
+;;                                 (cons (make-BasicBlock 
+;;                                        name  
+;;                                        (reverse acc)
+;;                                        (make-ComputedJump target))
+;;                                       basic-blocks)
+;;                                 (cdr stmts))]))]
+
+;;                      [(TestAndJumpStatement? first-stmt)
+;;                       ...]
+
+;;                      [else
+;;                       (loop name
+;;                             (cons first-stmt acc)
+;;                             basic-blocks
+;;                             (cdr stmts))]))]))))
+