From 27781a1dff8befabefef6a133f51871a6cb2223d Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 21 Mar 2011 23:17:42 -0400 Subject: [PATCH] parser recognizes set! for parameters --- expression-structs.rkt | 6 +- helpers.rkt | 10 +- lexical-env.rkt | 28 +++--- lexical-structs.rkt | 6 +- parse.rkt | 202 +++++++++++++++++++++++++++++++---------- 5 files changed, 188 insertions(+), 64 deletions(-) diff --git a/expression-structs.rkt b/expression-structs.rkt index ffedaec..fe7ae61 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -11,7 +11,8 @@ Branch Lam Seq App Let1 LetVoid - InstallValue)) + InstallValue + BoxEnv)) (define-struct: Top ([prefix : Prefix] [code : ExpressionCore]) #:transparent) @@ -58,6 +59,9 @@ #:transparent) +(define-struct: BoxEnv ([depth : Natural] + [body : ExpressionCore]) + #:transparent) diff --git a/helpers.rkt b/helpers.rkt index 015ac02..c0a37f2 100644 --- a/helpers.rkt +++ b/helpers.rkt @@ -1,6 +1,6 @@ #lang typed/racket/base (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))) @@ -19,6 +19,14 @@ [else (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: (define string-sort (inst sort String String)) diff --git a/lexical-env.rkt b/lexical-env.rkt index 4fe5048..21cb775 100644 --- a/lexical-env.rkt +++ b/lexical-env.rkt @@ -6,8 +6,10 @@ (provide find-variable extend-lexical-environment extend-lexical-environment/names + extend-lexical-environment/parameter-names extend-lexical-environment/boxed-names extend-lexical-environment/placeholders + collect-lexical-references lexical-references->compile-time-environment place-prefix-mask @@ -29,7 +31,7 @@ ([cenv : CompileTimeEnvironment cenv] [depth : Natural 0]) (cond [(empty? cenv) - (error 'find-variable "~s not in lexical environment" cenv)] + (error 'find-variable "~s not in lexical environment" name)] [else (let: ([elt : CompileTimeEnvironmentEntry (first cenv)]) (cond @@ -43,14 +45,7 @@ [(NamedBinding? elt) (cond [(eq? (NamedBinding-name elt) name) - (make-EnvLexicalReference depth #f)] - [else - (loop (rest cenv) (add1 depth))])] - - [(box? elt) - (cond - [(eq? (NamedBinding-name (unbox elt)) name) - (make-EnvLexicalReference depth #t)] + (make-EnvLexicalReference depth (NamedBinding-boxed? elt))] [else (loop (rest cenv) (add1 depth))])] @@ -81,13 +76,18 @@ (: extend-lexical-environment/names (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment)) (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)) (define (extend-lexical-environment/boxed-names cenv names) - (append (map (inst box NamedBinding) - (map make-NamedBinding names)) + (append (map (lambda: ([n : Symbol]) (make-NamedBinding n #f #t)) names) cenv)) @@ -187,10 +187,12 @@ (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) (cond [(EnvLexicalReference? a-ref) (EnvLexicalReference-depth a-ref)] + [(EnvPrefixReference? a-ref) + (EnvPrefixReference-depth a-ref)] [(EnvWholePrefixReference? a-ref) (EnvWholePrefixReference-depth a-ref)])) \ No newline at end of file diff --git a/lexical-structs.rkt b/lexical-structs.rkt index b5652c1..aeddb59 100644 --- a/lexical-structs.rkt +++ b/lexical-structs.rkt @@ -13,12 +13,14 @@ #:transparent) -(define-struct: NamedBinding ([name : Symbol])) +(define-struct: NamedBinding ([name : Symbol] + [parameter? : Boolean] + [boxed? : Boolean]) + #:transparent) (define-type CompileTimeEnvironmentEntry (U Prefix ;; a prefix NamedBinding - (Boxof NamedBinding) ;; A boxed local False)) diff --git a/parse.rkt b/parse.rkt index 140afe1..410bd31 100644 --- a/parse.rkt +++ b/parse.rkt @@ -66,48 +66,40 @@ (parse (desugar-cond exp) cenv)] [(lambda? exp) - (let* ([unbound-names (find-unbound-names 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/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))))] - + (parse-lambda exp cenv)] + [(begin? exp) (let ([actions (map (lambda (e) (parse e cenv)) (begin-actions exp))]) - (cond - [(= 1 (length actions)) - (car actions)] - [else - (make-Seq actions)]))] - + (seq actions))] + [(named-let? exp) (parse (desugar-named-let exp) cenv)] [(let*? exp) (parse (desugar-let* exp) cenv)] - + [(let? exp) (parse-let exp cenv)] [(letrec? exp) (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) (let ([cenv-with-scratch-space (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) +;; Fixme: Cache this. (define (find-unbound-names exp) (unique/eq? (let loop ([exp exp]) @@ -170,14 +201,81 @@ (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) + (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) (append (loop (operator exp)) (apply append (map loop (operands exp))))] [else - (error 'find-unbound-names "Unknown expression type ~e" exp)])))) - - + (error 'mutated? "Unknown expression type ~e" exp)])))) + @@ -274,7 +372,7 @@ `(if ,question ,answer ,(loop (cdr clauses))))]))) - + (define (parse-let exp cenv) @@ -292,17 +390,17 @@ [else (let ([rhs-cenv (extend-lexical-environment/placeholders cenv (length vars))]) (make-LetVoid (length vars) - (make-Seq (append - (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) - (extend-lexical-environment/names cenv vars))))) + (seq (append + (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) + (extend-lexical-environment/names cenv vars))))) #f))]))) (define (parse-letrec exp cenv) @@ -315,7 +413,7 @@ [else (let ([new-cenv (extend-lexical-environment/boxed-names cenv vars)]) (make-LetVoid (length vars) - (make-Seq (append + (seq (append (map (lambda (var rhs index) (make-InstallValue index (parameterize ([current-defined-name var]) @@ -339,7 +437,7 @@ `(let ([,(car vars) ,(car rhss)]) ,(loop (cdr vars) (cdr rhss)))])))) - + (define (desugar-named-let exp) @@ -348,8 +446,8 @@ ,@(named-let-body exp)))] (,(named-let-name exp) ,@(named-let-rhss exp)))) - - + + (define (named-let? exp) (and (tagged-list? exp 'let) (symbol? (cadr exp)))) @@ -394,4 +492,14 @@ ;; let -> (listof expr) (define (let-body exp) - (cddr exp)) \ No newline at end of file + (cddr exp)) + + +(define (set!? exp) + (tagged-list? exp 'set!)) + +(define (set!-name exp) + (cadr exp)) + +(define (set!-value exp) + (caddr exp)) \ No newline at end of file