diff --git a/js-assembler/collect-jump-targets.rkt b/js-assembler/collect-jump-targets.rkt index 812bfc9..fa1ebbc 100644 --- a/js-assembler/collect-jump-targets.rkt +++ b/js-assembler/collect-jump-targets.rkt @@ -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) + diff --git a/js-assembler/fracture.rkt b/js-assembler/fracture.rkt index 9edd613..03b5e6d 100644 --- a/js-assembler/fracture.rkt +++ b/js-assembler/fracture.rkt @@ -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)) diff --git a/js-assembler/package.rkt b/js-assembler/package.rkt index b450515..cec07b9 100644 --- a/js-assembler/package.rkt +++ b/js-assembler/package.rkt @@ -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)) diff --git a/make/make.rkt b/make/make.rkt index 746a332..d668268 100644 --- a/make/make.rkt +++ b/make/make.rkt @@ -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))]))