diff --git a/assemble.rkt b/assemble.rkt index 6611f05..ce6acce 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -402,8 +402,7 @@ EOF (CheckToplevelBound!-pos op))] [(CheckClosureArity!? op) - (format "if (! (MACHINE.proc instanceof RUNTIME.Closure && MACHINE.proc.arity === ~a)) { if (! (MACHINE.proc instanceof RUNTIME.Closure)) { throw new Error(\"not a closure\"); } else { throw new Error(\"arity failure\"); } }" - (CheckClosureArity!-arity op))] + (format "if (! (MACHINE.proc instanceof RUNTIME.Closure && MACHINE.proc.arity === MACHINE.val)) { if (! (MACHINE.proc instanceof RUNTIME.Closure)) { throw new Error(\"not a closure\"); } else { throw new Error(\"arity failure\"); } }")] [(ExtendEnvironment/Prefix!? op) (let: ([names : (Listof (U Symbol False ModuleVariable)) (ExtendEnvironment/Prefix!-names op)]) diff --git a/compile.rkt b/compile.rkt index 5afc06b..341b6cb 100644 --- a/compile.rkt +++ b/compile.rkt @@ -208,6 +208,7 @@ (: compile-constant (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-constant exp cenv target linkage) + ;; Compiles constant values. (end-with-linkage linkage cenv (make-instruction-sequence @@ -217,6 +218,7 @@ (: compile-local-reference (LocalRef CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-local-reference exp cenv target linkage) + ;; Compiles local references. (end-with-linkage linkage cenv (make-instruction-sequence @@ -227,6 +229,7 @@ (: compile-toplevel-reference (ToplevelRef CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiles toplevel references. (define (compile-toplevel-reference exp cenv target linkage) (end-with-linkage linkage cenv @@ -241,6 +244,7 @@ (: compile-toplevel-set (ToplevelSet CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiles toplevel definition. (define (compile-toplevel-set exp cenv target linkage) (let* ([var (ToplevelSet-name exp)] [lexical-pos (make-EnvPrefixReference (ToplevelSet-depth exp) @@ -257,6 +261,7 @@ (: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiles a conditional branch. (define (compile-branch exp cenv target linkage) (let: ([t-branch : LabelLinkage (make-LabelLinkage (make-label 'trueBranch))] [f-branch : LabelLinkage (make-LabelLinkage (make-label 'falseBranch))] @@ -281,6 +286,7 @@ (: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Compiles a sequence of expressions. The last expression will be compiled in the provided linkage. (define (compile-sequence seq cenv target linkage) ;; All but the last will use next-linkage linkage. (if (last-exp? seq) @@ -290,7 +296,8 @@ (: compile-splice ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) -;; Wrap a continuation prompt around each of the expressions. +;; Compiles a sequence of expressions. A continuation prompt wraps around each of the expressions +;; to delimit any continuation captures. (define (compile-splice seq cenv target linkage) (cond [(last-exp? seq) (let ([before-pop-prompt (make-label 'beforePromptPop)]) @@ -349,6 +356,7 @@ (: compile-lambda-body (Lam CompileTimeEnvironment -> InstructionSequence)) ;; Compiles the body of the lambda in the appropriate environment. +;; Closures will target their value to the 'val register, and use return linkage. (define (compile-lambda-body exp cenv) (append-instruction-sequences @@ -363,7 +371,6 @@ (append (map (lambda: ([d : Natural]) (list-ref cenv d)) (Lam-closure-map exp)) - ;; fixme: We need to capture the cenv so we can maintain static knowledge (build-list (Lam-num-parameters exp) (lambda: ([i : Natural]) '?))) 'val return-linkage))) @@ -381,12 +388,15 @@ (lam+cenv-cenv (first exps))) (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)) + + (: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Compiles procedure application ;; Special cases: if we know something about the operator, the compiler will special case. @@ -794,8 +804,9 @@ ;; Compiled branch (LabelLinkage-label compiled-branch) (make-instruction-sequence - `(,(make-PerformStatement (make-CheckClosureArity! n)))) - (compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage) + `(,(make-AssignImmediateStatement 'val (make-Const n)) + ,(make-PerformStatement (make-CheckClosureArity!)))) + (compile-procedure-application extended-cenv (make-Reg 'val) n target compiled-linkage) @@ -826,7 +837,7 @@ linkage after-call)]) (append-instruction-sequences - (compile-proc-appl extended-cenv + (compile-procedure-application extended-cenv (make-Label (StaticallyKnownLam-entry-point static-knowledge)) n target @@ -838,12 +849,12 @@ -(: compile-proc-appl (CompileTimeEnvironment (U Label Reg) Natural Target Linkage -> InstructionSequence)) +(: compile-procedure-application (CompileTimeEnvironment (U Label Reg) Natural Target Linkage -> InstructionSequence)) ;; Three fundamental cases for general compiled-procedure application. ;; 1. Tail calls. ;; 2. Non-tail calls (next/label linkage) that write to val ;; 3. Calls in argument position (next/label linkage) that write to the stack. -(define (compile-proc-appl cenv-with-args entry-point n target linkage) +(define (compile-procedure-application cenv-with-args entry-point n target linkage) (cond [(ReturnLinkage? linkage) (cond [(eq? target 'val) @@ -1182,29 +1193,6 @@ target])) -(: adjust-oparg-depth (OpArg Integer -> OpArg)) -(define (adjust-oparg-depth arg n) - (cond - [(Const? arg) - arg] - - [(Reg? arg) - arg] - - [(Label? arg) - arg] - - [(EnvLexicalReference? arg) - (make-EnvLexicalReference (ensure-natural (+ n (EnvLexicalReference-depth arg))) - (EnvLexicalReference-unbox? arg))] - [(EnvPrefixReference? arg) - (make-EnvPrefixReference (ensure-natural (+ n (EnvPrefixReference-depth arg))) - (EnvPrefixReference-pos arg))] - [(EnvWholePrefixReference? arg) - (make-EnvWholePrefixReference (ensure-natural (+ n (EnvWholePrefixReference-depth arg))))])) - - - (: adjust-expression-depth (Expression Natural Natural -> Expression)) ;; Redirects references to the stack to route around a region of size n. diff --git a/il-structs.rkt b/il-structs.rkt index 9cd189e..fdc2f71 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -231,8 +231,9 @@ [pos : Natural]) #:transparent) -;; Check the closure procedure value in 'proc and make sure it can accept n values. -(define-struct: CheckClosureArity! ([arity : Natural]) +;; Check the closure procedure value in 'proc and make sure it can accept the +;; # of arguments (stored as a number in the val register.). +(define-struct: CheckClosureArity! () #:transparent) ;; Extends the environment with a prefix that holds diff --git a/simulator.rkt b/simulator.rkt index 45caf87..d3120c2 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -227,10 +227,10 @@ (cond [(closure? clos) (if (= (closure-arity clos) - (CheckClosureArity!-arity op)) + (ensure-natural (ensure-primitive-value (machine-val m)))) 'ok (error 'check-closure-arity "arity mismatch: passed ~s args to ~s" - (CheckClosureArity!-arity op) + (machine-val m) (closure-display-name clos)))] [else (error 'check-closure-arity "not a closure: ~s" clos)]))] @@ -612,9 +612,11 @@ [else (error 'ensure-toplevel)])) -(: ensure-natural (Integer -> Natural)) +(define-predicate natural? Natural) + +(: ensure-natural (Any -> Natural)) (define (ensure-natural x) - (if (>= x 0) + (if (natural? x) x (error 'ensure-natural)))