view genesis/baste/baste-pass4.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 d5dc991bfcc4
line wrap: on
line source
class live-interval-list-element
	with-slots
		local
		interval
		prev
		next


interval-starts-before? a b
	if (< a.ranges.start b.ranges.start)
		true
	else
		if (and (type? a 'lir-fixed-interval) (type? b 'lir-fixed-interval) (== a.ranges.start b.ranges.start))
			< a.register b.register
		else
			nil

class live-interval-list
	with-slots
		first
		last
	insert-after existing-li new-li
		if (eq? self.last existing-li)
			existing-li.next = new-li
			new-li.prev = existing-li
			new-li.next = nil
			self.last = new-li
		else
			new-li.next = existing-li.next
			existing-li.next = new-li
			new-li.prev = existing-li
			new-li.next.prev = new-li
	insert-before existing-li new-li
		if (eq? self.first existing-li)
			existing-li.prev = new-li
			new-li.next = existing-li
			new-li.prev = nil
			self.first = new-li
		else
			new-li.prev = existing-li.prev
			existing-li.prev = new-li
			new-li.next = existing-li
			new-li.prev.next = new-li
	add-increasing-start-point li
		error "unused" li
		if (null? self.first)
			self.first = li
			self.last = li
			li.prev = nil
			li.next = nil
		else
			iter = self.first
			loop
				while (and (< iter.local.interval-begin li.local.interval-begin) (not (null? iter.next)))
				do
					iter = iter.next

			if (< iter.local.interval-begin li.local.interval-begin)
				insert-after self iter li
			else
				insert-before self iter li
		1
	add-increasing-start-point-new li
		if (null? self.first)
			self.first = li
			self.last = li
			li.prev = nil
			li.next = nil
		else
			iter = self.first
			loop
				while (and (< (start iter.interval) (start li.interval)) (not (null? iter.next)))
				do
					iter = iter.next

			if (< (start iter.interval) (start li.interval))
				insert-after self iter li
			else
				insert-before self iter li
		1
	add-increasing-end-point-new li
		if (null? self.first)
			self.first = li
			self.last = li
			li.prev = nil
			li.next = nil
		else
			iter = self.first
			loop
				while (and (< (end iter.interval) (end li.interval)) (not (null? iter.next)))
				do
					iter = iter.next

			if (< (end iter.interval) (end li.interval))
				insert-after self iter li
			else
				insert-before self iter li
		1
	add-lir-increasing-start-point li
		if (null? self.first)
			self.first = li
			self.last = li
			li.prev = nil
			li.next = nil
		else
			iter = self.first
			loop
				while (and (interval-starts-before? iter.interval li.interval) (not (null? iter.next)))
				do
					iter = iter.next

			if (interval-starts-before? iter.interval li.interval)
				insert-after self iter li
			else
				insert-before self iter li
		1
	map-lir-list proc
			iter = self.first		
			loop
				while iter
				do
					apply proc iter.interval
					iter = iter.next

			true
	add-increasing-end-point li
		if (null? self.first)
			self.first = li
			self.last = li
			li.prev = nil
			li.next = nil
		else
			iter = self.first
			loop
				while (and (< iter.local.interval-end li.local.interval-end) (not (null? iter.next)))
				do
					iter = iter.next

			if (< iter.local.interval-end li.local.interval-end)
				insert-after self iter li
			else
				insert-before self iter li
		1
	remove-list-element li
		if li.prev
			li.prev.next = li.next
		if li.next
			li.next.prev = li.prev
		if (eq? self.first li)
			self.first = li.next
		if (eq? self.last li)
			self.last = li.prev
		li


;--------------------------------------------------------------------------------
; Allocate registers (LIR)

extern NUM-PHYSICAL-REGS

; we reserve a stack slot to spill r8, r9, r10 and r11 across calls since they are callee clobbered

global NUM-RESERVED-SPILL-SLOTS = 4

;--------------------------------------------------------------------------------
; SCC based register allocation

pass4-lir-allocate-registers method-contexts
	print "pass 4 register allocation --------------------------------------------------------------------------------"
	loop
		for m in method-contexts
		do
			lir-function = m.lir-function
			next-fixed-reg = 1
			loop
				for vreg across lir-function.fixed-vregs
				do
					if (and vreg.first-interval (not (lir-unused-vreg? vreg)))
						vreg.first-interval.register = next-fixed-reg
						next-fixed-reg = * next-fixed-reg 2

			print "--------------------------------------------------------------------------------"
			print m.name
			print "--------------------------------------------------------------------------------"
			print "before allocation ----------------------------------------"
			loop
				for vreg across lir-function.vregs
				do
					out vreg
					out " ("
					if (type? vreg.first-interval 'lir-fixed-interval)
						out "F "
					else
						out vreg.first-interval.spill-slot-index
					out ") "
					print vreg.first-interval.register

			allocate-registers-scc lir-function m.name
			print "final register allocation --------------------------------------------------------------------------------"
			loop
				for vreg across lir-function.vregs
				do
					out vreg
					out " ("
					if (type? vreg.first-interval 'lir-fixed-interval)
						out "F "
					else
						out vreg.first-interval.spill-slot-index
					out ") "
					print vreg.first-interval.register



	'done


allocate-registers-scc lir-function function-name
	free-regs = new 'baste-register-set
; reserve the fixed regs
	loop
		for vreg across lir-function.fixed-vregs
		do
			if vreg.first-interval.register
				allocate-specific-register free-regs vreg.first-interval.register

	spill-slot-index = NUM-RESERVED-SPILL-SLOTS
	print "live intervals"
; collect intervals into the unhandled list
	live = new 'live-interval-list
	completed = new 'live-interval-list
;	print "live intervals"
;	print lir-function
	loop
		for vreg across lir-function.vregs
		do
			if (not (lir-unused-vreg? vreg))
				add-increasing-start-point-new live (new 'live-interval-list-element :interval vreg.first-interval :local vreg)

	print "done live intervals"
	dump-intervals live
	active = new 'live-interval-list
; for each interval
	li = live.first
	loop
		while li
		do
			current = li.interval
; expire active intervals that end before current
			ai = active.first
			loop
				while ai
				do
					if (< (end ai.interval) (start current))
						completed-li = new 'live-interval-list-element :interval ai.interval :local ai.local
						remove-list-element active ai
						add-increasing-start-point-new completed completed-li
						free-register free-regs ai.interval.register
					ai = ai.next

			if (and (not current.vreg.must-spill?) (empty? free-regs) (not current.register))
; should we spill another interval instead ?
;				print "spill"
				spill-interval = active.last
; cannot spill a fixed interval
				if (type? spill-interval 'lir-fixed-interval)
					spill-interval = nil
;				print spill-interval
				if (and spill-interval (> (end spill-interval.interval) (end current)))
;					out "spilling interval "
;					out (lir-arg-to-string spill-interval.interval.vreg)
;					out " with reg "
;					out spill-interval.interval.register
;					out " for "
;					print (lir-arg-to-string current.vreg)
					current.register = spill-interval.interval.register
					spill-interval.interval.spill-slot-index = spill-slot-index
					add-increasing-start-point-new completed (new 'live-interval-list-element :interval spill-interval.interval :local spill-interval.interval.vreg)
					remove-list-element active spill-interval
					spill-interval.interval.register = nil
				else
; spill current
					current.spill-slot-index = spill-slot-index
					add-increasing-start-point-new completed (new 'live-interval-list-element :interval current :local current.vreg)
				spill-slot-index = + spill-slot-index 1
			else
				if current.vreg.must-spill?
					current.spill-slot-index = spill-slot-index
					spill-slot-index = + spill-slot-index 1
					add-increasing-start-point-new completed (new 'live-interval-list-element :interval current :local current.vreg)
				else
	;				print "find reg"
	;				print current
					if current.register
	; register is already allocated 
						1
	;					print "has reg"
					else
						reg = allocate-register free-regs
						current.register = reg
						; make current active
					add-increasing-end-point-new active (new 'live-interval-list-element :interval current :local current.vreg)
			li = li.next

	; drain out remaining intervals
	ai = active.first
	loop
		while ai
		do
			completed-li = new 'live-interval-list-element :interval ai.interval :local ai.local
			remove-list-element active ai
			add-increasing-start-point-new completed completed-li
			free-register free-regs ai.interval.register
			ai = ai.next

	lir-function.num-spill-slots-used = spill-slot-index
	print "done "
	print "--------------------------------------------------------------------------------"
	print function-name
	print "--------------------------------------------------------------------------------"
	dump-intervals completed
	show-intervals completed
	1