From b5c138f2eb5ac8805630894a4a170b00100268ea Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 5 Aug 2011 17:16:32 -0400 Subject: [PATCH 01/30] using profiler to drive some optimizations --- js-assembler/runtime-src/baselib-format.js | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/js-assembler/runtime-src/baselib-format.js b/js-assembler/runtime-src/baselib-format.js index d358425..0412504 100644 --- a/js-assembler/runtime-src/baselib-format.js +++ b/js-assembler/runtime-src/baselib-format.js @@ -5,7 +5,9 @@ var exports = {}; baselib.format = exports; - + + var formatRegexp1 = new RegExp('~[sSaA]', 'g'); + var formatRegexp2 = new RegExp("~[sSaAnevE%~]", "g"); // format: string [X ...] string -> string // String formatting. If an exception occurs, throws @@ -13,7 +15,7 @@ var format = function(formatStr, args, functionName) { var throwFormatError = function() { functionName = functionName || 'format'; - var matches = formatStr.match(new RegExp('~[sSaA]', 'g')); + var matches = formatStr.match(formatRegexp1); var expectedNumberOfArgs = (matches === null ? 0 : matches.length); var errorStrBuffer = [functionName + ': format string requires ' + expectedNumberOfArgs + ' arguments, given ' + args.length + '; arguments were:', @@ -25,7 +27,7 @@ throw new Error(errorStrBuffer.join(' ')); } - var pattern = new RegExp("~[sSaAnevE%~]", "g"); + var buffer = args.slice(0); var onTemplate = function(s) { if (s === "~~") { @@ -62,7 +64,7 @@ ': string.replace matched invalid regexp'); } } - var result = formatStr.replace(pattern, onTemplate); + var result = formatStr.replace(formatRegexp2, onTemplate); if (buffer.length > 0) { throwFormatError(); } From 925b4c4ff058f2a1c87e203cfaac9741a0074690 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 5 Aug 2011 17:35:27 -0400 Subject: [PATCH 02/30] trying to reduce some runtime costs --- js-assembler/runtime-src/baselib-check.js | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/js-assembler/runtime-src/baselib-check.js b/js-assembler/runtime-src/baselib-check.js index 863f25a..15ba872 100644 --- a/js-assembler/runtime-src/baselib-check.js +++ b/js-assembler/runtime-src/baselib-check.js @@ -33,7 +33,7 @@ } testArgument( MACHINE, - parameterizedPredicateName.apply(null, args), + function() { parameterizedPredicateName.apply(null, args) }, function(x) { return parameterizedPredicate.apply(null, [x].concat(args)); }, @@ -101,6 +101,9 @@ if (predicate(val)) { return true; } else { + if (typeof(expectedTypeName) === 'function') { + expectedTypeName = expectedTypeName(); + } plt.baselib.exceptions.raiseArgumentTypeError(MACHINE, callerName, expectedTypeName, From 3eba4cda5493c1171dc0bb58da1f0888f28f69c8 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 5 Aug 2011 17:57:11 -0400 Subject: [PATCH 03/30] adding a little to the .xhtml packager so we can see how long evaluation takes --- js-assembler/package.rkt | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/js-assembler/package.rkt b/js-assembler/package.rkt index 63e82e5..49afab1 100644 --- a/js-assembler/package.rkt +++ b/js-assembler/package.rkt @@ -375,10 +375,15 @@ var invokeMainModule = function() { var MACHINE = plt.runtime.currentMachine; invoke(MACHINE, function() { + var startTime = new Date().valueOf(); plt.runtime.invokeMains( MACHINE, function() { - // On main module invokation success + // On main module invokation success: + var stopTime = new Date().valueOf(); + if (console && console.log) { + console.log('evaluation took ' + (stopTime - startTime) + ' milliseconds'); + } }, function(MACHINE, e) { // On main module invokation failure From d8d4db8401ce047395d4bbdf4ed9c9ca2d4dde35 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 7 Aug 2011 16:58:10 -0400 Subject: [PATCH 04/30] fixing test cases so things run under 5.1.2 --- tests/test-parse-bytecode.rkt | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/tests/test-parse-bytecode.rkt b/tests/test-parse-bytecode.rkt index 01498c0..f824e4e 100644 --- a/tests/test-parse-bytecode.rkt +++ b/tests/test-parse-bytecode.rkt @@ -69,13 +69,16 @@ -(check-equal? (run-my-parse #'(begin (define x 3) +(check-true (match (run-my-parse #'(begin (define x 3) x)) - (make-Top (make-Prefix (list (make-GlobalBucket 'x))) - (make-Splice (list (make-DefValues (list (make-ToplevelRef 0 0 #f #t)) - (make-Constant 3)) - (make-ToplevelRef 0 0 #f #t))))) - + [(struct Top ((struct Prefix (_)) + (struct Splice ((list (struct DefValues ((list (struct ToplevelRef ('0 '0 '#f '#t))) + (struct Constant ('3)))) + (struct ToplevelRef ('0 '0 '#f '#t))))))) + #t] + [else + #f])) + ;; Lambdas (let ([parsed (run-my-parse #'(lambda (x) x))]) @@ -368,9 +371,16 @@ ;; Variable reference -(check-equal? (run-my-parse #'(#%variable-reference x)) - (make-Top (make-Prefix (list (make-GlobalBucket 'x))) - (make-VariableReference (make-ToplevelRef 0 0 #f #t)))) +(check-true (match (run-my-parse #'(#%variable-reference x)) + [(struct Top ((struct Prefix + ((list #f (struct GlobalBucket ('x))))) + (struct VariableReference ((struct ToplevelRef ('0 '1 '#f '#t)))))) + #t] + [else + #f])) + +;(make-Top (make-Prefix (list (make-GlobalBucket 'x))) +; (make-VariableReference (make-ToplevelRef 0 0 #f #t)))) ;; todo: see what it would take to run a typed/racket/base language. (void From 356901cf7ec36bd70444bee3153106164390997e Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 7 Aug 2011 17:16:08 -0400 Subject: [PATCH 05/30] trying to reduce number of explicit make-instruction-sequence calls --- compiler/compiler.rkt | 430 ++++++++++++++++++------------------------ 1 file changed, 185 insertions(+), 245 deletions(-) diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index 27dd3aa..417d24a 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -535,8 +535,7 @@ cenv (append-instruction-sequences get-value-code - (make-instruction-sequence - `(,(make-AssignImmediateStatement target (make-Const (void))))) + (make-AssignImmediateStatement target (make-Const (void))) singular-context-check))))) @@ -560,15 +559,13 @@ [a-code (compile (Branch-alternative exp) cenv target linkage)]) (append-instruction-sequences p-code - (append-instruction-sequences - (make-instruction-sequence - `(,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) - f-branch))) - t-branch - c-code - f-branch - a-code - after-if)))))) + (make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) + f-branch) + t-branch + c-code + f-branch + a-code + after-if))))) (: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) @@ -600,31 +597,26 @@ linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-PushControlFrame/Prompt - default-continuation-prompt-tag - on-return))) + (make-PushControlFrame/Prompt default-continuation-prompt-tag + on-return) (compile (first seq) cenv 'val return-linkage/nontail) (emit-values-context-check-on-procedure-return (linkage-context linkage) on-return/multiple on-return) - (make-instruction-sequence - `(,(make-AssignImmediateStatement target (make-Reg 'val)))))))] + (make-AssignImmediateStatement target (make-Reg 'val)))))] [else (let* ([on-return/multiple (make-label 'beforePromptPopMultiple)] [on-return (make-LinkedLabel (make-label 'beforePromptPop) on-return/multiple)]) (append-instruction-sequences - (make-instruction-sequence - `(,(make-PushControlFrame/Prompt - (make-DefaultContinuationPromptTag) - on-return))) + (make-PushControlFrame/Prompt (make-DefaultContinuationPromptTag) + on-return) + (compile (first seq) cenv 'val return-linkage/nontail) on-return/multiple - (make-instruction-sequence - `(,(make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) - (make-Const 1)) - (make-Const 0)))) + (make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) + (make-Const 1)) + (make-Const 0)) on-return (compile-splice (rest seq) cenv target linkage)))])) @@ -641,37 +633,35 @@ (let ([evaluate-and-save-first-expression (let ([after-first-seq (make-label 'afterFirstSeqEvaluated)]) (append-instruction-sequences - (make-instruction-sequence - `(,(make-Comment "begin0"))) + (make-Comment "begin0") ;; Evaluate the first expression in a multiple-value context, and get the values on the stack. (compile (first seq) cenv 'val next-linkage/keep-multiple-on-stack) - (make-instruction-sequence - `(,(make-TestAndJumpStatement (make-TestZero (make-Reg 'argcount)) after-first-seq) - ,(make-PushImmediateOntoEnvironment (make-Reg 'val) #f))) + + (make-TestAndJumpStatement (make-TestZero (make-Reg 'argcount)) after-first-seq) + (make-PushImmediateOntoEnvironment (make-Reg 'val) #f) after-first-seq ;; At this time, the argcount values are on the stack. ;; Next, we save those values temporarily in a throwaway control frame. - (make-instruction-sequence - `(,(make-PushControlFrame/Generic) - ,(make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingBegin0Count) - (make-Reg 'argcount)) - ,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount))) - ,(make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingBegin0Values) - (make-EnvLexicalReference 0 #f)) - ,(make-PopEnvironment (make-Const 1) (make-Const 0))))))] - - [reinstate-values-on-stack - (let ([after-values-reinstated (make-label 'afterValuesReinstated)]) - (make-instruction-sequence - `(;; Reinstate the values of the first expression, and drop the throwaway control frame. - ,(make-PushImmediateOntoEnvironment (make-ControlFrameTemporary 'pendingBegin0Values) #f) - ,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0))) - ,(make-AssignImmediateStatement 'argcount (make-ControlFrameTemporary 'pendingBegin0Count)) - ,(make-PopControlFrame) - ,(make-TestAndJumpStatement (make-TestZero (make-Reg 'argcount)) after-values-reinstated) - ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f)) - ,(make-PopEnvironment (make-Const 1) (make-Const 0)) - ,after-values-reinstated)))]) + (make-PushControlFrame/Generic) + (make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingBegin0Count) + (make-Reg 'argcount)) + (make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount))) + (make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingBegin0Values) + (make-EnvLexicalReference 0 #f)) + (make-PopEnvironment (make-Const 1) (make-Const 0))))] + + [reinstate-values-on-stack + (let ([after-values-reinstated (make-label 'afterValuesReinstated)]) + (append-instruction-sequences + ;; Reinstate the values of the first expression, and drop the throwaway control frame. + (make-PushImmediateOntoEnvironment (make-ControlFrameTemporary 'pendingBegin0Values) #f) + (make-PerformStatement (make-SpliceListIntoStack! (make-Const 0))) + (make-AssignImmediateStatement 'argcount (make-ControlFrameTemporary 'pendingBegin0Count)) + (make-PopControlFrame) + (make-TestAndJumpStatement (make-TestZero (make-Reg 'argcount)) after-values-reinstated) + (make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f)) + (make-PopEnvironment (make-Const 1) (make-Const 0)) + after-values-reinstated))]) (append-instruction-sequences evaluate-and-save-first-expression @@ -679,8 +669,8 @@ (compile-sequence (rest seq) cenv 'val next-linkage/drop-multiple) reinstate-values-on-stack - (make-instruction-sequence - `(,(make-AssignImmediateStatement target (make-Reg 'val)))) + + (make-AssignImmediateStatement target (make-Reg 'val)) ;; TODO: context needs check for arguments. (cond @@ -720,13 +710,12 @@ linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-AssignPrimOpStatement + (make-AssignPrimOpStatement target (make-MakeCompiledProcedure (Lam-entry-label exp) (Lam-arity exp) (Lam-closure-map exp) - (Lam-name exp))))) + (Lam-name exp))) singular-context-check)))) (: compile-empty-closure-reference (EmptyClosureReference CompileTimeEnvironment Target Linkage -> InstructionSequence)) @@ -736,13 +725,12 @@ linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-AssignPrimOpStatement - target - (make-MakeCompiledProcedure (EmptyClosureReference-entry-label exp) - (EmptyClosureReference-arity exp) - empty - (EmptyClosureReference-name exp))))) + (make-AssignPrimOpStatement + target + (make-MakeCompiledProcedure (EmptyClosureReference-entry-label exp) + (EmptyClosureReference-arity exp) + empty + (EmptyClosureReference-name exp))) singular-context-check)))) @@ -761,9 +749,9 @@ cenv (append-instruction-sequences ;; Make some temporary space for the lambdas - (make-instruction-sequence - `(,(make-Comment "scratch space for case-lambda") - ,(make-PushEnvironment n #f))) + + (make-Comment "scratch space for case-lambda") + (make-PushEnvironment n #f) ;; Compile each of the lambdas (apply append-instruction-sequences @@ -789,16 +777,15 @@ (make-EnvLexicalReference i #f))))) ;; Make the case lambda as a regular compiled procedure. Its closed values are the lambdas. - (make-instruction-sequence - `(,(make-AssignPrimOpStatement - (adjust-target-depth target n) - (make-MakeCompiledProcedure (CaseLam-entry-label exp) - (merge-arities (map Lam-arity (CaseLam-clauses exp))) - (build-list n (lambda: ([i : Natural]) i)) - (CaseLam-name exp))) - - ;; Finally, pop off the scratch space. - ,(make-PopEnvironment (make-Const n) (make-Const 0)))) + (make-AssignPrimOpStatement + (adjust-target-depth target n) + (make-MakeCompiledProcedure (CaseLam-entry-label exp) + (merge-arities (map Lam-arity (CaseLam-clauses exp))) + (build-list n (lambda: ([i : Natural]) i)) + (CaseLam-name exp))) + + ;; Finally, pop off the scratch space. + (make-PopEnvironment (make-Const n) (make-Const 0)) singular-context-check)))) @@ -860,14 +847,13 @@ linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-AssignPrimOpStatement - target - (make-MakeCompiledProcedureShell (Lam-entry-label exp) - (if (Lam-rest? exp) - (make-ArityAtLeast (Lam-num-parameters exp)) - (Lam-num-parameters exp)) - (Lam-name exp))))) + (make-AssignPrimOpStatement + target + (make-MakeCompiledProcedureShell (Lam-entry-label exp) + (if (Lam-rest? exp) + (make-ArityAtLeast (Lam-num-parameters exp)) + (Lam-num-parameters exp)) + (Lam-name exp))) singular-context-check)))) @@ -897,8 +883,7 @@ return-linkage)]) (append-instruction-sequences - (make-instruction-sequence - `(,(Lam-entry-label exp))) + (Lam-entry-label exp) maybe-unsplice-rest-argument maybe-install-closure-values lam-body-code))) @@ -908,43 +893,41 @@ (define (compile-case-lambda-body exp cenv) (append-instruction-sequences - (make-instruction-sequence - `(,(CaseLam-entry-label exp))) + (CaseLam-entry-label exp) (apply append-instruction-sequences (map (lambda: ([lam : (U Lam EmptyClosureReference)] [i : Natural]) (let ([not-match (make-label 'notMatch)]) - (make-instruction-sequence - `(,(make-TestAndJumpStatement - (make-TestClosureArityMismatch - (make-CompiledProcedureClosureReference - (make-Reg 'proc) - i) - (make-Reg 'argcount)) - not-match) - ;; Set the procedure register to the lam - ,(make-AssignImmediateStatement - 'proc - (make-CompiledProcedureClosureReference (make-Reg 'proc) i)) - - ,(make-GotoStatement (make-Label - (cond [(Lam? lam) - (Lam-entry-label lam)] - [(EmptyClosureReference? lam) - (EmptyClosureReference-entry-label lam)]))) - - ,not-match)))) + (append-instruction-sequences + (make-TestAndJumpStatement (make-TestClosureArityMismatch + (make-CompiledProcedureClosureReference + (make-Reg 'proc) + i) + (make-Reg 'argcount)) + not-match) + ;; Set the procedure register to the lam + (make-AssignImmediateStatement + 'proc + (make-CompiledProcedureClosureReference (make-Reg 'proc) i)) + + (make-GotoStatement (make-Label + (cond [(Lam? lam) + (Lam-entry-label lam)] + [(EmptyClosureReference? lam) + (EmptyClosureReference-entry-label lam)]))) + + not-match))) (CaseLam-clauses exp) (build-list (length (CaseLam-clauses exp)) (lambda: ([i : Natural]) i)))))) - + (: compile-lambda-bodies ((Listof lam+cenv) -> InstructionSequence)) ;; Compile several lambda bodies, back to back. (define (compile-lambda-bodies exps) (cond [(empty? exps) - (make-instruction-sequence '())] + empty-instruction-sequence] [else (let: ([lam : (U Lam CaseLam) (lam+cenv-lam (first exps))] [cenv : CompileTimeEnvironment (lam+cenv-cenv (first exps))]) @@ -1050,14 +1033,13 @@ (make-EnvLexicalReference i #f) 'val))))]) (append-instruction-sequences - (make-instruction-sequence - `(,(make-Comment "scratch space for general application") - ,(make-PushEnvironment (length (App-operands exp)) #f))) + + (make-Comment "scratch space for general application") + (make-PushEnvironment (length (App-operands exp)) #f) proc-code (juggle-operands operand-codes) - (make-instruction-sequence `(,(make-AssignImmediateStatement - 'argcount - (make-Const (length (App-operands exp)))))) + (make-AssignImmediateStatement 'argcount + (make-Const (length (App-operands exp)))) (compile-general-procedure-call cenv (make-Const (length (App-operands exp))) target @@ -1111,14 +1093,12 @@ (end-with-linkage linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-AssignPrimOpStatement - target - (make-CallKernelPrimitiveProcedure - kernel-op - operand-poss - expected-operand-types - typechecks?)))) + (make-AssignPrimOpStatement target + (make-CallKernelPrimitiveProcedure + kernel-op + operand-poss + expected-operand-types + typechecks?)) singular-context-check)))] [else @@ -1169,13 +1149,11 @@ operand-knowledge)] [(stack-pushing-code) - (make-instruction-sequence `(,(make-PushEnvironment - (length rest-operands) - #f)))] + (make-PushEnvironment (length rest-operands) + #f)] [(stack-popping-code) - (make-instruction-sequence `(,(make-PopEnvironment - (make-Const (length rest-operands)) - (make-Const 0))))] + (make-PopEnvironment (make-Const (length rest-operands)) + (make-Const 0))] [(constant-operand-poss) (simple-operands->opargs constant-operands)] @@ -1200,14 +1178,12 @@ (append-instruction-sequences stack-pushing-code rest-operand-code - (make-instruction-sequence - `(,(make-AssignPrimOpStatement - (adjust-target-depth target (length rest-operands)) - (make-CallKernelPrimitiveProcedure - kernel-op - (append constant-operand-poss rest-operand-poss) - expected-operand-types - typechecks?)))) + (make-AssignPrimOpStatement (adjust-target-depth target (length rest-operands)) + (make-CallKernelPrimitiveProcedure + kernel-op + (append constant-operand-poss rest-operand-poss) + expected-operand-types + typechecks?)) stack-popping-code singular-context-check)))]))) @@ -1354,8 +1330,8 @@ (make-EnvLexicalReference i #f) 'val))))]) (append-instruction-sequences - (make-instruction-sequence `(,(make-Comment "scratch space for statically known lambda application") - ,(make-PushEnvironment (length (App-operands exp)) #f))) + (make-Comment "scratch space for statically known lambda application") + (make-PushEnvironment (length (App-operands exp)) #f) proc-code (juggle-operands operand-codes) arity-check @@ -1375,7 +1351,7 @@ (cond ;; If there are no operands, no need to juggle. [(null? ops) - (make-instruction-sequence empty)] + empty-instruction-sequence] [(null? (rest ops)) (let: ([n : Natural (ensure-natural (sub1 (length operand-codes)))]) ;; The last operand needs to be handled specially: it currently lives in @@ -1383,11 +1359,10 @@ ;; last operand at 'val into env[n]. (append-instruction-sequences (car ops) - (make-instruction-sequence - `(,(make-AssignImmediateStatement 'proc - (make-EnvLexicalReference n #f)) - ,(make-AssignImmediateStatement (make-EnvLexicalReference n #f) - (make-Reg 'val))))))] + (make-AssignImmediateStatement 'proc + (make-EnvLexicalReference n #f)) + (make-AssignImmediateStatement (make-EnvLexicalReference n #f) + (make-Reg 'val))))] [else ;; Otherwise, add instructions to juggle the operator and operands in the stack. (append-instruction-sequences (car ops) @@ -1432,16 +1407,14 @@ [primitive-linkage : Linkage (make-NextLinkage (linkage-context linkage))]) (append-instruction-sequences - (make-instruction-sequence - `(,(make-TestAndJumpStatement (make-TestPrimitiveProcedure + (make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) - primitive-branch))) + primitive-branch) ;; Compiled branch compiled-branch - (make-instruction-sequence - `(,(make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount))))) + (make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount))) (compile-compiled-procedure-application cenv number-of-arguments 'dynamic @@ -1454,8 +1427,7 @@ linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount))))) + (make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount))) (compile-primitive-application cenv target primitive-linkage) after-call)))))) @@ -1466,13 +1438,12 @@ (define (compile-primitive-application cenv target linkage) (let ([singular-context-check (emit-singular-context linkage)]) (append-instruction-sequences - (make-instruction-sequence - `(,(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure)) - ,(make-PopEnvironment (make-Reg 'argcount) - (make-Const 0)) - ,@(if (eq? target 'val) - empty - (list (make-AssignImmediateStatement target (make-Reg 'val)))))) + (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure)) + (make-PopEnvironment (make-Reg 'argcount) + (make-Const 0)) + (if (eq? target 'val) + empty-instruction-sequence + (make-AssignImmediateStatement target (make-Reg 'val))) singular-context-check))) @@ -1488,9 +1459,8 @@ after-call (linkage-context linkage)))]) (append-instruction-sequences - (make-instruction-sequence `(,(make-AssignImmediateStatement - 'argcount - (make-Const n)))) + (make-AssignImmediateStatement 'argcount + (make-Const n)) (compile-compiled-procedure-application cenv (make-Const n) (make-Label @@ -1533,8 +1503,7 @@ [(eq? target 'val) empty-instruction-sequence] [else - (make-instruction-sequence - `(,(make-AssignImmediateStatement target (make-Reg 'val))))])] + (make-AssignImmediateStatement target (make-Reg 'val))])] [on-return/multiple (make-label 'procReturnMultiple)] @@ -1545,9 +1514,8 @@ ;; are expected to generate the proc-return-multiple and proc-return code afterwards. [nontail-jump-into-procedure (append-instruction-sequences - (make-instruction-sequence - `(,(make-PushControlFrame/Call on-return) - ,(make-GotoStatement entry-point-target))))]) + (make-PushControlFrame/Call on-return) + (make-GotoStatement entry-point-target))]) (cond [(ReturnLinkage? linkage) (cond @@ -1558,15 +1526,13 @@ ;; We clean up the stack right before the jump, and do not add ;; to the control stack. (let ([reuse-the-stack - (make-instruction-sequence - `(,(make-PopEnvironment (make-Const (length cenv)) - number-of-arguments)))]) + (make-PopEnvironment (make-Const (length cenv)) + number-of-arguments)]) (append-instruction-sequences reuse-the-stack - (make-instruction-sequence - `(;; Assign the proc value of the existing call frame. - ,(make-PerformStatement (make-SetFrameCallee! (make-Reg 'proc))) - ,(make-GotoStatement entry-point-target)))))] + ;; Assign the proc value of the existing call frame. + (make-PerformStatement (make-SetFrameCallee! (make-Reg 'proc))) + (make-GotoStatement entry-point-target)))] [else ;; This case happens when we should be returning to a caller, but where @@ -1574,10 +1540,9 @@ (append-instruction-sequences nontail-jump-into-procedure on-return/multiple - (make-instruction-sequence - `(,(make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) + (make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) (make-Const 1)) - (make-Const 0)))) + (make-Const 0)) on-return)])] [else @@ -1592,8 +1557,7 @@ [maybe-jump-to-label (if (LabelLinkage? linkage) - (make-instruction-sequence - `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage))))) + (make-GotoStatement (make-Label (LabelLinkage-label linkage))) empty-instruction-sequence)]) (append-instruction-sequences @@ -1616,20 +1580,17 @@ [(eq? context 'drop-multiple) (append-instruction-sequences on-return/multiple - (make-instruction-sequence - `(,(make-PopEnvironment (SubtractArg (make-Reg 'argcount) (make-Const 1)) - (make-Const 0)))) + (make-PopEnvironment (SubtractArg (make-Reg 'argcount) (make-Const 1)) + (make-Const 0)) on-return)] [(eq? context 'keep-multiple) (let ([after-return (make-label 'afterReturn)]) (append-instruction-sequences on-return/multiple - (make-instruction-sequence - `(,(make-GotoStatement (make-Label after-return)))) + (make-GotoStatement (make-Label after-return)) on-return - (make-instruction-sequence - `(,(make-AssignImmediateStatement 'argcount (make-Const 1)))) + (make-AssignImmediateStatement 'argcount (make-Const 1)) after-return))] [(natural? context) @@ -1637,25 +1598,20 @@ [(= context 1) (append-instruction-sequences on-return/multiple - (make-instruction-sequence - `(,(make-PerformStatement - (make-RaiseContextExpectedValuesError! 1)))) + (make-PerformStatement + (make-RaiseContextExpectedValuesError! 1)) on-return)] [else (let ([after-value-check (make-label 'afterValueCheck)]) (append-instruction-sequences on-return/multiple - (make-instruction-sequence - `( - ;; if the wrong number of arguments come in, die - ,(make-TestAndJumpStatement - (make-TestZero (make-SubtractArg (make-Reg 'argcount) - (make-Const context))) - after-value-check))) + ;; if the wrong number of arguments come in, die + (make-TestAndJumpStatement (make-TestZero (make-SubtractArg (make-Reg 'argcount) + (make-Const context))) + after-value-check) on-return - (make-instruction-sequence - `(,(make-PerformStatement - (make-RaiseContextExpectedValuesError! context)))) + (make-PerformStatement + (make-RaiseContextExpectedValuesError! context)) after-value-check))])])) @@ -1742,12 +1698,12 @@ linkage extended-cenv (append-instruction-sequences - (make-instruction-sequence `(,(make-Comment "scratch space for let1") - ,(make-PushEnvironment 1 #f))) + (make-Comment "scratch space for let1") + (make-PushEnvironment 1 #f) rhs-code body-code after-body-code - (make-instruction-sequence `(,(make-PopEnvironment (make-Const 1) (make-Const 0)))) + (make-PopEnvironment (make-Const 1) (make-Const 0)) after-let1)))) @@ -1784,9 +1740,8 @@ linkage extended-cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-Comment "scratch space for let-void") - ,(make-PushEnvironment n (LetVoid-boxes? exp)))) + (make-Comment "scratch space for let-void") + (make-PushEnvironment n (LetVoid-boxes? exp)) body-code after-body-code @@ -1895,7 +1850,7 @@ (: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-install-value exp cenv target linkage) (append-instruction-sequences - (make-instruction-sequence `(,(make-Comment "install-value"))) + (make-Comment "install-value") (let ([count (InstallValue-count exp)]) (cond [(= count 0) (end-with-linkage @@ -1907,9 +1862,8 @@ (make-NextLinkage 0)))] [(= count 1) (append-instruction-sequences - (make-instruction-sequence - `(,(make-Comment (format "installing single value into ~s" - (InstallValue-depth exp))))) + (make-Comment (format "installing single value into ~s" + (InstallValue-depth exp))) (end-with-linkage linkage cenv @@ -1922,8 +1876,7 @@ linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-Comment "install-value: evaluating values"))) + (make-Comment "install-value: evaluating values") (compile (InstallValue-body exp) cenv 'val @@ -1942,17 +1895,15 @@ (cons (make-Reg 'val) (build-list (sub1 count) (lambda: ([i : Natural]) (make-EnvLexicalReference i #f)))))) - (make-instruction-sequence - `(,(make-PopEnvironment (make-Const (sub1 count)) (make-Const 0))))))])))) + (make-PopEnvironment (make-Const (sub1 count)) (make-Const 0))))])))) (: compile-box-environment-value (BoxEnv CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-box-environment-value exp cenv target linkage) (append-instruction-sequences - (make-instruction-sequence - `(,(make-AssignPrimOpStatement (make-EnvLexicalReference (BoxEnv-depth exp) #f) - (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp))))) + (make-AssignPrimOpStatement (make-EnvLexicalReference (BoxEnv-depth exp) #f) + (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp))) (compile (BoxEnv-body exp) cenv target linkage))) @@ -1965,13 +1916,11 @@ (define (in-return-context) (append-instruction-sequences (compile (WithContMark-key exp) cenv 'val next-linkage/expects-single) - (make-instruction-sequence - `(,(make-AssignImmediateStatement + (make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingContinuationMarkKey) - (make-Reg 'val)))) + (make-Reg 'val)) (compile (WithContMark-value exp) cenv 'val next-linkage/expects-single) - (make-instruction-sequence - `(,(make-PerformStatement (make-InstallContinuationMarkEntry!)))) + (make-PerformStatement (make-InstallContinuationMarkEntry!)) (compile (WithContMark-body exp) cenv target linkage))) (: in-other-context ((U NextLinkage LabelLinkage) -> InstructionSequence)) @@ -1985,18 +1934,14 @@ (append-instruction-sequences ;; Making a continuation frame; isn't really used for anything ;; but recording the key/value data. - (make-instruction-sequence - `(,(make-PushControlFrame/Generic))) + (make-PushControlFrame/Generic) (compile (WithContMark-key exp) cenv 'val next-linkage/expects-single) - (make-instruction-sequence `(,(make-AssignImmediateStatement - (make-ControlFrameTemporary 'pendingContinuationMarkKey) - (make-Reg 'val)))) + (make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingContinuationMarkKey) + (make-Reg 'val)) (compile (WithContMark-value exp) cenv 'val next-linkage/expects-single) - (make-instruction-sequence `(,(make-PerformStatement - (make-InstallContinuationMarkEntry!)))) + (make-PerformStatement (make-InstallContinuationMarkEntry!)) (compile (WithContMark-body exp) cenv target body-next-linkage) - (make-instruction-sequence - `(,(make-PopControlFrame))))))) + (make-PopControlFrame))))) (cond [(ReturnLinkage? linkage) @@ -2017,8 +1962,7 @@ (append-instruction-sequences ;; Save the procedure value temporarily in a control stack frame - (make-instruction-sequence - `(,(make-PushControlFrame/Generic))) + (make-PushControlFrame/Generic) (compile (ApplyValues-proc exp) cenv (make-ControlFrameTemporary 'pendingApplyValuesProc) @@ -2031,22 +1975,19 @@ 'val next-linkage/keep-multiple-on-stack) - (make-instruction-sequence - `(,(make-TestAndJumpStatement (make-TestZero (make-Reg 'argcount)) after-args-evaluated) + (make-TestAndJumpStatement (make-TestZero (make-Reg 'argcount)) after-args-evaluated) ;; In the common case where we do get values back, we push val onto the stack too, ;; so that we have n values on the stack before we jump to the procedure call. - ,(make-PushImmediateOntoEnvironment (make-Reg 'val) #f))) - + (make-PushImmediateOntoEnvironment (make-Reg 'val) #f) + after-args-evaluated ;; Retrieve the procedure off the temporary control frame. - (make-instruction-sequence - `(,(make-AssignImmediateStatement + (make-AssignImmediateStatement 'proc - (make-ControlFrameTemporary 'pendingApplyValuesProc)))) + (make-ControlFrameTemporary 'pendingApplyValuesProc)) ;; Pop off the temporary control frame - (make-instruction-sequence - `(,(make-PopControlFrame))) + (make-PopControlFrame) ;; Finally, do the generic call into the consumer function. @@ -2093,9 +2034,8 @@ ;; Finally, make sure any multiple values are off the stack. (if (> (length ids) 1) - (make-instruction-sequence - `(,(make-PopEnvironment (make-Const (sub1 (length ids))) - (make-Const 0)))) + (make-PopEnvironment (make-Const (sub1 (length ids))) + (make-Const 0)) empty-instruction-sequence))))) From 0757040ec241c91343735c8f7a4873485b8afa30 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 7 Aug 2011 17:24:53 -0400 Subject: [PATCH 06/30] continuing to remove explicit calls to make-instruction-sequence --- compiler/compiler.rkt | 204 +++++++++++++++++++----------------------- 1 file changed, 92 insertions(+), 112 deletions(-) diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index 417d24a..6c7acbd 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -43,24 +43,20 @@ (append-instruction-sequences ;; Layout the lambda bodies... - (make-instruction-sequence - `(,(make-GotoStatement (make-Label after-lam-bodies)))) + (make-GotoStatement (make-Label after-lam-bodies)) (compile-lambda-bodies (collect-all-lambdas-with-bodies exp)) after-lam-bodies ;; Begin a prompted evaluation: - (make-instruction-sequence - `(,(make-PushControlFrame/Prompt default-continuation-prompt-tag - before-pop-prompt))) + (make-PushControlFrame/Prompt default-continuation-prompt-tag + before-pop-prompt) (compile exp '() 'val return-linkage/nontail) before-pop-prompt-multiple - (make-instruction-sequence - `(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0)))) + (make-PopEnvironment (make-Reg 'argcount) (make-Const 0)) before-pop-prompt (if (eq? target 'val) empty-instruction-sequence - (make-instruction-sequence - `(,(make-AssignImmediateStatement target (make-Reg 'val))))))))))) + (make-AssignImmediateStatement target (make-Reg 'val))))))))) (define-struct: lam+cenv ([lam : (U Lam CaseLam)] @@ -199,25 +195,24 @@ [(ReturnLinkage-tail? linkage) ;; Under tail calls, clear the environment of the current stack frame (represented by cenv) ;; and do the jump. - (make-instruction-sequence - `(,(make-PopEnvironment (make-Const (length cenv)) - (make-Const 0)) - ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel)) - ,(make-PopControlFrame) - ,(make-GotoStatement (make-Reg 'proc))))] + (append-instruction-sequences + (make-PopEnvironment (make-Const (length cenv)) + (make-Const 0)) + (make-AssignImmediateStatement 'proc (make-ControlStackLabel)) + (make-PopControlFrame) + (make-GotoStatement (make-Reg 'proc)))] [else ;; Under non-tail calls, leave the stack as is and just do the jump. - (make-instruction-sequence - `(,(make-AssignImmediateStatement 'proc (make-ControlStackLabel)) - ,(make-PopControlFrame) - ,(make-GotoStatement (make-Reg 'proc))))])] + (append-instruction-sequences + (make-AssignImmediateStatement 'proc (make-ControlStackLabel)) + (make-PopControlFrame) + (make-GotoStatement (make-Reg 'proc)))])] [(NextLinkage? linkage) empty-instruction-sequence] [(LabelLinkage? linkage) - (make-instruction-sequence - `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))])) + (make-GotoStatement (make-Label (LabelLinkage-label linkage)))])) @@ -300,16 +295,14 @@ (end-with-linkage linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names)))) + (make-PerformStatement (make-ExtendEnvironment/Prefix! names)) (compile (Top-code top) (cons (Top-prefix top) cenv) 'val next-linkage/drop-multiple) - (make-instruction-sequence - `(,(make-AssignImmediateStatement target (make-Reg 'val)) - ,(make-PopEnvironment (make-Const 1) - (make-Const 0)))))))) + (make-AssignImmediateStatement target (make-Reg 'val)) + (make-PopEnvironment (make-Const 1) + (make-Const 0)))))) @@ -371,8 +364,7 @@ (end-with-linkage linkage cenv (append-instruction-sequences (compile-module-invoke (Require-path exp)) - (make-instruction-sequence - `(,(make-AssignImmediateStatement target (make-Const (void)))))))) + (make-AssignImmediateStatement target (make-Const (void)))))) (: compile-module-invoke (ModuleLocator -> InstructionSequence)) @@ -381,36 +373,36 @@ ;; if the module hasn't been linked yet. (define (compile-module-invoke a-module-name) (cond - [(kernel-module-name? a-module-name) - empty-instruction-sequence] - [else - (let* ([linked (make-label 'linked)] - [already-loaded (make-label 'alreadyLoaded)] - [on-return-multiple (make-label 'onReturnMultiple)] - [on-return (make-LinkedLabel (make-label 'onReturn) - on-return-multiple)]) - (make-instruction-sequence - `(,(make-TestAndJumpStatement (make-TestTrue - (make-IsModuleLinked a-module-name)) - linked) - ;; TODO: raise an exception here that says that the module hasn't been - ;; linked yet. - ,(make-DebugPrint (make-Const - (format "DEBUG: the module ~a hasn't been linked in!!!" - (ModuleLocator-name a-module-name)))) - ,(make-GotoStatement (make-Label already-loaded)) - ,linked - ,(make-TestAndJumpStatement (make-TestTrue - (make-IsModuleInvoked a-module-name)) - already-loaded) - ,(make-PushControlFrame/Call on-return) - ,(make-GotoStatement (ModuleEntry a-module-name)) - ,on-return-multiple - ,(make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) - (make-Const 1)) - (make-Const 0)) - ,on-return - ,already-loaded)))])) + [(kernel-module-name? a-module-name) + empty-instruction-sequence] + [else + (let* ([linked (make-label 'linked)] + [already-loaded (make-label 'alreadyLoaded)] + [on-return-multiple (make-label 'onReturnMultiple)] + [on-return (make-LinkedLabel (make-label 'onReturn) + on-return-multiple)]) + (append-instruction-sequences + (make-TestAndJumpStatement (make-TestTrue + (make-IsModuleLinked a-module-name)) + linked) + ;; TODO: raise an exception here that says that the module hasn't been + ;; linked yet. + (make-DebugPrint (make-Const + (format "DEBUG: the module ~a hasn't been linked in!!!" + (ModuleLocator-name a-module-name)))) + (make-GotoStatement (make-Label already-loaded)) + linked + (make-TestAndJumpStatement (make-TestTrue + (make-IsModuleInvoked a-module-name)) + already-loaded) + (make-PushControlFrame/Call on-return) + (make-GotoStatement (ModuleEntry a-module-name)) + on-return-multiple + (make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) + (make-Const 1)) + (make-Const 0)) + on-return + already-loaded))])) (: kernel-module-name? (ModuleLocator -> Boolean)) @@ -445,18 +437,15 @@ empty-instruction-sequence] [(eq? context 'keep-multiple) - (make-instruction-sequence - `(,(make-AssignImmediateStatement 'argcount (make-Const 1))))] - + (make-AssignImmediateStatement 'argcount (make-Const 1))] + [(natural? context) (if (= context 1) empty-instruction-sequence - (make-instruction-sequence - `(,(make-AssignImmediateStatement 'argcount - (make-Const 1)) - ,(make-PerformStatement - (make-RaiseContextExpectedValuesError! - context)))))]))])) + (append-instruction-sequences + (make-AssignImmediateStatement 'argcount (make-Const 1)) + (make-PerformStatement (make-RaiseContextExpectedValuesError! + context))))]))])) @@ -468,8 +457,7 @@ (end-with-linkage linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-AssignImmediateStatement target (make-Const (Constant-v exp))))) + (make-AssignImmediateStatement target (make-Const (Constant-v exp))) singular-context-check)))) @@ -480,8 +468,7 @@ (end-with-linkage linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-AssignImmediateStatement target exp))) + (make-AssignImmediateStatement target exp) singular-context-check)))) @@ -492,11 +479,9 @@ (end-with-linkage linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-AssignImmediateStatement - target - (make-EnvLexicalReference (LocalRef-depth exp) - (LocalRef-unbox? exp))))) + (make-AssignImmediateStatement target + (make-EnvLexicalReference (LocalRef-depth exp) + (LocalRef-unbox? exp))) singular-context-check)))) @@ -677,25 +662,24 @@ [(ReturnLinkage? linkage) (cond [(ReturnLinkage-tail? linkage) - (make-instruction-sequence - `(,(make-PopEnvironment (make-Const (length cenv)) + (append-instruction-sequences + (make-PopEnvironment (make-Const (length cenv)) (make-SubtractArg (make-Reg 'argcount) (make-Const 1))) - ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) - ,(make-PopControlFrame) - ,(make-GotoStatement (make-Reg 'proc))))] + (make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) + (make-PopControlFrame) + (make-GotoStatement (make-Reg 'proc)))] [else - (make-instruction-sequence - `(,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) - ,(make-PopControlFrame) - ,(make-GotoStatement (make-Reg 'proc))))])] + (append-instruction-sequences + (make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) + (make-PopControlFrame) + (make-GotoStatement (make-Reg 'proc)))])] [(NextLinkage? linkage) empty-instruction-sequence] [(LabelLinkage? linkage) - (make-instruction-sequence - `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))])))])) + (make-GotoStatement (make-Label (LabelLinkage-label linkage)))])))])) @@ -757,8 +741,7 @@ (apply append-instruction-sequences (map (lambda: ([lam : (U Lam EmptyClosureReference)] [target : Target]) - (make-instruction-sequence - `(,(make-AssignPrimOpStatement + (make-AssignPrimOpStatement target (cond [(Lam? lam) @@ -770,7 +753,7 @@ (make-MakeCompiledProcedure (EmptyClosureReference-entry-label lam) (EmptyClosureReference-arity lam) '() - (EmptyClosureReference-name lam))]))))) + (EmptyClosureReference-name lam))]))) (CaseLam-clauses exp) (build-list (length (CaseLam-clauses exp)) (lambda: ([i : Natural]) @@ -863,18 +846,17 @@ (define (compile-lambda-body exp cenv) (let: ([maybe-unsplice-rest-argument : InstructionSequence (if (Lam-rest? exp) - (make-instruction-sequence - `(,(make-PerformStatement + (make-PerformStatement (make-UnspliceRestFromStack! (make-Const (Lam-num-parameters exp)) (make-SubtractArg (make-Reg 'argcount) - (make-Const (Lam-num-parameters exp))))))) + (make-Const (Lam-num-parameters exp))))) empty-instruction-sequence)] [maybe-install-closure-values : InstructionSequence (if (not (empty? (Lam-closure-map exp))) - (make-instruction-sequence - `(,(make-Comment (format "installing closure for ~s" (Lam-name exp))) - ,(make-PerformStatement (make-InstallClosureValues!)))) + (append-instruction-sequences + (make-Comment (format "installing closure for ~s" (Lam-name exp))) + (make-PerformStatement (make-InstallClosureValues!))) empty-instruction-sequence)] [lam-body-code : InstructionSequence (compile (Lam-body exp) @@ -1000,10 +982,10 @@ [(Prefix? op-knowledge) (error 'impossible)] [(Const? op-knowledge) - (make-instruction-sequence - `(,(make-AssignImmediateStatement 'proc op-knowledge) - ,(make-PerformStatement - (make-RaiseOperatorApplicationError! (make-Reg 'proc)))))])))) + (append-instruction-sequences + (make-AssignImmediateStatement 'proc op-knowledge) + (make-PerformStatement + (make-RaiseOperatorApplicationError! (make-Reg 'proc))))])))) (: compile-general-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) @@ -1832,11 +1814,10 @@ (apply append-instruction-sequences (map (lambda: ([lam : Lam] [i : Natural]) - (make-instruction-sequence - `(,(make-Comment (format "Installing shell for ~s\n" (Lam-name lam))) - ,(make-PerformStatement - (make-FixClosureShellMap! i (Lam-closure-map lam)))))) - + (append-instruction-sequences + (make-Comment (format "Installing shell for ~s\n" (Lam-name lam))) + (make-PerformStatement (make-FixClosureShellMap! i + (Lam-closure-map lam))))) (LetRec-procs exp) (build-list n (lambda: ([i : Natural]) i)))) @@ -1884,9 +1865,9 @@ (apply append-instruction-sequences (map (lambda: ([to : EnvLexicalReference] [from : OpArg]) - (make-instruction-sequence - `(,(make-Comment "install-value: installing value") - ,(make-AssignImmediateStatement to from)))) + (append-instruction-sequences + (make-Comment "install-value: installing value") + (make-AssignImmediateStatement to from))) (build-list count (lambda: ([i : Natural]) (make-EnvLexicalReference (+ i (InstallValue-depth exp) @@ -2014,15 +1995,14 @@ (apply append-instruction-sequences (map (lambda: ([id : ToplevelRef] [from : OpArg]) - (make-instruction-sequence - `(,(make-AssignImmediateStatement + (make-AssignImmediateStatement ;; Slightly subtle: the toplevelrefs were with respect to the ;; stack at the beginning of def-values, but at the moment, ;; there may be additional values that are currently there. (make-EnvPrefixReference (+ (ensure-natural (sub1 n)) (ToplevelRef-depth id)) (ToplevelRef-pos id)) - from)))) + from)) ids (if (> n 0) (cons (make-Reg 'val) From ea7b29831426dc531564a190b896d7c9c52dc76d Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 7 Aug 2011 17:32:23 -0400 Subject: [PATCH 07/30] re-indentation --- compiler/compiler.rkt | 1218 ++++++++++++++++++++--------------------- 1 file changed, 606 insertions(+), 612 deletions(-) diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index 6c7acbd..d63d391 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -6,8 +6,7 @@ "compiler-structs.rkt" "kernel-primitives.rkt" "optimize-il.rkt" - "analyzer-structs.rkt" - #;"analyzer.rkt" + "analyzer-structs.rkt" "../parameters.rkt" "../sets.rkt" racket/match @@ -15,48 +14,43 @@ racket/list) (require/typed "../logger.rkt" [log-debug (String -> Void)]) - + (provide (rename-out [-compile compile]) compile-general-procedure-call append-instruction-sequences) -#;(: current-analysis (Parameterof Analysis)) -#;(define current-analysis (make-parameter (empty-analysis))) - - (: -compile (Expression Target Linkage -> (Listof Statement))) ;; Generates the instruction-sequence stream. ;; Note: the toplevel generates the lambda body streams at the head, and then the ;; rest of the instruction stream. (define (-compile exp target linkage) - (parameterize (#;[current-analysis (analyze exp)]) - (let* ([after-lam-bodies (make-label 'afterLamBodies)] - [before-pop-prompt-multiple (make-label 'beforePopPromptMultiple)] - [before-pop-prompt (make-LinkedLabel - (make-label 'beforePopPrompt) - before-pop-prompt-multiple)]) - (optimize-il - (statements - (append-instruction-sequences - - ;; Layout the lambda bodies... - (make-GotoStatement (make-Label after-lam-bodies)) - (compile-lambda-bodies (collect-all-lambdas-with-bodies exp)) - after-lam-bodies - - ;; Begin a prompted evaluation: - (make-PushControlFrame/Prompt default-continuation-prompt-tag - before-pop-prompt) - (compile exp '() 'val return-linkage/nontail) - before-pop-prompt-multiple - (make-PopEnvironment (make-Reg 'argcount) (make-Const 0)) - before-pop-prompt - (if (eq? target 'val) - empty-instruction-sequence - (make-AssignImmediateStatement target (make-Reg 'val))))))))) + (let* ([after-lam-bodies (make-label 'afterLamBodies)] + [before-pop-prompt-multiple (make-label 'beforePopPromptMultiple)] + [before-pop-prompt (make-LinkedLabel + (make-label 'beforePopPrompt) + before-pop-prompt-multiple)]) + (optimize-il + (statements + (append-instruction-sequences + + ;; Layout the lambda bodies... + (make-GotoStatement (make-Label after-lam-bodies)) + (compile-lambda-bodies (collect-all-lambdas-with-bodies exp)) + after-lam-bodies + + ;; Begin a prompted evaluation: + (make-PushControlFrame/Prompt default-continuation-prompt-tag + before-pop-prompt) + (compile exp '() 'val return-linkage/nontail) + before-pop-prompt-multiple + (make-PopEnvironment (make-Reg 'argcount) (make-Const 0)) + before-pop-prompt + (if (eq? target 'val) + empty-instruction-sequence + (make-AssignImmediateStatement target (make-Reg 'val)))))))) (define-struct: lam+cenv ([lam : (U Lam CaseLam)] @@ -68,97 +62,97 @@ ;; Finds all the lambdas in the expression. (define (collect-all-lambdas-with-bodies exp) (let: loop : (Listof lam+cenv) - ([exp : Expression exp] - [cenv : CompileTimeEnvironment '()]) - - (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) - '()] - [(ToplevelRef? exp) - '()] - [(ToplevelSet? exp) - (loop (ToplevelSet-value exp) cenv)] - [(Branch? exp) - (append (loop (Branch-predicate exp) cenv) - (loop (Branch-consequent exp) cenv) - (loop (Branch-alternative exp) cenv))] - [(Lam? exp) - (cons (make-lam+cenv exp cenv) - (loop (Lam-body exp) - (extract-lambda-cenv exp cenv)))] - [(CaseLam? exp) - (cons (make-lam+cenv exp cenv) - (apply append (map (lambda: ([lam : (U Lam EmptyClosureReference)]) - (loop lam cenv)) - (CaseLam-clauses exp))))] - - [(EmptyClosureReference? exp) - '()] - - [(Seq? exp) - (apply append (map (lambda: ([e : Expression]) (loop e cenv)) - (Seq-actions exp)))] - [(Splice? exp) - (apply append (map (lambda: ([e : Expression]) (loop e cenv)) - (Splice-actions exp)))] - [(Begin0? exp) - (apply append (map (lambda: ([e : Expression]) (loop e cenv)) - (Begin0-actions exp)))] - [(App? exp) - (let ([new-cenv (append (build-list (length (App-operands exp)) (lambda: ([i : Natural]) '?)) - cenv)]) - (append (loop (App-operator exp) new-cenv) - (apply append (map (lambda: ([e : Expression]) (loop e new-cenv)) (App-operands exp)))))] - [(Let1? exp) - (append (loop (Let1-rhs exp) - (cons '? cenv)) - (loop (Let1-body exp) - (cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv)) - cenv)))] - [(LetVoid? exp) - (loop (LetVoid-body exp) - (append (build-list (LetVoid-count exp) (lambda: ([i : Natural]) '?)) - cenv))] - [(InstallValue? exp) - (loop (InstallValue-body exp) cenv)] - [(BoxEnv? exp) - (loop (BoxEnv-body exp) cenv)] - [(LetRec? exp) - (let ([n (length (LetRec-procs exp))]) - (let ([new-cenv (append (map (lambda: ([p : Lam]) - (extract-static-knowledge - p - (append (build-list (length (LetRec-procs exp)) - (lambda: ([i : Natural]) '?)) - (drop cenv n)))) - (LetRec-procs exp)) - (drop cenv n))]) - (append (apply append - (map (lambda: ([lam : Lam]) - (loop lam new-cenv)) - (LetRec-procs exp))) - (loop (LetRec-body exp) new-cenv))))] - [(WithContMark? exp) - (append (loop (WithContMark-key exp) cenv) - (loop (WithContMark-value exp) cenv) - (loop (WithContMark-body exp) cenv))] - [(ApplyValues? exp) - (append (loop (ApplyValues-proc exp) cenv) - (loop (ApplyValues-args-expr exp) cenv))] - [(DefValues? exp) - (append (loop (DefValues-rhs exp) cenv))] - [(PrimitiveKernelValue? exp) - '()] - [(VariableReference? exp) - (loop (VariableReference-toplevel exp) cenv)] - [(Require? exp) - '()]))) + ([exp : Expression exp] + [cenv : CompileTimeEnvironment '()]) + + (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) + '()] + [(ToplevelRef? exp) + '()] + [(ToplevelSet? exp) + (loop (ToplevelSet-value exp) cenv)] + [(Branch? exp) + (append (loop (Branch-predicate exp) cenv) + (loop (Branch-consequent exp) cenv) + (loop (Branch-alternative exp) cenv))] + [(Lam? exp) + (cons (make-lam+cenv exp cenv) + (loop (Lam-body exp) + (extract-lambda-cenv exp cenv)))] + [(CaseLam? exp) + (cons (make-lam+cenv exp cenv) + (apply append (map (lambda: ([lam : (U Lam EmptyClosureReference)]) + (loop lam cenv)) + (CaseLam-clauses exp))))] + + [(EmptyClosureReference? exp) + '()] + + [(Seq? exp) + (apply append (map (lambda: ([e : Expression]) (loop e cenv)) + (Seq-actions exp)))] + [(Splice? exp) + (apply append (map (lambda: ([e : Expression]) (loop e cenv)) + (Splice-actions exp)))] + [(Begin0? exp) + (apply append (map (lambda: ([e : Expression]) (loop e cenv)) + (Begin0-actions exp)))] + [(App? exp) + (let ([new-cenv (append (build-list (length (App-operands exp)) (lambda: ([i : Natural]) '?)) + cenv)]) + (append (loop (App-operator exp) new-cenv) + (apply append (map (lambda: ([e : Expression]) (loop e new-cenv)) (App-operands exp)))))] + [(Let1? exp) + (append (loop (Let1-rhs exp) + (cons '? cenv)) + (loop (Let1-body exp) + (cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv)) + cenv)))] + [(LetVoid? exp) + (loop (LetVoid-body exp) + (append (build-list (LetVoid-count exp) (lambda: ([i : Natural]) '?)) + cenv))] + [(InstallValue? exp) + (loop (InstallValue-body exp) cenv)] + [(BoxEnv? exp) + (loop (BoxEnv-body exp) cenv)] + [(LetRec? exp) + (let ([n (length (LetRec-procs exp))]) + (let ([new-cenv (append (map (lambda: ([p : Lam]) + (extract-static-knowledge + p + (append (build-list (length (LetRec-procs exp)) + (lambda: ([i : Natural]) '?)) + (drop cenv n)))) + (LetRec-procs exp)) + (drop cenv n))]) + (append (apply append + (map (lambda: ([lam : Lam]) + (loop lam new-cenv)) + (LetRec-procs exp))) + (loop (LetRec-body exp) new-cenv))))] + [(WithContMark? exp) + (append (loop (WithContMark-key exp) cenv) + (loop (WithContMark-value exp) cenv) + (loop (WithContMark-body exp) cenv))] + [(ApplyValues? exp) + (append (loop (ApplyValues-proc exp) cenv) + (loop (ApplyValues-args-expr exp) cenv))] + [(DefValues? exp) + (append (loop (DefValues-rhs exp) cenv))] + [(PrimitiveKernelValue? exp) + '()] + [(VariableReference? exp) + (loop (VariableReference-toplevel exp) cenv)] + [(Require? exp) + '()]))) @@ -167,7 +161,7 @@ ;; body of the lambda. (define (extract-lambda-cenv lam cenv) (append (map (lambda: ([d : Natural]) - (list-ref cenv d)) + (list-ref cenv d)) (Lam-closure-map lam)) (build-list (if (Lam-rest? lam) (add1 (Lam-num-parameters lam)) @@ -210,7 +204,7 @@ [(NextLinkage? linkage) empty-instruction-sequence] - + [(LabelLinkage? linkage) (make-GotoStatement (make-Label (LabelLinkage-label linkage)))])) @@ -292,17 +286,17 @@ ;; and then pop the top prefix off. (define (compile-top top cenv target linkage) (let*: ([names : (Listof (U False Symbol GlobalBucket ModuleVariable)) (Prefix-names (Top-prefix top))]) - (end-with-linkage - linkage cenv - (append-instruction-sequences - (make-PerformStatement (make-ExtendEnvironment/Prefix! names)) - (compile (Top-code top) - (cons (Top-prefix top) cenv) - 'val - next-linkage/drop-multiple) - (make-AssignImmediateStatement target (make-Reg 'val)) - (make-PopEnvironment (make-Const 1) - (make-Const 0)))))) + (end-with-linkage + linkage cenv + (append-instruction-sequences + (make-PerformStatement (make-ExtendEnvironment/Prefix! names)) + (compile (Top-code top) + (cons (Top-prefix top) cenv) + 'val + next-linkage/drop-multiple) + (make-AssignImmediateStatement target (make-Reg 'val)) + (make-PopEnvironment (make-Const 1) + (make-Const 0)))))) @@ -328,7 +322,7 @@ (append-instruction-sequences (make-PerformStatement (make-InstallModuleEntry! name path module-entry)) (make-GotoStatement (make-Label after-module-body)) - + module-entry (make-PerformStatement (make-MarkModuleInvoked! path)) @@ -339,7 +333,7 @@ ;; 2. Next, evaluate the module body. (make-PerformStatement (make-ExtendEnvironment/Prefix! names)) - + (make-AssignImmediateStatement (make-ModulePrefixTarget path) (make-EnvWholePrefixReference 0)) ;; TODO: we need to sequester the prefix of the module with the record. @@ -347,12 +341,12 @@ (cons (Module-prefix mod) module-cenv) 'val next-linkage/drop-multiple) - + ;; 3. Finally, cleanup and return. (make-PopEnvironment (make-Const 1) (make-Const 0)) (make-AssignImmediateStatement 'proc (make-ControlStackLabel)) (make-PopControlFrame) - + (make-PerformStatement (make-FinalizeModuleInvokation! path)) (make-GotoStatement (make-Reg 'proc)) @@ -362,9 +356,9 @@ (: compile-require (Require CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-require exp cenv target linkage) (end-with-linkage linkage cenv - (append-instruction-sequences - (compile-module-invoke (Require-path exp)) - (make-AssignImmediateStatement target (make-Const (void)))))) + (append-instruction-sequences + (compile-module-invoke (Require-path exp)) + (make-AssignImmediateStatement target (make-Const (void)))))) (: compile-module-invoke (ModuleLocator -> InstructionSequence)) @@ -492,13 +486,13 @@ (end-with-linkage linkage cenv (append-instruction-sequences - + (if (ToplevelRef-check-defined? exp) (make-PerformStatement (make-CheckToplevelBound! (ToplevelRef-depth exp) (ToplevelRef-pos exp))) empty-instruction-sequence) - + (make-AssignImmediateStatement target (make-EnvPrefixReference (ToplevelRef-depth exp) @@ -530,27 +524,27 @@ (let: ([t-branch : Symbol (make-label 'trueBranch)] [f-branch : Symbol (make-label 'falseBranch)] [after-if : Symbol (make-label 'afterIf)]) - (let ([consequent-linkage - (cond - [(NextLinkage? linkage) - (let ([context (NextLinkage-context linkage)]) - (make-LabelLinkage after-if context))] - [(ReturnLinkage? linkage) - linkage] - [(LabelLinkage? linkage) - linkage])]) - (let ([p-code (compile (Branch-predicate exp) cenv 'val next-linkage/expects-single)] - [c-code (compile (Branch-consequent exp) cenv target consequent-linkage)] - [a-code (compile (Branch-alternative exp) cenv target linkage)]) - (append-instruction-sequences - p-code - (make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) - f-branch) - t-branch - c-code - f-branch - a-code - after-if))))) + (let ([consequent-linkage + (cond + [(NextLinkage? linkage) + (let ([context (NextLinkage-context linkage)]) + (make-LabelLinkage after-if context))] + [(ReturnLinkage? linkage) + linkage] + [(LabelLinkage? linkage) + linkage])]) + (let ([p-code (compile (Branch-predicate exp) cenv 'val next-linkage/expects-single)] + [c-code (compile (Branch-consequent exp) cenv target consequent-linkage)] + [a-code (compile (Branch-alternative exp) cenv target linkage)]) + (append-instruction-sequences + p-code + (make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) + f-branch) + t-branch + c-code + f-branch + a-code + after-if))))) (: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) @@ -577,7 +571,7 @@ [(empty? (rest seq)) (let* ([on-return/multiple (make-label 'beforePromptPopMultiple)] [on-return (make-LinkedLabel (make-label 'beforePromptPop) - on-return/multiple)]) + on-return/multiple)]) (end-with-linkage linkage cenv @@ -592,7 +586,7 @@ [else (let* ([on-return/multiple (make-label 'beforePromptPopMultiple)] [on-return (make-LinkedLabel (make-label 'beforePromptPop) - on-return/multiple)]) + on-return/multiple)]) (append-instruction-sequences (make-PushControlFrame/Prompt (make-DefaultContinuationPromptTag) on-return) @@ -664,8 +658,8 @@ [(ReturnLinkage-tail? linkage) (append-instruction-sequences (make-PopEnvironment (make-Const (length cenv)) - (make-SubtractArg (make-Reg 'argcount) - (make-Const 1))) + (make-SubtractArg (make-Reg 'argcount) + (make-Const 1))) (make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) (make-PopControlFrame) (make-GotoStatement (make-Reg 'proc)))] @@ -680,8 +674,8 @@ [(LabelLinkage? linkage) (make-GotoStatement (make-Label (LabelLinkage-label linkage)))])))])) - - + + (: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence)) @@ -695,11 +689,11 @@ cenv (append-instruction-sequences (make-AssignPrimOpStatement - target - (make-MakeCompiledProcedure (Lam-entry-label exp) - (Lam-arity exp) - (Lam-closure-map exp) - (Lam-name exp))) + target + (make-MakeCompiledProcedure (Lam-entry-label exp) + (Lam-arity exp) + (Lam-closure-map exp) + (Lam-name exp))) singular-context-check)))) (: compile-empty-closure-reference (EmptyClosureReference CompileTimeEnvironment Target Linkage -> InstructionSequence)) @@ -716,7 +710,7 @@ empty (EmptyClosureReference-name exp))) singular-context-check)))) - + @@ -725,7 +719,7 @@ (define (compile-case-lambda exp cenv target linkage) (let ([singular-context-check (emit-singular-context linkage)] [n (length (CaseLam-clauses exp))]) - + ;; We have to build all the lambda values, and then create a single CaseLam that holds onto ;; all of them. (end-with-linkage @@ -741,23 +735,23 @@ (apply append-instruction-sequences (map (lambda: ([lam : (U Lam EmptyClosureReference)] [target : Target]) - (make-AssignPrimOpStatement - target - (cond - [(Lam? lam) - (make-MakeCompiledProcedure (Lam-entry-label lam) - (Lam-arity lam) - (shift-closure-map (Lam-closure-map lam) n) - (Lam-name lam))] - [(EmptyClosureReference? lam) - (make-MakeCompiledProcedure (EmptyClosureReference-entry-label lam) - (EmptyClosureReference-arity lam) - '() - (EmptyClosureReference-name lam))]))) + (make-AssignPrimOpStatement + target + (cond + [(Lam? lam) + (make-MakeCompiledProcedure (Lam-entry-label lam) + (Lam-arity lam) + (shift-closure-map (Lam-closure-map lam) n) + (Lam-name lam))] + [(EmptyClosureReference? lam) + (make-MakeCompiledProcedure (EmptyClosureReference-entry-label lam) + (EmptyClosureReference-arity lam) + '() + (EmptyClosureReference-name lam))]))) (CaseLam-clauses exp) (build-list (length (CaseLam-clauses exp)) (lambda: ([i : Natural]) - (make-EnvLexicalReference i #f))))) + (make-EnvLexicalReference i #f))))) ;; Make the case lambda as a regular compiled procedure. Its closed values are the lambdas. (make-AssignPrimOpStatement @@ -787,10 +781,10 @@ (: EmptyClosureReference-arity (EmptyClosureReference -> Arity)) (define (EmptyClosureReference-arity lam) -(if (EmptyClosureReference-rest? lam) + (if (EmptyClosureReference-rest? lam) (make-ArityAtLeast (EmptyClosureReference-num-parameters lam)) (EmptyClosureReference-num-parameters lam))) - + @@ -847,10 +841,10 @@ (let: ([maybe-unsplice-rest-argument : InstructionSequence (if (Lam-rest? exp) (make-PerformStatement - (make-UnspliceRestFromStack! - (make-Const (Lam-num-parameters exp)) - (make-SubtractArg (make-Reg 'argcount) - (make-Const (Lam-num-parameters exp))))) + (make-UnspliceRestFromStack! + (make-Const (Lam-num-parameters exp)) + (make-SubtractArg (make-Reg 'argcount) + (make-Const (Lam-num-parameters exp))))) empty-instruction-sequence)] [maybe-install-closure-values : InstructionSequence (if (not (empty? (Lam-closure-map exp))) @@ -863,12 +857,12 @@ (extract-lambda-cenv exp cenv) 'val return-linkage)]) - - (append-instruction-sequences - (Lam-entry-label exp) - maybe-unsplice-rest-argument - maybe-install-closure-values - lam-body-code))) + + (append-instruction-sequences + (Lam-entry-label exp) + maybe-unsplice-rest-argument + maybe-install-closure-values + lam-body-code))) (: compile-case-lambda-body (CaseLam CompileTimeEnvironment -> InstructionSequence)) @@ -880,26 +874,26 @@ (apply append-instruction-sequences (map (lambda: ([lam : (U Lam EmptyClosureReference)] [i : Natural]) - (let ([not-match (make-label 'notMatch)]) - (append-instruction-sequences - (make-TestAndJumpStatement (make-TestClosureArityMismatch - (make-CompiledProcedureClosureReference - (make-Reg 'proc) - i) - (make-Reg 'argcount)) - not-match) - ;; Set the procedure register to the lam - (make-AssignImmediateStatement - 'proc - (make-CompiledProcedureClosureReference (make-Reg 'proc) i)) - - (make-GotoStatement (make-Label - (cond [(Lam? lam) - (Lam-entry-label lam)] - [(EmptyClosureReference? lam) - (EmptyClosureReference-entry-label lam)]))) - - not-match))) + (let ([not-match (make-label 'notMatch)]) + (append-instruction-sequences + (make-TestAndJumpStatement (make-TestClosureArityMismatch + (make-CompiledProcedureClosureReference + (make-Reg 'proc) + i) + (make-Reg 'argcount)) + not-match) + ;; Set the procedure register to the lam + (make-AssignImmediateStatement + 'proc + (make-CompiledProcedureClosureReference (make-Reg 'proc) i)) + + (make-GotoStatement (make-Label + (cond [(Lam? lam) + (Lam-entry-label lam)] + [(EmptyClosureReference? lam) + (EmptyClosureReference-entry-label lam)]))) + + not-match))) (CaseLam-clauses exp) (build-list (length (CaseLam-clauses exp)) (lambda: ([i : Natural]) i)))))) @@ -913,23 +907,23 @@ [else (let: ([lam : (U Lam CaseLam) (lam+cenv-lam (first exps))] [cenv : CompileTimeEnvironment (lam+cenv-cenv (first exps))]) - (cond - [(Lam? lam) - (append-instruction-sequences (compile-lambda-body lam - cenv) - (compile-lambda-bodies (rest exps)))] - [(CaseLam? lam) - (append-instruction-sequences - (compile-case-lambda-body lam cenv) - (compile-lambda-bodies (rest exps)))]))])) - + (cond + [(Lam? lam) + (append-instruction-sequences (compile-lambda-body lam + cenv) + (compile-lambda-bodies (rest exps)))] + [(CaseLam? lam) + (append-instruction-sequences + (compile-case-lambda-body lam cenv) + (compile-lambda-bodies (rest exps)))]))])) + (: extend-compile-time-environment/scratch-space (CompileTimeEnvironment Natural -> CompileTimeEnvironment)) (define (extend-compile-time-environment/scratch-space cenv n) (append (build-list n (lambda: ([i : Natural]) - '?)) + '?)) cenv)) @@ -953,39 +947,39 @@ (let: ([op-knowledge : CompileTimeEnvironmentEntry (extract-static-knowledge (App-operator exp) extended-cenv)]) - (cond - [(eq? op-knowledge '?) - (default)] - [(PrimitiveKernelValue? op-knowledge) - (let ([id (PrimitiveKernelValue-id op-knowledge)]) - (cond - [(KernelPrimitiveName/Inline? id) - (compile-kernel-primitive-application id exp cenv target linkage)] - [else - (default)]))] - [(ModuleVariable? op-knowledge) - (cond - [(symbol=? (ModuleLocator-name - (ModuleVariable-module-name op-knowledge)) - '#%kernel) - (let ([op (ModuleVariable-name op-knowledge)]) - (cond [(KernelPrimitiveName/Inline? op) - (compile-kernel-primitive-application - op - exp cenv target linkage)] - [else - (default)]))] - [else - (default)])] - [(StaticallyKnownLam? op-knowledge) - (compile-statically-known-lam-application op-knowledge exp cenv target linkage)] - [(Prefix? op-knowledge) - (error 'impossible)] - [(Const? op-knowledge) - (append-instruction-sequences - (make-AssignImmediateStatement 'proc op-knowledge) - (make-PerformStatement - (make-RaiseOperatorApplicationError! (make-Reg 'proc))))])))) + (cond + [(eq? op-knowledge '?) + (default)] + [(PrimitiveKernelValue? op-knowledge) + (let ([id (PrimitiveKernelValue-id op-knowledge)]) + (cond + [(KernelPrimitiveName/Inline? id) + (compile-kernel-primitive-application id exp cenv target linkage)] + [else + (default)]))] + [(ModuleVariable? op-knowledge) + (cond + [(symbol=? (ModuleLocator-name + (ModuleVariable-module-name op-knowledge)) + '#%kernel) + (let ([op (ModuleVariable-name op-knowledge)]) + (cond [(KernelPrimitiveName/Inline? op) + (compile-kernel-primitive-application + op + exp cenv target linkage)] + [else + (default)]))] + [else + (default)])] + [(StaticallyKnownLam? op-knowledge) + (compile-statically-known-lam-application op-knowledge exp cenv target linkage)] + [(Prefix? op-knowledge) + (error 'impossible)] + [(Const? op-knowledge) + (append-instruction-sequences + (make-AssignImmediateStatement 'proc op-knowledge) + (make-PerformStatement + (make-RaiseOperatorApplicationError! (make-Reg 'proc))))])))) (: compile-general-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) @@ -1004,16 +998,16 @@ next-linkage/expects-single)] [operand-codes (map (lambda: ([operand : Expression] [target : Target]) - (compile operand - extended-cenv - target - next-linkage/expects-single)) + (compile operand + extended-cenv + target + next-linkage/expects-single)) (App-operands exp) (build-list (length (App-operands exp)) (lambda: ([i : Natural]) - (if (< i (sub1 (length (App-operands exp)))) - (make-EnvLexicalReference i #f) - 'val))))]) + (if (< i (sub1 (length (App-operands exp)))) + (make-EnvLexicalReference i #f) + 'val))))]) (append-instruction-sequences (make-Comment "scratch space for general application") @@ -1053,16 +1047,16 @@ [operand-knowledge (map (lambda: ([arg : Expression]) - (extract-static-knowledge - arg - (extend-compile-time-environment/scratch-space - cenv n))) + (extract-static-knowledge + arg + (extend-compile-time-environment/scratch-space + cenv n))) (App-operands exp))] [typechecks? (map (lambda: ([dom : OperandDomain] [known : CompileTimeEnvironmentEntry]) - (not (redundant-check? dom known))) + (not (redundant-check? dom known))) (kernel-primitive-expected-operand-types kernel-op n) operand-knowledge)] @@ -1070,7 +1064,7 @@ (kernel-primitive-expected-operand-types kernel-op n)] [operand-poss (simple-operands->opargs (map (lambda: ([op : Expression]) - (adjust-expression-depth op n n)) + (adjust-expression-depth op n n)) (App-operands exp)))]) (end-with-linkage linkage cenv @@ -1103,30 +1097,30 @@ (length rest-operands)) (map (lambda: ([constant-operand : Expression]) - (ensure-simple-expression - (adjust-expression-depth constant-operand - (length constant-operands) - n))) + (ensure-simple-expression + (adjust-expression-depth constant-operand + (length constant-operands) + n))) constant-operands) (map (lambda: ([rest-operand : Expression]) - (adjust-expression-depth rest-operand - (length constant-operands) - n)) + (adjust-expression-depth rest-operand + (length constant-operands) + n)) rest-operands))] [(operand-knowledge) (append (map (lambda: ([arg : Expression]) - (extract-static-knowledge arg extended-cenv)) + (extract-static-knowledge arg extended-cenv)) constant-operands) (map (lambda: ([arg : Expression]) - (extract-static-knowledge arg extended-cenv)) + (extract-static-knowledge arg extended-cenv)) rest-operands))] [(typechecks?) (map (lambda: ([dom : OperandDomain] [known : CompileTimeEnvironmentEntry]) - (not (redundant-check? dom known))) + (not (redundant-check? dom known))) (kernel-primitive-expected-operand-types kernel-op n) operand-knowledge)] @@ -1143,15 +1137,15 @@ [(rest-operand-poss) (build-list (length rest-operands) (lambda: ([i : Natural]) - (make-EnvLexicalReference i #f)))] + (make-EnvLexicalReference i #f)))] [(rest-operand-code) (apply append-instruction-sequences (map (lambda: ([operand : Expression] [target : Target]) - (compile operand - extended-cenv - target - next-linkage/expects-single)) + (compile operand + extended-cenv + target + next-linkage/expects-single)) rest-operands rest-operand-poss))]) @@ -1185,17 +1179,17 @@ ;; Produces a list of OpArgs if all the operands are particularly simple, and false therwise. (define (simple-operands->opargs rands) (map (lambda: ([e : Expression]) - (cond - [(Constant? e) - (make-Const (Constant-v e))] - [(LocalRef? e) - (make-EnvLexicalReference (LocalRef-depth e) - (LocalRef-unbox? e))] - [(ToplevelRef? e) - (make-EnvPrefixReference (ToplevelRef-depth e) - (ToplevelRef-pos e))] - [else - (error 'all-operands-are-constant "Impossible")])) + (cond + [(Constant? e) + (make-Const (Constant-v e))] + [(LocalRef? e) + (make-EnvLexicalReference (LocalRef-depth e) + (LocalRef-unbox? e))] + [(ToplevelRef? e) + (make-EnvPrefixReference (ToplevelRef-depth e) + (ToplevelRef-pos e))] + [else + (error 'all-operands-are-constant "Impossible")])) rands)) @@ -1233,23 +1227,23 @@ ;; side effects, we can do a much better job here... (define (split-operands-by-constants rands) (let: loop : (values (Listof (U Constant LocalRef ToplevelRef)) (Listof Expression)) - ([rands : (Listof Expression) rands] - [constants : (Listof (U Constant LocalRef ToplevelRef)) - empty]) - (cond [(empty? rands) - (values (reverse constants) empty)] - [else (let ([e (first rands)]) - (if (or (Constant? e) - - ;; These two are commented out because it's not sound otherwise. - #;(and (LocalRef? e) (not (LocalRef-unbox? e))) - #;(and (ToplevelRef? e) - (let ([prefix (ensure-prefix - (list-ref cenv (ToplevelRef-depth e)))]) - (ModuleVariable? - (list-ref prefix (ToplevelRef-pos e)))))) - (loop (rest rands) (cons e constants)) - (values (reverse constants) rands)))]))) + ([rands : (Listof Expression) rands] + [constants : (Listof (U Constant LocalRef ToplevelRef)) + empty]) + (cond [(empty? rands) + (values (reverse constants) empty)] + [else (let ([e (first rands)]) + (if (or (Constant? e) + + ;; These two are commented out because it's not sound otherwise. + #;(and (LocalRef? e) (not (LocalRef-unbox? e))) + #;(and (ToplevelRef? e) + (let ([prefix (ensure-prefix + (list-ref cenv (ToplevelRef-depth e)))]) + (ModuleVariable? + (list-ref prefix (ToplevelRef-pos e)))))) + (loop (rest rands) (cons e constants)) + (values (reverse constants) rands)))]))) (define-predicate natural? Natural) @@ -1264,11 +1258,11 @@ (>= n (ArityAtLeast-value an-arity))] [(atomic-arity-list? an-arity) (ormap (lambda: ([an-arity : (U Natural ArityAtLeast)]) - (cond - [(natural? an-arity) - (= an-arity n)] - [(ArityAtLeast? an-arity) - (>= n (ArityAtLeast-value an-arity))])) + (cond + [(natural? an-arity) + (= an-arity n)] + [(ArityAtLeast? an-arity) + (>= n (ArityAtLeast-value an-arity))])) an-arity)])) @@ -1301,16 +1295,16 @@ next-linkage/expects-single)] [operand-codes (map (lambda: ([operand : Expression] [target : Target]) - (compile operand - extended-cenv - target - next-linkage/expects-single)) + (compile operand + extended-cenv + target + next-linkage/expects-single)) (App-operands exp) (build-list (length (App-operands exp)) (lambda: ([i : Natural]) - (if (< i (sub1 (length (App-operands exp)))) - (make-EnvLexicalReference i #f) - 'val))))]) + (if (< i (sub1 (length (App-operands exp)))) + (make-EnvLexicalReference i #f) + 'val))))]) (append-instruction-sequences (make-Comment "scratch space for statically known lambda application") (make-PushEnvironment (length (App-operands exp)) #f) @@ -1330,25 +1324,25 @@ ;; the procedure lives in 'proc, and the operands on the environment stack. (define (juggle-operands operand-codes) (let: loop : InstructionSequence ([ops : (Listof InstructionSequence) operand-codes]) - (cond - ;; If there are no operands, no need to juggle. - [(null? ops) - empty-instruction-sequence] - [(null? (rest ops)) - (let: ([n : Natural (ensure-natural (sub1 (length operand-codes)))]) - ;; The last operand needs to be handled specially: it currently lives in - ;; val. We move the procedure at env[n] over to proc, and move the - ;; last operand at 'val into env[n]. - (append-instruction-sequences - (car ops) - (make-AssignImmediateStatement 'proc - (make-EnvLexicalReference n #f)) - (make-AssignImmediateStatement (make-EnvLexicalReference n #f) - (make-Reg 'val))))] - [else - ;; Otherwise, add instructions to juggle the operator and operands in the stack. - (append-instruction-sequences (car ops) - (loop (rest ops)))]))) + (cond + ;; If there are no operands, no need to juggle. + [(null? ops) + empty-instruction-sequence] + [(null? (rest ops)) + (let: ([n : Natural (ensure-natural (sub1 (length operand-codes)))]) + ;; The last operand needs to be handled specially: it currently lives in + ;; val. We move the procedure at env[n] over to proc, and move the + ;; last operand at 'val into env[n]. + (append-instruction-sequences + (car ops) + (make-AssignImmediateStatement 'proc + (make-EnvLexicalReference n #f)) + (make-AssignImmediateStatement (make-EnvLexicalReference n #f) + (make-Reg 'val))))] + [else + ;; Otherwise, add instructions to juggle the operator and operands in the stack. + (append-instruction-sequences (car ops) + (loop (rest ops)))]))) (: linkage-context (Linkage -> ValuesContext)) @@ -1381,38 +1375,38 @@ (let: ([primitive-branch : Symbol (make-label 'primitiveBranch)] [compiled-branch : Symbol (make-label 'compiledBranch)] [after-call : Symbol (make-label 'afterCall)]) - (let: ([compiled-linkage : Linkage (if (and (ReturnLinkage? linkage) - (ReturnLinkage-tail? linkage)) - linkage - (make-LabelLinkage after-call - (linkage-context linkage)))] - [primitive-linkage : Linkage - (make-NextLinkage (linkage-context linkage))]) - (append-instruction-sequences - (make-TestAndJumpStatement (make-TestPrimitiveProcedure - (make-Reg 'proc)) - primitive-branch) - - - ;; Compiled branch - compiled-branch - (make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount))) - (compile-compiled-procedure-application cenv - number-of-arguments - 'dynamic - target - compiled-linkage) - - ;; Primitive branch - primitive-branch - (end-with-linkage - linkage - cenv - (append-instruction-sequences - (make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount))) - (compile-primitive-application cenv target primitive-linkage) - - after-call)))))) + (let: ([compiled-linkage : Linkage (if (and (ReturnLinkage? linkage) + (ReturnLinkage-tail? linkage)) + linkage + (make-LabelLinkage after-call + (linkage-context linkage)))] + [primitive-linkage : Linkage + (make-NextLinkage (linkage-context linkage))]) + (append-instruction-sequences + (make-TestAndJumpStatement (make-TestPrimitiveProcedure + (make-Reg 'proc)) + primitive-branch) + + + ;; Compiled branch + compiled-branch + (make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount))) + (compile-compiled-procedure-application cenv + number-of-arguments + 'dynamic + target + compiled-linkage) + + ;; Primitive branch + primitive-branch + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount))) + (compile-primitive-application cenv target primitive-linkage) + + after-call)))))) @@ -1440,19 +1434,19 @@ (make-LabelLinkage after-call (linkage-context linkage)))]) - (append-instruction-sequences - (make-AssignImmediateStatement 'argcount - (make-Const n)) - (compile-compiled-procedure-application cenv - (make-Const n) - (make-Label - (StaticallyKnownLam-entry-point static-knowledge)) - target - compiled-linkage) - (end-with-linkage - linkage - cenv - after-call)))) + (append-instruction-sequences + (make-AssignImmediateStatement 'argcount + (make-Const n)) + (compile-compiled-procedure-application cenv + (make-Const n) + (make-Label + (StaticallyKnownLam-entry-point static-knowledge)) + target + compiled-linkage) + (end-with-linkage + linkage + cenv + after-call)))) @@ -1490,7 +1484,7 @@ [on-return/multiple (make-label 'procReturnMultiple)] [on-return (make-LinkedLabel (make-label 'procReturn) - on-return/multiple)] + on-return/multiple)] ;; This code does the initial jump into the procedure. Clients of this code ;; are expected to generate the proc-return-multiple and proc-return code afterwards. @@ -1509,7 +1503,7 @@ ;; to the control stack. (let ([reuse-the-stack (make-PopEnvironment (make-Const (length cenv)) - number-of-arguments)]) + number-of-arguments)]) (append-instruction-sequences reuse-the-stack ;; Assign the proc value of the existing call frame. @@ -1523,8 +1517,8 @@ nontail-jump-into-procedure on-return/multiple (make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) - (make-Const 1)) - (make-Const 0)) + (make-Const 1)) + (make-Const 0)) on-return)])] [else @@ -1541,7 +1535,7 @@ (if (LabelLinkage? linkage) (make-GotoStatement (make-Label (LabelLinkage-label linkage))) empty-instruction-sequence)]) - + (append-instruction-sequences nontail-jump-into-procedure check-values-context-on-procedure-return @@ -1563,7 +1557,7 @@ (append-instruction-sequences on-return/multiple (make-PopEnvironment (SubtractArg (make-Reg 'argcount) (make-Const 1)) - (make-Const 0)) + (make-Const 0)) on-return)] [(eq? context 'keep-multiple) @@ -1581,7 +1575,7 @@ (append-instruction-sequences on-return/multiple (make-PerformStatement - (make-RaiseContextExpectedValuesError! 1)) + (make-RaiseContextExpectedValuesError! 1)) on-return)] [else (let ([after-value-check (make-label 'afterValueCheck)]) @@ -1593,7 +1587,7 @@ after-value-check) on-return (make-PerformStatement - (make-RaiseContextExpectedValuesError! context)) + (make-RaiseContextExpectedValuesError! context)) after-value-check))])])) @@ -1627,19 +1621,19 @@ (let: ([name : (U Symbol False GlobalBucket ModuleVariable) (list-ref (Prefix-names (ensure-prefix (list-ref cenv (ToplevelRef-depth exp)))) (ToplevelRef-pos exp))]) - (cond - [(ModuleVariable? name) - (log-debug (format "toplevel reference is to ~s" name)) - name] - [(GlobalBucket? name) - '?] - [else - (log-debug (format "nothing statically known about ~s" exp)) - '?]))] + (cond + [(ModuleVariable? name) + (log-debug (format "toplevel reference is to ~s" name)) + name] + [(GlobalBucket? name) + '?] + [else + (log-debug (format "nothing statically known about ~s" exp)) + '?]))] [(Constant? exp) (make-Const (Constant-v exp))] - + [(PrimitiveKernelValue? exp) exp] @@ -1676,17 +1670,17 @@ [body-target : Target (adjust-target-depth target 1)] [body-code : InstructionSequence (compile (Let1-body exp) extended-cenv body-target let-linkage)]) - (end-with-linkage - linkage - extended-cenv - (append-instruction-sequences - (make-Comment "scratch space for let1") - (make-PushEnvironment 1 #f) - rhs-code - body-code - after-body-code - (make-PopEnvironment (make-Const 1) (make-Const 0)) - after-let1)))) + (end-with-linkage + linkage + extended-cenv + (append-instruction-sequences + (make-Comment "scratch space for let1") + (make-PushEnvironment 1 #f) + rhs-code + body-code + after-body-code + (make-PopEnvironment (make-Const 1) (make-Const 0)) + after-let1)))) @@ -1718,49 +1712,49 @@ [body-target : Target (adjust-target-depth target n)] [body-code : InstructionSequence (compile (LetVoid-body exp) extended-cenv body-target let-linkage)]) - (end-with-linkage - linkage - extended-cenv - (append-instruction-sequences - (make-Comment "scratch space for let-void") - (make-PushEnvironment n (LetVoid-boxes? exp)) - body-code - after-body-code - - ;; We want to clear out the scratch space introduced by the - ;; let-void. However, there may be multiple values coming - ;; back at this point, from the evaluation of the body. We - ;; look at the context and route around those values - ;; appropriate. - (cond - [(eq? context 'tail) - empty-instruction-sequence] - [(eq? context 'drop-multiple) - (make-PopEnvironment (make-Const n) - (make-Const 0))] - [(eq? context 'keep-multiple) - ;; dynamic number of arguments that need - ;; to be preserved - (make-PopEnvironment (make-Const n) - (make-SubtractArg - (make-Reg 'argcount) - (make-Const 1)))] - [else - (cond [(= context 0) - (make-PopEnvironment (make-Const n) - (make-Const 0))] - [(= context 1) - (make-PopEnvironment (make-Const n) - (make-Const 0))] - [else - - ;; n-1 values on stack that we need to route - ;; around - (make-PopEnvironment (make-Const n) - (make-SubtractArg - (make-Const context) - (make-Const 1)))])]) - after-let)))) + (end-with-linkage + linkage + extended-cenv + (append-instruction-sequences + (make-Comment "scratch space for let-void") + (make-PushEnvironment n (LetVoid-boxes? exp)) + body-code + after-body-code + + ;; We want to clear out the scratch space introduced by the + ;; let-void. However, there may be multiple values coming + ;; back at this point, from the evaluation of the body. We + ;; look at the context and route around those values + ;; appropriate. + (cond + [(eq? context 'tail) + empty-instruction-sequence] + [(eq? context 'drop-multiple) + (make-PopEnvironment (make-Const n) + (make-Const 0))] + [(eq? context 'keep-multiple) + ;; dynamic number of arguments that need + ;; to be preserved + (make-PopEnvironment (make-Const n) + (make-SubtractArg + (make-Reg 'argcount) + (make-Const 1)))] + [else + (cond [(= context 0) + (make-PopEnvironment (make-Const n) + (make-Const 0))] + [(= context 1) + (make-PopEnvironment (make-Const n) + (make-Const 0))] + [else + + ;; n-1 values on stack that we need to route + ;; around + (make-PopEnvironment (make-Const n) + (make-SubtractArg + (make-Const context) + (make-Const 1)))])]) + after-let)))) @@ -1771,12 +1765,12 @@ (let*: ([n : Natural (length (LetRec-procs exp))] [extended-cenv : CompileTimeEnvironment (append (map (lambda: ([p : Lam]) - (extract-static-knowledge - p - (append (build-list (length (LetRec-procs exp)) - (lambda: ([i : Natural]) - '?)) - (drop cenv n)))) + (extract-static-knowledge + p + (append (build-list (length (LetRec-procs exp)) + (lambda: ([i : Natural]) + '?)) + (drop cenv n)))) (LetRec-procs exp)) (drop cenv n))] [n : Natural (length (LetRec-procs exp))] @@ -1794,37 +1788,37 @@ [(LabelLinkage? linkage) (make-LabelLinkage after-body-code (LabelLinkage-context linkage))])]) - (end-with-linkage - linkage - extended-cenv - (append-instruction-sequences - - ;; Install each of the closure shells. - (apply append-instruction-sequences - (map (lambda: ([lam : Lam] - [i : Natural]) - (compile-lambda-shell lam - extended-cenv - (make-EnvLexicalReference i #f) - next-linkage/expects-single)) - (LetRec-procs exp) - (build-list n (lambda: ([i : Natural]) i)))) - - ;; Fix the closure maps of each - (apply append-instruction-sequences - (map (lambda: ([lam : Lam] - [i : Natural]) - (append-instruction-sequences - (make-Comment (format "Installing shell for ~s\n" (Lam-name lam))) - (make-PerformStatement (make-FixClosureShellMap! i - (Lam-closure-map lam))))) - (LetRec-procs exp) - (build-list n (lambda: ([i : Natural]) i)))) - - ;; Compile the body - (compile (LetRec-body exp) extended-cenv target letrec-linkage) - - after-body-code)))) + (end-with-linkage + linkage + extended-cenv + (append-instruction-sequences + + ;; Install each of the closure shells. + (apply append-instruction-sequences + (map (lambda: ([lam : Lam] + [i : Natural]) + (compile-lambda-shell lam + extended-cenv + (make-EnvLexicalReference i #f) + next-linkage/expects-single)) + (LetRec-procs exp) + (build-list n (lambda: ([i : Natural]) i)))) + + ;; Fix the closure maps of each + (apply append-instruction-sequences + (map (lambda: ([lam : Lam] + [i : Natural]) + (append-instruction-sequences + (make-Comment (format "Installing shell for ~s\n" (Lam-name lam))) + (make-PerformStatement (make-FixClosureShellMap! i + (Lam-closure-map lam))))) + (LetRec-procs exp) + (build-list n (lambda: ([i : Natural]) i)))) + + ;; Compile the body + (compile (LetRec-body exp) extended-cenv target letrec-linkage) + + after-body-code)))) @@ -1834,49 +1828,49 @@ (make-Comment "install-value") (let ([count (InstallValue-count exp)]) (cond [(= count 0) - (end-with-linkage - linkage - cenv - (compile (InstallValue-body exp) - cenv - target - (make-NextLinkage 0)))] - [(= count 1) - (append-instruction-sequences - (make-Comment (format "installing single value into ~s" - (InstallValue-depth exp))) - (end-with-linkage - linkage - cenv - (compile (InstallValue-body exp) - cenv - (make-EnvLexicalReference (InstallValue-depth exp) (InstallValue-box? exp)) - (make-NextLinkage 1))))] - [else - (end-with-linkage - linkage - cenv - (append-instruction-sequences - (make-Comment "install-value: evaluating values") - (compile (InstallValue-body exp) - cenv - 'val - (make-NextLinkage count)) - (apply append-instruction-sequences - (map (lambda: ([to : EnvLexicalReference] - [from : OpArg]) - (append-instruction-sequences - (make-Comment "install-value: installing value") - (make-AssignImmediateStatement to from))) - (build-list count (lambda: ([i : Natural]) - (make-EnvLexicalReference (+ i - (InstallValue-depth exp) - (sub1 count)) - (InstallValue-box? exp)))) - (cons (make-Reg 'val) - (build-list (sub1 count) (lambda: ([i : Natural]) - (make-EnvLexicalReference i #f)))))) - (make-PopEnvironment (make-Const (sub1 count)) (make-Const 0))))])))) + (end-with-linkage + linkage + cenv + (compile (InstallValue-body exp) + cenv + target + (make-NextLinkage 0)))] + [(= count 1) + (append-instruction-sequences + (make-Comment (format "installing single value into ~s" + (InstallValue-depth exp))) + (end-with-linkage + linkage + cenv + (compile (InstallValue-body exp) + cenv + (make-EnvLexicalReference (InstallValue-depth exp) (InstallValue-box? exp)) + (make-NextLinkage 1))))] + [else + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (make-Comment "install-value: evaluating values") + (compile (InstallValue-body exp) + cenv + 'val + (make-NextLinkage count)) + (apply append-instruction-sequences + (map (lambda: ([to : EnvLexicalReference] + [from : OpArg]) + (append-instruction-sequences + (make-Comment "install-value: installing value") + (make-AssignImmediateStatement to from))) + (build-list count (lambda: ([i : Natural]) + (make-EnvLexicalReference (+ i + (InstallValue-depth exp) + (sub1 count)) + (InstallValue-box? exp)))) + (cons (make-Reg 'val) + (build-list (sub1 count) (lambda: ([i : Natural]) + (make-EnvLexicalReference i #f)))))) + (make-PopEnvironment (make-Const (sub1 count)) (make-Const 0))))])))) @@ -1884,7 +1878,7 @@ (define (compile-box-environment-value exp cenv target linkage) (append-instruction-sequences (make-AssignPrimOpStatement (make-EnvLexicalReference (BoxEnv-depth exp) #f) - (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp))) + (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp))) (compile (BoxEnv-body exp) cenv target linkage))) @@ -1898,8 +1892,8 @@ (append-instruction-sequences (compile (WithContMark-key exp) cenv 'val next-linkage/expects-single) (make-AssignImmediateStatement - (make-ControlFrameTemporary 'pendingContinuationMarkKey) - (make-Reg 'val)) + (make-ControlFrameTemporary 'pendingContinuationMarkKey) + (make-Reg 'val)) (compile (WithContMark-value exp) cenv 'val next-linkage/expects-single) (make-PerformStatement (make-InstallContinuationMarkEntry!)) (compile (WithContMark-body exp) cenv target linkage))) @@ -1957,20 +1951,20 @@ next-linkage/keep-multiple-on-stack) (make-TestAndJumpStatement (make-TestZero (make-Reg 'argcount)) after-args-evaluated) - ;; In the common case where we do get values back, we push val onto the stack too, - ;; so that we have n values on the stack before we jump to the procedure call. + ;; In the common case where we do get values back, we push val onto the stack too, + ;; so that we have n values on the stack before we jump to the procedure call. (make-PushImmediateOntoEnvironment (make-Reg 'val) #f) - + after-args-evaluated ;; Retrieve the procedure off the temporary control frame. (make-AssignImmediateStatement - 'proc - (make-ControlFrameTemporary 'pendingApplyValuesProc)) + 'proc + (make-ControlFrameTemporary 'pendingApplyValuesProc)) ;; Pop off the temporary control frame (make-PopControlFrame) - + ;; Finally, do the generic call into the consumer function. ;; FIXME: we have more static knowledge here of what the operator is. ;; We can make this faster. @@ -1982,42 +1976,42 @@ (let* ([ids (DefValues-ids exp)] [rhs (DefValues-rhs exp)] [n (length ids)]) - ;; First, compile the body, which will produce right side values. + ;; First, compile the body, which will produce right side values. (end-with-linkage linkage cenv (append-instruction-sequences (compile rhs cenv 'val (make-NextLinkage (length ids))) - + ;; Now install each of the values in place. The first value's in val, and the rest of the ;; values are on the stack. (if (> n 0) (apply append-instruction-sequences - (map (lambda: ([id : ToplevelRef] - [from : OpArg]) - (make-AssignImmediateStatement - ;; Slightly subtle: the toplevelrefs were with respect to the - ;; stack at the beginning of def-values, but at the moment, - ;; there may be additional values that are currently there. - (make-EnvPrefixReference (+ (ensure-natural (sub1 n)) - (ToplevelRef-depth id)) - (ToplevelRef-pos id)) - from)) - ids - (if (> n 0) - (cons (make-Reg 'val) - (build-list (sub1 n) - (lambda: ([i : Natural]) - (make-EnvLexicalReference i #f)))) - empty))) + (map (lambda: ([id : ToplevelRef] + [from : OpArg]) + (make-AssignImmediateStatement + ;; Slightly subtle: the toplevelrefs were with respect to the + ;; stack at the beginning of def-values, but at the moment, + ;; there may be additional values that are currently there. + (make-EnvPrefixReference (+ (ensure-natural (sub1 n)) + (ToplevelRef-depth id)) + (ToplevelRef-pos id)) + from)) + ids + (if (> n 0) + (cons (make-Reg 'val) + (build-list (sub1 n) + (lambda: ([i : Natural]) + (make-EnvLexicalReference i #f)))) + empty))) empty-instruction-sequence) - + ;; Finally, make sure any multiple values are off the stack. (if (> (length ids) 1) (make-PopEnvironment (make-Const (sub1 (length ids))) - (make-Const 0)) + (make-Const 0)) empty-instruction-sequence))))) - + (: compile-primitive-kernel-value (PrimitiveKernelValue CompileTimeEnvironment Target Linkage -> InstructionSequence)) @@ -2037,7 +2031,7 @@ (unless (set-contains? (current-seen-unimplemented-kernel-primitives) id) (set-insert! (current-seen-unimplemented-kernel-primitives) - id) + id) ((current-warn-unimplemented-kernel-primitive) id)) (make-PerformStatement (make-RaiseUnimplementedPrimitiveError! id))]))) @@ -2168,20 +2162,20 @@ (Lam-rest? exp) (Lam-body exp) (map (lambda: ([d : Natural]) - (if (< d skip) - d - (ensure-natural (- d n)))) + (if (< d skip) + d + (ensure-natural (- d n)))) (Lam-closure-map exp)) (Lam-entry-label exp))] [(CaseLam? exp) (make-CaseLam (CaseLam-name exp) (map (lambda: ([lam : (U Lam EmptyClosureReference)]) - (cond - [(Lam? lam) - (ensure-lam (adjust-expression-depth lam n skip))] - [(EmptyClosureReference? lam) - lam])) + (cond + [(Lam? lam) + (ensure-lam (adjust-expression-depth lam n skip))] + [(EmptyClosureReference? lam) + lam])) (CaseLam-clauses exp)) (CaseLam-entry-label exp))] @@ -2190,25 +2184,25 @@ [(Seq? exp) (make-Seq (map (lambda: ([action : Expression]) - (adjust-expression-depth action n skip)) + (adjust-expression-depth action n skip)) (Seq-actions exp)))] [(Splice? exp) (make-Splice (map (lambda: ([action : Expression]) - (adjust-expression-depth action n skip)) + (adjust-expression-depth action n skip)) (Splice-actions exp)))] - + [(Begin0? exp) (make-Begin0 (map (lambda: ([action : Expression]) - (adjust-expression-depth action n skip)) + (adjust-expression-depth action n skip)) (Begin0-actions exp)))] [(App? exp) (make-App (adjust-expression-depth (App-operator exp) n (+ skip (length (App-operands exp)))) (map (lambda: ([operand : Expression]) - (adjust-expression-depth - operand n (+ skip (length (App-operands exp))))) + (adjust-expression-depth + operand n (+ skip (length (App-operands exp))))) (App-operands exp)))] [(Let1? exp) @@ -2224,15 +2218,15 @@ [(LetRec? exp) (make-LetRec (let: loop : (Listof Lam) ([procs : (Listof Lam) (LetRec-procs exp)]) - (cond - [(empty? procs) - '()] - [else - (cons (ensure-lam (adjust-expression-depth - (first procs) - n - skip)) - (loop (rest procs)))])) + (cond + [(empty? procs) + '()] + [else + (cons (ensure-lam (adjust-expression-depth + (first procs) + n + skip)) + (loop (rest procs)))])) (adjust-expression-depth (LetRec-body exp) n skip))] @@ -2265,17 +2259,17 @@ [(ApplyValues? exp) (make-ApplyValues (adjust-expression-depth (ApplyValues-proc exp) n skip) (adjust-expression-depth (ApplyValues-args-expr exp) n skip))] - + [(DefValues? exp) (make-DefValues (map (lambda: ([id : ToplevelRef]) - (ensure-toplevelref - (adjust-expression-depth id n skip))) + (ensure-toplevelref + (adjust-expression-depth id n skip))) (DefValues-ids exp)) (adjust-expression-depth (DefValues-rhs exp) n skip))] [(PrimitiveKernelValue? exp) exp] - + [(VariableReference? exp) (make-VariableReference (ensure-toplevelref From 3c06d9a38d4cd87459df621fe1d128f7800009ff Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 7 Aug 2011 17:44:54 -0400 Subject: [PATCH 08/30] trying to rearrange code to be cleaner --- compiler/compiler.rkt | 52 +++++++++++++++++++------------------------ 1 file changed, 23 insertions(+), 29 deletions(-) diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index d63d391..8f25205 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -521,8 +521,7 @@ (: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Compiles a conditional branch. (define (compile-branch exp cenv target linkage) - (let: ([t-branch : Symbol (make-label 'trueBranch)] - [f-branch : Symbol (make-label 'falseBranch)] + (let: ([f-branch : Symbol (make-label 'falseBranch)] [after-if : Symbol (make-label 'afterIf)]) (let ([consequent-linkage (cond @@ -540,7 +539,6 @@ p-code (make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) f-branch) - t-branch c-code f-branch a-code @@ -1373,7 +1371,6 @@ ;; extended-cenv is the compile-time environment after arguments have been shifted in. (define (compile-general-procedure-call cenv number-of-arguments target linkage) (let: ([primitive-branch : Symbol (make-label 'primitiveBranch)] - [compiled-branch : Symbol (make-label 'compiledBranch)] [after-call : Symbol (make-label 'afterCall)]) (let: ([compiled-linkage : Linkage (if (and (ReturnLinkage? linkage) (ReturnLinkage-tail? linkage)) @@ -1382,31 +1379,28 @@ (linkage-context linkage)))] [primitive-linkage : Linkage (make-NextLinkage (linkage-context linkage))]) - (append-instruction-sequences - (make-TestAndJumpStatement (make-TestPrimitiveProcedure - (make-Reg 'proc)) - primitive-branch) - - - ;; Compiled branch - compiled-branch - (make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount))) - (compile-compiled-procedure-application cenv - number-of-arguments - 'dynamic - target - compiled-linkage) - - ;; Primitive branch - primitive-branch - (end-with-linkage - linkage - cenv - (append-instruction-sequences - (make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount))) - (compile-primitive-application cenv target primitive-linkage) - - after-call)))))) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (make-TestAndJumpStatement (make-TestPrimitiveProcedure + (make-Reg 'proc)) + primitive-branch) + + + ;; Compiled branch + (make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount))) + (compile-compiled-procedure-application cenv + number-of-arguments + 'dynamic + target + compiled-linkage) + + ;; Primitive branch + primitive-branch + (make-PerformStatement (make-CheckPrimitiveArity! (make-Reg 'argcount))) + (compile-primitive-application cenv target primitive-linkage) + after-call))))) From 193c526e04dc62d1e619d65cd1bd7d58ffeee91a Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 7 Aug 2011 17:56:38 -0400 Subject: [PATCH 09/30] removing more superfluous labels --- compiler/compiler.rkt | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index 8f25205..de9d8ac 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -371,7 +371,6 @@ empty-instruction-sequence] [else (let* ([linked (make-label 'linked)] - [already-loaded (make-label 'alreadyLoaded)] [on-return-multiple (make-label 'onReturnMultiple)] [on-return (make-LinkedLabel (make-label 'onReturn) on-return-multiple)]) @@ -384,19 +383,18 @@ (make-DebugPrint (make-Const (format "DEBUG: the module ~a hasn't been linked in!!!" (ModuleLocator-name a-module-name)))) - (make-GotoStatement (make-Label already-loaded)) + (make-GotoStatement (make-Label (LinkedLabel-label on-return))) linked (make-TestAndJumpStatement (make-TestTrue (make-IsModuleInvoked a-module-name)) - already-loaded) + (LinkedLabel-label on-return)) (make-PushControlFrame/Call on-return) (make-GotoStatement (ModuleEntry a-module-name)) on-return-multiple (make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) (make-Const 1)) (make-Const 0)) - on-return - already-loaded))])) + on-return))])) (: kernel-module-name? (ModuleLocator -> Boolean)) @@ -599,7 +597,6 @@ (: compile-begin0 ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) -;; FIXME: this is broken at the moment. (define (compile-begin0 seq cenv target linkage) (cond [(empty? seq) @@ -1645,7 +1642,6 @@ (cons '? cenv) (make-EnvLexicalReference 0 #f) next-linkage/expects-single)] - [after-let1 : Symbol (make-label 'afterLetOne)] [after-body-code : Symbol (make-label 'afterLetBody)] [extended-cenv : CompileTimeEnvironment (cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv)) @@ -1673,8 +1669,7 @@ rhs-code body-code after-body-code - (make-PopEnvironment (make-Const 1) (make-Const 0)) - after-let1)))) + (make-PopEnvironment (make-Const 1) (make-Const 0)))))) From 5122f4488571789ff1476e67b011bd7a7e49b25f Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 7 Aug 2011 18:24:16 -0400 Subject: [PATCH 10/30] collapsing a few lines --- js-assembler/runtime-src/baselib-functions.js | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/js-assembler/runtime-src/baselib-functions.js b/js-assembler/runtime-src/baselib-functions.js index 292182c..8f5bac1 100644 --- a/js-assembler/runtime-src/baselib-functions.js +++ b/js-assembler/runtime-src/baselib-functions.js @@ -245,22 +245,18 @@ // extra function call here. var finalizeClosureCall = function(MACHINE) { MACHINE.callsBeforeTrampoline--; - var frame, i, returnArgs = [].slice.call(arguments, 1); + var i, returnArgs = [].slice.call(arguments, 1); // clear out stack space // TODO: replace with a splice. - for(i = 0; i < MACHINE.argcount; i++) { - MACHINE.env.pop(); - } + MACHINE.env.length = MACHINE.env.length - MACHINE.argcount; if (returnArgs.length === 1) { MACHINE.val = returnArgs[0]; - frame = MACHINE.control.pop(); - return frame.label(MACHINE); + return MACHINE.control.pop().label(MACHINE); } else if (returnArgs.length === 0) { MACHINE.argcount = 0; - frame = MACHINE.control.pop(); - return frame.label.multipleValueReturn(MACHINE); + return MACHINE.control.pop().label.multipleValueReturn(MACHINE); } else { MACHINE.argcount = returnArgs.length; MACHINE.val = returnArgs.shift(); @@ -268,8 +264,7 @@ for(i = 0; i < MACHINE.argcount - 1; i++) { MACHINE.env.push(returnArgs.pop()); } - frame = MACHINE.control.pop(); - return frame.label.multipleValueReturn(MACHINE); + return MACHINE.control.pop().label.multipleValueReturn(MACHINE); } }; From 1026dff4cbfd72485940953d0fff0a6cf22706c3 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 7 Aug 2011 20:26:11 -0400 Subject: [PATCH 11/30] moving primitives to separate module, moved some functions as methods of the machine --- js-assembler/assemble-expression.rkt | 2 +- js-assembler/assemble-perform-statement.rkt | 6 +- js-assembler/assemble.rkt | 2 +- .../get-js-vm-implemented-primitives.rkt | 2 +- js-assembler/get-runtime.rkt | 3 +- js-assembler/runtime-src/baselib-functions.js | 4 +- js-assembler/runtime-src/baselib-modules.js | 2 +- .../runtime-src/baselib-primitives.js | 1586 ++++++++++++++++ js-assembler/runtime-src/runtime.js | 1610 +---------------- 9 files changed, 1676 insertions(+), 1541 deletions(-) create mode 100644 js-assembler/runtime-src/baselib-primitives.js diff --git a/js-assembler/assemble-expression.rkt b/js-assembler/assemble-expression.rkt index 2fc3391..cc58857 100644 --- a/js-assembler/assemble-expression.rkt +++ b/js-assembler/assemble-expression.rkt @@ -46,7 +46,7 @@ (CaptureEnvironment-skip op))] [(CaptureControl? op) - (format "RUNTIME.captureControl(MACHINE, ~a, ~a)" + (format "MACHINE.captureControl(~a, ~a)" (CaptureControl-skip op) (let: ([tag : (U DefaultContinuationPromptTag OpArg) (CaptureControl-tag op)]) diff --git a/js-assembler/assemble-perform-statement.rkt b/js-assembler/assemble-perform-statement.rkt index e4c81f5..58fa986 100644 --- a/js-assembler/assemble-perform-statement.rkt +++ b/js-assembler/assemble-perform-statement.rkt @@ -105,7 +105,7 @@ EOF "MACHINE.env = MACHINE.env[MACHINE.env.length - 2].slice(0);"] [(RestoreControl!? op) - (format "RUNTIME.restoreControl(MACHINE, ~a);" + (format "MACHINE.restoreControl(~a);" (let: ([tag : (U DefaultContinuationPromptTag OpArg) (RestoreControl!-tag op)]) (cond @@ -131,11 +131,11 @@ EOF (assemble-oparg (SetFrameCallee!-proc op)))] [(SpliceListIntoStack!? op) - (format "RUNTIME.spliceListIntoStack(MACHINE, ~a);" + (format "MACHINE.spliceListIntoStack(~a);" (assemble-oparg (SpliceListIntoStack!-depth op)))] [(UnspliceRestFromStack!? op) - (format "RUNTIME.unspliceRestFromStack(MACHINE, ~a, ~a);" + (format "MACHINE.unspliceRestFromStack(~a, ~a);" (assemble-oparg (UnspliceRestFromStack!-depth op)) (assemble-oparg (UnspliceRestFromStack!-length op)))] diff --git a/js-assembler/assemble.rkt b/js-assembler/assemble.rkt index 918a1b3..299f2c0 100644 --- a/js-assembler/assemble.rkt +++ b/js-assembler/assemble.rkt @@ -51,7 +51,7 @@ for (param in params) { } EOF ) - (fprintf op "RUNTIME.trampoline(MACHINE, ~a); })" + (fprintf op "MACHINE.trampoline(~a); })" (assemble-label (make-Label (BasicBlock-name (first basic-blocks))))))) diff --git a/js-assembler/get-js-vm-implemented-primitives.rkt b/js-assembler/get-js-vm-implemented-primitives.rkt index 58dcabf..f0807e2 100644 --- a/js-assembler/get-js-vm-implemented-primitives.rkt +++ b/js-assembler/get-js-vm-implemented-primitives.rkt @@ -8,7 +8,7 @@ (define-runtime-path js-vm-primitives.js "runtime-src/js-vm-primitives.js") -(define-runtime-path whalesong-primitives.js "runtime-src/runtime.js") +(define-runtime-path whalesong-primitives.js "runtime-src/baselib-primitives.js") ;; sort&unique: (listof string) -> (listof string) (define (sort&unique names) diff --git a/js-assembler/get-runtime.rkt b/js-assembler/get-runtime.rkt index 7974bc6..3b9a53f 100644 --- a/js-assembler/get-runtime.rkt +++ b/js-assembler/get-runtime.rkt @@ -74,7 +74,8 @@ ;; baselib-check has to come after the definitions of types, ;; since it uses the type predicates immediately on init time. baselib-check.js - + + baselib-primitives.js runtime.js)) diff --git a/js-assembler/runtime-src/baselib-functions.js b/js-assembler/runtime-src/baselib-functions.js index 8f5bac1..469e893 100644 --- a/js-assembler/runtime-src/baselib-functions.js +++ b/js-assembler/runtime-src/baselib-functions.js @@ -129,7 +129,7 @@ MACHINE.proc = oldProc; fail(e); }; - plt.runtime.trampoline(MACHINE, v.label); + MACHINE.trampoline(v.label); }; return f; }; @@ -198,7 +198,7 @@ MACHINE.proc = oldProc; fail(e); }; - plt.runtime.trampoline(MACHINE, proc.label); + MACHINE.trampoline(proc.label); } else { fail(plt.baselib.exceptions.makeExnFail( plt.baselib.format.format( diff --git a/js-assembler/runtime-src/baselib-modules.js b/js-assembler/runtime-src/baselib-modules.js index fd1cc8b..b6af144 100644 --- a/js-assembler/runtime-src/baselib-modules.js +++ b/js-assembler/runtime-src/baselib-modules.js @@ -62,7 +62,7 @@ if (isInternal) { throw that.label; } else { - plt.runtime.trampoline(MACHINE, that.label); + MACHINE.trampoline(that.label); } } }; diff --git a/js-assembler/runtime-src/baselib-primitives.js b/js-assembler/runtime-src/baselib-primitives.js new file mode 100644 index 0000000..71590db --- /dev/null +++ b/js-assembler/runtime-src/baselib-primitives.js @@ -0,0 +1,1586 @@ +// Arity structure +(function(baselib) { + var exports = {}; + baselib.primitives = exports; + + + ////////////////////////////////////////////////////////////////////// + ////////////////////////////////////////////////////////////////////// + // We try to isolate the effect of external modules: all the identifiers we + // pull from external modules should be listed here, and should otherwise not + // show up outside this section! + var isNumber = plt.baselib.numbers.isNumber; + var isNatural = plt.baselib.numbers.isNatural; + var isReal = plt.baselib.numbers.isReal; + var isPair = plt.baselib.lists.isPair; + var isList = plt.baselib.lists.isList; + var isVector = plt.baselib.vectors.isVector; + var isString = plt.baselib.strings.isString; + var isSymbol = plt.baselib.symbols.isSymbol; + var isNonNegativeReal = plt.baselib.numbers.isNonNegativeReal; + var equals = plt.baselib.equality.equals; + + var NULL = plt.baselib.lists.EMPTY; + var VOID = plt.baselib.constants.VOID_VALUE; + var EOF = plt.baselib.constants.EOF_VALUE; + + var NEGATIVE_ZERO = plt.baselib.numbers.negative_zero; + var INF = plt.baselib.numbers.inf; + var NEGATIVE_INF = plt.baselib.numbers.negative_inf; + var NAN = plt.baselib.numbers.nan; + + var makeFloat = plt.baselib.numbers.makeFloat; + var makeRational = plt.baselib.numbers.makeRational; + var makeBignum = plt.baselib.numbers.makeBignum; + var makeComplex = plt.baselib.numbers.makeComplex; + + var makeSymbol = plt.baselib.symbols.makeSymbol; + + var makeBox = plt.baselib.boxes.makeBox; + var isBox = plt.baselib.boxes.isBox; + + var makeVector = plt.baselib.vectors.makeVector; + var makeList = plt.baselib.lists.makeList; + var makePair = plt.baselib.lists.makePair; + + + var Closure = plt.baselib.functions.Closure; + var finalizeClosureCall = plt.baselib.functions.finalizeClosureCall; + var makePrimitiveProcedure = plt.baselib.functions.makePrimitiveProcedure; + var makeClosure = plt.baselib.functions.makeClosure; + + + // Other helpers + var withArguments = plt.baselib.withArguments; + var heir = plt.baselib.heir; + var makeClassPredicate = plt.baselib.makeClassPredicate; + var toDomNode = plt.baselib.format.toDomNode; + var toWrittenString = plt.baselib.format.toWrittenString; + var toDisplayedString = plt.baselib.format.toDisplayedString; + + + + // Frame structures. + var Frame = plt.baselib.frames.Frame; + var CallFrame = plt.baselib.frames.CallFrame; + var PromptFrame = plt.baselib.frames.PromptFrame; + + // Module structure + var ModuleRecord = plt.baselib.modules.ModuleRecord; + + + + // Ports + var OutputPort = plt.baselib.ports.OutputPort; + var isOutputPort = plt.baselib.ports.isOutputPort; + var StandardOutputPort = plt.baselib.ports.StandardOutputPort; + var StandardErrorPort = plt.baselib.ports.StandardErrorPort; + var OutputStringPort = plt.baselib.ports.OutputStringPort; + var isOutputStringPort = plt.baselib.ports.isOutputStringPort; + + + + + // Exceptions and error handling. + var raise = plt.baselib.exceptions.raise; + var raiseUnboundToplevelError = plt.baselib.exceptions.raiseUnboundToplevelError; + var raiseArgumentTypeError = plt.baselib.exceptions.raiseArgumentTypeError; + var raiseContextExpectedValuesError = plt.baselib.exceptions.raiseContextExpectedValuesError; + var raiseArityMismatchError = plt.baselib.exceptions.raiseArityMismatchError; + var raiseOperatorApplicationError = plt.baselib.exceptions.raiseOperatorApplicationError; + var raiseOperatorIsNotPrimitiveProcedure = plt.baselib.exceptions.raiseOperatorIsNotPrimitiveProcedure; + var raiseOperatorIsNotClosure = plt.baselib.exceptions.raiseOperatorIsNotClosure; + var raiseUnimplementedPrimitiveError = plt.baselib.exceptions.raiseUnimplementedPrimitiveError; + + + var testArgument = plt.baselib.check.testArgument; + var testArity = plt.baselib.check.testArity; + var makeCheckArgumentType = plt.baselib.check.makeCheckArgumentType; + + var checkOutputPort = plt.baselib.check.checkOutputPort; + var checkString = plt.baselib.check.checkString; + var checkMutableString = plt.baselib.check.checkMutableString; + var checkSymbol = plt.baselib.check.checkSymbol; + var checkByte = plt.baselib.check.checkByte; + var checkChar = plt.baselib.check.checkChar; + var checkProcedure = plt.baselib.check.checkProcedure; + var checkNumber = plt.baselib.check.checkNumber; + var checkReal = plt.baselib.check.checkReal; + var checkNonNegativeReal = plt.baselib.check.checkNonNegativeReal; + var checkNatural = plt.baselib.check.checkNatural; + var checkNaturalInRange = plt.baselib.check.checkNaturalInRange; + var checkInteger = plt.baselib.check.checkInteger; + var checkRational = plt.baselib.check.checkRational; + var checkPair = plt.baselib.check.checkPair; + var checkList = plt.baselib.check.checkList; + var checkVector = plt.baselib.check.checkVector; + var checkBox = plt.baselib.check.checkBox; + var checkMutableBox = plt.baselib.check.checkMutableBox; + var checkInspector = plt.baselib.check.checkInspector; + ////////////////////////////////////////////////////////////////////// + + + + + + + + + + + + // Primitives are the set of primitive values. Not all primitives + // are coded here; several of them (including call/cc) are injected by + // the bootstrapping code in compiler/boostrapped-primitives.rkt + var Primitives = {}; + + var installPrimitiveProcedure = function(name, arity, f) { + Primitives[name] = makePrimitiveProcedure(name, arity, f); + }; + + var installPrimitiveClosure = function(name, arity, f) { + Primitives[name] = makeClosure(name, arity, f, []); + }; + + + var installPrimitiveConstant = function(name, v) { + Primitives[name] = v; + }; + + + + installPrimitiveConstant('pi', plt.baselib.numbers.pi); + installPrimitiveConstant('e', plt.baselib.numbers.e); + installPrimitiveConstant('null', NULL); + installPrimitiveConstant('true', true); + installPrimitiveConstant('false', false); + + + installPrimitiveProcedure( + 'display', makeList(1, 2), + function(MACHINE) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + var outputPort = MACHINE.params.currentOutputPort; + if (MACHINE.argcount === 2) { + outputPort = checkOutputPort(MACHINE, 'display', 1); + } + outputPort.writeDomNode(MACHINE, toDomNode(firstArg, 'display')); + return VOID; + }); + + + installPrimitiveProcedure( + 'write-byte', makeList(1, 2), + function(MACHINE) { + var firstArg = checkByte(MACHINE, 'write-byte', 0); + var outputPort = MACHINE.params.currentOutputPort; + if (MACHINE.argcount === 2) { + outputPort = checkOutputPort(MACHINE, 'display', 1); + } + outputPort.writeDomNode(MACHINE, toDomNode(String.fromCharCode(firstArg), 'display')); + return VOID; + }); + + + installPrimitiveProcedure( + 'newline', makeList(0, 1), + function(MACHINE) { + var outputPort = MACHINE.params.currentOutputPort; + if (MACHINE.argcount === 1) { + outputPort = checkOutputPort(MACHINE, 'newline', 1); + } + outputPort.writeDomNode(MACHINE, toDomNode("\n", 'display')); + return VOID; + }); + + installPrimitiveProcedure( + 'displayln', + makeList(1, 2), + function(MACHINE){ + var firstArg = MACHINE.env[MACHINE.env.length-1]; + var outputPort = MACHINE.params.currentOutputPort; + if (MACHINE.argcount === 2) { + outputPort = checkOutputPort(MACHINE, 'displayln', 1); + } + outputPort.writeDomNode(MACHINE, toDomNode(firstArg, 'display')); + outputPort.writeDomNode(MACHINE, toDomNode("\n", 'display')); + return VOID; + }); + + + + installPrimitiveProcedure( + 'format', + plt.baselib.arity.makeArityAtLeast(1), + function(MACHINE) { + var args = [], i, formatString; + formatString = checkString(MACHINE, 'format', 0).toString(); + for(i = 1; i < MACHINE.argcount; i++) { + args.push(MACHINE.env[MACHINE.env.length - 1 - i]); + } + return plt.baselib.format.format(formatString, args, 'format'); + }); + + + installPrimitiveProcedure( + 'printf', + plt.baselib.arity.makeArityAtLeast(1), + function(MACHINE) { + var args = [], i, formatString, result, outputPort; + formatString = checkString(MACHINE, 'printf', 0).toString(); + for(i = 1; i < MACHINE.argcount; i++) { + args.push(MACHINE.env[MACHINE.env.length - 1 - i]); + } + result = plt.baselib.format.format(formatString, args, 'format'); + outputPort = MACHINE.params.currentOutputPort; + outputPort.writeDomNode(MACHINE, toDomNode(result, 'display')); + return VOID; + }); + + + installPrimitiveProcedure( + 'fprintf', + plt.baselib.arity.makeArityAtLeast(2), + function(MACHINE) { + var args = [], i, formatString, outputPort, result; + outputPort = checkOutputPort(MACHINE, 'fprintf', 0); + formatString = checkString(MACHINE, 'fprintf', 1).toString(); + for(i = 2; i < MACHINE.argcount; i++) { + args.push(MACHINE.env[MACHINE.env.length - 1 - i]); + } + result = plt.baselib.format.format(formatString, args, 'format'); + outputPort.writeDomNode(MACHINE, toDomNode(result, 'display')); + return VOID; + }); + + + + + + + installPrimitiveProcedure( + 'current-print', + makeList(0, 1), + function(MACHINE) { + if (MACHINE.argcount === 1) { + MACHINE.params['currentPrint'] = + checkProcedure(MACHINE, 'current-print', 0); + return VOID; + } else { + return MACHINE.params['currentPrint']; + } + }); + + + installPrimitiveProcedure( + 'current-output-port', + makeList(0, 1), + function(MACHINE) { + if (MACHINE.argcount === 1) { + MACHINE.params['currentOutputPort'] = + checkOutputPort(MACHINE, 'current-output-port', 0); + return VOID; + } else { + return MACHINE.params['currentOutputPort']; + } + }); + + + + + + installPrimitiveProcedure( + '=', + plt.baselib.arity.makeArityAtLeast(2), + function(MACHINE) { + var firstArg = checkNumber(MACHINE, '=', 0), secondArg; + for (var i = 1; i < MACHINE.argcount; i++) { + var secondArg = checkNumber(MACHINE, '=', i); + if (! (plt.baselib.numbers.equals(firstArg, secondArg))) { + return false; + } + } + return true; + }); + + + + installPrimitiveProcedure( + '=~', + 3, + function(MACHINE) { + var x = checkReal(MACHINE, '=~', 0); + var y = checkReal(MACHINE, '=~', 1); + var range = checkNonNegativeReal(MACHINE, '=~', 2); + return plt.baselib.numbers.lessThanOrEqual( + plt.baselib.numbers.abs(plt.baselib.numbers.subtract(x, y)), + range); + }); + + + + var makeChainingBinop = function(predicate, name) { + return function(MACHINE) { + var firstArg = checkNumber(MACHINE, name, 0), secondArg; + for (var i = 1; i < MACHINE.argcount; i++) { + secondArg = checkNumber(MACHINE, name, i); + if (! (predicate(firstArg, secondArg))) { + return false; + } + firstArg = secondArg; + } + return true; + }; + }; + + installPrimitiveProcedure( + '<', + plt.baselib.arity.makeArityAtLeast(2), + makeChainingBinop(plt.baselib.numbers.lessThan, '<')); + + + installPrimitiveProcedure( + '>', + plt.baselib.arity.makeArityAtLeast(2), + makeChainingBinop(plt.baselib.numbers.greaterThan, '>')); + + + installPrimitiveProcedure( + '<=', + plt.baselib.arity.makeArityAtLeast(2), + makeChainingBinop(plt.baselib.numbers.lessThanOrEqual, '<=')); + + + installPrimitiveProcedure( + '>=', + plt.baselib.arity.makeArityAtLeast(2), + makeChainingBinop(plt.baselib.numbers.greaterThanOrEqual, '>=')); + + + installPrimitiveProcedure( + '+', + plt.baselib.arity.makeArityAtLeast(0), + function(MACHINE) { + var result = 0; + var i = 0; + for (i = 0; i < MACHINE.argcount; i++) { + result = plt.baselib.numbers.add( + result, + checkNumber(MACHINE, '+', i)); + }; + return result; + }); + + + installPrimitiveProcedure( + '*', + plt.baselib.arity.makeArityAtLeast(0), + function(MACHINE) { + var result = 1; + var i = 0; + for (i=0; i < MACHINE.argcount; i++) { + result = plt.baselib.numbers.multiply( + result, + checkNumber(MACHINE, '*', i)); + } + return result; + }); + + installPrimitiveProcedure( + '-', + plt.baselib.arity.makeArityAtLeast(1), + function(MACHINE) { + if (MACHINE.argcount === 1) { + return plt.baselib.numbers.subtract( + 0, + checkNumber(MACHINE, '-', 0)); + } + var result = checkNumber(MACHINE, '-', 0); + for (var i = 1; i < MACHINE.argcount; i++) { + result = plt.baselib.numbers.subtract( + result, + checkNumber(MACHINE, '-', i)); + } + return result; + }); + + installPrimitiveProcedure( + '/', + plt.baselib.arity.makeArityAtLeast(1), + function(MACHINE) { + var result = checkNumber(MACHINE, '/', 0); + for (var i = 1; i < MACHINE.argcount; i++) { + result = plt.baselib.numbers.divide( + result, + checkNumber(MACHINE, '/', i)); + } + return result; + }); + + + installPrimitiveProcedure( + 'add1', + 1, + function(MACHINE) { + var firstArg = checkNumber(MACHINE, 'add1', 0); + return plt.baselib.numbers.add(firstArg, 1); + }); + + + installPrimitiveProcedure( + 'sub1', + 1, + function(MACHINE) { + var firstArg = checkNumber(MACHINE, 'sub1', 0); + return plt.baselib.numbers.subtract(firstArg, 1); + }); + + + installPrimitiveProcedure( + 'zero?', + 1, + function(MACHINE) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + return plt.baselib.numbers.equals(firstArg, 0); + }); + + + installPrimitiveProcedure( + 'cons', + 2, + function(MACHINE) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + var secondArg = MACHINE.env[MACHINE.env.length-2]; + return makePair(firstArg, secondArg); + }); + + + installPrimitiveProcedure( + 'list', + plt.baselib.arity.makeArityAtLeast(0), + function(MACHINE) { + var result = NULL; + for (var i = 0; i < MACHINE.argcount; i++) { + result = makePair(MACHINE.env[MACHINE.env.length - (MACHINE.argcount - i)], + result); + } + return result; + }); + + installPrimitiveProcedure( + 'list*', + plt.baselib.arity.makeArityAtLeast(1), + function(MACHINE) { + var result = checkList(MACHINE, 'list*', MACHINE.argcount - 1); + for (var i = MACHINE.argcount - 2; i >= 0; i--) { + result = makePair(MACHINE.env[MACHINE.env.length - 1 - i], + result); + } + return result; + }); + + + installPrimitiveProcedure( + 'list-ref', + 2, + function(MACHINE) { + var lst = checkList(MACHINE, 'list-ref', 0); + var index = checkNaturalInRange(MACHINE, 'list-ref', 1, + 0, plt.baselib.lists.length(lst)); + return plt.baselib.lists.listRef(lst, plt.baselib.numbers.toFixnum(index)); + }); + + + + + installPrimitiveProcedure( + 'car', + 1, + function(MACHINE) { + var firstArg = checkPair(MACHINE, 'car', 0); + return firstArg.first; + }); + + installPrimitiveProcedure( + 'cdr', + 1, + function(MACHINE) { + var firstArg = checkPair(MACHINE, 'cdr', 0); + return firstArg.rest; + }); + + installPrimitiveProcedure( + 'pair?', + 1, + function(MACHINE) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + return isPair(firstArg); + }); + + + installPrimitiveProcedure( + 'list?', + 1, + function(MACHINE) { + return isList(MACHINE.env[MACHINE.env.length -1]); + }); + + + installPrimitiveProcedure( + 'set-car!', + 2, + function(MACHINE) { + var firstArg = checkPair(MACHINE, 'set-car!', 0); + var secondArg = MACHINE.env[MACHINE.env.length-2]; + firstArg.first = secondArg; + return VOID; + }); + + + installPrimitiveProcedure( + 'set-cdr!', + 2, + function(MACHINE) { + var firstArg = checkPair(MACHINE, 'set-car!', 0); + var secondArg = MACHINE.env[MACHINE.env.length-2]; + firstArg.rest = secondArg; + return VOID; + }); + + + installPrimitiveProcedure( + 'not', + 1, + function(MACHINE) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + return (firstArg === false); + }); + + + installPrimitiveProcedure( + 'null?', + 1, + function(MACHINE) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + return firstArg === NULL; + }); + + + installPrimitiveProcedure( + 'vector', + plt.baselib.arity.makeArityAtLeast(0), + function(MACHINE) { + var i; + var result = []; + for (i = 0; i < MACHINE.argcount; i++) { + result.push(MACHINE.env[MACHINE.env.length-1-i]); + } + var newVector = makeVector.apply(null, result); + return newVector; + }); + + + installPrimitiveProcedure( + 'vector->list', + 1, + function(MACHINE) { + var elts = checkVector(MACHINE, 'vector->list', 0).elts; + var i; + var result = NULL; + for (i = 0; i < elts.length; i++) { + result = makePair(elts[elts.length - 1 - i], result); + } + return result; + }); + + + installPrimitiveProcedure( + 'list->vector', + 1, + function(MACHINE) { + var firstArg = checkList(MACHINE, 'list->vector', 0); + var result = []; + while (firstArg !== NULL) { + result.push(firstArg.first); + firstArg = firstArg.rest; + } + return makeVector.apply(null, result); + }); + + + installPrimitiveProcedure( + 'vector-ref', + 2, + function(MACHINE) { + var elts = checkVector(MACHINE, 'vector-ref', 0).elts; + var index = MACHINE.env[MACHINE.env.length-2]; + return elts[index]; + }); + + + installPrimitiveProcedure( + 'vector-set!', + 3, + function(MACHINE) { + var elts = checkVector(MACHINE, 'vector-set!', 0).elts; + // FIXME: check out-of-bounds vector + var index = plt.baselib.numbers.toFixnum( + checkNaturalInRange(MACHINE, 'vector-set!', 1, + 0, elts.length)); + var val = MACHINE.env[MACHINE.env.length - 1 - 2]; + elts[index] = val; + return VOID; + }); + + + installPrimitiveProcedure( + 'vector-length', + 1, + function(MACHINE) { + return checkVector(MACHINE, 'vector-length', 0).elts.length; + }); + + + + installPrimitiveProcedure( + 'make-string', + makeList(1, 2), + function(MACHINE) { + var value = "\0"; + var length = plt.baselib.numbers.toFixnum( + checkNatural(MACHINE, 'make-string', 0)); + if (MACHINE.argcount == 2) { + value = checkChar(MACHINE, 'make-string', 1).val; + } + var arr = []; + for(var i = 0; i < length; i++) { + arr[i] = value; + } + return plt.baselib.strings.makeMutableString(arr); + }); + + + installPrimitiveProcedure( + 'string-set!', + 3, + function(MACHINE) { + var str = checkMutableString(MACHINE, 'string-set!', 0); + var k = checkNatural(MACHINE, 'string-set!', 1); + var ch = checkChar(MACHINE, 'string-set!', 2); + + }); + + + + installPrimitiveProcedure( + 'make-vector', + makeList(1, 2), + function(MACHINE) { + var value = 0; + var length = plt.baselib.numbers.toFixnum( + checkNatural(MACHINE, 'make-vector', 0)); + if (MACHINE.argcount == 2) { + value = MACHINE.env[MACHINE.env.length - 2]; + } + var arr = []; + for(var i = 0; i < length; i++) { + arr[i] = value; + } + return makeVector.apply(null, arr); + }); + + + + installPrimitiveProcedure( + 'symbol?', + 1, + function(MACHINE) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + return isSymbol(firstArg); + }); + + installPrimitiveProcedure( + 'symbol->string', + 1, + function(MACHINE) { + var firstArg = checkSymbol(MACHINE, 'symbol->string', 0); + return firstArg.toString(); + }); + + + installPrimitiveProcedure( + 'string=?', + plt.baselib.arity.makeArityAtLeast(1), + function(MACHINE) { + var s = checkString(MACHINE, 'string=?', 0).toString(); + for (var i = 1; i < MACHINE.argcount; i++) { + if (checkString(MACHINE, 'string=?', i).toString() !== s) { + return false; + } + } + return true; + }); + + + installPrimitiveProcedure( + 'string-append', + plt.baselib.arity.makeArityAtLeast(0), + function(MACHINE) { + var buffer = []; + var i; + for (i = 0; i < MACHINE.argcount; i++) { + buffer.push(checkString(MACHINE, 'string-append', i).toString()); + } + return buffer.join(''); + }); + + installPrimitiveProcedure( + 'string-length', + 1, + function(MACHINE) { + var firstArg = checkString(MACHINE, 'string-length', 0).toString(); + return firstArg.length; + }); + + + installPrimitiveProcedure( + 'string?', + 1, + function(MACHINE) { + return isString(MACHINE.env[MACHINE.env.length - 1]); + }); + + + installPrimitiveProcedure( + 'number->string', + 1, + function(MACHINE) { + return checkNumber(MACHINE, 'number->string', 0).toString(); + }); + + + installPrimitiveProcedure( + 'string->symbol', + 1, + function(MACHINE) { + return makeSymbol(checkString(MACHINE, 'string->symbol', 0).toString()); + }); + + + installPrimitiveProcedure( + 'string->number', + 1, + function(MACHINE) { + return plt.baselib.numbers.fromString( + checkString(MACHINE, 'string->number', 0).toString()); + }); + + + + + + installPrimitiveProcedure( + 'box', + 1, + function(MACHINE) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + return makeBox(firstArg); + }); + + installPrimitiveProcedure( + 'unbox', + 1, + function(MACHINE) { + var firstArg = checkBox(MACHINE, 'unbox', 0); + return firstArg.ref(); + }); + + installPrimitiveProcedure( + 'set-box!', + 2, + function(MACHINE) { + var firstArg = checkMutableBox(MACHINE, 'set-box!', 0); + var secondArg = MACHINE.env[MACHINE.env.length-2]; + firstArg.set(secondArg); + return VOID; + }); + + installPrimitiveProcedure( + 'void', + plt.baselib.arity.makeArityAtLeast(0), + function(MACHINE) { + return VOID; + }); + + + installPrimitiveProcedure( + 'random', + plt.baselib.lists.makeList(0, 1), + function(MACHINE) { + if (MACHINE.argcount === 0) { + return plt.baselib.numbers.makeFloat(Math.random()); + } else { + var n = checkNatural(MACHINE, 'random', 0); + return Math.floor(Math.random() * plt.baselib.numbers.toFixnum(n)); + } + }); + + + installPrimitiveProcedure( + 'eq?', + 2, + function(MACHINE) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + var secondArg = MACHINE.env[MACHINE.env.length-2]; + return firstArg === secondArg; + }); + + installPrimitiveProcedure( + 'eqv?', + 2, + function(MACHINE) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + var secondArg = MACHINE.env[MACHINE.env.length-2]; + return plt.baselib.equality.eqv(firstArg, secondArg); + }); + + + + installPrimitiveProcedure( + 'equal?', + 2, + function(MACHINE) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + var secondArg = MACHINE.env[MACHINE.env.length-2]; + return equals(firstArg, secondArg); + }); + + + // This definition of apply will take precedence over the + // implementation of apply in the boostrapped-primitives.rkt, + // since it provides nicer error handling. + installPrimitiveClosure( + 'apply', + plt.baselib.arity.makeArityAtLeast(2), + function(MACHINE) { + if(--MACHINE.callsBeforeTrampoline < 0) { + throw arguments.callee; + } + var proc = checkProcedure(MACHINE, 'apply', 0); + MACHINE.env.pop(); + MACHINE.argcount--; + checkList(MACHINE, 'apply', MACHINE.argcount - 1); + MACHINE.spliceListIntoStack(MACHINE.argcount - 1); + if (plt.baselib.arity.isArityMatching(proc.racketArity, MACHINE.argcount)) { + MACHINE.proc = proc; + if (plt.baselib.functions.isPrimitiveProcedure(proc)) { + return finalizeClosureCall(MACHINE, proc(MACHINE)); + } else { + return proc.label(MACHINE); + } + } else { + raiseArityMismatchError(MACHINE, proc, proc.racketArity, MACHINE.argcount); + } + }); + + + // FIXME: The definition of call-with-values is in + // bootstrapped-primitives.rkt. We may want to replace it with an + // explicitly defined one here. + + + + + + installPrimitiveProcedure( + 'procedure?', + 1, + function(MACHINE) { + return plt.baselib.functions.isProcedure(MACHINE.env[MACHINE.env.length - 1]); + }); + + installPrimitiveProcedure( + 'procedure-arity-includes?', + 2, + function(MACHINE) { + var proc = checkProcedure(MACHINE, 'procedure-arity-includes?', 0); + var argcount = checkNatural(MACHINE, 'procedure-arity-includes?', 1); + return plt.baselib.arity.isArityMatching(proc.racketArity, argcount); + }); + + installPrimitiveProcedure( + 'procedure-arity', + 1, + function(MACHINE) { + var proc = checkProcedure(MACHINE, 'procedure-arity-includes?', 0); + return proc.racketArity; + }); + + + installPrimitiveProcedure( + 'member', + 2, + function(MACHINE) { + var x = MACHINE.env[MACHINE.env.length-1]; + var lst = MACHINE.env[MACHINE.env.length-2]; + var originalLst = lst; + while (true) { + if (lst === NULL) { + return false; + } + if (! isPair(lst)) { + raiseArgumentTypeError(MACHINE, + 'member', + 'list', + 1, + MACHINE.env[MACHINE.env.length - 1 - 1]); + } + if (equals(x, (lst.first))) { + return lst; + } + lst = lst.rest; + } + }); + + + + installPrimitiveProcedure( + 'reverse', + 1, + function(MACHINE) { + var rev = NULL; + var lst = MACHINE.env[MACHINE.env.length-1]; + while(lst !== NULL) { + testArgument(MACHINE, + 'pair', isPair, lst, 0, 'reverse'); + rev = makePair(lst.first, rev); + lst = lst.rest; + } + return rev; + }); + + + + + installPrimitiveProcedure( + 'abs', + 1, + function(MACHINE) { + return plt.baselib.numbers.abs( + checkNumber(MACHINE, 'abs', 0)); + }); + + installPrimitiveProcedure( + 'acos', + 1, + function(MACHINE) { + return plt.baselib.numbers.acos( + checkNumber(MACHINE, 'acos', 0)); + }); + + + installPrimitiveProcedure( + 'asin', + 1, + function(MACHINE) { + return plt.baselib.numbers.asin( + checkNumber(MACHINE, 'asin', 0)); + }); + + installPrimitiveProcedure( + 'sin', + 1, + function(MACHINE) { + return plt.baselib.numbers.sin( + checkNumber(MACHINE, 'sin', 0)); + }); + + + + installPrimitiveProcedure( + 'sinh', + 1, + function(MACHINE) { + return plt.baselib.numbers.sinh( + checkNumber(MACHINE, 'sinh', 0)); + }); + + + installPrimitiveProcedure( + 'tan', + 1, + function(MACHINE) { + return plt.baselib.numbers.tan( + checkNumber(MACHINE, 'tan', 0)); + }); + + + + installPrimitiveProcedure( + 'atan', + makeList(1, 2), + function(MACHINE) { + if (MACHINE.argcount === 1) { + return plt.baselib.numbers.atan( + checkNumber(MACHINE, 'atan', 0)); + } else { + testArgument(MACHINE, + 'number', + isNumber, + MACHINE.env[MACHINE.env.length - 1], + 0, + 'atan'); + testArgument(MACHINE, + 'number', + isNumber, + MACHINE.env[MACHINE.env.length - 2], + 1, + 'atan'); + return plt.baselib.numbers.makeFloat( + Math.atan2( + plt.baselib.numbers.toFixnum(checkNumber(MACHINE, 'atan', 0)), + plt.baselib.numbers.toFixnum(checkNumber(MACHINE, 'atan', 1)))); + } + }); + + + installPrimitiveProcedure( + 'angle', + 1, + function(MACHINE) { + return plt.baselib.numbers.angle( + checkNumber(MACHINE, 'angle', 0)); + }); + + installPrimitiveProcedure( + 'magnitude', + 1, + function(MACHINE) { + return plt.baselib.numbers.magnitude( + checkNumber(MACHINE, 'magnitude', 0)); + }); + + installPrimitiveProcedure( + 'conjugate', + 1, + function(MACHINE) { + return plt.baselib.numbers.conjugate( + checkNumber(MACHINE, 'conjugate', 0)); + }); + + + + + installPrimitiveProcedure( + 'cos', + 1, + function(MACHINE) { + return plt.baselib.numbers.cos( + checkNumber(MACHINE, 'cos', 0)); + }); + + + installPrimitiveProcedure( + 'cosh', + 1, + function(MACHINE) { + return plt.baselib.numbers.cosh( + checkNumber(MACHINE, 'cosh', 0)); + }); + + installPrimitiveProcedure( + 'gcd', + plt.baselib.arity.makeArityAtLeast(1), + function(MACHINE) { + var args = [], i, x; + for (i = 0; i < MACHINE.argcount; i++) { + args.push(checkNumber(MACHINE, 'gcd', i)); + } + x = args.shift(); + return plt.baselib.numbers.gcd(x, args); + }); + + installPrimitiveProcedure( + 'lcm', + plt.baselib.arity.makeArityAtLeast(1), + function(MACHINE) { + var args = [], i, x; + for (i = 0; i < MACHINE.argcount; i++) { + args.push(checkNumber(MACHINE, 'lcm', i)); + } + x = args.shift(); + return plt.baselib.numbers.lcm(x, args); + }); + + + + + installPrimitiveProcedure( + 'exp', + 1, + function(MACHINE) { + return plt.baselib.numbers.exp( + checkNumber(MACHINE, 'exp', 0)); + }); + + + installPrimitiveProcedure( + 'expt', + 2, + function(MACHINE) { + return plt.baselib.numbers.expt( + checkNumber(MACHINE, 'expt', 0), + checkNumber(MACHINE, 'expt', 1)); + }); + + installPrimitiveProcedure( + 'exact?', + 1, + function(MACHINE) { + return plt.baselib.numbers.isExact( + checkNumber(MACHINE, 'exact?', 0)); + }); + + + installPrimitiveProcedure( + 'integer?', + 1, + function(MACHINE) { + return plt.baselib.numbers.isInteger(MACHINE.env[MACHINE.env.length - 1]); + }); + + + installPrimitiveProcedure( + 'exact-nonnegative-integer?', + 1, + function(MACHINE) { + return plt.baselib.numbers.isNatural(MACHINE.env[MACHINE.env.length - 1]); + }); + + + + installPrimitiveProcedure( + 'imag-part', + 1, + function(MACHINE) { + return plt.baselib.numbers.imaginaryPart( + checkNumber(MACHINE, 'imag-part', 0)); + }); + + + installPrimitiveProcedure( + 'real-part', + 1, + function(MACHINE) { + return plt.baselib.numbers.realPart( + checkNumber(MACHINE, 'real-part', 0)); + }); + + + installPrimitiveProcedure( + 'make-polar', + 2, + function(MACHINE) { + return plt.baselib.numbers.makeComplexPolar( + checkReal(MACHINE, 'make-polar', 0), + checkReal(MACHINE, 'make-polar', 1)); + }); + + + installPrimitiveProcedure( + 'make-rectangular', + 2, + function(MACHINE) { + return plt.baselib.numbers.makeComplex( + checkReal(MACHINE, 'make-rectangular', 0), + checkReal(MACHINE, 'make-rectangular', 1)); + }); + + installPrimitiveProcedure( + 'modulo', + 2, + function(MACHINE) { + return plt.baselib.numbers.modulo( + checkInteger(MACHINE, 'modulo', 0), + checkInteger(MACHINE, 'modulo', 1)); + }); + + + installPrimitiveProcedure( + 'remainder', + 2, + function(MACHINE) { + return plt.baselib.numbers.remainder( + checkInteger(MACHINE, 'remainder', 0), + checkInteger(MACHINE, 'remainder', 1)); + }); + + + installPrimitiveProcedure( + 'quotient', + 2, + function(MACHINE) { + return plt.baselib.numbers.quotient( + checkInteger(MACHINE, 'quotient', 0), + checkInteger(MACHINE, 'quotient', 1)); + }); + + + + installPrimitiveProcedure( + 'floor', + 1, + function(MACHINE) { + return plt.baselib.numbers.floor( + checkReal(MACHINE, 'floor', 0)); + }); + + + installPrimitiveProcedure( + 'ceiling', + 1, + function(MACHINE) { + return plt.baselib.numbers.ceiling( + checkReal(MACHINE, 'ceiling', 0)); + }); + + + installPrimitiveProcedure( + 'round', + 1, + function(MACHINE) { + return plt.baselib.numbers.round( + checkReal(MACHINE, 'round', 0)); + }); + + + installPrimitiveProcedure( + 'truncate', + 1, + function(MACHINE) { + var n = checkReal(MACHINE, 'truncate', 0); + if (plt.baselib.numbers.lessThan(n, 0)) { + return plt.baselib.numbers.ceiling(n); + } else { + return plt.baselib.numbers.floor(n); + } + }); + + + installPrimitiveProcedure( + 'numerator', + 1, + function(MACHINE) { + return plt.baselib.numbers.numerator( + checkRational(MACHINE, 'numerator', 0)); + }); + + + installPrimitiveProcedure( + 'denominator', + 1, + function(MACHINE) { + return plt.baselib.numbers.denominator( + checkRational(MACHINE, 'denominator', 0)); + }); + + + installPrimitiveProcedure( + 'log', + 1, + function(MACHINE) { + return plt.baselib.numbers.log( + checkNumber(MACHINE, 'log', 0)); + }); + + + installPrimitiveProcedure( + 'sqr', + 1, + function(MACHINE) { + return plt.baselib.numbers.sqr( + checkNumber(MACHINE, 'sqr', 0)); + }); + + + + + installPrimitiveProcedure( + 'sqrt', + 1, + function(MACHINE) { + return plt.baselib.numbers.sqrt( + checkNumber(MACHINE, 'sqrt', 0)); + }); + + + + installPrimitiveProcedure( + 'integer-sqrt', + 1, + function(MACHINE) { + return plt.baselib.numbers.integerSqrt( + checkInteger(MACHINE, 'integer-sqrt', 0)); + }); + + + + installPrimitiveProcedure( + 'sgn', + 1, + function(MACHINE) { + return plt.baselib.numbers.sign( + checkInteger(MACHINE, 'sgn', 0)); + }); + + + + installPrimitiveProcedure( + 'error', + plt.baselib.arity.makeArityAtLeast(1), + function(MACHINE) { + if (MACHINE.argcount === 1) { + var sym = checkSymbol(MACHINE, 'error', 1); + // FIXME: we should collect the current continuation marks here... + raise(MACHINE, plt.baselib.exceptions.makeExnFail(String(sym), undefined)); + } + + if (isString(MACHINE.env[MACHINE.env.length - 1])) { + var vs = []; + for (var i = 1; i < MACHINE.argcount; i++) { + vs.push(plt.baselib.format.format("~e", [MACHINE.env[MACHINE.env.length - 1 - i]])); + } + raise(MACHINE, plt.baselib.exceptions.makeExnFail(String(MACHINE.env[MACHINE.env.length - 1]) + + ": " + + vs.join(' '), + undefined)); + } + + if (isSymbol(MACHINE.env[MACHINE.env.length - 1])) { + var fmtString = checkString(MACHINE, 'error', 1); + var args = [MACHINE.env[MACHINE.env.length - 1]]; + for (i = 2; i < MACHINE.argcount; i++) { + args.push(MACHINE.env[MACHINE.env.length - 1 - i]); + } + raise(MACHINE, plt.baselib.exceptions.makeExnFail( + plt.baselib.format.format('~s: ' + String(fmtString), + args), + undefined)); + } + + // Fall-through + raiseArgumentTypeError(MACHINE, 'error', 'symbol or string', 0, MACHINE.env[MACHINE.env.length - 1]); + }); + + + installPrimitiveProcedure( + 'raise-mismatch-error', + 3, + function(MACHINE) { + var name = checkSymbol(MACHINE, 'raise-mismatch-error', 0); + var message = checkString(MACHINE, 'raise-mismatch-error', 0); + var val = MACHINE.env[MACHINE.env.length - 1 - 2]; + raise(MACHINE, plt.baselib.exceptions.makeExnFail + (plt.baselib.format.format("~a: ~a~e", + [name, + message, + val]), + undefined)); + }); + + + installPrimitiveProcedure( + 'raise-type-error', + plt.baselib.arity.makeArityAtLeast(3), + function(MACHINE) { + var name = checkSymbol(MACHINE, 'raise-type-error', 0); + var expected = checkString(MACHINE, 'raise-type-error', 1); + if (MACHINE.argcount === 3) { + raiseArgumentTypeError(MACHINE, + name, + expected, + undefined, + MACHINE.env[MACHINE.env.length - 1 - 2]); + } else { + raiseArgumentTypeError(MACHINE, + name, + expected, + checkNatural(MACHINE, 'raise-type-error', 2), + MACHINE.env[MACHINE.env.length - 1 - 2]); + } + }); + + + + + installPrimitiveClosure( + 'make-struct-type', + makeList(4, 5, 6, 7, 8, 9, 10, 11), + function(MACHINE) { + withArguments( + MACHINE, + 4, + [false, + NULL, + false, + false, + NULL, + false, + false], + function(name, + superType, + initFieldCount, + autoFieldCount, + autoV, + props, // FIXME: currently ignored + inspector, // FIXME: currently ignored + procSpec, // FIXME: currently ignored + immutables, // FIXME: currently ignored + guard, // FIXME: currently ignored + constructorName + ) { + + // FIXME: typechecks. + + var structType = plt.baselib.structs.makeStructureType( + name, + superType, + initFieldCount, + autoFieldCount, + autoV, + //props, + //inspector, + //procSpec, + //immutables, + guard); + + var constructorValue = + makePrimitiveProcedure( + constructorName, + plt.baselib.numbers.toFixnum(initFieldCount), + function(MACHINE) { + var args = []; + for(var i = 0; i < initFieldCount; i++) { + args.push(MACHINE.env[MACHINE.env.length - 1 - i]); + } + return structType.constructor.apply(null, args); + }); + + var predicateValue = + makePrimitiveProcedure( + String(name) + "?", + 1, + function(MACHINE) { + return structType.predicate(MACHINE.env[MACHINE.env.length - 1]); + }); + + var accessorValue = + makePrimitiveProcedure( + String(name) + "-accessor", + 2, + function(MACHINE) { + // FIXME: typechecks + return structType.accessor( + MACHINE.env[MACHINE.env.length - 1], + plt.baselib.numbers.toFixnum(MACHINE.env[MACHINE.env.length - 2])); + }); + accessorValue.structType = structType; + + var mutatorValue = + makePrimitiveProcedure( + String(name) + "-mutator", + 3, + function(MACHINE) { + // FIXME: typechecks + return structType.mutator( + MACHINE.env[MACHINE.env.length - 1], + plt.baselib.numbers.toFixnum(MACHINE.env[MACHINE.env.length - 2]), + MACHINE.env[MACHINE.env.length - 3]); + }); + mutatorValue.structType = structType; + + + finalizeClosureCall(MACHINE, + structType, + constructorValue, + predicateValue, + accessorValue, + mutatorValue); + }); + }); + + + installPrimitiveProcedure( + 'current-inspector', + makeList(0, 1), + function(MACHINE) { + if (MACHINE.argcount === 1) { + MACHINE.params['currentInspector'] = + checkInspector(MACHINE, 'current-inspector', 0); + return VOID; + } else { + return MACHINE.params['currentInspector']; + } + } + ); + + + installPrimitiveProcedure( + 'make-struct-field-accessor', + makeList(2, 3), + function(MACHINE){ + // FIXME: typechecks + // We must guarantee that the ref argument is good. + var structType = MACHINE.env[MACHINE.env.length - 1].structType; + var index = MACHINE.env[MACHINE.env.length - 2]; + var name; + if (MACHINE.argcount === 3) { + name = String(MACHINE.env[MACHINE.env.length - 3]); + } else { + name = 'field' + index; + } + return makePrimitiveProcedure( + name, + 1, + function(MACHINE) { + return structType.accessor( + MACHINE.env[MACHINE.env.length - 1], + plt.baselib.numbers.toFixnum(index)); + }); + + }); + + + installPrimitiveProcedure( + 'make-struct-field-mutator', + makeList(2, 3), + function(MACHINE){ + // FIXME: typechecks + // We must guarantee that the set! argument is good. + var structType = MACHINE.env[MACHINE.env.length - 1].structType; + var index = MACHINE.env[MACHINE.env.length - 2]; + var name; + if (MACHINE.argcount === 3) { + name = String(MACHINE.env[MACHINE.env.length - 3]); + } else { + name = 'field' + index; + } + return makePrimitiveProcedure( + name, + 2, + function(MACHINE) { + return structType.mutator( + MACHINE.env[MACHINE.env.length - 1], + plt.baselib.numbers.toFixnum(index), + MACHINE.env[MACHINE.env.length - 2]); + }); + }); + + + + exports['Primitives'] = Primitives; + exports['installPrimitiveProcedure'] = installPrimitiveProcedure; + exports['installPrimitiveClosure'] = installPrimitiveClosure; + exports['installPrimitiveConstant'] = installPrimitiveConstant; + +})(this['plt'].baselib); diff --git a/js-assembler/runtime-src/runtime.js b/js-assembler/runtime-src/runtime.js index 99e3d7a..5ea71be 100644 --- a/js-assembler/runtime-src/runtime.js +++ b/js-assembler/runtime-src/runtime.js @@ -54,6 +54,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; } var Closure = plt.baselib.functions.Closure; var finalizeClosureCall = plt.baselib.functions.finalizeClosureCall; var makePrimitiveProcedure = plt.baselib.functions.makePrimitiveProcedure; + var makeClosure = plt.baselib.functions.makeClosure; // Other helpers @@ -130,14 +131,73 @@ if(this['plt'] === undefined) { this['plt'] = {}; } - //////////////////////////////////////////////////////////////////////] - // The MACHINE + var Primitives = plt.baselib.primitives.Primitives; + var installPrimitiveProcedure = plt.baselib.primitives.installPrimitiveProcedure; + var installPrimitiveConstant = plt.baselib.primitives.installPrimitiveConstant; + var installPrimitiveClosure = plt.baselib.primitives.installPrimitiveClosure; + + + // This value will be dynamically determined. // See findStackLimit later in this file. var STACK_LIMIT_ESTIMATE = 100; + // Approximately find the stack limit. + // This function assumes, on average, five variables or + // temporaries per stack frame. + // This will never report a number greater than MAXIMUM_CAP. + var findStackLimit = function(after) { + var MAXIMUM_CAP = 32768; + var n = 1; + var limitDiscovered = false; + setTimeout( + function() { + if(! limitDiscovered) { + limitDiscovered = true; + after(n); + } + }, + 0); + var loop1 = function(x, y, z, w, k) { + // Ensure termination, just in case JavaScript ever + // does eliminate stack limits. + if (n >= MAXIMUM_CAP) { return; } + n++; + return 1 + loop2(y, z, w, k, x); + }; + var loop2 = function(x, y, z, w, k) { + n++; + return 1 + loop1(y, z, w, k, x); + }; + try { + var dontCare = 1 + loop1(2, "seven", [1], {number: 8}, 2); + } catch (e) { + // ignore exceptions. + } + if (! limitDiscovered) { + limitDiscovered = true; + after(n); + } + }; + + + // Schedule a stack limit estimation. If it fails, no harm, no + // foul (hopefully!) + setTimeout(function() { + findStackLimit(function(v) { + // Trying to be a little conservative. + STACK_LIMIT_ESTIMATE = Math.floor(v / 10); + }); + }, + 0); + + + + + //////////////////////////////////////////////////////////////////////] + // The MACHINE var Machine = function() { this.callsBeforeTrampoline = STACK_LIMIT_ESTIMATE; @@ -197,64 +257,14 @@ if(this['plt'] === undefined) { this['plt'] = {}; } }; this.primitives = Primitives; }; - - - - - // Approximately find the stack limit. - // This function assumes, on average, five variables or - // temporaries per stack frame. - // This will never report a number greater than MAXIMUM_CAP. - var findStackLimit = function(after) { - var MAXIMUM_CAP = 32768; - var n = 1; - var limitDiscovered = false; - setTimeout( - function() { - if(! limitDiscovered) { - limitDiscovered = true; - after(n); - } - }, - 0); - var loop1 = function(x, y, z, w, k) { - // Ensure termination, just in case JavaScript ever - // does eliminate stack limits. - if (n >= MAXIMUM_CAP) { return; } - n++; - return 1 + loop2(y, z, w, k, x); - }; - var loop2 = function(x, y, z, w, k) { - n++; - return 1 + loop1(y, z, w, k, x); - }; - try { - var dontCare = 1 + loop1(2, "seven", [1], {number: 8}, 2); - } catch (e) { - // ignore exceptions. - } - if (! limitDiscovered) { - limitDiscovered = true; - after(n); - } - }; - - - // Schedule a stack limit estimation. If it fails, no harm, no - // foul (hopefully!) - setTimeout(function() { - findStackLimit(function(v) { - // Trying to be a little conservative. - STACK_LIMIT_ESTIMATE = Math.floor(v / 10); - }); - }, - 0); + // captureControl implements the continuation-capturing part of // call/cc. It grabs the control frames up to (but not including) the // prompt tagged by the given tag. - var captureControl = function(MACHINE, skip, tag) { + Machine.prototype.captureControl = function(skip, tag) { + var MACHINE = this; var i; for (i = MACHINE.control.length - 1 - skip; i >= 0; i--) { if (MACHINE.control[i].tag === tag) { @@ -271,7 +281,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; } // prompt tagged by tag), and then appends the rest of the control frames. // At the moment, the rest of the control frames is assumed to be in the // top of the environment. - var restoreControl = function(MACHINE, tag) { + Machine.prototype.restoreControl = function(tag) { + var MACHINE = this; var i; for (i = MACHINE.control.length - 1; i >= 0; i--) { if (MACHINE.control[i].tag === tag) { @@ -288,7 +299,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; } // Splices the list argument in the environment. Adjusts MACHINE.argcount // appropriately. - var spliceListIntoStack = function(MACHINE, depth) { + Machine.prototype.spliceListIntoStack = function(depth) { + var MACHINE = this; var lst = MACHINE.env[MACHINE.env.length - 1 - depth]; var vals = []; while(lst !== NULL) { @@ -303,7 +315,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; } // Unsplices a list from the MACHINE stack. - var unspliceRestFromStack = function(MACHINE, depth, length) { + Machine.prototype.unspliceRestFromStack = function(depth, length) { + var MACHINE = this; var lst = NULL; var i; for (i = 0; i < length; i++) { @@ -365,7 +378,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; } // All evaluation in Racketland happens in the context of this // trampoline. // - var trampoline = function(MACHINE, initialJump) { + Machine.prototype.trampoline = function(initialJump) { + var MACHINE = this; var thunk = initialJump; var startTime = (new Date()).valueOf(); MACHINE.callsBeforeTrampoline = STACK_LIMIT_ESTIMATE; @@ -408,7 +422,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; } (new Date()).valueOf() - startTime); setTimeout( function() { - trampoline(MACHINE, thunk); + MACHINE.trampoline(thunk); }, 0); return; @@ -418,7 +432,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; } } else if (e instanceof Pause) { var restart = function(thunk) { setTimeout( - function() { trampoline(MACHINE, thunk); }, + function() { MACHINE.trampoline(thunk); }, 0); }; e.onPause(restart); @@ -455,7 +469,9 @@ if(this['plt'] === undefined) { this['plt'] = {}; } - var defaultCurrentPrint = new Closure( + var defaultCurrentPrint = makeClosure( + "default-printer", + 1, function(MACHINE) { if(--MACHINE.callsBeforeTrampoline < 0) { throw arguments.callee; @@ -471,10 +487,7 @@ if(this['plt'] === undefined) { this['plt'] = {}; } } MACHINE.argcount = oldArgcount; return finalizeClosureCall(MACHINE, VOID); - }, - 1, - [], - "printer"); + }); @@ -502,1464 +515,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; } - - - - // Primitives are the set of primitive values. Not all primitives - // are coded here; several of them (including call/cc) are injected by - // the bootstrapping code in compiler/boostrapped-primitives.rkt - var Primitives = {}; - - var installPrimitiveProcedure = function(name, arity, f) { - Primitives[name] = f; - Primitives[name].racketArity = arity; - Primitives[name].displayName = name; - }; - - var installPrimitiveClosure = function(name, arity, f) { - Primitives[name] = - new Closure(f, arity, [], name); - }; - - - var installPrimitiveConstant = function(name, v) { - Primitives[name] = v; - }; - - - - installPrimitiveConstant('pi', plt.baselib.numbers.pi); - installPrimitiveConstant('e', plt.baselib.numbers.e); - installPrimitiveConstant('null', NULL); - installPrimitiveConstant('true', true); - installPrimitiveConstant('false', false); - - - installPrimitiveProcedure( - 'display', makeList(1, 2), - function(MACHINE) { - var firstArg = MACHINE.env[MACHINE.env.length-1]; - var outputPort = MACHINE.params.currentOutputPort; - if (MACHINE.argcount === 2) { - outputPort = checkOutputPort(MACHINE, 'display', 1); - } - outputPort.writeDomNode(MACHINE, toDomNode(firstArg, 'display')); - return VOID; - }); - - - installPrimitiveProcedure( - 'write-byte', makeList(1, 2), - function(MACHINE) { - var firstArg = checkByte(MACHINE, 'write-byte', 0); - var outputPort = MACHINE.params.currentOutputPort; - if (MACHINE.argcount === 2) { - outputPort = checkOutputPort(MACHINE, 'display', 1); - } - outputPort.writeDomNode(MACHINE, toDomNode(String.fromCharCode(firstArg), 'display')); - return VOID; - }); - - - installPrimitiveProcedure( - 'newline', makeList(0, 1), - function(MACHINE) { - var outputPort = MACHINE.params.currentOutputPort; - if (MACHINE.argcount === 1) { - outputPort = checkOutputPort(MACHINE, 'newline', 1); - } - outputPort.writeDomNode(MACHINE, toDomNode("\n", 'display')); - return VOID; - }); - - installPrimitiveProcedure( - 'displayln', - makeList(1, 2), - function(MACHINE){ - var firstArg = MACHINE.env[MACHINE.env.length-1]; - var outputPort = MACHINE.params.currentOutputPort; - if (MACHINE.argcount === 2) { - outputPort = checkOutputPort(MACHINE, 'displayln', 1); - } - outputPort.writeDomNode(MACHINE, toDomNode(firstArg, 'display')); - outputPort.writeDomNode(MACHINE, toDomNode("\n", 'display')); - return VOID; - }); - - - - installPrimitiveProcedure( - 'format', - plt.baselib.arity.makeArityAtLeast(1), - function(MACHINE) { - var args = [], i, formatString; - formatString = checkString(MACHINE, 'format', 0).toString(); - for(i = 1; i < MACHINE.argcount; i++) { - args.push(MACHINE.env[MACHINE.env.length - 1 - i]); - } - return plt.baselib.format.format(formatString, args, 'format'); - }); - - - installPrimitiveProcedure( - 'printf', - plt.baselib.arity.makeArityAtLeast(1), - function(MACHINE) { - var args = [], i, formatString, result, outputPort; - formatString = checkString(MACHINE, 'printf', 0).toString(); - for(i = 1; i < MACHINE.argcount; i++) { - args.push(MACHINE.env[MACHINE.env.length - 1 - i]); - } - result = plt.baselib.format.format(formatString, args, 'format'); - outputPort = MACHINE.params.currentOutputPort; - outputPort.writeDomNode(MACHINE, toDomNode(result, 'display')); - return VOID; - }); - - - installPrimitiveProcedure( - 'fprintf', - plt.baselib.arity.makeArityAtLeast(2), - function(MACHINE) { - var args = [], i, formatString, outputPort, result; - outputPort = checkOutputPort(MACHINE, 'fprintf', 0); - formatString = checkString(MACHINE, 'fprintf', 1).toString(); - for(i = 2; i < MACHINE.argcount; i++) { - args.push(MACHINE.env[MACHINE.env.length - 1 - i]); - } - result = plt.baselib.format.format(formatString, args, 'format'); - outputPort.writeDomNode(MACHINE, toDomNode(result, 'display')); - return VOID; - }); - - - - - - - installPrimitiveProcedure( - 'current-print', - makeList(0, 1), - function(MACHINE) { - if (MACHINE.argcount === 1) { - MACHINE.params['currentPrint'] = - checkProcedure(MACHINE, 'current-print', 0); - return VOID; - } else { - return MACHINE.params['currentPrint']; - } - }); - - - installPrimitiveProcedure( - 'current-output-port', - makeList(0, 1), - function(MACHINE) { - if (MACHINE.argcount === 1) { - MACHINE.params['currentOutputPort'] = - checkOutputPort(MACHINE, 'current-output-port', 0); - return VOID; - } else { - return MACHINE.params['currentOutputPort']; - } - }); - - - - - - installPrimitiveProcedure( - '=', - plt.baselib.arity.makeArityAtLeast(2), - function(MACHINE) { - var firstArg = checkNumber(MACHINE, '=', 0), secondArg; - for (var i = 1; i < MACHINE.argcount; i++) { - var secondArg = checkNumber(MACHINE, '=', i); - if (! (plt.baselib.numbers.equals(firstArg, secondArg))) { - return false; - } - } - return true; - }); - - - - installPrimitiveProcedure( - '=~', - 3, - function(MACHINE) { - var x = checkReal(MACHINE, '=~', 0); - var y = checkReal(MACHINE, '=~', 1); - var range = checkNonNegativeReal(MACHINE, '=~', 2); - return plt.baselib.numbers.lessThanOrEqual( - plt.baselib.numbers.abs(plt.baselib.numbers.subtract(x, y)), - range); - }); - - - - var makeChainingBinop = function(predicate, name) { - return function(MACHINE) { - var firstArg = checkNumber(MACHINE, name, 0), secondArg; - for (var i = 1; i < MACHINE.argcount; i++) { - secondArg = checkNumber(MACHINE, name, i); - if (! (predicate(firstArg, secondArg))) { - return false; - } - firstArg = secondArg; - } - return true; - }; - }; - - installPrimitiveProcedure( - '<', - plt.baselib.arity.makeArityAtLeast(2), - makeChainingBinop(plt.baselib.numbers.lessThan, '<')); - - - installPrimitiveProcedure( - '>', - plt.baselib.arity.makeArityAtLeast(2), - makeChainingBinop(plt.baselib.numbers.greaterThan, '>')); - - - installPrimitiveProcedure( - '<=', - plt.baselib.arity.makeArityAtLeast(2), - makeChainingBinop(plt.baselib.numbers.lessThanOrEqual, '<=')); - - - installPrimitiveProcedure( - '>=', - plt.baselib.arity.makeArityAtLeast(2), - makeChainingBinop(plt.baselib.numbers.greaterThanOrEqual, '>=')); - - - installPrimitiveProcedure( - '+', - plt.baselib.arity.makeArityAtLeast(0), - function(MACHINE) { - var result = 0; - var i = 0; - for (i = 0; i < MACHINE.argcount; i++) { - result = plt.baselib.numbers.add( - result, - checkNumber(MACHINE, '+', i)); - }; - return result; - }); - - - installPrimitiveProcedure( - '*', - plt.baselib.arity.makeArityAtLeast(0), - function(MACHINE) { - var result = 1; - var i = 0; - for (i=0; i < MACHINE.argcount; i++) { - result = plt.baselib.numbers.multiply( - result, - checkNumber(MACHINE, '*', i)); - } - return result; - }); - - installPrimitiveProcedure( - '-', - plt.baselib.arity.makeArityAtLeast(1), - function(MACHINE) { - if (MACHINE.argcount === 1) { - return plt.baselib.numbers.subtract( - 0, - checkNumber(MACHINE, '-', 0)); - } - var result = checkNumber(MACHINE, '-', 0); - for (var i = 1; i < MACHINE.argcount; i++) { - result = plt.baselib.numbers.subtract( - result, - checkNumber(MACHINE, '-', i)); - } - return result; - }); - - installPrimitiveProcedure( - '/', - plt.baselib.arity.makeArityAtLeast(1), - function(MACHINE) { - var result = checkNumber(MACHINE, '/', 0); - for (var i = 1; i < MACHINE.argcount; i++) { - result = plt.baselib.numbers.divide( - result, - checkNumber(MACHINE, '/', i)); - } - return result; - }); - - - installPrimitiveProcedure( - 'add1', - 1, - function(MACHINE) { - var firstArg = checkNumber(MACHINE, 'add1', 0); - return plt.baselib.numbers.add(firstArg, 1); - }); - - - installPrimitiveProcedure( - 'sub1', - 1, - function(MACHINE) { - var firstArg = checkNumber(MACHINE, 'sub1', 0); - return plt.baselib.numbers.subtract(firstArg, 1); - }); - - - installPrimitiveProcedure( - 'zero?', - 1, - function(MACHINE) { - var firstArg = MACHINE.env[MACHINE.env.length-1]; - return plt.baselib.numbers.equals(firstArg, 0); - }); - - - installPrimitiveProcedure( - 'cons', - 2, - function(MACHINE) { - var firstArg = MACHINE.env[MACHINE.env.length-1]; - var secondArg = MACHINE.env[MACHINE.env.length-2]; - return makePair(firstArg, secondArg); - }); - - - installPrimitiveProcedure( - 'list', - plt.baselib.arity.makeArityAtLeast(0), - function(MACHINE) { - var result = NULL; - for (var i = 0; i < MACHINE.argcount; i++) { - result = makePair(MACHINE.env[MACHINE.env.length - (MACHINE.argcount - i)], - result); - } - return result; - }); - - installPrimitiveProcedure( - 'list*', - plt.baselib.arity.makeArityAtLeast(1), - function(MACHINE) { - var result = checkList(MACHINE, 'list*', MACHINE.argcount - 1); - for (var i = MACHINE.argcount - 2; i >= 0; i--) { - result = makePair(MACHINE.env[MACHINE.env.length - 1 - i], - result); - } - return result; - }); - - - installPrimitiveProcedure( - 'list-ref', - 2, - function(MACHINE) { - var lst = checkList(MACHINE, 'list-ref', 0); - var index = checkNaturalInRange(MACHINE, 'list-ref', 1, - 0, plt.baselib.lists.length(lst)); - return plt.baselib.lists.listRef(lst, plt.baselib.numbers.toFixnum(index)); - }); - - - - - installPrimitiveProcedure( - 'car', - 1, - function(MACHINE) { - var firstArg = checkPair(MACHINE, 'car', 0); - return firstArg.first; - }); - - installPrimitiveProcedure( - 'cdr', - 1, - function(MACHINE) { - var firstArg = checkPair(MACHINE, 'cdr', 0); - return firstArg.rest; - }); - - installPrimitiveProcedure( - 'pair?', - 1, - function(MACHINE) { - var firstArg = MACHINE.env[MACHINE.env.length-1]; - return isPair(firstArg); - }); - - - installPrimitiveProcedure( - 'list?', - 1, - function(MACHINE) { - return isList(MACHINE.env[MACHINE.env.length -1]); - }); - - - installPrimitiveProcedure( - 'set-car!', - 2, - function(MACHINE) { - var firstArg = checkPair(MACHINE, 'set-car!', 0); - var secondArg = MACHINE.env[MACHINE.env.length-2]; - firstArg.first = secondArg; - return VOID; - }); - - - installPrimitiveProcedure( - 'set-cdr!', - 2, - function(MACHINE) { - var firstArg = checkPair(MACHINE, 'set-car!', 0); - var secondArg = MACHINE.env[MACHINE.env.length-2]; - firstArg.rest = secondArg; - return VOID; - }); - - - installPrimitiveProcedure( - 'not', - 1, - function(MACHINE) { - var firstArg = MACHINE.env[MACHINE.env.length-1]; - return (firstArg === false); - }); - - - installPrimitiveProcedure( - 'null?', - 1, - function(MACHINE) { - var firstArg = MACHINE.env[MACHINE.env.length-1]; - return firstArg === NULL; - }); - - - installPrimitiveProcedure( - 'vector', - plt.baselib.arity.makeArityAtLeast(0), - function(MACHINE) { - var i; - var result = []; - for (i = 0; i < MACHINE.argcount; i++) { - result.push(MACHINE.env[MACHINE.env.length-1-i]); - } - var newVector = makeVector.apply(null, result); - return newVector; - }); - - - installPrimitiveProcedure( - 'vector->list', - 1, - function(MACHINE) { - var elts = checkVector(MACHINE, 'vector->list', 0).elts; - var i; - var result = NULL; - for (i = 0; i < elts.length; i++) { - result = makePair(elts[elts.length - 1 - i], result); - } - return result; - }); - - - installPrimitiveProcedure( - 'list->vector', - 1, - function(MACHINE) { - var firstArg = checkList(MACHINE, 'list->vector', 0); - var result = []; - while (firstArg !== NULL) { - result.push(firstArg.first); - firstArg = firstArg.rest; - } - return makeVector.apply(null, result); - }); - - - installPrimitiveProcedure( - 'vector-ref', - 2, - function(MACHINE) { - var elts = checkVector(MACHINE, 'vector-ref', 0).elts; - var index = MACHINE.env[MACHINE.env.length-2]; - return elts[index]; - }); - - - installPrimitiveProcedure( - 'vector-set!', - 3, - function(MACHINE) { - var elts = checkVector(MACHINE, 'vector-set!', 0).elts; - // FIXME: check out-of-bounds vector - var index = plt.baselib.numbers.toFixnum( - checkNaturalInRange(MACHINE, 'vector-set!', 1, - 0, elts.length)); - var val = MACHINE.env[MACHINE.env.length - 1 - 2]; - elts[index] = val; - return VOID; - }); - - - installPrimitiveProcedure( - 'vector-length', - 1, - function(MACHINE) { - return checkVector(MACHINE, 'vector-length', 0).elts.length; - }); - - - - installPrimitiveProcedure( - 'make-string', - makeList(1, 2), - function(MACHINE) { - var value = "\0"; - var length = plt.baselib.numbers.toFixnum( - checkNatural(MACHINE, 'make-string', 0)); - if (MACHINE.argcount == 2) { - value = checkChar(MACHINE, 'make-string', 1).val; - } - var arr = []; - for(var i = 0; i < length; i++) { - arr[i] = value; - } - return plt.baselib.strings.makeMutableString(arr); - }); - - - installPrimitiveProcedure( - 'string-set!', - 3, - function(MACHINE) { - var str = checkMutableString(MACHINE, 'string-set!', 0); - var k = checkNatural(MACHINE, 'string-set!', 1); - var ch = checkChar(MACHINE, 'string-set!', 2); - - }); - - - - installPrimitiveProcedure( - 'make-vector', - makeList(1, 2), - function(MACHINE) { - var value = 0; - var length = plt.baselib.numbers.toFixnum( - checkNatural(MACHINE, 'make-vector', 0)); - if (MACHINE.argcount == 2) { - value = MACHINE.env[MACHINE.env.length - 2]; - } - var arr = []; - for(var i = 0; i < length; i++) { - arr[i] = value; - } - return makeVector.apply(null, arr); - }); - - - - installPrimitiveProcedure( - 'symbol?', - 1, - function(MACHINE) { - var firstArg = MACHINE.env[MACHINE.env.length-1]; - return isSymbol(firstArg); - }); - - installPrimitiveProcedure( - 'symbol->string', - 1, - function(MACHINE) { - var firstArg = checkSymbol(MACHINE, 'symbol->string', 0); - return firstArg.toString(); - }); - - - installPrimitiveProcedure( - 'string=?', - plt.baselib.arity.makeArityAtLeast(1), - function(MACHINE) { - var s = checkString(MACHINE, 'string=?', 0).toString(); - for (var i = 1; i < MACHINE.argcount; i++) { - if (checkString(MACHINE, 'string=?', i).toString() !== s) { - return false; - } - } - return true; - }); - - - installPrimitiveProcedure( - 'string-append', - plt.baselib.arity.makeArityAtLeast(0), - function(MACHINE) { - var buffer = []; - var i; - for (i = 0; i < MACHINE.argcount; i++) { - buffer.push(checkString(MACHINE, 'string-append', i).toString()); - } - return buffer.join(''); - }); - - installPrimitiveProcedure( - 'string-length', - 1, - function(MACHINE) { - var firstArg = checkString(MACHINE, 'string-length', 0).toString(); - return firstArg.length; - }); - - - installPrimitiveProcedure( - 'string?', - 1, - function(MACHINE) { - return isString(MACHINE.env[MACHINE.env.length - 1]); - }); - - - installPrimitiveProcedure( - 'number->string', - 1, - function(MACHINE) { - return checkNumber(MACHINE, 'number->string', 0).toString(); - }); - - - installPrimitiveProcedure( - 'string->symbol', - 1, - function(MACHINE) { - return makeSymbol(checkString(MACHINE, 'string->symbol', 0).toString()); - }); - - - installPrimitiveProcedure( - 'string->number', - 1, - function(MACHINE) { - return plt.baselib.numbers.fromString( - checkString(MACHINE, 'string->number', 0).toString()); - }); - - - - - - installPrimitiveProcedure( - 'box', - 1, - function(MACHINE) { - var firstArg = MACHINE.env[MACHINE.env.length-1]; - return makeBox(firstArg); - }); - - installPrimitiveProcedure( - 'unbox', - 1, - function(MACHINE) { - var firstArg = checkBox(MACHINE, 'unbox', 0); - return firstArg.ref(); - }); - - installPrimitiveProcedure( - 'set-box!', - 2, - function(MACHINE) { - var firstArg = checkMutableBox(MACHINE, 'set-box!', 0); - var secondArg = MACHINE.env[MACHINE.env.length-2]; - firstArg.set(secondArg); - return VOID; - }); - - installPrimitiveProcedure( - 'void', - plt.baselib.arity.makeArityAtLeast(0), - function(MACHINE) { - return VOID; - }); - - - installPrimitiveProcedure( - 'random', - plt.baselib.lists.makeList(0, 1), - function(MACHINE) { - if (MACHINE.argcount === 0) { - return plt.baselib.numbers.makeFloat(Math.random()); - } else { - var n = checkNatural(MACHINE, 'random', 0); - return Math.floor(Math.random() * plt.baselib.numbers.toFixnum(n)); - } - }); - - - installPrimitiveProcedure( - 'eq?', - 2, - function(MACHINE) { - var firstArg = MACHINE.env[MACHINE.env.length-1]; - var secondArg = MACHINE.env[MACHINE.env.length-2]; - return firstArg === secondArg; - }); - - installPrimitiveProcedure( - 'eqv?', - 2, - function(MACHINE) { - var firstArg = MACHINE.env[MACHINE.env.length-1]; - var secondArg = MACHINE.env[MACHINE.env.length-2]; - return plt.baselib.equality.eqv(firstArg, secondArg); - }); - - - - installPrimitiveProcedure( - 'equal?', - 2, - function(MACHINE) { - var firstArg = MACHINE.env[MACHINE.env.length-1]; - var secondArg = MACHINE.env[MACHINE.env.length-2]; - return equals(firstArg, secondArg); - }); - - - // This definition of apply will take precedence over the - // implementation of apply in the boostrapped-primitives.rkt, - // since it provides nicer error handling. - installPrimitiveClosure( - 'apply', - plt.baselib.arity.makeArityAtLeast(2), - function(MACHINE) { - if(--MACHINE.callsBeforeTrampoline < 0) { - throw arguments.callee; - } - var proc = checkProcedure(MACHINE, 'apply', 0); - MACHINE.env.pop(); - MACHINE.argcount--; - checkList(MACHINE, 'apply', MACHINE.argcount - 1); - spliceListIntoStack(MACHINE, MACHINE.argcount - 1); - if (plt.baselib.arity.isArityMatching(proc.racketArity, MACHINE.argcount)) { - MACHINE.proc = proc; - if (plt.baselib.functions.isPrimitiveProcedure(proc)) { - return finalizeClosureCall(MACHINE, proc(MACHINE)); - } else { - return proc.label(MACHINE); - } - } else { - raiseArityMismatchError(MACHINE, proc, proc.racketArity, MACHINE.argcount); - } - }); - - - // FIXME: The definition of call-with-values is in - // bootstrapped-primitives.rkt. We may want to replace it with an - // explicitly defined one here. - - - - - - installPrimitiveProcedure( - 'procedure?', - 1, - function(MACHINE) { - return plt.baselib.functions.isProcedure(MACHINE.env[MACHINE.env.length - 1]); - }); - - installPrimitiveProcedure( - 'procedure-arity-includes?', - 2, - function(MACHINE) { - var proc = checkProcedure(MACHINE, 'procedure-arity-includes?', 0); - var argcount = checkNatural(MACHINE, 'procedure-arity-includes?', 1); - return plt.baselib.arity.isArityMatching(proc.racketArity, argcount); - }); - - installPrimitiveProcedure( - 'procedure-arity', - 1, - function(MACHINE) { - var proc = checkProcedure(MACHINE, 'procedure-arity-includes?', 0); - return proc.racketArity; - }); - - - installPrimitiveProcedure( - 'member', - 2, - function(MACHINE) { - var x = MACHINE.env[MACHINE.env.length-1]; - var lst = MACHINE.env[MACHINE.env.length-2]; - var originalLst = lst; - while (true) { - if (lst === NULL) { - return false; - } - if (! isPair(lst)) { - raiseArgumentTypeError(MACHINE, - 'member', - 'list', - 1, - MACHINE.env[MACHINE.env.length - 1 - 1]); - } - if (equals(x, (lst.first))) { - return lst; - } - lst = lst.rest; - } - }); - - - - installPrimitiveProcedure( - 'reverse', - 1, - function(MACHINE) { - var rev = NULL; - var lst = MACHINE.env[MACHINE.env.length-1]; - while(lst !== NULL) { - testArgument(MACHINE, - 'pair', isPair, lst, 0, 'reverse'); - rev = makePair(lst.first, rev); - lst = lst.rest; - } - return rev; - }); - - - - - installPrimitiveProcedure( - 'abs', - 1, - function(MACHINE) { - return plt.baselib.numbers.abs( - checkNumber(MACHINE, 'abs', 0)); - }); - - installPrimitiveProcedure( - 'acos', - 1, - function(MACHINE) { - return plt.baselib.numbers.acos( - checkNumber(MACHINE, 'acos', 0)); - }); - - - installPrimitiveProcedure( - 'asin', - 1, - function(MACHINE) { - return plt.baselib.numbers.asin( - checkNumber(MACHINE, 'asin', 0)); - }); - - installPrimitiveProcedure( - 'sin', - 1, - function(MACHINE) { - return plt.baselib.numbers.sin( - checkNumber(MACHINE, 'sin', 0)); - }); - - - - installPrimitiveProcedure( - 'sinh', - 1, - function(MACHINE) { - return plt.baselib.numbers.sinh( - checkNumber(MACHINE, 'sinh', 0)); - }); - - - installPrimitiveProcedure( - 'tan', - 1, - function(MACHINE) { - return plt.baselib.numbers.tan( - checkNumber(MACHINE, 'tan', 0)); - }); - - - - installPrimitiveProcedure( - 'atan', - makeList(1, 2), - function(MACHINE) { - if (MACHINE.argcount === 1) { - return plt.baselib.numbers.atan( - checkNumber(MACHINE, 'atan', 0)); - } else { - testArgument(MACHINE, - 'number', - isNumber, - MACHINE.env[MACHINE.env.length - 1], - 0, - 'atan'); - testArgument(MACHINE, - 'number', - isNumber, - MACHINE.env[MACHINE.env.length - 2], - 1, - 'atan'); - return plt.baselib.numbers.makeFloat( - Math.atan2( - plt.baselib.numbers.toFixnum(checkNumber(MACHINE, 'atan', 0)), - plt.baselib.numbers.toFixnum(checkNumber(MACHINE, 'atan', 1)))); - } - }); - - - installPrimitiveProcedure( - 'angle', - 1, - function(MACHINE) { - return plt.baselib.numbers.angle( - checkNumber(MACHINE, 'angle', 0)); - }); - - installPrimitiveProcedure( - 'magnitude', - 1, - function(MACHINE) { - return plt.baselib.numbers.magnitude( - checkNumber(MACHINE, 'magnitude', 0)); - }); - - installPrimitiveProcedure( - 'conjugate', - 1, - function(MACHINE) { - return plt.baselib.numbers.conjugate( - checkNumber(MACHINE, 'conjugate', 0)); - }); - - - - - installPrimitiveProcedure( - 'cos', - 1, - function(MACHINE) { - return plt.baselib.numbers.cos( - checkNumber(MACHINE, 'cos', 0)); - }); - - - installPrimitiveProcedure( - 'cosh', - 1, - function(MACHINE) { - return plt.baselib.numbers.cosh( - checkNumber(MACHINE, 'cosh', 0)); - }); - - installPrimitiveProcedure( - 'gcd', - plt.baselib.arity.makeArityAtLeast(1), - function(MACHINE) { - var args = [], i, x; - for (i = 0; i < MACHINE.argcount; i++) { - args.push(checkNumber(MACHINE, 'gcd', i)); - } - x = args.shift(); - return plt.baselib.numbers.gcd(x, args); - }); - - installPrimitiveProcedure( - 'lcm', - plt.baselib.arity.makeArityAtLeast(1), - function(MACHINE) { - var args = [], i, x; - for (i = 0; i < MACHINE.argcount; i++) { - args.push(checkNumber(MACHINE, 'lcm', i)); - } - x = args.shift(); - return plt.baselib.numbers.lcm(x, args); - }); - - - - - installPrimitiveProcedure( - 'exp', - 1, - function(MACHINE) { - return plt.baselib.numbers.exp( - checkNumber(MACHINE, 'exp', 0)); - }); - - - installPrimitiveProcedure( - 'expt', - 2, - function(MACHINE) { - return plt.baselib.numbers.expt( - checkNumber(MACHINE, 'expt', 0), - checkNumber(MACHINE, 'expt', 1)); - }); - - installPrimitiveProcedure( - 'exact?', - 1, - function(MACHINE) { - return plt.baselib.numbers.isExact( - checkNumber(MACHINE, 'exact?', 0)); - }); - - - installPrimitiveProcedure( - 'integer?', - 1, - function(MACHINE) { - return plt.baselib.numbers.isInteger(MACHINE.env[MACHINE.env.length - 1]); - }); - - - installPrimitiveProcedure( - 'exact-nonnegative-integer?', - 1, - function(MACHINE) { - return plt.baselib.numbers.isNatural(MACHINE.env[MACHINE.env.length - 1]); - }); - - - - installPrimitiveProcedure( - 'imag-part', - 1, - function(MACHINE) { - return plt.baselib.numbers.imaginaryPart( - checkNumber(MACHINE, 'imag-part', 0)); - }); - - - installPrimitiveProcedure( - 'real-part', - 1, - function(MACHINE) { - return plt.baselib.numbers.realPart( - checkNumber(MACHINE, 'real-part', 0)); - }); - - - installPrimitiveProcedure( - 'make-polar', - 2, - function(MACHINE) { - return plt.baselib.numbers.makeComplexPolar( - checkReal(MACHINE, 'make-polar', 0), - checkReal(MACHINE, 'make-polar', 1)); - }); - - - installPrimitiveProcedure( - 'make-rectangular', - 2, - function(MACHINE) { - return plt.baselib.numbers.makeComplex( - checkReal(MACHINE, 'make-rectangular', 0), - checkReal(MACHINE, 'make-rectangular', 1)); - }); - - installPrimitiveProcedure( - 'modulo', - 2, - function(MACHINE) { - return plt.baselib.numbers.modulo( - checkInteger(MACHINE, 'modulo', 0), - checkInteger(MACHINE, 'modulo', 1)); - }); - - - installPrimitiveProcedure( - 'remainder', - 2, - function(MACHINE) { - return plt.baselib.numbers.remainder( - checkInteger(MACHINE, 'remainder', 0), - checkInteger(MACHINE, 'remainder', 1)); - }); - - - installPrimitiveProcedure( - 'quotient', - 2, - function(MACHINE) { - return plt.baselib.numbers.quotient( - checkInteger(MACHINE, 'quotient', 0), - checkInteger(MACHINE, 'quotient', 1)); - }); - - - - installPrimitiveProcedure( - 'floor', - 1, - function(MACHINE) { - return plt.baselib.numbers.floor( - checkReal(MACHINE, 'floor', 0)); - }); - - - installPrimitiveProcedure( - 'ceiling', - 1, - function(MACHINE) { - return plt.baselib.numbers.ceiling( - checkReal(MACHINE, 'ceiling', 0)); - }); - - - installPrimitiveProcedure( - 'round', - 1, - function(MACHINE) { - return plt.baselib.numbers.round( - checkReal(MACHINE, 'round', 0)); - }); - - - installPrimitiveProcedure( - 'truncate', - 1, - function(MACHINE) { - var n = checkReal(MACHINE, 'truncate', 0); - if (plt.baselib.numbers.lessThan(n, 0)) { - return plt.baselib.numbers.ceiling(n); - } else { - return plt.baselib.numbers.floor(n); - } - }); - - - installPrimitiveProcedure( - 'numerator', - 1, - function(MACHINE) { - return plt.baselib.numbers.numerator( - checkRational(MACHINE, 'numerator', 0)); - }); - - - installPrimitiveProcedure( - 'denominator', - 1, - function(MACHINE) { - return plt.baselib.numbers.denominator( - checkRational(MACHINE, 'denominator', 0)); - }); - - - installPrimitiveProcedure( - 'log', - 1, - function(MACHINE) { - return plt.baselib.numbers.log( - checkNumber(MACHINE, 'log', 0)); - }); - - - installPrimitiveProcedure( - 'sqr', - 1, - function(MACHINE) { - return plt.baselib.numbers.sqr( - checkNumber(MACHINE, 'sqr', 0)); - }); - - - - - installPrimitiveProcedure( - 'sqrt', - 1, - function(MACHINE) { - return plt.baselib.numbers.sqrt( - checkNumber(MACHINE, 'sqrt', 0)); - }); - - - - installPrimitiveProcedure( - 'integer-sqrt', - 1, - function(MACHINE) { - return plt.baselib.numbers.integerSqrt( - checkInteger(MACHINE, 'integer-sqrt', 0)); - }); - - - - installPrimitiveProcedure( - 'sgn', - 1, - function(MACHINE) { - return plt.baselib.numbers.sign( - checkInteger(MACHINE, 'sgn', 0)); - }); - - - - installPrimitiveProcedure( - 'error', - plt.baselib.arity.makeArityAtLeast(1), - function(MACHINE) { - if (MACHINE.argcount === 1) { - var sym = checkSymbol(MACHINE, 'error', 1); - // FIXME: we should collect the current continuation marks here... - raise(MACHINE, plt.baselib.exceptions.makeExnFail(String(sym), undefined)); - } - - if (isString(MACHINE.env[MACHINE.env.length - 1])) { - var vs = []; - for (var i = 1; i < MACHINE.argcount; i++) { - vs.push(plt.baselib.format.format("~e", [MACHINE.env[MACHINE.env.length - 1 - i]])); - } - raise(MACHINE, plt.baselib.exceptions.makeExnFail(String(MACHINE.env[MACHINE.env.length - 1]) + - ": " + - vs.join(' '), - undefined)); - } - - if (isSymbol(MACHINE.env[MACHINE.env.length - 1])) { - var fmtString = checkString(MACHINE, 'error', 1); - var args = [MACHINE.env[MACHINE.env.length - 1]]; - for (i = 2; i < MACHINE.argcount; i++) { - args.push(MACHINE.env[MACHINE.env.length - 1 - i]); - } - raise(MACHINE, plt.baselib.exceptions.makeExnFail( - plt.baselib.format.format('~s: ' + String(fmtString), - args), - undefined)); - } - - // Fall-through - raiseArgumentTypeError(MACHINE, 'error', 'symbol or string', 0, MACHINE.env[MACHINE.env.length - 1]); - }); - - - installPrimitiveProcedure( - 'raise-mismatch-error', - 3, - function(MACHINE) { - var name = checkSymbol(MACHINE, 'raise-mismatch-error', 0); - var message = checkString(MACHINE, 'raise-mismatch-error', 0); - var val = MACHINE.env[MACHINE.env.length - 1 - 2]; - raise(MACHINE, plt.baselib.exceptions.makeExnFail - (plt.baselib.format.format("~a: ~a~e", - [name, - message, - val]), - undefined)); - }); - - - installPrimitiveProcedure( - 'raise-type-error', - plt.baselib.arity.makeArityAtLeast(3), - function(MACHINE) { - var name = checkSymbol(MACHINE, 'raise-type-error', 0); - var expected = checkString(MACHINE, 'raise-type-error', 1); - if (MACHINE.argcount === 3) { - raiseArgumentTypeError(MACHINE, - name, - expected, - undefined, - MACHINE.env[MACHINE.env.length - 1 - 2]); - } else { - raiseArgumentTypeError(MACHINE, - name, - expected, - checkNatural(MACHINE, 'raise-type-error', 2), - MACHINE.env[MACHINE.env.length - 1 - 2]); - } - }); - - - - - installPrimitiveClosure( - 'make-struct-type', - makeList(4, 5, 6, 7, 8, 9, 10, 11), - function(MACHINE) { - withArguments( - MACHINE, - 4, - [false, - NULL, - false, - false, - NULL, - false, - false], - function(name, - superType, - initFieldCount, - autoFieldCount, - autoV, - props, // FIXME: currently ignored - inspector, // FIXME: currently ignored - procSpec, // FIXME: currently ignored - immutables, // FIXME: currently ignored - guard, // FIXME: currently ignored - constructorName - ) { - - // FIXME: typechecks. - - var structType = plt.baselib.structs.makeStructureType( - name, - superType, - initFieldCount, - autoFieldCount, - autoV, - //props, - //inspector, - //procSpec, - //immutables, - guard); - - var constructorValue = - makePrimitiveProcedure( - constructorName, - plt.baselib.numbers.toFixnum(initFieldCount), - function(MACHINE) { - var args = []; - for(var i = 0; i < initFieldCount; i++) { - args.push(MACHINE.env[MACHINE.env.length - 1 - i]); - } - return structType.constructor.apply(null, args); - }); - - var predicateValue = - makePrimitiveProcedure( - String(name) + "?", - 1, - function(MACHINE) { - return structType.predicate(MACHINE.env[MACHINE.env.length - 1]); - }); - - var accessorValue = - makePrimitiveProcedure( - String(name) + "-accessor", - 2, - function(MACHINE) { - // FIXME: typechecks - return structType.accessor( - MACHINE.env[MACHINE.env.length - 1], - plt.baselib.numbers.toFixnum(MACHINE.env[MACHINE.env.length - 2])); - }); - accessorValue.structType = structType; - - var mutatorValue = - makePrimitiveProcedure( - String(name) + "-mutator", - 3, - function(MACHINE) { - // FIXME: typechecks - return structType.mutator( - MACHINE.env[MACHINE.env.length - 1], - plt.baselib.numbers.toFixnum(MACHINE.env[MACHINE.env.length - 2]), - MACHINE.env[MACHINE.env.length - 3]); - }); - mutatorValue.structType = structType; - - - finalizeClosureCall(MACHINE, - structType, - constructorValue, - predicateValue, - accessorValue, - mutatorValue); - }); - }); - - - installPrimitiveProcedure( - 'current-inspector', - makeList(0, 1), - function(MACHINE) { - if (MACHINE.argcount === 1) { - MACHINE.params['currentInspector'] = - checkInspector(MACHINE, 'current-inspector', 0); - return VOID; - } else { - return MACHINE.params['currentInspector']; - } - } - ); - - - installPrimitiveProcedure( - 'make-struct-field-accessor', - makeList(2, 3), - function(MACHINE){ - // FIXME: typechecks - // We must guarantee that the ref argument is good. - var structType = MACHINE.env[MACHINE.env.length - 1].structType; - var index = MACHINE.env[MACHINE.env.length - 2]; - var name; - if (MACHINE.argcount === 3) { - name = String(MACHINE.env[MACHINE.env.length - 3]); - } else { - name = 'field' + index; - } - return makePrimitiveProcedure( - name, - 1, - function(MACHINE) { - return structType.accessor( - MACHINE.env[MACHINE.env.length - 1], - plt.baselib.numbers.toFixnum(index)); - }); - - }); - - - installPrimitiveProcedure( - 'make-struct-field-mutator', - makeList(2, 3), - function(MACHINE){ - // FIXME: typechecks - // We must guarantee that the set! argument is good. - var structType = MACHINE.env[MACHINE.env.length - 1].structType; - var index = MACHINE.env[MACHINE.env.length - 2]; - var name; - if (MACHINE.argcount === 3) { - name = String(MACHINE.env[MACHINE.env.length - 3]); - } else { - name = 'field' + index; - } - return makePrimitiveProcedure( - name, - 2, - function(MACHINE) { - return structType.mutator( - MACHINE.env[MACHINE.env.length - 1], - plt.baselib.numbers.toFixnum(index), - MACHINE.env[MACHINE.env.length - 2]); - }); - }); - - - - ////////////////////////////////////////////////////////////////////// @@ -2059,7 +616,6 @@ if(this['plt'] === undefined) { this['plt'] = {}; } // installing new primitives exports['installPrimitiveProcedure'] = installPrimitiveProcedure; - exports['installPrimitiveClosure'] = installPrimitiveClosure; exports['makePrimitiveProcedure'] = makePrimitiveProcedure; exports['Primitives'] = Primitives; @@ -2107,14 +663,6 @@ if(this['plt'] === undefined) { this['plt'] = {}; } exports['raiseUnimplementedPrimitiveError'] = raiseUnimplementedPrimitiveError; - exports['captureControl'] = captureControl; - exports['restoreControl'] = restoreControl; - - exports['trampoline'] = trampoline; - exports['spliceListIntoStack'] = spliceListIntoStack; - exports['unspliceRestFromStack'] = unspliceRestFromStack; - - exports['finalizeClosureCall'] = finalizeClosureCall; From 3b427f06c389c51627783b4353a95cb1b29cf078 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 7 Aug 2011 20:41:36 -0400 Subject: [PATCH 12/30] turning on 'use strict' --- js-assembler/get-runtime.rkt | 3 + js-assembler/runtime-src/baselib-chars.js | 2 +- js-assembler/runtime-src/baselib-contmarks.js | 15 ++- js-assembler/runtime-src/baselib-lists.js | 2 +- js-assembler/runtime-src/baselib-vectors.js | 2 +- js-assembler/runtime-src/runtime.js | 95 +++++++++---------- js-assembler/runtime-src/top.js | 1 + 7 files changed, 68 insertions(+), 52 deletions(-) create mode 100644 js-assembler/runtime-src/top.js diff --git a/js-assembler/get-runtime.rkt b/js-assembler/get-runtime.rkt index 3b9a53f..92ab815 100644 --- a/js-assembler/get-runtime.rkt +++ b/js-assembler/get-runtime.rkt @@ -30,6 +30,8 @@ ;; the other modules below have some circular dependencies that are resolved ;; by link. (define files '( + top.js + ;; jquery is special: we need to make sure it's resilient against ;; multiple invokation and inclusion. jquery-protect-header.js @@ -65,6 +67,7 @@ baselib-ports.js baselib-functions.js baselib-modules.js + baselib-contmarks.js baselib-arity.js baselib-inspectors.js diff --git a/js-assembler/runtime-src/baselib-chars.js b/js-assembler/runtime-src/baselib-chars.js index 7e555cf..de6bf90 100644 --- a/js-assembler/runtime-src/baselib-chars.js +++ b/js-assembler/runtime-src/baselib-chars.js @@ -6,7 +6,7 @@ // Chars // Char: string -> Char - Char = function(val){ + var Char = function(val){ this.val = val; }; // The characters less than 256 must be eq?, according to the diff --git a/js-assembler/runtime-src/baselib-contmarks.js b/js-assembler/runtime-src/baselib-contmarks.js index b1711ae..7293983 100644 --- a/js-assembler/runtime-src/baselib-contmarks.js +++ b/js-assembler/runtime-src/baselib-contmarks.js @@ -29,7 +29,20 @@ return []; }; - exports.ContinuationMarkSet = ContinuationMarkSet; + + // A continuation prompt tag labels a prompt frame. + var ContinuationPromptTag = function(name) { + this.name = name; + }; + + + + + + + exports.ContinuationMarkSet = ContinuationMarkSet; + exports.ContinuationPromptTag = ContinuationPromptTag; + })(this['plt'].baselib); \ No newline at end of file diff --git a/js-assembler/runtime-src/baselib-lists.js b/js-assembler/runtime-src/baselib-lists.js index fdbf4e5..99cca42 100644 --- a/js-assembler/runtime-src/baselib-lists.js +++ b/js-assembler/runtime-src/baselib-lists.js @@ -7,7 +7,7 @@ - Empty = function() { + var Empty = function() { }; Empty.EMPTY = new Empty(); var EMPTY = Empty.EMPTY; diff --git a/js-assembler/runtime-src/baselib-vectors.js b/js-assembler/runtime-src/baselib-vectors.js index 4746900..f292884 100644 --- a/js-assembler/runtime-src/baselib-vectors.js +++ b/js-assembler/runtime-src/baselib-vectors.js @@ -5,7 +5,7 @@ - Vector = function(n, initialElements) { + var Vector = function(n, initialElements) { this.elts = new Array(n); if (initialElements) { for (var i = 0; i < n; i++) { diff --git a/js-assembler/runtime-src/runtime.js b/js-assembler/runtime-src/runtime.js index 5ea71be..7b156a3 100644 --- a/js-assembler/runtime-src/runtime.js +++ b/js-assembler/runtime-src/runtime.js @@ -56,6 +56,8 @@ if(this['plt'] === undefined) { this['plt'] = {}; } var makePrimitiveProcedure = plt.baselib.functions.makePrimitiveProcedure; var makeClosure = plt.baselib.functions.makeClosure; + var ContinuationPromptTag = plt.baselib.contmarks.ContinuationPromptTag; + // Other helpers var withArguments = plt.baselib.withArguments; @@ -330,38 +332,6 @@ if(this['plt'] === undefined) { this['plt'] = {}; } }; - - // recomputeGas: state number -> number - var recomputeMaxNumBouncesBeforeYield = function(MACHINE, observedDelay) { - // We'd like to see a delay of DESIRED_DELAY_BETWEEN_BOUNCES so - // that we get MACHINE.params.desiredYieldsPerSecond bounces per - // second. - var DESIRED_DELAY_BETWEEN_BOUNCES = - (1000 / MACHINE.params.desiredYieldsPerSecond); - var ALPHA = 50; - var delta = (ALPHA * ((DESIRED_DELAY_BETWEEN_BOUNCES - - observedDelay) / - DESIRED_DELAY_BETWEEN_BOUNCES)); - MACHINE.params.maxNumBouncesBeforeYield = - Math.max(MACHINE.params.maxNumBouncesBeforeYield + delta, - 1); - }; - - - var HaltError = function(onHalt) { - // onHalt: MACHINE -> void - this.onHalt = onHalt || function(MACHINE) {}; - }; - - - var Pause = function(onPause) { - // onPause: MACHINE -> void - this.onPause = onPause || function(MACHINE) {}; - }; - - var PAUSE = function(onPause) { - throw(new Pause(onPause)); - }; @@ -457,6 +427,44 @@ if(this['plt'] === undefined) { this['plt'] = {}; } return; }; + // recomputeGas: state number -> number + var recomputeMaxNumBouncesBeforeYield = function(MACHINE, observedDelay) { + // We'd like to see a delay of DESIRED_DELAY_BETWEEN_BOUNCES so + // that we get MACHINE.params.desiredYieldsPerSecond bounces per + // second. + var DESIRED_DELAY_BETWEEN_BOUNCES = + (1000 / MACHINE.params.desiredYieldsPerSecond); + var ALPHA = 50; + var delta = (ALPHA * ((DESIRED_DELAY_BETWEEN_BOUNCES - + observedDelay) / + DESIRED_DELAY_BETWEEN_BOUNCES)); + MACHINE.params.maxNumBouncesBeforeYield = + Math.max(MACHINE.params.maxNumBouncesBeforeYield + delta, + 1); + }; + + + + // These are exception values that are treated specially in the context + // of the trampoline. + + var HaltError = function(onHalt) { + // onHalt: MACHINE -> void + this.onHalt = onHalt || function(MACHINE) {}; + }; + + + var Pause = function(onPause) { + // onPause: MACHINE -> void + this.onPause = onPause || function(MACHINE) {}; + }; + + var PAUSE = function(onPause) { + throw(new Pause(onPause)); + }; + + + ////////////////////////////////////////////////////////////////////// @@ -491,22 +499,6 @@ if(this['plt'] === undefined) { this['plt'] = {}; } - - - var VariableReference = function(prefix, pos) { - this.prefix = prefix; - this.pos = pos; - }; - - - - // A continuation prompt tag labels a prompt frame. - var ContinuationPromptTag = function(name) { - this.name = name; - }; - - - // There is a single, distinguished default continuation prompt tag // that's used to wrap around toplevel prompts. var DEFAULT_CONTINUATION_PROMPT_TAG = @@ -523,6 +515,13 @@ if(this['plt'] === undefined) { this['plt'] = {}; } ////////////////////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////// + var VariableReference = function(prefix, pos) { + this.prefix = prefix; + this.pos = pos; + }; + + + diff --git a/js-assembler/runtime-src/top.js b/js-assembler/runtime-src/top.js new file mode 100644 index 0000000..3918c74 --- /dev/null +++ b/js-assembler/runtime-src/top.js @@ -0,0 +1 @@ +"use strict"; From 0d6af5f66a3274ebeea0626fb1b1c2b247e9785d Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 7 Aug 2011 20:51:00 -0400 Subject: [PATCH 13/30] use strict --- image/private/kernel.js | 2 +- js-assembler/package.rkt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/image/private/kernel.js b/image/private/kernel.js index d24b96a..1630b38 100644 --- a/image/private/kernel.js +++ b/image/private/kernel.js @@ -391,7 +391,7 @@ var VideoImage = function(src, rawVideo) { VideoImage.prototype = heir(BaseImage.prototype); -videos = {}; +var videos = {}; VideoImage.makeInstance = function(path, rawVideo) { if (! (path in VideoImage)) { videos[path] = new VideoImage(path, rawVideo); diff --git a/js-assembler/package.rkt b/js-assembler/package.rkt index 49afab1..c544001 100644 --- a/js-assembler/package.rkt +++ b/js-assembler/package.rkt @@ -333,7 +333,7 @@ MACHINE.modules[~s] = Example