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

Trying to add prefix into the mix

Browse Source
This commit is contained in:
Danny Yoo 2011-02-21 15:08:56 -05:00
parent 9bed9d2ee1
commit 5599bc125f
5 changed files with 109 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
compile.rkt
View File

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

39
find-toplevel-variables.rkt Normal file
View File

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

20
helpers.rkt Normal file
View File

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

33
lexical-env.rkt Normal file
View File

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

13
typed-structs.rkt
View File

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