changeset 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 1f6702c7036a
children b71ecca92f10
files baste/gc_alloc.S baste/h_runtime.c baste/l.h baste/loader.c baste/test/no-exception-handler1.baste genesis/baste/baste-main.church genesis/baste/baste-parser.church genesis/baste/baste-pass1.church genesis/baste/baste-pass2.church genesis/baste/baste-pass3.church genesis/baste/baste-pass5.church
diffstat 11 files changed, 391 insertions(+), 124 deletions(-) [+]
line wrap: on
line diff
--- a/baste/gc_alloc.S	Wed Jun 19 15:20:56 2013 +0200
+++ b/baste/gc_alloc.S	Thu Jun 20 11:27:00 2013 +0200
@@ -1,6 +1,25 @@
 .text
 	.globl h_gc_alloc
 	.globl h_gc_init
+
+
+
+	;; // Thread local storage has the following layout
+	;; // (some other thread's heap)	   <------------ limit-pointer
+	;; // heap
+	;; // heap
+	;; // heap
+	;; // heap		   		   <------------ allocation-pointer
+	;; // heap
+	;; // heap
+	;; // heap   start of heap                			              %r15
+	;; // limit pointer  							-0x8 (%r15)
+	;; // allocation pointer  (initially points to start of heap)		-0x10(%r15)
+	;; // saved exception object 						-0x18(%r15)
+	;; // saved return address when calling unwind stub			-0x20(%r15)
+	;; // saved frame pointer for exception trace				-0x28(%r15)
+	;; // working stack pointer to be used during stack trace traversal 	-0x30(%r15)
+	;; // saved traversal stack pointer 					-0x38(%r15)
 	
 h_gc_alloc:
 	;; //allocation size is in %rdi
@@ -17,10 +36,14 @@
 
 h_gc_alloc_slowpath:
 	int $3
-	
+
+	;; // allocated raw heap in %rdi
+	;; // allocated size in %rsi
+
+	;; // adjust r15 to point to start of allocation heap
 h_gc_init:
 	movq %rdi, %r15
-	add $32, %r15
+	add $0x38, %r15
 	lea -0x10(%r15), %rax
 	mov %r15, (%rax)
 	lea -0x8(%r15), %rax
@@ -32,21 +55,40 @@
 	
 ;; //transfer to exception handler
 	.globl __l_throw_exception
+
+
+.macro switch_to_original_stack
+	mov %rsp, -0x30(%r15)
+	mov -0x38(%r15), %rsp
+.endm
+
+.macro switch_to_working_stack
+	mov %rsp, -0x38(%r15)
+	mov -0x30(%r15), %rsp
+.endm
 	
 __l_throw_exception:
 ;; // first argument is the exception object
 ;; // save it in thread local memory
 	mov %rdi, -0x18(%r15)
+	;; // also save the frame pointer so that we can generate a stack trace later if necessary
+	mov %rbp, -0x28(%r15)
+	;; // and keep a pointer to a 'working stack' so that we call helper routines without destroying the original stack frames
+	mov %rsp, -0x30(%r15)
 __find_exception_handler:
 	;; // get the return address from the stack
 	;; // and check if there is an exception handler installed around that address
 	mov (%rsp), %rdi
+	switch_to_working_stack
 	call __l_find_exception_handler
+	switch_to_original_stack
 	test %rax,%rax
 	jnz found_exception_handler
 	;; // if there is no exception handler, unwind this frame by finding the unwind stub for this function
 	mov (%rsp), %rdi
+	switch_to_working_stack
 	call __l_find_unwind_stub
+	switch_to_original_stack
 	test %rax,%rax
 	jz no_unwind
 	;; // pop off the return address (restore the stack to the calling function's expected value)
@@ -77,10 +119,14 @@
 	
 no_unwind:	
 no_exception_handler:
-	mov -0x18(%r15), %rdi
+	mov -0x28(%r15), %rdi
+	mov -0x18(%r15), %rsi
+	switch_to_working_stack
 	call __l_top_level_exception_handler
-
-
+	;;  // no return?
+	int $3
+	
+	
 	;; // test function which clobbers all callee clobbered regs
 	.globl clobber_callee_regs
 clobber_callee_regs:
--- a/baste/h_runtime.c	Wed Jun 19 15:20:56 2013 +0200
+++ b/baste/h_runtime.c	Thu Jun 20 11:27:00 2013 +0200
@@ -36,6 +36,7 @@
 extern int _abort(char* msg);
 extern void* find_unwind_handler(void*);
 extern void* find_exception_handler(void*);
+extern void* find_line_number_info(void*);
 
 void* __l_find_unwind_stub(void* code_address)
 {
@@ -47,8 +48,26 @@
   return find_exception_handler(code_address);
 }
 
-void* __l_top_level_exception_handler(void* object)
+void* __l_top_level_exception_handler(long long* saved_frame_pointer, void* object)
 {
+  fprintf(stderr, "Top level exception handler:\n");
+  fprintf(stderr, "Exception object: %p\n", object);
+  fprintf(stderr, "--------------------\n\n");
+  fprintf(stderr, "Stack trace:\n");
+  while(saved_frame_pointer != NULL)
+    {
+      void* return_address = (void*) *(saved_frame_pointer + 1);
+      line_number_entry* entry = find_line_number_info(return_address);
+      if (entry)
+	{
+	  fprintf(stderr, "%s:%llu\t\t\t: %p\n", entry->file_name, entry->line_number, return_address);
+	}
+      else
+	{
+	  fprintf(stderr, "(Unknown)\t\t\t %p\n", return_address);
+	}
+      saved_frame_pointer = (long long*) *saved_frame_pointer;
+    }
   _abort("top level handler");
   return NULL;
 }
--- a/baste/l.h	Wed Jun 19 15:20:56 2013 +0200
+++ b/baste/l.h	Thu Jun 20 11:27:00 2013 +0200
@@ -17,6 +17,14 @@
 
 typedef struct FUN_ENTRY fun_entry;
 
+struct LINE_NUMBER_ENTRY {
+  char* file_name;
+  long long line_number;
+  long long pc;
+  struct LINE_NUMBER_ENTRY* next;
+};
+
+typedef struct LINE_NUMBER_ENTRY line_number_entry;
 
 // add cleanup entries for each function
 
--- a/baste/loader.c	Wed Jun 19 15:20:56 2013 +0200
+++ b/baste/loader.c	Thu Jun 20 11:27:00 2013 +0200
@@ -25,7 +25,8 @@
   TAG_TEXT = 0x300,
   TAG_RELOC = 0x400,
   TAG_EXCEPTION_HANDLER = 0x500,
-  TAG_FUNCTION = 0x600
+  TAG_FUNCTION = 0x600,
+  TAG_LINE_NUMBERS = 0x700
 };
 
 enum {
@@ -76,6 +77,8 @@
 
 exception_handler_entry* EXCEPTION_HANDLER_TABLE = NULL;
 
+line_number_entry* LINE_NUMBER_TABLE = NULL;
+
 int _abort(char* msg)
 {
   fputs("\n", stderr);
@@ -328,6 +331,40 @@
   return 0;
 }
 
+
+int add_line_number_entry(long long name_sym_index, long long line_number, long long pc)
+{
+  line_number_entry* entry = malloc(sizeof(line_number_entry));
+  assert(entry != NULL);
+  entry->file_name = SYMBOL_TABLE[name_sym_index].name;
+  entry->line_number = line_number;
+  entry->pc = pc;
+
+  entry->next = LINE_NUMBER_TABLE;
+  LINE_NUMBER_TABLE = entry;
+  return 0;
+}
+
+line_number_entry* find_line_number_info(void* code_address)
+{
+  line_number_entry *prev = NULL, *current = LINE_NUMBER_TABLE;
+  while(current != NULL && ((CODE_AREA + current->pc) <= code_address))
+    {
+      //      fprintf(stderr, "line number info: %p, %llu\n", CODE_AREA + current->pc, current->line_number);
+      prev = current;
+      current = current->next;
+    }
+
+  if (prev)
+    {
+      return prev;
+    }
+
+  //fprintf(stderr, " no line number info found %p\n", code_address);
+  return NULL;
+  
+}
+
 void* lookup_function(char* symbol)
 {
   hnode_t* node = hash_lookup(SYMBOL_HASHTABLE, symbol);
@@ -470,6 +507,7 @@
 	      hnode_t* lookup = hash_lookup(SYMBOL_HASHTABLE, entry->name);
 	      if (lookup == NULL)
 		{
+		  fprintf(stderr, "added symbol %s\n", entry->name);
 		  hash_alloc_insert(SYMBOL_HASHTABLE, entry->name, entry);
 		}
 	      else
@@ -550,7 +588,32 @@
 	  
 	  break;
 	}
-      }
+      case TAG_LINE_NUMBERS:
+	{
+	  long long count = 0;
+	  int rc = fread(&count, sizeof(count), 1, input);
+	  assert(rc == 1);
+
+	  while (count > 0)
+	    {
+	      long long name;
+	      rc = fread(&name, sizeof(name), 1, input);
+	      assert(rc == 1);
+	      assert(name >= 1);
+	      long long line_number;
+	      rc = fread(&line_number, sizeof(line_number), 1, input);
+	      assert(rc == 1);
+	      long long pc;
+	      rc = fread(&pc, sizeof(pc), 1, input);
+	      assert(rc == 1);
+
+	      add_line_number_entry(name, line_number, pc);
+
+	      count--;
+	    }
+	  break;
+	}
+	}
   }
   fclose(input);
 
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/baste/test/no-exception-handler1.baste	Thu Jun 20 11:27:00 2013 +0200
@@ -0,0 +1,32 @@
+c-function __l_throw_exception mint
+c-function __l_create_gc_heap mint
+c-function h_gc_init mint
+c-function putchar mint
+
+def main args
+	heap = call __l_create_gc_heap
+	h_gc_init heap 1048576
+	foo 1 2 3 4 5 6
+	putchar 10
+
+def foo a b c d e f
+	a = 65
+	putchar a
+	a = a + 1
+	call bar
+	putchar a
+	putchar 72
+	1
+
+def bar
+	call quux
+	putchar 69
+	0
+
+def quux
+	throw 0
+	0
+
+
+
+
--- a/genesis/baste/baste-main.church	Wed Jun 19 15:20:56 2013 +0200
+++ b/genesis/baste/baste-main.church	Thu Jun 20 11:27:00 2013 +0200
@@ -1,6 +1,7 @@
 main args
 	file-path = second args
-	parsed-forms = baste-parse-file file-path
+	parser = new 'baste-parser :baste-grammar-file-name "baste/baste.g"
+	parsed-forms = parse-file parser file-path
 	parts = separate-baste-top-levels parsed-forms
 	records-ht = new 'dictionary
 	loop
@@ -19,13 +20,13 @@
 	methods = (loop
 			for m in methods
 			collect
-				baste-expand-macros m records-ht
+				baste-expand-macros m records-ht parser.source-location-map
 
 )
 ;
 ; --- pass 2 ---
 ;
-	pass2-ast = pass2-build-baste-ast (list (first parts) methods (third parts) (fourth parts) (fifth parts)) records-ht
+	pass2-ast = pass2-build-baste-ast (list (first parts) methods (third parts) (fourth parts) (fifth parts)) records-ht parser.source-location-map
 	methods-ht = first pass2-ast
 	method-contexts = third pass2-ast
 ;	pass2-env = build-lexical-environment method-contexts
@@ -39,6 +40,6 @@
 ;	error "pass4" pass4
 	a = new 'assembler-amd64
 	baste-writer = new 'baste-writer
-	pass5 = pass5-lir-emit-machine-code method-contexts a baste-writer
+	pass5 = pass5-lir-emit-machine-code method-contexts a baste-writer parser.line-number-for-input-position
 	0
 
--- a/genesis/baste/baste-parser.church	Wed Jun 19 15:20:56 2013 +0200
+++ b/genesis/baste/baste-parser.church	Thu Jun 20 11:27:00 2013 +0200
@@ -1,7 +1,19 @@
+extern o-fail
+
+global source-location-info
+
+class baste-source-information
+	with-slots
+		source-file-name
+		start-position
+		end-position
+
 class baste-parser
 	with-slots
 		parser
 		baste-grammar-file-name
+		line-number-for-input-position
+		source-location-map
 	init
 		ometa-grammar-parser = (make-grammar-parser)
 		array = read-file self.baste-grammar-file-name
@@ -19,22 +31,67 @@
 )
 		self.parser = make-parser-from-forms normalized-forms
 	parse-file file-name:string
-		array = read-file file-name
-		parse-result = parse-array self array 'grammar
+		array = read-file file-name 
+		parse-result = parse-array self array 'grammar file-name
 		print "parse-result"
 		print parse-result
 		parse-result
-	parse-array array parse-rule
+	parse-array array parse-rule file-name
 		stream = (new 'ometa-input-stream :input-array array)
 		reset-memo self.parser (length array)
 		parse-result = parse-memo self.parser parse-rule stream 0 0
 		if (not (at-end? stream))
 			print (remaining stream)
 			error "baste parse failed, not at end of stream" stream
+		source-map = new 'dictionary
+		print (length self.parser.memo-table)
+		time-closure (fn 
+		num-rules = / (length self.parser.memo-table[0]) 2
+		loop
+			for column across self.parser.memo-table
+			for column-index from 0
+			do
+				if (> (length column) 0)
+					loop
+						for entry-index from 0 to (- num-rules 2)
+						do
+							entry = column[* entry-index 2]
+							if (and (cons? entry) (not (eq? entry o-fail)))
+								out column-index
+								out ". ("
+								out entry-index
+								out ") "
+								print entry
+								put source-map entry (new 'baste-source-information :source-file-name file-name :start-position column-index :end-position  column[+ (* entry-index 2) 1])
+
+
+) "traverse memo"
+;		map self.parser.rules-map (fn name rule
+;				out name
+;				out " "
+;				print name
+;				print rule.rule-number
+;)
+;		print "line numbers "
+		line-number-for-input-position = make-array (length array) 4
+		line-number = 1
+		loop
+			for c across array
+			for i from 0
+			do
+				line-number-for-input-position[i] = line-number
+				if (eq? (char-code c) 10)
+					line-number = + line-number 1
+
+
+
+		source-location-info = source-map
 		result = map 'cleanup-baste-parse-tree parse-result
-		print "***"
-		print result
-		print "***"
+;		print "***"
+;		print result
+;		print "***"
+		self.source-location-map = source-map
+		self.line-number-for-input-position = line-number-for-input-position
 		result
 
 
@@ -47,7 +104,7 @@
 		return-from cleanup-baste-parse-tree form
 	if (string? form)
 		return-from cleanup-baste-parse-tree form
-	case-symbol (first form)
+	new-form = (case-symbol (first form)
 		_rule
 			list '_rule (cleanup-baste-parse-tree (second form)) (cleanup-baste-parse-tree (third form)) (map 'cleanup-baste-parse-tree (fourth form))
 		_record
@@ -116,22 +173,19 @@
 				`[_catch ,nil ,(map 'cleanup-baste-parse-tree (third form))]
 		else
 			form
-
-
-baste-parse-file file-path
-		parser = new 'baste-parser :baste-grammar-file-name "baste/baste.g"
-		parse-file parser file-path
+)
+	if (and new-form (cons? new-form))
+		print new-form
+		out " -> "
+		print (get source-location-info form nil)
+		put source-location-info new-form (get source-location-info form nil)
+		assert (eq? (get source-location-info new-form nil) (get source-location-info form nil)) "no match?"
+	new-form
 
 
-parse-baste file-path
-		parser = new 'baste-parser :baste-grammar-file-name "baste/baste.g"
-		parse-file parser file-path
-
-test-baste-parser
-		test-files = `["baste/test/record.baste" "baste/test/comment.baste" "baste/test/const.baste" "baste/test/fundef.baste" "baste/test/fundef1.baste" "baste/test/return.baste" "baste/test/compare.baste" "baste/test/assignment.baste" "baste/test/if.baste"]
-		loop
-			for t in test-files
-			do
-				print (parse-baste t)
 
 
+
+
+
+
--- a/genesis/baste/baste-pass1.church	Wed Jun 19 15:20:56 2013 +0200
+++ b/genesis/baste/baste-pass1.church	Thu Jun 20 11:27:00 2013 +0200
@@ -1,10 +1,11 @@
 extern baste-target-word-size
 
-baste-expand-macros form records-ht
+baste-expand-macros form records-ht source-location-info
 ;	out "baste-expand-macros "
 ;	print form
 	if (null? form)
 		form
+	new-form = (begin
 	if (cons? form)
 		case-symbol (first form)
 			_apply
@@ -25,7 +26,7 @@
 						loop
 							for el in form
 							collect
-								baste-expand-macros el records-ht
+								baste-expand-macros el records-ht source-location-info
 
 			_do-loop
 				label-sym = (gensym "loop-start")
@@ -33,13 +34,15 @@
 				test-clause = `[_if ,(third form) [_apply go ,label-sym] 1]
 				body = second form
 				newform = `[_tagbody [,label ,body ,test-clause]]
-				baste-expand-macros newform records-ht
+				baste-expand-macros newform records-ht source-location-info
 			else
 				loop
 					for el in form
 					collect
-						baste-expand-macros el records-ht
+						baste-expand-macros el records-ht source-location-info
 
 	else
-		form
+		form)
+	put source-location-info new-form (get source-location-info form nil)
+	new-form
 
--- a/genesis/baste/baste-pass2.church	Wed Jun 19 15:20:56 2013 +0200
+++ b/genesis/baste/baste-pass2.church	Thu Jun 20 11:27:00 2013 +0200
@@ -6,9 +6,12 @@
 		slots
 
 class baste-expression
+	with-slots
+		source-information
 	short-string
 		"-"
 
+
 class baste-comment extends baste-expression
 
 class baste-extern extends baste-expression
@@ -163,7 +166,7 @@
 			print-baste el indent
 
 
-pass2-build-baste-ast parts records-ht
+pass2-build-baste-ast parts records-ht source-info-map
 	print "records"
 	print (first parts)
 	print "rules"
@@ -222,7 +225,7 @@
 			pattern = select-pattern rule
 			name = (second (select-pattern rule))
 			c = get methods name nil
-			c.body = build-baste-ast c.body
+			c.body = build-baste-ast c.body source-info-map
 ;			print-baste c.body ""
 			loop
 				for v in (select-vars pattern)
@@ -249,9 +252,10 @@
 ;
 	[methods env (reverse! method-contexts)]
 
-build-baste-ast form
-;	print "build-baste-ast"
-;	print form
+build-baste-ast form source-info-map
+	print "build-baste-ast"
+	print form
+	print (get source-info-map form nil)
 	if (null? form)
 		return-from build-baste-ast form
 	if (symbol? form)
@@ -265,53 +269,55 @@
 				for e in (rest form)
 				when (not (eq? (first form) '_comment))
 				do
-					push (build-baste-ast e) exprs
+					push (build-baste-ast e source-info-map) exprs
 
-;			new 'baste-block :exprs (cons (new 'baste-label :name 'block-start)  (reverse! exprs))
 			new 'baste-block :exprs (reverse! exprs)
 		_bracketed
-			build-baste-ast (second form)
+			build-baste-ast (second form) source-info-map
 		_assign
-			new 'baste-assign :lhs (build-baste-ast (second form)) :rhs (build-baste-ast (third form))
+			new 'baste-assign :lhs (build-baste-ast (second form) source-info-map) :rhs (build-baste-ast (third form) source-info-map) :source-information (get source-info-map form nil)
 		_if
-			new 'baste-if :predicate (build-baste-ast (second form)) :consequent (build-baste-ast (third form)) :alternate (build-baste-ast (fourth form))
+			new 'baste-if :predicate (build-baste-ast (second form) source-info-map) :consequent (build-baste-ast (third form) source-info-map) :alternate (build-baste-ast (fourth form) source-info-map) :source-information (get source-info-map form nil)
 		_apply
 			if (== 0 (length (cddr form)))
-				new 'baste-var :name (second form)
+				new 'baste-var :name (second form) :source-information (get source-info-map form nil)
 			else
-				new 'baste-apply :callee (second form) :args (map 'build-baste-ast (cddr form))
+				print "in apply"
+				print form
+				print (get source-info-map form nil)
+				new 'baste-apply :callee (second form) :args (map (fn f -- build-baste-ast f source-info-map) (cddr form)) :source-information (get source-info-map form nil)
 		_apply1
-			new 'baste-apply :callee (second form)
+			new 'baste-apply :callee (second form) :source-information (get source-info-map form nil)
 		_var
-			new 'baste-var :name (second form) :type (third form)
+			new 'baste-var :name (second form) :type (third form) :source-information (get source-info-map form nil)
 		_arith
-			new 'baste-arith :operator (build-baste-ast (intern (second form))) :lhs (build-baste-ast (third form)) :rhs (build-baste-ast (fourth form))
+			new 'baste-arith :operator (build-baste-ast (intern (second form)) source-info-map) :lhs (build-baste-ast (third form) source-info-map) :rhs (build-baste-ast (fourth form) source-info-map) :source-information (get source-info-map form nil)
 		_slot-or-array
-			new 'baste-slot-or-array :base (build-baste-ast (second form)) :access-list (map 'build-baste-ast (third form))
+			new 'baste-slot-or-array :base (build-baste-ast (second form) source-info-map) :access-list (map (fn f -- build-baste-ast f  source-info-map)  (third form)) :source-information (get source-info-map form nil)
 		_slot-access
-			new 'baste-slot-access :slot-name-or-expr (second form)
+			new 'baste-slot-access :slot-name-or-expr (second form) :source-information (get source-info-map form nil)
 		_array-access
-			new 'baste-array-access :index-expr (second form)
+			new 'baste-array-access :index-expr (second form) :source-information (get source-info-map form nil)
 		_return
-			new 'baste-return :arg (build-baste-ast (third form))
+			new 'baste-return :arg (build-baste-ast (third form) source-info-map) :source-information (get source-info-map form nil)
 		_string
-			new 'baste-string :arg (second form)
+			new 'baste-string :arg (second form) :source-information (get source-info-map form nil)
 		_convert-hex-number
-			new 'baste-integer-literal :arg (convert-hex-number (second form))
+			new 'baste-integer-literal :arg (convert-hex-number (second form)) :source-information (get source-info-map form nil)
 		_comment
 			new 'baste-comment
 		_do-loop
 			error "do loop should have been expanded by macro" form
 		_tagbody_label
-			new 'baste-label :name (second form)
+			new 'baste-label :name (second form) :source-information (get source-info-map form nil)
 		_tagbody
-			t = new 'baste-tagbody
+			t = new 'baste-tagbody :source-information (get source-info-map form nil)
 			new-expressions = nil
 			loop
 				for e in (second form)
 				do
 					if (not (symbol? e))
-						push (build-baste-ast e) new-expressions
+						push (build-baste-ast e source-info-map) new-expressions
 					else
 						error "symbol in tagbody? " e
 						push (new 'baste-label :name e) new-expressions
@@ -322,7 +328,7 @@
 		_try_catch
 			print "_try_catch"
 			print form
-			new 'baste-try-catch :try-block (build-baste-ast (second form)) :exception-name (second (third form)) :catch-block (build-baste-ast (third (third form)))
+			new 'baste-try-catch :try-block (build-baste-ast (second form) source-info-map) :exception-name (second (third form)) :catch-block (build-baste-ast (third (third form)) source-info-map) :source-information (get source-info-map form nil)
 		else
 			error "bad form in build-baste-ast" form
 
@@ -416,8 +422,9 @@
 	method-contexts
 
 build-lexical-environment ctx e env
-;	out "build-lexical-environment "
-;	print e
+	out "build-lexical-environment "
+	print e
+	print e.source-information
 	typecase e
 		nil			e
 		baste-comment		e
--- a/genesis/baste/baste-pass3.church	Wed Jun 19 15:20:56 2013 +0200
+++ b/genesis/baste/baste-pass3.church	Thu Jun 20 11:27:00 2013 +0200
@@ -232,6 +232,8 @@
 		output-machine-register
 ; linked list of instructions
 		next
+; source code information
+		source-information
 ; index 
 
 ;; One argument
@@ -372,47 +374,47 @@
 		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?
-		add self (create-new-label self name inside-catch-block?)
+	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
+	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)
+		add self (new 'lir-arith :arg1 lhs :arg2 rhs :output vreg :op op :source-information source-information)
 		vreg
-	add-new-assign lhs rhs
-		add self (new 'lir-assign :arg1 rhs :output lhs :op 'assign)
+	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
+	add-new-constant v source-information
 		vreg = new-vreg self
-		add self (new 'lir-constant :constant v :op 'constant :output vreg)
+		add self (new 'lir-constant :constant v :op 'constant :output vreg :source-information source-information)
 		vreg
-	add-new-return local
+	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)
+			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
-	add-new-branch target
-		add self (new 'lir-branch :op 'branch :target target)
-	add-new-branch-zero  target
-		add self (new 'lir-branch-zero :op 'branch-zero  :target target)
-	add-new-test v 
-		add self (new 'lir-test :op 'test :arg1 v)
-	add-new-deref vreg:lir-vreg offset
-		add self (new 'lir-deref :op 'deref :arg1 vreg :arg2 offset)
-	add-new-load-address-of-data-object arg
+		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)
+		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
+	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)
+		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
-;		add self (new 'lir-tail-call :op 'tail-call :callee callee :output nil :arguments arg-temps)
+	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
+		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)
@@ -425,20 +427,20 @@
 ;	print e
 	typecase e
 		baste-label
-			add-new-label lir-function e.name inside-catch-block?
+			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
+			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
+			add-new-arith lir-function e.operator lhstemp rhstemp  e.source-information
 		baste-integer-literal
-			add-new-constant lir-function e.arg
+			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
@@ -454,11 +456,11 @@
 						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
+								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
+									add-new-return lir-function last-ins.output  e.source-information
 					iter = rest iter
 
 			nil
@@ -485,9 +487,9 @@
 
 )
 			if tail-pos?
-				add-new-tail-call lir-function e.callee fixed-vregs
+				add-new-tail-call lir-function e.callee fixed-vregs  e.source-information
 			else
-				add-new-call lir-function e.callee fixed-vregs
+				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))
@@ -498,7 +500,7 @@
 			loop
 				for a in e.access-list
 				do
-					temp = add-new-deref lir-function temp a.offset
+					temp = add-new-deref lir-function temp a.offset  e.source-information
 					print temp
 					temp.output = new-vreg lir-function
 					temp = temp.output
@@ -512,21 +514,21 @@
 				pred = new-vreg lir-function
 				pred-temp.output = pred
 				pred-temp = pred
-			test-instruction = add-new-test lir-function pred-temp
+			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
+			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
-			add lir-function else-label
+			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
+			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
+			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
@@ -572,17 +574,17 @@
 ;
 ;   try-out-label
 ;
-			try-block-label = add-new-label lir-function (gensym "try-block") inside-catch-block?
+			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
+			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-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
@@ -593,7 +595,7 @@
 				do
 					lookup = assoc e.label syms
 					if lookup
-						return-from lir-build-instructions (add-new-branch lir-function (rest 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
@@ -620,8 +622,8 @@
 
 			lir-function.fixed-vregs = fixed-vregs
 
-			start-label = add-new-label lir-function (gensym (concat (string method.name) "_start")) nil
-			return-label = create-new-label lir-function (gensym (concat (string method.name) "_cleanup")) nil
+			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
@@ -649,7 +651,7 @@
 						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
+			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
--- a/genesis/baste/baste-pass5.church	Wed Jun 19 15:20:56 2013 +0200
+++ b/genesis/baste/baste-pass5.church	Thu Jun 20 11:27:00 2013 +0200
@@ -19,7 +19,7 @@
 ;--------------------------------------------------------------------------------
 ; Emit machine code
 
-pass5-lir-emit-machine-code method-contexts a:assembler-amd64 baste-writer:baste-writer
+pass5-lir-emit-machine-code method-contexts a:assembler-amd64 baste-writer:baste-writer line-number-for-input-position
 ;	get-symbol-index baste-writer 'baste_main
 	loop
 		for m in method-contexts
@@ -28,7 +28,7 @@
 				m.name = 'baste_main
 			start-asm-offset = a.pc
 			lir-function = m.lir-function
-			emit-machine-code lir-function a baste-writer m.name
+			emit-machine-code lir-function a baste-writer m.name line-number-for-input-position
 			end-asm-offset = a.pc
 			register-function baste-writer m.name lir-function.start-block.name lir-function.end-block.name lir-function.return-block.name
 
@@ -42,15 +42,16 @@
 			patch-array a.code (- (- lookup pc) 4) pc
 
 	dump-code-and-disassemble a.code
-	(write-baste-file baste-writer a.code baste-writer.relocs)
+	(write-baste-file baste-writer a.code baste-writer.relocs) 
 	1
 
-emit-machine-code l:lir-function a:assembler-amd64 w:baste-writer name
+emit-machine-code l:lir-function a:assembler-amd64 w:baste-writer name line-number-for-input-position
 	print "--------------------------------------------------------------------------------"
 	print name
 	print "--------------------------------------------------------------------------------"
 	branch-targets = new 'dictionary
 	branch-fixups = nil
+	last-line-number = nil
 	record-entry-point w name a.pc
 	PUSHr a _rbp
 	MOVLrr a _rbp _rsp 
@@ -66,6 +67,15 @@
 			loop
 				while ins
 				do
+;					print ins
+;					print ins.source-information
+					if ins.source-information
+						line-number = line-number-for-input-position[ins.source-information.start-position]
+;						print line-number
+						if (not (eq? line-number last-line-number))
+							last-line-number = line-number
+							record-line-number w ins.source-information.source-file-name line-number a.pc
+
 ; fall through
 					if (type? ins 'lir-label)
 						ins = nil
@@ -173,9 +183,9 @@
 							lir-constant
 								MOVLir a ins.constant output-reg
 							lir-prepare-call-arg	
-								print "lir-prepare-call-arg"
-								print ins.output
-								print ins.output.first-interval
+;								print "lir-prepare-call-arg"
+;								print ins.output
+;								print ins.output.first-interval
 								MOVLrr a (map-reg ins.output.first-interval.register) arg1-reg
 								MOVLrr a output-reg arg1-reg
 								1
@@ -288,6 +298,7 @@
 		function-entry-points-ht
 		data-object-offsets-ht
 		exception-handlers
+		line-number-info
 	init
 		self.symbol-ht = new 'dictionary
 		self.symbols = nil
@@ -309,6 +320,8 @@
 		symbols = self.symbols
 		write-double-word output-stream TAG_SYMBOL_TABLE
 		write-double-word output-stream (length symbols)
+		print (length symbols)
+		print symbols
 		loop
 			for sym in symbols
 			do
@@ -342,7 +355,7 @@
 						write-double-word output-stream 0
 
 	write-text output-stream machine-code-bytes
-		write-double-word output-stream TAG-TEXT
+		write-double-word output-stream TAG_TEXT
 		write-double-word output-stream TEXT-SECTION-INDEX
 		len = length machine-code-bytes
 		write-double-word output-stream len
@@ -399,10 +412,11 @@
 ;				print pc
 				write-reloc self output-stream (get-symbol-index self sym) pc reloc-type
 
+		write-exception-handlers self output-stream
 		write-symbol-table self output-stream
 		write-text self output-stream code-bytes
 		write-functions self output-stream
-		write-exception-handlers self output-stream
+		write-line-number-info self output-stream
 		close output-stream
 	patch-symbol sym pc reloc-type
 ;		print "patch-symbol"
@@ -411,14 +425,32 @@
 		get-symbol-index self sym
 	patch-function-call sym pc
 		self.funcall-relocs = cons (list sym pc) self.funcall-relocs
+	record-line-number file-name line-number pc
+		self.line-number-info = cons (list (get-symbol-index self (intern file-name)) line-number pc) self.line-number-info
+		out "line number "
+		out line-number
+		out " "
+		print pc 
+	write-line-number-info output-stream
+		write-double-word output-stream TAG_LINE_NUMBERS
+		write-double-word output-stream (length self.line-number-info)
+		loop
+			for [file-name-sym-index line-number pc] in self.line-number-info
+			do
+				write-double-word output-stream file-name-sym-index
+				write-double-word output-stream line-number
+				write-double-word output-stream pc
+
+		1
 
 
 global TAG_SYMBOL_TABLE = 0x100
 global TAG_SYMBOL = 0x200
-global TAG-TEXT = 0x300
+global TAG_TEXT = 0x300
 global TAG_RELOC = 0x400
 global TAG_EXCEPTION_HANDLER = 0x500
 global TAG_FUNCTION = 0x600
+global TAG_LINE_NUMBERS = 0x700