still working on this...

js-assembler/assemble-structs.rkt

@@ -11,5 +11,25 @@
 ;; Assembly
 
 (define-struct: BasicBlock ([name : Symbol] 
-                            [stmts : (Listof UnlabeledStatement)]) 
+                            [stmts : (Listof StraightLineStatement)]
+                            [jump : Jump]) 
   #:transparent)
+
+
+
+
+(define-struct: ComputedJump ([label : (U Reg
+                                          ModuleEntry
+                                          CompiledProcedureEntry)])
+  #:transparent)
+(define-struct: DirectJump ([label : Symbol])
+  #:transparent)
+(define-struct: ConditionalJump ([op : PrimitiveTest]
+                                 [true-label : Symbol]
+                                 [false-label : Symbol])
+  #:transparent)
+
+(define-type Jump (U ComputedJump
+                     DirectJump
+                     ConditionalJump
+                     False))

js-assembler/fracture.rkt

@@ -13,15 +13,24 @@
          racket/string
          racket/list)
 
+;; Takes a sequence of statements, and breaks them down into basic
+;; blocks.
+;;
+;; A basic block consists of a name, a sequence of straight-line statements,
+;; followed by a Jump (conditional, direct, or end-of-program).
 
 (provide fracture)
 
 
 
 
-;; fracture: (listof stmt) -> (listof basic-block)
+;; Make sure:
-(: fracture ((Listof Statement) -> (Listof BasicBlock)))
+;;
-(define (fracture stmts)
+;; 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)
@@ -32,47 +41,86 @@
                                           stmts)]
           [jump-targets : (Listof Symbol)
                         (cons first-block-label (collect-general-jump-targets stmts))])
-         (let: loop : (Listof BasicBlock)
+    stmts))
-               ([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))
+;; ;; fracture: (listof stmt) -> (listof basic-block)
-                                 basic-blocks))]
+;; (: fracture ((Listof Statement) -> (Listof BasicBlock)))
-                 [else
+;; (define (fracture stmts)
-                  (let: ([first-stmt : Statement (car stmts)])
+;;   (let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
-                        (: do-on-label (Symbol -> (Listof BasicBlock)))
+;;                                                (symbol? (first stmts)))
-                        (define (do-on-label label-name)
+;;                                           (first stmts)
-                          (cond
+;;                                           (make-label 'start))]
-                            [(member label-name jump-targets)
+;;           [stmts : (Listof Statement) (if (and (not (empty? stmts))
-                             (loop label-name
+;;                                                (symbol? (first stmts)))
-                                   '()
+;;                                           (rest stmts)
-                                   (cons (make-BasicBlock 
+;;                                           stmts)]
-                                          name  
+;;           [jump-targets : (Listof Symbol)
-                                          (if last-stmt-goto? 
+;;                         (cons first-block-label (collect-general-jump-targets stmts))])
-                                              (reverse acc)
+;;          (let: loop : (Listof BasicBlock)
-                                              (reverse (append `(,(make-GotoStatement (make-Label label-name)))
+;;                ([name : Symbol first-block-label]
-                                                               acc))))
+;;                 [acc : (Listof UnlabeledStatement) '()]
-                                         basic-blocks)
+;;                 [basic-blocks  : (Listof BasicBlock) '()]
-                                   (cdr stmts)
+;;                 [stmts : (Listof Statement) stmts])
-                                   last-stmt-goto?)]
+;;                (cond
-                            [else
+;;                  [(null? stmts)
-                             (loop name
+;;                   (reverse (cons (make-BasicBlock name (reverse acc) #f)
-                                   acc
+;;                                  basic-blocks))]
-                                   basic-blocks
+;;                  [else
-                                   (cdr stmts)
+
-                                   last-stmt-goto?)]))
+;;                   (: do-on-label (Symbol -> (Listof BasicBlock)))
-                        (cond
+;;                   (define (do-on-label label-name)
-                          [(symbol? first-stmt)
+;;                     (loop label-name
-                           (do-on-label first-stmt)]
+;;                           '()
-                          [(LinkedLabel? first-stmt)
+;;                           (cons (make-BasicBlock 
-                           (do-on-label (LinkedLabel-label first-stmt))]
+;;                                  name  
-                          [else
+;;                                  (reverse acc)
-                           (loop name
+;;                                  (make-DirectJump label-name))
-                                 (cons first-stmt acc)
+;;                                 basic-blocks)
-                                 basic-blocks
+;;                           (cdr stmts))
-                                 (cdr stmts)
+;;                     )
-                                 (GotoStatement? (car 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))]))]))))
+