From 9bed9d2ee1c57d97bd39c49760f7d534d92835d0 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 21 Feb 2011 14:49:54 -0500 Subject: [PATCH] commit --- assemble.rkt | 87 ++++++----------------------------------------- typed-structs.rkt | 32 ++++++++++++++--- 2 files changed, 38 insertions(+), 81 deletions(-) diff --git a/assemble.rkt b/assemble.rkt index cba1910..bb4c8bb 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -80,6 +80,7 @@ ;; collects all the labels that are potential targets for GOTOs or branches. (: collect-general-jump-targets ((Listof Statement) -> (Listof Symbol))) (define (collect-general-jump-targets stmts) + (: collect-input (OpArg -> (Listof Symbol))) (define (collect-input an-input) (cond [(Reg? an-input) @@ -87,15 +88,16 @@ [(Const? an-input) empty] [(Label? an-input) - (list (Label-name an-input))] - [else (error 'collect-input "~e" an-input)])) + (list (Label-name an-input))])) + + (: collect-location ((U Reg Label) -> (Listof Symbol))) (define (collect-location a-location) (cond [(Reg? a-location) empty] [(Label? a-location) - (list (Label-name a-location))] - [else (error 'collect-location "~e" a-location)])) + (list (Label-name a-location))])) + (unique (let loop ([stmts stmts]) (cond [(empty? stmts) @@ -132,71 +134,6 @@ -;; collect-indirect-jump-targets: (listof stmt) -> (listof label) -;; collects the labels that are potential targets for GOTOs or branches from -;; indirect jumps. -;; The only interesting case should be where there's a register assignment -;; whose value is a label. -#;(: collect-indirect-jump-targets ((Listof Statement) -> (Listof Symbol))) -#;(define (collect-indirect-jump-targets stmts) - (define (collect-input an-input) - (cond - [(reg? an-input) - empty] - [(const? an-input) - empty] - [(label? an-input) - empty] - [else (error 'collect-input "~e" an-input)])) - (define (collect-location a-location) - (cond - [(reg? a-location) - empty] - [(label? a-location) - empty] - [else - (error 'collect-location "~e" a-location)])) - (unique - (let loop ([stmts stmts]) - (cond [(empty? stmts) - empty] - [else - (let ([stmt (first stmts)]) - (append (cond - [(symbol? stmt) - empty] - [(tagged-list? stmt 'assign) - (cond - [(reg? (caddr stmt)) - empty] - [(label? (caddr stmt)) - ;; Watch assignments of labels into registers. - (list (label-name (caddr stmt)))] - [(const? (caddr stmt)) - empty] - [(op? (caddr stmt)) - empty] - [else - (error 'assemble "~a" stmt)])] - [(tagged-list? stmt 'perform) - empty] - [(tagged-list? stmt 'test) - empty] - [(tagged-list? stmt 'branch) - empty] - [(tagged-list? stmt 'goto) - empty] - [(tagged-list? stmt 'save) - empty] - [(tagged-list? stmt 'restore) - empty] - [else - (error 'assemble "~a" stmt)]) - (loop (rest stmts))))])))) - - - - ;; assemble-basic-block: basic-block -> string (: assemble-basic-block (BasicBlock -> String)) @@ -267,7 +204,7 @@ [else (format "~s" val)]))) -(: assemble-op-expression (Symbol (Listof OpArg) -> String)) +(: assemble-op-expression ((U PrimitiveOperator TestOperator) (Listof OpArg) -> String)) (define (assemble-op-expression op-name inputs) (let ([assembled-inputs (map assemble-input inputs)]) (case op-name @@ -315,11 +252,9 @@ [(lookup-variable-value) (format "((~a).globalBindings[~a])" (second assembled-inputs) - (first assembled-inputs))] - [else - (error 'assemble "~e" op-name)]))) + (first assembled-inputs))]))) -(: assemble-op-statement (Symbol (Listof OpArg) -> String)) +(: assemble-op-statement (PerformOperator (Listof OpArg) -> String)) (define (assemble-op-statement op-name inputs) (let ([assembled-inputs (map assemble-input inputs)]) (case op-name @@ -343,9 +278,7 @@ (format "if (! (~a).globalBindings.hasOwnProperty(~a)) { throw new Error(\"Not bound: \" + ~a); }" (second assembled-inputs) (first assembled-inputs) - (first assembled-inputs))] - [else - (error 'assemble-op-statement "~a" op-name)]))) + (first assembled-inputs))]))) diff --git a/typed-structs.rkt b/typed-structs.rkt index 9efb901..0a4149e 100644 --- a/typed-structs.rkt +++ b/typed-structs.rkt @@ -1,6 +1,9 @@ #lang typed/racket/base (provide (all-defined-out)) + +;; Expressions + (define-type Expression (U Constant Quote Var Assign Branch Def Lam Seq App)) (define-struct: Constant ([v : Any]) #:transparent) (define-struct: Quote ([text : Any]) #:transparent) @@ -29,7 +32,7 @@ (define (rest-exps seq) (cdr seq)) - +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; instruction sequences (define-type UnlabeledStatement (U @@ -48,12 +51,12 @@ [value : (U Const Reg Label)]) #:transparent) (define-struct: AssignPrimOpStatement ([target : Symbol] - [op : Symbol] + [op : PrimitiveOperator] [rands : (Listof (U Label Reg Const))]) #:transparent) -(define-struct: PerformStatement ([op : Symbol] +(define-struct: PerformStatement ([op : PerformOperator] [rands : (Listof (U Label Reg Const))]) #:transparent) -(define-struct: TestStatement ([op : (U 'false? 'primitive-procedure?)] +(define-struct: TestStatement ([op : TestOperator] [register-rand : Symbol]) #:transparent) (define-struct: BranchLabelStatement ([label : Symbol]) #:transparent) (define-struct: GotoStatement ([target : (U Label Reg)]) #:transparent) @@ -67,6 +70,22 @@ (define-type OpArg (U Const Label Reg)) +(define-type PrimitiveOperator (U 'compiled-procedure-entry + 'compiled-procedure-env + 'make-compiled-procedure + 'false? + 'cons + 'list + 'apply-primitive-procedure + 'lexical-address-lookup + 'extend-environment + 'lookup-variable-value)) +(define-type TestOperator (U 'false? 'primitive-procedure?)) +(define-type PerformOperator (U 'define-variable! + 'set-variable-value! + 'lexical-address-set! + 'check-bound-global!)) + @@ -106,5 +125,10 @@ + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Assembly + (define-struct: BasicBlock ([name : Symbol] [stmts : (Listof UnlabeledStatement)]) #:transparent)