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

getting into bad compilation times again. Trying to isolate

Browse Source
This commit is contained in:
Danny Yoo 2011-05-11 14:22:47 -04:00
parent 3363c15082
commit 8fe3fbc9a4
10 changed files with 118 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
NOTES
View File

@ -462,4 +462,9 @@ such a context.
Ok, I think I've been able to do this successfully. I lifted out the
code for emit-values-context-check-on-procedure-return so it's used
for both the returns from procedure call, as well as the calls from
the prompt splicing.
the prompt splicing.
----------------------------------------------------------------------

7
assemble-perform-statement.rkt
View File

@ -123,4 +123,9 @@
[(RaiseOperatorApplicationError!? op)
(format "RUNTIME.raiseOperatorApplicationError(MACHINE, ~a);"
(assemble-oparg (RaiseOperatorApplicationError!-operator op)))]))
(assemble-oparg (RaiseOperatorApplicationError!-operator op)))]
[(InstallModuleEntry!? op)
(format "MACHINE.modules[~s]=new RUNTIME.ModuleRecord(~s, ~a);"
(symbol->string (ModuleName-name (InstallModuleEntry!-name op)))
(assemble-label (make-Label (InstallModuleEntry!-entry-point op))))]))

4
collect-jump-targets.rkt
View File

@ -154,7 +154,9 @@
[(RaiseArityMismatchError!? op)
empty]
[(RaiseOperatorApplicationError!? op)
empty]))
empty]
[(InstallModuleEntry!? op)
(list (InstallModuleEntry!-entry-point op))]))

42
compiler.rkt
View File

@ -65,6 +65,8 @@
(cond
[(Top? exp)
(loop (Top-code exp) (cons (Top-prefix exp) cenv))]
[(Module? exp)
(loop (Module-code exp) (cons (Module-prefix exp) cenv))]
[(Constant? exp)
'()]
[(LocalRef? exp)
@ -168,6 +170,8 @@
(cond
[(Top? exp)
(compile-top exp cenv target linkage)]
[(Module? exp)
(compile-module exp cenv target linkage)]
[(Constant? exp)
(compile-constant exp cenv target linkage)]
[(LocalRef? exp)
@ -244,6 +248,33 @@
(: compile-module (Module CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Generates code to write out the top prefix, evaluate the rest of the body,
;; and then pop the top prefix off.
(define (compile-module top cenv target linkage)
;; fixme: this is not right yet. This should instead install a module record
;; that has not yet been invoked.
;; fixme: This also needs to generate code for the requires and provides.
(let*: ([names : (Listof (U False Symbol GlobalBucket ModuleVariable))
(Prefix-names (Module-prefix top))])
(end-with-linkage
linkage cenv
(append-instruction-sequences
(make-instruction-sequence
`(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
(compile (Module-code top)
(cons (Module-prefix top) cenv)
target
next-linkage/drop-multiple)
(make-instruction-sequence
`(,(make-PopEnvironment (make-Const 1)
(make-Const 0))))))))
(: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence -> InstructionSequence))
;; Add linkage for expressions.
(define (end-with-linkage linkage cenv instruction-sequence)
@ -815,7 +846,9 @@
(default)]
[(ModuleVariable? op-knowledge)
(cond
[(symbol=? (ModuleVariable-module-path op-knowledge) '#%kernel)
[(symbol=? (ModuleName-name
(ModuleVariable-module-name op-knowledge))
'#%kernel)
(let ([op (ModuleVariable-name op-knowledge)])
(cond [(KernelPrimitiveName? op)
(compile-kernel-primitive-application
@ -1952,6 +1985,13 @@
(make-Top (Top-prefix exp)
(adjust-expression-depth (Top-code exp) n (add1 skip)))]
[(Module? exp)
(make-Module (Module-name exp)
(Module-prefix exp)
(Module-requires exp)
(Module-provides exp)
(adjust-expression-depth (Module-code exp) n (add1 skip)))]
[(Constant? exp)
exp]

13
il-structs.rkt
View File

@ -196,6 +196,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Primitive Operators
@ -369,6 +370,13 @@
;; Adds a continuation mark into the current top control frame.
(define-struct: InstallContinuationMarkEntry! () #:transparent)
;; Installs a module record into the machine
(define-struct: InstallModuleEntry! ([name : ModuleName]
[entry-point : Symbol])
#:transparent)
(define-type PrimitiveCommand (U
CheckToplevelBound!
CheckClosureArity!
@ -389,7 +397,10 @@
RaiseOperatorApplicationError!
RestoreEnvironment!
RestoreControl!))
RestoreControl!
InstallModuleEntry!
))

2
parse.rkt
View File

@ -52,7 +52,7 @@
[(current-language)
=> (lambda (lang)
(if (member sym lang)
(make-ModuleVariable sym '#%kernel)
(make-ModuleVariable sym (make-ModuleName '#%kernel))
#f))]
[else
#f]))

10
runtime.js
View File

@ -64,6 +64,7 @@
this.env = [];
this.control = []; // Arrayof (U Frame CallFrame PromptFrame)
this.running = false;
this.modules = {}; // String -> ModuleRecord
this.params = { 'currentDisplayer': function(v) {},
'currentOutputPort': new StandardOutputPort(),
@ -92,6 +93,12 @@
var ModuleRecord = function(name, label) {
this.name = name;
this.label = label;
this.isInvoked = false;
this.exports = {};
};
@ -1128,6 +1135,7 @@
exports['CallFrame'] = CallFrame;
exports['PromptFrame'] = PromptFrame;
exports['Closure'] = Closure;
exports['ModuleRecord'] = ModuleRecord;
exports['ContinuationPromptTag'] = ContinuationPromptTag;
exports['DEFAULT_CONTINUATION_PROMPT_TAG'] =
DEFAULT_CONTINUATION_PROMPT_TAG;
@ -1162,4 +1170,6 @@
exports['heir'] = heir;
exports['makeClassPredicate'] = makeClassPredicate;
}).call(this);

9
simulator-structs.rkt
View File

@ -48,6 +48,8 @@
[pc : Natural] ;; program counter
[text : (Vectorof Statement)] ;; text of the program
[modules : (HashTable Symbol module-record)]
;; other metrics for debugging
[stack-size : Natural]
@ -58,6 +60,13 @@
#:mutable)
(define-struct: module-record ([name : ModuleName]
[label : Symbol]
[invoked? : Boolean]
[exports : (HashTable Symbol PrimitiveValue)])
#:transparent
#:mutable)
(define-type frame (U GenericFrame CallFrame PromptFrame))

33
simulator.rkt
View File

@ -57,6 +57,7 @@
'()
0
(list->vector program-text)
((inst make-hash Symbol module-record))
0
((inst make-hash Symbol Natural)))])
(let: loop : Void ([i : Natural 0])
@ -401,7 +402,17 @@
[(RaiseOperatorApplicationError!? op)
(error "expected procedure, given ~a"
(evaluate-oparg m (RaiseOperatorApplicationError!-operator op)))])))
(evaluate-oparg m (RaiseOperatorApplicationError!-operator op)))]
[(InstallModuleEntry!? op)
(hash-set! (machine-modules m)
(ModuleName-name (InstallModuleEntry!-name op))
(make-module-record (InstallModuleEntry!-name op)
(InstallModuleEntry!-entry-point op)
#f
(make-hash)))
'ok])))
@ -879,7 +890,7 @@
(define (current-instruction m)
(match m
[(struct machine (val proc argcount env control pc text
stack-size jump-table))
modules stack-size jump-table))
(vector-ref text pc)]))
@ -903,7 +914,7 @@
(: env-push! (machine SlotValue -> 'ok))
(define (env-push! m v)
(match m
[(struct machine (val proc argcount env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text modules stack-size jump-table))
(set-machine-env! m (cons v env))
(set-machine-stack-size! m (add1 stack-size))
'ok]))
@ -911,7 +922,7 @@
(: env-push-many! (machine (Listof SlotValue) -> 'ok))
(define (env-push-many! m vs)
(match m
[(struct machine (val proc argcount env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text modules stack-size jump-table))
(set-machine-env! m (append vs env))
(set-machine-stack-size! m (+ stack-size (length vs)))
'ok]))
@ -920,13 +931,13 @@
(: env-ref (machine Natural -> SlotValue))
(define (env-ref m i)
(match m
[(struct machine (val proc argcount env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text modules stack-size jump-table))
(list-ref env i)]))
(: env-mutate! (machine Natural SlotValue -> 'ok))
(define (env-mutate! m i v)
(match m
[(struct machine (val proc argcount env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text modules stack-size jump-table))
(set-machine-env! m (list-replace env i v))
'ok]))
@ -944,7 +955,7 @@
(: env-pop! (machine Natural Natural -> 'ok))
(define (env-pop! m n skip)
(match m
[(struct machine (val proc argcount env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text modules stack-size jump-table))
(set-machine-env! m (append (take env skip)
(drop env (+ skip n))))
(set-machine-stack-size! m (ensure-natural (- stack-size n)))
@ -954,7 +965,7 @@
(: control-push! (machine frame -> 'ok))
(define (control-push! m a-frame)
(match m
[(struct machine (val proc argcount env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text modules stack-size jump-table))
(set-machine-control! m (cons a-frame control))
'ok]))
@ -962,14 +973,14 @@
(: control-pop! (machine -> 'ok))
(define (control-pop! m)
(match m
[(struct machine (val proc argcount env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text modules stack-size jump-table))
(set-machine-control! m (rest control))
'ok]))
(: control-top (machine -> frame))
(define (control-top m)
(match m
[(struct machine (val proc argcount env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text modules stack-size jump-table))
(first control)]))
@ -985,7 +996,7 @@
;; Jumps directly to the instruction at the given label.
(define (jump! m l)
(match m
[(struct machine (val proc argcount env control pc text stack-size jump-table))
[(struct machine (val proc argcount env control pc text modules stack-size jump-table))
(set-machine-pc! m (hash-ref jump-table l))
'ok]))

16
test-parse.rkt
View File

@ -208,7 +208,7 @@
'lamEntry2)))
(test (parse '(+ x x))
(make-Top (make-Prefix `(,(make-ModuleVariable '+ '#%kernel)
(make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel))
x))
(make-App (make-ToplevelRef 2 0)
(list (make-ToplevelRef 2 1)
@ -216,7 +216,7 @@
(test (parse '(lambda (x) (+ x x)))
(make-Top (make-Prefix `(,(make-ModuleVariable '+ '#%kernel)))
(make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel))))
(make-Lam 'unknown 1 #f
(make-App (make-ToplevelRef 2 0)
(list (make-LocalRef 3 #f)
@ -226,8 +226,8 @@
(test (parse '(lambda (x)
(+ (* x x) x)))
(make-Top (make-Prefix `(,(make-ModuleVariable '* '#%kernel)
,(make-ModuleVariable '+ '#%kernel)))
(make-Top (make-Prefix `(,(make-ModuleVariable '* (make-ModuleName '#%kernel))
,(make-ModuleVariable '+ (make-ModuleName '#%kernel))))
(make-Lam 'unknown 1 #f
;; stack layout: [???, ???, prefix, x]
(make-App (make-ToplevelRef 2 1)
@ -286,7 +286,7 @@
(test (parse '(let* ([x 3]
[x (add1 x)])
(add1 x)))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
;; stack layout: [prefix]
@ -415,7 +415,7 @@
(test (parse '(let ([x 0])
(lambda ()
(set! x (add1 x)))))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
(make-Let1 (make-Constant 0)
(make-BoxEnv 0
(make-Lam 'unknown 0 #f
@ -434,7 +434,7 @@
[y 1])
(lambda ()
(set! x (add1 x)))))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
(make-LetVoid 2
(make-Seq (list
(make-InstallValue 1 0 (make-Constant 0) #t)
@ -462,7 +462,7 @@
(reset!)
(list a b)))
(make-Top
(make-Prefix `(a b ,(make-ModuleVariable 'list '#%kernel) reset!))
(make-Prefix `(a b ,(make-ModuleVariable 'list (make-ModuleName '#%kernel)) reset!))
(make-Splice
(list
(make-ToplevelSet 0 0 (make-Constant '(hello)))