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

reducing cost of fracture by using hashtable

Browse Source
This commit is contained in:
Danny Yoo 2011-09-03 19:29:32 -04:00
parent 086f6c283f
commit 27e3a444b1
4 changed files with 69 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
js-assembler/collect-jump-targets.rkt
View File

@ -128,48 +128,27 @@
[(InstallModuleEntry!? op)
(list (InstallModuleEntry!-entry-point op))]
[else
empty]
;; currently written this way because I'm hitting some bad type-checking behavior.
#;([(CheckToplevelBound!? op)
empty]
[(CheckClosureArity!? op)
empty]
[(CheckPrimitiveArity!? op)
empty]
[(ExtendEnvironment/Prefix!? op)
empty]
[(InstallClosureValues!? op)
empty]
[(RestoreEnvironment!? op)
empty]
[(RestoreControl!? op)
empty]
[(SetFrameCallee!? op)
empty]
[(SpliceListIntoStack!? op)
empty]
[(UnspliceRestFromStack!? op)
empty]
[(FixClosureShellMap!? op)
empty]
[(InstallContinuationMarkEntry!? op)
empty]
[(RaiseContextExpectedValuesError!? op)
empty]
[(RaiseArityMismatchError!? op)
empty]
[(RaiseOperatorApplicationError!? op)
empty])))
empty]))
(unique/eq?
(let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
(cond [(empty? stmts)
empty]
[else
(let: ([stmt : Statement (first stmts)])
(append (collect-statement stmt)
(loop (rest stmts))))]))))
(: start-time Real)
(define start-time (current-inexact-milliseconds))
(: result (Listof Symbol))
(define result
(unique/eq?
(let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
(cond [(empty? stmts)
empty]
[else
(let: ([stmt : Statement (first stmts)])
(append (collect-statement stmt)
(loop (rest stmts))))]))))
(: end-time Real)
(define end-time (current-inexact-milliseconds))
(printf " collect-general-jump-targets: ~a milliseconds\n" (- end-time start-time))
result)

80
js-assembler/fracture.rkt
View File

@ -22,47 +22,58 @@
;; fracture: (listof stmt) -> (listof basic-block)
(: fracture ((Listof Statement) -> (values (Listof BasicBlock)
(Listof Symbol))))
(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))]
[entry-points : (Listof Symbol)
(cons first-block-label (collect-entry-points stmts))])
(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
[(member label-name jump-targets)
(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 (append `(,(make-GotoStatement (make-Label label-name)))
acc))))
(reverse (cons (make-GotoStatement (make-Label label-name))
acc))))
basic-blocks)
(cdr stmts)
last-stmt-goto?)]
@ -72,7 +83,7 @@
basic-blocks
(cdr stmts)
last-stmt-goto?)]))
(cond
(cond
[(symbol? first-stmt)
(do-on-label first-stmt)]
[(LinkedLabel? first-stmt)
@ -83,3 +94,8 @@
basic-blocks
(cdr stmts)
(GotoStatement? (car stmts)))]))]))))
(define end-time (current-inexact-milliseconds))
(printf " assemble fracture: ~a milliseconds\n" (- end-time start-time))
(values blocks entries))

1
js-assembler/package.rkt
View File

@ -253,7 +253,6 @@ MACHINE.modules[~s] =
(fprintf temporary-output-port "(MACHINE, function() { ")])
(define stop-time (current-inexact-milliseconds))
(printf " assembly: ~s milliseconds\n" (- stop-time start-time))
(displayln (bytes-length (get-output-bytes temporary-output-port)))
(write-bytes (get-output-bytes temporary-output-port) op)
(void))

2
make/make.rkt
View File

@ -66,7 +66,7 @@
(define start-time (current-inexact-milliseconds))
(define compiled-code (compile ast 'val next-linkage/drop-multiple))
(define stop-time (current-inexact-milliseconds))
(printf " compile ast: ~a milliseconds\n" (- stop-time start-time))
;(printf " compile ast: ~a milliseconds\n" (- stop-time start-time))
(values ast compiled-code))]))