~ chicken-core (chicken-5) 06577311a49f6fd04f91f056f2e6b4cf8f40ea97

commit 06577311a49f6fd04f91f056f2e6b4cf8f40ea97
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sun Dec 18 20:11:04 2016 +0100
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Mon Dec 19 13:29:45 2016 +1300

    Include debug info on ##core#direct_call nodes
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index dabdd339..79403b99 100644
--- a/NEWS
+++ b/NEWS
@@ -67,6 +67,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 9b09312e..5957514e 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -372,14 +372,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 #\,)) )
@@ -387,7 +400,8 @@
 		 (expr fn i)
 		 (when (pair? args) (gen #\,)) )
 	       (when (pair? args) (expr-args args i))
-	       (gen #\)) ) )
+	       (gen #\))		; function call
+	       (gen #t #\))))		; complete expression
 
 	    ((##core#provide)
 	     (gen "C_a_i_provide(&a,1,lf[" (first params) "])"))
diff --git a/core.scm b/core.scm
index db6337da..c046c079 100644
--- a/core.scm
+++ b/core.scm
@@ -220,7 +220,7 @@
 ; [##core#provide <literal>]
 ; [##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:
 ;
@@ -2666,8 +2666,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 fa810556..b4f623c6 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -1550,8 +1550,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-compiling
 		   "known procedure called with wrong number of arguments: `~A'"
@@ -1561,7 +1564,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)) ) ) ) ) )
 	    (filter (lambda (site)
 		      (let ((s2 (cdr site)))