Mercurial > repos > hgweb.cgi > bootstrap
view genesis/baste/baste-pass3.church @ 1029:819bffdbe3eb
thread source location information through from parser to AST to LIR
basic support for emitting line numbers in stack trace
author | John Leuner <jewel@subvert-the-dominant-paradigm.net> |
---|---|
date | Thu, 20 Jun 2013 11:27:00 +0200 |
parents | 2868fb888d1b |
children | 8db85d0fb0ca |
line wrap: on
line source
;-------------------------------------------------------------------------------- ; Build LIR ; Virtual register ; can end up in a machine register or spilled to the stack class lir-vreg with-slots index original-local ; indicates the first of a chain of intervals used to allocate machine registers to this vreg ; depending on the position of use, the vreg may be live in one of several intervals, which may be allocated to ; different machine registers and may or may not be spilled before or after each interval first-interval ; certain vregs must be spilled to the stack to account for exception control flow must-spill? ; used by pass 5 to track the live interval as we walk over all the instructions and emit machine code current-interval out stream out "<" stream out (lir-arg-to-string self) stream ; out self.index stream out ": " stream if self.original-local out "(" stream out self.original-local.name stream out ")" stream out ">" stream ; a use of a virtual register ; a use is either reading or writing (input / output) global USE-INPUT = 1 global USE-OUTPUT = 2 ; a use may require that the operand must be in a register global USE-REGISTER-ONLY = 4 ; sometimes it can be in memory or a register but we prefer a register if possible global USE-REGISTER-PREFERRED = 8 ; other uses don't care global USE-REGISTER-OR-MEM = 16 class lir-use with-slots position input-output-kind register-use-kind coerce target assert (eq? target 'string) "bad target" output-str = "(" output-str = concat output-str (coerce self.position 'string) output-str = concat output-str " " output-str = concat output-str (if (== self.input-output-kind USE-INPUT) "r)" "w)") output-str ; represents a def followed by one or more uses ; multiple ranges are linked into a list inside a lir-interval class lir-live-range with-slots start end next ; the use list is not used by fixed intervals use-list out stream out "<range start: " stream out self.start stream out " end: " stream out self.end stream out "> " stream newline stream class lir-base-interval with-slots ranges last-range vreg ;; register assigned to this interval register ; each interval is stored in a linked list attached to the vreg ; they are also part of linked lists that make up the active,inactive, handled and unhandled lists, but these links are stored in a live-interval-list-element next start self.ranges.start end assert self.last-range "no last range?" self.last-range.end class lir-fixed-interval extends lir-base-interval next-conflict-after position range-iter = self.ranges loop while (and range-iter (< range-iter.end position)) do range-iter = range-iter.next max range-iter.start position next-use-after position error "should not be called" self class lir-interval extends lir-base-interval with-slots ;; spill slot assigned to this interval (if spilled) spill-slot-index ;; spill parent -- the interval which we must reload at the beginning of this interval spill-parent-interval ;; register used by SCC register allocator register out stream out "<int " stream out (start self) stream out "-" stream out (end self) stream out ">" stream first-use car self.ranges.use-list last-use range-iter = self.ranges loop while range-iter do if (null? range-iter.next) return-from last-use (car (last range-iter.use-list)) range-iter = range-iter.next error "no ranges in last-use" self next-use-after position ; iterate over ranges range-iter = self.ranges loop while range-iter do ; iterate over use-list use-iter = range-iter.use-list loop while use-iter do next-use = first use-iter if (>= next-use.position position) return-from next-use-after next-use use-iter = rest use-iter range-iter = range-iter.next nil split-interval-at-position position ; error "split interval" "use" out "splitting interval at " print position new-interval = new 'lir-interval :vreg self.vreg :next self.next :register nil self.next = new-interval ; find the range containing position prev = nil range-iter = self.ranges loop while range-iter do out " checking range " out (lir-arg-to-string self.vreg) out " " out range-iter.start out " " print range-iter.end ; was the position in a live hole? ; in that case just put this range (which follows the hole) into the new interval if (< position range-iter.start) new-interval.ranges = range-iter new-interval.last-range = self.last-range new-interval.vreg = self.vreg prev.next = nil self.last-range = prev return-from split-interval-at-position new-interval ; if the position is inside this range ; we need to shorten the current range and create a new range if (<= position range-iter.end) assert (> (next-use-after self position).position position) "bad next-use" assert (<= (next-use-after self position).position range-iter.end) "bad next-use" assert (<= (next-use-after self position) range-iter.end) "bad next use after" new-range = new 'lir-live-range :start (next-use-after self position).position :end range-iter.end :next range-iter.next new-interval.ranges = new-range if (eq? self.last-range range-iter) new-interval.last-range = new-range else new-interval.last-range = self.last-range new-interval.vreg = self.vreg self.last-range = range-iter range-iter.end = - position 1 range-iter.next = nil ; fixup use lists new-range.use-list = keep range-iter.use-list (fn use-pos >= use-pos.position position ) range-iter.use-list = keep range-iter.use-list (fn use-pos < use-pos.position position ) out "new interval " out (start new-interval) out "-" out (end new-interval) out " " print new-interval.ranges.use-list return-from split-interval-at-position new-interval prev = range-iter range-iter = range-iter.next error "position not found in split-interval-at-position" (list self position) ;-------------------------------------------------------------------------------- ; LIR loop ; ; used to represent a loop ; class lir-loop with-slots loop-start loop-end ;-------------------------------------------------------------------------------- ; LIR instructions class lir-instruction with-slots op output output-machine-register ; linked list of instructions next ; source code information source-information ; index ;; One argument class lir-instruction1 extends lir-instruction with-slots arg1 arg1-machine-register ;; Two arguments class lir-instruction2 extends lir-instruction1 with-slots arg2 arg2-machine-register class lir-address-of-data-object extends lir-instruction class lir-assign extends lir-instruction1 class lir-test extends lir-instruction1 class lir-prepare-call-arg extends lir-instruction1 with-slots fixed-register num-call-args arg-index class lir-deref extends lir-instruction2 class lir-constant extends lir-instruction with-slots constant class lir-arith extends lir-instruction2 class lir-call extends lir-instruction with-slots callee arguments class lir-tail-call extends lir-call class lir-branch extends lir-instruction with-slots target class lir-branch-zero extends lir-branch ; represents a fake control flow edge to a catch block ; no code is emitted for this instruction class lir-pseudo-branch-to-catch-block extends lir-branch class lir-conditional-branch extends lir-branch with-slots condition ; labels also act as basic blocks class lir-label extends lir-instruction with-slots name block-start block-end predecessors successors ; used for graph traversal algorithms color scc-number ; all blocks inside a catch block are marked so that we can ; find vregs used by the catch block and spill them to the stack inside-catch-block? out stream out "<" stream out self.name stream out " >" class lir-receive extends lir-instruction with-slots fixed-register class lir-release-call-arg extends lir-instruction1 class lir-return extends lir-instruction class lir-prepare-value-for-return extends lir-instruction1 ; represents the range covered by a handler ; and the entry point for the handler class lir-exception-handler with-slots start end handler class lir-function with-slots first-instruction last-instruction ; an array of virtual registers used to store temporary values vregs ; a dictionary mapping each vreg to an interval vreg-to-intervals-map ; array of length NUM-PHYSICAL-REGS containing vregs for each machine register fixed-vregs ; an list of alists containing (sym . <lir-label>) to map tagbody labels to lir instructions ; a new list is pushed/popped every time we enter/leave a tagbody form tagbody-labels ; a list of basic blocks basic-blocks ; the start block start-block ; a special basic block that terminates all control flow and returns from the function return-block ; an empty block just after the last instruction end-block ; bbs ordered in reverse postorder (DFN) dfns ; used in code emitter num-spill-slots-used exception-handlers add ins if (null? self.first-instruction) self.first-instruction = ins ins.next = nil self.last-instruction = ins else self.last-instruction.next = ins ins.next = nil self.last-instruction = ins ins new-vreg new-vreg self nil new-vreg original-local vreg = new 'lir-vreg :index (length self.vregs) :original-local original-local :current-interval nil add-last self.vregs vreg vreg add-new-label name inside-catch-block? source-information add self (create-new-label self name inside-catch-block? source-information) create-new-label name inside-catch-block? new 'lir-label :name name :op 'label :inside-catch-block? inside-catch-block? add-new-arith op lhs rhs source-information vreg = new-vreg self add self (new 'lir-arith :arg1 lhs :arg2 rhs :output vreg :op op :source-information source-information) vreg add-new-assign lhs rhs source-information add self (new 'lir-assign :arg1 rhs :output lhs :op 'assign :source-information source-information) lhs add-new-constant v source-information vreg = new-vreg self add self (new 'lir-constant :constant v :op 'constant :output vreg :source-information source-information) vreg add-new-return local source-information ; assert local "return without local" if local add self (new 'lir-prepare-value-for-return :op 'prepare-value-for-return :arg1 local :output nil :source-information source-information) ; FIXME, what is the default return value? add-new-branch self self.return-block source-information add-new-branch target source-information add self (new 'lir-branch :op 'branch :target target :source-information source-information) add-new-branch-zero target source-information add self (new 'lir-branch-zero :op 'branch-zero :target target :source-information source-information) add-new-test v source-information add self (new 'lir-test :op 'test :arg1 v :source-information source-information) add-new-deref vreg:lir-vreg offset source-information add self (new 'lir-deref :op 'deref :arg1 vreg :arg2 offset :source-information source-information) add-new-load-address-of-data-object arg source-information result = new-vreg self add self (new 'lir-address-of-data-object :op 'load-address-of-data-object :output result :source-information source-information) result add-new-call callee arg-temps source-information result-temp = new-vreg self add self (new 'lir-call :op 'call :callee callee :output result-temp :arguments arg-temps :source-information source-information) result-temp add-new-tail-call callee arg-temps source-information ; add self (new 'lir-tail-call :op 'tail-call :callee callee :output nil :arguments arg-temps :source-information source-information) ; disabled for now output = add-new-call self callee arg-temps source-information ; error "from call" output assert output "bad call" add self (new 'lir-prepare-value-for-return :op 'prepare-value-for-return :arg1 output :output nil) record-exception-handler start end handler self.exception-handlers = cons (new 'lir-exception-handler :start start :end end :handler handler) self.exception-handlers lir-build-instructions e lir-function tail-pos? inside-catch-block? ; print "lir-build-instructions" ; print e typecase e baste-label add-new-label lir-function e.name inside-catch-block? e.source-information baste-local e.vreg baste-assign rhstemp = lir-build-instructions e.rhs lir-function nil inside-catch-block? print rhstemp assert (or (type? rhstemp 'lir-vreg) (type? rhstemp 'lir-instruction)) "bad result" add-new-assign lir-function (lir-build-instructions e.lhs lir-function tail-pos? inside-catch-block?) rhstemp e.source-information baste-arith lhstemp = lir-build-instructions e.lhs lir-function nil inside-catch-block? rhstemp = lir-build-instructions e.rhs lir-function nil inside-catch-block? add-new-arith lir-function e.operator lhstemp rhstemp e.source-information baste-integer-literal add-new-constant lir-function e.arg e.source-information baste-block ; the last element in a block may be in tail position ; if so, we need to insert a return instruction to return that value iter = e.exprs loop while iter do expr = first iter if (rest iter) lir-build-instructions expr lir-function nil inside-catch-block? else print "tail pos " last-ins = lir-build-instructions expr lir-function tail-pos? inside-catch-block? if tail-pos? if (type? last-ins 'lir-vreg) add-new-return lir-function last-ins e.source-information else if (not (type? last-ins 'lir-tail-call)) ; FIXME what to return? add-new-return lir-function last-ins.output e.source-information iter = rest iter nil baste-apply arg-temps = (loop for a in e.args collect temp = lir-build-instructions a lir-function nil inside-catch-block? if (type? temp 'lir-instruction) error "call arg is " temp temp ) fixed-register = 1 fixed-vregs = (loop for a in arg-temps for index from 0 for i from 1 collect fixed-vreg = lir-function.fixed-vregs[index] add lir-function (new 'lir-prepare-call-arg :op 'prepare-call-arg :arg1 a :fixed-register fixed-register :output fixed-vreg :num-call-args (length arg-temps) :arg-index i) fixed-register = * fixed-register 2 fixed-vreg ) if tail-pos? add-new-tail-call lir-function e.callee fixed-vregs e.source-information else add-new-call lir-function e.callee fixed-vregs e.source-information baste-slot-or-array temp = lir-build-instructions e.base lir-function nil inside-catch-block? if (not (type? temp 'lir-vreg)) base = new-vreg lir-function print temp temp.output = base temp = base loop for a in e.access-list do temp = add-new-deref lir-function temp a.offset e.source-information print temp temp.output = new-vreg lir-function temp = temp.output temp baste-comment nil baste-if pred-temp = lir-build-instructions e.predicate lir-function nil inside-catch-block? if (not (type? pred-temp 'lir-vreg)) pred = new-vreg lir-function pred-temp.output = pred pred-temp = pred test-instruction = add-new-test lir-function pred-temp e.source-information else-label = create-new-label lir-function (gensym "if-else") inside-catch-block? out-label = create-new-label lir-function (gensym "if-out") inside-catch-block? add-new-branch-zero lir-function else-label e.source-information lir-build-instructions e.consequent lir-function tail-pos? inside-catch-block? add-new-branch lir-function out-label e.source-information add lir-function else-label if e.alternate lir-build-instructions e.alternate lir-function tail-pos? inside-catch-block? add lir-function out-label baste-string add-new-load-address-of-data-object lir-function e.arg e.source-information baste-global add-new-load-address-of-data-object lir-function nil e.source-information baste-tagbody ; the first iteration records an alist mapping a symbol to a label syms = nil bodies = nil iter = e.expressions loop while iter do expr = first iter if (type? expr 'baste-label) new-label = create-new-label lir-function expr.name inside-catch-block? push (cons expr.name new-label) syms else push expr bodies iter = rest iter ; push the alist lir-function.tagbody-labels = cons syms lir-function.tagbody-labels ; iterate again iter = e.expressions loop while iter do expr = first iter if (type? expr 'baste-label) label = rest (assoc expr.name syms) add lir-function label else if (rest iter) lir-build-instructions expr lir-function nil inside-catch-block? else lir-build-instructions expr lir-function tail-pos? inside-catch-block? iter = rest iter ; pop off the alist lir-function.tagbody-labels = rest lir-function.tagbody-labels baste-try-catch ; construct ; try label ; try block ; catch label ; receive catch argument (exception object) ; ; try-out-label ; try-block-label = add-new-label lir-function (gensym "try-block") inside-catch-block? nil lir-build-instructions e.try-block lir-function tail-pos? inside-catch-block? try-out-label = create-new-label lir-function (gensym "try-exit") inside-catch-block? add-new-branch lir-function try-out-label nil catch-label = create-new-label lir-function (gensym "catch-block") true add lir-function (new 'lir-pseudo-branch-to-catch-block :target catch-label) add lir-function catch-label record-exception-handler lir-function try-block-label catch-label catch-label if e.exception-local vreg-fixed = lir-function.fixed-vregs[0] add lir-function (new 'lir-receive :op 'receive :output vreg-fixed) add lir-function (new 'lir-release-call-arg :op 'release-arg :output e.exception-local.vreg :arg1 vreg-fixed) lir-build-instructions e.catch-block lir-function tail-pos? true add lir-function try-out-label e baste-branch-to-label loop for syms in lir-function.tagbody-labels do lookup = assoc e.label syms if lookup return-from lir-build-instructions (add-new-branch lir-function (rest lookup) e.source-information) error "target for baste-branch-to-label not found in label lists" lir-function.tagbody-labels else error "bad expr in lir-build-instructions" e extern NUM-CALLEE-CLOBBERED-REGS extern NUM-PHYSICAL-REGS pass3-build-lir method-contexts print "pass 3 build lir --------------------------------------------------------------------------------" loop for method in method-contexts do lir-function = new 'lir-function :vregs #[] :first-instruction nil fixed-vregs = make-array NUM-PHYSICAL-REGS 4 ; add vregs representing each register, we use these to store fixed intervals loop for i from 0 to (- NUM-PHYSICAL-REGS 1) do fixed-reg = new-vreg lir-function fixed-vregs[i] = fixed-reg lir-function.fixed-vregs = fixed-vregs start-label = add-new-label lir-function (gensym (concat (string method.name) "_start")) nil nil return-label = create-new-label lir-function (gensym (concat (string method.name) "_cleanup")) nil end-label = create-new-label lir-function (gensym (concat (string method.name) "_end")) nil lir-function.start-block = start-label lir-function.return-block = return-label lir-function.end-block = end-label ; first add 'receive' instructions which represent the start of a fixed interval for that call argument fixed-reg-index = 0 loop for local in method.locals do local.vreg = new-vreg lir-function local if local.argument? vreg-fixed = fixed-vregs[fixed-reg-index] add lir-function (new 'lir-receive :op 'receive :output vreg-fixed) fixed-reg-index = + fixed-reg-index 1 ; then 'release' each call arg into a vreg which may be allocated to any free register or spill slot fixed-reg-index = 0 loop for local in method.locals do if local.argument? vreg = new-vreg lir-function local local.vreg = vreg vreg-fixed = fixed-vregs[fixed-reg-index] add lir-function (new 'lir-release-call-arg :op 'release-arg :output vreg :arg1 vreg-fixed) fixed-reg-index = + fixed-reg-index 1 add-new-label lir-function 'setup-call-args-done nil nil lir-build-instructions method.body lir-function true nil ; construct the return block add lir-function return-label add lir-function (new 'lir-return :op 'return) add lir-function end-label ; construct basic blocks by analyzing control flow dump-lir-instructions lir-function num-basic-blocks = construct-basic-blocks lir-function print "num basic blocks" print num-basic-blocks ; sort and number them in reverse postorder dfns = dfn-numbering-of-basic-blocks lir-function num-basic-blocks print "did dfn numbering" lir-function.dfns = dfns ; construct strongly connected components num-sccs = construct-sccs lir-function dfns print "constructed sccs" ; construct intervals for each vreg (includes fixed intervals for call arguments) loop for [scc-maps scc-dfn-start-positions scc-dfn-end-positions] in (list (record-use-def-per-scc lir-function dfns num-sccs)) do construct-intervals-for-vregs lir-function dfns num-sccs scc-maps scc-dfn-start-positions scc-dfn-end-positions print "constructed intervals per vreg" method.lir-function = lir-function dump-lir-instructions lir-function 'done dump-lir-instructions lir-function tab = new 'tabulator :column-widths [15 20 40 20 20] output-row tab ["No." "output" "op" "arg1" "arg2"] tuple-numbers = new 'dictionary ins = lir-function.first-instruction i = 0 loop while ins do if (type? ins 'lir-label) out ins.name out " " out (if ins.inside-catch-block? "C" " ") (newline) else output-row tab [ (coerce (* i 1) 'string) (if ins.output (lir-arg-to-string ins.output) "") (if ins.op (string ins.op) "") (if (type? ins 'lir-instruction1) (if ins.arg1 (lir-arg-to-string ins.arg1) "") (if (type? ins 'lir-branch) (string ins.target.name) (if (type? ins 'lir-call) (lir-arg-to-string ins.callee) ""))) (if (type? ins 'lir-instruction2) (if ins.arg2 (lir-arg-to-string ins.arg2) "") "") ] ins = ins.next i = + i 2 1 lir-arg-to-string o error "bad lir-arg" o lir-arg-to-string f:fixnum out = "$" out = concat out (coerce f 'string) out lir-arg-to-string l:lir-constant lir-arg-to-string l.arg1 lir-arg-to-string vreg:lir-vreg out = "" if (and vreg.first-interval (type? vreg.first-interval 'lir-fixed-interval)) out = "F" else out = "v" out = concat out (coerce vreg.index 'string) if vreg.original-local out = concat out "(" out = concat out (string vreg.original-local.name) out = concat out ")" out lir-arg-to-string e:baste-extern string e.name lir-arg-to-string f:baste-function-context string f.name dump-intervals interval-list:live-interval-list sorted-intervals = new 'live-interval-list first-interval-list-element = interval-list.first loop while first-interval-list-element do add-increasing-start-point-new sorted-intervals (new 'live-interval-list-element :interval first-interval-list-element.interval) first-interval-list-element = first-interval-list-element.next dump-intervals-helper sorted-intervals dump-intervals-helper intervals:live-interval-list print "Intervals:" (newline) li-element = intervals.first tab = new 'tabulator :column-widths [15 10 40 6] output-row tab ["Int." "Spill" "" "reg"] loop while li-element do current = li-element.interval int-str = "" assert current.vreg "no vreg?" int-str = lir-arg-to-string current.vreg if current.register int-str = concat int-str " " int-str = concat int-str (coerce current.register 'string) interval = current range-str = "" spill-str = "" loop while interval do range = interval.ranges loop while range do range-str = concat range-str "[" range-str = concat range-str (coerce range.start 'string) range-str = concat range-str " " range-str = concat range-str (coerce range.end 'string) range-str = concat range-str "] ." map (fn use range-str = concat range-str (coerce use 'string) range-str = concat range-str " " ) range.use-list range-str = concat range-str "." range = range.next if (not (type? interval 'lir-fixed-interval)) spill-str = concat spill-str (if interval.spill-slot-index (coerce interval.spill-slot-index 'string) "") interval = nil reg-str = "" if current.register reg-str = reg-to-string (map-reg current.register) output-row tab [int-str spill-str range-str reg-str] li-element = li-element.next nil dump-intervals vreg-to-intervals-map:dictionary sorted-intervals = new 'live-interval-list map vreg-to-intervals-map (fn k v if v interval = v loop while interval do add-lir-increasing-start-point sorted-intervals (new 'live-interval-list-element :interval interval) interval = interval.next ) dump-intervals-helper sorted-intervals show-intervals vreg-to-intervals-map sorted-intervals = new 'live-interval-list map vreg-to-intervals-map (fn k v if v interval = v loop while interval do add-lir-increasing-start-point sorted-intervals (new 'live-interval-list-element :interval interval) interval = interval.next ) show-intervals sorted-intervals show-intervals sorted-intervals:live-interval-list spaces = (fn num out-str = "" loop while (> num 0) do out-str = concat out-str " " num = - num 1 out-str ) register-numbers = (fn num reg-num hex-table = #[$0 $1 $2 $3 $4 $5 $6 $7 $8 $9 $A $B $C $D $E $F] out-str = "" loop while (> num 0) do out-str = concat out-str (if reg-num (coerce hex-table[(reg-to-index reg-num)] 'string) "S") num = - num 1 out-str ) print "Interval assignments:" (newline) tab = new 'tabulator :column-widths [15 2 8 200 40] output-row tab ["Int." "M" "Spill" "Reg" "Ranges"] li-element = sorted-intervals.first loop while li-element do current = li-element.interval name-str = lir-arg-to-string current.vreg must-spill-str = (if current.vreg.must-spill? "M" " ") graph-str = "" spill-str = "" range-str = "" loop while current do if current.ranges.end ; for each range range-iter = current.ranges start-pos = 0 loop while range-iter do range-str = concat range-str "[" range-str = concat range-str (coerce range-iter.start 'string) range-str = concat range-str "-" range-str = concat range-str (coerce range-iter.end 'string) range-str = concat range-str "] " graph-str = concat graph-str (spaces (- range-iter.start start-pos)) len = + (- range-iter.end range-iter.start) 1 assert (>= len 1) (list "len less than 1" range-iter.end range-iter.start) graph-str = concat graph-str (register-numbers len current.register) start-pos = + range-iter.end 1 range-iter = range-iter.next spill-str = concat spill-str " " if (not (type? current 'lir-fixed-interval)) spill-str = concat spill-str (if current.spill-slot-index (coerce current.spill-slot-index 'string) "") current = nil output-row tab (list name-str must-spill-str spill-str (pad-to graph-str 200) range-str) li-element = li-element.next nil ;-------------------------------------------------------------------------------- ; construct basic blocks (record predecessors and successors) ; ; for each instruction, record the use of any vreg in the current-bb ; ; construct-basic-blocks lir-function ins = lir-function.first-instruction current-basic-block = ins current-basic-block.block-start = 0 lir-function.basic-blocks = cons ins lir-function.basic-blocks ins = ins.next ; record whether the previous basic block ended with a branch or falls-through ended-in-branch? = nil index = 2 loop while ins do typecase ins lir-label ; end the previous block current-basic-block.block-end = - index 2 previous-basic-block = current-basic-block ; start the new block lir-function.basic-blocks = cons ins lir-function.basic-blocks current-basic-block = ins current-basic-block.block-start = index if (not ended-in-branch?) current-basic-block.predecessors = cons previous-basic-block current-basic-block.predecessors previous-basic-block.successors = cons current-basic-block previous-basic-block.successors else 'pass if (type? ins 'lir-branch-zero) current-basic-block.successors = cons ins.target current-basic-block.successors ins.target.predecessors = cons current-basic-block ins.target.predecessors ended-in-branch? = nil else if (or (type? ins 'lir-tail-call) (and (type? ins 'lir-branch) (not (type? ins 'lir-branch-zero)))) if (and (type? ins 'lir-branch) (not (type? ins 'lir-branch-zero))) current-basic-block.successors = cons ins.target current-basic-block.successors ins.target.predecessors = cons current-basic-block ins.target.predecessors ended-in-branch? = true else ended-in-branch? = nil ins = ins.next index = + index 2 lir-function.basic-blocks = reverse! lir-function.basic-blocks length lir-function.basic-blocks ;-------------------------------------------------------------------------------- ; do DFN numbering of basic blocks ; global WHITE = 1 global BLACK = 2 dfn-numbering-of-basic-blocks lir-function num-basic-blocks dfns = make-array num-basic-blocks 4 loop for bb in lir-function.basic-blocks do bb.color = WHITE visit-fn = nil visit-fn = (fn bb ; print "visit " ; print bb bb.color = BLACK loop for succ in bb.successors do if (eq? succ.color WHITE) visit-fn succ num-basic-blocks = - num-basic-blocks 1 dfns[num-basic-blocks] = bb ) visit-fn (first lir-function.basic-blocks) ; print dfns dfns ;-------------------------------------------------------------------------------- ; construct sccs ; ; construct strongly connected components ; ; dfns contains the basic blocks store in reverse postorder construct-sccs lir-function dfns loop for bb across dfns do bb.color = WHITE scc-number = -1 visit-fn = nil visit-fn = (fn bb print bb bb.color = BLACK bb.scc-number = scc-number loop for pred in bb.predecessors do if (eq? pred.color WHITE) visit-fn pred ) loop for bb across dfns do if (eq? bb.color WHITE) scc-number = + scc-number 1 visit-fn bb loop for bb across dfns do out bb out " " print bb.scc-number + scc-number 1 ;-------------------------------------------------------------------------------- ; iterate over all the instructions ; ; use the uses and defs of vregs to expand the start and end range of the ; strongly connected component associated with the current basic block record-use-def-per-scc lir-function dfns num-sccs ; print "num-sccs" ; print num-sccs scc-maps = make-array num-sccs 4 scc-dfn-start-positions = make-array num-sccs 4 scc-dfn-end-positions = make-array num-sccs 4 loop for i from 0 to (- num-sccs 1) do scc-maps[i] = new 'dictionary scc-dfn-start-positions[i] = MAX_INTERVAL_START scc-dfn-end-positions[i] = -1 index = 0 use-fn = (fn bb vreg index can-spill? if vreg ; out "use-fn " ; out (lir-arg-to-string vreg) ; out " " ; print index map = scc-maps[bb.scc-number] put map vreg vreg if (and can-spill? bb.inside-catch-block?) ; if a vreg is used inside a catch block ; then ensure that it is always spilled to the stack vreg.must-spill? = true scc-dfn-start-positions[bb.scc-number] = min scc-dfn-start-positions[bb.scc-number] index scc-dfn-end-positions[bb.scc-number] = max scc-dfn-end-positions[bb.scc-number] index ) loop for bb across dfns do use-fn bb nil index true ins = bb.next index = + index 2 loop while ins do typecase ins lir-label ; fall through ins = nil index = - index 2 lir-receive record-start-of-fixed-interval lir-function ins.output (+ index 1) ins.fixed-register ins = ins.next lir-prepare-call-arg use-fn bb ins.arg1 index true record-start-of-fixed-interval lir-function ins.output (+ index 1) ins.fixed-register ins = ins.next lir-release-call-arg ; construct a fixed interval for the argument to this function ; it stays live until it is 'released' into a normal vreg which is managed by the register allocator range = (new 'lir-live-range :start 0 :end index) interval = new 'lir-interval :ranges range :last-range range :vreg ins.arg1 fixed-register = 1 loop for i from 0 to (position ins.arg1 lir-function.fixed-vregs) do fixed-register = * fixed-register 2 interval.register = fixed-register ins.arg1.first-interval = interval use-fn bb ins.output index true ins = ins.next lir-call if ins.output use-fn bb ins.output (+ index 1) true loop for fixed-vreg in ins.arguments do use-fn bb fixed-vreg index nil record-end-of-fixed-interval lir-function fixed-vreg index ins = ins.next else if ins.output use-fn bb ins.output (+ index 1) true if (type? ins 'lir-instruction1) if (not (type? ins 'lir-constant)) use-fn bb ins.arg1 index true if (type? ins 'lir-instruction2) if (not (type? ins.arg2 'lir-constant)) use-fn bb ins.arg2 index true ; ended in branch if (or (and (type? ins 'lir-branch) (not (type? ins 'lir-branch-zero))) (type? ins 'lir-tail-call)) use-fn bb nil index true ins = nil index = - index 2 else ins = ins.next index = + index 2 loop for i from 0 to (- num-sccs 1) do out "scc " out i out " " out scc-dfn-start-positions[i] out "-" print scc-dfn-end-positions[i] (list scc-maps scc-dfn-start-positions scc-dfn-end-positions) record-start-of-fixed-interval lir-function vreg index fixed-register ; out "record-start-of-fixed-interval " ; out (lir-arg-to-string vreg) ; out " at " ; print index interval = vreg.first-interval if (null? interval) range = new 'lir-live-range :start index :end nil :next nil interval = new 'lir-fixed-interval :ranges range :last-range range :register fixed-register :vreg vreg vreg.first-interval = interval return-from record-start-of-fixed-interval interval else assert (not (null? interval.last-range.end)) "incomplete range" range = new 'lir-live-range :start index :end nil :next nil interval.last-range.next = range interval.last-range = range assert (eq? interval.vreg vreg) "mismatched vreg?" interval record-end-of-fixed-interval lir-function vreg index ; out "record-end-of-fixed-interval " ; out (lir-arg-to-string vreg) ; out " at " ; print index interval = vreg.first-interval if (null? interval) error "bad fixed interval" (lir-arg-to-string vreg) range = interval.last-range assert (null? range.end) (list "incomplete range" (lir-arg-to-string vreg)) range.end = index assert (eq? interval.vreg vreg) "mismatched vreg?" interval ;-------------------------------------------------------------------------------- ; construct intervals for each vreg ; ; use the ranges of scc number to determine widest interval that covers all sccs touched ; ; global MAX_INTERVAL_START = 10000000 lir-unused-vreg? vreg:lir-vreg if (== (start vreg.first-interval) MAX_INTERVAL_START) true else nil construct-intervals-for-vregs lir-function dfns num-sccs scc-maps scc-dfn-start-positions scc-dfn-end-positions loop for vreg across lir-function.vregs do construct-intervals-per-vreg lir-function num-sccs scc-maps scc-dfn-start-positions scc-dfn-end-positions vreg ; loop ; for vreg across lir-function.fixed-vregs ; do ; construct-intervals-per-vreg lir-function num-sccs scc-maps scc-dfn-start-positions scc-dfn-end-positions vreg ; 0 construct-intervals-per-vreg lir-function num-sccs scc-maps scc-dfn-start-positions scc-dfn-end-positions vreg print vreg if (null? vreg.first-interval) interval-start = MAX_INTERVAL_START interval-end = -1 loop for i from 0 to (- num-sccs 1) do map = scc-maps[i] if (get map vreg nil) interval-start = min scc-dfn-start-positions[i] interval-start interval-end = max scc-dfn-end-positions[i] interval-end range = (new 'lir-live-range :start interval-start :end interval-end) interval = new 'lir-interval :ranges range :last-range range :vreg vreg assert (null? vreg.first-interval) "already has interval" vreg.first-interval = interval out vreg out " " out interval print "." 1