ref: acc58dfee42368825f7595d63240fd6e88559776
dir: /appl/wm/deb.b/
implement WmDebugger;
include "sys.m";
sys: Sys;
stderr: ref Sys->FD;
include "string.m";
str: String;
include "arg.m";
arg: Arg;
include "readdir.m";
readdir: Readdir;
include "draw.m";
draw: Draw;
include "tk.m";
tk: Tk;
include "tkclient.m";
tkclient: Tkclient;
include "dialog.m";
dialog: Dialog;
include "selectfile.m";
selectfile: Selectfile;
include "tabs.m";
tabs: Tabs;
include "debug.m";
debug: Debug;
Prog, Exp, Module, Src, Sym: import debug;
include "wmdeb.m";
debdata: DebData;
Vars: import debdata;
debsrc: DebSrc;
opendir, Mod: import debsrc;
WmDebugger: module
{
init: fn(ctxt: ref Draw->Context, argv: list of string);
};
icondir : con "debug/";
tkconfig := array[] of {
"frame .m -relief raised -bd 1",
"frame .p -padx 2",
"frame .ctls -padx 2",
"frame .body",
# menu bar
"menubutton .m.file -text File -menu .m.file.menu",
"menubutton .m.search -text Search -menu .m.search.menu",
"button .m.stack -text Stack -command {send m stack}",
"pack .m.file .m.search .m.stack -side left",
# file menu
"menu .m.file.menu",
".m.file.menu add command -label Open... -command {send m open}",
".m.file.menu add command -label Thread... -command {send m pickup}",
".m.file.menu add command -label Options... -command {send m options}",
".m.file.menu add separator",
# search menu
"menu .m.search.menu",
".m.search.menu add command -state disabled"+
" -label Look -command {send m look}",
".m.search.menu add command -state disabled"+
" -label {Search For} -command {send m search}",
# program control
"image create bitmap Detach -file "+icondir+
"detach.bit -maskfile "+icondir+"detach.mask",
"image create bitmap Kill -file "+icondir+
"kill.bit -maskfile "+icondir+"kill.mask",
"image create bitmap Run -file "+icondir+
"run.bit -maskfile "+icondir+"run.mask",
"image create bitmap Stop -file "+icondir+
"stop.bit -maskfile "+icondir+"stop.mask",
"image create bitmap Bpt -file "+icondir+
"break.bit -maskfile "+icondir+"break.mask",
"image create bitmap Stepop -file "+icondir+
"stepop.bit -maskfile "+icondir+"stepop.mask",
"image create bitmap Stepin -file "+icondir+
"stepin.bit -maskfile "+icondir+"stepin.mask",
"image create bitmap Stepout -file "+icondir+
"stepout.bit -maskfile "+icondir+"stepout.mask",
"image create bitmap Stepover -file "+icondir+
"stepover.bit -maskfile "+icondir+"stepover.mask",
"button .p.kill -image Kill -command {send m killall}"+
" -state disabled -relief sunken",
"bind .p.kill <Enter> +{.p.status configure -text {kill current process}}",
"bind .p.kill <Leave> +{.p.status configure -text {}}",
"button .p.detach -image Detach -command {send m detach}"+
" -state disabled -relief sunken",
"bind .p.detach <Enter> +{.p.status configure -text {stop debugging current process}}",
"bind .p.detach <Leave> +{.p.status configure -text {}}",
"button .p.run -image Run -command {send m run}"+
" -state disabled -relief sunken",
"bind .p.run <Enter> +{.p.status configure -text {run to breakpoint}}",
"bind .p.run <Leave> +{.p.status configure -text {}}",
"button .p.step -image Stepop -command {send m step}"+
" -state disabled -relief sunken",
"bind .p.step <Enter> +{.p.status configure -text {step one operation}}",
"bind .p.step <Leave> +{.p.status configure -text {}}",
"button .p.stmt -image Stepin -command {send m stmt}"+
" -state disabled -relief sunken",
"bind .p.stmt <Enter> +{.p.status configure -text {step one statement}}",
"bind .p.stmt <Leave> +{.p.status configure -text {}}",
"button .p.over -image Stepover -command {send m over}"+
" -state disabled -relief sunken",
"bind .p.over <Enter> +{.p.status configure -text {step over calls}}",
"bind .p.over <Leave> +{.p.status configure -text {}}",
"button .p.out -image Stepout -command {send m out}"+
" -state disabled -relief sunken",
"bind .p.out <Enter> +{.p.status configure -text {step out of fn}}",
"bind .p.out <Leave> +{.p.status configure -text {}}",
"button .p.bpt -image Bpt -command {send m setbpt}"+
" -state disabled -relief sunken",
"bind .p.bpt <Enter> +{.p.status configure -text {set/clear breakpoint}}",
"bind .p.bpt <Leave> +{.p.status configure -text {}}",
"frame .p.steps",
"label .p.status -anchor w",
"pack .p.step .p.stmt .p.over .p.out -in .p.steps -side left -fill y",
"pack .p.kill .p.detach .p.run .p.steps .p.bpt -side left -padx 5 -fill y",
"pack .p.status -side left -expand 1 -fill x",
# progs
"frame .prog",
"label .prog.l -text Threads",
"canvas .prog.d -height 1 -width 1 -relief sunken -bd 2",
"frame .prog.v",
".prog.d create window 0 0 -window .prog.v -anchor nw",
"pack .prog.l -side top -anchor w",
"pack .prog.d -side left -fill both -expand 1",
# breakpoints
"frame .bpt",
"label .bpt.l -text Break",
"canvas .bpt.d -height 1 -width 1 -relief sunken -bd 2",
"frame .bpt.v",
".bpt.d create window 0 0 -window .bpt.v -anchor nw",
"pack .bpt.l -side top -anchor w",
"pack .bpt.d -side left -fill both -expand 1",
"pack .prog .bpt -side top -fill both -expand 1 -in .ctls",
# test body
"frame .body.ft -bd 1 -relief sunken -width 60w -height 20h",
"scrollbar .body.scy",
"pack .body.scy -side right -fill y",
"pack .body.ft -side top -expand 1 -fill both",
"pack propagate .body.ft 0",
"pack .m .p -side top -fill x",
"pack .ctls -side left -fill y",
"scrollbar .body.scx -orient horizontal",
"pack .body.scx -side bottom -fill x",
"pack .body -expand 1 -fill both",
"pack propagate . 0",
"raise .; update; cursor -default"
};
# commands for disabling or enabling buttons
searchoff := array[] of {
".m.search.menu entryconfigure 0 -state disabled",
".m.search.menu entryconfigure 1 -state disabled",
".m.search.menu entryconfigure 2 -state disabled",
};
searchon := array[] of {
".m.search.menu entryconfigure 0 -state normal",
".m.search.menu entryconfigure 1 -state normal",
".m.search.menu entryconfigure 2 -state normal",
};
tkstopped := array[] of {
".p.bpt configure -state normal -relief raised",
".p.detach configure -state normal -relief raised",
".p.kill configure -state normal -relief raised",
".p.out configure -state normal -relief raised",
".p.over configure -state normal -relief raised",
".p.run configure -state normal -relief raised -image Run -command {send m run}",
".p.step configure -state normal -relief raised",
".p.stmt configure -state normal -relief raised",
};
tkrunning := array[] of {
".p.bpt configure -state normal -relief raised",
".p.detach configure -state normal -relief raised",
".p.kill configure -state normal -relief raised",
".p.out configure -state disabled -relief sunken",
".p.over configure -state disabled -relief sunken",
".p.run configure -state normal -relief raised -image Stop -command {send m stop}",
".p.step configure -state disabled -relief sunken",
".p.stmt configure -state disabled -relief sunken",
};
tkexited := array[] of {
".p.bpt configure -state normal -relief raised",
".p.detach configure -state normal -relief raised",
".p.kill configure -state normal -relief raised",
".p.out configure -state disabled -relief sunken",
".p.over configure -state disabled -relief sunken",
".p.run configure -state disabled -relief sunken -image Run -command {send m run}",
".p.step configure -state disabled -relief sunken",
".p.stmt configure -state disabled -relief sunken",
".p.stop configure -state disabled -relief sunken",
};
tkloaded := array[] of {
".p.bpt configure -state normal -relief raised",
".p.detach configure -state disabled -relief sunken",
".p.kill configure -state disabled -relief sunken",
".p.out configure -state disabled -relief sunken",
".p.over configure -state disabled -relief sunken",
".p.run configure -state normal -relief raised -image Run -command {send m run}",
".p.step configure -state disabled -relief sunken",
".p.stmt configure -state disabled -relief sunken",
};
tknobody := array[] of {
".p.bpt configure -state disabled -relief sunken",
".p.detach configure -state disabled -relief sunken",
".p.kill configure -state disabled -relief sunken",
".p.out configure -state disabled -relief sunken",
".p.over configure -state disabled -relief sunken",
".p.run configure -state disabled -relief sunken -image Run -command {send m run}",
".p.step configure -state disabled -relief sunken",
".p.stmt configure -state disabled -relief sunken",
};
#tk option dialog
tkoptpack := array[] of {
"frame .buts",
"pack .opts -side left -padx 10 -pady 5",
};
tkoptions := array[] of {
# general options
"frame .gen",
"frame .mod",
"label .modlab -text 'Source of executable module",
"entry .modent",
"pack .modlab -in .mod -anchor w",
"pack .modent -in .mod -fill x",
"frame .arg",
"label .arglab -text 'Program Arguments",
"entry .argent -width 300",
"pack .arglab -in .arg -anchor w",
"pack .argent -in .arg -fill x",
"frame .wd",
"label .wdlab -text 'Working Directory",
"entry .wdent",
"pack .wdlab -in .wd -anchor w",
"pack .wdent -in .wd -fill x",
"pack .mod .arg .wd -fill x -anchor w -pady 10 -in .gen",
# thread control options
"frame .prog",
"frame .new",
"radiobutton .new.run -variable new -value r -text 'Run new threads",
"radiobutton .new.block -variable new -value b -text 'Block new threads",
"pack .new.block .new.run -anchor w",
"frame .x",
"radiobutton .x.kill -variable exit -value k -text 'Kill threads on exit",
"radiobutton .x.detach -variable exit -value d -text 'Detach threads on exit",
"pack .x.kill .x.detach -anchor w",
"pack .new .x -expand 1 -anchor w -in .prog",
# layout options
"frame .layout",
"frame .line",
"radiobutton .line.wrap -variable wrap -value w -text 'Wrap lines",
"radiobutton .line.scroll -variable wrap -value s -text 'Horizontal scroll",
"pack .line.wrap .line.scroll -anchor w",
"frame .crlf",
"radiobutton .crlf.no -variable crlf -value n -text 'CR/LF as is",
"radiobutton .crlf.yes -variable crlf -value y -text 'CR/LF -> LF",
"pack .crlf.no .crlf.yes -anchor w",
"pack .line .crlf -expand 1 -anchor w -in .layout",
};
tkopttabs := array[] of {
("General", ".gen"),
("Thread", ".prog"),
("Layout", ".layout"),
};
# prog listing dialog box
tkpicktab := array[] of {
"frame .progs",
"scrollbar .progs.s -command '.progs.p yview",
"listbox .progs.p -width 35w -yscrollcommand '.progs.s set",
"bind .progs.p <Double-Button-1> 'send cmd prog",
"pack .progs.s -side right -fill y",
"pack .progs.p -fill both -expand 1",
"frame .buts",
"button .buts.prog -text {Add Thread} -command 'send cmd prog",
"button .buts.grp -text {Add Group} -command 'send cmd group",
"pack .buts.prog .buts.grp -expand 1 -side left -fill x -padx 4 -pady 4",
"pack .progs -fill both -expand 1",
"pack .buts -fill x",
"pack propagate . 0",
};
Bpt: adt
{
id: int;
m: ref Mod;
pc: int;
};
Recv, Send, Alt, Running, Stopped, Exited, Broken, Killing, Killed: con iota;
status := array[] of
{
Running => "Running",
Recv => "Receive",
Send => "Send",
Alt => "Alt",
Stopped => "Stopped",
Exited => "Exited",
Broken => "Broken",
Killing => "Killed",
Killed => "Killed",
};
tktools : array of array of string;
toolstate : array of string;
KidGrab, KidStep, KidStmt, KidOver, KidOut, KidKill, KidRun: con iota;
Kid: adt
{
state: int;
prog: ref Prog;
watch: int; # pid of watching prog
run: int; # pid of stepping prog
pickup: int; # picking up this kid?
cmd: chan of int;
stack: ref Vars;
};
Options: adt
{
start: string; # src of module to start
mod: ref Mod; # module to start
wm: int; # program is a wm program?
path: array of string;# search path for .src and .sbl
args: list of string; # argument for starting a kid
dir: string; # . for kid
tabs: int; # options to show
nrun: int; # run new kids?
xkill: int; # kill kids on exit?
xscroll: int; # horizontal scrolling
remcr: int; # CR/LF -> LF
};
tktop: ref Tk->Toplevel;
kids: list of ref Kid;
kid: ref Kid;
kidctxt: ref Draw->Context;
kidack: chan of (ref Kid, string);
kidevent: chan of (ref Kid, string);
bpts: list of ref Bpt;
bptid:= 1;
title: string;
runok := 0;
context: ref Draw->Context;
opts: ref Options;
dbpid: int;
searchfor: string;
initsrc: string;
badmodule(p: string)
{
sys->fprint(sys->fildes(2), "deb: cannot load %s: %r\n", p);
raise "fail:bad module";
}
init(ctxt: ref Draw->Context, argv: list of string)
{
sys = load Sys Sys->PATH;
if (ctxt == nil) {
sys->fprint(sys->fildes(2), "deb: no window context\n");
raise "fail:bad context";
}
draw = load Draw Draw->PATH;
tk = load Tk Tk->PATH;
tkclient = load Tkclient Tkclient->PATH;
if(tkclient == nil)
badmodule(Tkclient->PATH);
selectfile = load Selectfile Selectfile->PATH;
if(selectfile == nil)
badmodule(Selectfile->PATH);
dialog = load Dialog Dialog->PATH;
if(dialog == nil)
badmodule(Dialog->PATH);
tabs = load Tabs Tabs->PATH;
if(tabs == nil)
badmodule(Tabs->PATH);
str = load String String->PATH;
if(str == nil)
badmodule(String->PATH);
readdir = load Readdir Readdir->PATH;
if(readdir == nil)
badmodule(Readdir->PATH);
debug = load Debug Debug->PATH;
if(debug == nil)
badmodule(Debug->PATH);
debdata = load DebData DebData->PATH;
if(debdata == nil)
badmodule(DebData->PATH);
debsrc = load DebSrc DebSrc->PATH;
if(debsrc == nil)
badmodule(DebSrc->PATH);
arg = load Arg Arg->PATH;
if(arg == nil)
badmodule(Arg->PATH);
dbpid = sys->pctl(Sys->NEWPGRP, nil);
opts = ref Options;
opts.tabs = 0;
opts.nrun = 0;
opts.xkill = 1;
opts.xscroll = 0;
opts.remcr = 0;
readopts(opts);
sysnam := sysname();
context = ctxt;
grabpids: list of int;
arg->init(argv);
arg->setusage("wmdeb [-p pid]");
while((opt := arg->opt()) != 0){
case opt {
'f' =>
initsrc = arg->earg();
'p' =>
grabpids = int arg->earg() :: grabpids;
* =>
arg->usage();
}
}
for(argv = arg->argv(); argv != nil; argv = tl argv)
grabpids = int hd argv :: grabpids;
arg = nil;
pickdummy := chan of int;
pickchan := pickdummy;
optdummy := chan of ref Options;
optchan := optdummy;
tktools = array[] of {
Running => tkrunning,
Recv => tkrunning,
Send => tkrunning,
Alt => tkrunning,
Stopped => tkstopped,
Exited => tkexited,
Broken => tkexited,
Killing => tkexited,
Killed => tkexited,
};
tkclient->init();
selectfile->init();
dialog->init();
tabs->init();
title = sysnam+":Wmdeb";
titlebut := chan of string;
(tktop, titlebut) = tkclient->toplevel(context, nil, title, Tkclient->Appl);
tkcmd("cursor -bitmap cursor.wait");
debug->init();
kidctxt = ctxt;
stderr = sys->fildes(2);
debsrc->init(context, tktop, tkclient, selectfile, dialog, str, debug, opts.xscroll, opts.remcr);
(datatop, datactl, datatitle) := debdata->init(context, nil, debsrc, str, debug);
m := chan of string;
tk->namechan(tktop, m, "m");
toolstate = tknobody;
tkcmds(tktop, tkconfig);
if(!opts.xscroll){
tkcmd("pack forget .body.scx");
tkcmd("pack .body -expand 1 -fill both; update");
}
tkcmd("cursor -default");
tkclient->onscreen(tktop, nil);
tkclient->startinput(tktop, "kbd" :: "ptr" :: nil);
kids = nil;
kid = nil;
kidack = chan of (ref Kid, string);
kidevent = chan of (ref Kid, string);
# pick up a src file, a kid?
if(initsrc != nil)
open1(initsrc);
else if(grabpids != nil)
for(; grabpids != nil; grabpids = tl grabpids)
pickup(hd grabpids);
for(exiting := 0; !exiting || kids != nil; ){
tkcmd("update");
alt {
c := <-tktop.ctxt.kbd =>
tk->keyboard(tktop, c);
p := <-tktop.ctxt.ptr =>
tk->pointer(tktop, *p);
s := <-tktop.ctxt.ctl or
s = <-tktop.wreq or
s = <-titlebut =>
case s{
"exit" =>
if(!exiting){
if(opts.xkill)
killkids();
else
detachkids();
tkcmd("destroy .");
}
exiting = 1;
break;
"task" =>
spawn task(tktop);
* =>
tkclient->wmctl(tktop, s);
}
c := <-datatop.ctxt.kbd =>
tk->keyboard(datatop, c);
p := <-datatop.ctxt.ptr =>
tk->pointer(datatop, *p);
s := <-datactl =>
debdata->ctl(s);
s := <-datatop.wreq or
s = <-datatop.ctxt.ctl or
s = <-datatitle =>
case s{
"task" =>
spawn debdata->wmctl(s);
* =>
debdata->wmctl(s);
}
o := <-optchan =>
if(o != nil && checkopts(o))
opts = o;
optchan = optdummy;
p := <-pickchan =>
if(p < 0){
pickchan = pickdummy;
break;
}
k := pickup(p);
if(k != nil && k != kid){
kid = k;
refresh(k);
}
s := <-m =>
case s {
"open" =>
open();
"pickup" =>
if(pickchan == pickdummy){
pickchan = chan of int;
spawn pickprog(pickchan);
}
"options" =>
if(optchan == optdummy){
optchan = chan of ref Options;
spawn options(opts, optchan);
}
"step" =>
step(kid, KidStep);
"over" =>
step(kid, KidOver);
"out" =>
step(kid, KidOut);
"stmt" =>
step(kid, KidStmt);
"run" =>
step(kid, KidRun);
"stop" =>
if(kid != nil)
kid.prog.stop();
"killall" =>
killkids();
"kill" =>
killkid(kid);
"detach" =>
detachkid(kid);
"setbpt" =>
setbpt();
"look" =>
debsrc->search(debsrc->snarf());
"search" =>
s = dialog->getstring(context, tktop.image, "Search For");
if(s == ""){
tkcmd(".m.search.menu delete 2");
}else{
if(searchfor == "")
tkcmd(".m.search.menu add command -command {send m research}");
tkcmd(".m.search.menu entryconfigure 2 -label '/"+s);
debsrc->search(s);
}
searchfor = s;
"research" =>
debsrc->search(searchfor);
"stack" =>
if(debdata != nil)
debdata->raisex();
* =>
if(str->prefix("open ", s))
debsrc->showstrsrc(s[len "open ":]);
else if(str->prefix("seeprog ", s))
seekid(int s[len "seeprog ":]);
else if(str->prefix("seebpt ", s))
seebpt(int s[len "seebpt ":]);
}
(k, s) := <-kidevent =>
case s{
"recv" =>
if(k.state == Running)
k.state = Recv;
"send" =>
if(k.state == Running)
k.state = Send;
"alt" =>
if(k.state == Running)
k.state = Alt;
"run" =>
if(k.state == Recv || k.state == Send || k.state == Alt)
k.state = Running;
"exited" =>
k.state = Exited;
"interrupted" or
"killed" =>
alert("Thread "+string k.prog.id+" "+s);
k.state = Exited;
* =>
if(str->prefix("new ", s)){
nk := newkid(int s[len "new ":]);
if(opts.nrun)
step(nk, KidRun);
break;
}
if(str->prefix("load ", s)){
s = s[len "load ":];
if(s != nil && s[0] != '$')
loaded(s);
break;
}
if(str->prefix("child: ", s))
s = s[len "child: ":];
if(str->prefix("broken: ", s))
k.state = Broken;
alert("Thread "+string k.prog.id+" "+s);
}
if(k == kid && k.state != Running)
refresh(k);
k = nil;
(k, s) := <-kidack =>
if(k.state == Killing){
k.state = Killed;
k.cmd <-= KidKill;
k = nil;
break;
}
if(k.state == Killed){
delkid(k);
k = nil;
break;
}
case s{
"" or "child: breakpoint" or "child: stopped" =>
k.state = Stopped;
k.prog.unstop();
"prog broken" =>
k.state = Broken;
* =>
if(!str->prefix("child: ", s))
alert("Debugger error "+status[k.state]+" "+string k.prog.id+" '"+s+"'");
}
if(k == kid)
refresh(k);
if(k.pickup && opts.nrun){
k.pickup = 0;
if(k.state == Stopped)
step(k, KidRun);
}
k = nil;
}
}
exitdb();
}
task(top: ref Tk->Toplevel)
{
tkclient->wmctl(top, "task");
}
open()
{
pattern := list of {
"*.b (Limbo source files)",
"* (All files)"
};
file := selectfile->filename(context, tktop.image, "Open source file", pattern, opendir);
if(file != nil)
open1(file);
}
open1(file: string)
{
(opendir, nil) = str->splitr(file, "/");
if(opendir == "")
opendir = ".";
m := debsrc->loadsrc(file, 1);
if(m == nil){
alert("Can't open "+file);
return;
}
debsrc->showmodsrc(m, ref Src((file, 1, 0), (file, 1, 0)));
kidstate();
if(opts.start == nil){
opts.start = file;
opts.mod = m;
}
if(opts.dir == "")
opts.dir = opendir;
}
options(oo: ref Options, r: chan of ref Options)
{
(t, titlebut) := tkclient->toplevel(context, nil, "Wmdeb Options", tkclient->OK);
tkcmds(t, tkoptions);
tabsctl := tabs->mktabs(t, ".opts", tkopttabs, oo.tabs);
tkcmds(t, tkoptpack);
o := ref *oo;
if(o.start != nil)
tk->cmd(t, ".modent insert end '"+o.start);
args := "";
for(oa := o.args; oa != nil; oa = tl oa){
if(args == "")
args = hd oa;
else
args += " " + hd oa;
}
tk->cmd(t, ".argent insert end '"+args);
tk->cmd(t, ".wdent insert end '"+o.dir);
if(o.xkill)
tk->cmd(t, ".x.kill invoke");
else
tk->cmd(t, ".x.detach invoke");
if(o.nrun)
tk->cmd(t, ".new.run invoke");
else
tk->cmd(t, ".new.block invoke");
if(o.xscroll)
tk->cmd(t, ".line.scroll invoke");
else
tk->cmd(t, ".line.wrap invoke");
if(o.remcr)
tk->cmd(t, ".crlf.yes invoke");
else
tk->cmd(t, ".crlf.no invoke");
tk->cmd(t, ".killkids configure -command 'send cmd kill");
tk->cmd(t, ".runkids configure -command 'send cmd run");
tkclient->onscreen(t, nil);
tkclient->startinput(t, "ptr" :: "kbd" :: nil);
out: for(;;){
tk->cmd(t, "update");
alt{
c := <-t.ctxt.kbd =>
tk->keyboard(t, c);
m := <-t.ctxt.ptr =>
tk->pointer(t, *m);
s := <-tabsctl =>
o.tabs = tabs->tabsctl(t, ".opts", tkopttabs, o.tabs, s);
s := <-t.ctxt.ctl or
s = <-t.wreq or
s = <-titlebut =>
case s{
"exit" =>
r <-= nil;
exit;
"ok" =>
break out;
}
tkclient->wmctl(t, s);
}
}
xscroll := o.xscroll;
o.start = tk->cmd(t, ".modent get");
(nil, o.args) = sys->tokenize(tk->cmd(t, ".argent get"), " \t\n");
o.dir = tk->cmd(t, ".wdent get");
case tk->cmd(t, "variable new"){
"r" => o.nrun = 1;
"b" => o.nrun = 0;
}
case tk->cmd(t, "variable exit"){
"k" => o.xkill = 1;
"d" => o.xkill = 0;
}
case tk->cmd(t, "variable wrap"){
"s" => o.xscroll = 1;
"w" => o.xscroll = 0;
}
case tk->cmd(t, "variable crlf"){
"y" => o.remcr = 1;
"n" => o.remcr = 0;
}
if(o.xscroll != xscroll){
if(o.xscroll)
tkcmd("pack .body.scx -side bottom -fill x");
else
tkcmd("pack forget .body.scx");
tkcmd("pack .body -expand 1 -fill both; update");
}
debsrc->reinit(o.xscroll, o.remcr);
writeopts(o);
r <-= o;
}
checkopts(o: ref Options): int
{
if(o.start != ""){
o.mod = debsrc->loadsrc(o.start, 1);
if(o.mod == nil)
o.start = "";
}
return 1;
}
pickprog(c: chan of int)
{
(t, titlebut) := tkclient->toplevel(context, nil, "Wmdeb Thread List", 0);
cmd := chan of string;
tk->namechan(t, cmd, "cmd");
tkcmds(t, tkpicktab);
tk->cmd(t, "update");
ids := addpickprogs(t);
tkclient->onscreen(t, nil);
tkclient->startinput(t, "ptr" :: "kbd" :: nil);
for(;;){
tk->cmd(t, "update");
alt{
key := <-t.ctxt.kbd =>
tk->keyboard(t, key);
m := <-t.ctxt.ptr =>
tk->pointer(t, *m);
s := <-t.ctxt.ctl or
s = <-t.wreq or
s = <-titlebut =>
if(s == "exit"){
c <-= -1;
exit;
}
tkclient->wmctl(t, s);
s := <-cmd =>
case s{
"ok" =>
c <-= -1;
exit;
"prog" =>
sel := tk->cmd(t, ".progs.p curselection");
if(sel == "")
break;
pid := int tk->cmd(t, ".progs.p get "+sel);
c <-= pid;
"group" =>
sel := tk->cmd(t, ".progs.p curselection");
if(sel == "")
break;
nid := int sel;
if(nid > len ids || nid < 0)
break;
(nil, gid) := ids[nid];
nid = len ids;
for(i := 0; i < nid; i++){
(p, g) := ids[i];
if(g == gid)
c <-= p;
}
}
}
}
}
addpickprogs(t: ref Tk->Toplevel): array of (int, int)
{
(d, n) := readdir->init("/prog", Readdir->NONE);
if(n <= 0)
return nil;
a := array[n] of { * => (-1, -1) };
for(i := 0; i < n; i++){
(p, nil) := debug->prog(int d[i].name);
if(p == nil)
continue;
(grp, nil, st, code) := debug->p.status();
if(grp < 0)
continue;
a[i] = (p.id, grp);
tk->cmd(t, ".progs.p insert end '"+
sys->sprint("%4d %4d %8s %s", p.id, grp, st, code));
}
return a;
}
step(k: ref Kid, cmd: int)
{
if(k == nil){
if(kids != nil){
alert("No current thread");
return;
}
k = spawnkid(opts);
kid = k;
if(k != nil)
refresh(k);
return;
}
case k.state{
Stopped =>
k.cmd <-= cmd;
k.state = Running;
if(k == kid)
kidstate();
Running or Send or Recv or Alt or Exited or Broken =>
;
* =>
sys->print("bad debug step state %d\n", k.state);
}
}
setbpt()
{
(m, pc) := debsrc->getsel();
if(m == nil)
return;
s := m.sym.pctosrc(pc);
if(s == nil){
alert("No pc is appropriate");
return;
}
# if the breakpoint is already there, delete it
for(bl := bpts; bl != nil; bl = tl bl){
b := hd bl;
if(b.m == m && b.pc == pc){
bpts = delbpt(b, bpts);
return;
}
}
b := ref Bpt(bptid++, m, pc);
bpts = b :: bpts;
debsrc->attachdis(m);
for(kl := kids; kl != nil; kl = tl kl){
k := hd kl;
k.prog.setbpt(m.dis, pc);
}
# mark the breakpoint text
tkcmd(m.tk+" tag add bpt "+string s.start.line+"."+string s.start.pos+" "+string s.stop.line+"."+string s.stop.pos);
# add the kid to the breakpoint window
me := ".bpt.v."+string b.id;
tkcmd("label "+me+" -text "+string b.id);
tkcmd("pack "+me+" -side top -fill x");
tkcmd("bind "+me+" <ButtonRelease-1> {send m seebpt "+string b.id+"}");
updatebpts();
}
seebpt(bpt: int)
{
for(bl := bpts; bl != nil; bl = tl bl){
b := hd bl;
if(b.id == bpt){
s := b.m.sym.pctosrc(b.pc);
debsrc->showmodsrc(b.m, s);
return;
}
}
}
delbpt(b: ref Bpt, bpts: list of ref Bpt): list of ref Bpt
{
if(bpts == nil)
return nil;
hb := hd bpts;
tb := tl bpts;
if(b == hb){
# remove mark from breakpoint text
s := b.m.sym.pctosrc(b.pc);
tkcmd(b.m.tk+" tag remove bpt "+string s.start.line+"."+string s.start.pos+" "+string s.stop.line+"."+string s.stop.pos);
# remove the breakpoint window
tkcmd("destroy .bpt.v."+string b.id);
# remove from kids
disablebpt(b);
return tb;
}
return hb :: delbpt(b, tb);
}
disablebpt(b: ref Bpt)
{
for(kl := kids; kl != nil; kl = tl kl){
k := hd kl;
k.prog.delbpt(b.m.dis, b.pc);
}
}
updatebpts()
{
tkcmd("update");
tkcmd(".bpt.d configure -scrollregion {0 0 [.bpt.v cget -width] [.bpt.v cget -height]}");
}
seekid(pid: int)
{
for(kl := kids; kl != nil; kl = tl kl){
k := hd kl;
if(k.prog.id == pid){
kid = k;
kid.stack.show();
refresh(kid);
return;
}
}
}
delkid(k: ref Kid)
{
kids = rdelkid(k, kids);
if(kid == k){
if(kids == nil){
kid = nil;
kidstate();
}else{
kid = hd kids;
refresh(kid);
}
}
}
rdelkid(k: ref Kid, kids: list of ref Kid): list of ref Kid
{
if(kids == nil)
return nil;
hk := hd kids;
t := tl kids;
if(k == hk){
# remove kid from display
k.stack.delete();
tkcmd("destroy .prog.v."+string k.prog.id);
updatekids();
return t;
}
return hk :: rdelkid(k, t);
}
updatekids()
{
tkcmd("update");
tkcmd(".prog.d configure -scrollregion {0 0 [.prog.v cget -width] [.prog.v cget -height]}");
}
killkids()
{
for(kl := kids; kl != nil; kl = tl kl)
killkid(hd kl);
}
killkid(k: ref Kid)
{
if(k.watch >= 0){
killpid(k.watch);
k.watch = -1;
}
case k.state{
Exited or Broken or Stopped =>
k.cmd <-= KidKill;
k.state = Killed;
Running or Send or Recv or Alt or Killing =>
k.prog.kill();
k.state = Killing;
* =>
sys->print("unknown state %d in killkid\n", k.state);
}
}
freekids(): int
{
r := 0;
for(kl := kids; kl != nil; kl = tl kl){
k := hd kl;
if(k.state == Exited || k.state == Killing || k.state == Killed){
r ++;
detachkid(k);
}
}
return r;
}
detachkids()
{
for(kl := kids; kl != nil; kl = tl kl)
detachkid(hd kl);
}
detachkid(k: ref Kid)
{
if(k == nil){
alert("No current thread");
return;
}
if(k.state == Exited){
killkid(k);
return;
}
# kill off the debugger progs
killpid(k.watch);
killpid(k.run);
err := k.prog.start();
if(err != "")
alert("Detaching thread: "+err);
delkid(k);
}
kidstate()
{
ts : array of string;
if(kid == nil){
tkcmd(".Wm_t.title configure -text '"+title);
if(debsrc->packed == nil){
tkcmds(tktop, searchoff);
ts = tknobody;
}else{
ts = tkloaded;
tkcmds(tktop, searchon);
}
}else{
tkcmd(".Wm_t.title configure -text '"+title+" "+string kid.prog.id+" "+status[kid.state]);
ts = tktools[kid.state];
tkcmds(tktop, searchon);
}
if(ts != toolstate){
toolstate = ts;
tkcmds(tktop, ts);
}
}
#
# update the stack an src displays
# to reflect the current state of k
#
refresh(k: ref Kid)
{
if(k.state == Killing || k.state == Killed){
kidstate();
return;
}
(s, err) := k.prog.stack();
if(s == nil && err == "")
err = "No stack";
if(err != ""){
kidstate();
return;
}
for(i := 0; i < len s; i++){
debsrc->findmod(s[i].m);
s[i].findsym();
}
err = s[0].findsym();
src := s[0].src();
kidstate();
m := s[0].m;
if(src == nil && len s > 1){
dis := s[0].m.dis();
if(len dis > 0 && dis[0] == '$'){
m = s[1].m;
s[1].findsym();
src = s[1].src();
}
}
debsrc->showmodsrc(debsrc->findmod(m), src);
k.stack.refresh(s);
k.stack.show();
}
pickup(pid: int): ref Kid
{
for(kl := kids; kl != nil; kl = tl kl)
if((hd kl).prog.id == pid)
return hd kl;
k := newkid(pid);
if(k == nil)
return nil;
k.cmd <-= KidGrab;
k.state = Running;
k.pickup = 1;
if(kid == nil){
kid = k;
refresh(kid);
}
return k;
}
loaded(s: string)
{
for(bl := bpts; bl != nil; bl = tl bl){
b := hd bl;
debsrc->attachdis(b.m);
if(s == b.m.dis){
for(kl := kids; kl != nil; kl = tl kl)
(hd kl).prog.setbpt(s, b.pc);
}
}
}
Enofd: con "no free file descriptors\n";
newkid(pid: int): ref Kid
{
(p, err) := debug->prog(pid);
if(err != ""){
n := len err - len Enofd;
if(n >= 0 && err[n: ] == Enofd && freekids()){
(p, err) = debug->prog(pid);
if(err == "")
return mkkid(p);
}
alert("Can't pick up thread "+err);
return nil;
}
return mkkid(p);
}
mkkid(p: ref Prog): ref Kid
{
for(bl := bpts; bl != nil; bl = tl bl){
b := hd bl;
debsrc->attachdis(b.m);
p.setbpt(b.m.dis, b.pc);
}
k := ref Kid(Stopped, p, -1, -1, 0, chan of int, Vars.create());
kids = k :: kids;
c := chan of int;
spawn kidslave(k, c);
k.run = <- c;
spawn kidwatch(k, c);
k.watch = <-c;
me := ".prog.v."+string p.id;
tkcmd("label "+me+" -text "+string p.id);
tkcmd("pack "+me+" -side top -fill x");
tkcmd("bind "+me+" <ButtonRelease-1> {send m seeprog "+string p.id+"}");
tkcmd(".prog.d configure -scrollregion {0 0 [.prog.v cget -width] [.prog.v cget -height]}");
return k;
}
spawnkid(o: ref Options): ref Kid
{
m := o.mod;
if(m == nil){
alert("No module to run");
return nil;
}
if(!debsrc->attachdis(m)){
alert("Can't load Dis file "+m.dis);
return nil;
}
(p, err) := debug->startprog(m.dis, o.dir, kidctxt, m.dis :: o.args);
if(err != nil){
alert(m.dis+" is not a debuggable Dis command module: "+err);
return nil;
}
return mkkid(p);
}
xlate := array[] of {
KidStep => Debug->StepExp,
KidStmt => Debug->StepStmt,
KidOver => Debug->StepOver,
KidOut => Debug->StepOut,
};
kidslave(k: ref Kid, me: chan of int)
{
me <-= sys->pctl(0, nil);
me = nil;
for(;;){
c := <-k.cmd;
case c{
KidGrab =>
err := k.prog.grab();
kidack <-= (k, err);
KidStep or KidStmt or KidOver or KidOut =>
err := k.prog.step(xlate[c]);
kidack <-= (k, err);
KidKill =>
err := "kill "+k.prog.kill();
k.prog.kill(); # kill again to slay blocked progs
kidack <-= (k, err);
exit;
KidRun =>
err := k.prog.cont();
kidack <-= (k, err);
* =>
sys->print("kidslave: bad command %d\n", c);
exit;
}
}
}
kidwatch(k: ref Kid, me: chan of int)
{
me <-= sys->pctl(0, nil);
me = nil;
for(;;)
kidevent <-= (k, k.prog.event());
}
alert(m: string)
{
dialog->prompt(context, tktop.image, "warning -fg yellow",
"Debugger Alert", m, 0, "Dismiss"::nil);
}
tkcmd(cmd: string): string
{
s := tk->cmd(tktop, cmd);
# if(len s != 0 && s[0] == '!')
# sys->print("%s '%s'\n", s, cmd);
return s;
}
sysname(): string
{
fd := sys->open("#c/sysname", sys->OREAD);
if(fd == nil)
return "Anon";
buf := array[128] of byte;
n := sys->read(fd, buf, len buf);
if(n < 0)
return "Anon";
return string buf[:n];
}
tkcmds(top: ref Tk->Toplevel, cmds: array of string)
{
for(i := 0; i < len cmds; i++)
tk->cmd(top, cmds[i]);
}
exitdb()
{
fd := sys->open("#p/"+string dbpid+"/ctl", sys->OWRITE);
if(fd != nil)
sys->fprint(fd, "killgrp");
exit;
}
killpid(pid: int)
{
fd := sys->open("#p/"+string pid+"/ctl", sys->OWRITE);
if(fd != nil)
sys->fprint(fd, "kill");
}
getuser(): string
{
fd := sys->open("/dev/user", Sys->OREAD);
if(fd == nil)
return "";
buf := array[128] of byte;
n := sys->read(fd, buf, len buf);
if(n < 0)
return "";
return string buf[0:n];
}
debconf(): string
{
return "/usr/" + getuser() + "/lib/deb";
}
readopts(o: ref Options)
{
fd := sys->open(debconf(), Sys->OREAD);
if(fd == nil)
return;
b := array[4] of byte;
if(sys->read(fd, b, 4) != 4)
return;
o.nrun = int b[0]-'0';
o.xkill = int b[1]-'0';
o.xscroll = int b[2]-'0';
o.remcr = int b[3]-'0';
}
writeopts(o: ref Options)
{
fd := sys->create(debconf(), Sys->OWRITE, 8r660);
if(fd == nil)
return;
b := array[4] of byte;
b[0] = byte (o.nrun+'0');
b[1] = byte (o.xkill+'0');
b[2] = byte (o.xscroll+'0');
b[3] = byte (o.remcr+'0');
sys->write(fd, b, 4);
}