Ported fracture to #lang whalesong

whalesong/selfhost/js-assembler/fracture.rkt

@@ -0,0 +1,111 @@
+#lang whalesong (require "../selfhost-lang.rkt" whalesong/lang/for) 
+; #lang typed/racket/base
+
+(require "assemble-structs.rkt"
+         "collect-jump-targets.rkt"
+         "../compiler/il-structs.rkt"
+         "../compiler/expression-structs.rkt"
+         "../parameters.rkt"
+         racket/list)
+
+
+;; Breaks up a sequence of statements into a list of basic blocks.
+;;
+;; The first basic block is special, and represents the start of execution.
+;;
+;; A basic block consists of a sequence of straight line statements, followed by one of
+;; the following:
+;;
+;;     * A conditional jump.
+;;     * An unconditional jump.
+;;     * Termination.
+
+(provide fracture)
+
+
+
+
+;; fracture: (listof stmt) -> (listof basic-block)
+(: fracture ((Listof Statement) -> (values (Listof BasicBlock)
+                                           (Listof Symbol))))
+(define (fracture stmts)
+  
+  (define start-time (current-inexact-milliseconds))
+  
+  (define-values (blocks entries)
+    (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))]
+           [entry-points ; : (Listof Symbol)
+            (cons first-block-label (collect-entry-points stmts))])
+      
+      (define jump-targets-ht ((inst make-hasheq Symbol Boolean)))
+      (for ([name jump-targets])
+        (hash-set! jump-targets-ht name #t))
+      
+      (set! start-time (current-inexact-milliseconds))
+      (let loop ; : (values (Listof BasicBlock) (Listof Symbol))
+        ([name ; : Symbol 
+               first-block-label]
+         [acc ; : (Listof UnlabeledStatement)
+              '()]
+         [basic-blocks  ; : (Listof BasicBlock)
+                        '()]
+         [stmts ; : (Listof Statement)
+                stmts]
+         [last-stmt-goto? ; : Boolean 
+                          #f])
+        (cond
+          [(null? stmts)
+           (values (reverse (cons (make-BasicBlock name (reverse acc))
+                                  basic-blocks))
+                   entry-points)]
+          [else
+           (let ([first-stmt ; : Statement
+                             (car stmts)])
+             (: do-on-label (Symbol -> (values (Listof BasicBlock) (Listof Symbol))))
+             (define (do-on-label label-name)
+               (cond
+                 [(hash-has-key? jump-targets-ht label-name)
+                  (loop label-name
+                        '()
+                        (cons (make-BasicBlock 
+                               name  
+                               (if last-stmt-goto? 
+                                   (reverse acc)
+                                   (reverse (cons (make-Goto (make-Label label-name))
+                                                  acc))))
+                              basic-blocks)
+                        (cdr stmts)
+                        last-stmt-goto?)]
+                 [else
+                  (loop name
+                        acc
+                        basic-blocks
+                        (cdr stmts)
+                        last-stmt-goto?)]))
+             (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)
+                      (Goto? (car stmts)))]))]))))
+  
+  (define end-time (current-inexact-milliseconds))
+  (fprintf (current-timing-port) "  assemble fracture: ~a milliseconds\n" (- end-time start-time))
+  
+  (values blocks entries))