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

reducing the amount of consing to append instruction sequences together

Browse Source
This commit is contained in:
Danny Yoo 2011-09-03 18:44:30 -04:00
parent 3ece0e20cd
commit e5d69fbfc1
6 changed files with 68 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
compiler/bootstrapped-primitives.rkt
View File

@ -39,30 +39,29 @@
(define (make-call/cc-code)
(statements
(append-instruction-sequences
(make-instruction-sequence
`(,call/cc-label
;; Precondition: the environment holds the f function that we want to jump into.
;; First, move f to the proc register
,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
;; Next, capture the envrionment and the current continuation closure,.
,(make-PushEnvironment 2 #f)
,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f)
(make-CaptureControl 0 default-continuation-prompt-tag))
,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
;; When capturing, skip over f and the two slots we just added.
(make-CaptureEnvironment 3 default-continuation-prompt-tag))
,(make-AssignPrimOpStatement (make-EnvLexicalReference 2 #f)
(make-MakeCompiledProcedure call/cc-closure-entry
1 ;; the continuation consumes a single value
(list 0 1)
'call/cc))
,(make-PopEnvironment (make-Const 2)
(make-Const 0))))
call/cc-label
;; Precondition: the environment holds the f function that we want to jump into.
;; First, move f to the proc register
(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f))
;; Next, capture the envrionment and the current continuation closure,.
(make-PushEnvironment 2 #f)
(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f)
(make-CaptureControl 0 default-continuation-prompt-tag))
(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f)
;; When capturing, skip over f and the two slots we just added.
(make-CaptureEnvironment 3 default-continuation-prompt-tag))
(make-AssignPrimOpStatement (make-EnvLexicalReference 2 #f)
(make-MakeCompiledProcedure call/cc-closure-entry
1 ;; the continuation consumes a single value
(list 0 1)
'call/cc))
(make-PopEnvironment (make-Const 2)
(make-Const 0))
;; Finally, do a tail call into f.
(make-instruction-sequence `(,(make-AssignImmediateStatement 'argcount (make-Const 1))))
(make-AssignImmediateStatement 'argcount (make-Const 1))
(compile-general-procedure-call '()
(make-Const 1) ;; the stack at this point holds a single argument
'val
@ -70,15 +69,14 @@
;; The code for the continuation code follows. It's supposed to
;; abandon the current continuation, initialize the control and environment, and then jump.
(make-instruction-sequence `(,call/cc-closure-entry
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
,(make-PerformStatement (make-InstallClosureValues!))
,(make-PerformStatement
(make-RestoreControl! default-continuation-prompt-tag))
,(make-PerformStatement (make-RestoreEnvironment!))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc)))))))
call/cc-closure-entry
(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
(make-PerformStatement (make-InstallClosureValues!))
(make-PerformStatement (make-RestoreControl! default-continuation-prompt-tag))
(make-PerformStatement (make-RestoreEnvironment!))
(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
(make-PopControlFrame)
(make-GotoStatement (make-Reg 'proc)))))

20
compiler/compiler.rkt
View File

@ -21,8 +21,8 @@
[ensure-const-value (Any -> const-value)])
(provide (rename-out [-compile compile])
compile-general-procedure-call
append-instruction-sequences)
compile-general-procedure-call)
@ -2067,22 +2067,6 @@
(: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
(define (append-instruction-sequences . seqs)
(append-seq-list seqs))
(: append-2-sequences (InstructionSequence InstructionSequence -> InstructionSequence))
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence
(append (statements seq1) (statements seq2))))
(: append-seq-list ((Listof InstructionSequence) -> InstructionSequence))
(define (append-seq-list seqs)
(if (null? seqs)
empty-instruction-sequence
(append-2-sequences (car seqs)
(append-seq-list (cdr seqs)))))
(: ensure-natural (Integer -> Natural))
(define (ensure-natural n)

33
compiler/il-structs.rkt
View File

@ -481,10 +481,16 @@
(define-type InstructionSequence (U Symbol LinkedLabel Statement instruction-sequence))
(define-struct: instruction-sequence ([statements : (Listof Statement)])
(define-type InstructionSequence (U Symbol
LinkedLabel
Statement
instruction-sequence-list
instruction-sequence-chunks))
(define-struct: instruction-sequence-list ([statements : (Listof Statement)])
#:transparent)
(define empty-instruction-sequence (make-instruction-sequence '()))
(define-struct: instruction-sequence-chunks ([chunks : (Listof InstructionSequence)])
#:transparent)
(define empty-instruction-sequence (make-instruction-sequence-list '()))
(define-predicate Statement? Statement)
@ -498,11 +504,28 @@
(list s)]
[(Statement? s)
(list s)]
[else
(instruction-sequence-statements s)]))
[(instruction-sequence-list? s)
(instruction-sequence-list-statements s)]
[(instruction-sequence-chunks? s)
(apply append (map statements (instruction-sequence-chunks-chunks s)))]))
(: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
(define (append-instruction-sequences . seqs)
(append-seq-list seqs))
(: append-2-sequences (InstructionSequence InstructionSequence -> InstructionSequence))
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence-chunks (list seq1 seq2)))
(: append-seq-list ((Listof InstructionSequence) -> InstructionSequence))
(define (append-seq-list seqs)
(if (null? seqs)
empty-instruction-sequence
(make-instruction-sequence-chunks seqs)))

5
get-module-bytecode.rkt
View File

@ -60,7 +60,7 @@
(lookup-language-namespace
#;'racket/base
`(file ,(path->string kernel-language-path)))
#;(make-base-namespace))
#;(make-base-namespace))
@ -74,7 +74,8 @@
(log-debug "parsing from scratch")
(call-with-input-file* p
(lambda (ip)
(get-compiled-code-from-port ip))))])
(get-compiled-code-from-port ip)))
)])
(get-module-code p)))

3
make/make.rkt
View File

@ -168,8 +168,7 @@
[(hash-has-key? visited (first sources))
(loop (rest sources))]
[else
(log-debug (format "compiling a module ~a"
(source-name (first sources))))
(printf "compiling a module ~a\n" (source-name (first sources)))
(hash-set! visited (first sources) #t)
(let*-values ([(this-source)
((current-module-source-compiling-hook)

7
parser/parse-bytecode-5.1.2.rkt
View File

@ -144,8 +144,11 @@
base]
[else
(error 'parse-bytecode)])])
(parse-bytecode
(open-input-bytes (get-module-bytecode normal-path)))))]
(define start-time (current-inexact-milliseconds))
(define module-bytecode (get-module-bytecode normal-path))
(define stop-time (current-inexact-milliseconds))
(printf " parse-bytecode get-module-bytecode: ~a milliseconds\n" (- stop-time start-time))
(parse-bytecode (open-input-bytes module-bytecode))))]
[else
(error 'parse-bytecode "Don't know how to parse from ~e" in)]))