103 lines
3.8 KiB
Racket
103 lines
3.8 KiB
Racket
#lang typed/racket/base
|
|
|
|
(require "assemble-structs.rkt"
|
|
"collect-jump-targets.rkt"
|
|
"../compiler/il-structs.rkt"
|
|
"../compiler/expression-structs.rkt"
|
|
"../parameters.rkt"
|
|
racket/list)
|
|
|
|
|
|
;; Breaks up a sequence of statements into a list of basic blocks.
|
|
;;
|
|
;; The first basic block is special, and represents the start of execution.
|
|
;;
|
|
;; A basic block consists of a sequence of straight line statements, followed by one of
|
|
;; the following:
|
|
;;
|
|
;; * A conditional jump.
|
|
;; * An unconditional jump.
|
|
;; * Termination.
|
|
|
|
(provide fracture)
|
|
|
|
|
|
|
|
|
|
;; fracture: (listof stmt) -> (listof basic-block)
|
|
(: fracture ((Listof Statement) -> (values (Listof BasicBlock)
|
|
(Listof Symbol))))
|
|
(define (fracture stmts)
|
|
|
|
(define start-time (current-inexact-milliseconds))
|
|
|
|
(define-values (blocks entries)
|
|
(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))]
|
|
[entry-points : (Listof Symbol)
|
|
(cons first-block-label (collect-entry-points stmts))])
|
|
|
|
(define jump-targets-ht ((inst make-hasheq Symbol Boolean)))
|
|
(for ([name jump-targets])
|
|
(hash-set! jump-targets-ht name #t))
|
|
|
|
(set! start-time (current-inexact-milliseconds))
|
|
(let: loop : (values (Listof BasicBlock) (Listof Symbol))
|
|
([name : Symbol first-block-label]
|
|
[acc : (Listof UnlabeledStatement) '()]
|
|
[basic-blocks : (Listof BasicBlock) '()]
|
|
[stmts : (Listof Statement) stmts]
|
|
[last-stmt-goto? : Boolean #f])
|
|
(cond
|
|
[(null? stmts)
|
|
(values (reverse (cons (make-BasicBlock name (reverse acc))
|
|
basic-blocks))
|
|
entry-points)]
|
|
[else
|
|
(let: ([first-stmt : Statement (car stmts)])
|
|
(: do-on-label (Symbol -> (values (Listof BasicBlock) (Listof Symbol))))
|
|
(define (do-on-label label-name)
|
|
(cond
|
|
[(hash-has-key? jump-targets-ht label-name)
|
|
(loop label-name
|
|
'()
|
|
(cons (make-BasicBlock
|
|
name
|
|
(if last-stmt-goto?
|
|
(reverse acc)
|
|
(reverse (cons (make-GotoStatement (make-Label label-name))
|
|
acc))))
|
|
basic-blocks)
|
|
(cdr stmts)
|
|
last-stmt-goto?)]
|
|
[else
|
|
(loop name
|
|
acc
|
|
basic-blocks
|
|
(cdr stmts)
|
|
last-stmt-goto?)]))
|
|
(cond
|
|
[(symbol? first-stmt)
|
|
(do-on-label first-stmt)]
|
|
[(LinkedLabel? first-stmt)
|
|
(do-on-label (LinkedLabel-label first-stmt))]
|
|
[else
|
|
(loop name
|
|
(cons first-stmt acc)
|
|
basic-blocks
|
|
(cdr stmts)
|
|
(GotoStatement? (car stmts)))]))]))))
|
|
|
|
(define end-time (current-inexact-milliseconds))
|
|
(fprintf (current-timing-port) " assemble fracture: ~a milliseconds\n" (- end-time start-time))
|
|
|
|
(values blocks entries))
|