;--------------------------------------------------------------------------------
; 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