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

trying to deal with case-lam's revised structure

Browse Source
This commit is contained in:
Danny Yoo 2011-05-12 14:36:06 -04:00
parent 3c2917f0c5
commit 882b228ae8
7 changed files with 59 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
compiler.rkt
View File

@ -85,7 +85,7 @@
(extract-lambda-cenv exp cenv)))]
[(CaseLam? exp)
(cons (make-lam+cenv exp cenv)
(apply append (map (lambda: ([lam : Lam])
(apply append (map (lambda: ([lam : (U Lam EmptyClosureReference)])
(loop lam cenv))
(CaseLam-clauses exp))))]
@ -652,15 +652,22 @@
;; Compile each of the lambdas
(apply append-instruction-sequences
(map (lambda: ([lam : Lam]
(map (lambda: ([lam : (U Lam EmptyClosureReference)]
[target : Target])
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
target
(make-MakeCompiledProcedure (Lam-entry-label lam)
(Lam-arity lam)
(shift-closure-map (Lam-closure-map lam) n)
(Lam-name lam))))))
(cond
[(Lam? lam)
(make-MakeCompiledProcedure (Lam-entry-label lam)
(Lam-arity lam)
(shift-closure-map (Lam-closure-map lam) n)
(Lam-name lam))]
[(EmptyClosureReference? lam)
(make-MakeCompiledProcedure (EmptyClosureReference-entry-label lam)
(EmptyClosureReference-arity lam)
'()
(EmptyClosureReference-name lam))])))))
(CaseLam-clauses exp)
(build-list (length (CaseLam-clauses exp))
(lambda: ([i : Natural])
@ -680,19 +687,25 @@
singular-context-check))))
(: Lam-arity (Lam -> Arity))
(: Lam-arity ((U Lam EmptyClosureReference) -> Arity))
(define (Lam-arity lam)
(if (Lam-rest? lam)
(make-ArityAtLeast (Lam-num-parameters lam))
(Lam-num-parameters lam)))
(cond
[(Lam? lam)
(if (Lam-rest? lam)
(make-ArityAtLeast (Lam-num-parameters lam))
(Lam-num-parameters lam))]
[(EmptyClosureReference? lam)
(if (EmptyClosureReference-rest? lam)
(make-ArityAtLeast (EmptyClosureReference-num-parameters lam))
(EmptyClosureReference-num-parameters lam))]))
(: EmptyClosureReference-arity (EmptyClosureReference -> Arity))
(define (EmptyClosureReference-arity lam)
(if (EmptyClosureReference-rest? lam)
(if (EmptyClosureReference-rest? lam)
(make-ArityAtLeast (EmptyClosureReference-num-parameters lam))
(EmptyClosureReference-num-parameters lam)))
@ -784,7 +797,7 @@
`(,(CaseLam-entry-label exp)))
(apply append-instruction-sequences
(map (lambda: ([lam : Lam]
(map (lambda: ([lam : (U Lam EmptyClosureReference)]
[i : Natural])
(let ([not-match (make-label 'notMatch)])
(make-instruction-sequence
@ -800,7 +813,11 @@
'proc
(make-CompiledProcedureClosureReference (make-Reg 'proc) i))
,(make-GotoStatement (make-Label (Lam-entry-label lam)))
,(make-GotoStatement (make-Label
(cond [(Lam? lam)
(Lam-entry-label lam)]
[(EmptyClosureReference? lam)
(EmptyClosureReference-entry-label lam)])))
,not-match))))
(CaseLam-clauses exp)
@ -2050,8 +2067,12 @@
[(CaseLam? exp)
(make-CaseLam (CaseLam-name exp)
(map (lambda: ([lam : Lam])
(ensure-lam (adjust-expression-depth lam n skip)))
(map (lambda: ([lam : (U Lam EmptyClosureReference)])
(cond
[(Lam? lam)
(ensure-lam (adjust-expression-depth lam n skip))]
[(EmptyClosureReference? lam)
lam]))
(CaseLam-clauses exp))
(CaseLam-entry-label exp))]
@ -2101,10 +2122,10 @@
(cons (ensure-lam (adjust-expression-depth
(first procs)
n
(+ skip (length (LetRec-procs exp)))))
skip))
(loop (rest procs)))]))
(adjust-expression-depth (LetRec-body exp) n
(+ skip (length (LetRec-procs exp)))))]
skip))]
[(InstallValue? exp)
(if (< (InstallValue-depth exp) skip)

2
expression-structs.rkt
View File

@ -64,7 +64,7 @@
[alternative : Expression]) #:transparent)
(define-struct: CaseLam ([name : (U Symbol LamPositionalName)]
[clauses : (Listof Lam)]
[clauses : (Listof (U Lam EmptyClosureReference))]
[entry-label : Symbol]) #:transparent)
(define-struct: Lam ([name : (U Symbol LamPositionalName)]

1
kernel-primitives.rkt
View File

@ -46,6 +46,7 @@
'continuation-mark-set->list
'values
'call-with-values
'apply
))
(define-predicate KernelPrimitiveName? KernelPrimitiveName)

9
parse-bytecode-5.1.1.rkt
View File

@ -365,7 +365,7 @@
entry-point-label))]))
;; parse-closure: closure -> Expression
;; parse-closure: closure -> (U Lam EmptyClosureReference)
;; Either parses as a regular lambda, or if we come across the same closure twice,
;; breaks the cycle by creating an EmptyClosureReference with the pre-existing lambda
;; entry point.
@ -425,7 +425,12 @@
[(struct case-lam (name clauses))
(let ([case-lam-label (make-lam-label)])
(make-CaseLam (extract-lam-name name)
(map (lambda (l) (parse-lam l (make-lam-label)))
(map (lambda (l)
(cond
[(closure? l)
(parse-closure l)]
[else
(parse-lam l (make-lam-label))]))
clauses)
case-lam-label))]))

6
simulator.rkt
View File

@ -391,17 +391,17 @@
'ok)]
[(RaiseContextExpectedValuesError!? op)
(error "context expected ~a values, received ~a values."
(error 'step "context expected ~a values, received ~a values."
(RaiseContextExpectedValuesError!-expected op)
(machine-argcount m))]
[(RaiseArityMismatchError!? op)
(error "expects ~s arguments, given ~a"
(error 'step "expects ~s arguments, given ~a"
(RaiseArityMismatchError!-expected op)
(evaluate-oparg m (RaiseArityMismatchError!-received op)))]
[(RaiseOperatorApplicationError!? op)
(error "expected procedure, given ~a"
(error 'step "expected procedure, given ~a"
(evaluate-oparg m (RaiseOperatorApplicationError!-operator op)))]

2
test-compiler.rkt
View File

@ -387,7 +387,7 @@
;; deriv
(test '(let ()
#;(test '(let ()
(define (deriv-aux a) (list '/ (deriv a) a))
(define (map f l)
(if (null? l)

7
test-parse-bytecode-5.1.1.rkt
View File

@ -371,6 +371,11 @@
(void
(run-my-parse #'(case-lambda [(x) x]
[(x y) (list x y)])))
;; make sure we don't see an infinite loop
#;(run-zo-parse #'(letrec ([g (lambda () (g))])
(g)))
@ -390,6 +395,8 @@
#;(parameterize ([current-module-path
"/home/dyoo/local/racket-5.1.1/lib/racket/collects/racket/private/foo.rkt"])
(run-my-parse/file "/home/dyoo/local/racket-5.1.1/lib/racket/collects/racket/private/for.rkt"))