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 (setf (trace-oldfun fun
) (and (fboundp fun
) (symbol-function fun
)))
285 (let ((sym (gensym)))
286 (setf (symbol-value sym
) 0)
287 (setf (trace-level fun
) sym
))
288 (push fun
(cdr ilist
))
291 (defun rem-trace-info (fun ilist
)
292 (setf (trace-p fun
) nil
)
293 (or (member fun trace-handling-stack
:test
#'eq
)
294 (setf (trace-level fun
) nil
))
295 (setf (trace-type fun
) nil
)
296 (setq ilist
(delete fun ilist
:test
#'eq
))
299 ;; Placing the TRACE functional hook.
300 ;; Because the function properties in macsyma are used by the EDITOR, SAVE,
301 ;; and GRIND commands it is not possible to simply replace the function
302 ;; being traced with a hook and to store the old definition someplace.
303 ;; [We do know how to cons up machine-code hooks on the fly, so that
304 ;; is not stopping us].
307 ;; This data should be formalized somehow at the time of
308 ;; definition of the DEFining form.
310 (defprop subr expr shadow
)
311 (defprop lsubr expr shadow
)
312 (defprop expr expr shadow
)
313 (defprop mfexpr
*s mfexpr
* shadow
)
314 (defprop mfexpr
* mfexpr
* shadow
)
316 (defprop mexpr t mget
)
317 (defprop mexpr expr shadow
)
321 (maxima-error (intl:gettext
"GET!: property ~a of symbol ~a undefined.") y x
)))
323 (defun trace-fshadow (fun type value
)
324 (let ((shadow (get! type
'shadow
)))
325 (cond ((and (eq type
'mexpr
)
327 ; We're tracing an mexpr with special evaluation rules (mfexpr).
328 ; Let's put a Maxima lambda expression on the plist that calls
329 ; the trace hook. Then in the evaluator we can just have mlambda
330 ; do the work for us.
332 ; If there is not a rest argument in the mexpr's lambda list
333 ; then this newly-constructed lambda expression just does a
334 ; funcall. If there is a rest argument then it requires a
337 (let* ((lambda-list (cadr (mget fun
'mexpr
)))
338 (params (mparams lambda-list
)))
339 `((lambda) ,lambda-list
340 ,(if (mget fun
'mlexprp
)
341 (flet ((call-hook (restarg &rest nonrestargs
)
342 (apply value
(append nonrestargs
344 ; This is the mfexpr+mlexpr case (we have at
345 ; least one quoted arg and a rest arg).
347 ; The use of call-hook here is basically like
351 ; ((mlist) ,@(butlast params))
352 ; ,(car (last params))))
354 ; but faster. We just have to construct
355 ; things so simplifya doesn't barf on any
356 ; intermediate expressions.
357 `((funcall) ,#'call-hook
360 `((funcall) ,value
,@params
))))
362 ((member shadow
'(expr subr
) :test
#'eq
)
363 (setf (trace-oldfun fun
) (and (fboundp fun
) (symbol-function fun
)))
364 (setf (symbol-function fun
) value
))
366 (setf (symbol-plist fun
) `(,shadow
,value
,@(symbol-plist fun
)))))))
368 (defun trace-unfshadow (fun type
)
369 ;; At this point, we know that FUN is traced.
370 (cond ((and (eq type
'mexpr
)
371 (safe-get fun
'mfexpr
))
372 (remprop fun
'mfexpr
))
373 ((member type
'(expr subr
) :test
#'eq
)
374 (let ((oldf (trace-oldfun fun
)))
375 (if (not (null oldf
))
376 (setf (symbol-function fun
) oldf
)
378 (t (remprop fun
(get! type
'shadow
))
381 ;;--- trace-fsymeval :: find original function
382 ;; fun : a function which is being traced. The original definition may
383 ;; be hidden on the property list behind the shadow function.
385 (defun trace-fsymeval (fun)
387 (let ((type-of (trace-type fun
)))
388 (cond ((get type-of
'mget
)
389 (if (eq (get! type-of
'shadow
) type-of
)
390 (mget (cdr (mgetl fun
(list type-of
))) type-of
)
392 ((eq (get! type-of
'shadow
) 'expr
)
394 (t (if (eq (get! type-of
'shadow
) type-of
)
395 (cadr (getl (cdr (getl fun
`(,type-of
))) `(,type-of
)))
396 (get fun type-of
)))))
398 (merror "internal error: trace property for ~:@M went away without hook." fun
))))
400 ;;; The handling of a traced call.
402 (defvar trace-indent-level -
1)
404 (defmacro bind-sym
(symbol value . body
)
405 ;; is by far the best dynamic binding generally available.
406 `(progv (list ,symbol
)
410 ;; We really want to (BINDF (TRACE-LEVEL FUN) (1+ (TRACE-LEVEL FUN)) ...)
411 ;; (Think about PROGV and SETF and BINDF. If the trace object where
412 ;; a closure, then we want to fluid bind instance variables.)
414 (declare-top (special errcatch bindlist loclist
))
416 (defmacro macsyma-errset
(form &aux
(ret (gensym)))
417 `(let ((errcatch (cons bindlist loclist
)) ,ret
)
418 (setq ,ret
(errset ,form
))
419 (or ,ret
(errlfun1 errcatch
))
422 (defvar predicate-arglist nil
)
424 (defvar return-to-trace-handle nil
)
426 (defun trace-handler (fun largs
)
427 (if (or return-to-trace-handle
428 (and (not (atom (car largs
)))
429 (not (atom (caar largs
)))
430 (eq (caaar largs
) '$untrace
)
431 (eq (cadar largs
) fun
)))
432 ;; We were called by the trace-handler or by $untrace and the function
433 ;; fun is to be untraced.
434 (trace-apply fun largs
)
435 (let ((trace-indent-level (1+ trace-indent-level
))
436 (return-to-trace-handle t
)
437 (trace-handling-stack (cons fun trace-handling-stack
))
438 (level-sym (trace-level fun
))
440 (setq level
(1+ (symbol-value level-sym
)))
441 (bind-sym level-sym level
446 (setq predicate-arglist
`(,level $enter
,fun
((mlist) ,@largs
)))
447 (setq largs
(trace-enter-break fun level largs
))
448 (trace-enter-print fun level largs
)
449 (cond ((trace-option-p fun
'$errorcatch
)
450 (setq ret-vals
(macsyma-errset (trace-apply fun largs
)))
451 (cond ((null ret-vals
)
452 (setq ret-vals
(trace-error-break fun level largs
))
453 (setq continuation
(car ret-vals
)
454 ret-vals
(cdr ret-vals
)))
456 (setq continuation
'exit
))))
458 (setq continuation
'exit
459 ret-vals
(multiple-value-list (trace-apply fun largs
)))))
462 (setq predicate-arglist
`(,level $exit
,fun
,(car ret-vals
)))
463 (setq ret-vals
(trace-exit-break fun level ret-vals
))
464 (trace-exit-print fun level
(car ret-vals
))
465 (return (values-list ret-vals
)))
467 (setq largs ret-vals
)
468 (mtell "TRACE-HANDLER: reapplying the function ~:@M~%" fun
))
470 (merror "~%TRACE-HANDLER: signaling 'maxima-error' for function ~:@M~%" fun
))))))))
473 ;; The (Trace-options function) access is not optimized to take place
474 ;; only once per trace-handle call. This is so that the user may change
475 ;; options during his break loops.
476 ;; Question: Should we bind return-to-trace-handle to NIL when we
477 ;; call the user's predicate? He has control over his own lossage.
479 (defmvar $trace_safety t
"This is subtle")
481 (defun trace-option-p (function keyword
)
483 (let ((options (trace-options function
)))
484 (cond ((null options
) nil
)
485 (($listp options
) (cdr options
))
487 (mtell "TRACE-OPTION-P: trace options for ~:@M not a list, so ignored.~%" function
)
492 (setq option
(car options
))
494 (if (eq option keyword
) (return t
)))
495 ((eq (caar option
) keyword
)
496 (let ((return-to-trace-handle $trace_safety
))
497 (return (mapply (cadr option
) predicate-arglist
498 "A trace option predicate")))))))
501 (defun trace-enter-print (fun lev largs
)
502 (let ((args (if (eq (trace-type fun
) 'mfexpr
*)
505 (if (not (trace-option-p fun
'$noprint
))
506 (let ((info (trace-option-p fun
'$info
)))
507 (cond ((trace-option-p fun
'$lisp_print
)
508 (trace-print `(,lev enter
,fun
,args
,@info
)))
511 (intl:gettext
" Enter ")
516 (if info info
""))))))))
518 (defun mopstringnam (x)
519 (maknam (mstring (getop x
))))
521 (defun trace-exit-print (fun lev ret-val
)
522 (if (not (trace-option-p fun
'$noprint
))
523 (let ((info (trace-option-p fun
'$info
)))
524 (cond ((trace-option-p fun
'$lisp_print
)
525 (trace-print `(,lev exit
,fun
,ret-val
,@info
)))
527 (trace-mprint lev
(intl:gettext
" Exit ") (mopstringnam fun
) " " ret-val
529 (if info info
"")))))))
531 (defmvar $trace_break_arg
'$trace_break_arg
532 "During trace Breakpoints bound to the argument list or return value")
534 (defun trace-enter-break (fun lev largs
)
535 (if (trace-option-p fun
'$break
)
536 (do ((return-to-trace-handle nil
)
537 ($trace_break_arg
`((mlist) ,@largs
)))(nil)
538 ($break
"Trace entering" fun
"level" lev
)
539 (cond (($listp $trace_break_arg
)
540 (return (cdr $trace_break_arg
)))
542 (mtell "TRACE-ENTER-BREAK: 'trace_break_arg' must be a list.~%"))))
545 (defun trace-exit-break (fun lev ret-vals
)
546 (if (trace-option-p fun
'$break
)
547 (let (($trace_break_arg
(car ret-vals
))
548 (return-to-trace-handle nil
))
549 ($break
"Trace exiting" fun
"level" lev
)
550 ; If trace_break_arg is the same (in the sense of eq) now
551 ; as when we started the breakpoint, then return all of the
552 ; original return values from the function. This means if
553 ; the user sets trace_break_arg but its value is eq to its
554 ; original value (which is only the primary return value
555 ; from the original function) then we still return the extra
556 ; values (if there are any). I (kjak) don't think this is
557 ; strictly correct, but we can try to fix it up later if
558 ; anyone ever really cares about this corner case involving
559 ; multiple return values, exit breakpoints and setting
560 ; trace_break_arg to the same value it started with.
561 (if (eq $trace_break_arg
(car ret-vals
))
563 (list $trace_break_arg
)))
566 (defun pred-$read
(predicate argl bad-message
)
568 (setq ans
(apply #'$read argl
))
569 (if (funcall predicate ans
) (return ans
))
570 (mtell "PRED-$READ: unacceptable input: ~A~%" bad-message
)))
572 (defun ask-choicep (llist &rest header-message
)
574 (dlist nil
(list* #\newline
`((marrow) ,j
,(car ilist
)) dlist
))
575 (ilist llist
(cdr ilist
)))
577 (setq dlist
(nconc header-message
(cons #\newline
(nreverse dlist
))))
578 (let ((upper (1- j
)))
579 (pred-$read
#'(lambda (val)
584 "please reply with an integer from the menue.")))))
586 ;; I GUESS ALL OF THE STRINGS IN THIS FUNCTION NEED TO BE GETTEXT'D TOO
587 ;; JUST CAN'T BRING MYSELF TO DO IT
589 (defun trace-error-break (fun level largs
)
590 (case (ask-choicep '("Signal an `maxima-error', i.e. punt?"
591 "Retry with same arguments?"
592 "Retry with new arguments?"
593 "Exit with user supplied value")
594 "Error during application of" (mopstringnam fun
)
596 #\newline
"Do you want to:")
602 (cons 'retry
(let (($trace_break_arg
`((mlist) ,@largs
)))
603 (cdr (pred-$read
'$listp
605 "Enter new argument list for"
607 "please enter a list.")))))
610 (cons 'exit
(list ($read
"Enter value to return"))))))
612 ;;; application dispatch, and the consing up of the trace hook.
614 (defun macsyma-fsymeval (fun)
615 (let ((try (macsyma-fsymeval-sub fun
)))
618 (load-and-tell (get fun
'autoload
))
619 (setq try
(macsyma-fsymeval-sub fun
))
621 (mtell (intl:gettext
"trace: ~@:M has no functional properties after autoloading.~%")
626 (defun macsyma-fsymeval-sub (fun)
627 ;; The semantics of $TRANSRUN are herein taken from DESCRIBE,
628 ;; a careful reading of MEVAL1 reveals, well... I've promised to watch
629 ;; my language in these comments.
631 (let ((mprops (mgetl fun
'(mexpr mmacro
)))
632 (lprops (getl fun
'(translated-mmacro mfexpr
* mfexpr
*s
)))
633 (fcell-props (getl-lm-fcn-prop fun
'(subr lsubr expr macro
))))
635 ;; the default, so its really a waste to have looked for
636 ;; those mprops. Its better to fix the crock than to
637 ;; optimize this though!
638 (or lprops fcell-props mprops
))
640 (or mprops lprops fcell-props
)))))
642 (defprop expr expr hook-type
)
643 (defprop mexpr expr hook-type
)
644 (defprop subr expr hook-type
)
645 (defprop lsubr expr hook-type
)
646 (defprop mfexpr
* macro hook-type
)
647 (defprop mfexpr
*s macro hook-type
)
649 (defun make-trace-hook (fun type handler
)
650 ;; Argument handling according to FUN's TYPE is already done
651 ;; elsewhere: HANDLER, meval...
652 (declare (ignore type
))
653 #'(lambda (&rest trace-args
)
654 (funcall handler fun trace-args
)))
656 (defmacro trace-setup-call
(prop fun type
)
657 (declare (ignore fun type
))
658 `(setf (symbol-function 'the-trace-apply-hack
) ,prop
))
660 (defun trace-apply (fun largs
)
661 (let ((prop (trace-fsymeval fun
))
662 (type (trace-type fun
))
663 (return-to-trace-handle nil
))
666 (mapply prop largs
"A traced function"))
670 (setf (symbol-plist 'the-trace-apply-hack
) (list type prop
))
671 (apply (second (getl 'the-trace-apply-hack
'(subr lsubr
))) largs
))
673 (funcall prop
(car largs
))))))
677 (defmvar $trace_max_indent
15.
"max number of spaces it will go right" fixnum
)
679 (putprop '$trace_max_indent
'assign-mode-check
'assign
)
680 (putprop '$trace_max_indent
'$fixnum
'mode
)
682 (defun-prop (spaceout dimension
) (form result
)
683 (dimension-string (make-list (cadr form
) :initial-element
#\space
) result
))
685 (defun trace-mprint (&rest l
)
686 (mtell-open "~M" `((mtext) ((spaceout) ,(min $trace_max_indent trace-indent-level
)) ,@l
)))
688 (defun trace-print (form)
689 (do ((j (min $trace_max_indent trace-indent-level
) (1- j
)))
691 (write-char #\space
))
696 ;; 9:02pm Monday, 18 May 1981 -GJC
697 ;; A function benchmark facility using trace utilities.
698 ;; This provides medium accuracy, enough for most user needs.
700 (defmvar $timer
'((mlist)) "List of functions under active timetrace")
702 (defmspec $timer
(form)
703 (mlistcan-$all
#'macsyma-timer
(cdr form
) $timer
))
705 (defmspec $untimer
(form)
706 `((mlist) ,@(mapcan #'macsyma-untimer
(or (cdr form
) (cdr $timer
)))))
708 (defun micro-to-sec (runtime)
709 (mul runtime
(float (/ internal-time-units-per-second
)) '$sec
))
711 (defun micro-per-call-to-sec (runtime calls
)
712 (div (micro-to-sec runtime
)
713 (if (zerop calls
) 1 calls
)))
715 (defun timer-mlist (function calls runtime gctime
)
716 `((mlist simp
) ,function
717 ,(micro-per-call-to-sec (+ runtime gctime
) calls
)
719 ,(micro-to-sec runtime
)
720 ,(micro-to-sec gctime
)))
722 (defmspec $timer_info
(form)
723 (do ((l (or (cdr form
) (cdr $timer
))
731 ((mlist simp
) $function $time
//call $calls $runtime $gctime
)
733 ,(timer-mlist '$total total-calls total-runtime total-gctime
)))
735 ((fun-opr (getopr (car l
)))
736 (runtime ($get fun-opr
'$runtime
))
737 (gctime ($get fun-opr
'$gctime
))
738 (calls ($get fun-opr
'$calls
)))
740 (incf total-calls calls
)
741 (incf total-runtime runtime
)
742 (incf total-gctime gctime
)
743 (push (timer-mlist (car l
) calls runtime gctime
) v
)))))
745 (defun macsyma-timer (fun)
747 (macsyma-trace-sub fun
'timer-handler $timer
)
748 (let ((fun-opr (getopr fun
)))
749 ($put fun-opr
0 '$runtime
)
750 ($put fun-opr
0 '$gctime
)
751 ($put fun-opr
0 '$calls
))))
753 (defun macsyma-untimer (fun) (macsyma-untrace-sub fun
'timer-handler $timer
))
755 (defvar runtime-devalue
0)
756 (defvar gctime-devalue
0)
758 (defmvar $timer_devalue nil
759 "If true, then time spent inside calls to other timed functions is
760 subtracted from the timing figure for a function.")
762 (defun timer-handler (fun largs
)
763 ;; N.B. Doesn't even try to account for use of DYNAMIC CONTROL
764 ;; such as ERRSET ERROR and CATCH and THROW, as these are
765 ;; rare and the overhead for the unwind-protect is high.
766 (let ((runtime (get-internal-run-time))
767 (gctime (status gctime
))
768 (old-runtime-devalue runtime-devalue
)
769 (old-gctime-devalue gctime-devalue
))
770 (multiple-value-prog1 (trace-apply fun largs
)
771 (setq old-runtime-devalue
(- runtime-devalue old-runtime-devalue
))
772 (setq old-gctime-devalue
(- gctime-devalue old-gctime-devalue
))
773 (setq runtime
(- (get-internal-run-time) runtime old-runtime-devalue
))
774 (setq gctime
(- (status gctime
) gctime old-gctime-devalue
))
776 (incf runtime-devalue runtime
)
777 (incf gctime-devalue gctime
))
778 ($put fun
(+ ($get fun
'$runtime
) runtime
) '$runtime
)
779 ($put fun
(+ ($get fun
'$gctime
) gctime
) '$gctime
)
780 ($put fun
(1+ ($get fun
'$calls
)) '$calls
))))