trivial optimziation
This commit is contained in:
Danny Yoo
parent
df1ef5b693
commit
dc14753a73
|
|
@ -16,8 +16,7 @@
|
|||
(define (optimize-il statements)
|
||||
;; For now, replace pairs of PushEnvironment / AssignImmediate(0, ...)
|
||||
;; We should do some more optimizations here, like peephole...
|
||||
(let* ([statements (filter not-no-op? statements)]
|
||||
[statements (flatten-labels statements)])
|
||||
(let* ([statements (filter not-no-op? statements)])
|
||||
(let loop ([statements statements])
|
||||
(cond
|
||||
[(empty? statements)
|
||||
|
|
@ -111,46 +110,6 @@
|
|||
|
||||
|
||||
|
||||
;; detect adjacent labels, and flatten them into a single jump target.
|
||||
(: flatten-labels ((Listof Statement) -> (Listof Statement)))
|
||||
(define (flatten-labels stmts)
|
||||
(cond
|
||||
[(empty? stmts)
|
||||
stmts]
|
||||
[else
|
||||
(let ([forest (ufind:new-forest)])
|
||||
|
||||
;; First scan identifies the adjacent labels
|
||||
(let: loop : Void ([last-labeled-stmt : (U False Symbol) #f]
|
||||
[stmts : (Listof Statement) stmts])
|
||||
(cond
|
||||
[(empty? stmts)
|
||||
(void)]
|
||||
[else
|
||||
(let ([next-stmt (first stmts)])
|
||||
(cond [(symbol? next-stmt)
|
||||
(ufind:make-set forest next-stmt)
|
||||
(when (and (symbol? last-labeled-stmt)
|
||||
(eq? last-labeled-stmt next-stmt))
|
||||
(ufind:union-set forest last-labeled-stmt next-stmt))
|
||||
(loop next-stmt
|
||||
(rest stmts))]
|
||||
[else
|
||||
(loop #f (rest stmts))]))]))
|
||||
|
||||
|
||||
;; We then run through all the statements and replace with
|
||||
;; canonical ones.
|
||||
(let: loop : (Listof Statement) ([stmts : (Listof Statement) stmts])
|
||||
(cond
|
||||
[(empty? stmts)
|
||||
empty]
|
||||
[else
|
||||
(let ([next-stmt (first stmts)])
|
||||
(cons next-stmt
|
||||
(loop (rest stmts))))])))]))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -9,12 +9,12 @@
|
|||
"../compiler/lexical-structs.rkt"
|
||||
"../compiler/expression-structs.rkt"
|
||||
"../helpers.rkt"
|
||||
"optimize-basic-blocks.rkt"
|
||||
"fracture.rkt"
|
||||
racket/string
|
||||
racket/list)
|
||||
|
||||
(provide assemble/write-invoke
|
||||
fracture
|
||||
assemble-basic-block
|
||||
assemble-statement)
|
||||
|
||||
|
||||
|
|
@ -32,7 +32,8 @@
|
|||
(fprintf op "(function(MACHINE, success, fail, params) {\n")
|
||||
(fprintf op "var param;\n")
|
||||
(fprintf op "var RUNTIME = plt.runtime;\n")
|
||||
(let: ([basic-blocks : (Listof BasicBlock) (fracture stmts)])
|
||||
(let: ([basic-blocks : (Listof BasicBlock)
|
||||
(optimize-basic-blocks (fracture stmts))])
|
||||
(for-each
|
||||
(lambda: ([basic-block : BasicBlock])
|
||||
(displayln (assemble-basic-block basic-block) op)
|
||||
|
|
@ -56,63 +57,6 @@ EOF
|
|||
|
||||
|
||||
|
||||
;; fracture: (listof stmt) -> (listof basic-block)
|
||||
(: fracture ((Listof Statement) -> (Listof BasicBlock)))
|
||||
(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))])
|
||||
(let: loop : (Listof BasicBlock)
|
||||
([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
|
||||
(let: ([first-stmt : Statement (car stmts)])
|
||||
(: do-on-label (Symbol -> (Listof BasicBlock)))
|
||||
(define (do-on-label label-name)
|
||||
(cond
|
||||
[(member label-name jump-targets)
|
||||
(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?)]
|
||||
[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)
|
||||
(GotoStatement? (car stmts)))]))]))))
|
||||
|
||||
|
||||
(: write-linked-label-attributes ((Listof Statement) Output-Port -> 'ok))
|
||||
|
|
@ -165,10 +109,16 @@ EOF
|
|||
|
||||
|
||||
|
||||
|
||||
;; assemble-basic-block: basic-block -> string
|
||||
(: assemble-basic-block (BasicBlock -> String))
|
||||
(define (assemble-basic-block a-basic-block)
|
||||
(format "var ~a=function(MACHINE){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};"
|
||||
(format "var ~a = function(MACHINE){
|
||||
if(--MACHINE.callsBeforeTrampoline < 0) {
|
||||
throw ~a;
|
||||
}
|
||||
~a
|
||||
};"
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)))
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)))
|
||||
(string-join (map assemble-statement (BasicBlock-stmts a-basic-block))
|
||||
|
|
|
|||
78
js-assembler/fracture.rkt
Normal file
78
js-assembler/fracture.rkt
Normal file
|
|
@ -0,0 +1,78 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require "assemble-structs.rkt"
|
||||
"assemble-helpers.rkt"
|
||||
"assemble-open-coded.rkt"
|
||||
"assemble-expression.rkt"
|
||||
"assemble-perform-statement.rkt"
|
||||
"collect-jump-targets.rkt"
|
||||
"../compiler/il-structs.rkt"
|
||||
"../compiler/lexical-structs.rkt"
|
||||
"../compiler/expression-structs.rkt"
|
||||
"../helpers.rkt"
|
||||
racket/string
|
||||
racket/list)
|
||||
|
||||
|
||||
(provide fracture)
|
||||
|
||||
|
||||
|
||||
|
||||
;; fracture: (listof stmt) -> (listof basic-block)
|
||||
(: fracture ((Listof Statement) -> (Listof BasicBlock)))
|
||||
(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))])
|
||||
(let: loop : (Listof BasicBlock)
|
||||
([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
|
||||
(let: ([first-stmt : Statement (car stmts)])
|
||||
(: do-on-label (Symbol -> (Listof BasicBlock)))
|
||||
(define (do-on-label label-name)
|
||||
(cond
|
||||
[(member label-name jump-targets)
|
||||
(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?)]
|
||||
[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)
|
||||
(GotoStatement? (car stmts)))]))]))))
|
||||
53
js-assembler/optimize-basic-blocks.rkt
Normal file
53
js-assembler/optimize-basic-blocks.rkt
Normal file
|
|
@ -0,0 +1,53 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require "assemble-structs.rkt"
|
||||
"../compiler/il-structs.rkt"
|
||||
racket/list)
|
||||
|
||||
(require/typed "../logger.rkt" [log-debug (String -> Void)])
|
||||
|
||||
|
||||
(provide optimize-basic-blocks)
|
||||
|
||||
|
||||
(define-type Blockht (HashTable Symbol BasicBlock))
|
||||
|
||||
|
||||
(: optimize-basic-blocks ((Listof BasicBlock) -> (Listof BasicBlock)))
|
||||
(define (optimize-basic-blocks blocks)
|
||||
(let: ([blockht : Blockht (make-hasheq)])
|
||||
(for-each (lambda: ([b : BasicBlock])
|
||||
(hash-set! blockht (BasicBlock-name b) b))
|
||||
blocks)
|
||||
|
||||
(map (lambda: ([b : BasicBlock])
|
||||
(optimize-block b blockht))
|
||||
blocks)))
|
||||
|
||||
|
||||
|
||||
|
||||
(: optimize-block (BasicBlock Blockht -> BasicBlock))
|
||||
;; Simple optimization: optimize away single-statement goto blocks with their
|
||||
;; immediate contents.
|
||||
(define (optimize-block b blocks)
|
||||
(let ([stmts (BasicBlock-stmts b)])
|
||||
(cond
|
||||
[(= (length stmts) 1)
|
||||
(let ([first-stmt (first stmts)])
|
||||
(cond
|
||||
[(GotoStatement? first-stmt)
|
||||
(let ([target (GotoStatement-target first-stmt)])
|
||||
(cond
|
||||
[(Label? target)
|
||||
(log-debug (format "inlining basic block ~a" (BasicBlock-name b)))
|
||||
(optimize-block (make-BasicBlock (BasicBlock-name b)
|
||||
(BasicBlock-stmts
|
||||
(hash-ref blocks (Label-name target))))
|
||||
blocks)]
|
||||
[else
|
||||
b]))]
|
||||
[else
|
||||
b]))]
|
||||
[else
|
||||
b])))
|
||||
Loading…
Reference in New Issue
Block a user