diff --git a/compile.rkt b/compile.rkt index c8ef070..1c14275 100644 --- a/compile.rkt +++ b/compile.rkt @@ -1,6 +1,8 @@ #lang typed/racket/base (require "typed-structs.rkt" + "lexical-env.rkt" + "helpers.rkt" racket/list) (provide compile) @@ -13,39 +15,6 @@ -;; A compile-time environment is a (listof (listof symbol)). -;; A lexical address is either a 2-tuple (depth pos), or 'not-found. -(define-type CompileTimeEnvironment (Listof (Listof Symbol))) -(define-type LexicalAddress (U (List Number Number) 'not-found)) - - - -;; find-variable: symbol compile-time-environment -> lexical-address -;; Find where the variable should be located. -(: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress)) -(define (find-variable name cenv) - (: find-pos (Symbol (Listof Symbol) -> Natural)) - (define (find-pos sym los) - (cond - [(eq? sym (car los)) - 0] - [else - (add1 (find-pos sym (cdr los)))])) - (let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv] - [depth : Natural 0]) - (cond [(empty? cenv) - 'not-found] - [(member name (first cenv)) - (list depth (find-pos name (first cenv)))] - [else - (loop (rest cenv) (add1 depth))]))) - - - -;; extend-lexical-environment: lexical-environment (listof symbol) -> lexical-envrionment -(: extend-lexical-environment (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment)) -(define (extend-lexical-environment cenv names) - (cons names cenv)) ;; compile: expression target linkage -> instruction-sequence @@ -72,9 +41,8 @@ target linkage)] [(App? exp) - (compile-application exp cenv target linkage)] - [else - (error 'compile "Unknown expression type ~e" exp)])) + (compile-application exp cenv target linkage)])) + (: compile-linkage (Linkage -> InstructionSequence)) @@ -449,22 +417,8 @@ (append-2-sequences (car seqs) (append-seq-list (cdr seqs))))) -(: list-union ((Listof Symbol) (Listof Symbol) -> (Listof Symbol))) -(define (list-union s1 s2) - (cond [(null? s1) s2] - [(memq (car s1) s2) - (list-union (cdr s1) s2)] - [else (cons (car s1) (list-union (cdr s1) s2))])) -(: list-difference ((Listof Symbol) (Listof Symbol) -> (Listof Symbol))) -(define (list-difference s1 s2) - (cond [(null? s1) '()] - [(memq (car s1) s2) - (list-difference (cdr s1) s2)] - [else - (cons (car s1) (list-difference (cdr s1) s2))])) - (: tack-on-instruction-sequence (InstructionSequence InstructionSequence -> InstructionSequence)) (define (tack-on-instruction-sequence seq body-seq) @@ -481,34 +435,3 @@ (registers-modified seq2)) (append (statements seq1) (statements seq2)))) - - - - - - - - - - - - - - - - -#;(define (test source-code) - (let ([basic-blocks - (fracture (statements (compile source-code - '() - 'val - 'return)))]) - (printf "var invoke = function(MACHINE, k) {\n") - (for-each (lambda (basic-block) - (displayln (assemble-basic-block basic-block)) - (newline)) - basic-blocks) - (printf "MACHINE.cont = k;\n") - (printf "trampoline(~a, function() {}); };\n" - (basic-block-name (first basic-blocks))))) - diff --git a/find-toplevel-variables.rkt b/find-toplevel-variables.rkt new file mode 100644 index 0000000..50e31af --- /dev/null +++ b/find-toplevel-variables.rkt @@ -0,0 +1,39 @@ +#lang typed/racket/base +(require "typed-structs.rkt" + "helpers.rkt" + racket/list) + +;; Collects the list of toplevel variables we need. + +(: find-toplevel (Expression -> (Listof Symbol))) +(define (find-toplevel exp) + (cond + [(Constant? exp) + empty] + + [(Quote? exp) + empty] + + [(Var? exp) + (list (Var-id exp))] + + [(Assign? exp) + (find-toplevel (Assign-value exp))] + + [(Def? exp) + (find-toplevel (Def-value exp))] + + [(Branch? exp) + (append (find-toplevel (Branch-predicate exp)) + (find-toplevel (Branch-consequent exp)) + (find-toplevel (Branch-alternative exp)))] + + [(Lam? exp) + (list-difference (apply append (map find-toplevel (Lam-body exp))) + (Lam-parameters exp))] + [(Seq? exp) + (apply append (map find-toplevel (Seq-actions exp)))] + + [(App? exp) + (append (find-toplevel (App-operator exp)) + (apply append (map find-toplevel (App-operands exp))))])) diff --git a/helpers.rkt b/helpers.rkt new file mode 100644 index 0000000..786b65a --- /dev/null +++ b/helpers.rkt @@ -0,0 +1,20 @@ +#lang typed/racket/base + +(provide list-union list-difference) + + +(: list-union ((Listof Symbol) (Listof Symbol) -> (Listof Symbol))) +(define (list-union s1 s2) + (cond [(null? s1) s2] + [(memq (car s1) s2) + (list-union (cdr s1) s2)] + [else (cons (car s1) (list-union (cdr s1) s2))])) + + +(: list-difference ((Listof Symbol) (Listof Symbol) -> (Listof Symbol))) +(define (list-difference s1 s2) + (cond [(null? s1) '()] + [(memq (car s1) s2) + (list-difference (cdr s1) s2)] + [else + (cons (car s1) (list-difference (cdr s1) s2))])) \ No newline at end of file diff --git a/lexical-env.rkt b/lexical-env.rkt new file mode 100644 index 0000000..d6a9406 --- /dev/null +++ b/lexical-env.rkt @@ -0,0 +1,33 @@ +#lang typed/racket/base + +(require racket/list + "typed-structs.rkt") +(provide find-variable extend-lexical-environment) + + +;; find-variable: symbol compile-time-environment -> lexical-address +;; Find where the variable should be located. +(: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress)) +(define (find-variable name cenv) + (: find-pos (Symbol (Listof Symbol) -> Natural)) + (define (find-pos sym los) + (cond + [(eq? sym (car los)) + 0] + [else + (add1 (find-pos sym (cdr los)))])) + (let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv] + [depth : Natural 0]) + (cond [(empty? cenv) + 'not-found] + [(member name (first cenv)) + (list depth (find-pos name (first cenv)))] + [else + (loop (rest cenv) (add1 depth))]))) + + + +;; extend-lexical-environment: lexical-environment (listof symbol) -> lexical-envrionment +(: extend-lexical-environment (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment)) +(define (extend-lexical-environment cenv names) + (cons names cenv)) \ No newline at end of file diff --git a/typed-structs.rkt b/typed-structs.rkt index 0a4149e..f9db437 100644 --- a/typed-structs.rkt +++ b/typed-structs.rkt @@ -132,3 +132,16 @@ (define-struct: BasicBlock ([name : Symbol] [stmts : (Listof UnlabeledStatement)]) #:transparent) + + +;;;;;;;;;;;;;; + +;; Lexical environments + + +;; A compile-time environment is a (listof (listof symbol)). +;; A lexical address is either a 2-tuple (depth pos), or 'not-found. +(define-type CompileTimeEnvironment (Listof (Listof Symbol))) +(define-type LexicalAddress (U (List Number Number) 'not-found)) + +(define-struct: Prefix ([names : (Listof Symbol)])) \ No newline at end of file