suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

extending Lam to have a name.

Browse Source
This commit is contained in:
Danny Yoo 2011-03-20 22:33:22 -04:00
parent 4f8217d5c6
commit ee3ed353b0
6 changed files with 53 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
bootstrapped-primitives.rkt
View File

@ -3,7 +3,8 @@
"lexical-structs.rkt" "lexical-structs.rkt"
"il-structs.rkt" "il-structs.rkt"
"compile.rkt" "compile.rkt"
"typed-parse.rkt") "typed-parse.rkt"
"parameters.rkt")
(provide get-bootstrapping-code) (provide get-bootstrapping-code)

10
compile.rkt
View File

@ -8,12 +8,9 @@
(provide (rename-out [-compile compile]) (provide (rename-out [-compile compile])
compile-procedure-call compile-procedure-call
append-instruction-sequences append-instruction-sequences
current-defined-name
adjust-target-depth) adjust-target-depth)
(: current-defined-name (Parameterof (U Symbol False)))
(define current-defined-name (make-parameter #f))
(: -compile (ExpressionCore Target Linkage -> (Listof Statement))) (: -compile (ExpressionCore Target Linkage -> (Listof Statement)))
(define (-compile exp target linkage) (define (-compile exp target linkage)
@ -160,9 +157,8 @@
[lexical-pos (make-EnvPrefixReference (ToplevelSet-depth exp) [lexical-pos (make-EnvPrefixReference (ToplevelSet-depth exp)
(ToplevelSet-pos exp))]) (ToplevelSet-pos exp))])
(let ([get-value-code (let ([get-value-code
(parameterize ([current-defined-name var]) (compile (ToplevelSet-value exp) cenv lexical-pos
(compile (ToplevelSet-value exp) cenv lexical-pos 'next)])
'next))])
(end-with-linkage (end-with-linkage
linkage linkage
cenv cenv
@ -225,7 +221,7 @@
(make-MakeCompiledProcedure proc-entry (make-MakeCompiledProcedure proc-entry
(Lam-num-parameters exp) (Lam-num-parameters exp)
(Lam-closure-map exp) (Lam-closure-map exp)
(current-defined-name)))))) (Lam-name exp))))))
(compile-lambda-body exp proc-entry) (compile-lambda-body exp proc-entry)
after-lambda))) after-lambda)))

3
expression-structs.rkt
View File

@ -35,7 +35,8 @@
[consequent : ExpressionCore] [consequent : ExpressionCore]
[alternative : ExpressionCore]) #:transparent) [alternative : ExpressionCore]) #:transparent)
(define-struct: Lam ([num-parameters : Natural] (define-struct: Lam ([name : (U Symbol False)]
[num-parameters : Natural]
[body : ExpressionCore] [body : ExpressionCore]
[closure-map : (Listof Natural)]) #:transparent) [closure-map : (Listof Natural)]) #:transparent)

6
parameters.rkt Normal file
View File

@ -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))

26
parse.rkt
View File

@ -4,6 +4,7 @@
"lexical-env.rkt" "lexical-env.rkt"
"lexical-structs.rkt" "lexical-structs.rkt"
"helpers.rkt" "helpers.rkt"
"parameters.rkt"
racket/list) racket/list)
(provide (rename-out (-parse parse))) (provide (rename-out (-parse parse)))
@ -53,7 +54,8 @@
(make-ToplevelSet (EnvPrefixReference-depth address) (make-ToplevelSet (EnvPrefixReference-depth address)
(EnvPrefixReference-pos address) (EnvPrefixReference-pos address)
(definition-variable exp) (definition-variable exp)
(parse (definition-value exp) cenv))]))] (parameterize ([current-defined-name (definition-variable exp)])
(parse (definition-value exp) cenv)))]))]
[(if? exp) [(if? exp)
(make-Branch (parse (if-predicate exp) cenv) (make-Branch (parse (if-predicate exp) cenv)
@ -77,7 +79,8 @@
(let ([lam-body (map (lambda (b) (let ([lam-body (map (lambda (b)
(parse b body-cenv)) (parse b body-cenv))
(lambda-body exp))]) (lambda-body exp))])
(make-Lam (length (lambda-parameters exp)) (make-Lam (current-defined-name)
(length (lambda-parameters exp))
(if (= (length lam-body) 1) (if (= (length lam-body) 1)
(first lam-body) (first lam-body)
(make-Seq lam-body)) (make-Seq lam-body))
@ -282,15 +285,20 @@
[(= 0 (length vars)) [(= 0 (length vars))
(parse `(begin ,@body) cenv)] (parse `(begin ,@body) cenv)]
[(= 1 (length vars)) [(= 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) (parse `(begin ,@body)
(extend-lexical-environment/names cenv (list (first vars)))))] (extend-lexical-environment/names cenv (list (first vars)))))]
[else [else
(let ([rhs-cenv (extend-lexical-environment/placeholders cenv (length vars))]) (let ([rhs-cenv (extend-lexical-environment/placeholders cenv (length vars))])
(make-LetVoid (length vars) (make-LetVoid (length vars)
(make-Seq (append (make-Seq (append
(map (lambda (rhs index) (map (lambda (var rhs index)
(make-InstallValue index (parse rhs rhs-cenv) #f)) (make-InstallValue index
(parameterize ([current-defined-name var])
(parse rhs rhs-cenv))
#f))
vars
rhss rhss
(build-list (length rhss) (lambda (i) i))) (build-list (length rhss) (lambda (i) i)))
(list (parse `(begin ,@body) (list (parse `(begin ,@body)
@ -308,8 +316,12 @@
(let ([new-cenv (extend-lexical-environment/boxed-names cenv vars)]) (let ([new-cenv (extend-lexical-environment/boxed-names cenv vars)])
(make-LetVoid (length vars) (make-LetVoid (length vars)
(make-Seq (append (make-Seq (append
(map (lambda (rhs index) (map (lambda (var rhs index)
(make-InstallValue index (parse rhs new-cenv) #t)) (make-InstallValue index
(parameterize ([current-defined-name var])
(parse rhs new-cenv))
#t))
vars
rhss rhss
(build-list (length rhss) (lambda (i) i))) (build-list (length rhss) (lambda (i) i)))
(list (parse `(begin ,@body) new-cenv)))) (list (parse `(begin ,@body) new-cenv))))

40
test-parse.rkt
View File

@ -88,33 +88,35 @@
(test (parse '(lambda (x y z) x)) (test (parse '(lambda (x y z) x))
(make-Top (make-Prefix '()) (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)) (test (parse '(lambda (x y z) y))
(make-Top (make-Prefix '()) (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)) (test (parse '(lambda (x y z) z))
(make-Top (make-Prefix '()) (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)) (test (parse '(lambda (x y z) x y z))
(make-Top (make-Prefix '()) (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 1 #f)
(make-LocalRef 2 #f))) (make-LocalRef 2 #f)))
'()))) '())))
(test (parse '(lambda (x y z) k)) (test (parse '(lambda (x y z) k))
(make-Top (make-Prefix '(k)) (make-Top (make-Prefix '(k))
(make-Lam 3 (make-Lam #f
3
(make-ToplevelRef 0 0 ) (make-ToplevelRef 0 0 )
'(0)))) '(0))))
(test (parse '(lambda (x y z) k x y z)) (test (parse '(lambda (x y z) k x y z))
(make-Top (make-Prefix '(k)) (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 1 #f)
(make-LocalRef 2 #f) (make-LocalRef 2 #f)
(make-LocalRef 3 #f))) (make-LocalRef 3 #f)))
@ -128,9 +130,9 @@
z z
w)))) w))))
(make-Top (make-Prefix '(w)) (make-Top (make-Prefix '(w))
(make-Lam 1 (make-Lam #f 1
(make-Lam 1 (make-Lam #f 1
(make-Lam 1 (make-Lam #f 1
(make-Seq (list (make-Seq (list
(make-LocalRef 1 #f) (make-LocalRef 1 #f)
(make-LocalRef 2 #f) (make-LocalRef 2 #f)
@ -147,8 +149,8 @@
(lambda (y) (lambda (y)
x))) x)))
(make-Top (make-Prefix '()) (make-Top (make-Prefix '())
(make-Lam 1 (make-Lam #f 1
(make-Lam 1 (make-Lam #f 1
(make-LocalRef 0 #f) (make-LocalRef 0 #f)
'(0)) '(0))
(list)))) (list))))
@ -157,8 +159,8 @@
(lambda (y) (lambda (y)
y))) y)))
(make-Top (make-Prefix '()) (make-Top (make-Prefix '())
(make-Lam 1 (make-Lam #f 1
(make-Lam 1 (make-Lam #f 1
(make-LocalRef 0 #f) (make-LocalRef 0 #f)
(list)) (list))
(list)))) (list))))
@ -172,7 +174,7 @@
(test (parse '(lambda (x) (+ x x))) (test (parse '(lambda (x) (+ x x)))
(make-Top (make-Prefix '(+)) (make-Top (make-Prefix '(+))
(make-Lam 1 (make-Lam #f 1
(make-App (make-ToplevelRef 2 0) (make-App (make-ToplevelRef 2 0)
(list (make-LocalRef 3 #f) (list (make-LocalRef 3 #f)
(make-LocalRef 3 #f))) (make-LocalRef 3 #f)))
@ -181,7 +183,7 @@
(test (parse '(lambda (x) (test (parse '(lambda (x)
(+ (* x x) x))) (+ (* x x) x)))
(make-Top (make-Prefix '(* +)) (make-Top (make-Prefix '(* +))
(make-Lam 1 (make-Lam #f 1
;; stack layout: [???, ???, prefix, x] ;; stack layout: [???, ???, prefix, x]
(make-App (make-ToplevelRef 2 1) (make-App (make-ToplevelRef 2 1)
(list (list
@ -273,10 +275,10 @@
(make-Seq (make-Seq
(list (list
(make-InstallValue 0 (make-InstallValue 0
(make-Lam 1 (make-LocalRef 0 #f) '()) (make-Lam 'x 1 (make-LocalRef 0 #f) '())
#t) #t)
(make-InstallValue 1 (make-InstallValue 1
(make-Lam 1 (make-LocalRef 0 #f) '()) (make-Lam 'y 1 (make-LocalRef 0 #f) '())
#t) #t)
;; stack layout: ??? x y ;; stack layout: ??? x y
(make-App (make-LocalRef 1 #t) (make-App (make-LocalRef 1 #t)
@ -292,13 +294,13 @@
(make-Seq (make-Seq
(list (list
(make-InstallValue 0 (make-InstallValue 0
(make-Lam 1 (make-Lam 'x 1
(make-App (make-LocalRef 1 #t) (make-App (make-LocalRef 1 #t)
(list (make-LocalRef 2 #f))) (list (make-LocalRef 2 #f)))
'(1)) '(1))
#t) #t)
(make-InstallValue 1 (make-InstallValue 1
(make-Lam 1 (make-Lam 'y 1
(make-App (make-LocalRef 2 #f) (make-App (make-LocalRef 2 #f)
(list (make-LocalRef 1 #t))) (list (make-LocalRef 1 #t)))
'(1)) '(1))