1 ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancments. ;;;;;
5 ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
6 ;;; All rights reserved ;;;;;
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13 (macsyma-module mtrace
)
15 (declare-top (special $functions $transrun trace-allp
))
17 ;;; a reasonable trace capability for macsyma users.
18 ;;; 8:10pm Saturday, 10 January 1981 -GJC.
20 ;; TRACE(F1,F2,...) /* traces the functions */
21 ;; TRACE() /* returns a list of functions under trace */
22 ;; UNTRACE(F1,F2,...) /* untraces the functions */
23 ;; UNTRACE() /* untraces all functions. */
24 ;; TRACE_MAX_INDENT /* The maximum indentation of trace printing. */
26 ;; TRACE_OPTIONS(F,option1,option2,...) /* gives F options */
28 ;; TRACE_BREAK_ARG /* Bound to list of argument during BREAK ENTER,
29 ;; and the return value during BREAK EXIT.
30 ;; This lets you change the arguments to a function,
31 ;; or make a function return a different value,
32 ;; which are both useful debugging hacks.
34 ;; You probably want to give this a short alias
35 ;; for typing convenience.
38 ;; An option is either a keyword, FOO.
39 ;; or an expression FOO(PREDICATE_FUNCTION);
41 ;; A keyword means that the option is in effect, an keyword
42 ;; expression means to apply the predicate function to some arguments
43 ;; to determine if the option is in effect. The argument list is always
44 ;; [LEVEL,DIRECTION, FUNCTION, ITEM] where
45 ;; LEVEL is the recursion level for the function.
46 ;; DIRECTION is either ENTER or EXIT.
47 ;; FUNCTION is the name of the function.
48 ;; ITEM is either the argument list or the return value.
50 ;; ----------------------------------------------
51 ;; | Keyword | Meaning of return value |
52 ;; ----------------------------------------------
53 ;; | NOPRINT | If TRUE do no printing. |
54 ;; | BREAK | If TRUE give a breakpoint. |
55 ;; | LISP_PRINT | If TRUE use lisp printing. |
56 ;; | INFO | Extra info to print |
57 ;; | ERRORCATCH | If TRUE errors are caught. |
58 ;; ----------------------------------------------
60 ;; General interface functions. These would be called by user debugging utilities.
62 ;; TRACE_IT('F) /* Trace the function named F */
63 ;; TRACE /* list of functions presently traced. */
64 ;; UNTRACE_IT('F) /* Untrace the function named F */
65 ;; GET('F,'TRACE_OPTIONS) /* Access the trace options of F */
67 ;; Sophisticated feature:
68 ;; TRACE_SAFETY a variable with default value TRUE.
69 ;; Example: F(X):=X; BREAKP([L]):=(PRINT("Hi!",L),FALSE),
70 ;; TRACE(F,BREAKP); TRACE_OPTIONS(F,BREAK(BREAKP));
71 ;; F(X); Note that even though BREAKP is traced, and it is called,
72 ;; it does not print out as if it were traced. If you set
73 ;; TRACE_SAFETY:FALSE; then F(X); will cause a normal trace-printing
74 ;; for BREAKP. However, then consider TRACE_OPTIONS(BREAKP,BREAK(BREAKP));
75 ;; When TRACE_SAFETY:FALSE; F(X); will give an infinite recursion,
76 ;; which it would not if safety were turned on.
77 ;; [Just thinking about this gives me a headache.]
79 ;; Internal notes on this package: -jkf
80 ;; Trace works by storing away the real definition of a function and
81 ;; replacing it by a 'shadow' function. The shadow function prints a
82 ;; message, calls the real function, and then prints a message as it
83 ;; leaves. The type of the shadow function may differ from the
84 ;; function being shadowed. The chart below shows what type of shadow
85 ;; function is needed for each type of Macsyma function.
87 ;; Macsyma function shadow type hook type mget
88 ;; ____________________________________________________________
95 ;; mfexpr* mfexpr* macro
96 ;; mfexpr*s mfexpr* macro
98 ;; The 'hook type' refers to the form of the shadow function. 'expr' types
99 ;; are really lexprs, they expect any number of evaluated arguments.
100 ;; 'fexpr' types expect one unevaluated argument which is the list of
101 ;; arguments. 'macro' types expect one argument, the caar of which is the
102 ;; name of the function, and the cdr of which is a list of arguments.
104 ;; For systems which store all function properties on the property list,
105 ;; it is easy to shadow a function. For systems with function cells,
106 ;; the situation is a bit more difficult since the standard types of
107 ;; functions are stored in the function cell (expr,fexpr,lexpr), whereas
108 ;; the macsyma functions (mfexpr*,...) are stored on the property list.
111 ;; 1) The variety of maxima functions is much more restricted than
112 ;; what the table above shows. I think the following table gives
113 ;; the correct picture (like its counterpart, it ignores maxima
114 ;; macros or functional arrays).
117 ;; Maxima function shadow type hook type mget
118 ;; ____________________________________________________________
121 ;; mfexpr* mfexpr* expr
123 ;; These types have the following meaning: Suppose MFUN evaluates to some
124 ;; symbol in the MAXIMA package. That this symbol is of type
126 ;; - EXPR (or SUBR) implies that it has a lisp function definition
127 ;; (SYMBOL-FUNCTION MFUN).
129 ;; - MEXPR implies that it has a (parsed) maxima language definition
130 ;; (MGET MFUN 'MEXPR) and all arguments are evaluated by MEVAL.
132 ;; - MFEXPR* implies that it has a lisp function definition
133 ;; (GET MFUN 'MFEXPR*) and its arguments are not automatically
134 ;; evaluated by MEVAL.
136 ;; Note that the shadow type has to agree with the original function's
137 ;; type in the way arguments are evaluated. On the other hand, I think
138 ;; we are left with EXPR as the only hook type; as a matter of fact, this
139 ;; is equivalent to the next point:
141 ;; 2) There is no need for MAKE-TRACE-HOOK to dispatch with respect to
142 ;; HOOK-TYPE since, roughly speaking, proper handling of the traced
143 ;; function's arguments is done by the trace handler in concert with
146 ;; Note that I also removed the COPY-LIST used to pass the traced
147 ;; function's argument list to the trace handler.
149 ;; There remains an annoying problem with translated functions: tracing
150 ;; some function of type MEXPR and then loading its translated version
151 ;; (which is of type EXPR) will not cleanly untrace it (i.e., it is
152 ;; effectively no longer traced but it remains on the list of traced
153 ;; functions). I think that this has to be fixed somewhere in the
154 ;; translation package. -wj
156 ;; Maxima offers no user-level mechanism for manipulating multiple
157 ;; return values; however, multiple (lisp) return values need to be
158 ;; handled and returned correctly in traced or timed functions.
159 ;; For example, if a user traces or times a rule created by defrule
160 ;; then the second return value must be propagated so apply1 and
161 ;; friends know when the rule hits (the documentation states that
162 ;; these rules can be treated as functions, so it seems reasonable
163 ;; to want to trace or time them).
165 ;; We still pretend like there is only one return value when we
166 ;; print the trace, pass the value to a trace option predicate or
167 ;; allow the user to set a new return value at a breakpoint. This
168 ;; is both for backward-compatibility (particularly in predicates)
169 ;; and because Maxima doesn't actually support multiple values anyway.
174 #+gcl
(compile load eval
)
175 #-gcl
(:compile-toplevel
:load-toplevel
:execute
)
176 (defmacro trace-p
(x)
178 (defmacro trace-type
(x)
179 `(mget ,x
'trace-type
))
180 (defmacro trace-level
(x)
181 `(mget ,x
'trace-level
))
182 (defmacro trace-options
(x)
183 `($get
,x
'$trace_options
))
184 (defmacro trace-oldfun
(x)
185 `(mget ,x
'trace-oldfun
)))
187 ;;; User interface functions.
189 (defmvar $trace
(list '(mlist)) "List of functions actively traced")
191 (defun mlistcan-$all
(fun llist default
)
192 "totally random utility function"
196 `((mlist) ,@(mapcan fun
197 (if (member (car llist
) '($all $functions
) :test
#'eq
)
200 (mapcar #'caar
(cdr $functions
)))
203 (defmspec $trace
(form)
204 (mlistcan-$all
#'macsyma-trace
(cdr form
) $trace
))
206 (defmfun $trace_it
(function)
207 `((mlist) ,@(macsyma-trace function
)))
209 (defmspec $untrace
(form)
210 `((mlist) ,@(mapcan #'macsyma-untrace
(or (cdr form
) (cdr $trace
)))))
212 (defmfun $untrace_it
(function)
213 `((mlist) ,@(macsyma-untrace function
)))
215 (defmspec $trace_options
(form)
216 (setf (trace-options (cadr form
))
217 `((mlist) ,@(cddr form
))))
219 ;;; System interface functions.
221 (defvar hard-to-trace
'(trace-handler listify args trace-apply
*apply mapply
))
223 ;; A list of functions called by the TRACE-HANDLEr at times when
224 ;; it cannot possibly shield itself from a continuation which would
225 ;; cause infinite recursion. We are assuming the best-case of
228 (defun macsyma-trace (fun)
229 (macsyma-trace-sub fun
'trace-handler $trace
))
231 (defun macsyma-trace-sub (fun handler ilist
&aux temp
)
232 (cond ((not (symbolp (setq fun
(getopr fun
))))
233 (mtell (intl:gettext
"trace: argument is apparently not a function or operator: ~M~%") fun
)
236 ;; Things which redefine should be expected to reset this
238 (if (not trace-allp
) (mtell (intl:gettext
"trace: function ~@:M is already traced.~%") fun
))
240 ((member fun hard-to-trace
:test
#'eq
)
241 (mtell (intl:gettext
"trace: ~@:M cannot be traced.~%") fun
)
243 ((not (setq temp
(car (macsyma-fsymeval fun
))))
244 (mtell (intl:gettext
"trace: ~@:M has no functional properties.~%") fun
)
246 ((member temp
'(mmacro translated-mmacro
) :test
#'eq
)
247 (mtell (intl:gettext
"trace: ~@:M is a macro, so it won't trace well; try 'macroexpand' to debug it.~%") fun
)
250 (put-trace-info fun temp ilist
)
251 (trace-fshadow fun temp
(make-trace-hook fun temp handler
))
254 (mtell (intl:gettext
"trace: ~@:M is an unknown type of function.~%") fun
)
257 (defvar trace-handling-stack
())
259 (defun macsyma-untrace (fun)
260 (macsyma-untrace-sub fun
'trace-handler $trace
))
262 (defun macsyma-untrace-sub (fun handler ilist
)
264 (cond ((not (symbolp (setq fun
(getopr fun
))))
265 (mtell (intl:gettext
"untrace: argument is apparently not a function or operator: ~M~%") fun
)
268 (mtell (intl:gettext
"untrace: ~@:M is not traced.~%") fun
)
271 (trace-unfshadow fun
(trace-type fun
))
272 (rem-trace-info fun ilist
)
274 (if (member fun trace-handling-stack
:test
#'eq
)
275 ;; yes, he has re-defined or untraced the function
276 ;; during the trace-handling application.
277 ;; This is not strange, in fact it happens all the
278 ;; time when the user is using the $ERRORCATCH option!
279 (macsyma-trace-sub fun handler ilist
))))
281 (defun put-trace-info (fun type ilist
)
282 (setf (trace-p fun
) fun
) ; needed for MEVAL at this time also.
283 (setf (trace-type fun
) type
)
284 ;; Pretty sure this next property assignment is clobbered by TRACE-FSHADOW,
285 ;; however, the assignment is conditional there, so I don't know 100%.
286 (setf (trace-oldfun fun
) (and (fboundp fun
) (symbol-function (or (get fun
'impl-name
) fun
))))
287 (let ((sym (gensym)))
288 (setf (symbol-value sym
) 0)
289 (setf (trace-level fun
) sym
))
290 (push fun
(cdr ilist
))
293 (defun rem-trace-info (fun ilist
)
294 (setf (trace-p fun
) nil
)
295 (or (member fun trace-handling-stack
:test
#'eq
)
296 (setf (trace-level fun
) nil
))
297 (setf (trace-type fun
) nil
)
298 (setq ilist
(delete fun ilist
:test
#'eq
))
301 ;; Placing the TRACE functional hook.
302 ;; Because the function properties in macsyma are used by the EDITOR, SAVE,
303 ;; and GRIND commands it is not possible to simply replace the function
304 ;; being traced with a hook and to store the old definition someplace.
305 ;; [We do know how to cons up machine-code hooks on the fly, so that
306 ;; is not stopping us].
309 ;; This data should be formalized somehow at the time of
310 ;; definition of the DEFining form.
312 (defprop subr expr shadow
)
313 (defprop lsubr expr shadow
)
314 (defprop expr expr shadow
)
315 (defprop mfexpr
*s mfexpr
* shadow
)
316 (defprop mfexpr
* mfexpr
* shadow
)
318 (defprop mexpr t mget
)
319 (defprop mexpr expr shadow
)
323 (maxima-error (intl:gettext
"GET!: property ~a of symbol ~a undefined.") y x
)))
325 (defun trace-fshadow (fun type value
)
326 (let ((shadow (get! type
'shadow
)))
327 (cond ((and (eq type
'mexpr
)
329 ; We're tracing an mexpr with special evaluation rules (mfexpr).
330 ; Let's put a Maxima lambda expression on the plist that calls
331 ; the trace hook. Then in the evaluator we can just have mlambda
332 ; do the work for us.
334 ; If there is not a rest argument in the mexpr's lambda list
335 ; then this newly-constructed lambda expression just does a
336 ; funcall. If there is a rest argument then it requires a
339 (let* ((lambda-list (cadr (mget fun
'mexpr
)))
340 (params (mparams lambda-list
)))
341 `((lambda) ,lambda-list
342 ,(if (mget fun
'mlexprp
)
343 (flet ((call-hook (restarg &rest nonrestargs
)
344 (apply value
(append nonrestargs
346 ; This is the mfexpr+mlexpr case (we have at
347 ; least one quoted arg and a rest arg).
349 ; The use of call-hook here is basically like
353 ; ((mlist) ,@(butlast params))
354 ; ,(car (last params))))
356 ; but faster. We just have to construct
357 ; things so simplifya doesn't barf on any
358 ; intermediate expressions.
359 `((funcall) ,#'call-hook
362 `((funcall) ,value
,@params
))))
364 ((member shadow
'(expr subr
) :test
#'eq
)
365 (setf (trace-oldfun fun
) (and (fboundp fun
) (symbol-function (or (get fun
'impl-name
) fun
))))
366 (setf (symbol-function (or (get fun
'impl-name
) fun
)) value
))
368 (setf (symbol-plist fun
) `(,shadow
,value
,@(symbol-plist fun
)))))))
370 (defun trace-unfshadow (fun type
)
371 ;; At this point, we know that FUN is traced.
372 (cond ((and (eq type
'mexpr
)
373 (safe-get fun
'mfexpr
))
374 (remprop fun
'mfexpr
))
375 ((member type
'(expr subr
) :test
#'eq
)
376 (let ((oldf (trace-oldfun fun
)))
377 (if (not (null oldf
))
378 (setf (symbol-function (or (get fun
'impl-name
) fun
)) oldf
)
380 (t (remprop fun
(get! type
'shadow
))
383 ;;--- trace-fsymeval :: find original function
384 ;; fun : a function which is being traced. The original definition may
385 ;; be hidden on the property list behind the shadow function.
387 (defun trace-fsymeval (fun)
389 (let ((type-of (trace-type fun
)))
390 (cond ((get type-of
'mget
)
391 (if (eq (get! type-of
'shadow
) type-of
)
392 (mget (cdr (mgetl fun
(list type-of
))) type-of
)
394 ((eq (get! type-of
'shadow
) 'expr
)
396 (t (if (eq (get! type-of
'shadow
) type-of
)
397 (cadr (getl (cdr (getl fun
`(,type-of
))) `(,type-of
)))
398 (get fun type-of
)))))
400 (merror "internal error: trace property for ~:@M went away without hook." fun
))))
402 ;;; The handling of a traced call.
404 (defvar trace-indent-level -
1)
406 (defmacro bind-sym
(symbol value . body
)
407 ;; is by far the best dynamic binding generally available.
408 `(progv (list ,symbol
)
412 ;; We really want to (BINDF (TRACE-LEVEL FUN) (1+ (TRACE-LEVEL FUN)) ...)
413 ;; (Think about PROGV and SETF and BINDF. If the trace object where
414 ;; a closure, then we want to fluid bind instance variables.)
416 (declare-top (special errcatch bindlist loclist
))
418 (defmacro macsyma-errset
(form &aux
(ret (gensym)))
419 `(let ((errcatch (cons bindlist loclist
)) ,ret
)
420 (setq ,ret
(errset ,form
))
421 (or ,ret
(errlfun1 errcatch
))
424 (defvar predicate-arglist nil
)
426 (defvar return-to-trace-handle nil
)
428 (defun trace-handler (fun largs
)
429 (if (or return-to-trace-handle
430 (and (not (atom (car largs
)))
431 (not (atom (caar largs
)))
432 (eq (caaar largs
) '$untrace
)
433 (eq (cadar largs
) fun
)))
434 ;; We were called by the trace-handler or by $untrace and the function
435 ;; fun is to be untraced.
436 (trace-apply fun largs
)
437 (let ((trace-indent-level (1+ trace-indent-level
))
438 (return-to-trace-handle t
)
439 (trace-handling-stack (cons fun trace-handling-stack
))
440 (level-sym (trace-level fun
))
442 (setq level
(1+ (symbol-value level-sym
)))
443 (bind-sym level-sym level
448 (setq predicate-arglist
`(,level $enter
,fun
((mlist) ,@largs
)))
449 (setq largs
(trace-enter-break fun level largs
))
450 (trace-enter-print fun level largs
)
451 (cond ((trace-option-p fun
'$errorcatch
)
452 (setq ret-vals
(macsyma-errset (trace-apply fun largs
)))
453 (cond ((null ret-vals
)
454 (setq ret-vals
(trace-error-break fun level largs
))
455 (setq continuation
(car ret-vals
)
456 ret-vals
(cdr ret-vals
)))
458 (setq continuation
'exit
))))
460 (setq continuation
'exit
461 ret-vals
(multiple-value-list (trace-apply fun largs
)))))
464 (setq predicate-arglist
`(,level $exit
,fun
,(car ret-vals
)))
465 (setq ret-vals
(trace-exit-break fun level ret-vals
))
466 (trace-exit-print fun level
(car ret-vals
))
467 (return (values-list ret-vals
)))
469 (setq largs ret-vals
)
470 (mtell "TRACE-HANDLER: reapplying the function ~:@M~%" fun
))
472 (merror "~%TRACE-HANDLER: signaling 'maxima-error' for function ~:@M~%" fun
))))))))
475 ;; The (Trace-options function) access is not optimized to take place
476 ;; only once per trace-handle call. This is so that the user may change
477 ;; options during his break loops.
478 ;; Question: Should we bind return-to-trace-handle to NIL when we
479 ;; call the user's predicate? He has control over his own lossage.
481 (defmvar $trace_safety t
"This is subtle")
483 (defun trace-option-p (function keyword
)
485 (let ((options (trace-options function
)))
486 (cond ((null options
) nil
)
487 (($listp options
) (cdr options
))
489 (mtell "TRACE-OPTION-P: trace options for ~:@M not a list, so ignored.~%" function
)
494 (setq option
(car options
))
496 (if (eq option keyword
) (return t
)))
497 ((eq (caar option
) keyword
)
498 (let ((return-to-trace-handle $trace_safety
))
499 (return (mapply (cadr option
) predicate-arglist
500 "A trace option predicate")))))))
503 (defun trace-enter-print (fun lev largs
)
504 (let ((args (if (eq (trace-type fun
) 'mfexpr
*)
507 (if (not (trace-option-p fun
'$noprint
))
508 (let ((info (trace-option-p fun
'$info
)))
509 (cond ((trace-option-p fun
'$lisp_print
)
510 (trace-print `(,lev enter
,fun
,args
,@info
)))
513 (intl:gettext
" Enter ")
518 (if info info
""))))))))
520 (defun mopstringnam (x)
521 (maknam (mstring (getop x
))))
523 (defun trace-exit-print (fun lev ret-val
)
524 (if (not (trace-option-p fun
'$noprint
))
525 (let ((info (trace-option-p fun
'$info
)))
526 (cond ((trace-option-p fun
'$lisp_print
)
527 (trace-print `(,lev exit
,fun
,ret-val
,@info
)))
529 (trace-mprint lev
(intl:gettext
" Exit ") (mopstringnam fun
) " " ret-val
531 (if info info
"")))))))
533 (defmvar $trace_break_arg
'$trace_break_arg
534 "During trace Breakpoints bound to the argument list or return value")
536 (defun trace-enter-break (fun lev largs
)
537 (if (trace-option-p fun
'$break
)
538 (do ((return-to-trace-handle nil
)
539 ($trace_break_arg
`((mlist) ,@largs
)))(nil)
540 ($break
"Trace entering" fun
"level" lev
)
541 (cond (($listp $trace_break_arg
)
542 (return (cdr $trace_break_arg
)))
544 (mtell "TRACE-ENTER-BREAK: 'trace_break_arg' must be a list.~%"))))
547 (defun trace-exit-break (fun lev ret-vals
)
548 (if (trace-option-p fun
'$break
)
549 (let (($trace_break_arg
(car ret-vals
))
550 (return-to-trace-handle nil
))
551 ($break
"Trace exiting" fun
"level" lev
)
552 ; If trace_break_arg is the same (in the sense of eq) now
553 ; as when we started the breakpoint, then return all of the
554 ; original return values from the function. This means if
555 ; the user sets trace_break_arg but its value is eq to its
556 ; original value (which is only the primary return value
557 ; from the original function) then we still return the extra
558 ; values (if there are any). I (kjak) don't think this is
559 ; strictly correct, but we can try to fix it up later if
560 ; anyone ever really cares about this corner case involving
561 ; multiple return values, exit breakpoints and setting
562 ; trace_break_arg to the same value it started with.
563 (if (eq $trace_break_arg
(car ret-vals
))
565 (list $trace_break_arg
)))
568 (defun pred-$read
(predicate argl bad-message
)
570 (setq ans
(apply #'$read argl
))
571 (if (funcall predicate ans
) (return ans
))
572 (mtell "PRED-$READ: unacceptable input: ~A~%" bad-message
)))
574 (defun ask-choicep (llist &rest header-message
)
576 (dlist nil
(list* #\newline
`((marrow) ,j
,(car ilist
)) dlist
))
577 (ilist llist
(cdr ilist
)))
579 (setq dlist
(nconc header-message
(cons #\newline
(nreverse dlist
))))
580 (let ((upper (1- j
)))
581 (pred-$read
#'(lambda (val)
586 "please reply with an integer from the menue.")))))
588 ;; I GUESS ALL OF THE STRINGS IN THIS FUNCTION NEED TO BE GETTEXT'D TOO
589 ;; JUST CAN'T BRING MYSELF TO DO IT
591 (defun trace-error-break (fun level largs
)
592 (case (ask-choicep '("Signal an `maxima-error', i.e. punt?"
593 "Retry with same arguments?"
594 "Retry with new arguments?"
595 "Exit with user supplied value")
596 "Error during application of" (mopstringnam fun
)
598 #\newline
"Do you want to:")
604 (cons 'retry
(let (($trace_break_arg
`((mlist) ,@largs
)))
605 (cdr (pred-$read
'$listp
607 "Enter new argument list for"
609 "please enter a list.")))))
612 (cons 'exit
(list ($read
"Enter value to return"))))))
614 ;;; application dispatch, and the consing up of the trace hook.
616 (defun macsyma-fsymeval (fun)
617 (let ((try (macsyma-fsymeval-sub fun
)))
620 (load-and-tell (get fun
'autoload
))
621 (setq try
(macsyma-fsymeval-sub fun
))
623 (mtell (intl:gettext
"trace: ~@:M has no functional properties after autoloading.~%")
628 (defun macsyma-fsymeval-sub (fun)
629 ;; The semantics of $TRANSRUN are herein taken from DESCRIBE,
630 ;; a careful reading of MEVAL1 reveals, well... I've promised to watch
631 ;; my language in these comments.
633 (let ((mprops (mgetl fun
'(mexpr mmacro
)))
634 (lprops (getl fun
'(translated-mmacro mfexpr
* mfexpr
*s
)))
635 (fcell-props (getl-lm-fcn-prop fun
'(subr lsubr expr macro
))))
637 ;; the default, so its really a waste to have looked for
638 ;; those mprops. Its better to fix the crock than to
639 ;; optimize this though!
640 (or lprops fcell-props mprops
))
642 (or mprops lprops fcell-props
)))))
644 (defprop expr expr hook-type
)
645 (defprop mexpr expr hook-type
)
646 (defprop subr expr hook-type
)
647 (defprop lsubr expr hook-type
)
648 (defprop mfexpr
* macro hook-type
)
649 (defprop mfexpr
*s macro hook-type
)
651 (defun make-trace-hook (fun type handler
)
652 ;; Argument handling according to FUN's TYPE is already done
653 ;; elsewhere: HANDLER, meval...
654 (declare (ignore type
))
655 #'(lambda (&rest trace-args
)
656 (funcall handler fun trace-args
)))
658 (defun trace-apply (fun largs
)
659 (let ((prop (trace-fsymeval fun
))
660 (type (trace-type fun
))
661 (return-to-trace-handle nil
))
664 (mapply prop largs
"A traced function"))
670 (funcall prop
(car largs
))))))
674 (defmvar $trace_max_indent
15.
"max number of spaces it will go right" fixnum
)
676 (putprop '$trace_max_indent
'assign-mode-check
'assign
)
677 (putprop '$trace_max_indent
'$fixnum
'mode
)
679 (defun-prop (spaceout dimension
) (form result
)
680 (dimension-string (make-list (cadr form
) :initial-element
#\space
) result
))
682 (defun trace-mprint (&rest l
)
683 (mtell-open "~M" `((mtext) ((spaceout) ,(min $trace_max_indent trace-indent-level
)) ,@l
)))
685 (defun trace-print (form)
686 (do ((j (min $trace_max_indent trace-indent-level
) (1- j
)))
688 (write-char #\space
))
693 ;; 9:02pm Monday, 18 May 1981 -GJC
694 ;; A function benchmark facility using trace utilities.
695 ;; This provides medium accuracy, enough for most user needs.
697 (defmvar $timer
'((mlist)) "List of functions under active timetrace")
699 (defmspec $timer
(form)
700 (mlistcan-$all
#'macsyma-timer
(cdr form
) $timer
))
702 (defmspec $untimer
(form)
703 `((mlist) ,@(mapcan #'macsyma-untimer
(or (cdr form
) (cdr $timer
)))))
705 (defun micro-to-sec (runtime)
706 (mul runtime
(float (/ internal-time-units-per-second
)) '$sec
))
708 (defun micro-per-call-to-sec (runtime calls
)
709 (div (micro-to-sec runtime
)
710 (if (zerop calls
) 1 calls
)))
712 (defun timer-mlist (function calls runtime gctime
)
713 `((mlist simp
) ,function
714 ,(micro-per-call-to-sec (+ runtime gctime
) calls
)
716 ,(micro-to-sec runtime
)
717 ,(micro-to-sec gctime
)))
719 (defmspec $timer_info
(form)
720 (do ((l (or (cdr form
) (cdr $timer
))
728 ((mlist simp
) $function $time
//call $calls $runtime $gctime
)
730 ,(timer-mlist '$total total-calls total-runtime total-gctime
)))
732 ((fun-opr (getopr (car l
)))
733 (runtime ($get fun-opr
'$runtime
))
734 (gctime ($get fun-opr
'$gctime
))
735 (calls ($get fun-opr
'$calls
)))
737 (incf total-calls calls
)
738 (incf total-runtime runtime
)
739 (incf total-gctime gctime
)
740 (push (timer-mlist (car l
) calls runtime gctime
) v
)))))
742 (defun macsyma-timer (fun)
744 (macsyma-trace-sub fun
'timer-handler $timer
)
745 (let ((fun-opr (getopr fun
)))
746 ($put fun-opr
0 '$runtime
)
747 ($put fun-opr
0 '$gctime
)
748 ($put fun-opr
0 '$calls
))))
750 (defun macsyma-untimer (fun) (macsyma-untrace-sub fun
'timer-handler $timer
))
752 (defvar runtime-devalue
0)
753 (defvar gctime-devalue
0)
755 (defmvar $timer_devalue nil
756 "If true, then time spent inside calls to other timed functions is
757 subtracted from the timing figure for a function.")
759 (defun timer-handler (fun largs
)
760 ;; N.B. Doesn't even try to account for use of DYNAMIC CONTROL
761 ;; such as ERRSET ERROR and CATCH and THROW, as these are
762 ;; rare and the overhead for the unwind-protect is high.
763 (let ((runtime (get-internal-run-time))
764 (gctime (status gctime
))
765 (old-runtime-devalue runtime-devalue
)
766 (old-gctime-devalue gctime-devalue
))
767 (multiple-value-prog1 (trace-apply fun largs
)
768 (setq old-runtime-devalue
(- runtime-devalue old-runtime-devalue
))
769 (setq old-gctime-devalue
(- gctime-devalue old-gctime-devalue
))
770 (setq runtime
(- (get-internal-run-time) runtime old-runtime-devalue
))
771 (setq gctime
(- (status gctime
) gctime old-gctime-devalue
))
773 (incf runtime-devalue runtime
)
774 (incf gctime-devalue gctime
))
775 ($put fun
(+ ($get fun
'$runtime
) runtime
) '$runtime
)
776 ($put fun
(+ ($get fun
'$gctime
) gctime
) '$gctime
)
777 ($put fun
(1+ ($get fun
'$calls
)) '$calls
))))