1 ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancements. ;;;;;
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 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 (:compile-toplevel
:load-toplevel
:execute
)
175 (defmacro trace-p
(x)
177 (defmacro trace-type
(x)
178 `(mget ,x
'trace-type
))
179 (defmacro trace-level
(x)
180 `(mget ,x
'trace-level
))
181 (defmacro trace-options
(x)
182 `($get
,x
'$trace_options
))
183 (defmacro trace-oldfun
(x)
184 `(mget ,x
'trace-oldfun
)))
186 ;;; User interface functions.
188 (defmvar $trace
(list '(mlist))
189 "List of functions actively traced"
190 :properties
((assign 'neverset
)))
192 (defun mlistcan-$all
(fun llist default
)
193 "totally random utility function"
197 `((mlist) ,@(mapcan fun
198 (if (member (car llist
) '($all $functions
) :test
#'eq
)
201 (mapcar #'caar
(cdr $functions
)))
204 (defmspec $trace
(form)
205 (mlistcan-$all
#'macsyma-trace
(cdr form
) $trace
))
207 (defmfun $trace_it
(function)
208 `((mlist) ,@(macsyma-trace function
)))
210 (defmspec $untrace
(form)
211 `((mlist) ,@(mapcan #'macsyma-untrace
(or (cdr form
) (cdr $trace
)))))
213 (defmfun $untrace_it
(function)
214 `((mlist) ,@(macsyma-untrace function
)))
216 (defmspec $trace_options
(form)
217 (setf (trace-options (cadr form
))
218 `((mlist) ,@(cddr form
))))
220 ;;; System interface functions.
222 (defvar hard-to-trace
'(trace-handler listify args trace-apply
*apply mapply
))
224 ;; A list of functions called by the TRACE-HANDLEr at times when
225 ;; it cannot possibly shield itself from a continuation which would
226 ;; cause infinite recursion. We are assuming the best-case of
229 (defun macsyma-trace (fun)
230 (macsyma-trace-sub fun
'trace-handler $trace
))
232 (defun macsyma-trace-sub (fun handler ilist
&aux temp
)
233 (cond ((not (symbolp (setq fun
(getopr fun
))))
234 (mtell (intl:gettext
"trace: argument is apparently not a function or operator: ~M~%") fun
)
237 ;; Things which redefine should be expected to reset this
239 (if (not trace-allp
) (mtell (intl:gettext
"trace: function ~@:M is already traced.~%") fun
))
241 ((member fun hard-to-trace
:test
#'eq
)
242 (mtell (intl:gettext
"trace: ~@:M cannot be traced.~%") fun
)
244 ((not (setq temp
(car (macsyma-fsymeval fun
))))
245 (mtell (intl:gettext
"trace: ~@:M has no functional properties.~%") fun
)
247 ((member temp
'(mmacro translated-mmacro
) :test
#'eq
)
248 (mtell (intl:gettext
"trace: ~@:M is a macro, so it won't trace well; try 'macroexpand' to debug it.~%") fun
)
251 (put-trace-info fun temp ilist
)
252 (trace-fshadow fun temp
(make-trace-hook fun temp handler
))
255 (mtell (intl:gettext
"trace: ~@:M is an unknown type of function.~%") fun
)
258 (defvar trace-handling-stack
())
260 (defun macsyma-untrace (fun)
261 (macsyma-untrace-sub fun
'trace-handler $trace
))
263 (defun macsyma-untrace-sub (fun handler ilist
)
265 (cond ((not (symbolp (setq fun
(getopr fun
))))
266 (mtell (intl:gettext
"untrace: argument is apparently not a function or operator: ~M~%") fun
)
269 (mtell (intl:gettext
"untrace: ~@:M is not traced.~%") fun
)
272 (trace-unfshadow fun
(trace-type fun
))
273 (rem-trace-info fun ilist
)
275 (if (member fun trace-handling-stack
:test
#'eq
)
276 ;; yes, he has re-defined or untraced the function
277 ;; during the trace-handling application.
278 ;; This is not strange, in fact it happens all the
279 ;; time when the user is using the $ERRORCATCH option!
280 (macsyma-trace-sub fun handler ilist
))))
282 (defun put-trace-info (fun type ilist
)
283 (setf (trace-p fun
) fun
) ; needed for MEVAL at this time also.
284 (setf (trace-type fun
) type
)
285 ;; Pretty sure this next property assignment is clobbered by TRACE-FSHADOW,
286 ;; however, the assignment is conditional there, so I don't know 100%.
287 (setf (trace-oldfun fun
) (and (fboundp fun
) (symbol-function (or (get fun
'impl-name
) fun
))))
288 (let ((sym (gensym)))
289 (setf (symbol-value sym
) 0)
290 (setf (trace-level fun
) sym
))
291 (push fun
(cdr ilist
))
294 (defun rem-trace-info (fun ilist
)
295 (setf (trace-p fun
) nil
)
296 (or (member fun trace-handling-stack
:test
#'eq
)
297 (setf (trace-level fun
) nil
))
298 (setf (trace-type fun
) nil
)
299 (setq ilist
(delete fun ilist
:test
#'eq
))
302 ;; Placing the TRACE functional hook.
303 ;; Because the function properties in macsyma are used by the EDITOR, SAVE,
304 ;; and GRIND commands it is not possible to simply replace the function
305 ;; being traced with a hook and to store the old definition someplace.
306 ;; [We do know how to cons up machine-code hooks on the fly, so that
307 ;; is not stopping us].
310 ;; This data should be formalized somehow at the time of
311 ;; definition of the DEFining form.
313 (defprop subr expr shadow
)
314 (defprop lsubr expr shadow
)
315 (defprop expr expr shadow
)
316 (defprop mfexpr
*s mfexpr
* shadow
)
317 (defprop mfexpr
* mfexpr
* shadow
)
319 (defprop mexpr t mget
)
320 (defprop mexpr expr shadow
)
324 (maxima-error (intl:gettext
"GET!: property ~a of symbol ~a undefined.") y x
)))
326 (defun trace-fshadow (fun type value
)
327 (let ((shadow (get! type
'shadow
)))
328 (cond ((and (eq type
'mexpr
)
330 ; We're tracing an mexpr with special evaluation rules (mfexpr).
331 ; Let's put a Maxima lambda expression on the plist that calls
332 ; the trace hook. Then in the evaluator we can just have mlambda
333 ; do the work for us.
335 ; If there is not a rest argument in the mexpr's lambda list
336 ; then this newly-constructed lambda expression just does a
337 ; funcall. If there is a rest argument then it requires a
340 (let* ((lambda-list (cadr (mget fun
'mexpr
)))
341 (params (mparams lambda-list
)))
342 `((lambda) ,lambda-list
343 ,(if (mget fun
'mlexprp
)
344 (flet ((call-hook (restarg &rest nonrestargs
)
345 (apply value
(append nonrestargs
347 ; This is the mfexpr+mlexpr case (we have at
348 ; least one quoted arg and a rest arg).
350 ; The use of call-hook here is basically like
354 ; ((mlist) ,@(butlast params))
355 ; ,(car (last params))))
357 ; but faster. We just have to construct
358 ; things so simplifya doesn't barf on any
359 ; intermediate expressions.
360 `((funcall) ,#'call-hook
363 `((funcall) ,value
,@params
))))
365 ((member shadow
'(expr subr
) :test
#'eq
)
366 (setf (trace-oldfun fun
) (and (fboundp fun
) (symbol-function (or (get fun
'impl-name
) fun
))))
367 (setf (symbol-function (or (get fun
'impl-name
) fun
)) value
))
369 (setf (symbol-plist fun
) `(,shadow
,value
,@(symbol-plist fun
)))))))
371 (defun trace-unfshadow (fun type
)
372 ;; At this point, we know that FUN is traced.
373 (cond ((and (eq type
'mexpr
)
374 (safe-get fun
'mfexpr
))
375 (remprop fun
'mfexpr
))
376 ((member type
'(expr subr
) :test
#'eq
)
377 (let ((oldf (trace-oldfun fun
)))
378 (if (not (null oldf
))
379 (setf (symbol-function (or (get fun
'impl-name
) fun
)) oldf
)
381 (t (remprop fun
(get! type
'shadow
))
384 ;;--- trace-fsymeval :: find original function
385 ;; fun : a function which is being traced. The original definition may
386 ;; be hidden on the property list behind the shadow function.
388 (defun trace-fsymeval (fun)
390 (let ((type-of (trace-type fun
)))
391 (cond ((get type-of
'mget
)
392 (if (eq (get! type-of
'shadow
) type-of
)
393 (mget (cdr (mgetl fun
(list type-of
))) type-of
)
395 ((eq (get! type-of
'shadow
) 'expr
)
397 (t (if (eq (get! type-of
'shadow
) type-of
)
398 (cadr (getl (cdr (getl fun
`(,type-of
))) `(,type-of
)))
399 (get fun type-of
)))))
401 (merror "internal error: trace property for ~:@M went away without hook." fun
))))
403 ;;; The handling of a traced call.
405 (defvar trace-indent-level -
1)
407 (defmacro bind-sym
(symbol value . body
)
408 ;; is by far the best dynamic binding generally available.
409 `(progv (list ,symbol
)
413 ;; We really want to (BINDF (TRACE-LEVEL FUN) (1+ (TRACE-LEVEL FUN)) ...)
414 ;; (Think about PROGV and SETF and BINDF. If the trace object where
415 ;; a closure, then we want to fluid bind instance variables.)
417 (defmacro macsyma-errset
(form &aux
(ret (gensym)))
418 `(let ((errcatch (cons bindlist loclist
)) ,ret
)
419 (setq ,ret
(errset ,form
))
420 (or ,ret
(errlfun1 errcatch
))
423 (defvar predicate-arglist nil
)
425 (defvar return-to-trace-handle nil
)
427 (defun trace-handler (fun largs
)
428 (if (or return-to-trace-handle
429 (and (not (atom (car largs
)))
430 (not (atom (caar largs
)))
431 (eq (caaar largs
) '$untrace
)
432 (eq (cadar largs
) fun
)))
433 ;; We were called by the trace-handler or by $untrace and the function
434 ;; fun is to be untraced.
435 (trace-apply fun largs
)
436 (let ((trace-indent-level (1+ trace-indent-level
))
437 (return-to-trace-handle t
)
438 (trace-handling-stack (cons fun trace-handling-stack
))
439 (level-sym (trace-level fun
))
441 (setq level
(1+ (symbol-value level-sym
)))
442 (bind-sym level-sym level
447 (setq predicate-arglist
`(,level $enter
,fun
((mlist) ,@largs
)))
448 (setq largs
(trace-enter-break fun level largs
))
449 (trace-enter-print fun level largs
)
450 (cond ((trace-option-p fun
'$errorcatch
)
451 (setq ret-vals
(macsyma-errset (trace-apply fun largs
)))
452 (cond ((null ret-vals
)
453 (setq ret-vals
(trace-error-break fun level largs
))
454 (setq continuation
(car ret-vals
)
455 ret-vals
(cdr ret-vals
)))
457 (setq continuation
'exit
))))
459 (setq continuation
'exit
460 ret-vals
(multiple-value-list (trace-apply fun largs
)))))
463 (setq predicate-arglist
`(,level $exit
,fun
,(car ret-vals
)))
464 (setq ret-vals
(trace-exit-break fun level ret-vals
))
465 (trace-exit-print fun level
(car ret-vals
))
466 (return (values-list ret-vals
)))
468 (setq largs ret-vals
)
469 (mtell "TRACE-HANDLER: reapplying the function ~:@M~%" fun
))
471 (merror "~%TRACE-HANDLER: signaling 'maxima-error' for function ~:@M~%" fun
))))))))
474 ;; The (Trace-options function) access is not optimized to take place
475 ;; only once per trace-handle call. This is so that the user may change
476 ;; options during his break loops.
477 ;; Question: Should we bind return-to-trace-handle to NIL when we
478 ;; call the user's predicate? He has control over his own lossage.
480 (defmvar $trace_safety t
"This is subtle")
482 (defun trace-option-p (function keyword
)
484 (let ((options (trace-options function
)))
485 (cond ((null options
) nil
)
486 (($listp options
) (cdr options
))
488 (mtell "TRACE-OPTION-P: trace options for ~:@M not a list, so ignored.~%" function
)
493 (setq option
(car options
))
495 (if (eq option keyword
) (return t
)))
496 ((eq (caar option
) keyword
)
497 (let ((return-to-trace-handle $trace_safety
))
498 (return (mapply (cadr option
) predicate-arglist
499 "A trace option predicate")))))))
502 (defun trace-enter-print (fun lev largs
)
503 (let ((args (if (eq (trace-type fun
) 'mfexpr
*)
506 (if (not (trace-option-p fun
'$noprint
))
507 (let ((info (trace-option-p fun
'$info
)))
508 (cond ((trace-option-p fun
'$lisp_print
)
509 (trace-print `(,lev enter
,fun
,args
,@info
)))
512 (intl:gettext
" Enter ")
517 (if info info
""))))))))
519 (defun mopstringnam (x)
520 (maknam (mstring (getop x
))))
522 (defun trace-exit-print (fun lev ret-val
)
523 (if (not (trace-option-p fun
'$noprint
))
524 (let ((info (trace-option-p fun
'$info
)))
525 (cond ((trace-option-p fun
'$lisp_print
)
526 (trace-print `(,lev exit
,fun
,ret-val
,@info
)))
528 (trace-mprint lev
(intl:gettext
" Exit ") (mopstringnam fun
) " " ret-val
530 (if info info
"")))))))
532 (defmvar $trace_break_arg
'$trace_break_arg
533 "During trace Breakpoints bound to the argument list or return value")
535 (defun trace-enter-break (fun lev largs
)
536 (if (trace-option-p fun
'$break
)
537 (do ((return-to-trace-handle nil
)
538 ($trace_break_arg
`((mlist) ,@largs
)))(nil)
539 ($break
"Trace entering" fun
"level" lev
)
540 (cond (($listp $trace_break_arg
)
541 (return (cdr $trace_break_arg
)))
543 (mtell "TRACE-ENTER-BREAK: 'trace_break_arg' must be a list.~%"))))
546 (defun trace-exit-break (fun lev ret-vals
)
547 (if (trace-option-p fun
'$break
)
548 (let (($trace_break_arg
(car ret-vals
))
549 (return-to-trace-handle nil
))
550 ($break
"Trace exiting" fun
"level" lev
)
551 ; If trace_break_arg is the same (in the sense of eq) now
552 ; as when we started the breakpoint, then return all of the
553 ; original return values from the function. This means if
554 ; the user sets trace_break_arg but its value is eq to its
555 ; original value (which is only the primary return value
556 ; from the original function) then we still return the extra
557 ; values (if there are any). I (kjak) don't think this is
558 ; strictly correct, but we can try to fix it up later if
559 ; anyone ever really cares about this corner case involving
560 ; multiple return values, exit breakpoints and setting
561 ; trace_break_arg to the same value it started with.
562 (if (eq $trace_break_arg
(car ret-vals
))
564 (list $trace_break_arg
)))
567 (defun pred-$read
(predicate argl bad-message
)
569 (setq ans
(apply #'$read argl
))
570 (if (funcall predicate ans
) (return ans
))
571 (mtell "PRED-$READ: unacceptable input: ~A~%" bad-message
)))
573 (defun ask-choicep (llist &rest header-message
)
575 (dlist nil
(list* #\newline
`((marrow) ,j
,(car ilist
)) dlist
))
576 (ilist llist
(cdr ilist
)))
578 (setq dlist
(nconc header-message
(cons #\newline
(nreverse dlist
))))
579 (let ((upper (1- j
)))
580 (pred-$read
#'(lambda (val)
585 "please reply with an integer from the menu.")))))
587 ;; I GUESS ALL OF THE STRINGS IN THIS FUNCTION NEED TO BE GETTEXT'D TOO
588 ;; JUST CAN'T BRING MYSELF TO DO IT
590 (defun trace-error-break (fun level largs
)
591 (case (ask-choicep '("Signal an `maxima-error', i.e. punt?"
592 "Retry with same arguments?"
593 "Retry with new arguments?"
594 "Exit with user supplied value")
595 "Error during application of" (mopstringnam fun
)
597 #\newline
"Do you want to:")
603 (cons 'retry
(let (($trace_break_arg
`((mlist) ,@largs
)))
604 (cdr (pred-$read
'$listp
606 "Enter new argument list for"
608 "please enter a list.")))))
611 (cons 'exit
(list ($read
"Enter value to return"))))))
613 ;;; application dispatch, and the consing up of the trace hook.
615 (defun macsyma-fsymeval (fun)
616 (let ((try (macsyma-fsymeval-sub fun
)))
619 ($load
(get fun
'autoload
))
620 (setq try
(macsyma-fsymeval-sub fun
))
622 (mtell (intl:gettext
"trace: ~@:M has no functional properties after autoloading.~%")
627 (defun macsyma-fsymeval-sub (fun)
628 ;; The semantics of $TRANSRUN are herein taken from DESCRIBE,
629 ;; a careful reading of MEVAL1 reveals, well... I've promised to watch
630 ;; my language in these comments.
632 (let ((mprops (mgetl fun
'(mexpr mmacro
)))
633 (lprops (getl fun
'(translated-mmacro mfexpr
* mfexpr
*s
)))
634 (fcell-props (getl-lm-fcn-prop fun
'(subr lsubr expr macro
))))
636 ;; the default, so its really a waste to have looked for
637 ;; those mprops. Its better to fix the crock than to
638 ;; optimize this though!
639 (or lprops fcell-props mprops
))
641 (or mprops lprops fcell-props
)))))
643 (defprop expr expr hook-type
)
644 (defprop mexpr expr hook-type
)
645 (defprop subr expr hook-type
)
646 (defprop lsubr expr hook-type
)
647 (defprop mfexpr
* macro hook-type
)
648 (defprop mfexpr
*s macro hook-type
)
650 (defun make-trace-hook (fun type handler
)
651 ;; Argument handling according to FUN's TYPE is already done
652 ;; elsewhere: HANDLER, meval...
653 (declare (ignore type
))
654 #'(lambda (&rest trace-args
)
655 (funcall handler fun trace-args
)))
657 (defun trace-apply (fun largs
)
658 (let ((prop (trace-fsymeval fun
))
659 (type (trace-type fun
))
660 (return-to-trace-handle nil
))
663 (mapply prop largs
"A traced function"))
669 (funcall prop
(car largs
))))))
673 (defmvar $trace_max_indent
15.
674 "max number of spaces it will go right"
676 :properties
((assign 'assign-mode-check
)
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
))))