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"
"il-structs.rkt"
"compile.rkt"
"typed-parse.rkt")
"typed-parse.rkt"
"parameters.rkt")
(provide get-bootstrapping-code)

10
compile.rkt
View File

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

3
expression-structs.rkt
View File

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

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

40
test-parse.rkt
View File

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