~ chicken-core (chicken-5) 1ad3512ac0b1d657ecf3b9e773396dc8065c2a0f

commit 1ad3512ac0b1d657ecf3b9e773396dc8065c2a0f
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sat Sep 27 13:37:53 2014 +1200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Mon Dec 19 13:31:39 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 fcdeabc2..6a347081 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 24799860..9631f62d 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 db1b0b21..62a55f57 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 129efd6b..af4d786c 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) )