From 60ad22f29f55a38f1ea09e71a5e25ce0cad7ec32 Mon Sep 17 00:00:00 2001
From: Evan Hanson <address@hidden>
Date: Sat, 27 Sep 2014 13:37:53 +1200
Subject: [PATCH] Include debug info on ##core#direct_call nodes.

Signed-off-by: Peter Bex <address@hidden>
---
 NEWS          |  1 +
 c-backend.scm | 26 ++++++++++++++++++++------
 compiler.scm  | 15 ++++++++++++---
 optimizer.scm |  9 ++++++---
 4 files changed, 39 insertions(+), 12 deletions(-)

diff --git a/NEWS b/NEWS
index fcdeabc..6a34708 100644
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,7 @@
 - Compiler:
   - Fixed incorrect argvector restoration after GC in directly
     recursive functions (#1317).
+  - "Direct" procedure invocations now also maintain debug info (#894).
 
 - Runtime system:
   - "time" macro now shows peak memory usage (#1318, thanks to Kooda).
diff --git a/c-backend.scm b/c-backend.scm
index 2479986..b006ed0 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -356,14 +356,27 @@
 	    ((##core#direct_call) 
 	     (let* ((args (cdr subs))
 		    (n (length args))
-		    (nf (add1 n)) 
-		    ;;(name (second params))
-		    (call-id (third params))
-		    (demand (fourth params))
+		    (nf (add1 n))
+		    (dbi (first params))
+		    ;; (safe-to-call (second params))
+		    (name (third params))
+		    (name-str (source-info->string name))
+		    (call-id (fourth params))
+		    (demand (fifth params))
 		    (allocating (not (zero? demand)))
 		    (empty-closure (zero? (lambda-literal-closure-size (find-lambda call-id))))
 		    (fn (car subs)) )
-	       (gen call-id #\()
+	       (gen #\()
+	       (when name
+		 (cond (emit-debug-info
+			(when dbi
+			  (gen #t "  C_debugger(&(C_debug_info[" dbi "]),"
+			       (if non-av-proc "0,NULL" "c,av") "),")))
+		       (emit-trace-info
+			(gen #t "  C_trace(\"" (backslashify name-str) "\"),"))
+		       (else
+			(gen #t "  /* " (uncommentify name-str) " */") ) ) )
+	       (gen #t "  " call-id #\()
 	       (when allocating 
 		 (gen "C_a_i(&a," demand #\))
 		 (when (or (not empty-closure) (pair? args)) (gen #\,)) )
@@ -371,7 +384,8 @@
 		 (expr fn i)
 		 (when (pair? args) (gen #\,)) )
 	       (when (pair? args) (expr-args args i))
-	       (gen #\)) ) )
+	       (gen #\))		; function call
+	       (gen #t #\)) ) )		; complete expression
 
 	    ((##core#callunit)
 	     ;; The code generated here does not use the extra temporary needed for standard calls, so we have
diff --git a/compiler.scm b/compiler.scm
index db1b0b2..be605f2 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -218,7 +218,7 @@
 ; [##core#proc {<name> [<non-internal>]}]
 ; [##core#recurse {<tail-flag> <call-id>} <exp1> ...]
 ; [##core#return <exp>]
-; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
+; [##core#direct_call {<dbg-info-index> <safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
 
 ; Analysis database entries:
 ;
@@ -2592,8 +2592,17 @@
 	   (walk-var (first params) e e-count #f) )
 
 	  ((##core#direct_call)
-	   (set! allocated (+ allocated (fourth params)))
-	   (make-node class params (mapwalk subs e e-count here boxes)) )
+	   (let* ((name (second params))
+		  (name-str (source-info->string name))
+		  (demand (fourth params)))
+	     (if (and emit-debug-info name)
+		 (let ((info (list dbg-index 'C_DEBUG_CALL "" name-str)))
+		   (set! params (cons dbg-index params))
+		   (set! debug-info (cons info debug-info))
+		   (set! dbg-index (add1 dbg-index)))
+		 (set! params (cons #f params)))
+	     (set! allocated (+ allocated demand))
+	     (make-node class params (mapwalk subs e e-count here boxes))) )
 
 	  ((##core#inline_allocate)
 	   (set! allocated (+ allocated (second params)))
diff --git a/optimizer.scm b/optimizer.scm
index 129efd6..af4d786 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -1526,8 +1526,11 @@
 	   ;; Transform call-sites:
 	   (for-each
 	    (lambda (site)
-	      (let* ([n (cdr site)]
-		     [nsubs (node-subexpressions n)] )
+	      (let* ((n (cdr site))
+		     (nsubs (node-subexpressions n))
+		     (params (node-parameters n))
+		     (debug-info (and (pair? (cdr params))
+				      (second params))))
 		(unless (= argc (length (cdr nsubs)))
 		  (quit
 		   "known procedure called with wrong number of arguments: `~A'"
@@ -1537,7 +1540,7 @@
 		 (list (second nsubs)
 		       (make-node
 			'##core#direct_call
-			(list #t #f id allocated)
+			(list #t debug-info id allocated)
 			(cons (car nsubs) (cddr nsubs)) ) ) ) ) )
 	    (lset-difference (lambda (s1 s2) (eq? (cdr s1) (cdr s2))) sites ksites) )
 
-- 
2.1.4