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

parser recognizes set! for parameters

Browse Source
This commit is contained in:
Danny Yoo 2011-03-21 23:17:42 -04:00
parent 7b49557a7e
commit 27781a1dff
5 changed files with 188 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
expression-structs.rkt
View File

@ -11,7 +11,8 @@
Branch Lam Seq App Branch Lam Seq App
Let1 Let1
LetVoid LetVoid
InstallValue)) InstallValue
BoxEnv))
(define-struct: Top ([prefix : Prefix] (define-struct: Top ([prefix : Prefix]
[code : ExpressionCore]) #:transparent) [code : ExpressionCore]) #:transparent)
@ -58,6 +59,9 @@
#:transparent) #:transparent)
(define-struct: BoxEnv ([depth : Natural]
[body : ExpressionCore])
#:transparent)

10
helpers.rkt
View File

@ -1,6 +1,6 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/list) (require racket/list)
(provide list-union list-difference unique/eq? unique/equal?) (provide list-union list-difference list-intersection unique/eq? unique/equal?)
(: list-union ((Listof Symbol) (Listof Symbol) -> (Listof Symbol))) (: list-union ((Listof Symbol) (Listof Symbol) -> (Listof Symbol)))
@ -19,6 +19,14 @@
[else [else
(cons (car s1) (list-difference (cdr s1) s2))])) (cons (car s1) (list-difference (cdr s1) s2))]))
(: list-intersection ((Listof Symbol) (Listof Symbol) -> (Listof Symbol)))
(define (list-intersection s1 s2)
(cond [(null? s1) '()]
[(memq (car s1) s2)
(cons (car s1) (list-intersection (cdr s1) s2))]
[else
(list-difference (cdr s1) s2)]))
;; Trying to work around what looks like a bug in typed racket: ;; Trying to work around what looks like a bug in typed racket:
(define string-sort (inst sort String String)) (define string-sort (inst sort String String))

28
lexical-env.rkt
View File

@ -6,8 +6,10 @@
(provide find-variable (provide find-variable
extend-lexical-environment extend-lexical-environment
extend-lexical-environment/names extend-lexical-environment/names
extend-lexical-environment/parameter-names
extend-lexical-environment/boxed-names extend-lexical-environment/boxed-names
extend-lexical-environment/placeholders extend-lexical-environment/placeholders
collect-lexical-references collect-lexical-references
lexical-references->compile-time-environment lexical-references->compile-time-environment
place-prefix-mask place-prefix-mask
@ -29,7 +31,7 @@
([cenv : CompileTimeEnvironment cenv] ([cenv : CompileTimeEnvironment cenv]
[depth : Natural 0]) [depth : Natural 0])
(cond [(empty? cenv) (cond [(empty? cenv)
(error 'find-variable "~s not in lexical environment" cenv)] (error 'find-variable "~s not in lexical environment" name)]
[else [else
(let: ([elt : CompileTimeEnvironmentEntry (first cenv)]) (let: ([elt : CompileTimeEnvironmentEntry (first cenv)])
(cond (cond
@ -43,14 +45,7 @@
[(NamedBinding? elt) [(NamedBinding? elt)
(cond (cond
[(eq? (NamedBinding-name elt) name) [(eq? (NamedBinding-name elt) name)
(make-EnvLexicalReference depth #f)] (make-EnvLexicalReference depth (NamedBinding-boxed? elt))]
[else
(loop (rest cenv) (add1 depth))])]
[(box? elt)
(cond
[(eq? (NamedBinding-name (unbox elt)) name)
(make-EnvLexicalReference depth #t)]
[else [else
(loop (rest cenv) (add1 depth))])] (loop (rest cenv) (add1 depth))])]
@ -81,13 +76,18 @@
(: extend-lexical-environment/names (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment)) (: extend-lexical-environment/names (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment))
(define (extend-lexical-environment/names cenv names) (define (extend-lexical-environment/names cenv names)
(append (map make-NamedBinding names) cenv)) (append (map (lambda: ([n : Symbol]) (make-NamedBinding n #f #f)) names) cenv))
(: extend-lexical-environment/parameter-names (CompileTimeEnvironment (Listof Symbol) (Listof Boolean) -> CompileTimeEnvironment))
(define (extend-lexical-environment/parameter-names cenv names boxed?)
(append (map (lambda: ([n : Symbol]
[b : Boolean])
(make-NamedBinding n #t b)) names boxed?)
cenv))
(: extend-lexical-environment/boxed-names (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment)) (: extend-lexical-environment/boxed-names (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment))
(define (extend-lexical-environment/boxed-names cenv names) (define (extend-lexical-environment/boxed-names cenv names)
(append (map (inst box NamedBinding) (append (map (lambda: ([n : Symbol]) (make-NamedBinding n #f #t)) names)
(map make-NamedBinding names))
cenv)) cenv))
@ -187,10 +187,12 @@
(make-EnvWholePrefixReference (+ n (EnvWholePrefixReference-depth target)))])) (make-EnvWholePrefixReference (+ n (EnvWholePrefixReference-depth target)))]))
(: env-reference-depth (EnvReference -> Natural)) (: env-reference-depth ((U EnvLexicalReference EnvPrefixReference EnvWholePrefixReference) -> Natural))
(define (env-reference-depth a-ref) (define (env-reference-depth a-ref)
(cond (cond
[(EnvLexicalReference? a-ref) [(EnvLexicalReference? a-ref)
(EnvLexicalReference-depth a-ref)] (EnvLexicalReference-depth a-ref)]
[(EnvPrefixReference? a-ref)
(EnvPrefixReference-depth a-ref)]
[(EnvWholePrefixReference? a-ref) [(EnvWholePrefixReference? a-ref)
(EnvWholePrefixReference-depth a-ref)])) (EnvWholePrefixReference-depth a-ref)]))

6
lexical-structs.rkt
View File

@ -13,12 +13,14 @@
#:transparent) #:transparent)
(define-struct: NamedBinding ([name : Symbol])) (define-struct: NamedBinding ([name : Symbol]
[parameter? : Boolean]
[boxed? : Boolean])
#:transparent)
(define-type CompileTimeEnvironmentEntry (U Prefix ;; a prefix (define-type CompileTimeEnvironmentEntry (U Prefix ;; a prefix
NamedBinding NamedBinding
(Boxof NamedBinding) ;; A boxed local
False)) False))

202
parse.rkt
View File

@ -66,48 +66,40 @@
(parse (desugar-cond exp) cenv)] (parse (desugar-cond exp) cenv)]
[(lambda? exp) [(lambda? exp)
(let* ([unbound-names (find-unbound-names exp)] (parse-lambda exp cenv)]
[closure-references (collect-lexical-references
(map (lambda (var)
(find-variable var cenv))
unbound-names))]
[body-cenv (lexical-references->compile-time-environment
closure-references
cenv
(extend-lexical-environment/names '() (lambda-parameters exp))
unbound-names)])
(let ([lam-body (map (lambda (b)
(parse b body-cenv))
(lambda-body exp))])
(make-Lam (current-defined-name)
(length (lambda-parameters exp))
(if (= (length lam-body) 1)
(first lam-body)
(make-Seq lam-body))
(map env-reference-depth closure-references))))]
[(begin? exp) [(begin? exp)
(let ([actions (map (lambda (e) (let ([actions (map (lambda (e)
(parse e cenv)) (parse e cenv))
(begin-actions exp))]) (begin-actions exp))])
(cond (seq actions))]
[(= 1 (length actions))
(car actions)]
[else
(make-Seq actions)]))]
[(named-let? exp) [(named-let? exp)
(parse (desugar-named-let exp) cenv)] (parse (desugar-named-let exp) cenv)]
[(let*? exp) [(let*? exp)
(parse (desugar-let* exp) cenv)] (parse (desugar-let* exp) cenv)]
[(let? exp) [(let? exp)
(parse-let exp cenv)] (parse-let exp cenv)]
[(letrec? exp) [(letrec? exp)
(parse-letrec exp cenv)] (parse-letrec exp cenv)]
[(set!? exp)
(let ([address (find-variable (set!-name exp) cenv)])
(cond
[(EnvLexicalReference? address)
(make-InstallValue (EnvLexicalReference-depth address)
(parse (set!-value exp) cenv)
#t)]
[(EnvPrefixReference? address)
(make-ToplevelSet (EnvPrefixReference-depth address)
(EnvPrefixReference-pos address)
(definition-variable exp)
(parse (set!-value exp) cenv))]))]
;; Remember, this needs to be the last case.
[(application? exp) [(application? exp)
(let ([cenv-with-scratch-space (let ([cenv-with-scratch-space
(extend-lexical-environment/placeholders cenv (length (operands exp)))]) (extend-lexical-environment/placeholders cenv (length (operands exp)))])
@ -119,9 +111,48 @@
(define (parse-lambda exp cenv)
(let* ([unbound-names (find-unbound-names exp)]
[mutated-parameters (list-intersection (find-mutated-names `(begin ,@(lambda-body exp)))
(lambda-parameters exp))]
[closure-references (collect-lexical-references
(map (lambda (var)
(find-variable var cenv))
unbound-names))]
[body-cenv (lexical-references->compile-time-environment
closure-references
cenv
(extend-lexical-environment/parameter-names '()
(lambda-parameters exp)
(map (lambda (p)
(and (member p mutated-parameters) #t))
(lambda-parameters exp)))
unbound-names)])
(let ([lam-body (foldl (lambda (a-mutated-param code)
(make-BoxEnv (env-reference-depth (find-variable a-mutated-param body-cenv))
code))
(seq (map (lambda (b)
(parse b body-cenv))
(lambda-body exp)))
mutated-parameters)])
(make-Lam (current-defined-name)
(length (lambda-parameters exp))
lam-body
(map env-reference-depth closure-references)))))
(define (seq codes)
(cond
[(= 1 (length codes))
(first codes)]
[else
(make-Seq codes)]))
;; find-unbound-names: Any -> (Listof Symbol) ;; find-unbound-names: Any -> (Listof Symbol)
;; Fixme: Cache this.
(define (find-unbound-names exp) (define (find-unbound-names exp)
(unique/eq? (unique/eq?
(let loop ([exp exp]) (let loop ([exp exp])
@ -170,14 +201,81 @@
(apply append (map loop (let-body exp)))) (apply append (map loop (let-body exp))))
(let-variables exp))] (let-variables exp))]
[(set!? exp)
(cons (set!-name exp)
(loop (set!-value exp)))]
;; Remember: this needs to be the last case.
[(application? exp)
(append (loop (operator exp))
(apply append (map loop (operands exp))))]
[else
(error 'find-unbound-names "Unknown expression type ~e" exp)]))))
;; find-mutated-names: any -> (listof symbol)
;; Fixme: cache this.
;; Produces a set of the free names mutated in the expression.
(define (find-mutated-names exp)
(unique/eq?
(let loop ([exp exp])
(cond
[(self-evaluating? exp)
'()]
[(quoted? exp)
'()]
[(variable? exp)
'()]
[(definition? exp)
(loop (definition-value exp))]
[(if? exp)
(append (loop (if-predicate exp))
(loop (if-consequent exp))
(loop (if-alternative exp)))]
[(cond? exp)
(loop (desugar-cond exp))]
[(lambda? exp)
(list-difference (loop (lambda-body exp))
(lambda-parameters exp))]
[(begin? exp)
(apply append (map loop (begin-actions exp)))]
[(named-let? exp)
(loop (desugar-named-let exp))]
[(let*? exp)
(loop (desugar-let* exp))]
[(let? exp)
(append (apply append (map loop (let-rhss exp)))
(list-difference (apply append (map loop (let-body exp)))
(let-variables exp)))]
[(letrec? exp)
(list-difference (append (apply append (map loop (let-rhss exp)))
(apply append (map loop (let-body exp))))
(let-variables exp))]
[(set!? exp)
(cons (set!-name exp)
(loop (set!-value exp)))]
;; Remember, this needs to be the last case.
[(application? exp) [(application? exp)
(append (loop (operator exp)) (append (loop (operator exp))
(apply append (map loop (operands exp))))] (apply append (map loop (operands exp))))]
[else [else
(error 'find-unbound-names "Unknown expression type ~e" exp)])))) (error 'mutated? "Unknown expression type ~e" exp)]))))
@ -274,7 +372,7 @@
`(if ,question `(if ,question
,answer ,answer
,(loop (cdr clauses))))]))) ,(loop (cdr clauses))))])))
(define (parse-let exp cenv) (define (parse-let exp cenv)
@ -292,17 +390,17 @@
[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 (seq (append
(map (lambda (var rhs index) (map (lambda (var rhs index)
(make-InstallValue index (make-InstallValue index
(parameterize ([current-defined-name var]) (parameterize ([current-defined-name var])
(parse rhs rhs-cenv)) (parse rhs rhs-cenv))
#f)) #f))
vars 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)
(extend-lexical-environment/names cenv vars))))) (extend-lexical-environment/names cenv vars)))))
#f))]))) #f))])))
(define (parse-letrec exp cenv) (define (parse-letrec exp cenv)
@ -315,7 +413,7 @@
[else [else
(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 (seq (append
(map (lambda (var rhs index) (map (lambda (var rhs index)
(make-InstallValue index (make-InstallValue index
(parameterize ([current-defined-name var]) (parameterize ([current-defined-name var])
@ -339,7 +437,7 @@
`(let ([,(car vars) ,(car rhss)]) `(let ([,(car vars) ,(car rhss)])
,(loop (cdr vars) (cdr rhss)))])))) ,(loop (cdr vars) (cdr rhss)))]))))
(define (desugar-named-let exp) (define (desugar-named-let exp)
@ -348,8 +446,8 @@
,@(named-let-body exp)))] ,@(named-let-body exp)))]
(,(named-let-name exp) ,@(named-let-rhss exp)))) (,(named-let-name exp) ,@(named-let-rhss exp))))
(define (named-let? exp) (define (named-let? exp)
(and (tagged-list? exp 'let) (and (tagged-list? exp 'let)
(symbol? (cadr exp)))) (symbol? (cadr exp))))
@ -394,4 +492,14 @@
;; let -> (listof expr) ;; let -> (listof expr)
(define (let-body exp) (define (let-body exp)
(cddr exp)) (cddr exp))
(define (set!? exp)
(tagged-list? exp 'set!))
(define (set!-name exp)
(cadr exp))
(define (set!-value exp)
(caddr exp))