diff --git a/compiler.rkt b/compiler.rkt index 833f53f..d175cd5 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -730,7 +730,8 @@ (append-instruction-sequences ;; Make some temporary space for the lambdas (make-instruction-sequence - `(,(make-PushEnvironment n #f))) + `(,(make-Comment "scratch space for case-lambda") + ,(make-PushEnvironment n #f))) ;; Compile each of the lambdas (apply append-instruction-sequences @@ -1011,9 +1012,12 @@ 'val))))]) (append-instruction-sequences (make-instruction-sequence - `(,(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-DebugPrint (make-Reg 'proc)))) (make-instruction-sequence `(,(make-AssignImmediateStatement 'argcount (make-Const (length (App-operands exp)))))) @@ -1313,7 +1317,8 @@ (make-EnvLexicalReference i #f) 'val))))]) (append-instruction-sequences - (make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f))) + (make-instruction-sequence `(,(make-Comment "scratch space for statically known lambda application") + ,(make-PushEnvironment (length (App-operands exp)) #f))) proc-code (juggle-operands operand-codes) arity-check @@ -1688,7 +1693,8 @@ linkage extended-cenv (append-instruction-sequences - (make-instruction-sequence `(,(make-PushEnvironment 1 #f))) + (make-instruction-sequence `(,(make-Comment "scratch space for let1") + ,(make-PushEnvironment 1 #f))) rhs-code body-code after-body-code @@ -1728,7 +1734,8 @@ extended-cenv (append-instruction-sequences (make-instruction-sequence - `(,(make-PushEnvironment n (LetVoid-boxes? exp)))) + `(,(make-Comment "scratch space for let-void") + ,(make-PushEnvironment n (LetVoid-boxes? exp)))) body-code after-body-code (make-instruction-sequence @@ -1790,7 +1797,8 @@ (map (lambda: ([lam : Lam] [i : Natural]) (make-instruction-sequence - `(,(make-PerformStatement + `(,(make-Comment (format "Installing shell for ~s\n" (Lam-name lam))) + ,(make-PerformStatement (make-FixClosureShellMap! i (Lam-closure-map lam)))))) (LetRec-procs exp) diff --git a/lam-entry-gensym.rkt b/lam-entry-gensym.rkt new file mode 100644 index 0000000..9d2e082 --- /dev/null +++ b/lam-entry-gensym.rkt @@ -0,0 +1,14 @@ +#lang typed/racket/base + + +(define-values (make-lam-label reset-lam-label-counter!/unit-testing) + (let ([n 0]) + (values + (lambda () + (set! n (add1 n)) + (string->symbol (format "lamEntry~a" n))) + (lambda () + (set! n 0))))) + + +(provide make-lam-label reset-lam-label-counter!/unit-testing) \ No newline at end of file diff --git a/parse-bytecode-5.1.1.rkt b/parse-bytecode-5.1.1.rkt index 49ef116..782d567 100644 --- a/parse-bytecode-5.1.1.rkt +++ b/parse-bytecode-5.1.1.rkt @@ -5,6 +5,7 @@ "typed-module-path.rkt" "path-rewriter.rkt" "parameters.rkt" + "lam-entry-gensym.rkt" syntax/modresolve) @@ -386,15 +387,6 @@ (make-Splice (map parse-item body)))) -(define-values (make-lam-label reset-lam-label-counter!/unit-testing) - (let ([n 0]) - (values - (lambda () - (set! n (add1 n)) - (string->symbol (format "lamEntry~a" n))) - (lambda () - (set! n 0))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/parse.rkt b/parse.rkt index bdf0318..184e9d0 100644 --- a/parse.rkt +++ b/parse.rkt @@ -5,12 +5,11 @@ "lexical-structs.rkt" "helpers.rkt" "parameters.rkt" + "lam-entry-gensym.rkt" racket/list) -(provide (rename-out (-parse parse)) - - ;; meant for tests - set-private-lam-label-counter!) +(provide (rename-out (-parse parse))) + (define (-parse exp) (let* ([prefix (construct-the-prefix exp)]) @@ -205,28 +204,21 @@ #t lam-body (map env-reference-depth closure-references) - (fresh-lam-label))] + (make-lam-label))] [else (make-Lam (current-defined-name) (length (lambda-parameters exp)) #f lam-body (map env-reference-depth closure-references) - (fresh-lam-label))])))) + (make-lam-label))])))) -(define lam-label-counter 0) -(define (set-private-lam-label-counter! x) - (set! lam-label-counter x)) -(define fresh-lam-label - (lambda () - (set! lam-label-counter (add1 lam-label-counter)) - (string->symbol (format "lamEntry~a" lam-label-counter)))) (define (parse-case-lambda exp cenv) - (let* ([entry-label (fresh-lam-label)] + (let* ([entry-label (make-lam-label)] [parsed-lams (map (lambda (lam) (parse-lambda lam cenv)) (case-lambda-clauses exp))]) diff --git a/test-parse.rkt b/test-parse.rkt index 689b59a..91951fa 100644 --- a/test-parse.rkt +++ b/test-parse.rkt @@ -3,6 +3,7 @@ (require "parse.rkt" "lexical-structs.rkt" "expression-structs.rkt" + "lam-entry-gensym.rkt" (for-syntax racket/base)) ; Test out the compiler, using the simulator. @@ -13,7 +14,7 @@ (syntax/loc #'stx (begin (printf "Running ~s ...\n" (syntax->datum #'expr)) - (set-private-lam-label-counter! 0) + (reset-lam-label-counter!/unit-testing) (let ([expected expt] [actual (with-handlers ([void