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) [(InstallModuleEntry!? op)
(list (InstallModuleEntry!-entry-point op))] (list (InstallModuleEntry!-entry-point op))]
[else [else
empty] 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])))
(: start-time Real)
(unique/eq? (define start-time (current-inexact-milliseconds))
(let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
(cond [(empty? stmts) (: result (Listof Symbol))
empty] (define result
[else (unique/eq?
(let: ([stmt : Statement (first stmts)]) (let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
(append (collect-statement stmt) (cond [(empty? stmts)
(loop (rest 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 stmt) -> (listof basic-block)
(: fracture ((Listof Statement) -> (values (Listof BasicBlock) (: fracture ((Listof Statement) -> (values (Listof BasicBlock)
(Listof Symbol)))) (Listof Symbol))))
(define (fracture stmts) (define (fracture stmts)
(let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
(symbol? (first stmts))) (define start-time (current-inexact-milliseconds))
(first stmts)
(make-label 'start))] (define-values (blocks entries)
[stmts : (Listof Statement) (if (and (not (empty? stmts)) (let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
(symbol? (first stmts))) (symbol? (first stmts)))
(rest stmts) (first stmts)
stmts)] (make-label 'start))]
[jump-targets : (Listof Symbol) [stmts : (Listof Statement) (if (and (not (empty? stmts))
(cons first-block-label (collect-general-jump-targets stmts))] (symbol? (first stmts)))
[entry-points : (Listof Symbol) (rest stmts)
(cons first-block-label (collect-entry-points stmts))]) stmts)]
(let: loop : (values (Listof BasicBlock) (Listof Symbol)) [jump-targets : (Listof Symbol)
([name : Symbol first-block-label] (cons first-block-label (collect-general-jump-targets stmts))]
[acc : (Listof UnlabeledStatement) '()] [entry-points : (Listof Symbol)
[basic-blocks : (Listof BasicBlock) '()] (cons first-block-label (collect-entry-points stmts))])
[stmts : (Listof Statement) stmts]
[last-stmt-goto? : Boolean #f]) (define jump-targets-ht ((inst make-hasheq Symbol Boolean)))
(cond (for ([name jump-targets])
[(null? stmts) (hash-set! jump-targets-ht name #t))
(values (reverse (cons (make-BasicBlock name (reverse acc))
basic-blocks)) (set! start-time (current-inexact-milliseconds))
entry-points)] (let: loop : (values (Listof BasicBlock) (Listof Symbol))
[else ([name : Symbol first-block-label]
(let: ([first-stmt : Statement (car stmts)]) [acc : (Listof UnlabeledStatement) '()]
(: do-on-label (Symbol -> (values (Listof BasicBlock) (Listof Symbol)))) [basic-blocks : (Listof BasicBlock) '()]
(define (do-on-label label-name) [stmts : (Listof Statement) stmts]
(cond [last-stmt-goto? : Boolean #f])
[(member label-name jump-targets) (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 (loop label-name
'() '()
(cons (make-BasicBlock (cons (make-BasicBlock
name name
(if last-stmt-goto? (if last-stmt-goto?
(reverse acc) (reverse acc)
(reverse (append `(,(make-GotoStatement (make-Label label-name))) (reverse (cons (make-GotoStatement (make-Label label-name))
acc)))) acc))))
basic-blocks) basic-blocks)
(cdr stmts) (cdr stmts)
last-stmt-goto?)] last-stmt-goto?)]
@ -72,7 +83,7 @@
basic-blocks basic-blocks
(cdr stmts) (cdr stmts)
last-stmt-goto?)])) last-stmt-goto?)]))
(cond (cond
[(symbol? first-stmt) [(symbol? first-stmt)
(do-on-label first-stmt)] (do-on-label first-stmt)]
[(LinkedLabel? first-stmt) [(LinkedLabel? first-stmt)
@ -83,3 +94,8 @@
basic-blocks basic-blocks
(cdr stmts) (cdr stmts)
(GotoStatement? (car 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() { ")]) (fprintf temporary-output-port "(MACHINE, function() { ")])
(define stop-time (current-inexact-milliseconds)) (define stop-time (current-inexact-milliseconds))
(printf " assembly: ~s milliseconds\n" (- stop-time start-time)) (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) (write-bytes (get-output-bytes temporary-output-port) op)
(void)) (void))

2
make/make.rkt
View File

@ -66,7 +66,7 @@
(define start-time (current-inexact-milliseconds)) (define start-time (current-inexact-milliseconds))
(define compiled-code (compile ast 'val next-linkage/drop-multiple)) (define compiled-code (compile ast 'val next-linkage/drop-multiple))
(define stop-time (current-inexact-milliseconds)) (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))])) (values ast compiled-code))]))