127 lines
5.0 KiB
Racket
127 lines
5.0 KiB
Racket
#lang typed/racket/base
|
|
|
|
(require "assemble-structs.rkt"
|
|
"assemble-helpers.rkt"
|
|
"assemble-open-coded.rkt"
|
|
"assemble-expression.rkt"
|
|
"assemble-perform-statement.rkt"
|
|
"collect-jump-targets.rkt"
|
|
"../compiler/il-structs.rkt"
|
|
"../compiler/lexical-structs.rkt"
|
|
"../compiler/expression-structs.rkt"
|
|
"../helpers.rkt"
|
|
racket/string
|
|
racket/list)
|
|
|
|
;; Takes a sequence of statements, and breaks them down into basic
|
|
;; blocks.
|
|
;;
|
|
;; A basic block consists of a name, a sequence of straight-line statements,
|
|
;; followed by a Jump (conditional, direct, or end-of-program).
|
|
|
|
(provide fracture)
|
|
|
|
|
|
|
|
|
|
;; Make sure:
|
|
;;
|
|
;; The statements are non-empty, by adding a leading label if necessary
|
|
;; Filter out statements that are unreachable by jumps.
|
|
;; Eliminate redundant GOTOs.
|
|
(: cleanup-statements ((Listof Statement) -> (Listof Statement)))
|
|
(define (cleanup-statements stmts)
|
|
(let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
|
|
(symbol? (first stmts)))
|
|
(first stmts)
|
|
(make-label 'start))]
|
|
[stmts : (Listof Statement) (if (and (not (empty? stmts))
|
|
(symbol? (first stmts)))
|
|
(rest stmts)
|
|
stmts)]
|
|
[jump-targets : (Listof Symbol)
|
|
(cons first-block-label (collect-general-jump-targets stmts))])
|
|
stmts))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; ;; fracture: (listof stmt) -> (listof basic-block)
|
|
;; (: fracture ((Listof Statement) -> (Listof BasicBlock)))
|
|
;; (define (fracture stmts)
|
|
;; (let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
|
|
;; (symbol? (first stmts)))
|
|
;; (first stmts)
|
|
;; (make-label 'start))]
|
|
;; [stmts : (Listof Statement) (if (and (not (empty? stmts))
|
|
;; (symbol? (first stmts)))
|
|
;; (rest stmts)
|
|
;; stmts)]
|
|
;; [jump-targets : (Listof Symbol)
|
|
;; (cons first-block-label (collect-general-jump-targets stmts))])
|
|
;; (let: loop : (Listof BasicBlock)
|
|
;; ([name : Symbol first-block-label]
|
|
;; [acc : (Listof UnlabeledStatement) '()]
|
|
;; [basic-blocks : (Listof BasicBlock) '()]
|
|
;; [stmts : (Listof Statement) stmts])
|
|
;; (cond
|
|
;; [(null? stmts)
|
|
;; (reverse (cons (make-BasicBlock name (reverse acc) #f)
|
|
;; basic-blocks))]
|
|
;; [else
|
|
|
|
;; (: do-on-label (Symbol -> (Listof BasicBlock)))
|
|
;; (define (do-on-label label-name)
|
|
;; (loop label-name
|
|
;; '()
|
|
;; (cons (make-BasicBlock
|
|
;; name
|
|
;; (reverse acc)
|
|
;; (make-DirectJump label-name))
|
|
;; basic-blocks)
|
|
;; (cdr stmts))
|
|
;; )
|
|
|
|
;; (let: ([first-stmt : Statement (car stmts)])
|
|
;; (cond
|
|
;; [(symbol? first-stmt)
|
|
;; (do-on-label first-stmt)]
|
|
|
|
;; [(LinkedLabel? first-stmt)
|
|
;; (do-on-label (LinkedLabel-label first-stmt))]
|
|
|
|
;; [(GotoStatement? first-stmt)
|
|
;; (let ([target (GotoStatement-target first-stmt)])
|
|
;; (cond
|
|
;; [(Label? target)
|
|
;; (loop ...?
|
|
;; '()
|
|
;; (cons (make-BasicBlock
|
|
;; name
|
|
;; (reverse acc)
|
|
;; (make-DirectJump label-name))
|
|
;; basic-blocks)
|
|
;; (cdr stmts))]
|
|
;; [else
|
|
;; (loop ...?
|
|
;; '()
|
|
;; (cons (make-BasicBlock
|
|
;; name
|
|
;; (reverse acc)
|
|
;; (make-ComputedJump target))
|
|
;; basic-blocks)
|
|
;; (cdr stmts))]))]
|
|
|
|
;; [(TestAndJumpStatement? first-stmt)
|
|
;; ...]
|
|
|
|
;; [else
|
|
;; (loop name
|
|
;; (cons first-stmt acc)
|
|
;; basic-blocks
|
|
;; (cdr stmts))]))]))))
|
|
|