diff --git a/bootstrapped-primitives.rkt b/bootstrapped-primitives.rkt index a680e72..a0e67f3 100644 --- a/bootstrapped-primitives.rkt +++ b/bootstrapped-primitives.rkt @@ -3,7 +3,8 @@ "lexical-structs.rkt" "il-structs.rkt" "compile.rkt" - "typed-parse.rkt") + "typed-parse.rkt" + "parameters.rkt") (provide get-bootstrapping-code) diff --git a/compile.rkt b/compile.rkt index 7b6581c..99d508c 100644 --- a/compile.rkt +++ b/compile.rkt @@ -8,12 +8,9 @@ (provide (rename-out [-compile compile]) compile-procedure-call append-instruction-sequences - current-defined-name adjust-target-depth) -(: current-defined-name (Parameterof (U Symbol False))) -(define current-defined-name (make-parameter #f)) (: -compile (ExpressionCore Target Linkage -> (Listof Statement))) (define (-compile exp target linkage) @@ -160,9 +157,8 @@ [lexical-pos (make-EnvPrefixReference (ToplevelSet-depth exp) (ToplevelSet-pos exp))]) (let ([get-value-code - (parameterize ([current-defined-name var]) - (compile (ToplevelSet-value exp) cenv lexical-pos - 'next))]) + (compile (ToplevelSet-value exp) cenv lexical-pos + 'next)]) (end-with-linkage linkage cenv @@ -225,7 +221,7 @@ (make-MakeCompiledProcedure proc-entry (Lam-num-parameters exp) (Lam-closure-map exp) - (current-defined-name)))))) + (Lam-name exp)))))) (compile-lambda-body exp proc-entry) after-lambda))) diff --git a/expression-structs.rkt b/expression-structs.rkt index bf9b47f..ffedaec 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -35,7 +35,8 @@ [consequent : ExpressionCore] [alternative : ExpressionCore]) #:transparent) -(define-struct: Lam ([num-parameters : Natural] +(define-struct: Lam ([name : (U Symbol False)] + [num-parameters : Natural] [body : ExpressionCore] [closure-map : (Listof Natural)]) #:transparent) diff --git a/parameters.rkt b/parameters.rkt new file mode 100644 index 0000000..9308e2f --- /dev/null +++ b/parameters.rkt @@ -0,0 +1,6 @@ +#lang typed/racket/base + +(provide current-defined-name) + +(: current-defined-name (Parameterof (U Symbol False))) +(define current-defined-name (make-parameter #f)) \ No newline at end of file diff --git a/parse.rkt b/parse.rkt index 7b8b99a..140afe1 100644 --- a/parse.rkt +++ b/parse.rkt @@ -4,6 +4,7 @@ "lexical-env.rkt" "lexical-structs.rkt" "helpers.rkt" + "parameters.rkt" racket/list) (provide (rename-out (-parse parse))) @@ -53,7 +54,8 @@ (make-ToplevelSet (EnvPrefixReference-depth address) (EnvPrefixReference-pos address) (definition-variable exp) - (parse (definition-value exp) cenv))]))] + (parameterize ([current-defined-name (definition-variable exp)]) + (parse (definition-value exp) cenv)))]))] [(if? exp) (make-Branch (parse (if-predicate exp) cenv) @@ -77,7 +79,8 @@ (let ([lam-body (map (lambda (b) (parse b body-cenv)) (lambda-body exp))]) - (make-Lam (length (lambda-parameters exp)) + (make-Lam (current-defined-name) + (length (lambda-parameters exp)) (if (= (length lam-body) 1) (first lam-body) (make-Seq lam-body)) @@ -282,15 +285,20 @@ [(= 0 (length vars)) (parse `(begin ,@body) cenv)] [(= 1 (length vars)) - (make-Let1 (parse (car rhss) (extend-lexical-environment/placeholders cenv 1)) + (make-Let1 (parameterize ([current-defined-name (first vars)]) + (parse (car rhss) (extend-lexical-environment/placeholders cenv 1))) (parse `(begin ,@body) (extend-lexical-environment/names cenv (list (first vars)))))] [else (let ([rhs-cenv (extend-lexical-environment/placeholders cenv (length vars))]) (make-LetVoid (length vars) (make-Seq (append - (map (lambda (rhs index) - (make-InstallValue index (parse rhs rhs-cenv) #f)) + (map (lambda (var rhs index) + (make-InstallValue index + (parameterize ([current-defined-name var]) + (parse rhs rhs-cenv)) + #f)) + vars rhss (build-list (length rhss) (lambda (i) i))) (list (parse `(begin ,@body) @@ -308,8 +316,12 @@ (let ([new-cenv (extend-lexical-environment/boxed-names cenv vars)]) (make-LetVoid (length vars) (make-Seq (append - (map (lambda (rhs index) - (make-InstallValue index (parse rhs new-cenv) #t)) + (map (lambda (var rhs index) + (make-InstallValue index + (parameterize ([current-defined-name var]) + (parse rhs new-cenv)) + #t)) + vars rhss (build-list (length rhss) (lambda (i) i))) (list (parse `(begin ,@body) new-cenv)))) diff --git a/test-parse.rkt b/test-parse.rkt index 30304e8..13029a3 100644 --- a/test-parse.rkt +++ b/test-parse.rkt @@ -88,33 +88,35 @@ (test (parse '(lambda (x y z) x)) (make-Top (make-Prefix '()) - (make-Lam 3 (make-LocalRef 0 #f) '()))) + (make-Lam #f 3 (make-LocalRef 0 #f) '()))) (test (parse '(lambda (x y z) y)) (make-Top (make-Prefix '()) - (make-Lam 3 (make-LocalRef 1 #f) '()))) + (make-Lam #f 3 (make-LocalRef 1 #f) '()))) (test (parse '(lambda (x y z) z)) (make-Top (make-Prefix '()) - (make-Lam 3 (make-LocalRef 2 #f) '()))) + (make-Lam #f 3 (make-LocalRef 2 #f) '()))) (test (parse '(lambda (x y z) x y z)) (make-Top (make-Prefix '()) - (make-Lam 3 (make-Seq (list (make-LocalRef 0 #f) + (make-Lam #f 3 (make-Seq (list (make-LocalRef 0 #f) (make-LocalRef 1 #f) (make-LocalRef 2 #f))) '()))) (test (parse '(lambda (x y z) k)) (make-Top (make-Prefix '(k)) - (make-Lam 3 + (make-Lam #f + 3 (make-ToplevelRef 0 0 ) '(0)))) (test (parse '(lambda (x y z) k x y z)) (make-Top (make-Prefix '(k)) - (make-Lam 3 (make-Seq (list (make-ToplevelRef 0 0 ) + (make-Lam #f + 3 (make-Seq (list (make-ToplevelRef 0 0 ) (make-LocalRef 1 #f) (make-LocalRef 2 #f) (make-LocalRef 3 #f))) @@ -128,9 +130,9 @@ z w)))) (make-Top (make-Prefix '(w)) - (make-Lam 1 - (make-Lam 1 - (make-Lam 1 + (make-Lam #f 1 + (make-Lam #f 1 + (make-Lam #f 1 (make-Seq (list (make-LocalRef 1 #f) (make-LocalRef 2 #f) @@ -147,8 +149,8 @@ (lambda (y) x))) (make-Top (make-Prefix '()) - (make-Lam 1 - (make-Lam 1 + (make-Lam #f 1 + (make-Lam #f 1 (make-LocalRef 0 #f) '(0)) (list)))) @@ -157,8 +159,8 @@ (lambda (y) y))) (make-Top (make-Prefix '()) - (make-Lam 1 - (make-Lam 1 + (make-Lam #f 1 + (make-Lam #f 1 (make-LocalRef 0 #f) (list)) (list)))) @@ -172,7 +174,7 @@ (test (parse '(lambda (x) (+ x x))) (make-Top (make-Prefix '(+)) - (make-Lam 1 + (make-Lam #f 1 (make-App (make-ToplevelRef 2 0) (list (make-LocalRef 3 #f) (make-LocalRef 3 #f))) @@ -181,7 +183,7 @@ (test (parse '(lambda (x) (+ (* x x) x))) (make-Top (make-Prefix '(* +)) - (make-Lam 1 + (make-Lam #f 1 ;; stack layout: [???, ???, prefix, x] (make-App (make-ToplevelRef 2 1) (list @@ -273,10 +275,10 @@ (make-Seq (list (make-InstallValue 0 - (make-Lam 1 (make-LocalRef 0 #f) '()) + (make-Lam 'x 1 (make-LocalRef 0 #f) '()) #t) (make-InstallValue 1 - (make-Lam 1 (make-LocalRef 0 #f) '()) + (make-Lam 'y 1 (make-LocalRef 0 #f) '()) #t) ;; stack layout: ??? x y (make-App (make-LocalRef 1 #t) @@ -292,13 +294,13 @@ (make-Seq (list (make-InstallValue 0 - (make-Lam 1 + (make-Lam 'x 1 (make-App (make-LocalRef 1 #t) (list (make-LocalRef 2 #f))) '(1)) #t) (make-InstallValue 1 - (make-Lam 1 + (make-Lam 'y 1 (make-App (make-LocalRef 2 #f) (list (make-LocalRef 1 #t))) '(1))