diff --git a/compile.rkt b/compile.rkt index f6b8d30..8a8bf12 100644 --- a/compile.rkt +++ b/compile.rkt @@ -14,9 +14,10 @@ ;; We try to keep at compile time a mapping from environment positions to ;; statically known things, to generate better code. -(define-struct: StaticallyKnownLam ([entry-point : Symbol] +(define-struct: StaticallyKnownLam ([name : (U Symbol False)] + [entry-point : Symbol] [arity : Natural]) #:transparent) -(define-type CompileTimeEnvironmentEntry (U '? 'prefix StaticallyKnownLam)) +(define-type CompileTimeEnvironmentEntry (U '? Prefix StaticallyKnownLam)) (define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry)) @@ -52,7 +53,7 @@ (cond [(Top? exp) - (loop (Top-code exp) (cons 'prefix cenv))] + (loop (Top-code exp) (cons (Top-prefix exp) cenv))] [(Constant? exp) '()] [(LocalRef? exp) @@ -164,7 +165,7 @@ (append-instruction-sequences (make-instruction-sequence `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names)))) - (compile (Top-code top) (cons 'prefix cenv) target linkage)))) + (compile (Top-code top) (cons (Top-prefix top) cenv) target linkage)))) @@ -396,19 +397,16 @@ [(and (LocalRef? operator) (not (LocalRef-unbox? operator))) (let: ([static-knowledge : CompileTimeEnvironmentEntry (list-ref extended-cenv (LocalRef-depth operator))]) (cond - [(eq? static-knowledge 'prefix) - (default)] [(eq? static-knowledge '?) (default)] + [(Prefix? static-knowledge) + (default)] [(StaticallyKnownLam? static-knowledge) - ;; Currently disabling the static analysis stuff till I get error trapping working first. - #;(default) (unless (= n (StaticallyKnownLam-arity static-knowledge)) - (error 'arity-mismatch "Expected ~s, received ~s" + (error 'arity-mismatch "~s expected ~s arguments, but received ~s" + (StaticallyKnownLam-name static-knowledge) (StaticallyKnownLam-arity static-knowledge) n)) - ;; FIXME: do the arity check here... - #;(printf "I'm here with ~s\n" static-knowledge) (compile-procedure-call/statically-known-lam static-knowledge extended-cenv n @@ -559,7 +557,8 @@ (define (extract-static-knowledge exp cenv) (cond [(Lam? exp) - (make-StaticallyKnownLam (Lam-entry-label exp) + (make-StaticallyKnownLam (Lam-name exp) + (Lam-entry-label exp) (Lam-num-parameters exp))] [(LocalRef? exp) (list-ref cenv (LocalRef-depth exp))] diff --git a/simulator-primitives.rkt b/simulator-primitives.rkt index 7474776..67163b6 100644 --- a/simulator-primitives.rkt +++ b/simulator-primitives.rkt @@ -28,7 +28,7 @@ (syntax->list #'(name ...)))]) (syntax/loc stx (let ([prim-name (make-primitive-proc - (lambda (machine return-label . args) + (lambda (machine . args) (apply name args)))] ...) (lambda (n) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 0dfb8d8..08aebc6 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -67,7 +67,7 @@ ;; Primitive procedure wrapper -(define-struct: primitive-proc ([f : (machine Symbol PrimitiveValue * -> PrimitiveValue)]) +(define-struct: primitive-proc ([f : (machine PrimitiveValue * -> PrimitiveValue)]) #:transparent) diff --git a/simulator.rkt b/simulator.rkt index c170bac..40adcaa 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -309,7 +309,6 @@ (current-simulated-output-port)]) (apply (primitive-proc-f prim) m - (ApplyPrimitiveProcedure-label op) args))))] [else (error 'apply-primitive-procedure)]))] diff --git a/test-assemble.rkt b/test-assemble.rkt index fc97934..49cbf54 100644 --- a/test-assemble.rkt +++ b/test-assemble.rkt @@ -154,7 +154,7 @@ (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 4)) (make-AssignPrimOpStatement 'val - (make-ApplyPrimitiveProcedure 2 'done)) + (make-ApplyPrimitiveProcedure 2)) 'done)) "7") diff --git a/test-simulator.rkt b/test-simulator.rkt index bdcacd2..b697249 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -472,7 +472,7 @@ ,(make-PushEnvironment 2 #f) ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 126389)) ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 42)) - ,(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure 2 'after)) + ,(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure 2)) after))]) (test (machine-val (run m)) (+ 126389 42))