#lang scheme/base
(require
"../target.ss"
"../tools.ss"
"../ns.ss"
"../scat.ss"
"../coma/macro.ss"
"../control/2stack.ss"
scheme/pretty
scheme/match)
(provide
words->cfg!
macro->postprocess
empty-ctrl->asm
assert-empty-ctrl
)
(define (empty-ctrl->asm state [name ""])
(match state
((struct 2stack (ctor asm ctrl))
(unless (null? ctrl)
(error 'non-null-compilation-stack
"~a ~s" name ctrl))
asm)))
(define (assert-empty-ctrl . a) (void (apply empty-ctrl->asm a)))
(define (words->cfg! compiled-words [postproc-asm
(lambda (x) x)])
(define roots (link! compiled-words))
(define (all: . fns)
(let ((words (apply append (map target-chain->list roots))))
(for-each (lambda (fn) (for-each fn words)) fns)))
(all: (target-post! postproc-asm))
roots)
(define (link! chains)
(define link-chain!
(match-lambda
((list w) w)
((list-rest w+ w ws)
(set-target-word-next! w w+)
(link-chain! (cons w ws)))))
(define (link-code! word code)
(set-target-word-code! word code)
word)
(map link-chain!
(map (lambda (chain)
(map* link-code! chain))
chains)))
(define ((target-post! postproc-asm) word)
(set-target-word-code! word
(postproc-asm (target-word-code word))))
(define (macro->postprocess macro [name #f])
(lambda (reverse-asm)
(let next ((in-asm (reverse reverse-asm))
(out-asm '()))
(if (null? in-asm)
out-asm
(let* ((in (cons (car in-asm) out-asm))
(out (empty-ctrl->asm
(macro (make-state:2stack in '())))))
(when name
(printf "postproc: ~a\n" name)
(for ((a (reverse in))) (printf "\t~a\n" (instruction->string a))) (display "->\n")
(for ((a (reverse out))) (printf "\t~a\n" (instruction->string a))) (display "\n\n"))
(next (cdr in-asm) out))))))