diff --git a/assemble.rkt b/assemble.rkt index 6a324d2..f3f72a7 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -68,31 +68,59 @@ EOF [(null? stmts) (reverse (cons (make-BasicBlock name (reverse acc)) basic-blocks))] - [(symbol? (car stmts)) - (cond - [(member (car stmts) jump-targets) - (loop (car stmts) - '() - (cons (make-BasicBlock name - (if last-stmt-goto? - (reverse acc) - (reverse (append `(,(make-GotoStatement (make-Label (car stmts)))) - acc)))) - basic-blocks) - (cdr stmts) - last-stmt-goto?)] - [else - (loop name - acc - basic-blocks - (cdr stmts) - last-stmt-goto?)])] [else - (loop name - (cons (car stmts) acc) - basic-blocks - (cdr stmts) - (GotoStatement? (car stmts)))])))) + (let ([first-stmt (car stmts)]) + (cond + + [(symbol? first-stmt) + (cond + [(member first-stmt jump-targets) + (loop first-stmt + '() + (cons (make-BasicBlock + name + (if last-stmt-goto? + (reverse acc) + (reverse (append `(,(make-GotoStatement (make-Label first-stmt))) + acc)))) + basic-blocks) + (cdr stmts) + last-stmt-goto?)] + [else + (loop name + acc + basic-blocks + (cdr stmts) + last-stmt-goto?)])] + + [(PairedLabel? first-stmt) + (cond + [(member (PairedLabel-label first-stmt) jump-targets) + (loop (PairedLabel-label first-stmt) + '() + (cons (make-BasicBlock + name + (if last-stmt-goto? + (reverse acc) + (reverse (append `(,(make-GotoStatement + (make-Label (PairedLabel-label first-stmt)))) + acc)))) + basic-blocks) + (cdr stmts) + last-stmt-goto?)] + [else + (loop name + acc + basic-blocks + (cdr stmts) + last-stmt-goto?)])] + + [else + (loop name + (cons first-stmt acc) + basic-blocks + (cdr stmts) + (GotoStatement? first-stmt))]))])))) @@ -176,6 +204,8 @@ EOF (append (cond [(symbol? stmt) empty] + [(PairedLabel? stmt) + (list (PairedLabel-previous stmt))] [(AssignImmediateStatement? stmt) (let: ([v : OpArg (AssignImmediateStatement-value stmt)]) (cond diff --git a/il-structs.rkt b/il-structs.rkt index 97c83e4..5dbdffd 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -52,6 +52,9 @@ + + + ;; instruction sequences (define-type UnlabeledStatement (U @@ -73,6 +76,7 @@ (define-type Statement (U UnlabeledStatement Symbol ;; label + PairedLabel )) (define-struct: AssignImmediateStatement ([target : Target] @@ -292,6 +296,24 @@ +;; A PairedLabel is like a regular label, but it knows about +;; a previous label as well. Used for efficient implementation +;; of multiple return values. +(define-struct: PairedLabel ([label : Symbol] + [previous : Symbol])) + + + +(: make-paired-labels (Symbol -> (values Symbol PairedLabel))) +(define (make-paired-labels name) + (let* ([first-label (make-label name)] + [second-label (make-label name)]) + (values first-label (make-PairedLabel second-label first-label)))) + + + + + ;; Linkage (define-struct: NextLinkage ()) diff --git a/simulator.rkt b/simulator.rkt index eeddfca..3cf8411 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -61,6 +61,8 @@ (let: ([stmt : Statement (vector-ref (machine-text m) i)]) (when (symbol? stmt) (hash-set! (machine-jump-table m) stmt i)) + (when (PairedLabel? stmt) + (hash-set! (machine-jump-table m) (PairedLabel-label stmt) i)) (loop (add1 i))))) m))])) @@ -88,6 +90,8 @@ (cond [(symbol? i) 'ok] + [(PairedLabel? i) + 'ok] [(AssignImmediateStatement? i) (step-assign-immediate! m i)] [(AssignPrimOpStatement? i)