From c9066c26541ec62c9a45d15bbb888aecd933be32 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 20 Feb 2011 16:32:12 -0500 Subject: [PATCH] simplifying structure a little --- assemble.rkt | 28 ++++++++++++++++++---------- compile.rkt | 18 +++++++++--------- typed-structs.rkt | 17 +++++------------ 3 files changed, 32 insertions(+), 31 deletions(-) diff --git a/assemble.rkt b/assemble.rkt index 65e2399..8b8db51 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -7,6 +7,7 @@ ;; assemble/write-invoke: (listof statement) output-port -> void +(: assemble/write-invoke ((Listof Statement) Output-Port -> Void)) (define (assemble/write-invoke stmts op) (let ([basic-blocks (fracture stmts)]) (fprintf op "function(k) {\n") @@ -22,6 +23,7 @@ ;; fracture: (listof stmt) -> (listof basic-block) +(: fracture ((Listof Statement) -> (Listof BasicBlock))) (define (fracture stmts) (let* ([first-block-label (make-label 'start)] [jump-targets @@ -43,7 +45,7 @@ (cons (make-basic-block name (if last-stmt-goto? (reverse acc) - (reverse (append `((goto (label ,(car stmts)))) + (reverse (append `(,(make-GotoStatement (make-Label (car stmts)))) acc)))) basic-blocks) (cdr stmts) @@ -59,11 +61,12 @@ (cons (car stmts) acc) basic-blocks (cdr stmts) - (tagged-list? (car stmts) 'goto))])))) + (GotoStatement? (car stmts)))])))) ;; unique: (listof symbol -> listof symbol) +(: unique ((Listof symbol) -> (Listof Symbol))) (define (unique los) (let ([ht (make-hasheq)]) (for ([l los]) @@ -74,22 +77,23 @@ ;; collect-general-jump-targets: (listof stmt) -> (listof label) ;; 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) (define (collect-input an-input) (cond - [(reg? an-input) + [(Reg? an-input) empty] - [(const? an-input) + [(Const? an-input) empty] - [(label? an-input) - (list (label-name an-input))] + [(Label? an-input) + (list (Label-name an-input))] [else (error 'collect-input "~e" an-input)])) (define (collect-location a-location) (cond - [(reg? a-location) + [(Reg? a-location) empty] - [(label? a-location) - (list (label-name a-location))] + [(Label? a-location) + (list (Label-name a-location))] [else (error 'collect-location "~e" a-location)])) (unique (let loop ([stmts stmts]) @@ -135,7 +139,8 @@ ;; indirect jumps. ;; The only interesting case should be where there's a register assignment ;; whose value is a label. -(define (collect-indirect-jump-targets stmts) +#;(: collect-indirect-jump-targets ((Listof Statement) -> (Listof Symbol))) +#;(define (collect-indirect-jump-targets stmts) (define (collect-input an-input) (cond [(reg? an-input) @@ -196,6 +201,7 @@ ;; assemble-basic-block: basic-block -> string +(: assemble-basic-block (BasicBlock -> String)) (define (assemble-basic-block a-basic-block) (format "var ~a=function(){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};" (basic-block-name a-basic-block) @@ -205,6 +211,7 @@ ;; assemble-stmt: stmt -> string +(: assemble-stmt (Statement -> String)) (define (assemble-stmt stmt) (cond [(tagged-list? stmt 'assign) @@ -250,6 +257,7 @@ [else (error 'assemble "~a" stmt)])) ;; fixme: use js->string +(: Assemble-Const (Any -> String)) (define (assemble-const stmt) (let loop ([val (cadr stmt)]) (cond [(symbol? val) diff --git a/compile.rkt b/compile.rkt index d8e5684..c8ef070 100644 --- a/compile.rkt +++ b/compile.rkt @@ -100,7 +100,7 @@ (make-instruction-sequence '() (list target) - `(,(make-AssignConstantStatement target exp))))) + `(,(make-AssignImmediateStatement target (make-Const exp)))))) (: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-quoted exp cenv target linkage) @@ -108,7 +108,7 @@ (make-instruction-sequence '() (list target) - `(,(make-AssignConstantStatement target (Quote-text exp)))))) + `(,(make-AssignImmediateStatement target (make-Const (Quote-text exp))))))) (: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-variable exp cenv target linkage) @@ -160,7 +160,7 @@ (list (make-Const var) (make-Reg 'val) (make-Reg 'env))) - ,(make-AssignConstantStatement target 'ok)))))] + ,(make-AssignImmediateStatement target (make-Const 'ok))))))] [else (end-with-linkage linkage @@ -174,7 +174,7 @@ (make-Const (second lexical-address)) (make-Reg 'env) (make-Reg 'val))) - ,(make-AssignConstantStatement target 'ok)))))]))) + ,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) ;; FIXME: exercise 5.43 @@ -195,7 +195,7 @@ (list (make-Const var) (make-Reg 'val) (make-Reg 'env))) - ,(make-AssignConstantStatement target 'ok))))))) + ,(make-AssignImmediateStatement target (make-Const 'ok)))))))) (: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) @@ -297,7 +297,7 @@ (if (null? operand-codes) (make-instruction-sequence '() '(argl) - `(,(make-AssignConstantStatement 'argl '()))) + `(,(make-AssignImmediateStatement 'argl (make-Const '())))) (let ([code-to-get-last-arg (append-instruction-sequences (car operand-codes) @@ -362,7 +362,7 @@ (make-instruction-sequence '(proc) all-regs - `(,(make-AssignLabelStatement 'cont linkage) + `(,(make-AssignImmediateStatement 'cont (make-Label linkage)) ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry (list (make-Reg 'proc))) ,(make-GotoStatement (make-Reg 'val))))] @@ -372,12 +372,12 @@ (make-instruction-sequence '(proc) all-regs - `(,(make-AssignLabelStatement 'cont proc-return) + `(,(make-AssignImmediateStatement 'cont (make-Label proc-return)) ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry (list (make-Reg 'proc))) ,(make-GotoStatement (make-Reg 'val)) ,proc-return - ,(make-AssignRegisterStatement target 'val) + ,(make-AssignImmediateStatement target (make-Reg 'val)) ,(make-GotoStatement (make-Label linkage)))))] [(and (eq? target 'val) (eq? linkage 'return)) diff --git a/typed-structs.rkt b/typed-structs.rkt index 6437d5c..673c394 100644 --- a/typed-structs.rkt +++ b/typed-structs.rkt @@ -32,9 +32,7 @@ ;; instruction sequences (define-type Statement (U Symbol ;; label - AssignConstantStatement - AssignLabelStatement - AssignRegisterStatement + AssignImmediateStatement AssignPrimOpStatement PerformStatement TestStatement @@ -42,14 +40,8 @@ GotoStatement SaveStatement RestoreStatement)) -(define-struct: AssignConstantStatement ([target : Symbol] - [value : Any]) - #:transparent) -(define-struct: AssignRegisterStatement ([target : Symbol] - [reg : Symbol]) - #:transparent) -(define-struct: AssignLabelStatement ([target : Symbol] - [label : Symbol]) +(define-struct: AssignImmediateStatement ([target : Symbol] + [value : (U Const Reg Label)]) #:transparent) (define-struct: AssignPrimOpStatement ([target : Symbol] [op : Symbol] @@ -110,4 +102,5 @@ -(define-struct: basic-block ([name : Symbol] [stmts : (Listof Statement)]) #:transparent) +(define-struct: basic-block ([name : Symbol] + [stmts : (Listof Statement)]) #:transparent)