Produce debug information for arguments to compiled functions when DEBUG=3.

src/CHANGELOG

@@ -79,6 +79,10 @@ ECL 9.5:
 
  - The debugger is now fit for multithreaded environments (JCB)
 
+ - Compiled functions with DEBUG=3 now produce information about their
+   arguments and variables, that can be inspected in the debugger
+   (evolved from patches by JCB).
+
 * Bugs fixed:
 
  - Remove an obsolete #if statement for Solaris that broke current builds

src/cmp/cmpdefs.lsp

@@ -346,6 +346,8 @@ progress. The default value is T.")
 (defvar *next-cmacro* 0)	; holds the last cmacro number used.
 (defvar *next-cfun* 0)		; holds the last cfun used.
 
+(defvar *debug-fun* 0)		; Level of debugging of functions
+
 ;;;
 ;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
 ;;; If possible, *tail-recursion-info* holds

src/cmp/cmpexit.lsp

@@ -27,8 +27,9 @@
 	(declare (fixnum n))
 	(wt-nl "ecl_bds_unwind1(cl_env_copy);"))
       (wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");"))
-  (when ihs-p
-    (wt-nl "ecl_ihs_pop(cl_env_copy);")))
+  (case ihs-p
+    (IHS (wt-nl "ecl_ihs_pop(cl_env_copy);"))
+    (IHS-ENV (wt-nl "ihs.lex_env = _ecl_debug_env;"))))
 
 (defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil))
   (declare (fixnum bds-bind))
@@ -75,7 +76,8 @@
       ((numberp ue) (baboon)
        (setq bds-lcl ue bds-bind 0))
       (t (case ue
-	   (IHS (setf ihs-p t))
+	   (IHS (setf ihs-p ue))
+           (IHS-ENV (setf ihs-p (or ihs-p ue)))
 	   (BDS-BIND (incf bds-bind))
 	   (RETURN
 	     (unless (eq *exit* 'RETURN) (baboon))
@@ -154,6 +156,8 @@
         ;;; Never reached
         )
        ((eq ue 'JUMP))
+       ((eq ue 'IHS-ENV)
+        (setf ihs-p ue))
        (t (baboon))
        ))
   ;;; Never reached

src/cmp/cmplam.lsp

@@ -383,6 +383,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
 	       (bind `(LCL ,reqi) var))
 	      ((unboxed var) ; create unboxed variable
 	       (setf (var-loc var) (wt-decl var)))))
+      #+nil ; jjgr debug
       (loop for req in requireds
             do (print (list local-entry-p req (var-loc req))))
       (when (and rest (< (var-ref rest) 1)) ; dont create rest if not used
@@ -410,10 +411,6 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
 		 "cl_va_list args; cl_va_start(args,~a,narg,~d);")
 	     first-arg nreq))))
 
-    (when fname-in-ihs-p
-      (push 'IHS *unwind-exit*)
-      (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname) ",Cnil);"))
-
     ;; Bind required parameters.
     (do ((reqs requireds (cdr reqs))
 	 (reqi (1+ req0) (1+ reqi)))	; to allow concurrent compilations
@@ -421,8 +418,19 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
       (declare (fixnum reqi) (type cons reqs))
       (bind `(LCL ,reqi) (first reqs)))
 
-    (setq *lcl* lcl)
-    )
+    (when fname-in-ihs-p
+      (wt-nl "{")
+      (push 'IHS *unwind-exit*)
+      (cond ((>= *debug-fun* 3)
+             (build-debug-lexical-env (reverse requireds) t)
+             (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname)
+                    ",_ecl_debug_env);"))
+            (t
+             (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname)
+                    ",Cnil);"))))
+
+    (setq *lcl* lcl))
+
   ;; Bind optional parameters as long as there remain arguments.
   (when optionals
     ;; When binding optional values, we use two calls to BIND. This means
@@ -506,6 +514,8 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
   (c2expr body)
 
   ;;; Closing braces is done i cmptop.lsp
+  (when fname-in-ihs-p
+    (wt-nl "}"))
   )
 
 (defun optimize-funcall/apply-lambda (lambda-form arguments apply-p

src/cmp/cmploc.lsp

@@ -146,6 +146,8 @@
 
 (defun wt-cadr (loc) (wt "CADR(" loc ")"))
 
+(defun lcl-name (lcl) (format nil "V~D" lcl))
+
 (defun wt-lcl (lcl) (unless (numberp lcl) (baboon)) (wt "V" lcl))
 
 (defun wt-vv (vv)

src/cmp/cmptop.lsp

@@ -527,6 +527,59 @@
           (t (cmperr "The C variable specification ~s is illegal." cvs))))
   )
 
+(defvar *debug-fun* nil)
+
+(defun locative-type-from-var-kind (kind)
+  (cdr (assoc kind
+              '((:object . "_ecl_object_loc")
+                (:fixnum . "_ecl_fixnum_loc")
+                (:char . "_ecl_base_char_loc")
+                (:float . "_ecl_float_loc")
+                (:double . "_ecl_double_loc")
+                ((special global closure replaced lexical) . NIL)))))
+
+(defun build-debug-lexical-env (var-locations &optional first)
+  (let* ((filtered-locations '())
+         (filtered-codes '()))
+    ;; Filter out variables that we know how to store in the
+    ;; debug information table. This excludes among other things
+    ;; closures and special variables.
+    (loop for var in var-locations
+          for name = (format nil "\"~A\"" (var-name var))
+          for code = (locative-type-from-var-kind (var-kind var))
+          for loc = (var-loc var)
+          when (and code (consp loc) (eq (first loc) 'LCL))
+          do (progn
+               (push (cons name code) filtered-codes)
+               (push (second loc) filtered-locations)))
+    ;; Generate two tables, a static one with information about the
+    ;; variables, including name and type, and dynamic one, which is
+    ;; a vector of pointer to the variables.
+    (when filtered-codes
+      (wt-nl "static const struct ecl_var_debug_info _ecl_descriptors[]={")
+      (loop for (name . code) in filtered-codes
+            for i from 0
+            do (wt-nl (if (zerop i) "{" ",{") name "," code "}"))
+      (wt "};")
+      (wt-nl "const cl_index _ecl_debug_info_raw[]={")
+      (wt-nl (if first "(cl_index)(Cnil)," "(cl_index)(_ecl_debug_env),")
+             "(cl_index)(_ecl_descriptors)")
+      (loop for var-loc in filtered-locations
+            do (wt ",(cl_index)(&" (lcl-name var-loc) ")"))
+      (wt "};")
+      (wt-nl "ecl_def_ct_vector(_ecl_debug_env,aet_index,_ecl_debug_info_raw,"
+             (+ 2 (length filtered-locations))
+             ",,);"))
+    (if first
+        (if (not filtered-codes)
+            (wt-nl "cl_object _ecl_debug_env = Cnil;"))
+        (if filtered-codes
+            (wt-nl "ihs.lex_env=_ecl_debug_env;")))
+    filtered-codes))
+
+(defun pop-debug-lexical-env ()
+  (wt-nl "ihs.lex_env=_ecl_debug_env;"))
+
 (defun t3local-fun (fun &aux  (lambda-expr (fun-lambda fun))
 			      (level (if (eq (fun-closure fun) 'LEXICAL)
 					 (fun-level fun)
@@ -539,7 +592,8 @@
 			      (*volatile* (c1form-volatile* lambda-expr))
 			      (*tail-recursion-info* fun)
                               (lambda-list (c1form-arg 0 lambda-expr))
-                              (requireds (car lambda-list)))
+                              (requireds (car lambda-list))
+                              (*debug-fun* *debug-fun*))
   (declare (fixnum level nenvs))
   (print-emitting fun)
   (wt-comment-nl (cond ((fun-global fun) "function definition for ~a")
@@ -596,6 +650,7 @@
       (wt "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;"))
     (wt-nl *volatile* "cl_object value0;")
     (when (>= (fun-debug fun) 2)
+      (setq *debug-fun* (fun-debug fun))
       (wt-nl "struct ihs_frame ihs;"))
     (when (policy-check-stack-overflow)
       (wt-nl "ecl_cs_check(cl_env_copy,value0);"))