display_argument_list_.pl1 10/24/88 1638.0r w 10/24/88 1400.2 115011 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-03-13,GWMay), approve(86-04-16,MCR7373), audit(86-04-29,LJAdams), install(86-05-01,MR12.0-1051): Changed to reference entry_desc_info_version_2 constant. 2) change(86-11-19,DGHowe), approve(86-11-19,MCR7583), audit(86-11-24,JRGray), install(86-12-09,MR12.0-1238): Changed to print out command_name. Modified to refer to command_name_arglist instead of arg_list. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */ display_argument_list_: procedure (Iocb, Amup, Framep, Argp, Entryp, Farg, Larg, Lmarg); /* This program is an adaptation of Steve Webber's list_arg_ routine from db, for use by trace_stack_. */ /* rewritten 8/10/81 by Melanie Weaver to use arithmetic_to_ascii_ */ /* Adapted from list_frame_args_ May 1982 by C. Hornig */ /* modified 7/12/83 by Jeffrey D. Ives to not print a warning if a packed arg is passed to an unpacked parm. */ /* modified 9/05/84 by Jeffrey D. Ives to use get_entry_arg_descs_$info, use "RET VAL" before a return value, and handle the returns (char|bit|area (*)) case. */ dcl Amup ptr parameter; /* unused */ dcl Framep ptr parameter; dcl Argp ptr parameter; dcl Entryp ptr parameter; dcl (Farg, Larg) fixed bin parameter; dcl Lmarg fixed bin parameter; dcl Iocb ptr parameter; dcl (addr, addrel, character, hbound, lbound, min, null, substr, max, verify, unspec) builtin; dcl cleanup condition; dcl argp ptr; dcl ep ptr; dcl ap ptr; /* ptr to arglist. */ dcl strp ptr; dcl tp ptr; dcl xdesc (64) ptr; dcl (j, k) fixed bin; dcl (min_arg, max_arg, type, xtype) fixed bin; dcl (no_args, no_desc, strl, ndims, scale) fixed bin; dcl (xstrl, xndims, xscale, xnargs) fixed bin; dcl ec fixed bin (35); dcl arg_id char (7); dcl (ttype, xttype) char (40); dcl ascii_representation char (132) varying; dcl (packed, xpacked) bit (1) aligned; dcl begin_block_entries (2) bit (36) aligned internal static options (constant) init ("000614272100"b3 /* tsp2 pr0|614 */, "001376272100"b3 /* tsp2 pr0|1376 */); dcl condition_ entry (char (*), entry); dcl get_entry_arg_descs_$info entry (ptr, fixed bin, (*) ptr, ptr, fixed bin (35)); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin); dcl interpret_ptr_ entry (ptr, ptr, ptr); dcl ioa_$ioa_switch entry options (variable); dcl ioa_$ioa_switch_nnl entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl arithmetic_to_ascii_ entry (ptr, fixed bin, bit (1) aligned, fixed bin, fixed bin, char (132) varying); dcl display_file_value_ entry (ptr, file, fixed bin (35)); dcl based_ptr ptr based; dcl packptr ptr based unaligned; dcl fword (4) fixed bin (35) based (argp); dcl bcs char (100) based (argp); dcl char_string char (strl) based (argp); dcl based_bit bit (36) aligned based; dcl bit_string bit (strl) based (argp); dcl based_file file based; dcl 1 edi like entry_desc_info aligned; dcl 1 label_variable based (argp) aligned, 2 ptr ptr, 2 stack ptr; dcl LEGAL char (96) static options (constant) init /* Printables except PAD, but with BS */ ( " !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"); %page; sp = Framep; ep = Entryp; ap = Argp; if ep = null () then ep = stack_frame.entry_ptr; if ap = null () then ap = stack_frame.arg_ptr; if ap = null () then do; if ep ^= null () then do j = 1 to hbound (begin_block_entries, 1); if addrel (ep, 1) -> based_bit = begin_block_entries (j) then do; call ioa_$ioa_switch (Iocb, "^vxThis is a begin block. It has no argument list.", Lmarg); return; end; end; call ioa_$ioa_switch (Iocb, "^vxNo argument list.", Lmarg); return; end; strp = addr (strbuf); no_args = ap -> arg_list.arg_count; /* get the number of arguments */ no_desc = ap -> arg_list.desc_count; /* and the number of descriptors */ if (ap -> command_name_arglist.mbz ^= ""b) | ((ap -> command_name_arglist.call_type ^= 4) & (ap -> command_name_arglist.call_type ^= 8)) | ((no_desc ^= 0) & (no_desc ^= no_args)) then do; call ioa_$ioa_switch (Iocb, "^vxArgument list header invalid.", Lmarg); return; end; entry_desc_info_ptr = addr (edi); unspec (entry_desc_info) = ""b; entry_desc_info.version = entry_desc_info_version_2; call get_entry_arg_descs_$info (ep, xnargs, xdesc, entry_desc_info_ptr, ec); if (xnargs > 0) & (xnargs ^= no_args) then call ioa_$ioa_switch (Iocb, "^vxWarning: ^d arguments expected, ^d supplied.", Lmarg, xnargs, no_args); if no_args = 0 then do; /* check for no arguments */ call ioa_$ioa_switch (Iocb, "^vxNo arguments.", Lmarg); return; end; /* check and see if the command name is available */ if (ap -> command_name_arglist.has_command_name) then do; argp = ap -> command_name_arglist.name.command_name_ptr; strl = ap -> command_name_arglist.name.command_name_length; if strl > 0 then call ioa_$ioa_switch (Iocb, "^vxCommand name: ^a", Lmarg, char_string); end; if no_args > 64 then call ioa_$ioa_switch (Iocb, "^vxOnly first 64 args of ^d will be listed.", Lmarg, no_args); min_arg = max (1, Farg); /* print out all arguments */ max_arg = min (Larg, no_args, 64); call condition_ ("any_other", intproc); on cleanup ; %page; do j = min_arg to max_arg; /* loop through the desired number of args */ argp = ap -> command_name_arglist.arg_ptrs (j); /* get pointer to the argument */ type, xtype = -1; /* full word octal */ packed, xpacked = "0"b; ndims, xndims = 0; strl, xstrl = 0; scale, xscale = 0; if entry_desc_info.flags.function & j = xnargs then arg_id = "RET VAL"; else call ioa_$rsnnl ("ARG ^3d", arg_id, k, j); if xnargs >= j & xdesc (j) ^= null () then do; /* Do we know what this arg shd be? */ call decode_descriptor_ (xdesc (j), 0, xtype, xpacked, xndims, xstrl, xscale); end; if arg_id = "RET VAL" & xstrl = 16777215 then argp = argp -> based_ptr; /* returns (char|bit|area (*)) case */ if no_desc ^= 0 then do; /* if we have descriptors, look at them */ call decode_descriptor_ (ap, j, type, packed, ndims, strl, scale); if xnargs >= j & xdesc (j) ^= null () then do; /* Yes. We know what this arg shd be. */ if xtype ^= type then do; if type >= lbound (data_type_info_$info, 1) & type <= hbound (data_type_info_$info, 1) then ttype = type_name (type); else call ioa_$rsnnl ("type ^d", ttype, k, type); if xtype >= lbound (data_type_info_$info, 1) & xtype <= hbound (data_type_info_$info, 1) then xttype = type_name (xtype); else call ioa_$rsnnl ("type ^d", xttype, k, xtype); call ioa_$ioa_switch (Iocb, "^vxWarning: ^a is ^a, but it should be ^a.", Lmarg, arg_id, ttype, xttype); end; if xpacked ^= packed /* Check that packed attributes match */ then do; if xpacked then do; if xtype ^= char_dtype then call ioa_$ioa_switch (Iocb, "^vxWarning: ^a is unpacked, but it should be packed.", Lmarg, arg_id); end; else call ioa_$ioa_switch (Iocb, "^vxWarning: ^a is packed, but it should be unpacked.", Lmarg, arg_id); end; if xndims ^= ndims then call ioa_$ioa_switch (Iocb, "^vxWarning: ^a has ^d dimensions, but it should have ^d.", Lmarg, arg_id, ndims, xndims); if xstrl ^= strl then if xtype < pointer_dtype then call ioa_$ioa_switch (Iocb, "^vxWarning: ^a has a precision of ^d, but it should be ^d.", Lmarg, arg_id, strl, xstrl); else if xstrl ^= 16777215 then /* No fuss abt char (*) */ call ioa_$ioa_switch (Iocb, "^vxWarning: ^a has a length of ^d, but it should be ^d.", Lmarg, arg_id, strl, xstrl); if xscale ^= scale then call ioa_$ioa_switch (Iocb, "^vxWarning: ^a has a scale of ^d, but it should be ^d.", Lmarg, arg_id, scale, xscale); end; end; else if xnargs >= j then do; /* Callee might have descriptors for args. */ if xdesc (j) = null then go to guess; /* .. and then again he might not. */ call decode_descriptor_ (xdesc (j), 0, type, packed, ndims, strl, scale); end; else do; /* try to find out what type by heuristics */ guess: if argp -> its.its_mod = ITS_MODIFIER then type = pointer_dtype; /* assume pointer */ else do; strl = verify (bcs, LEGAL) - 1; /* Scan for last legal char in string. */ if strl < 0 then strl = 100; /* If all legal, print first 100. */ if strl >= 2 then type = char_dtype; else strl = 0; end; end; if /* case */ type = -1 then call ioa_$ioa_switch (Iocb, "^vx^a: ^w", Lmarg, arg_id, fword (1)); /* no descriptor; print full word octal */ else if type < lbound (data_type_info_$info, 1) | type > hbound (data_type_info_$info, 1) then call ioa_$ioa_switch (Iocb, "^vx^a: (bad type ^d at ^p) ^w", Lmarg, arg_id, type, argp, fword (1)); else if data_type_info_$info (type).arithmetic then do; call arithmetic_to_ascii_ (argp, type, packed, strl, scale, ascii_representation); call ioa_$ioa_switch (Iocb, "^vx^a: ^a", Lmarg, arg_id, ascii_representation); end; else if type = pointer_dtype then do; /* Pointer */ if packed then do; /* packed ptr */ tp = argp -> packptr; go to pptr; end; if argp -> its.its_mod = ITS_MODIFIER then do; tp = argp -> based_ptr; pptr: call interpret_ptr_ (tp, null (), strp); call ioa_$ioa_switch (Iocb, "^vx^a: ^p ^a^a|^a ^a", Lmarg, arg_id, tp, struc.segment, struc.entryn, struc.offset, struc.comment); end; else call ioa_$ioa_switch (Iocb, "^vx^a: ^w ^w", Lmarg, arg_id, fword (1), fword (2)); end; else if type = offset_dtype /* Offset */ then call ioa_$ioa_switch (Iocb, "^vx^a: ^w", Lmarg, arg_id, fword (1)); else if type = label_dtype | type = entry_dtype /* Label, Entry */ then do; call interpret_ptr_ (argp -> label_variable.ptr, argp -> label_variable.stack, strp); call ioa_$ioa_switch (Iocb, "^vx^a: ^p, ^p ^a^a|^a ^a", Lmarg, arg_id, label_variable.ptr, label_variable.stack, struc.segment, struc.entryn, struc.offset, struc.comment); end; else if type = bit_dtype | type = varying_bit_dtype /* Bit string */ then do; if type = varying_bit_dtype then strl = addrel (argp, -1) -> fword (1); if bit_string ^= ""b then ascii_representation = """" || character (substr (bit_string, 1, min (strl, 72))) || """b"; else call ioa_$rsnnl ("(^d)""0""b", ascii_representation, 0, strl); call ioa_$ioa_switch (Iocb, "^vx^a: ^a", Lmarg, arg_id, ascii_representation); end; else if type = char_dtype | type = varying_char_dtype /* Character string */ then do; if type = varying_char_dtype then strl = min (80, max (addrel (argp, -1) -> fword (1), 0)); call ioa_$ioa_switch (Iocb, "^vx^a: ""^va""", Lmarg, arg_id, strl, char_string); end; else if type = file_dtype /* File */ then do; call ioa_$ioa_switch_nnl (Iocb, "^vx^a: ", Lmarg, arg_id); call display_file_value_ (Iocb, argp -> based_file, ec); call ioa_$ioa_switch (Iocb, "(file at ^p)", argp); end; else call ioa_$ioa_switch (Iocb, "^vx^a: (^a at ^p) ^w", Lmarg, arg_id, type_name (type), argp, fword (1)); if ndims > 0 then call ioa_$ioa_switch (Iocb, "^-^vx(^d-dim array)", Lmarg, ndims); skiparg: end; return; %page; intproc: procedure (mcp, cname, cop, infop, cont); dcl (mcp, cop, infop) ptr, cname char (*), cont bit (1); if (cname = "program_interrupt") | (cname = "finish") | (cname = "quit") then do; cont = "1"b; return; end; if infop ^= null () then if infop -> condition_info_header.action_flags.quiet_restart then return; call ioa_$ioa_switch (Iocb, "^vx^a not accessible. - ^a", Lmarg, arg_id, cname); go to skiparg; end; %page; %include arg_list; %include entry_desc_info; %include stack_frame; %include interpret_ptr_struc; %include its; %include data_type_info_; %include condition_info_header; %include std_descriptor_types; %include probe_data_type_names; end display_argument_list_;  trace.pl1 01/11/85 1045.4rew 01/11/85 1034.9 252351 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This is the command interface to the trace facility. Initial Version: 25 February 1970 by BLW Modified many times. Completely rewritten: May 1984 by Jeffrey D. Ives. */ /* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */ %page; trace: procedure options (variable); /* DISABLE TRACE_CATCH_ */ transaction_id = clock (); on cleanup status = trace_$transaction_end (transaction_id); /* Disregard nonstandard use of status. */ if ^trace_$transaction_begin (transaction_id) /* Temporarily disables trace_catch_. */ then do; call com_err_ (code, ME, "There seems to be an incomplete invocation of trace, watch, or trace_meters still on the stack. Try the release command."); return; end; /* SET UP A SUB_ERROR_ CONDITION HANDLER */ call condition_ ("sub_error_", SUB_ERROR_HANDLER); /* SET DEFAULT ACTIONS */ set_defaults = "0"b; add_remove_action = ""; on_off_action = ""; parameters = "0"b; print_buffer = 0; status = "0"b; /* READ THE ARGUMENTS */ call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, ME); go to TRANSACTION_END; end; arg_idx = 1; ARGUMENT_LOOP: do while (arg_idx <= arg_count); call cu_$arg_ptr (arg_idx, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, ME); go to TRANSACTION_END; end; if length (arg) = 0 then do; call com_err_ (code, ME, "A null argument was found where an entrypoint was expected."); go to TRANSACTION_END; end; if substr (arg, 1, 1) ^= "-" then ENTRYPOINTS_ARGUMENT: do; call CHECK_NEXT_ARG (arg, 256, "trace", "entrypoints", " control_args"); call trace_$specify_entrypoints ((arg), null ()); arg_idx = arg_idx + 1; end ENTRYPOINTS_ARGUMENT; else CONTROL_ARGUMENT: do; if arg_idx + 1 > arg_count then next_arg_ptr = null (); else do; call cu_$arg_ptr (arg_idx + 1, next_arg_ptr, next_arg_len, code); if code ^= 0 then do; call com_err_ (code, ME); go to TRANSACTION_END; end; if length (next_arg) > 0 then if substr (next_arg, 1, 1) = "-" then next_arg_ptr = null (); end; if arg = "-add" /* -add */ then do; add_remove_action = "add"; arg_idx = arg_idx + 1; end; else if arg = "-alm" /* -alm on|off */ then do; call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", ""); call trace_$set_alm (trace_$cv_onoff_to_bit ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-arguments" | arg = "-ag" | arg = "-argument" | arg = "-args" | arg = "-arg" | arg = "-ags" /* -arguments in|out|on|off, -ag in|out|on|off */ then do; call CHECK_NEXT_ARG (next_arg, 8, arg, "in|out|on|off", ""); call trace_$set_arguments (trace_$cv_inout_to_bits ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-automatic" | arg = "-auto" /* -automatic on|off, -auto on|off */ then do; call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", ""); call trace_$set_automatic (trace_$cv_onoff_to_bit ((next_arg))); call trace_$set_signals (trace_$cv_onoff_to_bit ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-brief" | arg = "-bf" /* -brief, -bf */ then do; call trace_$set_long ("0"b); arg_idx = arg_idx + 1; end; else if arg = "-buffer" | arg = "-buf" | arg = "-buff" /* -buffer on|off, -buf on|off */ then do; call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", ""); call trace_$set_buffer (trace_$cv_onoff_to_bit ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-calibrate" /* -calibrate on|off */ then do; call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", ""); call trace_$set_calibrate (trace_$cv_onoff_to_bit ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-call" /* -call COMMAND-LINE */ then do; call CHECK_NEXT_ARG (next_arg, 256, arg, "COMMAND-LINE", " (if CL contains spaces, it must be quoted)"); call trace_$set_call ((next_arg)); arg_idx = arg_idx + 2; end; else if arg = "-disable" | arg = "-disa" | arg = "-dis" /* -disable, -disa */ then do; call trace_$set_enabled ("0"b); arg_idx = arg_idx + 1; end; else if arg = "-enable" | arg = "-ena" | arg = "-en" /* -enable, -ena */ then do; call trace_$set_enabled ("1"b); arg_idx = arg_idx + 1; end; else if arg = "-every" | arg = "-ev" /* -every N, -ev N */ then do; call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)"); call trace_$set_every (trace_$cv_n_to_number ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-first" | arg = "-ft" /* -first N, -ft N */ then do; call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)"); call trace_$set_first (trace_$cv_n_to_number ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-high" /* -high N */ then do; call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)"); call trace_$set_high (trace_$cv_n_to_number ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-last" | arg = "-lt" /* -last N, -lt N */ then do; call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)"); call trace_$set_last (trace_$cv_n_to_number ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-long" | arg = "-lg" /* -long, -lg */ then do; call trace_$set_long ("1"b); arg_idx = arg_idx + 1; end; else if arg = "-loud" /* -loud */ then do; call trace_$set_loud ("1"b); arg_idx = arg_idx + 1; end; else if arg = "-low" /* -low N */ then do; call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)"); call trace_$set_low (trace_$cv_n_to_number ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-meter" | arg = "-mt" | arg = "-meters" | arg = "-mts" /* -meter on|off, -mt on|off */ then do; call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", ""); call trace_$set_meter (trace_$cv_onoff_to_bit ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-new_high" /* -new_high on|off */ then do; call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", ""); call trace_$set_new_high (trace_$cv_onoff_to_bit ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-no_alm" /* -no_alm */ then do; call trace_$set_alm ("0"b); arg_idx = arg_idx + 1; end; else if arg = "-no_arguments" | arg = "-nag" | arg = "-no_argument" | arg = "-nargs" | arg = "-narg" | arg = "-nags" /* -no_arguments, -nag */ then do; call trace_$set_arguments ("00"b); arg_idx = arg_idx + 1; end; else if arg = "-no_automatic" | arg = "-nauto" /* -no_automatic, -nauto */ then do; call trace_$set_automatic ("0"b); call trace_$set_signals ("0"b); arg_idx = arg_idx + 1; end; else if arg = "-no_buffer" | arg = "-nbuf" | arg = "-nbuff" /* -no_buffer, -nbuf */ then do; call trace_$set_buffer ("0"b); arg_idx = arg_idx + 1; end; else if arg = "-no_calibrate" /* -no_calibrate */ then do; call trace_$set_calibrate ("0"b); arg_idx = arg_idx + 1; end; else if arg = "-no_call" /* -no_call */ then do; call trace_$set_call (""); arg_idx = arg_idx + 1; end; else if arg = "-no_every" | arg = "-nev" /* -no_every, -nev */ then do; call trace_$set_every (0); arg_idx = arg_idx + 1; end; else if arg = "-no_first" | arg = "-nft" /* -no_first, -nft */ then do; call trace_$set_first (0); arg_idx = arg_idx + 1; end; else if arg = "-no_high" /* -no_high */ then do; call trace_$set_high (0); arg_idx = arg_idx + 1; end; else if arg = "-no_last" | arg = "-nlt" /* -no_last, -nlt */ then do; call trace_$set_last (0); arg_idx = arg_idx + 1; end; else if arg = "-no_low" /* -no_low */ then do; call trace_$set_low (0); arg_idx = arg_idx + 1; end; else if arg = "-no_meter" | arg = "-nmt" | arg = "-no_meters" | arg = "-nmts" /* -no_meter, -nmt */ then do; call trace_$set_meter ("0"b); arg_idx = arg_idx + 1; end; else if arg = "-no_new_high" /* -no_new_high */ then do; call trace_$set_new_high ("0"b); arg_idx = arg_idx + 1; end; else if arg = "-no_output_file" | arg = "-nof" /* -no_output_file, -nof */ then do; call trace_$set_output_switch (trace_$cv_file_path_to_osw ("", null ())); arg_idx = arg_idx + 1; end; else if arg = "-no_output_switch" | arg = "-nosw" /* -no_output_switch, -nosw */ then do; call trace_$set_output_switch (trace_$cv_stream_name_to_osw ("")); arg_idx = arg_idx + 1; end; else if arg = "-no_signals" | arg = "-nsig" | arg = "-no_signal" | arg = "-nsigs" /* -no_signals, -nsig */ then do; call trace_$set_signals ("0"b); arg_idx = arg_idx + 1; end; else if arg = "-no_stop" | arg = "-nsp" /* -no_stop, -nsp */ then do; call trace_$set_stop ("00"b); arg_idx = arg_idx + 1; end; else if arg = "-no_stop_every" | arg = "-nspev" /* -no_stop_every, -nspev */ then do; call trace_$set_every (0); arg_idx = arg_idx + 1; end; else if arg = "-no_stop_low" | arg = "-nsplow" /* -no_stop_low, -nsplow */ then do; call trace_$set_stop_low (0); arg_idx = arg_idx + 1; end; else if arg = "-no_stop_proc" | arg = "-nspp" /* -no_stop_proc, -nspp */ then do; call trace_$set_stop_proc (trace_$cv_entry_name_to_spp ("", null ())); arg_idx = arg_idx + 1; end; else if arg = "-no_trace" /* -no_trace */ then do; call trace_$set_trace ("00"b); arg_idx = arg_idx + 1; end; else if arg = "-off" /* -off */ then do; on_off_action = "off"; arg_idx = arg_idx + 1; end; else if arg = "-on" /* -on */ then do; on_off_action = "on"; arg_idx = arg_idx + 1; end; else if arg = "-output_file" | arg = "-of" /* -output_file PATH, -of PATH */ then do; call CHECK_NEXT_ARG (next_arg, 256, arg, "PATH", ""); call trace_$set_output_switch (trace_$cv_file_path_to_osw ((next_arg), null ())); arg_idx = arg_idx + 2; end; else if arg = "-output_switch" | arg = "-osw" /* -output_switch SWITCH, -osw SWITCH */ then do; call CHECK_NEXT_ARG (next_arg, 32, arg, "SWITCH", " (SWITCH must be open for stream output)"); call trace_$set_output_switch (trace_$cv_stream_name_to_osw ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-parameters" | arg = "-pm" | arg = "-parameter" | arg = "-pms" | arg = "-parm" | arg = "-parms" /* -parameters, -pm */ then do; parameters = "1"b; arg_idx = arg_idx + 1; end; else if arg = "-print_buffer" | arg = "-prbuf" | arg = "-prbuff" /* -print_buffer N, -prbuf N */ then do; call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)"); print_buffer = trace_$cv_n_to_number ((next_arg)); arg_idx = arg_idx + 2; end; else if arg = "-quiet" /* -quiet */ then do; call trace_$set_loud ("0"b); arg_idx = arg_idx + 1; end; else if arg = "-remove" | arg = "-rm" /* -remove, -rm */ then do; add_remove_action = "remove"; arg_idx = arg_idx + 1; end; else if arg = "-set_defaults" | arg = "-sdft" | arg = "-set_default" | arg = "-sdf" | arg = "-sdfs" | arg = "-sdfts" /* -set_defaults, -sdft */ then do; set_defaults = "1"b; arg_idx = arg_idx + 1; end; else if arg = "-signals" | arg = "-sig" | arg = "-signal" | arg = "-sigs" /* -signals on|off, -sig on|off */ then do; call CHECK_NEXT_ARG (next_arg, 8, arg, "on|off", ""); call trace_$set_signals (trace_$cv_onoff_to_bit ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-status" | arg = "-st" /* -status, -st */ then do; status = "1"b; arg_idx = arg_idx + 1; end; else if arg = "-stop" | arg = "-sp" /* -stop in|out|on|off, -sp in|out|on|off */ then do; call CHECK_NEXT_ARG (next_arg, 8, arg, "in|out|on|off", ""); call trace_$set_stop (trace_$cv_inout_to_bits ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-stop_every" | arg = "-spev" /* -stop_every N, -spev N */ then do; call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)"); call trace_$set_stop_every (trace_$cv_n_to_number ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-stop_proc" | arg = "-spp" /* -stop_proc ENTRYNAME, -spp ENTRYNAME */ then do; call CHECK_NEXT_ARG (next_arg, 256, arg, "ENTRYNAME", ""); call trace_$set_stop_proc (trace_$cv_entry_name_to_spp ((next_arg), null ())); arg_idx = arg_idx + 2; end; else if arg = "-stop_low" | arg = "-splow" /* -stop_low N, -splow N */ then do; call CHECK_NEXT_ARG (next_arg, 16, arg, "N", " (where N is positive or 0)"); call trace_$set_stop_low (trace_$cv_n_to_number ((next_arg))); arg_idx = arg_idx + 2; end; else if arg = "-trace" /* -trace in|out|on|off */ then do; call CHECK_NEXT_ARG (next_arg, 8, arg, "in|out|on|off", ""); call trace_$set_trace (trace_$cv_inout_to_bits ((next_arg))); arg_idx = arg_idx + 2; end; /************ THE FOLLOWING CONTROL ARGUMENTS BECAME OBSOLETE IN MR11 ********/ else if arg = "-return_value" | arg = "-rv" then do; call com_err_ (ZERO, ME, "The ^a argument is now obsolete. Trace automatically determines whether entrypoints return values.", arg); go to TRANSACTION_END; end; else if arg = "-start" | arg = "-sr" then do; call OBSOLETE_ARG (arg, "-add"); go to TRANSACTION_END; end; else if arg = "-before" then do; call OBSOLETE_ARG (arg, "-stop_every N -stop in (-spev N -sp in)"); go to TRANSACTION_END; end; else if arg = "-after" then do; call OBSOLETE_ARG (arg, "-stop_every N -stop out (-spev N -sp out)"); go to TRANSACTION_END; end; else if arg = "-depth " | arg = "-dh" then do; call OBSOLETE_ARG (arg, "-high"); go to TRANSACTION_END; end; else if arg = "-in" then do; call OBSOLETE_ARG (arg, "-arguments in (-ag in)"); go to TRANSACTION_END; end; else if arg = "-out" then do; call OBSOLETE_ARG (arg, "-arguments out (-ag out)"); go to TRANSACTION_END; end; else if arg = "-inout" then do; call OBSOLETE_ARG (arg, "-arguments inout (-ag inout)"); go to TRANSACTION_END; end; else if arg = "-template" | arg = "-tp" then do; call OBSOLETE_ARG (arg, "-parameters (-pm)"); go to TRANSACTION_END; end; else if arg = "-govern " | arg = "-gv" then do; call OBSOLETE_ARG (arg, "-stop_low N -stop in (-splow N -sp in)"); go to TRANSACTION_END; end; else if arg = "-execute" | arg = "-ex" then do; call OBSOLETE_ARG (arg, "-call"); go to TRANSACTION_END; end; /************ THE FOLLOWING CONTROL ARGUMENTS BECAME OBSOLETE IN MR9 ********/ else if arg = "-print " | arg = "-pr" then do; call OBSOLETE_ARG (arg, "-status (-st)"); go to TRANSACTION_END; end; else if arg = "-reset " | arg = "-rs" then do; call OBSOLETE_ARG (arg, "the trace_meters command (tmt)"); go to TRANSACTION_END; end; else if arg = "-total" | arg = "-tt" then do; call OBSOLETE_ARG (arg, "the trace_meters command (tmt)"); go to TRANSACTION_END; end; else if arg = "-subtotal" | arg = "-stt" then do; call OBSOLETE_ARG (arg, "the trace_meters command (tmt)"); go to TRANSACTION_END; end; else if arg = "-reset_total" | arg = "-rst" then do; call OBSOLETE_ARG (arg, "the trace_meters command (tmt -rs)"); go to TRANSACTION_END; end; else if arg = "-reset_subtotal" | arg = "-rss" then do; call OBSOLETE_ARG (arg, "the trace_meters command (tmt -rs)"); go to TRANSACTION_END; end; /*************** END OF OBSOLETE ARGUMENTS *********************************/ else do; call com_err_ (error_table_$badopt, ME, """^a""", arg); go to TRANSACTION_END; end; end CONTROL_ARGUMENT; end ARGUMENT_LOOP; %page; /* COMMIT ACTION and print a nice message something like this: Trace: global parms changed, default parms changed, 4 entrypoints specified, 2 entrypoints added, 2 entrypoints updated, 4 entrypoints turned off. */ call SAY_BEGIN (); if FIRST_TIME then do; call SAY (trace_$version ()); FIRST_TIME = "0"b; end; if trace_$update_global_parms () then call SAY ("global parms changed"); if set_defaults then do; if trace_$update_default_parms () then call SAY ("default parms changed"); end; n_specified = trace_$num_specified_entrypoints (); if n_specified > 0 then ENTRYPOINT_ACTION: do; call SAY_N_ENTRYPOINTS (n_specified, "specified"); if add_remove_action = "" & on_off_action = "" & ^status then add_remove_action = "add"; if add_remove_action = "add" then begin; dcl n_added fixed bin; dcl n_modified fixed bin; call trace_$add_specified_eps (n_added, n_modified); call SAY_N_ENTRYPOINTS (n_added, "added"); if n_modified > 0 then call SAY_N_ENTRYPOINTS (n_modified, "modified"); end; if add_remove_action = "remove" then begin; dcl n_removed fixed bin; call trace_$remove_specified_eps (n_removed); call SAY_N_ENTRYPOINTS (n_removed, "removed"); end; if on_off_action = "on" then begin; dcl n_turned_on fixed bin; call trace_$turn_on_specified_eps (n_turned_on); call SAY_N_ENTRYPOINTS (n_turned_on, "turned on"); end; if on_off_action = "off" then begin; dcl n_turned_off fixed bin; call trace_$turn_off_specified_eps (n_turned_off); call SAY_N_ENTRYPOINTS (n_turned_off, "turned off"); end; end ENTRYPOINT_ACTION; n_entrypoints = trace_$num_entrypoints (); if n_entrypoints = 0 then call SAY ("trace table empty"); else call SAY_N_ENTRYPOINTS (n_entrypoints, "in trace table"); if ^trace_$enabled () then call SAY ("disabled"); else if trace_$in_trace () then call SAY ("temporarily disabled"); call SAY_END (); if parameters | arg_count = 0 then do; call ioa_ ("Global parms: ^a", trace_$global_parms_string ()); call ioa_ ("Default parms: ^a", trace_$parms_string (-1, "0"b)); end; if arg_count = 0 then call ioa_ ("Acts: -set_defaults -add/-remove -on/-off -parameters -status -print_buffer."); if add_remove_action = "" then if trace_$parms_specified () then call ioa_ ("The trace parameters you specified were ineffectual because you did not specify any entrypoints to be added or -set_defaults."); if status & n_entrypoints ^= 0 then STATUS: begin; dcl ep_idx fixed bin; dcl ep_ptr ptr; dcl n_not_in_tt fixed bin; dcl old_seg_no bit (18) aligned; dcl specified_ep_idx fixed bin; if n_specified = 0 then call ioa_ ("If you want status, you must specify some entrypoints."); else call ioa_ ("^/ CALLS RECURSION/HIGHEST NAME ^18x(STATUS) PARMS ^= DEFAULTS"); old_seg_no = ""b; n_not_in_tt = 0; do specified_ep_idx = 0 to n_specified - 1; ep_idx = trace_$specified_entrypoint_index (specified_ep_idx); if ep_idx < 0 then n_not_in_tt = n_not_in_tt + 1; else do; ep_ptr = trace_$entrypoint_ptr (ep_idx); if baseno (ep_ptr) ^= old_seg_no then do; call ioa_ ("^a", trace_$entrypoint_seg_path (ep_idx)); old_seg_no = baseno (ep_ptr); end; counts = trace_$entrypoint_counts (ep_idx); call ioa_ ("^7d ^d/^d ^38a (^a) ^a", counts.calls, counts.level, counts.max_level, trace_$entrypoint_name (ep_idx), trace_$entrypoint_status (ep_idx), trace_$parms_string (ep_idx, "1"b)); end; end; if n_not_in_tt > 0 then do; if n_not_in_tt = 1 then call ioa_ ("^d of the specified entrypoints was not in the trace table.", n_not_in_tt); else call ioa_ ("^d of the specified entrypoints were not in the trace table.", n_not_in_tt); end; end STATUS; if print_buffer ^= 0 then PRINT_BUFFER: begin; dcl buffer_count fixed bin (34); dcl buffer_first_idx fixed bin (34); dcl buffer_idx fixed bin (34); call ioa_ (""); if ^trace_$buffer () then call ioa_ ("There is no buffer to print."); else do; call trace_$buffer_counts (buffer_first_idx, buffer_count); if buffer_count = 0 then call ioa_ ("The buffer is empty."); else do; buffer_idx = max (buffer_count - print_buffer, buffer_first_idx); call ioa_ ("^8a ^a", " EVENT#", trace_$buffer_event_header (buffer_idx)); do buffer_idx = buffer_idx to buffer_count - 1; call ioa_ ("^8d ^a", buffer_idx, trace_$buffer_event_string (buffer_idx)); end; end; end; end PRINT_BUFFER; TRANSACTION_END: if ^trace_$transaction_end (transaction_id) /* Re-enable trace_catch_. */ then call com_err_ (ZERO, ME, "The trace command ended abnormally."); return; SAY: proc (action_i); if trace_$loud () then do; call INIT (); call ioa_$nnl ("^a", action_i); end; return; SAY_N_ENTRYPOINTS: entry (num_i, action_i); if trace_$loud () then do; call INIT (); if num_i = 1 then call ioa_$nnl ("^d ep ^a", num_i, action_i); else call ioa_$nnl ("^d eps ^a", num_i, action_i); end; return; SAY_BEGIN: entry (); n_things_said = 0; return; SAY_END: entry (); if n_things_said > 0 then call ioa_ ("."); return; INIT: proc (); if n_things_said = 0 then call ioa_$nnl ("^a: ", ME); else call ioa_$nnl (", "); n_things_said = n_things_said + 1; end INIT; dcl action_i char (*) parm; dcl num_i fixed bin parm; end SAY; %page; compensations: compensation: entry (); call ioa_ ("^24x REAL VCPU"); call PC (COMPENSATION_FROM_ENTRY_TO_ENTRY, "From entry to entry"); call PC (COMPENSATION_FROM_ENTRY_TO_RETURN, "From entry to return"); call PC (COMPENSATION_FROM_RETURN_TO_ENTRY, "From return to entry"); call PC (COMPENSATION_FROM_RETURN_TO_RETURN, "From return to return"); return; PC: proc (compensation_type_i, compensation_name_i); dcl compensation_type_i fixed bin parm; dcl compensation_name_i char (24) parm; comp = trace_$compensation (compensation_type_i); call ioa_ ("^24a ^4d ^4d", compensation_name_i, comp.real_time, comp.vcpu_time); dcl 1 comp aligned like compensation; end PC; OBSOLETE_ARG: proc (obsolete_arg_i, use_instead_i); dcl (obsolete_arg_i, use_instead_i) char (*) parm; call com_err_ (ZERO, ME, "The ^a argument is now obsolete. Use ^a instead. This version of the trace command has substantially improved syntax. Please see the new documentation for trace and watch.", obsolete_arg_i, use_instead_i); end OBSOLETE_ARG; CHECK_NEXT_ARG: proc (next_arg_i, max_arg_len_i, control_arg_i, syntax_i, comment_i); dcl (next_arg_i, control_arg_i, syntax_i, comment_i) char (*) parm; dcl max_arg_len_i fixed bin (21); if addr (next_arg_i) = null () then do; call com_err_ (error_table_$noarg, ME, "The syntax is: ^a ^a^a.", control_arg_i, syntax_i, comment_i); go to TRANSACTION_END; end; if length (next_arg_i) > max_arg_len_i then do; call com_err_ (error_table_$bigarg, ME, "The maximum length for ^a is ^d characters. The syntax is: ^a ^a^a.", syntax_i, max_arg_len_i, control_arg_i, syntax_i, comment_i); go to TRANSACTION_END; end; end CHECK_NEXT_ARG; %page; /* SUBROUTINES */ SUB_ERROR_HANDLER: proc (mcptr_i, a_name_i, wcptr_i, info_ptr_i, continue_o); sub_error_info_ptr = info_ptr_i; condition_info_header_ptr = null (); if sub_error_info.name ^= trace_$me () then go to CONTINUE; if sub_error_info.header.support_signal | sub_error_info.header.quiet_restart then go to HANDLED; if sub_error_info.header.default_restart then go to REPORT; if sub_error_info.header.cant_restart then go to REPORT_AND_ABORT; else go to CONTINUE; REPORT_AND_ABORT: call com_err_ (sub_error_info.header.status_code, ME, "^a", sub_error_info.header.info_string); go to TRANSACTION_END; REPORT: call com_err_ (sub_error_info.header.status_code, ME, "^a", sub_error_info.header.info_string); HANDLED: continue_o = "0"b; return; CONTINUE: continue_o = "1"b; return; dcl mcptr_i ptr parm; dcl a_name_i char (*) parm; dcl info_ptr_i ptr parm; dcl wcptr_i ptr parm; dcl continue_o bit aligned; %include condition_info_header; %include sub_error_info; end SUB_ERROR_HANDLER; %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Automatic */ dcl add_remove_action char (8) init (""); dcl arg_count fixed bin init (0); dcl arg_idx fixed bin init (0); dcl arg_len fixed bin (21) init (0); dcl arg_ptr ptr init (null ()); dcl code fixed bin (35) init (0); dcl n_entrypoints fixed bin; dcl n_specified fixed bin init (0); dcl n_things_said fixed bin init (0); dcl next_arg_idx fixed bin init (0); dcl next_arg_len fixed bin (21) init (0); dcl next_arg_ptr ptr init (null ()); dcl on_off_action char (4) init (""); dcl parameters bit aligned init ("0"b); dcl print_buffer fixed bin (34); dcl set_defaults bit aligned init ("0"b); dcl status bit aligned init ("0"b); dcl transaction_id fixed bin (71) init (0); /* Static */ dcl FIRST_TIME bit aligned static init ("1"b); dcl ME char (32) static options (constant) init ("trace"); dcl ZERO fixed bin (35) static options (constant) init (0); /* Conditions */ dcl cleanup condition; dcl error condition; /* Based */ dcl arg char (arg_len) based (arg_ptr); dcl next_arg char (next_arg_len) based (next_arg_ptr); /* External Variables */ dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$bigarg fixed bin (35) ext; dcl error_table_$noarg fixed bin (35) ext; /* External Entries */ dcl com_err_ entry options (variable); dcl condition_ entry (char (*), entry); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl ioa_ entry () options (variable); dcl ioa_$nnl entry () options (variable); /* format: insnl,delnl */ /* END OF DECLARATIONS */ %page; /* START OF INCLUDE FILES */ %include trace_interface; end trace;  trace_.alm 11/05/86 1345.5r w 11/04/86 1038.2 108297 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1984 * " * * " *********************************************************** " This is (or will be) the trace gate. " For efficiency, it implements some of the simple operations. " Written: May 1984 by Jeffrey D. Ives. name trace_ INITIALIZE_EVERYTHING: getlp call6 trace_transactions_$initialize_everything firstref <*text>|INITIALIZE_EVERYTHING include gate_macros gate_info macro TraceGate gentry &1,&3*2,0 tsx2 TRACE_SETUP call6 &2 &end " CATCH EXECUTION TraceGate catch_pl1,trace_catch_$catch_pl1_,0 " IDENTIFICATION " () returns (char (32)) TraceGate me,trace_version_$me,1 " () returns (char (32)) TraceGate version,trace_version_$version,1 " TRANSACTIONS " entry (fixed bin (71)) returns (bit aligned) TraceGate transaction_begin,trace_transactions_$transaction_begin,2 " entry (fixed bin (71)) TraceGate transaction_begin_force,trace_transactions_$transaction_begin_force,1 " entry (fixed bin (71)) returns (bit aligned) TraceGate transaction_end,trace_transactions_$transaction_end,2 " UPDATES " entry () returns (bit aligned) TraceGate update_default_parms,trace_parameters_$update_default_parms,1 " entry () returns (bit aligned) TraceGate update_global_parms,trace_parameters_$update_global_parms,1 " entry (fixed bin, fixed bin) TraceGate add_specified_eps,trace_tables_$add_specified_eps,2 " entry (fixed bin, fixed bin) TraceGate add_specified_locs,trace_tables_$add_specified_locs,2 " entry (fixed bin) TraceGate remove_specified_eps,trace_tables_$remove_specified_eps,1 " entry (fixed bin) TraceGate remove_specified_locs,trace_tables_$remove_specified_locs,1 " entry (fixed bin) TraceGate turn_on_specified_eps,trace_tables_$turn_on_specified_eps,1 " entry (fixed bin) TraceGate turn_off_specified_eps,trace_tables_$turn_off_specified_eps,1 " CONVERSION " (char (8) aligned) returns (bit (2) aligned) TraceGate cv_inout_to_bits,trace_conversions_$cv_inout_to_bits,2 " (bit (2) aligned) returns (char (8) aligned) TraceGate cv_bits_to_inout,trace_conversions_$cv_bits_to_inout,2 " (char (16) aligned) returns (fixed bin (34)) TraceGate cv_n_to_number,trace_conversions_$cv_n_to_number,2 " (char (8)) returns (bit aligned) TraceGate cv_onoff_to_bit,trace_conversions_$cv_onoff_to_bit,2 " (bit aligned) returns (char (8)) TraceGate cv_bit_to_onoff,trace_conversions_$cv_bit_to_onoff,2 " (char (256) var, ptr) returns (1 like stop_proc aligned) TraceGate cv_entry_name_to_spp,trace_print_$cv_entry_name_to_spp,3 " (char (256) var, ptr) returns (1 like output_switch aligned) TraceGate cv_file_path_to_osw,trace_print_$cv_file_path_to_osw,3 " (char (32) var) returns (1 like output_switch aligned) TraceGate cv_stream_name_to_osw,trace_print_$cv_stream_name_to_osw,2 " METERS " (fixed bin) returns (1 aligned like counts) TraceGate entrypoint_counts,trace_tables_$entrypoint_counts,2 " (fixed bin) returns (1 aligned like meters) TraceGate entrypoint_global_meters,trace_tables_$entrypoint_global_meters,2 " (fixed bin) returns (1 aligned like meters) TraceGate entrypoint_local_meters,trace_tables_$entrypoint_local_meters,2 " entry () returns (1 like meters aligned) TraceGate metered,trace_tables_$metered,1 " entry () returns (1 like meters aligned) TraceGate removed,trace_tables_$removed,1 " entry () TraceGate reset_meters,trace_tables_$reset_meters,0 " ENTRYPOINTS " (ptr unal) returns (fixed bin) TraceGate entrypoint_index,trace_tables_$entrypoint_index,2 " (fixed bin) returns (char (256) var) TraceGate entrypoint_name,trace_tables_$entrypoint_name,2 " (fixed bin) returns (ptr) TraceGate entrypoint_ptr,trace_tables_$entrypoint_ptr,2 " (fixed bin) returns (char (256) var) TraceGate entrypoint_seg_path,trace_tables_$entrypoint_seg_path,2 " (fixed bin) returns (char (32) var) TraceGate entrypoint_status,trace_tables_$entrypoint_status,2 " (fixed bin) returns (bit aligned) TraceGate function,trace_tables_$function,2 " () returns (fixed bin) TraceGate num_entrypoints,trace_tables_$num_entrypoints,1 " () returns (fixed bin) TraceGate num_specified_entrypoints,trace_tables_$num_specified_entrypoints,1 " (fixed bin) returns (fixed bin) TraceGate specified_entrypoint_index,trace_tables_$specified_entrypoint_index,2 " (char (256) var, ptr) TraceGate specify_entrypoints,trace_entrypoints_$specify_entrypoints,2 " (fixed bin) returns (fixed bin) TraceGate translator_id,trace_tables_$translator_id,2 " LOCATIONS " (fixed bin) returns (ptr) TraceGate location_ptr,trace_tables_$location_ptr,2 " (fixed bin) returns (char (256) var) TraceGate location_seg_path,trace_tables_$location_seg_path,2 " (fixed bin) returns (1 aligned like values) TraceGate location_values,trace_tables_$location_values,2 " () returns (fixed bin) TraceGate num_locations,trace_tables_$num_locations,1 " () returns (fixed bin) TraceGate num_specified_locations,trace_tables_$num_specified_locations,1 " (fixed bin) returns (fixed bin) TraceGate specified_location_index,trace_tables_$specified_location_index,2 " (char (256) var) TraceGate specify_locations,trace_tables_$specify_locations,1 " () TraceGate specify_changed_locations,trace_tables_$specify_changed_locations,0 " EVENT BUFFER " (fixed bin (34), fixed bin (34)) TraceGate buffer_counts,trace_print_$buffer_counts,2 " (fixed bin (34), fixed bin, char (2), ptr unal, " 1 like counts aligned, 1 like meters aligned) TraceGate buffer_event,trace_print_$buffer_event,6 " (fixed bin (34)) returns (char (256) var) TraceGate buffer_event_header,trace_print_$buffer_event_header,2 " (fixed bin (34)) returns (char (256) var) TraceGate buffer_event_string,trace_print_$buffer_event_string,2 " () returns (ptr unal) TraceGate buffer_ptr,trace_parameters_$buffer_ptr,1 " TRACE PARAMETERS " (fixed bin) returns (bit (2) aligned) TraceGate arguments,trace_parameters_$arguments,2 " (bit (2) aligned) TraceGate set_arguments,trace_parameters_$set_arguments,1 " (fixed bin) returns (char (256) var) TraceGate call,trace_parameters_$call,2 " (char (256) var) TraceGate set_call,trace_parameters_$set_call,1 " (fixed bin) returns (fixed bin (34)) TraceGate every,trace_parameters_$every,2 " (fixed bin (34)) TraceGate set_every,trace_parameters_$set_every,1 " (fixed bin) returns (fixed bin (34)) TraceGate first,trace_parameters_$first,2 " (fixed bin (34)) TraceGate set_first,trace_parameters_$set_first,1 " (fixed bin) returns (fixed bin (34)) TraceGate high,trace_parameters_$high,2 " (fixed bin (34)) TraceGate set_high,trace_parameters_$set_high,1 " (fixed bin) returns (fixed bin (34)) TraceGate last,trace_parameters_$last,2 " (fixed bin (34)) TraceGate set_last,trace_parameters_$set_last,1 " (fixed bin) returns (fixed bin (34)) TraceGate low,trace_parameters_$low,2 " (fixed bin (34)) TraceGate set_low,trace_parameters_$set_low,1 " (fixed bin) returns (bit aligned) TraceGate new_high,trace_parameters_$new_high,2 " (bit aligned) TraceGate set_new_high,trace_parameters_$set_new_high,1 " (fixed bin, bit aligned) returns (char (256) var) TraceGate parms_string,trace_parameters_$parms_string,3 " () returns (bit aligned) TraceGate parms_specified,trace_parameters_$parms_specified,1 " (fixed bin) returns (bit (2) aligned) TraceGate stop,trace_parameters_$stop,2 " (bit (2) aligned) TraceGate set_stop,trace_parameters_$set_stop,1 " (fixed bin) returns (fixed bin (34)) TraceGate stop_every,trace_parameters_$stop_every,2 " (fixed bin (34)) TraceGate set_stop_every,trace_parameters_$set_stop_every,1 " (fixed bin) returns (fixed bin (34)) TraceGate stop_low,trace_parameters_$stop_low,2 " (fixed bin (34)) TraceGate set_stop_low,trace_parameters_$set_stop_low,1 " (fixed bin) returns (bit (2) aligned) TraceGate trace,trace_parameters_$trace,2 " (bit (2) aligned) TraceGate set_trace,trace_parameters_$set_trace,1 " GLOBAL PARAMETERS " () returns (bit aligned) TraceGate alm,trace_parameters_$alm,1 " (bit aligned) TraceGate set_alm,trace_parameters_$set_alm,1 " () returns (bit aligned) TraceGate automatic,trace_parameters_$automatic,1 " (bit aligned) TraceGate set_automatic,trace_parameters_$set_automatic,1 " () returns (bit aligned) TraceGate buffer,trace_parameters_$buffer,1 " (bit aligned) TraceGate set_buffer,trace_parameters_$set_buffer,1 " () returns (bit aligned) TraceGate calibrate,trace_parameters_$calibrate,1 " (bit aligned) TraceGate set_calibrate,trace_parameters_$set_calibrate,1 " (fixed bin) returns (1 aligned like compensation) TraceGate compensation,trace_parameters_$compensation,2 " (fixed bin, 1 aligned like compensation) TraceGate set_compensation,trace_parameters_$set_compensation,2 " () returns (bit aligned) TraceGate enabled,trace_parameters_$enabled,1 " (bit aligned) TraceGate set_enabled,trace_parameters_$set_enabled,1 " () returns (char (256) var); TraceGate global_parms_string,trace_parameters_$global_parms_string,1 " returns (bit aligned) TraceGate long,trace_parameters_$long,1 " (bit aligned) TraceGate set_long,trace_parameters_$set_long,1 " () returns (bit aligned) TraceGate meter,trace_parameters_$meter,1 " (bit aligned) TraceGate set_meter,trace_parameters_$set_meter,1 " () returns (1 like output_switch aligned) TraceGate output_switch,trace_parameters_$output_switch,1 " (1 like output_switch aligned) TraceGate set_output_switch,trace_parameters_$set_output_switch,1 " () returns (bit aligned) TraceGate signals,trace_parameters_$signals,1 " (bit aligned) TraceGate set_signals,trace_parameters_$set_signals,1 " () returns (1 like stop_proc aligned) TraceGate stop_proc,trace_parameters_$stop_proc,1 " (1 like stop_proc aligned) TraceGate set_stop_proc,trace_parameters_$set_stop_proc,1 " () returns (entry) TraceGate stop_routine,trace_parameters_$stop_routine,1 " (entry) TraceGate set_stop_routine,trace_parameters_$set_stop_routine,1 " () returns (entry) TraceGate trace_routine,trace_parameters_$trace_routine,1 " (entry) TraceGate set_trace_routine,trace_parameters_$set_trace_routine,1 " () returns (bit aligned) TraceGate loud,trace_parameters_$loud,1 " (bit aligned) TraceGate set_loud,trace_parameters_$set_loud,1 " MISCELLANEOUS " () returns (bit aligned) TraceGate in_trace,IN_TRACE,1 TRACE_SETUP: epaq * get_lp without invoking trace_catch_ lprp4 pr7|stack_header.lot_ptr,*au ldx1 -2,2 get number of args expected tze 0,2 if zero, none or doesn't matter cmpx1 ap|0 compare against number given tze 0,2 args match, call procedure eaa TRUE Take this out when sta pr7|stack_header.in_trace trace becomes a real gate. call6 trace_$SIGNAL_GATE_ERROR entry SIGNAL_GATE_ERROR Buff up before signalling. SIGNAL_GATE_ERROR: push call signal_$signal_(signal_arglist) oct 0 hopefully, it never returns IN_TRACE: lda pr7|stack_header.in_trace sta pr0|2,* short_return Life can be easy sometimes. " CONSTANTS even null_ptr: oct 077777000043,000001000000 ptr_mask: oct 077777000077,777777077077 " STATIC use static_section join /link/static_section even segdef transaction_id transaction_id: dec 0,0 even segdef stt_ptr stt_ptr: its -1,1 even segdef swt_ptr swt_ptr: its -1,1 segdef parameters_ptr parameters_ptr: oct 007777000001 even segdef global_parameters bss global_parameters,182 " SYMBOLS SYMBOLS SYMBOLS SYMBOLS SYMBOLS SYMBOLS SYMBOLS SYMBOLS bool TRUE,400000 include stack_header end  trace_calibrate_.pl1 01/11/85 1045.4rew 01/11/85 1034.9 113904 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This program experimentally determines the metering compensation values. Written: May 1984 by Jeffrey D. Ives. */ /* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */ trace_calibrate_: proc (compensation_kind_i, entry_comp_o, return_comp_o); if trace_$num_entrypoints () ^= 0 then signal error; transaction_id = clock (); if ^trace_$transaction_begin (transaction_id) then signal error; if compensation_kind_i = "repeat" then do; call trace_tables_$specify_entrypoint (codeptr (trace_repeat_), "trace_repeat_$trace_repeat_", 0, "0"b); call trace_tables_$specify_entrypoint (codeptr (trace_repeat_dummy_), "trace_repeat_dummy_$trace_repeat_dummy_", 0, "0"b); end; else if compensation_kind_i = "recurse" then do; call trace_tables_$specify_entrypoint (codeptr (trace_recurse_), "trace_recurse_$trace_recurse_", 0, "0"b); call trace_tables_$specify_entrypoint (codeptr (trace_recurse_dummy_), "trace_recurse_dummy_$trace_recurse_dummy_", 0, "0"b); end; else signal error; stop_routine_saved = trace_$stop_routine (); call trace_$set_stop_routine (SNAP_ENTRIES); call trace_$set_enabled ("0"b); /* Run without trace operators. */ call trace_$set_trace ("00"b); if ^trace_$update_global_parms () then signal error; call trace_$add_specified_eps (n_added, n_modified); if n_added ^= 2 | n_modified ^= 0 then signal error; if ^trace_$transaction_end (transaction_id) then signal error; total = 0; trials_vcpu_start = vclock (); TRIAL_LOOP: do total_trials = 0 by 1 while (total_trials < NUMBER_OF_TRIALS); run.elapsed = 0; NO_INTERRUPTION_LOOP: /* We are striving for perfection. */ do while (run.elapsed.real_time >= run.elapsed.vcpu_time); if vclock () - trials_vcpu_start > 2000000 then go to END_OF_TRIALS; /* We know when to give up. */ run.start.vcpu_time = vclock (); run.start.real_time = clock (); if compensation_kind_i = "repeat" then do; call trace_repeat_ (NUMBER_OF_BASELINE_CALLS, trial.benchmark.baseline.entry.real_time, trial.benchmark.baseline.return.real_time); call trace_repeat_ (NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS, trial.benchmark.measure.entry.real_time, trial.benchmark.measure.return.real_time); end; else if compensation_kind_i = "recurse" then do; call trace_recurse_ (NUMBER_OF_BASELINE_CALLS, trial.benchmark.baseline.entry.real_time, trial.benchmark.baseline.return.real_time); call trace_recurse_ (NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS, trial.benchmark.measure.entry.real_time, trial.benchmark.measure.return.real_time); end; else signal error; transaction_id = clock (); if ^trace_$transaction_begin (transaction_id) then signal error; else if compensation_kind_i = "recurse" then do; call trace_tables_$specify_entrypoint (codeptr (trace_recurse_dummy_), "trace_recurse_dummy_$trace_recurse_dummy_", 0, "0"b); call trace_$set_trace ("00"b); call trace_$set_stop ("10"b); /* -stop in */ call trace_$set_stop_every (NUMBER_OF_BASELINE_CALLS); call trace_$add_specified_eps (n_added, n_modified); if n_added ^= 0 | n_modified ^= 1 then signal error; end; call trace_$set_enabled ("1"b); if ^trace_$update_global_parms () then signal error; call trace_$reset_meters (); if ^trace_$transaction_end (transaction_id) then signal error; if compensation_kind_i = "repeat" then call trace_repeat_ (NUMBER_OF_BASELINE_CALLS, not_used (1), not_used (2)); else if compensation_kind_i = "recurse" then call trace_recurse_ (NUMBER_OF_BASELINE_CALLS, not_used (1), not_used (2)); else signal error; transaction_id = clock (); if ^trace_$transaction_begin (transaction_id) then signal error; do tt_idx = 0 to 1; meters = trace_$entrypoint_local_meters (tt_idx); entry_ptr = trace_$entrypoint_ptr (tt_idx); if entry_ptr = codeptr (trace_repeat_) then do; trial.meter.baseline.return.real_time = meters.real_time; trial.meter.baseline.return.vcpu_time = meters.vcpu_time; end; else if entry_ptr = codeptr (trace_repeat_dummy_) then do; trial.meter.baseline.entry.real_time = meters.real_time; trial.meter.baseline.entry.vcpu_time = meters.vcpu_time; end; else if entry_ptr = codeptr (trace_recurse_) then ; else if entry_ptr = codeptr (trace_recurse_dummy_) then do; trial.meter.baseline.return.real_time = meters.real_time - trial.meter.baseline.entry.real_time; trial.meter.baseline.return.vcpu_time = meters.vcpu_time - trial.meter.baseline.entry.vcpu_time; call trace_tables_$specify_entrypoint (codeptr (trace_recurse_dummy_), "trace_recurse_dummy_$trace_recurse_dummy_", 0, "0"b); call trace_$set_trace ("00"b); call trace_$set_stop ("10"b); /* -stop in */ call trace_$set_stop_every (NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS); call trace_$add_specified_eps (n_added, n_modified); if n_added ^= 0 | n_modified ^= 1 then signal error; end; else signal error; end; call trace_$reset_meters (); if ^trace_$transaction_end (transaction_id) then signal error; if compensation_kind_i = "repeat" then call trace_repeat_ (NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS, not_used (1), not_used (2)); else if compensation_kind_i = "recurse" then call trace_recurse_ (NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS, not_used (1), not_used (2)); else signal error; run.stop.real_time = clock (); run.stop.vcpu_time = vclock (); run.elapsed = run.stop - run.start; transaction_id = clock (); if ^trace_$transaction_begin (transaction_id) then signal error; call trace_$set_enabled ("0"b); /* Run without trace operators. */ if ^trace_$update_global_parms () then signal error; if ^trace_$transaction_end (transaction_id) then signal error; end NO_INTERRUPTION_LOOP; do tt_idx = 0 to 1; entry_ptr = trace_$entrypoint_ptr (tt_idx); meters = trace_$entrypoint_local_meters (tt_idx); if entry_ptr = codeptr (trace_repeat_) then do; trial.meter.measure.return.real_time = meters.real_time; trial.meter.measure.return.vcpu_time = meters.vcpu_time; end; else if entry_ptr = codeptr (trace_repeat_dummy_) then do; trial.meter.measure.entry.real_time = meters.real_time; trial.meter.measure.entry.vcpu_time = meters.vcpu_time; end; else if entry_ptr = codeptr (trace_recurse_) then ; else if entry_ptr = codeptr (trace_recurse_dummy_) then do; trial.meter.measure.return.real_time = meters.real_time - trial.meter.measure.entry.real_time; trial.meter.measure.return.vcpu_time = meters.vcpu_time - trial.meter.measure.entry.vcpu_time; end; else signal error; end; total = total + trial; end TRIAL_LOOP; END_OF_TRIALS: transaction_id = clock (); if ^trace_$transaction_begin (transaction_id) then signal error; call trace_$specify_entrypoints ("*", null ()); call trace_$set_stop_routine (stop_routine_saved); call trace_$set_enabled ("1"b); if ^trace_$update_global_parms () then signal error; call trace_$remove_specified_eps (n_removed); if n_removed ^= 2 then signal error; if ^trace_$transaction_end (transaction_id) then signal error; if total_trials = 0 then do; entry_comp_o = 0; return_comp_o = 0; end; else do; total_measured_calls = multiply (total_trials, NUMBER_OF_MEASURED_CALLS, 17); entry_comp_o = divide ((total.meter.measure.entry - total.meter.baseline.entry) - (total.benchmark.measure.entry.real_time - total.benchmark.baseline.entry.real_time), total_measured_calls, 53); return_comp_o = divide ((total.meter.measure.return - total.meter.baseline.return) - (total.benchmark.measure.return.real_time - total.benchmark.baseline.return.real_time), total_measured_calls, 53); end; return; %page; /* SUBROUTINES */ SNAP_ENTRIES: proc (event_i); dcl 1 event_i like event aligned parm; dcl EVENT_VERSION_3 char (4) aligned static options (constant) init ("TEV3"); dcl event_ptr ptr; dcl 1 event aligned based (event_ptr), /* Trace_catch_ knows this is 16 words. */ 2 version char (4), 2 kind char (2) unal, 2 frame_count fixed bin unal, 2 frame like meters, 2 entry_ptr ptr unal, 2 saved like counts, 2 entry_idx fixed bin, 2 arg_list_ptr ptr unal, 2 callers_sp ptr unal, 2 return_ptr ptr unal; dcl 1 snap_meters like meters aligned; dcl trace_catch_$start_tracing entry (); dcl trace_catch_$stop_tracing entry (); event_ptr = addr (event_i); if event.version ^= EVENT_VERSION_3 | event.kind ^= "ca" then signal error; call trace_catch_$stop_tracing (); /* Flush meters form trace_catch_ frames in stack.*/ snap_meters = trace_$entrypoint_local_meters (event.entry_idx); call trace_catch_$start_tracing (); /* Replant the trace operators pointers. */ if event.saved.calls + 1 = NUMBER_OF_BASELINE_CALLS then do; trial.meter.baseline.entry.real_time = snap_meters.real_time; trial.meter.baseline.entry.vcpu_time = snap_meters.vcpu_time; end; else if event.saved.calls + 1 = NUMBER_OF_BASELINE_CALLS + NUMBER_OF_MEASURED_CALLS then do; trial.meter.measure.entry.real_time = snap_meters.real_time; trial.meter.measure.entry.vcpu_time = snap_meters.vcpu_time; end; else signal error; return; end SNAP_ENTRIES; %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl compensation_kind_i char (8) aligned parm; dcl 1 entry_comp_o aligned parm like compensation; dcl 1 return_comp_o aligned parm like compensation; /* Automatic */ dcl entry_ptr ptr unal; dcl n_added fixed bin; dcl n_modified fixed bin; dcl n_removed fixed bin; dcl not_used (2) fixed bin (53); dcl stop_routine_saved entry variable; dcl total_measured_calls fixed bin; dcl total_trials fixed bin; dcl transaction_id fixed bin (71); dcl trials_vcpu_start fixed bin (53); dcl tt_idx fixed bin; dcl 1 run aligned, 2 start like compensation, 2 stop like compensation, 2 elapsed like compensation; dcl 1 trial aligned, 2 benchmark, 3 baseline, 4 entry, 5 real_time fixed bin (53), 4 return, 5 real_time fixed bin (53), 3 measure, 4 entry, 5 real_time fixed bin (53), 4 return, 5 real_time fixed bin (53), 2 meter, 3 baseline, 4 entry like compensation, 4 return like compensation, 3 measure, 4 entry like compensation, 4 return like compensation; dcl 1 total aligned like trial; /* Static */ dcl NUMBER_OF_BASELINE_CALLS fixed bin (34) static options (constant) init (2); dcl NUMBER_OF_MEASURED_CALLS fixed bin (34) static options (constant) init (16); dcl NUMBER_OF_TRIALS fixed bin static options (constant) init (8); dcl ZERO fixed bin (35) static options (constant) init (0); /* Conditions */ dcl error condition; /* Based */ /* External Variables */ /* External Entries */ dcl trace_repeat_ entry (fixed bin (34), fixed bin (53), fixed bin (53)); dcl trace_repeat_dummy_ entry (fixed bin (53)); dcl trace_recurse_ entry (fixed bin (34), fixed bin (53), fixed bin (53)); dcl trace_recurse_dummy_ entry (fixed bin, fixed bin (53)); dcl trace_tables_$specify_entrypoint entry (ptr unal, char (65) var, fixed bin, bit aligned); /* format: insnl,delnl */ /* END OF DECLARATIONS */ %page; /* START OF INCLUDE FILES */ %include sub_err_flags; %page; %include trace_interface; end trace_calibrate_;  trace_catch_.alm 11/05/86 1345.5r w 11/04/86 1038.2 499491 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** " Program to trace procedure calls " " Barry L. Wolman, 2 January 1970 " Modified: 18 June 1971 by BLW for Version II pl1 " Modified: 30 May 1972 by BLW to use per/process info procedure instead of usage_values " Modified: 2 March 1973 by BLW for 6180 " Modified: 16 May 1974 by BLW for change in setting up cleanup handler " Modified: 2 January 1974 by Richard A. Barnes to fix up many bugs " Modified: 7 May 1975 by RAB for new pl1_operators_ interface " Modified: 6 December 1975 by RAB to fix bugs in TRACE_CATCH_CLEANUP and update_stats " Modified: 20 September 1977 by PCK to use a temporary segment for trace_storage. " Modified: Autumn 1978 by R.E. Mullen for dynamic tracelist " Modified: 28 July 1981 by Jeffrey D. Ives, fix returns (*), cleanup trace_catch_$in_trace. " Modified: 01 Apr 1982 by Jeffrey D. Ives, add trace_catch_$switch for efficiency. " Rewritten: 23 June 1983 by Jeffrey D. Ives, multitasking, accurate metering, and macros. " Modified: May 1984 by Jeffrey D. Ives, for new trace_tab, parameters, global_parameters. name trace_catch_ " This is the first reference trap code for trace_catch_. It snaps these " links so that the linker will not run and invoke trace_catch_ while " trace_catch_ itself is running. entry initialize initialize: rccl sys_info$clock_,* epp5 cpu_time_and_paging_op_$cpu_time_and_paging_op_ epp5 trace_catch_$trace_catcher_ epp5 trace_catch_$TRACE_CATCH_CLEANUP epp5 pl1_operators_$operator_table epp5 operator_pointers_$operator_pointers_ epp5 pl1_operators_$alm_entry epp5 pl1_operators_$trace_operator_table epp5 trace_operator_pointers_$trace_operator_pointers_ epp5 pl1_operators_$trace_alm_entry " Remember these entrypoints because they are very special. epp5 trace_transactions_$transaction_begin sprp5 pr4|TRANSACTION_BEGIN epp5 trace_transactions_$transaction_begin_force sprp5 pr4|TRANSACTION_BEGIN_FORCE epp5 signal_$signal_ sprp5 pr4|SIGNAL_ epp5 signal_$io_signal sprp5 pr4|IO_SIGNAL short_return " STACK FRAME DATA STACK FRAME DATA STACK FRAME DATA STACK FRAME DATA " Do not put anything ahead of ptr_registers_saved unless it is mod16 in length. temp8 registers_saved temp8 ptr_registers_saved(2) " This must be on a mod16 boundary! tempd arg_list.header tempd arg_list.first_arg_ptr tempd arg_list.second_arg_ptr tempd arg_list.third_arg_ptr tempd event(8) tempd cleanup_unit(3) tempd trace_frames_saved tempd global_start.real_time " These three MUST be kept together. tempd global_start.vcpu_time temp global_start.page_faults temp indicators_saved temp watch_values_changed temp stack_frame_end(0) " For checking stack_frame_size. equ stack_frame_size,112 " Trace_catch_ pushes this size frame. " MACRO DEFINITIONS MACRO DEFINITIONS MACRO DEFINITIONS MACRO DEFINITIONS macro get_pr4 epaq * lprp4 pr7|stack_header.lot_ptr,*au &end macro read_the_calendar_clock rccl sys_info$clock_,* staq pr4|&1+meters.real_time &end macro read_vcpu_time_and_page_faults stcd pr6|stack_frame.return_ptr call6 cpu_time_and_paging_op_$cpu_time_and_paging_op_ epbp7 pr6|0 epp4 pr6|stack_frame.lp_ptr,* staq pr4|&1+meters.vcpu_time " Vcpu time is returned in AQ register. stx0 pr4|&1+meters.page_faults " Page faults are returned in X0 and X1. sxl1 pr4|&1+meters.page_faults &end " A FEW WORDS ON THE METERING METHOD " The trace facility meters real time, virtual CPU time, and page faults. " Trace_catch_ reads the real time clock and usage meters as soon as possible " when it gets control and as late as possible when it relinquishes control. " This minimizes the effect of the overhead tracing overhead that is metered. " The remaining inaccuracy is reduced by a set of compensation values. " There are four kinds of intervals during which an entrypoint can collect " meters: " 1. from the time it is entered until control enters another " 2. from the time it is entered until it returns " 3. from the time it is returned to until it enters another " 4. from the time it is returned to until it returns " When control leaves trace_catch_, the meters are always saved in " trace_catch_$start. When control comes back, they are saved in " trace_catch_$stop. The difference between start and stop is accumulated in " the trace_catch_ frame associated with the procedure that relinquished " control. Eventually, when that frame is popped or unwound, the accumulated " meters are added to the tab for that procedure. At that time, they are also " added to trace_catch_$metered which accumulates all metered quantities and " is always equal the sum of the meters in the tabs and trace_catch_$removed, " which accumulates the meters of entrypoints that are removed from the trace " table. " The meters described in the previous paragraph are called frame meters and " represent the usage of a procedure without including the usage of any traced " procedures it calls. Global meters represent the usage from the time a " procedure is called until it returns. However, if it calls itself, it " should not be double metered. When an entrypoint is called, the values in " trace_catch_$metered are saved in its trace_catch_ frame in the variable " global_start. When it finally returns (or is unwound) the difference " between the current value of tc_$metered and global_start is added to " tab.global, which accumulates the entrypoint's global meters. " The user may wish to see the meters or remove entrypoints from the trace " table while trace_catch_ frames are still on the stack. Therefore, at the " beginning of each trace command, there is a call to " trace_catch_$stop_tracing. This routine yanks the trace operator pointers " and walks the stack of trace_catch_ frames, flushing the accumulated frame " and global meters into the corresponding tabs. At the end of each trace " command, there is a call to trace_catch_$start_tracing which again walks the " stack and sets the global_starts to tc_$metered. " This macro starts a metering interval. It puts the linkage section offset of " the appropriate portion of the compensation table in pr4|start_comp. It " then reads the meters into pr4|start. It does not store real_time because " this will be done at the very last. " It clobbers X4 and the registers clobbered by read_vcpu_time_and_page_faults. macro start_metering_interval eax4 global_parameters+global_parms.comps+from_&1 stx4 pr4|start_comp " Remember which compensations to use. read_vcpu_time_and_page_faults start NOTHING_TO_START&U: &end " This macro calculates the usages during a metering interval and adds them to " the meters in whatever stack frame &1 points to and to pr4|metered. " Pr4|start_comp contains an offset into the linkage section for the " compensation values. If pr4|start is zero, there is no interval and there " is nothing to do. It assumes that pr4|stop contains the stop readings and " it uses pr4|delta as working storage. It clobbers AQ and X4. macro metering_interval_calculations , lcaq pr4|start+meters.real_time tze INTERVAL_CALCULATED&U ldx4 pr4|start_comp " How were they started? adaq pr4|stop+meters.real_time " Calculate elapsed real time. tmi trace_error_halt_$trace_error_halt_ sbaq pr4|to_&2.real_time,x4 " Subtract appropriate compensation. tpl *+2 " A negative number would later lls 72 " be detected as an inconsistency. staq pr4|delta+meters.real_time ldaq pr4|stop+meters.vcpu_time " Calculate elapsed vcpu time. sbaq pr4|start+meters.vcpu_time cmpaq pr4|delta+meters.real_time " Elapsed vcpu time should always be less tmoz *+5 " than or equal to elapsed real time. szn pr4|global_parameters+global_parms.calibrate " Don't apply correction tnz *+3 " when determining compensations. ldaq pr4|delta+meters.real_time " If it isn't, use real time instead. tra *+2 " Delta real is already compensated. sbaq pr4|to_&2.vcpu_time,x4 " Subtract appropriate compensation. staq pr4|delta+meters.vcpu_time ldaq &1|event+event.frame.real_time adaq pr4|delta+meters.real_time " Update frame real time. staq &1|event+event.frame.real_time ldaq &1|event+event.frame.vcpu_time adaq pr4|delta+meters.vcpu_time " Update frame vcpu time. staq &1|event+event.frame.vcpu_time lda pr4|stop+meters.page_faults sba pr4|start+meters.page_faults tmi trace_error_halt_$trace_error_halt_ asa &1|event+event.frame.page_faults " Update frame page faults. INTERVAL_CALCULATED&U: lls 72 " Insure that they are not used again. staq pr4|start+meters.real_time staq pr4|start+meters.vcpu_time stz pr4|start+meters.page_faults &end " This macro starts a global metering interval if the recursion count is 1. " This is because we don't want to multiple-meter procedures used recursively. macro start_global_metering_interval lda &1|event+event.saved.level " Only start global meters tpnz GLOBAL_INTERVAL_STARTED&U " at recursion level 1. tmi trace_error_halt_$trace_error_halt_ lda pr4|metered+meters.page_faults sta &1|global_start.page_faults ldaq pr4|metered+meters.vcpu_time staq &1|global_start.vcpu_time ldaq pr4|metered+meters.real_time " Store this one last because it shows staq &1|global_start.real_time " that the others are valid. GLOBAL_INTERVAL_STARTED&U: &end " This macro takes the meters that have been accumulating in a trace_catch_ " frame and adds them to the tab. It also adds them to trace_catch_$metered, " which accumulates all metered time and page faults. This may be done either " because the frame is being popped or because we need the latest information " in the tab in order to produce a metering report. macro update_tab_meters ldaq pr4|metered+meters.real_time adaq &1|event+event.frame.real_time " Update metered real time. staq pr4|metered+meters.real_time ldaq pr2|tab.local+meters.real_time adaq &1|event+event.frame.real_time " Update tab real time. staq pr2|tab.local+meters.real_time ldaq pr4|metered+meters.vcpu_time adaq &1|event+event.frame.vcpu_time " Update metered vcpu time. staq pr4|metered+meters.vcpu_time ldaq pr2|tab.local+meters.vcpu_time adaq &1|event+event.frame.vcpu_time " Update tab real time. staq pr2|tab.local+meters.vcpu_time lda &1|event+event.frame.page_faults asa pr4|metered+meters.page_faults " Update metered page faults. asa pr2|tab.local+meters.page_faults " Update tab page faults. ldaq &1|global_start.real_time tze FRAME_METERS_UPDATED&U " No global metering in this frame. ldaq pr4|metered+meters.real_time " Update global real time. sbaq &1|global_start.real_time tmi trace_error_halt_$trace_error_halt_ adaq pr2|tab.global+meters.real_time staq pr2|tab.global+meters.real_time ldaq pr4|metered+meters.vcpu_time " Update global vcpu time. sbaq &1|global_start.vcpu_time adaq pr2|tab.global+meters.vcpu_time staq pr2|tab.global+meters.vcpu_time lda pr4|metered+meters.page_faults " Update global page faults. sba &1|global_start.page_faults tmi trace_error_halt_$trace_error_halt_ asa pr2|tab.global+meters.page_faults FRAME_METERS_UPDATED&U: lls 72 " Insure that they are not used again. staq &1|event+event.frame.real_time staq &1|event+event.frame.vcpu_time stz &1|event+event.frame.page_faults staq &1|global_start.real_time staq &1|global_start.vcpu_time stz &1|global_start.page_faults &end " FILL EVENT FOR PRINT OR STOP MACRO macro fill_event_for_trace_or_signal lda EVENT_VERSION_3 sta event+event.version lxl0 trace_frames_saved+trace_frames.count sxl0 event+event.frame_count epp0 ptr_registers_saved+2*0,* " This is where PR0 was saved. sprp0 event+event.arg_list_ptr epp0 pr6|0 epp0 pr0|stack_frame.prev_sp,* " Pointer to caller's stack frame. lda pr0|stack_frame.flag_word ana stack_frame.support_bit,dl tnz *-3 " Skip support frames. sprp0 event+event.callers_sp epp0 pr0|stack_frame.return_ptr,* " Pointer to caller's return point. sprp0 event+event.return_ptr &end " fill_event_for_trace_or_signal " CALL STOP ROUTINE MACRO macro call_stop_routine , " call global_parameters.stop_routine (event, watch_values_changed); " dcl global_parameters.stop_routine entry (1 like event aligned, bit aligned); ldx0 =2a&2,du stx0 &1|event+event.kind ldaq two_arg_list_header staq arg_list.header ldaq pr4|global_parameters+global_parms.stop_routine+2 " Environment ptr. staq arg_list.third_arg_ptr eraq null_ptr anaq ptr_mask tze *+3 ldaq two_arg_list_header_w_env staq arg_list.header epp0 &1|event spri0 arg_list.first_arg_ptr epp0 &1|watch_values_changed spri0 arg_list.second_arg_ptr call pr4|global_parameters+global_parms.stop_routine,*(arg_list.header) &end " CALL PRINT ROUTINE MACRO macro call_trace_routine_or_buffer , " call global_parameters.print_routine (event); " dcl global_parameters.print_routine entry (1 like event aligned); ldx0 =2a&2,du stx0 &1|event+event.kind lda pr4|global_parameters+global_parms.buffer_ptr cmpa packed_null tze CALL_TRACE_PRINT&U lprp1 pr4|global_parameters+global_parms.buffer_ptr ldaq pr1|buffer.h.version cmpaq BUFFER_VERSION_3 tnz trace_error_halt_$trace_error_halt_ lda pr1|buffer.h.count aos pr1|buffer.h.count ana =o017777,dl " mod 8192 als 4 " 16 words per event. epp1 pr1|buffer.e,al " pr1 -> buffer entry mlr (pr),(pr) desc9a &1|event,(event_size-2)*4 desc9a pr1|0,(event_size-2)*4 ldaq pr4|stop+meters.real_time staq pr1|event_size-2 " Put clock reading in last two words. ife &2,si mlr (),(pr) " Initialize so we can punt fast. desc9a UNUSUAL_SIGNAL_ARG_LIST,24 " "Unusual signal_ arg list" desc9a pr1|event.saved,24 " 24 is from event.saved to the clock. epp0 &1|ptr_registers_saved+2*0,* " PR0 -> argument list header. lxl0 pr0|0 " If arg_list.header.call_type cmpx0 4,du " ^= Interseg_call_type tnz SKIP_TRACE_PRINT&U " then punt. ldx0 pr0|1 " If arg_list.header.desc_count cmpx0 2,du " < 1 tmi SKIP_TRACE_PRINT&U " then punt. ldx0 pr0|0 " If arg_list.header.arg_count cmpx0 2,du " < 1 tmi SKIP_TRACE_PRINT&U " then punt. lda pr0|2,x0* " A = descriptor als 1 " Bit bucket = arg_descriptor.flag lrl 25 arl 5 " A = arg_descriptor.type cmpa 21,dl " If arg_descriptor.type ^= char_dtype tnz SKIP_TRACE_PRINT&U " then punt. qrl 12 " Q = arg_descriptor.size epp0 pr0|2,* " PR0 -> signal name. mlr (pr,rl),(pr),fill(040) desc9a pr0|0,ql desc9a pr1|event.saved,24 " 24 is from event.saved to the clock. ifend tra SKIP_TRACE_PRINT&U CALL_TRACE_PRINT&U: ldaq one_arg_list_header " call trace_print_$trace (event); staq arg_list.header ldaq pr4|global_parameters+global_parms.trace_routine+2 " Environment ptr. staq arg_list.second_arg_ptr eraq null_ptr anaq ptr_mask tze *+3 ldaq one_arg_list_header_w_env staq arg_list.header epp0 &1|event spri0 arg_list.first_arg_ptr call pr4|global_parameters+global_parms.trace_routine,*(arg_list.header) SKIP_TRACE_PRINT&U: &end " CHECK OR UPDATE WATCH TABLE MACRO " This macro either checks or updates the watch table, depending on its second " argument. It clobbers PR0, PR1, AQ, and X0. macro check_or_update_watch_table , ife &2,check stz &1|watch_values_changed ifend ife &2,update szn &1|watch_values_changed tze WATCH_TABLE_DONE&U ifend epp1 pr4|wt_ptr,* " Pr1 points to the table header. ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ lxl0 pr1|table.count WATCH_TABLE_LOOP&U: eax0 -1,x0 tmi WATCH_TABLE_DONE&U eaa 0,x0 ars 18 cmpa pr1|table.idx+idx.low " if idx - idx.low < 0 tmi *+3 " then actual_idx = idx; sba pr1|table.idx+idx.low " else actual_idx = idx - idx.low ada pr1|table.idx+idx.high " + idx.high; als 1 lprp0 pr1|table.e+te.key,al ldq pr0|0 cmpq pr1|table.e+te.data,al tze WATCH_TABLE_LOOP&U ife &2,check eaa TRUE sta &1|watch_values_changed ifend ife &2,update stq pr1|table.e+te.data,al tra WATCH_TABLE_LOOP&U ifend WATCH_TABLE_DONE&U: &end " TRACE IF NECESSARY MACRO macro trace_and_stop_if_necessary , szn pr4|global_parameters+global_parms.meter tnz DONT_CALL_ANYTHING&U lda pr2|tab.parms_ptr cmpa packed_null " If this entrypoint has been removed, tze DONT_CALL_ANYTHING&U " then don't trace it. szn pr2|tab.on " If this entrypoint is -off, tze DONT_CALL_ANYTHING&U " then don't trace it. szn pr4|global_parameters+global_parms.alm tnz *+4 lda pr2|tab.translator_id cmpa 1,dl " If tab.translator_id = ALM tze DONT_CALL_ANYTHING&U " then don't trace. inhibit off " <-> <-> <-> <-> <-> <-> <-> <-> <-> lprp3 pr2|tab.parms_ptr " pr3 = tab.parms_ptr; ldaq pr3|parms.version cmpaq PARAMETERS_VERSION_3 tnz trace_error_halt_$trace_error_halt_ lda pr3|parms.trace " Check inout. &^=&2,ca&[ als 1 &] tpl CHECK_WATCH_TABLE&U ldaq &1|event+event.saved.calls adl 1,dl " Get current count. staq arg_list.header " Save in strange temporary. szn pr3|parms.every " Is this parameter active? tze CHECK_FIRST&U lrs 34 " If mod (call_count, tab.every) ^= 0 dvf pr3|parms.every " then don't trace. lls 36 ldq arg_list.header+1 " Actually counts.calls+1. qls 1 dvf pr3|parms.every " Q = mod (saved calls, tab.every); qrs 0 " Set indicators from register Q. tnz CHECK_WATCH_TABLE&U CHECK_FIRST&U: lcaq arg_list.header " Actually counts.calls. adl pr3|parms.first " If tab.first - saved calls > 0 tpnz CHECK_WATCH_TABLE&U " then don't trace. szn pr3|parms.last tze *+4 " -last 0 means it is diasbled. lcaq arg_list.header " Actually counts.calls. adl pr3|parms.last " If parms.last - saved calls < 0 tmi CHECK_WATCH_TABLE&U " then don't trace. lda &1|event+event.saved.level ada 1,dl " Get current level. cmpa pr3|parms.low " If level - parms.low < 0 tmi CHECK_WATCH_TABLE&U " then don't trace. szn pr3|parms.high tze *+3 " -high 0 means it is diasbled. cmpa pr3|parms.high " If level - parms.high > 0 tpnz CHECK_WATCH_TABLE&U " then don't trace. szn pr3|parms.new_high " If -new_high is off tze *+3 " then skip this check. cmpa &1|event+event.saved.max_level tmoz CHECK_WATCH_TABLE&U " then don't trace. call_trace_routine_or_buffer &1,&2 CHECK_WATCH_TABLE&U: ine &2,un check_or_update_watch_table &1,check szn &1|watch_values_changed tnz STOP_IT&U lda pr3|parms.stop &^=&2,ca&[ als 1 &] tpl DONT_CALL_ANYTHING&U ldaq &1|event+event.saved.calls adl 1,dl " Get real counts.calls. staq arg_list.header " Use this as a temporary. szn pr3|parms.stop_every " Is this parameter active? tze CHECK_STOP_LOW&U lrs 34 " If mod (call_count, tab.every) ^= 0 dvf pr3|parms.stop_every " then don't stop. lls 36 ldq arg_list.header+1 " Actually counts.calls+1. qls 1 dvf pr3|parms.stop_every " Q = mod (saved calls, tab.every); qrs 0 " Set indicators from register Q. tnz DONT_CALL_ANYTHING&U CHECK_STOP_LOW&U: lda &1|event+event.saved.level ada 1,dl " Get current level. cmpa pr3|parms.stop_low " If level - parms.stop_low < 0 tmi DONT_CALL_ANYTHING&U " then don't stop. STOP_IT&U: call_stop_routine &1,&2 check_or_update_watch_table &1,update ifend inhibit on " <+> <+> <+> <+> <+> <+> <+> <+> <+> DONT_CALL_ANYTHING&U: &end macro is_tracing_permitted " Is tracing this entry point permitted? lda pr2|tab.translator_id " If tab.translator_id < 0, tmi &1 " then this program can't be traced. szn pr4|global_parameters+global_parms.alm tnz *+3 cmpa 1,dl " If tab.translator_id = ALM tze &1 " then don't trace. szn pr2|tab.on " If this entrypoint is -off, tze &1 " then don't trace it. &end macro pop_tab lda &1|event+event.saved.level " Revert tab.cts.level, tmi trace_error_halt_$trace_error_halt_ sta pr2|tab.cts+counts.level &end; " A FEW WORDS ABOUT THE STRUCTURE OF THE TRACE TABLES " The trace facility maintains four tables in the same format: " tt: The trace table itself, which has a maximum of 10,000 entries. " stt: The table of entrypoints specified by the trace command. " wt: The table locations being watched, with a maximum of 1024 entries. " swt: The table of locations specified by the watch_locations command. " Each table has an 8 word header that contains a version, the maximum number " of entries (max_count), and the current number of entries (count). The " table entries are two words each and are sorted into ascending order based " on the numeric value of the first word, which is known as the key. The " second word is known as the data. " In order to facilitate updating, the entries in a table are divided into two " halves. One half is at the low end of the table and the other half is at " the high end. When an entry is to be added to a table, entries are shifted " from one half to the other until the new entry can be added by appending it " to the high end of the low half. " The index of a table entry must be translated into the index of an element " in the table array. Both the array indexes and the table indexes are zero " relative. The first element of the table array is 0 and the index of the " last element is max_count - 1. If an entry is in the low half, the array " index is the same as the entry index. " There is a double word in the table header that describes the halvs. The " first word is called idx.low and the second word is called idx.high. " Idx.high is the array index of the first element in the high half. If it is " equal to max_count, there are no entries in the high half. Idx.low is the " number of entries in the low half. An entry is in the high half if its " entry index is >= idx.low. If an entry is in the high half, its array index " is its entry index - idx.low + idx.high. " There are three macros for manipulating these tables. " seek_table which finds an entry, given its key. " index_table which finds an entry, given its entry index. " normalize_table which moves entries until idx.low = entry index. " SEEK TABLE MACRO " This macro searches the trace or locations table for an entry or location. " It is called with: " PR1 -> table header, " Q containing the key being searched for. " If the entry is found, it returns to the FOUND label with: " PR2 -> the matching entry " X2 containing the entry index " A, X1, and table.working_storage clobbered. " If the entry is not found, it returns to the NOT_FOUND label with: " X2 containing the entry index it would have if it were added. " PR2, A, X1, and table.working_storage clobbered. " If the table is empty, it goes to the NOT_FOUND label with: " X2 = 0. " PR2, A, X1, and table.working_storage clobbered. macro seek_table " Syntax: seek_table FOUND,NOT_FOUND lda pr1|table.idx+idx.high als 1 epp2 pr1|table.e,al " Pr2 points to high half. lda pr1|table.max_count sba pr1|table.idx+idx.high " If table.max_count - idx.high = 0, tze SEEK_LOW&U " then the high half is empty. tmi trace_error_halt_$trace_error_halt_ cmpq pr2|te.key " If Q - table.e (idx.high) < 0 tmi SEEK_LOW&U tpnz BINARY_LOOP&U lxl2 pr1|table.idx+idx.low " Good luck. We found it. tra &1 SEEK_LOW&U: epp2 pr1|table.e " Pr2 points to low half. lda pr1|table.idx+idx.low " A = number of entries in low half. tpnz BINARY_LOOP&U " If A > 0, then do a binary search. tmi trace_error_halt_$trace_error_halt_ eax2 0 " else it's not in the table. tra &2 " The binary search uses pr2 to point to the group of remaining candidates. " It uses the A register to contain the number of remaining candidates. " During the search uses X2 to represent the offset to the middle of the candidates. BINARY_LOOP&U: " X2 contains offset that divides portion in half, eax2 -1,al " with the upper division being the larger one. tmi BINARY_NOT_FOUND&U " Quit, if the portion is zero length. anx2 =o777776,du " Truncate offset in x2 to a double word boundary. ars 1 " Calculate size of the portion for the next pass. cmpq pr2|te.key,x2 " If value we are looking for is LESS than value we tmi BINARY_LOOP&U " are looking at, then look again in LOWER division. epp2 pr2|te_size,x2 " If value we are looking for is MORE than value we tpnz BINARY_LOOP&U " are looking at, then look again in UPPER division. epp2 pr2|-te_size " Success! The binary search always eax1 &1 " succeeds with PR2 -> to the next entry. tra FIGURE_INDEX&U BINARY_NOT_FOUND&U: " The binary search always fails with eax1 &2 " PR2 -> entry where it should have been. FIGURE_INDEX&U: eaa pr1|table.e " Calculate the winning index. arl 19 sta pr1|table.working_storage eaa pr2|0 arl 19 sba pr1|table.working_storage eax2 0,al cmpa pr1|table.idx+idx.low " If index - idx.low <= 0, tmoz 0,x1 " then it is in the low half and we are done. sba pr1|table.idx+idx.high tmi trace_error_halt_$trace_error_halt_ ada pr1|table.idx+idx.low eax2 0,al " index = index - idx.high + idx.low; tra 0,x1 &end " INDEX TABLE MACRO " This macro assumes that: " PR1 -> table, " X2 = table index. " It finishes with: " PR2 -> the table entry specified by the index in X2, " A clobbered. macro index_table eaa 0,x2 ars 18 tmi trace_error_halt_$table_index_oob cmpa pr1|table.idx+idx.low " If table_index - idx.low > 0, tpl INDEX_HIGH&U " then get it from the high half. als 1 epp2 pr1|table.e,al tra INDEX_DONE&U INDEX_HIGH&U: sba pr1|table.idx+idx.low ada pr1|table.idx+idx.high " Q = array_index - idx.low + idx.high; cmpa pr1|table.max_count tpl trace_error_halt_$table_index_oob als 1 epp2 pr1|table.e,al INDEX_DONE&U: &end " NORMALIZE TABLE MACRO " This macro assumes that: " PR1 -> table " X2 contains an entry index. " It moves table entries until idx.low = X2, using the mlr or mrl instruction. " When it returns: " idx.low = X2. " PR2, PR3, AQ, and table.working_storage clobbered. macro normalize_table ldaq pr1|table.idx staq pr1|table.working_storage eaa 0,x2 ars 18 sba pr1|table.idx+idx.low "A = table_index - idx.low; tze TABLE_NORMALIZED&U " The table is already normalized. asa pr1|table.working_storage+idx.low " Working_storage is an image of asa pr1|table.working_storage+idx.high " what table.idx will be. ldq pr1|table.max_count sbq pr1|table.count " If table.max_count - table.count = 0, tze TABLE_NORMALIZED&U " then table is full, so just change idx. tmi trace_error_halt_$trace_error_halt_ ars 0 " Set the indicator registers from A. tpnz MOVE_HIGH_TO_LOW&U " If A > 0, move data down. MOVE_LOW_TO_HIGH&U: " If A < 0, move data up. ldaq pr1|table.working_storage lls 1 epp2 pr1|table.e,al " Pr2 -> table.e (idx.low). epp3 pr1|table.e,ql " Pr3 -> table.e (idx.high). lda pr1|table.idx+idx.low sba pr1|table.working_storage+idx.low als 3 " There are eight bytes per entry. mrl (pr,rl),(pr,rl) desc9a pr2|0,al desc9a pr3|0,al tra TABLE_NORMALIZED&U MOVE_HIGH_TO_LOW&U: ldaq pr1|table.idx lls 1 epp2 pr1|table.e,al " Pr2 -> table.e (idx.low). epp3 pr1|table.e,ql " Pr3 -> table.e (idx.high). lda pr1|table.working_storage+idx.low sba pr1|table.idx+idx.low als 3 " There are eight bytes per entry. mlr (pr,rl),(pr,rl) desc9a pr3|0,al desc9a pr2|0,al TABLE_NORMALIZED&U: ldaq pr1|table.working_storage staq pr1|table.idx &end " TABLE SEEK " dcl trace_catch_$table_seek entry (ptr, bit (36) aligned) returns (fixed bin); " table_index = trace_catch_$table_seek (table_ptr, key); segdef table_seek table_seek: get_pr4 epp1 pr0|2,* epp1 pr1|0,* " Pr1 points to the table header. ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ ldq pr0|4,* " Q reg contains the key we seek. seek_table TABLE_SEEK_FOUND,TABLE_SEEK_NOT_FOUND TABLE_SEEK_FOUND: eaa 0,x2 ars 18 sta pr0|6,* short_return " return (table_index); TABLE_SEEK_NOT_FOUND: lca 1,dl sta pr0|6,* short_return " return (-1) " TABLE GET " dcl trace_catch_$table_get entry (ptr, fixed bin) returns (1 like table_entry aligned); " table_entry = trace_catch_$table_get (table_ptr, table_index); segdef table_get table_get: get_pr4 epp1 pr0|2,* epp1 pr1|0,* " Pr1 points to the table header. ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ lxl2 pr0|4,* " X2 contains the index. index_table ldaq pr2|te epp3 pr0|6,* sta pr3|te.key stq pr3|te.data short_return " return (AQ); " TABLE PUT DATA " dcl trace_catch_$table_put_data entry (ptr, fixed bin, bit (36) aligned); " call trace_catch_$table_put_data (table_ptr, table_index, data); segdef table_put_data table_put_data: get_pr4 epp1 pr0|2,* epp1 pr1|0,* " Pr1 points to the table header. ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ lxl2 pr0|4,* " X2 contains the index. index_table ldq pr0|6,* stq pr2|te.data short_return " TABLE ADD " dcl trace_catch_$table_add entry (ptr, 1 like table_entry aligned) returns (fixed bin); " table_index = trace_catch_$table_add (table_ptr, table_entry); segdef table_add table_add: get_pr4 epp1 pr0|2,* epp1 pr1|0,* " Pr1 points to the table header. ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ ldq pr0|4,* " Q reg contains the key we seek. seek_table ADD_ENTRY_FOUND_IN_TABLE,TRY_LOW_HALF_APPEND ADD_ENTRY_FOUND_IN_TABLE: lca 1,dl sta pr0|6,* short_return " return (-1); TRY_LOW_HALF_APPEND: eaa 0,x2 ars 18 cmpa pr1|table.idx+idx.low " If index_we_want ^= idx.low tnz NORMALIZE_FOR_ADD cmpa pr1|table.idx+idx.high " If idx.low - idx.high >= 0, tpl trace_error_halt_$table_full " then the table is already full. als 1 epp2 pr1|table.e,al " PR2 -> where new entry will go. epp3 pr0|4,* lda pr3|te.key " Arg is not necessarily double word aligned. ldq pr3|te.data staq pr2|te " table.e (idx.low) = table_entry; lda pr1|table.idx+idx.low sta pr0|6,* " return (idx.low); inhibit on " <+> <+> <+> <+> <+> <+> <+> <+> <+> aos pr1|table.idx+idx.low " idx.low = idx.low + 1; aos pr1|table.count " table.count = table.count + 1; inhibit off " <-> <-> <-> <-> <-> <-> <-> <-> <-> short_return NORMALIZE_FOR_ADD: normalize_table tra TRY_LOW_HALF_APPEND " This will work now. " TABLE REMOVE " dcl trace_catch_$table_remove entry (ptr, fixed bin) returns (1 like te aligned); " te = trace_catch_$table_remove (table_ptr, table_index); segdef table_remove table_remove: get_pr4 epp1 pr0|2,* epp1 pr1|0,* " Pr1 points to the table header. ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ lxl2 pr0|4,* " X2 contains the index. index_table ldaq pr2|te " Store the return value. epp3 pr0|6,* sta pr3|te.key " Return arg is not necessarily stq pr3|te.data " double word aligned. normalize_table inhibit on " <+> <+> <+> <+> <+> <+> <+> <+> <+> aos pr1|table.idx+idx.high " idx.high = idx.high + 1; lca 1,dl asa pr1|table.count " table.count = table.count - 1; inhibit off " <-> <-> <-> <-> <-> <-> <-> <-> <-> short_return " The entry operators do a tsp2 to trace$catch_pl1_, so " " PR2 -> place to resume the entry operator. " " The entry operator uses the first two words after the end of the stack for " temporary storage. These two words must be restored before resuming the " operator. The following pl1 declaration shows what is stored there. " " dcl 1 saved aligned based (stack_header.stack_end_ptr), " 2 entry_ptr ptr unal, /* packed ptr to entry being traced */ " 2 pr1 ptr unal, /* not needed, but must be restored */ " Trace_catcher_ is a stub entry point for the benefit of debuggers. entry trace_catcher_ trace_catcher_: short_return segdef catch_pl1_ catch_pl1_: inhibit on <+> <+> <+> <+> <+> <+> <+> <+> <+> <+> get_pr4 " Read the calendar clock as soon as possible. read_the_calendar_clock stop " If tracing is inhibited, just resume the entry operator. szn pr7|stack_header.in_trace tnz pr2|0 " Getlp. This cutrate getlp uses PR4 and PR5 as temporaries since the " remainder of the entry operator will change them anyway. epp5 pr7|stack_header.stack_end_ptr,* " PR5 -> stack frame construction site. epp4 trace_catch_$trace_catcher_ " Let debuggers see a real entry point. spri4 pr5|stack_frame.entry_ptr " Push. spri6 pr5|stack_frame.prev_sp epp4 null_ptr,* spri4 pr5|stack_frame.arg_ptr get_pr4 spri4 pr5|stack_frame.lp_ptr epp6 pr5|0 epp5 pr6|stack_frame_size spri5 pr7|stack_header.stack_end_ptr spri5 pr6|stack_frame.next_sp " Save the cpu registers, and the two words where end of stack used to be, in a safe place. ldaq pr6|0 spri ptr_registers_saved sreg registers_saved sti indicators_saved " Read the meters. I wish it could have been done sooner. read_vcpu_time_and_page_faults stop " To whom it may concern: trace_catch_ is an alm program. eax7 1 stx7 pr6|stack_frame.translator_id " Establish a cleanup handler to undo changes to static data. epp0 =7acleanup " Initialize the on unit data block. spri0 cleanup_unit+on_unit.name epp0 PRELIMINARY_CLEANUP_HANDLER " It just resets stack_header.in_trace. spri0 cleanup_unit+on_unit.body ldq 7,dl stq cleanup_unit+on_unit.size stz cleanup_unit+on_unit.next equ cleanup_unit_offset,cleanup_unit eaa cleanup_unit_offset " Put it at the head of the list. sta pr6|stack_frame.on_unit_rel_ptrs lda stack_frame.condition_bit+stack_frame.support_bit,dl orsa pr6|stack_frame.flag_word " List is valid & this is a support frame. " Prevent recursion in case of calls or errors. eaa TRUE sta pr7|stack_header.in_trace " Calculate the meters and store them in the previously top trace_catch_ frame, " if there is one. ldaq pr7|stack_header.trace_frames staq trace_frames_saved tze SEEK_TAB_FOR_CALL lprp5 trace_frames_saved+trace_frames.top_ptr sba 1,dl " Make sure things are copacetic. cmpa pr5|trace_frames_saved+trace_frames.count tnz trace_error_halt_$trace_error_halt_ metering_interval_calculations pr5,entry SEEK_TAB_FOR_CALL: " Copy the packed pointer to the entry being traced from where the end of stack used to be. lda registers_saved+4 " This is where the sreg instruction puts A. sta event+event.entry_ptr " Get the tab for this entrypoint, if it is in the trace table. epp1 pr4|tt_ptr,* ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ ldq event+event.entry_ptr " Q reg contains the value we are looking for. seek_table EP_IS_IN_TT_AT_CALL,ADD_ENTRYPOINT EP_IS_IN_TT_AT_CALL: eaa 0,x2 ars 18 sta event+event.entry_idx lprp2 pr2|te.data tra HAVE_TAB ADD_ENTRYPOINT: lca 1,dl sta event+event.entry_idx epp2 null_ptr,* " Catch bugs early. " If the entry point is signal_$signal_ or signal_$io_signal, then trace as signal. ldq event+event.entry_ptr cmpq pr4|SIGNAL_ tze THIS_IS_A_SIGNAL cmpq pr4|IO_SIGNAL tze THIS_IS_A_SIGNAL " If -auto on, then add this entry point to the trace table. szn pr4|global_parameters+global_parms.automatic tze POP_TRACE_FRAME_AND_RESUME " If the entry point is trace_transactions_$transaction_begin, then skip it. cmpq pr4|TRANSACTION_BEGIN tze POP_TRACE_FRAME_AND_RESUME cmpq pr4|TRANSACTION_BEGIN_FORCE tze POP_TRACE_FRAME_AND_RESUME " call trace_entrypoints_$add_entrypoint (event+event.entry_ptr, pr2); ldaq two_arg_list_header staq arg_list.header epp0 event+event.entry_ptr spri0 arg_list.first_arg_ptr epp0 event+event.entry_idx spri0 arg_list.second_arg_ptr call trace_entrypoints_$add_entrypoint(arg_list.header) lxl2 event+event.entry_idx tmi POP_TRACE_FRAME_AND_RESUME epp1 pr4|tt_ptr,* ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ index_table lprp2 pr2|te.data tra HAVE_TAB THIS_IS_A_SIGNAL: szn pr4|global_parameters+global_parms.meter tnz POP_TRACE_FRAME_AND_RESUME szn pr4|global_parameters+global_parms.signals tze POP_TRACE_FRAME_AND_RESUME " Never trace signal_ as a procedure. TRACE_THIS_SIGNAL: fill_event_for_trace_or_signal call_trace_routine_or_buffer pr6,si tra POP_TRACE_FRAME_AND_RESUME " Never trace signal_ as a procedure. HAVE_TAB: ldaq pr2|tab.version cmpaq TAB_VERSION_3 tnz trace_error_halt_$trace_error_halt_ " Save the old counts before we start modifying them. ldaq pr2|tab.cts staq event+event.saved ldaq pr2|tab.cts+2 staq event+event.saved+2 " Count this entry whether we trace it or not. ldaq pr2|tab.cts+counts.calls adl 1,dl staq pr2|tab.cts+counts.calls " See if this entrypoint is traceable. is_tracing_permitted POP_TRACE_FRAME_AND_RESUME " Calculate the recursion level and maximum recursion level. lda pr2|tab.cts+counts.level ada 1,dl sta pr2|tab.cts+counts.level cmpa pr2|tab.cts+counts.max_level tmoz *+2 " if tab.cts.level - tab.cts.max_level > 0 sta pr2|tab.cts+counts.max_level " then tab.cts.max_level = tab.cts.level; " Initialize some values used by the cleanup handler. lls 72 " Initialize the meters. staq event+event.frame.real_time staq event+event.frame.vcpu_time stz event+event.frame.page_faults staq global_start.real_time staq global_start.vcpu_time stz global_start.page_faults " Turn on the full cleanup handler now. epp0 TRACE_CATCH_CLEANUP spri0 cleanup_unit+on_unit.body " Push this frame onto the stack of trace_catch_ frames. aos pr7|stack_header.trace_frames+trace_frames.count sprp6 pr7|stack_header.trace_frames+trace_frames.top_ptr " If we are not just metering, call the procedure that prints the tracing message. fill_event_for_trace_or_signal trace_and_stop_if_necessary pr6,ca " Start the global meters for this procedure if this is the first level of recursion. start_global_metering_interval pr6 " Start the metering interval. start_metering_interval entry " Establish the return point, like the call operator would. epp2 PROCEDURE_RETURN_POINT spri2 pr6|stack_frame.return_ptr sti pr6|stack_frame.return_ptr+1 " Restore registers. Ptr_registers_saved pr4 and pr6 contain trace_catch_'s lp and sp. lpri ptr_registers_saved lreg registers_saved ldi indicators_saved tra RESUME_ENTRY_OPERATOR " Control comes here when the entry point cannot be traced. POP_TRACE_FRAME_AND_RESUME: start_metering_interval entry " Restore registers. Ptr_registers_saved pr4 and pr6 contain trace_catch_'s lp and sp. lpri ptr_registers_saved lreg registers_saved ldi indicators_saved " Pop our stack frame. spri6 pr7|stack_header.stack_end_ptr epp6 pr6|stack_frame.prev_sp,* RESUME_ENTRY_OPERATOR: " Restore two words at stack end that were saved with the registers for the entry operator. staq pr7|stack_header.stack_end_ptr,* " Permit tracing again. stz pr7|stack_header.in_trace " We have postponed reading the clock until now for accurate metering. read_the_calendar_clock start " Resume the entry operator. tra pr2|0 " Control comes to this label when the procedure being traced does a return. PROCEDURE_RETURN_POINT: " First priority is reading the clock for accurate metering. epp4 pr6|stack_frame.lp_ptr,* read_the_calendar_clock stop " Save the cpu registers. spri ptr_registers_saved sreg registers_saved " Read the meters. read_vcpu_time_and_page_faults stop " Prevent recursion in case of calls or errors. The A register is never zero at this point. eaa TRUE sta pr7|stack_header.in_trace " Make sure we are where we think we are. sprp6 arg_list.header lda pr7|stack_header.trace_frames+trace_frames.top_ptr cmpa arg_list.header tnz trace_error_halt_$trace_error_halt_ " Calculate the elapsed meters and store them in this frame. metering_interval_calculations pr6,return " Get the tab_ptr, if this entrypoint is still in the trace table. epp1 pr4|tt_ptr,* ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ ldq event+event.entry_ptr " Q reg contains the value we are looking for. seek_table EP_IS_IN_TT_AT_RETURN,POP_TRACE_FRAME_AND_RETURN EP_IS_IN_TT_AT_RETURN: eaa 0,x2 ars 18 sta event+event.entry_idx lprp2 pr2|te.data ldaq pr2|tab.version cmpaq TAB_VERSION_3 tnz trace_error_halt_$trace_error_halt_ " If tracing is disabled, the operator pointers have been yanked. Pretend we arn't here. szn pr4|global_parameters+global_parms.enabled tze POP_TAB_AND_RETURN " See if this entrypoint can still be traced. The user could have turned it off while stopped. is_tracing_permitted POP_TAB_AND_RETURN " If we are not just metering, call the procedure that prints the tracing message. trace_and_stop_if_necessary pr6,re " Update the meters in the tab since this frame is about to be popped. update_tab_meters pr6 POP_TAB_AND_RETURN: pop_tab pr6 " Pop this trace_catch_ frame from the top of the stack of such frames. POP_TRACE_FRAME_AND_RETURN: ldaq trace_frames_saved staq pr7|stack_header.trace_frames " Start a metering interval, regardless of whether there is anything to meter. start_metering_interval return " If the end of the frame is not where it should be, because it has been " extended to hold the value of a returns (*) function, merge it with the " previous frame. eax0 pr6|stack_frame_size cmpx0 pr6|stack_frame.next_sp+1 tnz MERGE_FRAMES " Restore registers. Ptr_registers_saved pr4 and pr6 contain trace_catch_'s lp and sp. lpri ptr_registers_saved lreg registers_saved " Pop our stack frame. spri6 pr7|stack_header.stack_end_ptr epp6 pr6|stack_frame.prev_sp,* tra RETURN MERGE_FRAMES: " Restore registers. Ptr_registers_saved pr4 and pr6 contain trace_catch_'s lp and sp. lpri ptr_registers_saved lreg registers_saved ldaq pr7|stack_header.stack_end_ptr " Remember where this frame ends. epp6 pr6|stack_frame.prev_sp,* " Drop back to frame we are returning to. staq pr6|stack_frame.next_sp " Extend it to protect data in next frame. RETURN: epbp7 pr6|0 epp0 pr6|stack_frame.operator_ptr,* ldi pr6|stack_frame.return_ptr+1 " Permit tracing again. stz pr7|stack_header.in_trace " The read the clock as the last step for maximum accuracy. read_the_calendar_clock start rtcd pr6|stack_frame.return_ptr inhibit off <-> <-> <-> <-> <-> <-> <-> <-> <-> <-> " This preliminary cleanup handler just permits tracing again. PRELIMINARY_CLEANUP_HANDLER: stz pr7|stack_header.in_trace short_return " This code is invoked during stack unwinding. It calculates the meters for " the last interval, adds them to the tab and trace_catch_$metered, pops the " tab recursion level, pops the frame off the stack of trace_catch_ frames, " and resets stack_header.in_trace to permit tracing again. entry TRACE_CATCH_CLEANUP TRACE_CATCH_CLEANUP: inhibit on <+> <+> <+> <+> <+> <+> <+> <+> <+> <+> get_pr4 " Read the calendar clock as soon as possible. read_the_calendar_clock stop " Do what getlp does. epp5 pr7|stack_header.stack_end_ptr,* " PR5 -> stack frame construction site. epp3 trace_catch_$TRACE_CATCH_CLEANUP " Let debuggers see a real entry point. spri3 pr5|stack_frame.entry_ptr " Push. spri6 pr5|stack_frame.prev_sp spri0 pr5|stack_frame.arg_ptr spri4 pr5|stack_frame.lp_ptr epp6 pr5|0 epp5 pr6|stack_frame_size spri5 pr7|stack_header.stack_end_ptr spri5 pr6|stack_frame.next_sp " Read the meters. read_vcpu_time_and_page_faults stop " Prevent tracing of calls or errors during cleanup. eaa TRUE sta pr7|stack_header.in_trace " Put environment pointer from argument into pr5. epp0 pr6|stack_frame.arg_ptr,* lda pr0|0 eaq -1 cmk 8,dl " If there in no environment pointer, tnz trace_error_halt_$trace_error_halt_ " we can't go further. epp5 pr0|2,au* " Calculate the elapsed meters and store them in the frame being unwound. metering_interval_calculations pr5,entry " Get the tab_ptr, if this entrypoint is still in the trace table. epp1 pr4|tt_ptr,* ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ ldq pr5|event+event.entry_ptr " Q reg contains the value we are looking for. seek_table EP_IS_IN_TT_AT_UNWIND,POP_TRACE_FRAME_AT_UNWIND EP_IS_IN_TT_AT_UNWIND: eaa 0,x2 ars 18 sta pr5|event+event.entry_idx lprp2 pr2|te.data ldaq pr2|tab.version cmpaq TAB_VERSION_3 tnz trace_error_halt_$trace_error_halt_ " If tracing is disabled, the operator pointers have been yanked. Pretend we arn't here. szn pr4|global_parameters+global_parms.enabled tze POP_TAB_AT_UNWIND " See if this entrypoint can still be traced. The user could have turned it off while stopped. is_tracing_permitted POP_TAB_AT_UNWIND " Call the procedure that prints the tracing message, if appropriate. trace_and_stop_if_necessary pr5,un " Move the meters to the tab. update_tab_meters pr5 POP_TAB_AT_UNWIND: " Restore the recursion level in the tab. pop_tab pr5 POP_TRACE_FRAME_AT_UNWIND: epp2 null_ptr,* " For safety. " Pop this frame off the stack of trace_catch_ frames. ldaq pr5|trace_frames_saved staq pr7|stack_header.trace_frames " Permit tracing again. We don't expect any errors from the few operations below. stz pr7|stack_header.in_trace " Start a metering interval, regardless of whether there is anything to meter. start_metering_interval return " Pop our stack frame. spri6 pr7|stack_header.stack_end_ptr epp6 pr6|stack_frame.prev_sp,* " Return. epbp7 pr6|0 epp0 pr6|stack_frame.operator_ptr,* ldi pr6|stack_frame.return_ptr+1 " The read the clock as the last step for maximum accuracy. read_the_calendar_clock start rtcd pr6|stack_frame.return_ptr inhibit off <-> <-> <-> <-> <-> <-> <-> <-> <-> <-> " This entrypoint disables the trace facility by yanking the trace operator " pointers from the stack header. It then flushes the frame and global meters " from all the trace_catch_ frames on the stack. It is " only called if trace is enabled at the beginning of the transaction. " dcl trace_catch_$stop_tracing entry (); " call trace_catch_$stop_tracing (); segdef stop_tracing stop_tracing: get_pr4 " See if trace is disabled or effectively disabled. szn pr4|global_parameters+global_parms.enabled tze STOP_SHORT_RETURN szn pr4|global_parameters+global_parms.automatic tnz YANK_OP_PTRS szn pr4|global_parameters+global_parms.signals tnz YANK_OP_PTRS epp1 pr4|tt_ptr,* ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ szn pr1|table.count tnz YANK_OP_PTRS STOP_SHORT_RETURN: short_return " Yank the pl1, ALM, and other language operator pointers from the stack header. YANK_OP_PTRS: epp5 pl1_operators_$operator_table spri5 pr7|stack_header.pl1_operators_ptr epp5 operator_pointers_$operator_pointers_ spri5 pr7|stack_header.trans_op_tv_ptr epp5 pl1_operators_$alm_entry spri5 pr7|stack_header.entry_op_ptr call6 trace_catch_$STOP_TRACING " Its nice to be able to act like a regular ALM program. entry STOP_TRACING STOP_TRACING: push " Go down the stack of trace_catch_ frames and update the global meters. lda pr7|stack_header.trace_frames+trace_frames.count lprp5 pr7|stack_header.trace_frames+trace_frames.top_ptr FLUSH_METERS_FROM_THIS_FRAME: tze ALL_FRAMES_FLUSHED sba 1,dl cmpa pr5|trace_frames_saved+trace_frames.count tnz trace_error_halt_$trace_error_halt_ " Get the tab_ptr, if this entrypoint is still in the trace table. epp1 pr4|tt_ptr,* ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ ldq pr5|event+event.entry_ptr " Q reg contains the value we are looking for. seek_table EP_IS_IN_TT_AT_STOP,FLUSH_NEXT_FRAME EP_IS_IN_TT_AT_STOP: lprp2 pr2|te.data ldaq pr2|tab.version cmpaq TAB_VERSION_3 tnz trace_error_halt_$trace_error_halt_ " Add the meters to the tab and to trace_catch_$metered. update_tab_meters pr5 FLUSH_NEXT_FRAME: lda pr5|trace_frames_saved+trace_frames.count lprp5 pr5|trace_frames_saved+trace_frames.top_ptr tra FLUSH_METERS_FROM_THIS_FRAME ALL_FRAMES_FLUSHED: return " This entrypoint is called at the end of a trace command transaction to plant " the operator pointers and restart global metering. It is only called if " trace is enabled at the end of the transaction. It plants the operators and " reads the meters into trace_catch_$start. " dcl trace_catch_$start_tracing entry (); " call trace_catch_$start_tracing (); entry start_tracing start_tracing: push " See if trace is disabled or effectively disabled. szn pr4|global_parameters+global_parms.enabled tze START_RETURN szn pr4|global_parameters+global_parms.automatic tnz RESTART_METERS szn pr4|global_parameters+global_parms.signals tnz RESTART_METERS epp1 pr4|tt_ptr,* ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ szn pr1|table.count tze START_RETURN " Go down the stack of trace_catch_ frames and restart the global meters. RESTART_METERS: lda pr7|stack_header.trace_frames+trace_frames.count lprp5 pr7|stack_header.trace_frames+trace_frames.top_ptr START_METERS_IN_THIS_FRAME: tze ALL_FRAMES_STARTED sba 1,dl cmpa pr5|trace_frames_saved+trace_frames.count tnz trace_error_halt_$trace_error_halt_ " Get the tab_ptr, if this entrypoint is still in the trace table. epp1 pr4|tt_ptr,* ldaq pr1|table.version cmpaq TT_VERSION_3 tnz trace_error_halt_$trace_error_halt_ ldq pr5|event+event.entry_ptr " Q reg contains the value we are looking for. seek_table EP_IS_IN_TT_AT_START,START_NEXT_FRAME EP_IS_IN_TT_AT_START: lprp2 pr2|te.data ldaq pr2|tab.version cmpaq TAB_VERSION_3 tnz trace_error_halt_$trace_error_halt_ " Reset the global meters for this procedure if this is the first level of recursion. start_global_metering_interval pr5 START_NEXT_FRAME: lda pr5|trace_frames_saved+trace_frames.count lprp5 pr5|trace_frames_saved+trace_frames.top_ptr tra START_METERS_IN_THIS_FRAME " Plant the pl1 and other language operator pointers in the stack header. ALL_FRAMES_STARTED: epp5 pl1_operators_$trace_operator_table spri5 pr7|stack_header.pl1_operators_ptr epp5 trace_operator_pointers_$trace_operator_pointers_ spri5 pr7|stack_header.trans_op_tv_ptr " Plant the ALM operator only if alm is on. szn pr4|global_parameters+global_parms.alm tze *+3 epp5 pl1_operators_$trace_alm_entry spri5 pr7|stack_header.entry_op_ptr START_RETURN: return " CONSTANTS CONSTANTS CONSTANTS CONSTANTS CONSTANTS CONSTANTS CONSTANTS even BUFFER_VERSION_3: aci /TraceBF3/,8 even EVENT_VERSION_3: aci /TEV3/,4 even TT_VERSION_3: aci /TraceTT3/,8 even TAB_VERSION_3: aci /TraceTB3/,8 even PARAMETERS_VERSION_3: aci /TraceTP3/,8 even GLOBAL_PARAMETERS_VERSION_3: aci /TraceGP3/,8 even UNUSUAL_SIGNAL_ARG_LIST: aci /Unusual signal_ arg list/,24 even zero_arg_list_header: oct 000000000004,000000000000 one_arg_list_header: oct 000002000004,000000000000 two_arg_list_header: oct 000004000004,000000000000 three_arg_list_header: oct 000006000004,000000000000 four_arg_list_header: oct 000010000004,000000000000 five_arg_list_header: oct 000012000004,000000000000 one_arg_list_header_w_env: oct 000002000010,000000000000 two_arg_list_header_w_env: oct 000004000010,000000000000 three_arg_list_header_w_env: oct 000006000010,000000000000 four_arg_list_header_w_env: oct 000010000010,000000000000 five_arg_list_header_w_env: oct 000012000010,000000000000 null_ptr: oct 077777000043,000001000000 ptr_mask: oct 077777000077,777777077077 double_precision_one: dec 0,1 vcpu_time_fuzz: dec 0,16 packed_null: oct 007777000001 " INTERNAL STATIC INTERNAL STATIC INTERNAL STATIC INTERNAL STATIC INTERNAL STATIC use static_section join /link/static_section TRANSACTION_BEGIN: oct 007777000001 TRANSACTION_BEGIN_FORCE: oct 007777000001 SIGNAL_: oct 007777000001 IO_SIGNAL: oct 007777000001 even start: dec 0,0,0,0,0 start_comp: dec 0 " UPPER HALF WORD even stop: dec 0,0,0,0,0 even delta: dec 0,0,0,0,0 even segdef metered metered: dec 0,1,0,1,1 even segdef removed removed: dec 0,1,0,1,1 even segdef trace_storage_ptr trace_storage_ptr: its -1,1 even segdef tt_ptr tt_ptr: its -1,1 even segdef wt_ptr wt_ptr: its -1,1 segdef parameters_ptr parameters_ptr: oct 007777000001 even segdef global_parameters bss global_parameters,182 " SYMBOLS SYMBOLS SYMBOLS SYMBOLS SYMBOLS SYMBOLS SYMBOLS SYMBOLS bool TRUE,400000 " " Structure table " equ table.version,0 " DOUBLE equ table.max_count,2 equ table.count,3 equ table.idx,4 " LEVEL 2 equ idx.low,0 equ idx.high,1 equ table.working_storage,6 " DOUBLE equ table.e,8 " DOUBLE " " Structure te " equ te_size,2 equ te,0 " DOUBLE equ te.key,0 equ te.data,1 " " Structure tab " equ tab.version,0 " DOUBLE equ tab.reference_count,2 equ tab.parms_ptr,3 equ tab.cts,4 " like counts equ tab.local,8 " like meters equ tab.on,13 equ tab.global,14 " like meters equ tab.translator_id,19 equ tab.function,20 " " Structure event is a 16 word block that describes a trace event. " equ event_size,16 equ event.version,0 equ event.kind,1 " UPPER equ event.frame_count,1 " LOWER equ event.frame,2 " LEVEL 2 equ event.frame.real_time,2 " DOUBLE equ event.frame.vcpu_time,4 " DOUBLE equ event.frame.page_faults,6 equ event.entry_ptr,7 equ event.saved,8 " LEVEL 2 equ event.saved.calls,8 " DOUBLE equ event.saved.level,10 equ event.saved.max_level,11 equ event.entry_idx,12 equ event.arg_list_ptr,13 equ event.callers_sp,14 equ event.return_ptr,15 " " Structure counts is passed to the trace and stop routines. " equ counts.calls,0 " DOUBLE equ counts.level,2 equ counts.max_level,3 " " Structure buffer of trace events. " equ buffer.h,0 " LEVEL 2 equ buffer.h.version,0 " DOUBLE equ buffer.h.not_used,2 equ buffer.h.count,3 equ buffer.e,4 " (0 : 8191) like event " " Structure meters " equ meters.real_time,0 " DOUBLE equ meters.vcpu_time,2 " DOUBLE equ meters.page_faults,4 " " Structure parms " equ parms.version,0 " DOUBLE equ parms.reference_count,2 equ parms.every,3 equ parms.first,4 equ parms.last,5 equ parms.low,6 equ parms.high,7 equ parms.new_high,8 equ parms.arguments,9 equ parms.not_used1,10 equ parms.stop_every,11 equ parms.stop_low,12 equ parms.stop,13 equ parms.trace,14 equ parms.call_ptr,15 " " Structure global_parms (182 words) " equ global_parms.version,0 " DOUBLE equ global_parms.alm,2 equ global_parms.automatic,3 equ global_parms.meter,4 equ global_parms.signals,5 equ global_parms.enabled,6 equ global_parms.long,7 equ global_parms.osw,8 " LEVEL 2 equ global_parms.osw.iocb_ptr,8 equ global_parms.osw.stream_name,10 equ global_parms.osw.file_path,19 equ global_parms.spp,84 " LEVEL 2 equ global_parms.spp.entry_value,84 equ global_parms.spp.entry_name,88 equ global_parms.trace_routine,154 equ global_parms.stop_routine,158 equ global_parms.loud,162 equ global_parms.calibrate,163 equ global_parms.buffer_ptr,164 equ global_parms.not_used,165 equ global_parms.comps,166 " LEVEL 2 equ from_entry,0 equ from_return,8 equ to_entry.real_time,0 equ to_entry.vcpu_time,2 equ to_return.real_time,4 equ to_return.vcpu_time,6 include stack_header include stack_frame include on_unit end  trace_conversions_.pl1 10/23/84 1334.6rew 10/23/84 1219.1 32193 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This program contains data conversion logic for the trace facility. Written: May 1984 by Jeffrey D. Ives. */ /* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */ trace_conversions_: procedure (); signal error; cv_inout_to_bits: entry (char8_i) returns (bit (2) aligned); char8 = char8_i; if char8 = "on" | char8 = "inout" | char8 = "both" then return ("11"b); else if char8 = "off" | char8 = "none" | char8 = "neither" then return ("00"b); else if char8 = "in" then return ("10"b); else if char8 = "out" then return ("01"b); else call sub_err_ (error_table_$bad_arg, trace_$me (), ACTION_CANT_RESTART, null (), rv, "I don't understand ""^a"". I was expecting in, out, on, or off.", char8); cv_bits_to_inout: entry (bit2_i) returns (char (8) aligned); bit2 = bit2_i; if bit2 = "00"b then return ("off"); else if bit2 = "01"b then return ("out"); else if bit2 = "10"b then return ("in"); else if bit2 = "11"b then return ("on"); else signal error; cv_n_to_number: entry (char16_i) returns (fixed bin (34)); char16 = char16_i; on conversion, size call sub_err_ (error_table_$bad_arg, trace_$me (), ACTION_CANT_RESTART, null (), rv, "I can not interpret ""^a"" as a number between 0 and ^d.", char16, MAX_34_BIT_NUMBER); (size): number = convert (number, char16); if number < 0 | number > MAX_34_BIT_NUMBER then call sub_err_ (error_table_$bad_arg, trace_$me (), ACTION_CANT_RESTART, null (), rv, "I can not interpret ""^a"" as a number between 0 and ^d.", char16, MAX_34_BIT_NUMBER); return (number); cv_onoff_to_bit: entry (char8_i) returns (bit aligned); char8 = char8_i; if char8 = "on" then return ("1"b); else if char8 = "off" then return ("0"b); else call sub_err_ (error_table_$bad_arg, trace_$me (), ACTION_CANT_RESTART, null (), rv, "I don't understand ""^a"". I was expecting on, or off.", char8); cv_bit_to_onoff: entry (bit1_i) returns (char (8) aligned); if bit1_i then return ("on"); else return ("off"); %page; /* START OF DEC_LARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl bit1_i bit aligned parm; dcl bit2_i bit (2) aligned parm; dcl char8_i char (8) aligned parm; dcl char16_i char (16) parm; /* Automatic */ dcl bit2 bit (2) aligned; dcl char8 char (8) aligned; dcl char16 char (16); dcl code fixed bin (35); dcl number fixed bin (35); dcl rv fixed bin (35); /* Static */ dcl MAX_34_BIT_NUMBER fixed bin (35) static options (constant) init (17179869183); dcl ZERO fixed bin (35) static options (constant) init (0); /* Conditions */ dcl conversion condition; dcl error condition; dcl size condition; /* Based */ /* External Variables */ dcl error_table_$bad_arg fixed bin (35) ext; /* External Entries */ dcl sub_err_ entry () options (variable); /* format: insnl,delnl */ /* END OF DECLARATIONS */ %page; /* START OF INCLUDE FILES */ %include sub_err_flags; %page; %include trace_interface; end trace_conversions_;  trace_entrypoints_.pl1 05/01/86 0830.8rew 05/01/86 0805.9 172170 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-03-13,GWMay), approve(86-04-16,MCR7373), audit(86-04-29,LJAdams), install(86-05-01,MR12.0-1051): Changed to reference entry_desc_info_version_2 constant. END HISTORY COMMENTS */ /* This program converts entrypoint names into pointers and vice versa. Written: May 1984 by Jeffrey D. Ives. */ /* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */ trace_entrypoints_: procedure (); dcl (addr, addrel, baseno, before, bin, codeptr, index, maxlength, null, pointer, rel, reverse, rtrim, search, substr, unspec) builtin; signal error; get_path_name: entry (entry_ptr_i) returns (char (256) var); call hcs_$fs_get_path_name (pointer (entry_ptr_i, 0), pathname.dir, (0), pathname.ent, code); if code ^= 0 then do; call sub_err_ (code, trace_$me (), ACTION_DEFAULT_RESTART, null (), rv, "I could not get the path name of ^p.", pointer (entry_ptr_i, 0)); pathname.dir = "?"; pathname.ent = "?"; end; return (rtrim (pathname.dir) || ">" || rtrim (pathname.ent)); %page; add_entrypoint: /* Called from trace_catch_. */ entry (entry_ptr_i) returns (fixed bin); entry_ptr = entry_ptr_i; on any_other go to ADD_ENTRYPOINT_PUNT; segment = SEGMENT (entry_ptr); object = OBJECT (segment); entry_ptr_offset = bin (rel (entry_ptr), 18); if entry_ptr_offset < 2 | entry_ptr -> word (1) = ALM_TSP2_PR7_UP_38_STAR then do; /* if alm then search definitions */ definition = DEFINITION (object, object.defp); do while (^(definition.section = "text" & definition.offset = entry_ptr_offset)); if definition.section = "eof" then go to ADD_ENTRYPOINT_PUNT; definition = DEFINITION (object, definition.next_def); end; entry_name = ENTRY_NAME (object, definition); end; else do; /* assume standard entry sequence -> definition */ defptr = addrel (object.defp, addrel (entry_ptr, -2) -> entry_sequence.def_relp); entry_name = ENTRY_NAME (object, DEFINITION (object, defptr)); end; return ( trace_tables_$add_entrypoint (entry_ptr, entry_name, TRANSLATOR_ID (entry_ptr, entry_name), FUNCTION (entry_ptr)) ); ADD_ENTRYPOINT_PUNT: revert any_other; call hcs_$fs_get_path_name (pointer (entry_ptr, 0), pathname.dir, (0), pathname.ent, code); if code = 0 then entry_name = rtrim (pathname.ent) || "$" || OCTAL (rel (entry_ptr)); else entry_name = OCTAL (baseno (entry_ptr)) || "$" || OCTAL (rel (entry_ptr)); return (trace_tables_$add_entrypoint (entry_ptr, entry_name, -1, "0"b)); %page; specify_entrypoints: entry (char256var_i, referencing_ptr_i); if char256var_i = "*" then do; call trace_tables_$specify_all_entrypoints (); return; end; desired = DESIRED (char256var_i); entry_ptr = codeptr (cv_entry_ (desired.path, referencing_ptr_i, code)); if code ^= 0 then begin; /* try looking for seg name in trace table */ dcl tt_count fixed bin; dcl tt_idx fixed bin; tt_count = trace_$num_entrypoints (); do tt_idx = 0 by 1 while (code = error_table_$seg_not_found & tt_idx < tt_count); if before (trace_$entrypoint_name (tt_idx), "$") = desired.segment_symbol then do; entry_ptr = pointer (trace_$entrypoint_ptr (tt_idx), 0); code = 0; end; end; if code ^= 0 then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", char256var_i); end; segment = SEGMENT (entry_ptr); object = OBJECT (segment); if desired.offset_symbol ^= "*" then begin; /* try get_definition_ first */ dcl get_definition_ entry (ptr, char (*), char (*), ptr, fixed bin (35)); call get_definition_ (object.defp, (desired.segment_symbol), (desired.offset_symbol), defptr, code); if code = 0 then do; definition = DEFINITION (object, defptr); entry_ptr = addrel (object.textp, definition.offset); entry_name = ENTRY_NAME (object, definition); call trace_tables_$specify_entrypoint (entry_ptr, entry_name, TRANSLATOR_ID (entry_ptr, entry_name), FUNCTION (entry_ptr)); return; end; end; definition = DEFINITION (object, object.defp); /* get primary or bind file name */ do while (definition.flags.a_ignore & definition.section ^= "eof"); definition = DEFINITION (object, definition.next_def); end; if definition.section ^= "segn" then call sub_err_ (error_table_$no_ext_sym, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", char256var_i); n_specified = 0; if ^object.format.bound | substr (definition.symbol, 1, definition.symbol_lng) = desired.segment_symbol then do; definition = DEFINITION (object, definition.block_ptr); do while (definition.section ^= "eof"); if definition.section = "text" & definition.offset ^= 0 then do; if desired.offset_symbol = "*" | substr (definition.symbol, 1, definition.symbol_lng) = desired.offset_symbol then do; entry_ptr = addrel (object.textp, definition.offset); entry_name = ENTRY_NAME (object, definition); call trace_tables_$specify_entrypoint (entry_ptr, entry_name, TRANSLATOR_ID (entry_ptr, entry_name), FUNCTION (entry_ptr)); n_specified = n_specified + 1; end; end; definition = DEFINITION (object, definition.next_def); end; end; else do; /* look for the component to trace */ definition = DEFINITION (object, definition.next_def); do while ( ^(definition.section = "segn" & substr (definition.symbol, 1, definition.symbol_lng) = desired.segment_symbol)) ; if definition.section = "eof" then call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv, "The segment symbol ""^a"" was not found in the segment ""^a"".", desired.segment_symbol, desired.path); definition = DEFINITION (object, definition.next_def); end; definition = DEFINITION (object, definition.block_ptr); do while (^(definition.section = "segn" | definition.section = "eof")); if definition.section = "text" & definition.offset ^= 0 then do; if desired.offset_symbol = "*" | substr (definition.symbol, 1, definition.symbol_lng) = desired.offset_symbol then do; entry_ptr = addrel (object.textp, definition.offset); entry_name = ENTRY_NAME (object, definition); call trace_tables_$specify_entrypoint (entry_ptr, entry_name, TRANSLATOR_ID (entry_ptr, entry_name), FUNCTION (entry_ptr)); n_specified = n_specified + 1; end; end; definition = DEFINITION (object, definition.next_def); end; end; if n_specified = 0 then call sub_err_ (error_table_$no_ext_sym, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", char256var_i); return; %page; /* SUBROUTINES */ DESIRED: proc (char256var_i) returns (1 like desired aligned); dcl char256var_i char (256) var parm; dcl jj fixed bin; dcl kk fixed bin; dcl 1 des like desired aligned; des.path = char256var_i; des.pathl = length (rtrim (des.path)); des.segment_symbol = ""; des.offset_symbol = ""; if des.pathl = 0 then call sub_err_ (error_table_$smallarg, trace_$me (), ACTION_CANT_RESTART, null (), rv, """"""); jj = search (reverse (substr (des.path, 1, des.pathl)), "<>"); if jj = 1 then call sub_err_ (error_table_$badpath, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", des.path); if jj = 0 /* point jj to first char in seg name */ then jj = 1; else jj = des.pathl - jj + 2; kk = search (substr (des.path, jj, des.pathl - jj + 1), "$|"); if kk = 1 | kk = des.pathl - jj + 1 /* shouldn't be first or last */ then call sub_err_ (error_table_$bad_arg, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", des.path); if kk = 0 then do; if des.pathl - jj + 1 > maxlength (des.segment_symbol) | des.pathl - jj + 1 > maxlength (des.offset_symbol) then call sub_err_ (error_table_$bigarg, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", des.path); des.segment_symbol = substr (des.path, jj, des.pathl - jj + 1); des.offset_symbol = substr (des.path, jj, des.pathl - jj + 1); des.pathl = des.pathl + 2; substr (des.path, des.pathl - 1, 2) = "$0"; /* for cv_entry_ */ end; else do; if kk - 1 > maxlength (des.segment_symbol) | des.pathl - jj + 1 - kk > maxlength (des.offset_symbol) then call sub_err_ (error_table_$bigarg, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", des.path); des.segment_symbol = substr (des.path, jj, kk - 1); des.offset_symbol = substr (des.path, jj + kk, des.pathl - jj + 1 - kk); des.pathl = jj + kk; substr (des.path, des.pathl) = "0"; end; if jj > 1 /* if there are "<>" characters */ then substr (des.path, des.pathl - 1, 1) = "|"; return (des); end DESIRED; SEGMENT: proc (entry_ptr_i) returns (1 like segment aligned); dcl entry_ptr_i ptr unal; dcl 1 seg like segment aligned; dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); seg.base_ptr = pointer (entry_ptr, 0); call hcs_$status_mins (seg.base_ptr, seg.entry_type, seg.bit_count, code); if code ^= 0 then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "I could not get the status of ""^p"".", seg.base_ptr); if seg.entry_type ^= 1 /* 1 means segment. */ then call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^p"" does not point to a segment.", seg.base_ptr); return (seg); end SEGMENT; OBJECT: proc (segment_i) returns (1 like object_info aligned); dcl 1 segment_i like segment aligned parm; dcl 1 oi like object_info aligned; dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); unspec (oi) = ""b; oi.version_number = object_info_version_2; call object_info_$brief (segment_i.base_ptr, segment_i.bit_count, addr (oi), code); if code ^= 0 then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, """^a""", get_path_name ((segment.base_ptr))); return (oi); end OBJECT; DEFINITION: proc (object_i, defptr_i) returns (1 like definition aligned); dcl defptr_i ptr parm; dcl 1 object_i like object_info aligned; dcl 1 def like definition aligned; dcl decode_definition_$full entry (ptr, ptr, ptr) returns (bit aligned); if decode_definition_$full ((defptr_i), addr (def), addr (object_i)) then do; unspec (def) = ""b; def.next_def = null (); def.last_def = null (); def.block_ptr = null (); def.section = "eof"; def.descr_ptr = null (); end; else if def.section = "text" then begin; /* strip off component name if necessary */ dcl kk fixed bin; kk = index (substr (def.symbol, 1, def.symbol_lng), "$"); if kk > 0 then do; def.symbol_lng = def.symbol_lng - kk; def.symbol = substr (def.symbol, kk + 1, def.symbol_lng); end; end; return (def); end DEFINITION; ENTRY_NAME: proc (object_i, offset_definition_i) returns (char (65) var); dcl 1 object_i like object_info aligned parm; dcl 1 offset_definition_i like definition aligned parm; dcl 1 segment_definition like definition aligned; segment_definition = DEFINITION (object_i, offset_definition_i.block_ptr); if segment_definition.section = "eof" then call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv, "There seems to be something wrong with the definition of ^a.", substr (offset_definition_i.symbol, 1, offset_definition_i.symbol_lng)); return (substr (segment_definition.symbol, 1, segment_definition.symbol_lng) || "$" || substr (offset_definition_i.symbol, 1, offset_definition_i.symbol_lng)); end ENTRY_NAME; OCTAL: proc (half_word_i) returns (char (32) var); dcl half_word_i bit (18) aligned parm; dcl char32var char (32) var; dcl dummy fixed bin; call ioa_$rsnnl ("^o", char32var, dummy, half_word_i); return (char32var); end OCTAL; FUNCTION: proc (entry_ptr_i) returns (bit aligned); dcl entry_ptr_i ptr unal parm; dcl desc_ptrs (1) ptr; dcl 1 edi like entry_desc_info aligned; dcl get_entry_arg_descs_$info entry (ptr, fixed bin, (*) ptr, ptr, fixed bin (35)); entry_desc_info_ptr = addr (edi); unspec (entry_desc_info) = ""b; entry_desc_info.version = entry_desc_info_version_2; call get_entry_arg_descs_$info ((entry_ptr_i), (0), desc_ptrs, entry_desc_info_ptr, (0)); return (entry_desc_info.flags.function); %include entry_desc_info; end FUNCTION; TRANSLATOR_ID: proc (entry_ptr_i, entry_name_i) returns (fixed bin); dcl entry_ptr_i ptr unal parm; dcl entry_name_i char (65) var parm; dcl translator_id fixed bin; dcl entry_name char (65); dcl entry_ptr ptr; dcl link_trap_caller_ entry (); dcl unwind_stack_ entry (); dcl unwinder_ entry (); entry_name = entry_name_i; entry_ptr = entry_ptr_i; if entry_ptr -> word (1) = ALM_TSP2_PR7_UP_38_STAR then translator_id = 1; else translator_id = 0; if (entry_ptr -> word (2) ^= PL1_FORTRAN_EPP2_PR7_UP_28_STAR & entry_ptr -> word (2) ^= COBOL_EPP2_PR7_UP_40_STAR & entry_ptr -> word (1) ^= ALM_TSP2_PR7_UP_38_STAR) | (entry_ptr -> word (1) = ALM_TSP2_PR7_UP_38_STAR & (entry_name = "ssu_$standalone_invocation" | substr (entry_name, 1, 4) = "cu_$" | substr (entry_name, 1, 9) = "formline_" | substr (entry_name, 1, 5) = "lisp_" | substr (entry_name, 1, 15) = "nonlocal_goto_$" | substr (entry_name, 1, 11) = "condition_$")) | entry_ptr = codeptr (link_trap_caller_) | entry_ptr = codeptr (unwind_stack_) | entry_ptr = codeptr (unwinder_) | entry_name = "ssu_invocation_$create_standalone" | substr (entry_name, 1, 11) = "pascal_io_$" | substr (entry_name, 1, 24) = "pascal_area_management_$" | substr (entry_name, 1, 12) = "pascal_time$" | substr (entry_name, 1, 15) = "pascal_errors_$" | substr (entry_name, 1, 5) = "probe" | substr (entry_name, 1, 10) = "cobol_rts_" | substr (entry_name, 1, 11) = "fortran_io_" | substr (entry_name, 1, 14) = "cobol_control_" then translator_id = -1; return (translator_id); end TRANSLATOR_ID; %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl char256var_i char (256) var parm; dcl entry_ptr_i ptr unal parm; dcl referencing_ptr_i ptr parm; /* Automatic */ dcl code fixed bin (35); dcl defptr ptr; dcl entry_name char (65) var; dcl entry_ptr ptr unal; dcl entry_ptr_offset fixed bin (18); dcl n_specified fixed bin; dcl rv fixed bin (35); dcl 1 desired aligned, 2 path char (300) unal, 2 pathl fixed bin, 2 segment_symbol char (32) var unal, 2 offset_symbol char (32) var unal; dcl 1 pathname aligned, 2 dir char (168) unal, 2 ent char (32) unal; dcl 1 segment aligned, 2 base_ptr ptr, 2 entry_type fixed bin (2), 2 bit_count fixed bin (24); dcl 1 definition aligned, /* structure filled in by full entry */ 2 next_def ptr, /* ptr to next definition in list */ 2 last_def ptr, /* ptr to previous definition in list */ 2 block_ptr ptr, /* ptr to either defblock or segname block */ 2 section char (4), /* "text", "link", "symb" or "segn" */ 2 offset fixed bin (18), /* offset within class (if ^= "segn") */ 2 entrypoint fixed bin (18), /* value of entrypoint in text if ^= 0 */ 2 symbol char (256), /* the symbolic name of the definition */ 2 symbol_lng fixed bin, /* the actual length of symbol */ 2 flags, /* same flags as in std def */ 3 a_new_format bit unaligned, /* def is in new format */ 3 a_ignore bit unaligned, /* linker should ignore this def */ 3 a_entrypoint bit unaligned, /* def is for entrypoint */ 3 a_retain bit unaligned, 3 a_arg_count bit unaligned, /* there is an arg count for entry */ 3 a_descr_sw bit unaligned, /* there are valid descriptors for entry */ 3 unused bit (12) unaligned, 2 n_args fixed bin, /* # of args entry expects */ 2 descr_ptr ptr; /* ptr to array of rel ptrs to descriptors for entry */ dcl 1 entry_sequence aligned based, 2 descr_relp_offset bit (18) unal, 2 reserved bit (18) unal, 2 def_relp bit (18) unal, 2 flags bit (18) unal; dcl 1 object like object_info aligned; /* Static */ dcl ALM_TSP2_PR7_UP_38_STAR bit (36) aligned static options (constant) init ("700046272120"b3); /* ALM entry point */ dcl COBOL_EPP2_PR7_UP_40_STAR bit (36) aligned static options (constant) init ("700050352120"b3); /* COBOL entry point */ dcl PL1_FORTRAN_EPP2_PR7_UP_28_STAR bit (36) aligned static options (constant) init ("700034352120"b3); /* PL/I or FORTRAN entry point */ dcl ZERO fixed bin (35) static options (constant) init (0); dcl length builtin; /* Conditions */ dcl any_other condition; dcl error condition; /* Based */ dcl word (3) bit (36) aligned based; /* External Variables */ dcl error_table_$bad_arg fixed bin (35) ext; dcl error_table_$badpath fixed bin (35) ext; dcl error_table_$bigarg fixed bin (35) ext; dcl error_table_$no_ext_sym fixed bin (35) ext; dcl error_table_$seg_not_found fixed bin (35) ext; dcl error_table_$smallarg fixed bin (35) ext; /* External Entries */ dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl ioa_$rsnnl entry () options (variable); dcl trace_tables_$add_entrypoint entry (ptr unal, char (65) var, fixed bin, bit aligned) returns (fixed bin); dcl trace_tables_$specify_all_entrypoints entry (); dcl trace_tables_$specify_entrypoint entry (ptr unal, char (65) var, fixed bin, bit aligned); dcl sub_err_ entry () options (variable); /* format: insnl,delnl */ /* END OF DECLARATIONS */ %page; /* START OF INCLUDE FILES */ %include object_info; %include sub_err_flags; %page; %include trace_interface; end trace_entrypoints_;  trace_meters.pl1 01/11/85 1045.4rew 01/11/85 1034.9 123165 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* Fall//79, Robert E. Mullen, Initial coding. 06/29/81, Jeffrey D. Ives, added SUB TOTALs. 03/29/82, Jeffrey D. Ives, added -bf and -of and made trace table 0 relative. 07/22/83, Jeffrey D. Ives, for new tab with bigger vcpu and real time fields. Added VCPU/CALL. May 1984, Jeffrey D. Ives, get rid of tab altogether and go to new interface. */ /* format: style2,^inddcls,^indnoniterdo,^inditerdo,dclind5,idind35 */ trace_meters: tmt: procedure options (variable); /* DISABLE TRACE_CATCH_ */ transaction_id = clock (); on cleanup call TRACE_METERS_CLEANUP (); if ^trace_$transaction_begin (transaction_id) /* Temporarily disables trace_catch_. */ then do; call com_err_ (code, ME, "There seems to be an incomplete invocation of trace, watch, or trace_meters still on the stack. Try the release command."); return; end; %page; /* read the arguments */ call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, ME); go to RETURN; end; ARG_READING_LOOP: do arg_idx = 1 to arg_count; call cu_$arg_ptr (arg_idx, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, ME); go to RETURN; end; if arg = "-brief" | arg = "-bf" then long_format = "0"b; else if arg = "-long" | arg = "-lg" then long_format = "1"b; else if arg = "-reset" | arg = "-rs" then do; reset = "1"b; report = "0"b; end; else if arg = "-report_reset" | arg = "-rr" then do; reset = "1"b; report = "1"b; end; else if arg = "-output_file" | arg = "-of" then do; control_arg = arg; arg_idx = arg_idx + 1; call cu_$arg_ptr (arg_idx, arg_ptr, arg_length, code); if code ^= 0 then do; BAD_FILE_PATH_ARG: call com_err_ (code, ME, " A pathname must follow ^a.", control_arg); go to RETURN; end; if arg = "" then go to BAD_FILE_PATH_ARG; if substr (arg, 1, 1) = "-" then go to BAD_FILE_PATH_ARG; call expand_pathname_$add_suffix (arg, "tmt", output_file.dir_path, output_file.entry_name, code); if code ^= 0 then do; call com_err_ (code, ME, " The argument in error is ""^a"".", arg); go to RETURN; end; end; else if arg = "-percent" | arg = "-pct" | arg = "-%" then do; minimum.kind = "local"; go to GET_PERCENTAGE; end; else if arg = "-global_percent" | arg = "-gpct" | arg = "-g%" then do; minimum.kind = "global"; GET_PERCENTAGE: control_arg = arg; arg_idx = arg_idx + 1; call cu_$arg_ptr (arg_idx, arg_ptr, arg_length, code); if code ^= 0 then do; BAD_PERCENTAGE_ARG: call com_err_ (code, ME, " A number between 0 and 100 must follow ^a.", control_arg); go to RETURN; end; if arg = "" then go to BAD_PERCENTAGE_ARG; if substr (arg, 1, 1) = "-" then go to BAD_PERCENTAGE_ARG; numeric_arg = cv_dec_check_ (arg, code); if code ^= 0 then do; call com_err_ (ZERO, ME, " Decimal conversion error at ""^a"" in ""^a"".", substr (arg, code, 1), arg); code = 0; go to BAD_PERCENTAGE_ARG; end; if numeric_arg < 0 | numeric_arg > 100 then go to BAD_PERCENTAGE_ARG; minimum.percent = numeric_arg; end; else do; call com_err_ (error_table_$badopt, ME, """^a""", arg); go to RETURN; end; end ARG_READING_LOOP; %page; /* Open the output file if necessary. */ if output_file.entry_name = "" then output_file.iocb_ptr = iox_$user_output; else OPEN_OUTPUT_FILE: do; call iox_$attach_name (unique_chars_ (""b), output_file.iocb_ptr, "vfile_ " || rtrim (output_file.dir_path) || ">" || rtrim (output_file.entry_name), codeptr (trace_meters), code); if code ^= 0 then do; call com_err_ (code, ME, " Coult not attach the file ""^a>^a"".", output_file.dir_path, output_file.entry_name); go to RETURN; end; call iox_$open (output_file.iocb_ptr, Stream_output, "0"b, code); if code ^= 0 then do; call com_err_ (code, ME, " Could not open the file ""^a>^a"".", output_file.dir_path, output_file.entry_name); go to RETURN; end; end OPEN_OUTPUT_FILE; /* Do some consistency checks. */ metered = trace_$metered () - trace_$removed (); if metered.real_time < 0 | metered.vcpu_time > metered.real_time | metered.page_faults < 0 then call com_err_ (ZERO, ME, " The meters are inconsistent. Metered real time is ^d, vcpu time is ^d, and page faults are ^d.", metered.real_time, metered.vcpu_time, metered.page_faults); /* Calculate the percentage coefficients. */ if metered.vcpu_time = 0 then percentage_coefficient.vcpu_time = 0; else percentage_coefficient.vcpu_time = 1e2 / float (metered.vcpu_time, 27); if metered.page_faults = 0 then percentage_coefficient.page_faults = 0; else percentage_coefficient.page_faults = 1e2 / float (metered.page_faults, 27); %page; /* Print the requested information. */ totals = 0; tt_count = trace_$num_entrypoints (); TOTAL_LOOP: do tt_idx = 0 by 0 to tt_count - 1; segment_being_subtotaled.seg_num = baseno (trace_$entrypoint_ptr (tt_idx)); segment_being_subtotaled.dir_path = "?"; segment_being_subtotaled.entry_name = "?"; subtotals = 0; SUB_TOTAL_LOOP: do tt_idx = tt_idx to tt_count - 1 while (baseno (trace_$entrypoint_ptr (tt_idx)) = segment_being_subtotaled.seg_num); counts = trace_$entrypoint_counts (tt_idx); local_meters = trace_$entrypoint_local_meters (tt_idx); global_meters = trace_$entrypoint_global_meters (tt_idx); if ^report then go to END_SUB_TOTAL_LOOP; if counts.calls = 0 then go to END_SUB_TOTAL_LOOP; if minimum.kind = "local" then if float (local_meters.vcpu_time, 27) * percentage_coefficient.vcpu_time < minimum.percent & float (local_meters.page_faults, 27) * percentage_coefficient.page_faults < minimum.percent then go to END_SUB_TOTAL_LOOP; if minimum.kind = "global" then if float (global_meters.vcpu_time, 27) * percentage_coefficient.vcpu_time < minimum.percent & float (global_meters.page_faults, 27) * percentage_coefficient.page_faults < minimum.percent then go to END_SUB_TOTAL_LOOP; /* Print column headers if necessary */ if subtotals.line_count = 0 then do; if long_format then do; call PRINT_METERS_HEADER ("G"); call PRINT_METERS_HEADER ("L"); call expand_pathname_ ((trace_$entrypoint_seg_path (tt_idx)), segment_being_subtotaled.dir_path, segment_being_subtotaled.entry_name, code); if code ^= 0 then segment_being_subtotaled.dir_path, segment_being_subtotaled.entry_name = "?"; call ioa_$ioa_switch (output_file.iocb_ptr, " ^a>^a", segment_being_subtotaled.dir_path, segment_being_subtotaled.entry_name); end; if ^long_format & totals.line_count = 0 then do; call PRINT_METERS_HEADER ("L"); call ioa_$ioa_switch (output_file.iocb_ptr, " ENTRY POINT NAME"); end; end; /* Print the stats for this entrypoint. */ if long_format then call PRINT_METERS (global_meters); call PRINT_METERS (local_meters); call PRINT_STATS (local_meters.vcpu_time, counts.calls); call ioa_$ioa_switch (output_file.iocb_ptr, " ^a", trace_$entrypoint_name (tt_idx)); subtotals.line_count = subtotals.line_count + 1; subtotals.calls = subtotals.calls + counts.calls; subtotals.meters = subtotals.meters + local_meters; END_SUB_TOTAL_LOOP: end SUB_TOTAL_LOOP; if report & long_format & subtotals.line_count >= 1 then do; if subtotals.line_count >= 2 then call PRINT_TOTAL_LINE (subtotals, "SUBTOTAL", segment_being_subtotaled.entry_name); call ioa_$ioa_switch (output_file.iocb_ptr, ""); end; totals = totals + subtotals; end TOTAL_LOOP; if report then do; if long_format then call PRINT_METERS_HEADER (" "); else call ioa_$ioa_switch (output_file.iocb_ptr, ""); call PRINT_METERS_HEADER ("L"); call ioa_$ioa_switch (output_file.iocb_ptr, ""); call date_time_ (clock (), date_time_string); call PRINT_TOTAL_LINE (totals, "TOTAL", date_time_string); end; if reset then call trace_$reset_meters (); RETURN: call TRACE_METERS_CLEANUP; return; %page; /* SUBROUTINES */ TRACE_METERS_CLEANUP: proc; if output_file.iocb_ptr ^= null () & output_file.iocb_ptr ^= iox_$user_output then do; call iox_$close (output_file.iocb_ptr, (0)); call iox_$detach_iocb (output_file.iocb_ptr, (0)); output_file.iocb_ptr = null (); end; if ^trace_$transaction_end (transaction_id) /* Re-enable trace_catch_. */ then call com_err_ (ZERO, ME, "The trace_meters command ended abnormally."); end TRACE_METERS_CLEANUP; PRINT_TOTAL_LINE: proc (totals_i, comment_1_i, comment_2_i); if long_format then call PRINT_METERS_HEADER (" "); call PRINT_METERS (totals_i.meters); call PRINT_STATS (totals_i.meters.vcpu_time, totals_i.calls); call ioa_$ioa_switch (output_file.iocb_ptr, " ^a ^a", comment_1_i, comment_2_i); dcl 1 totals_i aligned parm like totals; dcl comment_1_i char (*) parm; dcl comment_2_i char (*) parm; end PRINT_TOTAL_LINE; PRINT_METERS_HEADER: proc (leading_letter_i); if leading_letter_i = " " then call ioa_$ioa_switch_nnl (output_file.iocb_ptr, "^24x"); else call ioa_$ioa_switch_nnl (output_file.iocb_ptr, " ^aREAL ^aVCPU ^aPF^[ LVCPU/CALL LVCPU% CALLS^]", leading_letter_i, leading_letter_i, leading_letter_i, leading_letter_i = "L"); dcl leading_letter_i char parm; end PRINT_METERS_HEADER; PRINT_METERS: proc (meters_i); if meters_i.real_time = 0 & meters_i.vcpu_time = 0 & meters_i.page_faults = 0 then call PRINT_METERS_HEADER (" "); else call ioa_$ioa_switch_nnl (output_file.iocb_ptr, "^9.3f ^8.3f ^5d", float (meters_i.real_time, 27) * 1e-6, float (meters_i.vcpu_time, 27) * 1e-6, meters_i.page_faults); dcl 1 meters_i aligned parm like local_meters; end PRINT_METERS; PRINT_STATS: proc (vcpu_time_i, calls_i); if vcpu_time_i = 0 | calls_i = 0 then call ioa_$ioa_switch_nnl (output_file.iocb_ptr, " ^10x ^5x ^7d", calls_i); else call ioa_$ioa_switch_nnl (output_file.iocb_ptr, " ^10.6f ^5.1f ^7d", (float (vcpu_time_i, 27) / float (calls_i, 27)) * 1e-6, float (vcpu_time_i, 27) * percentage_coefficient.vcpu_time, calls_i); dcl vcpu_time_i fixed bin (53) parm; dcl calls_i fixed bin (53) parm; end PRINT_STATS; %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ /* Automatic */ dcl arg_count fixed bin; dcl arg_idx fixed bin; dcl arg_length fixed bin (21); dcl arg_ptr ptr init (null ()); dcl code fixed bin (35) init (0); dcl control_arg char (32); dcl date_time_string char (24); dcl in_trace_saved bit (36) aligned; dcl long_format bit aligned init ("1"b); dcl numeric_arg fixed bin (35); dcl report bit aligned init ("1"b); dcl reset bit aligned init ("0"b); dcl transaction_id fixed bin (71); dcl tt_count fixed bin; dcl tt_idx fixed bin; dcl 1 local_meters like meters aligned; dcl 1 global_meters like meters aligned; dcl 1 metered like meters aligned; dcl 1 minimum aligned, 2 kind char (8) init (""), 2 percent float bin (27) init (0); dcl 1 output_file aligned, 2 iocb_ptr ptr init (null ()), 2 dir_path char (168) unal init (""), 2 entry_name char (32) unal init (""); dcl 1 percentage_coefficient aligned, 2 vcpu_time float bin (27), 2 page_faults float bin (27); dcl 1 totals aligned, 2 line_count fixed bin, 2 calls fixed bin (53), 2 meters like meters; dcl 1 subtotals aligned like totals; dcl 1 segment_being_subtotaled aligned, 2 seg_num bit (18), 2 dir_path char (168) unal, 2 entry_name char (32) unal; /* Static */ dcl ME char (32) static options (constant) init ("trace_meters"); dcl ZERO fixed bin (35) static options (constant) init (0); /* Conditions */ dcl cleanup condition; /* Based */ dcl arg char (arg_length) based (arg_ptr); /* External Variables */ dcl error_table_$badopt fixed bin (35) ext; dcl iox_$user_output ptr ext; /* External Entries */ dcl com_err_ entry () options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl ioa_$ioa_switch entry () options (variable); dcl ioa_$ioa_switch_nnl entry () options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* format: insnl,delnl */ /* END OF DECLARATIONS */ %page; /* START OF INCLUDE FILES */ %page; %include iox_modes; %page; %include trace_interface; end trace_meters;  trace_parameters_.pl1 10/23/84 1334.7rew 10/23/84 1219.1 269550 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This program stores and fetches trace parameters and global parameters. Written: May 1984 by Jeffrey D. Ives. */ /* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */ trace_parameters_: procedure (); signal error; /* INITIALIZE */ initialize: entry (); trace_catch_$global_parameters = INITIAL_GLOBAL_PARAMETERS; trace_catch_$global_parameters.osw = trace_$cv_stream_name_to_osw (INITIAL_GLOBAL_PARAMETERS.osw.stream_name); trace_catch_$global_parameters.spp = trace_$cv_entry_name_to_spp (INITIAL_GLOBAL_PARAMETERS.spp.entry_name, codeptr (trace_parameters_)); trace_catch_$global_parameters.trace_routine = trace_print_$trace; trace_catch_$global_parameters.stop_routine = trace_print_$stop; trace_$global_parameters.version = ""; allocate parameters in (trace_storage); parameters = INITIAL_PARAMETERS; call ASSIGN_PTR (trace_catch_$parameters_ptr, parameters_ptr); call ASSIGN_PTR (trace_$parameters_ptr, parameters_ptr); trace_catch_$global_parameters.calibrate = "1"b; call trace_calibrate_ ("recurse", trace_catch_$global_parameters.comps (COMPENSATION_FROM_ENTRY_TO_ENTRY), trace_catch_$global_parameters.comps (COMPENSATION_FROM_RETURN_TO_RETURN)); call trace_calibrate_ ("repeat", trace_catch_$global_parameters.comps (COMPENSATION_FROM_ENTRY_TO_RETURN), trace_catch_$global_parameters.comps (COMPENSATION_FROM_RETURN_TO_ENTRY)); trace_catch_$global_parameters.calibrate = "0"b; return; %page; /* TRANSACTIONS */ transaction_begin: entry (transaction_id_i); if trace_catch_$global_parameters.version ^= GLOBAL_PARAMETERS_VERSION_3 then signal error; if trace_$global_parameters.version ^= "" then signal error; if trace_catch_$parameters_ptr -> parameters.version ^= PARAMETERS_VERSION_3 then signal error; if trace_$parameters_ptr ^= trace_catch_$parameters_ptr then signal error; return; transaction_begin_force: transaction_end: entry (transaction_id_i); trace_$global_parameters.version = ""; /* This will show that they are not modified yet. */ call ASSIGN_PTR (trace_$parameters_ptr, trace_catch_$parameters_ptr); return; /* UPDATES */ update_default_parms: entry () returns (bit aligned); if OBJECTS_ARE_EQUAL (trace_catch_$parameters_ptr, trace_$parameters_ptr) then return ("0"b); call ASSIGN_PTR (trace_catch_$parameters_ptr, trace_$parameters_ptr); return ("1"b); update_global_parms: entry () returns (bit aligned); if trace_$global_parameters.version = "" then return ("0"b); if trace_$global_parameters.version ^= GLOBAL_PARAMETERS_VERSION_3 then signal error; if unspec (trace_$global_parameters) = unspec (trace_catch_$global_parameters) then return ("0"b); if trace_$global_parameters.osw.iocb_ptr ^= trace_catch_$global_parameters.osw.iocb_ptr then call trace_print_$copy_osw (trace_$global_parameters.osw, trace_catch_$global_parameters.osw); if trace_$global_parameters.buffer_ptr ^= trace_catch_$global_parameters.buffer_ptr then call trace_print_$copy_buffer_ptr (trace_$global_parameters.buffer_ptr, trace_catch_$global_parameters.buffer_ptr); trace_catch_$global_parameters = trace_$global_parameters; return ("1"b); free_parameters: entry (parms_ptr_io); call FREE_OBJECT (parms_ptr_io); return; parms_specified: entry () returns (bit aligned); if OBJECTS_ARE_EQUAL (trace_catch_$parameters_ptr, trace_$parameters_ptr) then return ("0"b); else return ("1"b); update_parameters: entry (parms_ptr_io) returns (bit aligned); if parms_ptr_io = trace_$parameters_ptr /* Optimization. */ then return ("0"b); if OBJECTS_ARE_EQUAL (parms_ptr_io, trace_$parameters_ptr) then return ("0"b); call ASSIGN_PTR (parms_ptr_io, trace_$parameters_ptr); return ("1"b); %page; /* TRACE PARAMETERS */ arguments: entry (tt_idx_i) returns (bit (2) aligned); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (parameters.arguments); set_arguments: entry (inout_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); parameters.arguments = inout_i; return; call: entry (tt_idx_i) returns (char (256) var); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); allocated_string_ptr = parameters.call_ptr; if allocated_string_ptr = null () then return (""); else return (allocated_string.value); set_call: entry (char256var_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); allocated_string_value_length = length (char256var_i); if allocated_string_value_length > 256 then signal error; allocate allocated_string in (trace_storage); allocated_string.version = ALLOCATED_STRING_VERSION_3; allocated_string.reference_count = 0; allocated_string.value = char256var_i; call ASSIGN_PTR (parameters.call_ptr, allocated_string_ptr); return; every: entry (tt_idx_i) returns (fixed bin (34)); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (parameters.every); set_every: entry (number_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); parameters.every = number_i; return; first: entry (tt_idx_i) returns (fixed bin (34)); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (parameters.first); set_first: entry (number_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); parameters.first = number_i; return; high: entry (tt_idx_i) returns (fixed bin (34)); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (parameters.high); set_high: entry (number_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); parameters.high = number_i; return; last: entry (tt_idx_i) returns (fixed bin (34)); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (parameters.last); set_last: entry (number_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); parameters.last = number_i; return; low: entry (tt_idx_i) returns (fixed bin (34)); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (parameters.low); set_low: entry (number_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); parameters.low = number_i; return; new_high: entry (tt_idx_i) returns (bit aligned); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (parameters.new_high); set_new_high: entry (onoff_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); parameters.new_high = onoff_i; return; parms_string: entry (tt_idx_i, just_differences_i) returns (char (256) var); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (MAKE_PARAMETERS_STRING (parameters_ptr, trace_catch_$parameters_ptr, just_differences_i)); stop: entry (tt_idx_i) returns (bit (2) aligned); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (parameters.stop); set_stop: entry (inout_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); parameters.stop = inout_i; return; stop_every: entry (tt_idx_i) returns (fixed bin (34)); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (parameters.stop_every); set_stop_every: entry (number_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); parameters.stop_every = number_i; return; stop_low: entry (tt_idx_i) returns (fixed bin (34)); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (parameters.stop_low); set_stop_low: entry (number_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); parameters.stop_low = number_i; return; trace: entry (tt_idx_i) returns (bit (2) aligned); tt_idx = tt_idx_i; if tt_idx < 0 then parameters_ptr = trace_catch_$parameters_ptr; else parameters_ptr = trace_tables_$parameters_ptr (tt_idx); return (parameters.trace); set_trace: entry (inout_i); parameters_ptr = MODIFIED_PARAMETERS_PTR (); parameters.trace = inout_i; return; %page; /* GLOBAL PARAMETERS */ alm: entry () returns (bit aligned); return (trace_catch_$global_parameters.alm); set_alm: entry (onoff_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.alm = onoff_i; return; automatic: entry () returns (bit aligned); return (trace_catch_$global_parameters.automatic); set_automatic: entry (onoff_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.automatic = onoff_i; return; buffer: entry () returns (bit aligned); return (trace_catch_$global_parameters.buffer_ptr ^= null ()); buffer_ptr: entry () returns (ptr unal); return (trace_catch_$global_parameters.buffer_ptr); set_buffer: entry (onoff_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; if onoff_i = "1"b then call trace_print_$allocate_buffer (trace_$global_parameters.buffer_ptr); else trace_$global_parameters.buffer_ptr = null (); return; calibrate: entry () returns (bit aligned); return (trace_catch_$global_parameters.calibrate); set_calibrate: entry (onoff_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.calibrate = onoff_i; return; compensation: entry (compensation_idx_i) returns (1 aligned like compensation); compensation_idx = compensation_idx_i; if compensation_idx < lbound (trace_catch_$global_parameters.comps, 1) | compensation_idx > hbound (trace_catch_$global_parameters.comps, 1) then signal error; return (trace_catch_$global_parameters.comps (compensation_idx)); set_compensation: entry (compensation_idx_i, compensation_i); compensation_idx = compensation_idx_i; if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; if compensation_idx < lbound (trace_$global_parameters.comps, 1) | compensation_idx > hbound (trace_$global_parameters.comps, 1) then signal error; trace_$global_parameters.comps (compensation_idx) = compensation_i; return; enabled: entry () returns (bit aligned); return (trace_catch_$global_parameters.enabled); set_enabled: entry (onoff_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.enabled = onoff_i; return; global_parms_changed: entry () returns (bit aligned); if trace_$global_parameters.version = GLOBAL_PARAMETERS_VERSION_3 then return ("1"b); else return ("0"b); global_parms_string: entry () returns (char (256) var); return (MAKE_GLOBAL_PARAMETERS_STRING (trace_catch_$global_parameters)); long: entry () returns (bit aligned); return (trace_catch_$global_parameters.long); set_long: entry (onoff_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.long = onoff_i; return; loud: entry () returns (bit aligned); return (trace_catch_$global_parameters.loud); set_loud: entry (onoff_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.loud = onoff_i; return; meter: entry () returns (bit aligned); return (trace_catch_$global_parameters.meter); set_meter: entry (onoff_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.meter = onoff_i; return; output_switch: entry () returns (1 like output_switch); return (trace_catch_$global_parameters.osw); set_output_switch: entry (output_switch_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.osw = output_switch_i; if trace_$global_parameters.osw.iocb_ptr = null () then trace_$global_parameters.osw = trace_$cv_stream_name_to_osw (INITIAL_GLOBAL_PARAMETERS.osw.stream_name); return; signals: entry () returns (bit aligned); return (trace_catch_$global_parameters.signals); set_signals: entry (onoff_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.signals = onoff_i; return; stop_proc: entry () returns (1 like stop_proc aligned); return (trace_catch_$global_parameters.spp); set_stop_proc: entry (stop_proc_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.spp = stop_proc_i; if codeptr (trace_$global_parameters.spp.entry_value) = null () then trace_$global_parameters.spp = trace_$cv_entry_name_to_spp (INITIAL_GLOBAL_PARAMETERS.spp.entry_name, codeptr (trace_parameters_)); return; trace_routine: entry () returns (entry); return (trace_catch_$global_parameters.trace_routine); set_trace_routine: entry (entrypoint_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.trace_routine = entrypoint_i; return; stop_routine: entry () returns (entry); return (trace_catch_$global_parameters.stop_routine); set_stop_routine: entry (entrypoint_i); if trace_$global_parameters.version = "" then trace_$global_parameters = trace_catch_$global_parameters; trace_$global_parameters.stop_routine = entrypoint_i; return; %page; /* SUBROUTINES */ ASSIGN_PTR: proc (destination_ptr_io, source_ptr_i); dcl (destination_ptr_io, source_ptr_i) ptr unal parm; dcl goner_ptr ptr unal; if destination_ptr_io = source_ptr_i then return; goner_ptr = destination_ptr_io; if source_ptr_i ^= null () then source_ptr_i -> allocated_string.reference_count = source_ptr_i -> allocated_string.reference_count + 1; destination_ptr_io = source_ptr_i; call FREE_OBJECT (goner_ptr); end ASSIGN_PTR; MODIFIED_PARAMETERS_PTR: proc () returns (ptr unal); dcl p ptr unal; if trace_$parameters_ptr = trace_catch_$parameters_ptr then do; allocate parameters in (trace_storage) set (p); p -> parameters = trace_catch_$parameters_ptr -> parameters; p -> parameters.reference_count = 0; p -> parameters.call_ptr = null (); call ASSIGN_PTR (p -> parameters.call_ptr, trace_catch_$parameters_ptr -> parameters.call_ptr); call ASSIGN_PTR (trace_$parameters_ptr, p); end; return (trace_$parameters_ptr); end MODIFIED_PARAMETERS_PTR; FREE_OBJECT: proc (object_ptr_io); dcl object_ptr_io ptr unal parm; dcl object_ptr ptr unal; object_ptr = object_ptr_io; if object_ptr = null () then return; object_ptr_io = null (); object_ptr -> allocated_string.reference_count = object_ptr -> allocated_string.reference_count - 1; if object_ptr -> allocated_string.reference_count > 0 then return; if object_ptr -> allocated_string.reference_count < 0 then signal error; if object_ptr -> allocated_string.version = ALLOCATED_STRING_VERSION_3 then ; else if object_ptr -> allocated_string.version = PARAMETERS_VERSION_3 then call FREE_OBJECT (object_ptr -> parameters.call_ptr); else signal error; free object_ptr -> allocated_string; return; end FREE_OBJECT; OBJECTS_ARE_EQUAL: proc (A_ptr_io, B_ptr_io) returns (bit aligned); dcl (A_ptr_io, B_ptr_io) ptr unal parm; if A_ptr_io = B_ptr_io then return ("1"b); if A_ptr_io = null () | B_ptr_io = null () then return ("0"b); if A_ptr_io -> allocated_string.version ^= B_ptr_io -> allocated_string.version then signal error; if A_ptr_io -> allocated_string.version = ALLOCATED_STRING_VERSION_3 then do; if A_ptr_io -> allocated_string.value_length ^= B_ptr_io -> allocated_string.value_length then return ("0"b); if A_ptr_io -> allocated_string.value ^= B_ptr_io -> allocated_string.value then return ("0"b); end; else if A_ptr_io -> allocated_string.version = PARAMETERS_VERSION_3 then do; if ^OBJECTS_ARE_EQUAL (A_ptr_io -> parameters.call_ptr, B_ptr_io -> parameters.call_ptr) then return ("0"b); if unspec (A_ptr_io -> parameters) ^= unspec (B_ptr_io -> parameters) then return ("0"b); end; else signal error; /* Combine them. */ if A_ptr_io -> allocated_string.reference_count <= B_ptr_io -> allocated_string.reference_count then call ASSIGN_PTR (A_ptr_io, B_ptr_io); else call ASSIGN_PTR (B_ptr_io, A_ptr_io); return ("1"b); end OBJECTS_ARE_EQUAL; %page; MAKE_PARAMETERS_STRING: proc (A_parms_ptr_i, B_parms_ptr_i, just_differences_i) returns (char (256) var); if A_parms_ptr_i = null () then return ("no parms"); if A_parms_i.version ^= PARAMETERS_VERSION_3 | B_parms_i.version ^= PARAMETERS_VERSION_3 then signal error; just_differences = just_differences_i; many_parm_string = ""; call APPEND_INOUT_PARAMETER (A_parms_i.trace, B_parms_i.trace, "trace"); call APPEND_N_PARAMETER (A_parms_i.every, B_parms_i.every, "every"); call APPEND_N_PARAMETER (A_parms_i.first, B_parms_i.first, "first"); call APPEND_N_PARAMETER (A_parms_i.last, B_parms_i.last, "last"); call APPEND_N_PARAMETER (A_parms_i.low, B_parms_i.low, "low"); call APPEND_N_PARAMETER (A_parms_i.high, B_parms_i.high, "high"); call APPEND_ONOFF_PARAMETER (A_parms_i.new_high, B_parms_i.new_high, "new_high"); call APPEND_INOUT_PARAMETER (A_parms_i.stop, B_parms_i.stop, "stop"); call APPEND_N_PARAMETER (A_parms_i.stop_every, B_parms_i.stop_every, "stop_every"); call APPEND_N_PARAMETER (A_parms_i.stop_low, B_parms_i.stop_low, "stop_low"); call APPEND_INOUT_PARAMETER (A_parms_i.arguments, B_parms_i.arguments, "arguments"); if A_parms_i.call_ptr = null () then A_as_ptr = addr (NULL_ALLOCATED_STRING); else A_as_ptr = A_parms_i.call_ptr; if B_parms_i.call_ptr = null () then B_as_ptr = addr (NULL_ALLOCATED_STRING); else B_as_ptr = B_parms_i.call_ptr; call APPEND_CHAR_PARAMETER ((A_as_ptr -> allocated_string.value), (B_as_ptr -> allocated_string.value), "call"); return (many_parm_string); MAKE_GLOBAL_PARAMETERS_STRING: entry (global_parms_i) returns (char (256) var); if global_parms_i.version ^= GLOBAL_PARAMETERS_VERSION_3 then signal error; many_parm_string = ""; just_differences = "0"b; call APPEND_ONOFF_PARAMETER (global_parms_i.alm, "0"b, "alm"); call APPEND_ONOFF_PARAMETER (global_parms_i.automatic, "0"b, "automatic"); call APPEND_ONOFF_PARAMETER (global_parms_i.buffer_ptr ^= null (), "0"b, "buffer"); call APPEND_ONOFF_PARAMETER (global_parms_i.meter, "0"b, "meter"); call APPEND_ONOFF_PARAMETER (global_parms_i.signals, "0"b, "signals"); call APPEND_ONOFF_ALT_PARAMETER (global_parms_i.enabled, "0"b, "disable", "enable"); call APPEND_ONOFF_ALT_PARAMETER (global_parms_i.long, "0"b, "brief", "long"); call APPEND_ONOFF_ALT_PARAMETER (global_parms_i.loud, "0"b, "quiet", "loud"); if global_parms_i.osw.file_path = "" then call APPEND_CHAR_PARAMETER ((global_parms_i.osw.stream_name), "", "output_switch"); else call APPEND_CHAR_PARAMETER (global_parms_i.osw.file_path, "", "output_file"); call APPEND_CHAR_PARAMETER (global_parms_i.spp.entry_name, "", "stop_proc"); return (many_parm_string); /* declarations */ dcl A_parms_ptr_i ptr unal parm; dcl 1 A_parms_i like parameters aligned based (A_parms_ptr_i); dcl B_parms_ptr_i ptr unal parm; dcl 1 B_parms_i like parameters aligned based (B_parms_ptr_i); dcl 1 global_parms_i like trace_catch_$global_parameters aligned parm; dcl just_differences_i bit aligned parm; dcl A_as_ptr ptr; dcl B_as_ptr ptr; dcl just_differences bit aligned; dcl many_parm_string char (256) var; APPEND_N_PARAMETER: proc (A_n_i, B_n_i, control_arg_name_i); dcl A_n_i fixed bin (34) parm; dcl B_n_i fixed bin (34) parm; if just_differences & A_n_i = B_n_i then return; if A_n_i = 0 then one_parm_string = "-no_" || control_arg_name_i; else call ioa_$rsnnl ("-^a ^d", one_parm_string, one_parm_length, control_arg_name_i, A_n_i); go to APPEND_STRING; APPEND_ONOFF_PARAMETER: entry (A_onoff_i, B_onoff_i, control_arg_name_i); dcl A_onoff_i bit aligned parm; dcl B_onoff_i bit aligned parm; if just_differences & A_onoff_i = B_onoff_i then return; if A_onoff_i = "0"b then one_parm_string = "-" || control_arg_name_i || " off"; else one_parm_string = "-" || control_arg_name_i || " on"; go to APPEND_STRING; APPEND_ONOFF_ALT_PARAMETER: entry (A_onoff_i, B_onoff_i, control_arg_name_i, alt_control_arg_name_i); if just_differences & A_onoff_i = B_onoff_i then return; if A_onoff_i = "0"b then one_parm_string = "-" || control_arg_name_i; else one_parm_string = "-" || alt_control_arg_name_i; go to APPEND_STRING; APPEND_INOUT_PARAMETER: entry (A_inout_i, B_inout_i, control_arg_name_i); dcl A_inout_i bit (2) aligned parm; dcl B_inout_i bit (2) aligned parm; if just_differences & A_inout_i = B_inout_i then return; call ioa_$rsnnl ("-^a ^a", one_parm_string, one_parm_length, control_arg_name_i, trace_$cv_bits_to_inout (A_inout_i)); go to APPEND_STRING; APPEND_CHAR_PARAMETER: entry (A_char256var_i, B_char256var_i, control_arg_name_i); dcl A_char256var_i char (256) var parm; dcl B_char256var_i char (256) var parm; if just_differences & A_char256var_i = B_char256var_i then return; if length (A_char256var_i) = 0 then one_parm_string = "-no_" || control_arg_name_i; else if search (A_char256var_i, " ") = 0 then call ioa_$rsnnl ("-^a ^a", one_parm_string, one_parm_length, control_arg_name_i, A_char256var_i); else call ioa_$rsnnl ("-^a ""^a""", one_parm_string, one_parm_length, control_arg_name_i, A_char256var_i); go to APPEND_STRING; APPEND_STRING: if length (many_parm_string) > 0 then (nostrz): many_parm_string = many_parm_string || " "; (nostrz): many_parm_string = many_parm_string || one_parm_string; return; dcl control_arg_name_i char (16) var parm; dcl alt_control_arg_name_i char (16) var parm; dcl one_parm_length fixed bin (21); dcl one_parm_string char (256) var; end APPEND_N_PARAMETER; end MAKE_PARAMETERS_STRING; %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl char256var_i char (256) var parm; dcl compensation_idx_i fixed bin parm; dcl entrypoint_i entry parm; dcl inout_i bit (2) aligned parm; dcl just_differences_i bit aligned parm; dcl number_i fixed bin (34) parm; dcl onoff_i bit aligned parm; dcl parms_ptr_io ptr unal parm; dcl transaction_id_i fixed bin (71) parm; dcl tt_idx_i fixed bin parm; dcl 1 compensation_i aligned like compensation; dcl 1 output_switch_i like output_switch aligned parm; dcl 1 stop_proc_i like stop_proc aligned parm; /* Automatic */ dcl compensation_idx fixed bin; dcl tt_idx fixed bin; /* Static */ dcl ZERO fixed bin (35) static options (constant) init (0); dcl 1 NULL_ALLOCATED_STRING aligned static options (constant), 2 version char (8) init ("TraceAS3"), 2 reference_count fixed bin init (0), 2 value_length fixed bin init (0), 2 value char (0) unal; dcl 1 INITIAL_GLOBAL_PARAMETERS aligned static options (constant), 2 version char (8) init ("TraceGP3"), 2 alm bit init ("0"b), /* off */ 2 automatic bit init ("0"b), /* off */ 2 meter bit init ("0"b), /* off */ 2 signals bit init ("0"b), /* off */ 2 enabled bit init ("1"b), /* on */ 2 long bit init ("0"b), /* off */ 2 osw, 3 iocb_ptr ptr, 3 stream_name char (32) var init ("user_output"), 3 file_path char (256) var init (""), 2 spp, 3 entry_value entry (), 3 entry_name char (256) var init ("cu_$cl"), 2 trace_routine entry, 2 stop_routine entry, 2 loud bit init ("1"b), /* on */ 2 calibrate bit init ("0"b), /* off */ 2 buffer_ptr ptr unal init (null ()), 2 not_used fixed bin init (0), 2 comps (4), 3 real_time fixed bin (53) init (0, 0, 0, 0), 3 vcpu_time fixed bin (53) init (0, 0, 0, 0); dcl 1 INITIAL_PARAMETERS aligned static options (constant), 2 version char (8) init ("TraceTP3"), 2 reference_count fixed bin init (0), 2 every fixed bin (34) init (0), 2 first fixed bin (34) init (0), 2 last fixed bin (34) init (0), 2 low fixed bin (34) init (0), 2 high fixed bin (34) init (0), 2 new_high bit init ("0"b), 2 arguments bit (2) init ("00"b), 2 not_used1 bit init ("0"b), 2 stop_every fixed bin (34) init (0), 2 stop_low fixed bin (34) init (0), 2 stop bit (2) init ("00"b), 2 trace bit (2) init ("11"b), 2 call_ptr ptr unal init (null ()); /* Conditions */ dcl error condition; /* Based */ dcl trace_storage area based (trace_catch_$trace_storage_ptr); dcl PARAMETERS_VERSION_3 char (8) aligned static options (constant) init ("TraceTP3"); dcl parameters_ptr ptr unal; dcl 1 parameters aligned based (parameters_ptr), 2 version char (8), 2 reference_count fixed bin, 2 every fixed bin (34), 2 first fixed bin (34), 2 last fixed bin (34), 2 low fixed bin (34), 2 high fixed bin (34), 2 new_high bit, 2 arguments bit (2), 2 not_used1 bit, 2 stop_every fixed bin (34), 2 stop_low fixed bin (34), 2 stop bit (2), 2 trace bit (2), 2 call_ptr ptr unal; dcl ALLOCATED_STRING_VERSION_3 char (8) aligned static options (constant) init ("TraceAS3"); dcl allocated_string_value_length fixed bin; dcl allocated_string_ptr ptr unal; dcl 1 allocated_string aligned based (allocated_string_ptr), 2 version char (8), 2 reference_count fixed bin, 2 value_length fixed bin, 2 value char (allocated_string_value_length refer (allocated_string.value_length)) unal; /* External Variables */ dcl trace_$parameters_ptr ptr unal ext; dcl 1 trace_$global_parameters like trace_catch_$global_parameters aligned ext; dcl trace_catch_$trace_storage_ptr ptr ext; dcl trace_catch_$parameters_ptr ptr unal ext; dcl GLOBAL_PARAMETERS_VERSION_3 char (8) aligned static options (constant) init ("TraceGP3"); dcl 1 trace_catch_$global_parameters aligned ext, 2 version char (8), 2 alm bit, 2 automatic bit, 2 meter bit, 2 signals bit, 2 enabled bit, 2 long bit, 2 osw like output_switch, 2 spp like stop_proc, 2 trace_routine entry, 2 stop_routine entry, 2 loud bit, 2 calibrate bit, 2 buffer_ptr ptr unal, 2 not_used fixed bin, 2 comps (4) like compensation; /* External Entries */ dcl ioa_$rsnnl entry options (variable); dcl trace_calibrate_ entry (char (8) aligned, 1 like compensation aligned, 1 like compensation aligned); dcl trace_print_$copy_osw entry (1 like output_switch aligned, 1 like output_switch aligned); dcl trace_tables_$parameters_ptr entry (fixed bin) returns (ptr); dcl trace_print_$allocate_buffer entry (ptr unal); dcl trace_print_$copy_buffer_ptr entry (ptr unal, ptr unal); dcl trace_print_$stop entry (fixed bin, fixed bin (53)); dcl trace_print_$trace entry (fixed bin, fixed bin (53)); /* format: insnl,delnl */ /* END OF DECLARATIONS */ %page; /* START OF INCLUDE FILES */ %include trace_interface; end trace_parameters_;  trace_print_.pl1 10/24/88 1638.0r w 10/24/88 1400.1 217116 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* This program is called by trace_catch_ when the trace or stop conditions are satisfied. When called to trace, it formats and writes a trace message and executes a command line if required. When called to stop, it prints a stop message and checks the watch table. Initial Version: 25 February 1969 by BLW. Modified: December 1974 by S.E. Barr. Modified: 1 May 1975 by RAB for -return_value. Modified: Apr 1982 by Jeffrey D. Ives to use ioa_$ioa_switch for efficiency (instead of ioa_$ioa_stream). Modified: July 1983 by Jeffrey D. Ives for multitasking and to trace unwinds and signals. Modified: May 1984 by Jeffrey D. Ives for new trace interface and to separate trace and stop. */ /* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */ trace_print_: proc (); signal error; %page; trace: entry (event_i); event_ptr = addr (event_i); if event.version ^= EVENT_VERSION_3 then signal error; clock_reading = clock (); if event.kind = "ca" then TRACE_CALL: do; if ^trace_$long () then char256var = trace_$entrypoint_name (event.entry_idx); else do; call hcs_$fs_get_path_name ((event.return_ptr), dir_path, bname_length, entry_name, code); if code ^= 0 then do; call ioa_$rsnnl ("^a from ^p", char256var, return_string_length, trace_$entrypoint_name (event.entry_idx), event.return_ptr); end; else do; call pl1_frame_$name ((event.callers_sp), bname_ptr, bname_length); call interpret_bind_map_ ((event.return_ptr), cname, offset, code); if code ^= 0 then do; cname = entry_name; offset = bin (rel (event.return_ptr), 18); end; if bname_ptr ^= null () then if cname = bname then bname_ptr = null (); if bname_ptr = null () then call ioa_$rsnnl ("^a from ^a", char256var, return_string_length, trace_$entrypoint_name (event.entry_idx), cname); else call ioa_$rsnnl ("^a from ^a$^a", char256var, return_string_length, trace_$entrypoint_name (event.entry_idx), cname, bname); end; end; end TRACE_CALL; else if event.kind = "re" then char256var = trace_$entrypoint_name (event.entry_idx); else if event.kind = "un" then char256var = trace_$entrypoint_name (event.entry_idx) || " unwound"; else if event.kind = "si" then TRACE_SIGNAL: do; if event.arg_list_ptr -> arg_list.header.call_type ^= Interseg_call_type then char256var = "The signal_ routine has been called without an intersegment argument list."; else if event.arg_list_ptr -> arg_list.header.arg_count < 1 then char256var = "The signal_ routine has been called without arguments."; else if event.arg_list_ptr -> arg_list.header.desc_count < 1 then char256var = "The signal_ routine has been called without argument descriptors."; else if event.arg_list_ptr -> arg_list.desc_ptrs (1) -> arg_descriptor.type ^= char_dtype then char256var = "The first argument to signal_ is not a non-varying character string."; else do; bname_ptr = event.arg_list_ptr -> arg_list.arg_ptrs (1); bname_length = event.arg_list_ptr -> arg_list.desc_ptrs (1) -> arg_descriptor.size; call interpret_bind_map_ ((event.return_ptr), cname, offset, code); if code ^= 0 then char256var = bname; else call ioa_$rsnnl ("^a from ^a|^o", char256var, return_string_length, bname, cname, offset); char256var = char256var || SIGNAL_PTR_STRING (2, "machine conditions"); char256var = char256var || SIGNAL_PTR_STRING (3, "info"); char256var = char256var || SIGNAL_PTR_STRING (4, "crawlout machine conditions"); end; SIGNAL_PTR_STRING: proc (arg_list_idx_i, ptr_name_i) returns (char (256) var); dcl arg_list_idx_i fixed bin parm; dcl ptr_name_i char (*) parm; dcl return_string_length fixed bin; dcl signal_ptr_string char (256) var; if event.arg_list_ptr -> arg_list.header.arg_count < arg_list_idx_i then signal_ptr_string = ""; else if event.arg_list_ptr -> arg_list.header.desc_count < arg_list_idx_i then signal_ptr_string = ""; else if event.arg_list_ptr -> arg_list.desc_ptrs (arg_list_idx_i) -> arg_descriptor.type ^= pointer_dtype then call ioa_$rsnnl ("The ^a ptr argument to signal_ is not an aligned pointer", signal_ptr_string, return_string_length, ptr_name_i); else if event.arg_list_ptr -> arg_list.arg_ptrs (arg_list_idx_i) -> based_ptr = null () then signal_ptr_string = ""; else if ptr_name_i = "info" then begin; dcl short_message char (8) aligned; dcl long_message char (100) aligned; dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); %include condition_info_header; condition_info_header_ptr = event.arg_list_ptr -> arg_list.arg_ptrs (arg_list_idx_i) -> based_ptr; if condition_info_header.version ^= 1 then call ioa_$rsnnl (" ^a at ^p (condition_info_header.version = ^d)", signal_ptr_string, return_string_length, ptr_name_i, condition_info_header_ptr, condition_info_header.version); else do; if condition_info_header.status_code = 0 then long_message = ""; else call convert_status_code_ (condition_info_header.status_code, short_message, long_message); call ioa_$rsnnl (" ^a: ^a ^a", signal_ptr_string, return_string_length, ptr_name_i, long_message, condition_info_header.info_string); end; end; else call ioa_$rsnnl (" ^a at ^p", signal_ptr_string, return_string_length, ptr_name_i, event.arg_list_ptr -> arg_list.arg_ptrs (arg_list_idx_i) -> based_ptr); return (signal_ptr_string); end SIGNAL_PTR_STRING; end TRACE_SIGNAL; else call ioa_$rsnnl ("Unknown trace event ""^a""", char256var, return_string_length, event.kind); /* CLOCK TIME REAL SEC VCPU SEC PF CALL# RECURSION/HIGHEST ENTRYPOINT 19:01:00.460 0.000156 0.000156 0<- 1 1/1 wioctl_$control */ osw = trace_$output_switch (); if trace_$long () then do; if osw.iocb_ptr ^= LAST_OSW_IOCB_PTR_THAT_A_TRACE_MESSAGE_WAS_WRITTEN_TO then call ioa_$ioa_switch (osw.iocb_ptr, "^12a ^25a ^a^13a ^a", " CLOCK TIME ", METERS_STRING_HEADER (), DOTS_STRING (event.frame_count), COUNTS_STRING_HEADER (), " ENTRYPOINT"); call ioa_$ioa_switch (osw.iocb_ptr, "^12a ^25a ^a^13a ^a", trace_time_ (clock_reading), METERS_STRING (event.kind, event.frame), DOTS_STRING (event.frame_count), COUNTS_STRING (event.kind, event.saved), char256var); end; else do; if osw.iocb_ptr ^= LAST_OSW_IOCB_PTR_THAT_A_TRACE_MESSAGE_WAS_WRITTEN_TO then call ioa_$ioa_switch (osw.iocb_ptr, "^a^13a ^a", DOTS_STRING (event.frame_count), COUNTS_STRING_HEADER (), " ENTRYPOINT"); call ioa_$ioa_switch (osw.iocb_ptr, "^a^13a ^a", DOTS_STRING (event.frame_count), COUNTS_STRING (event.kind, event.saved), char256var); end; LAST_OSW_IOCB_PTR_THAT_A_TRACE_MESSAGE_WAS_WRITTEN_TO = osw.iocb_ptr; if event.kind = "ca" | event.kind = "re" then DISPLAY_ARGUMENT_LIST_AND_CALL_CP: begin; dcl indentation fixed bin; dcl first_arg_to_print fixed bin; dcl last_arg_to_print fixed bin; dcl 1 display_args_at aligned, 2 call bit unal, 2 return bit unal; dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35)); dcl display_argument_list_ entry (ptr, ptr, ptr, ptr, ptr, fixed bin, fixed bin, fixed bin); string (display_args_at) = trace_$arguments (event.entry_idx); if (event.kind = "ca" & display_args_at.call) | (event.kind = "re" & display_args_at.return) then do; first_arg_to_print = 1; if event.kind = "ca" & trace_$function (event.entry_idx) then last_arg_to_print = event.arg_list_ptr -> arg_list.header.arg_count - 1; else last_arg_to_print = event.arg_list_ptr -> arg_list.header.arg_count; if last_arg_to_print > 0 then do; if trace_$long () then indentation = min (event.frame_count, 40) + 54; else indentation = min (event.frame_count, 40) + 15; call display_argument_list_ (osw.iocb_ptr, null (), null (), (event.arg_list_ptr), (event.entry_ptr), first_arg_to_print, last_arg_to_print, indentation); end; end; char256var = trace_$call (event.entry_idx); if length (char256var) ^= 0 then call cu_$cp (addrel (addr (char256var), 1), length (char256var), code); end DISPLAY_ARGUMENT_LIST_AND_CALL_CP; return; %page; stop: entry (event_i, watch_values_changed_i); event_ptr = addr (event_i); if event.version ^= EVENT_VERSION_3 then signal error; osw = trace_$output_switch (); do iop = osw.iocb_ptr, iox_$error_output while (iop -> iocb.actual_iocb_ptr ^= osw.iocb_ptr -> iocb.actual_iocb_ptr); if event.kind = "ca" then call ioa_$ioa_switch (iop, "^a: Stopping at the call of ^a.", trace_$me (), trace_$entrypoint_name (event.entry_idx)); else call ioa_$ioa_switch (iop, "^a: Stopping at the return of ^a.", trace_$me (), trace_$entrypoint_name (event.entry_idx)); end; if watch_values_changed_i then DISPLAY_CHANGED_LOCATIONS: begin; dcl location_idx fixed bin; dcl location_ptr ptr unal; dcl prev_location_baseno bit (18) aligned; prev_location_baseno = ""b; do location_idx = 0 to trace_$num_locations () - 1; watch_values = trace_$location_values (location_idx); if watch_values.old ^= watch_values.new then do; location_ptr = trace_$location_ptr (location_idx); if baseno (location_ptr) ^= prev_location_baseno then do iop = osw.iocb_ptr, iox_$error_output while (iop -> iocb.actual_iocb_ptr ^= osw.iocb_ptr -> iocb.actual_iocb_ptr); call ioa_$ioa_switch (iop, "^a", trace_$location_seg_path (location_idx)); prev_location_baseno = baseno (location_ptr); end; do iop = osw.iocb_ptr, iox_$error_output while (iop -> iocb.actual_iocb_ptr ^= osw.iocb_ptr -> iocb.actual_iocb_ptr); call ioa_$ioa_switch (iop, "^20x^w -> ^w at ^p", watch_values.old, watch_values.new, location_ptr); end; end; end; end DISPLAY_CHANGED_LOCATIONS; spp = trace_$stop_proc (); if spp.entry_value = cu_$cl then call cu_$cl (CL_FLAGS); else call spp.entry_value (); return; %page; allocate_buffer: entry (buffer_ptr_o); allocate buffer; buffer.h.version = BUFFER_VERSION_3; buffer.h.count = 0; buffer_ptr_o = buffer_ptr; return; copy_buffer_ptr: entry (buffer_ptr_source_i, buffer_ptr_target_i); if buffer_ptr_target_i = buffer_ptr_source_i then return; buffer_ptr = buffer_ptr_target_i; buffer_ptr_target_i = buffer_ptr_source_i; if buffer_ptr = null () then return; if buffer.h.version ^= BUFFER_VERSION_3 then signal error; free buffer; return; buffer_counts: entry (buffer_first_idx_o, buffer_count_o); buffer_ptr = trace_$buffer_ptr (); if buffer_ptr = null () then do; buffer_first_idx_o = 0; buffer_count_o = 0; end; else do; if buffer.h.version ^= BUFFER_VERSION_3 then signal error; buffer_first_idx_o = max (0, buffer.count - dim (buffer.e, 1)); buffer_count_o = buffer.count; end; return; buffer_event: entry (buffer_idx_i, frame_count_o, kind_o, entry_ptr_o, saved_counts_o, frame_meters_o); event_ptr = EVENT_PTR (buffer_idx_i); if event_ptr = null () then do; frame_count_o = -1; kind_o = "!!"; entry_ptr_o = null (); saved_counts_o = -1; frame_meters_o = -1; end; else do; frame_count_o = event.frame_count; kind_o = event.kind; entry_ptr_o = event.entry_ptr; saved_counts_o = event.saved; frame_meters_o = event.frame; end; return; /* CLOCK TIME REAL SEC VCPU SEC PF CALL# RECURSION/HIGHEST ENTRYPOINT 19:01:00.460 0.069478 0.000318 1<- 1 1/1 user_info_$homedir */ buffer_event_header: entry (buffer_idx_i) returns (char (256) var); event_ptr = EVENT_PTR (buffer_idx_i); if event_ptr = null () then return ("There is no buffer or the buffer index is out of bounds."); if trace_$long () then return (" CLOCK TIME " || METERS_STRING_HEADER () || " " || DOTS_STRING (event.frame_count) || COUNTS_STRING_HEADER () || " ENTRYPOINT"); else return (DOTS_STRING (event.frame_count) || COUNTS_STRING_HEADER () || " ENTRYPOINT"); buffer_event_string: entry (buffer_idx_i) returns (char (256) var); event_ptr = EVENT_PTR (buffer_idx_i); if event_ptr = null () then return ("There is no buffer or the buffer index is out of bounds."); if event.kind = "ca" | event.kind = "re" then char256var = trace_$entrypoint_name (trace_$entrypoint_index (event.entry_ptr)); else if event.kind = "un" then char256var = trace_$entrypoint_name (trace_$entrypoint_index (event.entry_ptr)) || " unwound"; else if event.kind = "si" then char256var = rtrim (addr (event.saved) -> based_signal_name); else char256var = "Unknown trace event """ || event.kind || """"; if trace_$long () then return (trace_time_ (addr (event.callers_sp) -> fb71based) || " " || METERS_STRING (event.kind, event.frame) || " " || DOTS_STRING (event.frame_count) || COUNTS_STRING (event.kind, event.saved) || " " || char256var); else return (DOTS_STRING (event.frame_count) || COUNTS_STRING (event.kind, event.saved) || " " || char256var); %page; cv_file_path_to_osw: entry (char256var_i, referencing_ptr_i) returns (1 like output_switch aligned); osw.iocb_ptr = null (); osw.stream_name = ""; osw.file_path = char256var_i; if osw.file_path = "" then return (osw); osw.stream_name = "trace_of_." || unique_chars_ (""b); if length (osw.file_path) < 6 then osw.file_path = osw.file_path || ".trace"; else if substr (osw.file_path, length (osw.file_path) - 5) ^= ".trace" then osw.file_path = osw.file_path || ".trace"; call iox_$attach_name ((osw.stream_name), osw.iocb_ptr, "vfile_ " || osw.file_path, (referencing_ptr_i), code); if code ^= 0 then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "Attempting to attach file ""^a"".", osw.file_path); call iox_$open (osw.iocb_ptr, Stream_output, "0"b, code); if code ^= 0 then do; call iox_$detach_iocb (osw.iocb_ptr, rv); call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "Attempting to open ""^a"".", osw.file_path); end; return (osw); cv_stream_name_to_osw: entry (char32var_i) returns (1 like output_switch aligned); osw.iocb_ptr = null (); osw.stream_name = char32var_i; osw.file_path = ""; if osw.stream_name ^= "" then do; if before (osw.stream_name, ".") = "trace_of_" then call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv, "The io stream prefix ""trace_of_."" is reserved for use by trace only."); call iox_$look_iocb ((osw.stream_name), osw.iocb_ptr, code); if code ^= 0 then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "Attempting to locate the io stream ""^a"".", osw.stream_name); end; return (osw); copy_osw: entry (osw_source_i, osw_dest_i); if osw_source_i.iocb_ptr = osw_dest_i.iocb_ptr then return; osw = osw_dest_i; osw_dest_i = osw_source_i; if osw.file_path = "" then return; call iox_$close (osw.iocb_ptr, code); if code ^= 0 then call sub_err_ (code, trace_$me (), ACTION_DEFAULT_RESTART, null (), rv, "Attempting to close file ""^a"".", osw.file_path); code = 0; call iox_$detach_iocb (osw.iocb_ptr, code); if code ^= 0 then call sub_err_ (code, trace_$me (), ACTION_DEFAULT_RESTART, null (), rv, "Attempting to detach file ""^a"".", osw.file_path); return; cv_entry_name_to_spp: entry (char256var_i, referencing_ptr_i) returns (1 like stop_proc aligned); call cu_$make_entry_value (null (), spp.entry_value); spp.entry_name = char256var_i; if spp.entry_name ^= "" then do; spp.entry_value = cv_entry_ ((spp.entry_name), (referencing_ptr_i), code); if code ^= 0 then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "-stop_proc ""^a"".", spp.entry_name); end; return (spp); %page; /* SUBROUTINES */ EVENT_PTR: proc (buffer_idx_i) returns (ptr unal); dcl buffer_idx_i fixed bin (34) parm; dcl buffer_ptr ptr unal; dcl buffer_idx fixed bin (34); dcl buffer_array_idx fixed bin; buffer_ptr = trace_$buffer_ptr (); buffer_idx = buffer_idx_i; if buffer_ptr = null () then return (null ()); if buffer.h.version ^= BUFFER_VERSION_3 then signal error; if buffer_idx < 0 | buffer_idx < buffer.count - dim (buffer.e, 1) | buffer_idx >= buffer.count then return (null ()); buffer_array_idx = mod (buffer_idx, dim (buffer.e, 1)); if buffer.e (buffer_array_idx).version ^= EVENT_VERSION_3 then signal error; return (addr (buffer.e (buffer_array_idx))); end EVENT_PTR; METERS_STRING: proc (kind_i, meters_i) returns (char (40) var); dcl kind_i char (2) parm; dcl 1 meters_i like meters aligned parm; dcl meters_string char (40) var; dcl return_string_length fixed bin; if kind_i = "re" | kind_i = "un" then call ioa_$rsnnl ("^10.6f ^10.6f ^3d", meters_string, return_string_length, float (meters_i.real_time, 27) * 1e-6, float (meters_i.vcpu_time, 27) * 1e-6, meters_i.page_faults); else meters_string = (25)" "; return (meters_string); METERS_STRING_HEADER: entry () returns (char (25)); return (" REAL SEC VCPU SEC PF"); end METERS_STRING; DOTS_STRING: proc (number_of_dots_i) returns (char (40) var); dcl number_of_dots_i fixed bin unal parm; dcl dot_string char (40) var; dcl return_string_length fixed bin; if number_of_dots_i <= maxlength (dot_string) then dot_string = copy (".", number_of_dots_i); else do; call ioa_$rsnnl ("[^d]", dot_string, return_string_length, number_of_dots_i); dot_string = copy (".", maxlength (dot_string) - length (dot_string)) || dot_string; end; return (dot_string); end DOTS_STRING; COUNTS_STRING: proc (kind_i, saved_counts_i) returns (char (40) var); dcl kind_i char (2) parm; dcl 1 saved_counts_i like counts aligned parm; dcl kind_symbol char (2) aligned; dcl counts_string char (40) var; dcl return_string_length fixed bin; if kind_i = "ca" then kind_symbol = "->"; else if kind_i = "re" then kind_symbol = "<-"; else if kind_i = "un" then kind_symbol = "UW"; else kind_symbol = ""; if kind_i = "si" then counts_string = "Signal "; else if kind_symbol = "" then counts_string = (13)" "; else call ioa_$rsnnl ("^2a^7d ^d/^d", counts_string, return_string_length, kind_symbol, saved_counts_i.calls + 1, saved_counts_i.level + 1, max (saved_counts_i.level + 1, saved_counts_i.max_level)); return (counts_string); COUNTS_STRING_HEADER: entry () returns (char (27)); return (" CALL# RECURSION/HIGHEST"); end COUNTS_STRING; %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl buffer_count_o fixed bin (34) parm; dcl buffer_first_idx_o fixed bin (34) parm; dcl buffer_idx_i fixed bin (34) parm; dcl buffer_ptr_o ptr unal parm; dcl buffer_ptr_source_i ptr unal parm; dcl buffer_ptr_target_i ptr unal parm; dcl char32var_i char (32) var parm; dcl char256var_i char (256) var parm; dcl entry_ptr_o ptr unal parm; dcl frame_count_o fixed bin parm; dcl kind_o char (2) unal parm; dcl referencing_ptr_i ptr parm; dcl watch_values_changed_i bit aligned parm; dcl 1 event_i like event aligned parm; dcl 1 frame_meters_o like meters aligned parm; dcl 1 osw_dest_i like output_switch aligned parm; dcl 1 osw_source_i like output_switch aligned parm; dcl 1 saved_counts_o like counts aligned parm; /* Automatic */ dcl bname_length fixed bin; dcl bname_ptr ptr; dcl clock_reading fixed bin (71); dcl cname char (32) aligned; dcl code fixed bin (35); dcl char256var char (256) var; dcl dir_path char (168); dcl entry_name char (32); dcl offset fixed bin (18); dcl iop ptr; dcl return_string_length fixed bin; dcl rv fixed bin (35); dcl 1 osw aligned like output_switch; dcl 1 spp aligned like stop_proc; dcl EVENT_VERSION_3 char (4) aligned static options (constant) init ("TEV3"); dcl event_ptr ptr; dcl 1 event aligned based (event_ptr), /* Trace_catch_ knows this is 16 words. */ 2 version char (4), 2 kind char (2) unal, 2 frame_count fixed bin unal, 2 frame like meters, 2 entry_ptr ptr unal, 2 saved like counts, 2 entry_idx fixed bin, 2 arg_list_ptr ptr unal, 2 callers_sp ptr unal, 2 return_ptr ptr unal; /* Static */ dcl 1 CL_FLAGS aligned static options (constant), 2 reset_sw bit unal init ("0"b), 2 mbz bit (35) unal init (""b); dcl LAST_OSW_IOCB_PTR_THAT_A_TRACE_MESSAGE_WAS_WRITTEN_TO ptr static init (null ()); dcl ZERO fixed bin (35) static options (constant) init (0); /* Conditions */ dcl error condition; /* Based */ dcl based_ptr ptr based; dcl based_signal_name char (24) aligned based; dcl bname char (bname_length) based (bname_ptr); dcl fb71based fixed bin (71) based; dcl buffer_ptr ptr unal; dcl BUFFER_VERSION_3 char (8) aligned static options (constant) init ("TraceBF3"); dcl 1 buffer aligned based (buffer_ptr), 2 h, 3 version char (8), 3 not_used fixed bin, 3 count fixed bin (34), 2 e (0:8191) like event; /* Trace_catch_ knows this dimension. */ /* External Variables */ dcl iox_$error_output ptr ext; /* External Entries */ dcl cu_$cl entry (1 aligned, 2 bit (1) unal, 2 bit (35) unal); dcl cu_$make_entry_value entry (ptr, entry); dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl interpret_bind_map_ entry (ptr, char (32) aligned, fixed bin (18), fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl ioa_$ioa_switch entry options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl pl1_frame_$name entry (ptr, ptr, fixed bin); dcl sub_err_ entry () options (variable); dcl trace_time_ entry (fixed bin (71)) returns (char (12)); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* format: insnl,delnl */ /* END OF DECLARATIONS */ %page; /* START OF INCLUDE FILES */ %include arg_descriptor; %page; %include arg_list; %page; %include iocbx; %include iox_modes; %page; %include std_descriptor_types; %page; %include sub_err_flags; %page; %include trace_interface; end trace_print_;  trace_recurse_.pl1 10/23/84 1256.2rew 10/23/84 1219.1 16713 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Written in June 1983 by Jeffrey D. Ives. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* format: style2,^inddcls,ifthendo,^indnoniterdo,thendo,^inditerdo,ind2,dclind5,idind32 */ %page; trace_recurse_: proc (number_of_times_i, entry_to_entry_elapsed_time_o, return_to_return_elapsed_time_o); number_of_times = number_of_times_i; entry_clock_reading = clock (); call trace_recurse_dummy_ (number_of_times, divider_clock_reading); return_clock_reading = clock (); entry_to_entry_elapsed_time_o = divider_clock_reading - entry_clock_reading; return_to_return_elapsed_time_o = return_clock_reading - divider_clock_reading; return; %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl entry_to_entry_elapsed_time_o fixed bin (53) parm; dcl number_of_times_i fixed bin (34) parm; dcl return_to_return_elapsed_time_o fixed bin (53) parm; /* Automatic */ dcl divider_clock_reading fixed bin (53); dcl entry_clock_reading fixed bin (53); dcl number_of_times fixed bin; dcl return_clock_reading fixed bin (53); /* Static */ /* Conditions */ /* Based */ /* External Variables */ /* External Entries */ dcl trace_recurse_dummy_ entry (fixed bin, fixed bin (53)); /* format: insnl,delnl */ /* END OF DECLARATIONS */ end trace_recurse_;  trace_recurse_dummy_.pl1 10/23/84 1256.2rew 10/23/84 1219.1 12798 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Written in June 1983 by Jeffrey D. Ives. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* format: style2,^inddcls,ifthendo,^indnoniterdo,thendo,^inditerdo,ind2,dclind5,idind32 */ trace_recurse_dummy_: proc (number_of_times_io, return_clock_reading_o); number_of_times_io = number_of_times_io - 1; if number_of_times_io ^= 0 then call trace_recurse_dummy_ (number_of_times_io, return_clock_reading_o); else return_clock_reading_o = clock (); return; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl return_clock_reading_o fixed bin (53) parm; dcl number_of_times_io fixed bin parm; /* Automatic */ /* Static */ /* Conditions */ /* Based */ /* External Variables */ /* External Entries */ dcl trace_recurse_dummy_ entry (fixed bin, fixed bin (53)); /* format: insnl,delnl */ /* END OF DECLARATIONS */ end trace_recurse_dummy_;  trace_repeat_.pl1 10/23/84 1256.2rew 10/23/84 1219.1 21132 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Written in June 1983 by Jeffrey D. Ives. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* format: style2,^inddcls,ifthendo,^indnoniterdo,thendo,^inditerdo,ind2,dclind5,idind32 */ %page; trace_repeat_: proc (number_of_times_i, entry_to_return_elapsed_time_o, return_to_entry_elapsed_time_o); entry_to_return_elapsed_time = 0; return_to_entry_elapsed_time = 0; do number_of_times = 0 to number_of_times_i; entry_clock_reading = clock (); call trace_repeat_dummy_ (return_clock_reading); if number_of_times ^= 0 /* Waste the first entry reading. */ then do; return_to_entry_elapsed_time = return_to_entry_elapsed_time + (entry_clock_reading - old_return_clock_reading); entry_to_return_elapsed_time = entry_to_return_elapsed_time + (return_clock_reading - entry_clock_reading); end; old_return_clock_reading = return_clock_reading; end; entry_to_return_elapsed_time_o = entry_to_return_elapsed_time; return_to_entry_elapsed_time_o = return_to_entry_elapsed_time; return; %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl entry_to_return_elapsed_time_o fixed bin (53) parm; dcl number_of_times_i fixed bin (34) parm; dcl return_to_entry_elapsed_time_o fixed bin (53) parm; /* Automatic */ dcl entry_clock_reading fixed bin (53); dcl entry_to_return_elapsed_time fixed bin (53); dcl number_of_times fixed bin; dcl old_return_clock_reading fixed bin (53); dcl return_clock_reading fixed bin (53); dcl return_to_entry_elapsed_time fixed bin (53); /* Static */ /* Conditions */ /* Based */ /* External Variables */ /* External Entries */ dcl trace_repeat_dummy_ entry (fixed bin (53)); /* format: insnl,delnl */ /* END OF DECLARATIONS */ end trace_repeat_;  trace_repeat_dummy_.pl1 10/23/84 1256.2rew 10/23/84 1219.2 10044 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Written in June 1983 by Jeffrey D. Ives. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* format: style2,^inddcls,ifthendo,^indnoniterdo,thendo,^inditerdo,ind2,dclind5,idind32 */ trace_repeat_dummy_: proc (return_clock_reading_o); return_clock_reading_o = clock (); return; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl return_clock_reading_o fixed bin (53) parm; /* Automatic */ /* Static */ /* Conditions */ /* Based */ /* External Variables */ /* External Entries */ /* format: insnl,delnl */ /* END OF DECLARATIONS */ end trace_repeat_dummy_;  trace_tables_.pl1 10/23/84 1334.8rew 10/23/84 1219.2 226611 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This program manages the trace and watch tables and the tab (trace attributes) structures. The tables are not simple arrays. To promote efficient update, each consists of two stacks, one at each end of a large storage array. Entrypoints in trace_catch_ are used to access and update the tables. Written: May 1984 by Jeffrey D. Ives. */ /* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */ trace_tables_: procedure (); signal error; /* INITIALIZE */ initialize: entry (); allocate tt in (trace_storage); call INIT_TABLE_HEADER (tt.h, dim (tt.e, 1)); trace_catch_$tt_ptr = tt_ptr; allocate stt in (trace_storage); call INIT_TABLE_HEADER (stt.h, dim (stt.e, 1)); trace_$stt_ptr = stt_ptr; allocate wt in (trace_storage); call INIT_TABLE_HEADER (wt.h, dim (wt.e, 1)); trace_catch_$wt_ptr = wt_ptr; allocate swt in (trace_storage); call INIT_TABLE_HEADER (swt.h, dim (swt.e, 1)); trace_$swt_ptr = swt_ptr; return; INIT_TABLE_HEADER: proc (table_header_o, table_dim_i); dcl 1 table_header_o like table_header aligned parm; dcl table_dim_i fixed bin parm; unspec (table_header_o) = ""b; table_header_o.version = TT_VERSION_3; table_header_o.max_count = table_dim_i; table_header_o.idx.high = table_dim_i; return; end INIT_TABLE_HEADER; %page; /* TRANSACTION BEGIN */ transaction_begin: entry (); if trace_catch_$tt_ptr -> tt.h.version ^= TT_VERSION_3 then signal error; if trace_$stt_ptr -> tt.h.version ^= TT_VERSION_3 | trace_$stt_ptr -> tt.h.count ^= 0 then signal error; if trace_catch_$wt_ptr -> wt.h.version ^= TT_VERSION_3 then signal error; if trace_$swt_ptr -> wt.h.version ^= TT_VERSION_3 | trace_$swt_ptr -> wt.h.count ^= 0 then signal error; return; /* TRANSACTION BEGIN FORCE is the same as TRANSACTION END */ transaction_begin_force: /* TRANSACTION END */ transaction_end: entry (); stt_ptr = trace_$stt_ptr; if stt.h.count = -1 then stt.h.count = 0; /* "*" case */ else do stt_idx = 0 to stt.h.count - 1; te = trace_catch_$table_remove (stt_ptr, 0); /* Removing the 0th one is the most efficient. */ unspec (tte) = unspec (te); call FREE_TAB (tte.trace_attributes_ptr); end; swt_ptr = trace_$swt_ptr; if swt.h.count = -1 then swt.h.count = 0; /* "*" case */ else do swt_idx = 0 to swt.h.count - 1; te = trace_catch_$table_remove (swt_ptr, 0); end; return; /* ADD SPECIFIED ENTRYPOINTS */ add_specified_eps: entry (n_added_o, n_updated_o); tt_ptr = trace_catch_$tt_ptr; stt_ptr = trace_$stt_ptr; n_added = 0; n_updated = 0; if stt.h.count < 0 then do tt_idx = 0 to tt.h.count - 1; /* "*" case */ te = trace_catch_$table_get (tt_ptr, tt_idx); call UPDATE_TTE (te); end; else do stt_idx = 0 to stt.h.count - 1; te = trace_catch_$table_get (stt_ptr, stt_idx); call UPDATE_TTE (te); end; n_added_o = n_added; n_updated_o = n_updated; return; UPDATE_TTE: proc (te_i); dcl 1 te_i like te aligned parm; unspec (tte) = unspec (te_i); tab_ptr = tte.trace_attributes_ptr; tt_idx = trace_catch_$table_seek (tt_ptr, te.key); if tt_idx < 0 then do; /* Add it. */ if tab.translator_id >= 0 /* If it can be traced. */ then do; if ^trace_parameters_$update_parameters (tab.parms_ptr) then signal error; end; tab.reference_count = tab.reference_count + 1; tt_idx = trace_catch_$table_add (tt_ptr, te); if tt_idx < 0 then signal error; n_added = n_added + 1; end; else do; /* Update it. */ if tab.translator_id >= 0 /* If it can be traced. */ then do; if trace_parameters_$update_parameters (tab.parms_ptr) then n_updated = n_updated + 1; end; end; end UPDATE_TTE; /* ADD SPECIFIED LOCATIONS */ add_specified_locs: entry (n_added_o, n_updated_o); wt_ptr = trace_catch_$wt_ptr; swt_ptr = trace_$swt_ptr; n_added = 0; n_updated = 0; if swt.h.count < 0 then do wt_idx = 0 to wt.h.count - 1; /* "*" case */ te = trace_catch_$table_get (wt_ptr, wt_idx); unspec (wte) = unspec (te); if wte.old_value ^= wte.location_ptr -> based_value then do; call trace_catch_$table_put_data (wt_ptr, wt_idx, wte.location_ptr -> based_value); n_updated = n_updated + 1; end; end; else do swt_idx = 0 to swt.h.count - 1; te = trace_catch_$table_get (swt_ptr, swt_idx); unspec (wte) = unspec (te); wte.old_value = wte.location_ptr -> based_value; wt_idx = trace_catch_$table_seek (wt_ptr, te.key); if wt_idx < 0 then do; /* Add it. */ unspec (te) = unspec (wte); wt_idx = trace_catch_$table_add (wt_ptr, te); if wt_idx < 0 then signal error; n_added = n_added + 1; end; else do; /* Update it. */ te = trace_catch_$table_get (wt_ptr, wt_idx); if te.data ^= wte.old_value then do; call trace_catch_$table_put_data (wt_ptr, wt_idx, wte.old_value); n_updated = n_updated + 1; end; end; end; n_added_o = n_added; n_updated_o = n_updated; return; /* REMOVE SPECIFIED ENTRYPOINTS */ remove_specified_eps: entry (n_removed_o); tt_ptr = trace_catch_$tt_ptr; stt_ptr = trace_$stt_ptr; n_removed = 0; if stt.h.count < 0 then do; /* "*" case */ trace_$stt_ptr = null (); /* Switch tables. */ stt.h.count = 0; trace_catch_$tt_ptr = stt_ptr; trace_$stt_ptr = tt_ptr; n_removed = tt.h.count; do tt_idx = 0 to tt.h.count - 1; /* Remove the meters. */ te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; trace_catch_$removed = trace_catch_$removed + tab.local; end; end; else do stt_idx = 0 to stt.h.count - 1; te = trace_catch_$table_get (stt_ptr, stt_idx); tt_idx = trace_catch_$table_seek (tt_ptr, te.key); if tt_idx >= 0 then do; /* Remove it. */ unspec (tte) = unspec (te); te = trace_catch_$table_remove (tt_ptr, tt_idx); if unspec (te) ^= unspec (tte) then signal error; tab_ptr = tte.trace_attributes_ptr; trace_catch_$removed = trace_catch_$removed + tab.local; call FREE_TAB (tab_ptr); n_removed = n_removed + 1; end; end; n_removed_o = n_removed; return; /* REMOVE SPECIFIED LOCATIONS */ remove_specified_locs: entry (n_removed_o); wt_ptr = trace_catch_$wt_ptr; swt_ptr = trace_$swt_ptr; n_removed = 0; if swt.h.count < 0 then do; /* "*" case */ trace_$swt_ptr = null (); /* Switch them. */ swt.h.count = 0; trace_catch_$wt_ptr = swt_ptr; trace_$swt_ptr = wt_ptr; n_removed = wt.h.count; end; else do swt_idx = 0 to swt.h.count - 1; te = trace_catch_$table_get (swt_ptr, swt_idx); wt_idx = trace_catch_$table_seek (wt_ptr, te.key); if wt_idx >= 0 then do; /* Remove it. */ unspec (wte) = unspec (te); te = trace_catch_$table_remove (wt_ptr, wt_idx); if unspec (te.key) ^= unspec (wte.location_ptr) then signal error; n_removed = n_removed + 1; end; end; n_removed_o = n_removed; return; /* TURN ON AND OFF SPECIFIED ENTRYPOINTS */ turn_on_specified_eps: entry (n_turned_o); what_we_want = "1"b; go to ON_OFF_JOIN; turn_off_specified_eps: entry (n_turned_o); what_we_want = "0"b; go to ON_OFF_JOIN; ON_OFF_JOIN: tt_ptr = trace_catch_$tt_ptr; stt_ptr = trace_$stt_ptr; n_turned = 0; if stt.h.count < 0 then do tt_idx = 0 to tt.h.count - 1; /* "*" case */ te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; if tab.on ^= what_we_want then do; /* Turn it. */ tab.on = what_we_want; n_turned = n_turned + 1; end; end; else do stt_idx = 0 to stt.h.count - 1; te = trace_catch_$table_get (stt_ptr, stt_idx); tt_idx = trace_catch_$table_seek (tt_ptr, te.key); if tt_idx >= 0 /* If it is in the table... */ then do; unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; if tab.on ^= what_we_want then do; /* Turn it. */ tab.on = what_we_want; n_turned = n_turned + 1; end; end; end; n_turned_o = n_turned; return; %page; /* METERS */ entrypoint_counts: entry (tt_idx_i) returns (1 aligned like counts); tt_idx = tt_idx_i; tt_ptr = trace_catch_$tt_ptr; if tt_idx < 0 | tt_idx >= tt.h.count then signal error; te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; return (tab.cts); entrypoint_global_meters: entry (tt_idx_i) returns (1 like meters aligned); tt_idx = tt_idx_i; tt_ptr = trace_catch_$tt_ptr; if tt_idx < 0 | tt_idx >= tt.h.count then signal error; te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; return (tab.global); entrypoint_local_meters: entry (tt_idx_i) returns (1 like meters aligned); tt_idx = tt_idx_i; tt_ptr = trace_catch_$tt_ptr; if tt_idx < 0 | tt_idx >= tt.h.count then signal error; te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; return (tab.local); metered: entry () returns (1 like meters aligned); return (trace_catch_$metered); removed: entry () returns (1 like meters aligned); return (trace_catch_$removed); reset_meters: entry (); tt_ptr = trace_catch_$tt_ptr; do tt_idx = 0 to tt.h.count - 1; te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; tab.cts.calls = 0; tab.cts.max_level = 0; tab.local = 0; tab.global = 0; end; trace_catch_$removed = 1; trace_catch_$metered = 1; return; %page; /* ENTRYPOINTS */ entrypoint_index: entry (entry_ptr_i) returns (fixed bin); te.key = unspec (entry_ptr_i); return (trace_catch_$table_seek (trace_catch_$tt_ptr, te.key)); entrypoint_name: entry (tt_idx_i) returns (char (256) var); tt_idx = tt_idx_i; tt_ptr = trace_catch_$tt_ptr; if tt_idx < 0 | tt_idx >= tt.h.count then return ("entrypoint not in trace table"); te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; if before (tab.name, "$") = after (tab.name, "$") then return (before (tab.name, "$")); else return (tab.name); entrypoint_ptr: entry (tt_idx_i) returns (ptr); tt_idx = tt_idx_i; tt_ptr = trace_catch_$tt_ptr; if tt_idx < 0 | tt_idx >= tt.h.count then signal error; te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); return (tte.entry_ptr); entrypoint_seg_path: entry (tt_idx_i) returns (char (256) var); tt_idx = tt_idx_i; tt_ptr = trace_catch_$tt_ptr; if tt_idx < 0 | tt_idx >= tt.h.count then signal error; te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); return (trace_entrypoints_$get_path_name (tte.entry_ptr)); entrypoint_status: entry (tt_idx_i) returns (char (32) var); tt_idx = tt_idx_i; tt_ptr = trace_catch_$tt_ptr; if tt_idx < 0 | tt_idx >= tt.h.count then signal error; te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; if tab.translator_id < 0 then return ("cannot be traced"); if tab.translator_id = 1 then if ^trace_$alm () then return ("off because -alm off"); if tab.on then return ("on"); else return ("off"); function: entry (tt_idx_i) returns (bit aligned); tt_idx = tt_idx_i; tt_ptr = trace_catch_$tt_ptr; if tt_idx < 0 | tt_idx >= tt.h.count then signal error; te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; return (tab.function); num_entrypoints: entry () returns (fixed bin); return (trace_catch_$tt_ptr -> tt.h.count); num_specified_entrypoints: entry () returns (fixed bin); stt_ptr = trace_$stt_ptr; if stt.h.count < 0 then stt_ptr = trace_catch_$tt_ptr; /* "*" case */ return (stt.h.count); parameters_ptr: entry (tt_idx_i) returns (ptr); tt_idx = tt_idx_i; tt_ptr = trace_catch_$tt_ptr; if tt_idx < 0 | tt_idx >= tt.h.count then signal error; te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; return (tab.parms_ptr); specified_entrypoint_index: entry (stt_idx_i) returns (fixed bin); stt_idx = stt_idx_i; stt_ptr = trace_$stt_ptr; tt_ptr = trace_catch_$tt_ptr; if stt.h.count < 0 then return (stt_idx); /* "*" case */ if stt_idx < 0 | stt_idx >= stt.h.count then signal error; te = trace_catch_$table_get (stt_ptr, stt_idx); tt_idx = trace_catch_$table_seek (tt_ptr, te.key); return (tt_idx); translator_id: entry (tt_idx_i) returns (ptr); tt_idx = tt_idx_i; tt_ptr = trace_catch_$tt_ptr; if tt_idx < 0 | tt_idx >= tt.h.count then signal error; te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; return (tab.translator_id); %page; /* LOCATIONS */ location_ptr: entry (wt_idx_i) returns (ptr); wt_idx = wt_idx_i; wt_ptr = trace_catch_$wt_ptr; if wt_idx < 0 | wt_idx >= wt.h.count then signal error; te = trace_catch_$table_get (wt_ptr, wt_idx); unspec (wte) = unspec (te); return (wte.location_ptr); location_seg_path: entry (wt_idx_i) returns (char (256) var); wt_idx = wt_idx_i; wt_ptr = trace_catch_$wt_ptr; if wt_idx < 0 | wt_idx >= wt.h.count then signal error; te = trace_catch_$table_get (wt_ptr, wt_idx); unspec (wte) = unspec (te); return (trace_entrypoints_$get_path_name (wte.location_ptr)); location_values: entry (wt_idx_i) returns (1 aligned like watch_values); wt_idx = wt_idx_i; wt_ptr = trace_catch_$wt_ptr; if wt_idx < 0 | wt_idx >= wt.h.count then signal error; te = trace_catch_$table_get (wt_ptr, wt_idx); unspec (wte) = unspec (te); my_watch_values.old = wte.old_value; my_watch_values.new = wte.location_ptr -> based_value; return (my_watch_values); num_locations: entry () returns (fixed bin); return (trace_catch_$wt_ptr -> wt.h.count); num_specified_locations: entry () returns (fixed bin); swt_ptr = trace_$swt_ptr; wt_ptr = trace_catch_$wt_ptr; if swt.h.count >= 0 then return (swt.h.count); else return (wt.h.count); /* "*" case */ specified_location_index: entry (swt_idx_i) returns (fixed bin); swt_idx = swt_idx_i; swt_ptr = trace_$swt_ptr; wt_ptr = trace_catch_$wt_ptr; if swt.h.count < 0 then return (swt_idx); /* "*" case */ if swt_idx < 0 | swt_idx >= swt.h.count then signal error; te = trace_catch_$table_get (swt_ptr, swt_idx); wt_idx = trace_catch_$table_seek (wt_ptr, te.key); return (wt_idx); specify_locations: entry (char256var_i); swt_ptr = trace_$swt_ptr; if char256var_i = "*" then do; if swt.h.count > 0 then LOCATIONS_STAR_ERROR: call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv, "If you specify *, you cannot specify any other locations."); swt.h.count = -1; end; else do; if swt.h.count < 0 then go to LOCATIONS_STAR_ERROR; wte.location_ptr = addrel (cv_ptr_ ((char256var_i), code), 0); if wte.location_ptr = null () /* Addrel zeros the bit offset. */ then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "I could not convert ""^a"" to a pointer value.", char256var_i); wte.old_value = wte.location_ptr -> based_value; /* See if we blow up trying to reference it. */ unspec (te) = unspec (wte); swt_idx = trace_catch_$table_add (swt_ptr, te); end; return; specify_changed_locations: entry (); wt_ptr = trace_catch_$wt_ptr; swt_ptr = trace_$swt_ptr; if swt.h.count < 0 then ; /* "*" case */ else do wt_idx = 0 to wt.h.count - 1; te = trace_catch_$table_get (wt_ptr, wt_idx); unspec (wte) = unspec (te); te.data = wte.location_ptr -> based_value; if te.data ^= wte.old_value then swt_idx = trace_catch_$table_add (swt_ptr, te); end; return; /* MISCELLANEOUS */ add_entrypoint: /* Called from trace_entrypoints_$add_entrypoint. */ entry (entry_ptr_i, entry_name_i, translator_id_i, function_i) returns (fixed bin); tt_ptr = trace_catch_$tt_ptr; if tt.h.count = tt.h.max_count then return (null ()); call ALLOCATE_TAB (entry_name_i, translator_id_i, function_i); if tab.translator_id >= 0 /* -1 means don't trace. */ then do; if ^trace_parameters_$update_parameters (tab.parms_ptr) then signal error; end; tte.entry_ptr = entry_ptr_i; tte.trace_attributes_ptr = tab_ptr; unspec (te) = unspec (tte); tab.reference_count = tab.reference_count + 1; tt_idx = trace_catch_$table_add (tt_ptr, te); if tt_idx < 0 then signal error; return (tt_idx); specify_all_entrypoints: entry (); stt_ptr = trace_$stt_ptr; if stt.h.count > 0 then call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv, "If you specify all entrypoints, you cannot specify any particular entrypoints."); stt.h.count = -1; return; specify_entrypoint: /* Called from trace_entrypoints_$specify_entrypoints. */ entry (entry_ptr_i, entry_name_i, translator_id_i, function_i); stt_ptr = trace_$stt_ptr; tt_ptr = trace_catch_$tt_ptr; if stt.h.count < 0 then call /* "*" case */ sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv, "If you specify *, you cannot specify any other entrypoints."); if trace_catch_$table_seek (stt_ptr, unspec (entry_ptr_i)) >= 0 then return; if stt.h.count = stt.h.max_count then call sub_err_ (ZERO, trace_$me (), ACTION_CANT_RESTART, null (), rv, "You have specified too many entrypoints. The limit is ^d.", stt.h.max_count); tt_idx = trace_catch_$table_seek (tt_ptr, unspec (entry_ptr_i)); if tt_idx >= 0 then do; te = trace_catch_$table_get (tt_ptr, tt_idx); unspec (tte) = unspec (te); tab_ptr = tte.trace_attributes_ptr; end; else do; tte.entry_ptr = entry_ptr_i; call ALLOCATE_TAB (entry_name_i, translator_id_i, function_i); tte.trace_attributes_ptr = tab_ptr; unspec (te) = unspec (tte); end; tab.reference_count = tab.reference_count + 1; stt_idx = trace_catch_$table_add (stt_ptr, te); if stt_idx < 0 then signal error; return; %page; /* SUBROUTINES */ ALLOCATE_TAB: proc (entry_name_i, translator_id_i, function_i); dcl entry_name_i char (65) var parm; dcl translator_id_i fixed bin parm; dcl function_i bit aligned parm; tab_name_length = length (entry_name_i); if tab_name_length > 65 then signal error; allocate tab in (trace_storage); unspec (tab) = ""b; tab.version = TAB_VERSION_3; tab.parms_ptr = null (); tab.on = "1"b; tab.translator_id = translator_id_i; tab.function = function_i; tab.name_length = tab_name_length; tab.name = entry_name_i; end ALLOCATE_TAB; FREE_TAB: proc (tab_ptr_io); dcl tab_ptr_io ptr unal parm; dcl tp ptr unal; tp = tab_ptr_io; if tp = null () then return; tab_ptr_io = null (); if tp -> tab.version ^= TAB_VERSION_3 then signal error; tp -> tab.reference_count = tp -> tab.reference_count - 1; if tp -> tab.reference_count < 0 then signal error; if tp -> tab.reference_count > 0 then return; if tp -> tab.parms_ptr ^= null () then call trace_parameters_$free_parameters (tp -> tab.parms_ptr); free tp -> tab; end FREE_TAB; %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl char256var_i char (256) var parm; dcl entry_name_i char (65) var parm; dcl entry_ptr_i ptr unal parm; dcl function_i bit aligned parm; dcl n_added_o fixed bin parm; dcl n_removed_o fixed bin parm; dcl n_turned_o fixed bin parm; dcl n_updated_o fixed bin parm; dcl stt_idx_i fixed bin parm; dcl swt_idx_i fixed bin parm; dcl translator_id_i fixed bin parm; dcl tt_idx_i fixed bin parm; dcl wt_idx_i fixed bin parm; /* Automatic */ dcl code fixed bin (35); dcl entry_ptr ptr unal; dcl n_added fixed bin; dcl n_removed fixed bin; dcl n_turned fixed bin; dcl n_updated fixed bin; dcl rv fixed bin (35); dcl stt_idx fixed bin; dcl swt_idx fixed bin; dcl tt_idx fixed bin; dcl wt_idx fixed bin; dcl what_we_want bit aligned; dcl 1 te aligned, 2 key bit (36), 2 data bit (36); dcl 1 tte aligned, 3 entry_ptr ptr unal, 3 trace_attributes_ptr ptr unal; dcl 1 wte aligned, 3 location_ptr ptr unal, 3 old_value bit (36); dcl 1 my_watch_values like watch_values aligned; /* Static */ dcl ZERO fixed bin (35) static options (constant) init (0); /* Conditions */ dcl error condition; /* Based */ dcl based_value bit (36) aligned based; dcl trace_storage area based (trace_catch_$trace_storage_ptr); dcl TAB_VERSION_3 char (8) aligned static options (constant) init ("TraceTB3"); dcl tab_name_length fixed bin; dcl tab_ptr ptr unal; dcl 1 tab aligned based (tab_ptr), 2 version char (8), 2 reference_count fixed bin, 2 parms_ptr ptr unal, 2 cts like counts, 2 local like meters, 2 on bit, 2 global like meters, 2 translator_id fixed bin, 2 function bit, 2 name_length fixed bin, 2 name char (tab_name_length refer (tab.name_length)) unal; dcl 1 table_header aligned based, 2 version char (8), /* "TraceTT3" */ 2 max_count fixed bin, 2 count fixed bin, 2 idx, /* Must be double word aligned. */ 3 low fixed bin, 3 high fixed bin, 2 working_storage fixed bin (71); /* For trace_catch_ */ dcl TT_VERSION_3 char (8) aligned static options (constant) init ("TraceTT3"); dcl tt_ptr ptr; dcl 1 tt aligned based (tt_ptr), 2 h like table_header, 2 e (0:9999) fixed bin (66); dcl stt_ptr ptr; dcl 1 stt like tt aligned based (stt_ptr); dcl wt_ptr ptr; dcl 1 wt aligned based (wt_ptr), 2 h like table_header, 2 e (0:1023) fixed bin (66); dcl swt_ptr ptr; dcl 1 swt like wt aligned based (swt_ptr); /* External Variables */ dcl trace_catch_$trace_storage_ptr ptr ext; dcl trace_catch_$tt_ptr ptr ext; dcl trace_catch_$wt_ptr ptr ext; dcl 1 trace_catch_$metered like meters aligned ext; dcl 1 trace_catch_$removed like meters aligned ext; dcl trace_$stt_ptr ptr ext; dcl trace_$swt_ptr ptr ext; /* External Entries */ dcl cv_ptr_ entry (char (*), fixed bin (35)) returns (ptr); dcl sub_err_ entry () options (variable); dcl trace_catch_$table_add entry (ptr, 1 like te aligned) returns (fixed bin); dcl trace_catch_$table_get entry (ptr, fixed bin) returns (1 like te aligned); dcl trace_catch_$table_put_data entry (ptr, fixed bin, bit (36) aligned); dcl trace_catch_$table_remove entry (ptr, fixed bin) returns (1 like te aligned); dcl trace_catch_$table_seek entry (ptr, bit (36) aligned) returns (fixed bin); dcl trace_entrypoints_$get_path_name entry (ptr unal) returns (char (256) var); dcl trace_parameters_$free_parameters entry (ptr unal); dcl trace_parameters_$update_parameters entry (ptr unal) returns (bit aligned); /* format: insnl,delnl */ /* END OF DECLARATIONS */ %page; /* START OF INCLUDE FILES */ %include sub_err_flags; %page; %include trace_interface; end trace_tables_;  trace_time_.pl1 10/23/84 1334.8rew 10/23/84 1219.2 22086 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* This program is called by trace_print_ to get a formatted clock reading. The format is HH:MM:SS.FFF. Written: May 1984 by Jeffrey D. Ives. */ /* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */ %page; trace_time_: proc (clock_reading_i) returns (char (12)); zone = ""; call decode_clock_value_$date_time (clock_reading_i, de.month, de.dom, de.year, de.hour, de.minute, de.second, de.microsecond, de.dow, zone, code); if code ^= 0 then de = 0; dec3 = de.hour; unspec (formatted_string.hour) = substr (unspec (dec3), 19, 18); formatted_string.colon1 = ":"; dec3 = de.minute; unspec (formatted_string.minute) = substr (unspec (dec3), 19, 18); formatted_string.colon2 = ":"; dec3 = de.second; unspec (formatted_string.second) = substr (unspec (dec3), 19, 18); formatted_string.dot = "."; dec3 = divide (de.microsecond, 1000, 20); unspec (formatted_string.millisecond) = substr (unspec (dec3), 10, 27); return (string (formatted_string)); %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl clock_reading_i fixed bin (71) parm; /* Automatic */ dcl code fixed bin (35); dcl dec3 fixed dec (3) aligned; dcl zone char (3); dcl 1 de aligned, /* Read de as decoded. */ 2 month fixed bin, 2 dom fixed bin, 2 year fixed bin, 2 hour fixed bin, 2 minute fixed bin, 2 second fixed bin, 2 microsecond fixed bin (71), 2 dow fixed bin; dcl 1 formatted_string unal, 2 hour char (2), 2 colon1 char (1), 2 minute char (2), 2 colon2 char (1), 2 second char (2), 2 dot char (1), 2 millisecond char (3); /* Static */ /* Conditions */ /* Based */ /* External Variables */ /* External Entries */ dcl decode_clock_value_$date_time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (35)); /* format: insnl,delnl */ /* END OF DECLARATIONS */ end trace_time_;  trace_transactions_.pl1 10/23/84 1334.8rew 10/23/84 1219.2 42777 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This program contains the trace operations that are too complicated for trace_.alm Written: May 1984 by Jeffrey D. Ives. */ /* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */ trace_transactions_: procedure (); signal error; /* INITIALIZE EVERYTHING is invoked by the firstref trap in trace_.alm. */ initialize_everything: entry (); unspec (my_area_info) = ""b; my_area_info.version = area_info_version_1; my_area_info.control.extend = "1"b; my_area_info.owner = trace_$me (); my_area_info.size = sys_info$max_seg_size; my_area_info.areap = null (); call define_area_ (addr (my_area_info), code); if code ^= 0 then call sub_err_ (code, trace_$me (), ACTION_CANT_RESTART, null (), rv, "Call to define_area_ failed."); trace_catch_$trace_storage_ptr = my_area_info.areap; call trace_catch_$initialize (); call trace_tables_$initialize (); call trace_parameters_$initialize (); call add_epilogue_handler_ (trace_epilogue, code); if code ^= 0 then call sub_err_ (code, trace_$me (), ACTION_DEFAULT_RESTART, null (), rv, "I could not add the epilogue handler."); return; trace_epilogue: entry (); call transaction_begin_force (clock ()); call trace_$set_enabled ("0"b); call trace_$set_output_switch (trace_$cv_stream_name_to_osw ("")); if trace_$update_global_parms () then; return; %page; /* TRANSACTION BEGIN */ transaction_begin: entry (transaction_id_i) returns (bit aligned); transaction_id = transaction_id_i; if transaction_id = 0 then return ("0"b); if trace_$transaction_id ^= 0 then return ("0"b); /* A transaction is already in progress. */ trace_$transaction_id = transaction_id; /* Order is important for correct cleanup. */ call trace_catch_$stop_tracing (); /* Yank operator ptrs and move meters to tabs. */ call trace_parameters_$transaction_begin (); call trace_tables_$transaction_begin (); return ("1"b); /* TRANSACTION BEGIN FORCE */ transaction_begin_force: entry (transaction_id_i); trace_$transaction_id = transaction_id_i; /* Order is important for correct cleanup. */ call trace_catch_$stop_tracing (); /* Yank operator ptrs and move meters to tabs. */ call trace_parameters_$transaction_begin_force (); call trace_tables_$transaction_begin_force (); return; /* TRANSACTION END */ transaction_end: entry (transaction_id_i) returns (bit aligned); if transaction_id_i ^= trace_$transaction_id then return ("0"b); call trace_parameters_$transaction_end (); call trace_tables_$transaction_end (); call trace_catch_$start_tracing (); /* Plant operator ptrs and start global meters. */ trace_$transaction_id = 0; return ("1"b); %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Parameters */ dcl transaction_id_i fixed bin (71) parm; /* Automatic */ dcl code fixed bin (35); dcl rv fixed bin (35); dcl transaction_id fixed bin (71); dcl 1 my_area_info like area_info aligned; /* Static */ dcl sys_info$max_seg_size fixed bin (35) ext; dcl trace_catch_$trace_storage_ptr ptr ext; dcl ZERO fixed bin (35) static options (constant) init (0); /* Conditions */ dcl error condition; /* Based */ /* External Variables */ dcl trace_$transaction_id fixed bin (71) ext; /* External Entries */ dcl add_epilogue_handler_ entry (entry, fixed bin (35)); dcl define_area_ entry (ptr, fixed bin (35)); dcl sub_err_ entry () options (variable); dcl trace_catch_$initialize entry (); dcl trace_catch_$start_tracing entry (); dcl trace_catch_$stop_tracing entry (); dcl trace_parameters_$initialize entry (); dcl trace_parameters_$transaction_begin entry (); dcl trace_parameters_$transaction_begin_force entry (); dcl trace_parameters_$transaction_end entry (); dcl trace_tables_$initialize entry (); dcl trace_tables_$transaction_begin entry (); dcl trace_tables_$transaction_begin_force entry (); dcl trace_tables_$transaction_end entry (); /* format: insnl,delnl */ /* END OF DECLARATIONS */ %page; /* START OF INCLUDE FILES */ %include area_info; %page; %include sub_err_flags; %page; %include trace_interface; end trace_transactions_;  trace_version_.pl1 10/23/84 1334.9rew 10/23/84 1219.2 6849 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This program contains the identification of the trace facility. Written: May 1984 by Jeffrey D. Ives. */ /* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */ trace_version_: procedure (); signal error; dcl error condition; me: entry () returns (char (32)); return ("Trace"); version: entry () returns (char (32)); return ("Version 3.0"); end trace_version_;  watch.pl1 01/11/85 1045.4rew 01/11/85 1035.0 94482 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This is the command interface to the watch part of the trace facility. Written: May 1984 by Jeffrey D. Ives. */ /* format: style2,ifthendo,^indnoniterdo,thendo,^inditerdo,indproc,ind2,dclind5,idind32 */ %page; watch: procedure options (variable); /* DISABLE TRACE_CATCH_ */ transaction_id = clock (); on cleanup status = trace_$transaction_end (transaction_id); /* Disregard nonstandard use of status. */ if ^trace_$transaction_begin (transaction_id) /* Temporarily disables trace_catch_. */ then do; call com_err_ (code, ME, "There seems to be an incomplete invocation of trace, watch, or trace_meters still on the stack. Try the release command."); return; end; /* SET UP A SUB_ERROR_ CONDITION HANDLER */ call condition_ ("sub_error_", SUB_ERROR_HANDLER); /* SET DEFAULT ACTIONS */ add_remove_action = ""; status = "0"b; /* READ THE ARGUMENTS */ call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, ME); go to TRANSACTION_END; end; arg_idx = 1; ARGUMENT_LOOP: do while (arg_idx <= arg_count); call cu_$arg_ptr (arg_idx, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, ME); go to TRANSACTION_END; end; if length (arg) = 0 then do; call com_err_ (code, ME, "A null argument was found where a location was expected."); go to TRANSACTION_END; end; if substr (arg, 1, 1) ^= "-" then ENTRYPOINTS_ARGUMENT: do; call CHECK_NEXT_ARG (arg, 256, "watch", "locations", " control_args"); call trace_$specify_locations ((arg)); arg_idx = arg_idx + 1; end ENTRYPOINTS_ARGUMENT; else CONTROL_ARGUMENT: do; if arg_idx + 1 > arg_count then next_arg_ptr = null (); else do; call cu_$arg_ptr (arg_idx + 1, next_arg_ptr, next_arg_len, code); if code ^= 0 then do; call com_err_ (code, ME); go to TRANSACTION_END; end; if length (next_arg) > 0 then if substr (next_arg, 1, 1) = "-" then next_arg_ptr = null (); end; if arg = "-add" /* -add */ then do; add_remove_action = "add"; arg_idx = arg_idx + 1; end; else if arg = "-changed" /* -changed */ then do; call trace_$specify_changed_locations (); arg_idx = arg_idx + 1; end; else if arg = "-remove" | arg = "-rm" /* -remove, -rm */ then do; add_remove_action = "remove"; arg_idx = arg_idx + 1; end; else if arg = "-status" | arg = "-st" /* -status, -st */ then do; status = "1"b; arg_idx = arg_idx + 1; end; else do; call com_err_ (error_table_$badopt, ME, """^a""", arg); go to TRANSACTION_END; end; end CONTROL_ARGUMENT; end ARGUMENT_LOOP; %page; /* COMMIT ACTION and print a nice message something like this: Trace: 2 locations specified, 2 locations added. */ call SAY_BEGIN (); n_specified = trace_$num_specified_locations (); if n_specified > 0 then LOCATION_ACTION: do; call SAY_N_LOCATIONS (n_specified, "specified"); if add_remove_action = "" & ^status then add_remove_action = "add"; if add_remove_action = "add" then begin; dcl n_added fixed bin; dcl n_updated fixed bin; call trace_$add_specified_locs (n_added, n_updated); call SAY_N_LOCATIONS (n_added, "added"); if n_updated > 0 then call SAY_N_LOCATIONS (n_updated, "updated"); end; if add_remove_action = "remove" then begin; dcl n_removed fixed bin; call trace_$remove_specified_locs (n_removed); call SAY_N_LOCATIONS (n_removed, "removed"); end; end LOCATION_ACTION; n_locations = trace_$num_locations (); if n_locations = 0 then call SAY ("watch table empty"); else call SAY_N_LOCATIONS (n_locations, "in watch table"); if ^trace_$enabled () then call SAY ("trace is disabled"); else if trace_$in_trace () then call SAY ("trace is temporarily disabled"); else if trace_$num_entrypoints () = 0 then call SAY ("trace table empty"); call SAY_END (); if status & n_locations ^= 0 then STATUS: begin; dcl loc_idx fixed bin; dcl loc_ptr ptr; dcl n_not_in_wt fixed bin; dcl old_seg_no bit (18) aligned; dcl specified_loc_idx fixed bin; old_seg_no = ""b; n_not_in_wt = 0; if n_specified = 0 then call ioa_ ("If you want status, you must specify some locations."); do specified_loc_idx = 0 to n_specified - 1; loc_idx = trace_$specified_location_index (specified_loc_idx); if loc_idx < 0 then n_not_in_wt = n_not_in_wt + 1; else do; loc_ptr = trace_$location_ptr (loc_idx); if baseno (loc_ptr) ^= old_seg_no then do; call ioa_ ("^a", trace_$location_seg_path (loc_idx)); old_seg_no = baseno (loc_ptr); end; watch_values = trace_$location_values (loc_idx); if watch_values.old = watch_values.new then call ioa_ ("^20x^w ^12x at ^p", watch_values.old, loc_ptr); else call ioa_ ("^20x^w -> ^w at ^p", watch_values.old, watch_values.new, loc_ptr); end; end; if n_not_in_wt > 0 then do; if n_not_in_wt = 1 then call ioa_ ("^d of the specified locations was not in the watch table.", n_not_in_wt); else call ioa_ ("^d of the specified locations were not in the watch table.", n_not_in_wt); end; end STATUS; if arg_count = 0 then call ioa_ ("Acts: -add/-remove -status."); TRANSACTION_END: if ^trace_$transaction_end (transaction_id) /* Re-enable trace_catch_. */ then call com_err_ (ZERO, ME, "This invocation of the watch command ended abnormally."); return; SAY: proc (action_i); if trace_$loud () then do; call INIT (); call ioa_$nnl ("^a", action_i); end; return; SAY_N_LOCATIONS: entry (num_i, action_i); if trace_$loud () then do; call INIT (); if num_i = 1 then call ioa_$nnl ("^d loc ^a", num_i, action_i); else call ioa_$nnl ("^d locs ^a", num_i, action_i); end; return; SAY_BEGIN: entry (); n_things_said = 0; return; SAY_END: entry (); if n_things_said > 0 then call ioa_ ("."); return; INIT: proc (); if n_things_said = 0 then call ioa_$nnl ("^a: ", ME); else call ioa_$nnl (", "); n_things_said = n_things_said + 1; end INIT; dcl action_i char (*) parm; dcl num_i fixed bin parm; end SAY; %page; CHECK_NEXT_ARG: proc (next_arg_i, max_arg_len_i, control_arg_i, syntax_i, comment_i); dcl (next_arg_i, control_arg_i, syntax_i, comment_i) char (*) parm; dcl max_arg_len_i fixed bin (21); if addr (next_arg_i) = null () then do; call com_err_ (error_table_$noarg, ME, "The syntax is: ^a ^a^a.", control_arg_i, syntax_i, comment_i); go to TRANSACTION_END; end; if length (next_arg_i) > max_arg_len_i then do; call com_err_ (error_table_$bigarg, ME, "The maximum length for ^a is ^d characters. The syntax is: ^a ^a^a.", syntax_i, max_arg_len_i, control_arg_i, syntax_i, comment_i); go to TRANSACTION_END; end; end CHECK_NEXT_ARG; %page; /* SUBROUTINES */ SUB_ERROR_HANDLER: proc (mcptr_i, a_name_i, wcptr_i, info_ptr_i, continue_o); sub_error_info_ptr = info_ptr_i; condition_info_header_ptr = null (); if sub_error_info.name ^= trace_$me () then go to CONTINUE; if sub_error_info.header.support_signal | sub_error_info.header.quiet_restart then go to HANDLED; if sub_error_info.header.default_restart then go to REPORT; if sub_error_info.header.cant_restart then go to REPORT_AND_ABORT; else go to CONTINUE; REPORT_AND_ABORT: call com_err_ (sub_error_info.header.status_code, ME, "^a", sub_error_info.header.info_string); go to TRANSACTION_END; REPORT: call com_err_ (sub_error_info.header.status_code, ME, "^a", sub_error_info.header.info_string); HANDLED: continue_o = "0"b; return; CONTINUE: continue_o = "1"b; return; dcl mcptr_i ptr parm; dcl a_name_i char (*) parm; dcl info_ptr_i ptr parm; dcl wcptr_i ptr parm; dcl continue_o bit aligned; %include condition_info_header; %include sub_error_info; end SUB_ERROR_HANDLER; %page; /* START OF DECLARATIONS */ /* format: ^insnl,^delnl */ /* Automatic */ dcl add_remove_action char (8) init (""); dcl arg_count fixed bin init (0); dcl arg_idx fixed bin init (0); dcl arg_len fixed bin (21) init (0); dcl arg_ptr ptr init (null ()); dcl code fixed bin (35) init (0); dcl n_locations fixed bin; dcl n_specified fixed bin init (0); dcl n_things_said fixed bin init (0); dcl next_arg_idx fixed bin init (0); dcl next_arg_len fixed bin (21) init (0); dcl next_arg_ptr ptr init (null ()); dcl status bit aligned init ("0"b); dcl transaction_id fixed bin (71) init (0); /* Static */ dcl ME char (32) static options (constant) init ("watch"); dcl ZERO fixed bin (35) static options (constant) init (0); /* Conditions */ dcl cleanup condition; /* Based */ dcl arg char (arg_len) based (arg_ptr); dcl next_arg char (next_arg_len) based (next_arg_ptr); /* External Variables */ dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$bigarg fixed bin (35) ext; dcl error_table_$noarg fixed bin (35) ext; /* External Entries */ dcl com_err_ entry options (variable); dcl condition_ entry (char (*), entry); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl ioa_ entry () options (variable); dcl ioa_$nnl entry () options (variable); /* format: insnl,delnl */ /* END OF DECLARATIONS */ %page; /* START OF INCLUDE FILES */ %include trace_interface; end watch; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved