suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

still working on this...

Browse Source
This commit is contained in:
Danny Yoo 2011-07-27 18:11:37 -04:00
parent c2024bcd7a
commit 18582cb23f
2 changed files with 90 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
js-assembler/assemble-structs.rkt
View File

@ -18,7 +18,7 @@
(define-struct: ComputedJump ([label : (U Reg (define-struct: ComputedJump ([label : (U Reg
ModuleEntry ModuleEntry
CompiledProcedureEntry)]) CompiledProcedureEntry)])
#:transparent) #:transparent)

129
js-assembler/fracture.rkt
View File

@ -17,16 +17,20 @@
;; blocks. ;; blocks.
;; ;;
;; A basic block consists of a name, a sequence of straight-line statements, ;; 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) (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)) (let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
(symbol? (first stmts))) (symbol? (first stmts)))
(first stmts) (first stmts)
@ -37,41 +41,86 @@
stmts)] stmts)]
[jump-targets : (Listof Symbol) [jump-targets : (Listof Symbol)
(cons first-block-label (collect-general-jump-targets stmts))]) (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))
basic-blocks))]
[else
(: 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) ;; ;; fracture: (listof stmt) -> (listof basic-block)
(do-on-label (LinkedLabel-label first-stmt))] ;; (: fracture ((Listof Statement) -> (Listof BasicBlock)))
[else ;; (define (fracture stmts)
(loop name ;; (let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
(cons first-stmt acc) ;; (symbol? (first stmts)))
basic-blocks ;; (first stmts)
(cdr stmts) ;; (make-label 'start))]
(GotoStatement? (car stmts)))]))])))) ;; [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))]))]))))