From e5d69fbfc17cfad3c29b895dee9b443a1fe74166 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sat, 3 Sep 2011 18:44:30 -0400 Subject: [PATCH] reducing the amount of consing to append instruction sequences together --- compiler/bootstrapped-primitives.rkt | 60 ++++++++++++++-------------- compiler/compiler.rkt | 20 +--------- compiler/il-structs.rkt | 33 ++++++++++++--- get-module-bytecode.rkt | 5 ++- make/make.rkt | 3 +- parser/parse-bytecode-5.1.2.rkt | 7 +++- 6 files changed, 68 insertions(+), 60 deletions(-) diff --git a/compiler/bootstrapped-primitives.rkt b/compiler/bootstrapped-primitives.rkt index ad81ed7..0382094 100644 --- a/compiler/bootstrapped-primitives.rkt +++ b/compiler/bootstrapped-primitives.rkt @@ -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))))) diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index 72871b4..c070eae 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -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) diff --git a/compiler/il-structs.rkt b/compiler/il-structs.rkt index 853a964..3265be2 100644 --- a/compiler/il-structs.rkt +++ b/compiler/il-structs.rkt @@ -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))) + + diff --git a/get-module-bytecode.rkt b/get-module-bytecode.rkt index bc0aacc..14f42c9 100644 --- a/get-module-bytecode.rkt +++ b/get-module-bytecode.rkt @@ -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))) diff --git a/make/make.rkt b/make/make.rkt index 49f8e15..7334296 100644 --- a/make/make.rkt +++ b/make/make.rkt @@ -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) diff --git a/parser/parse-bytecode-5.1.2.rkt b/parser/parse-bytecode-5.1.2.rkt index 36addd3..ede29d0 100644 --- a/parser/parse-bytecode-5.1.2.rkt +++ b/parser/parse-bytecode-5.1.2.rkt @@ -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)]))