diff --git a/bootstrapped-primitives.rkt b/bootstrapped-primitives.rkt index 241d12b..23ac492 100644 --- a/bootstrapped-primitives.rkt +++ b/bootstrapped-primitives.rkt @@ -43,7 +43,8 @@ 1 ;; the continuation consumes a single value (list 0 1) 'call/cc)) - ,(make-PopEnvironment 2 0))) + ,(make-PopEnvironment 2 0) + ,(make-AssignImmediateStatement 'argcount (make-Const 1)))) ;; Finally, do a tail call into f. (compile-general-procedure-call '() diff --git a/compile.rkt b/compile.rkt index fd29df4..4b9043b 100644 --- a/compile.rkt +++ b/compile.rkt @@ -468,6 +468,9 @@ empty-instruction-sequence) proc-code (juggle-operands operand-codes) + (make-instruction-sequence `(,(make-AssignImmediateStatement + 'argcount + (make-Const (length (App-operands exp)))))) (compile-general-procedure-call cenv (length extended-cenv) (length (App-operands exp)) @@ -784,6 +787,7 @@ -> InstructionSequence)) ;; Assumes the procedure value has been loaded into the proc register. +;; and the # of values passed in has been written into argcount. ;; n is the number of arguments passed in. ;; cenv is the compile-time enviroment before arguments have been shifted in. ;; extended-cenv is the compile-time environment after arguments have been shifted in. @@ -804,8 +808,7 @@ ;; Compiled branch (LabelLinkage-label compiled-branch) (make-instruction-sequence - `(,(make-AssignImmediateStatement 'val (make-Const number-of-arguments)) - ,(make-PerformStatement (make-CheckClosureArity! (make-Reg 'val))))) + `(,(make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount))))) (compile-procedure-application extended-cenv-length (make-Reg 'val) number-of-arguments @@ -1189,6 +1192,8 @@ target] [(eq? target 'proc) target] + [(eq? target 'argcount) + target] [(EnvLexicalReference? target) (make-EnvLexicalReference (+ n (EnvLexicalReference-depth target)) (EnvLexicalReference-unbox? target))] diff --git a/il-structs.rkt b/il-structs.rkt index fa7f418..f180b48 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -11,7 +11,7 @@ ;; Registers of the machine: (define-type StackRegisterSymbol (U 'control 'env)) -(define-type AtomicRegisterSymbol (U 'val 'proc)) +(define-type AtomicRegisterSymbol (U 'val 'proc 'argcount)) (define-type RegisterSymbol (U StackRegisterSymbol AtomicRegisterSymbol)) (define-predicate AtomicRegisterSymbol? AtomicRegisterSymbol)