diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2006 Andy Gill, Colin Runciman +Copyright (c) 2006-2007 Galois, Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The names of the authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fs/code.html b/fs/code.html new file mode 100644 --- /dev/null +++ b/fs/code.html @@ -0,0 +1,5 @@ + + + The Boot Sequence... + + diff --git a/fs/default.css b/fs/default.css new file mode 100644 --- /dev/null +++ b/fs/default.css @@ -0,0 +1,6 @@ +span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px } +span.spaces { background: white; border: none } +.cap { font-size: 140% } +td.logo { letter-spacing: 1.2px } +td.rhs { font-weight: bold } +input.hdbutton { height: 40px } diff --git a/fs/default.js b/fs/default.js new file mode 100644 --- /dev/null +++ b/fs/default.js @@ -0,0 +1,1056 @@ +// We want to load this code once. + +////////////////////////////////////////////////////////////////////////////// +// Some global vars + +var run_status = 0; + +////////////////////////////////////////////////////////////////////////////// + +var XMLHttpRequests = new Array(); + +function XMLHttpRequestFactory() { + if (XMLHttpRequests.length > 0) { + return XMLHttpRequests.pop(); + } else { + var request = false; + try { + request = new XMLHttpRequest(); + } catch (failed) { + request = false; + } + if (!request) { + alert("Error initializing XMLHttpRequest!"); + } + return request; + } +} + +// This is a uniq number for all requests, to avoid cache hit problems. +uq = 0; + +function send(msg,args) { + // progressbar(true); + var i = 0; + var request = XMLHttpRequestFactory(); + var argMsg = msg + "?uq=" + uq++; + if (args != "") { + argMsg += "&" + args; + } + request.open("GET", argMsg,true); + // Abort the request if there is no response in a timely manner. (1 minute). + var timeout = setTimeout(function () { + alert("request did not get response, aborting"); + request.abort(); + XMLHttpRequests.push(request); + },60000); + request.onreadystatechange = function () { + if (request.readyState == 4) { + // Please do not cancel this request; we will return it to the factory. + clearTimeout(timeout); + // progressbar(false); + try { + if (request.status == 200) { + // alert(request.responseText); + // Frightfully simple; evaluate the text in the content of top.status + try { + eval(request.responseText); + } catch (problem) { + alert('callback failure : ' + problem + "\n" + request.responseText); + } + } else { + // Should *never* happen. + alert('status != 200 ' + request.status); + } + } catch (problem) { + alert('status wrong or callback aborted:' + problem); + request.abort(); + } + // Return the completed xml + XMLHttpRequests.push(request); + } + }; + request.send(null); +} + +////////////////////////////////////////////////////////////////////////////// + +function setField(name,val) { + var w = top.status.document.getElementById(name); + if (w.innerHTML != val) { + w.innerHTML = val; + } +} + +////////////////////////////////////////////////////////////////////////////// +// Show functions + +function showLocation(loc) { + if (loc == null) { + return "-"; + } else { + if (loc.startLine == loc.endLine) { + return loc.startLine + ":" + loc.startCol + "-" + loc.endCol; + } + return loc.startLine + ":" + loc.startCol + "-" + + loc.endLine + ":" + loc.endCol; + } +} + +////////////////////////////////////////////////////////////////////////////// +// Local State + +var state = new Object(); + +state.module = ''; // which module is the cursor at? +state.location = ''; // HTML of location +state.event = ''; // simple string of event +state.eventtext = ''; // HTML of event description +state.counter = ''; +state.threadid = ''; +state.tixboxNo = ''; +state.tixboxType = ''; +state.lineno = ''; +state.viewedModule = ''; // which module is the user looking at? +state.modNames = new Object(); +state.fontsize = '10'; +state.linespacing = '13'; + + +function stateAlert () { + alert("state.module = " + state.module + "\n" + + "state.viewedModule = " + state.viewedModule + "\n" + + ""); + +} + +// These functions both modify the state, and also +// modify any viewer on the data, like the status box. + +function setModule(mod) { + setField("module",mod); + // Also set the pulldown box to the correct module. + + if (state.module != mod) { + var w = state.modNames["mod_" + state.module]; + if (w != undefined) { + w.setAttribute("style","background: white"); + } + var w = state.modNames["mod_" + mod]; + if (w != undefined) { + w.setAttribute("style","background: yellow"); + } + } + state.module = mod; +} + +function setLocation(loc) { + state.location = loc; + setField("location",showLocation(loc)); +} + +function setEvent2(e,et) { + state.event = e; + state.eventtext = e; + setField("event",et); +} + +function setCounter(c) { + state.counter = c; + setField("counter",c); +} + +function setThreadID(tid) { + state.counter = tid; + setField("thread_no",tid); +} + +function setTickInfo(tick,ty,lineno) { + state.tixboxNo = tick; + state.tixboxType = ty; + state.lineno = lineno; +} + +function clearTickInfo() { + state.tixboxNo = ''; + state.tixboxType = ''; + state.lineno = ''; + unmark(); +} + + +function setViewedModule(modName) { + state.viewedModule = modName; + top.status.document.getElementById('allmodules').value = modName; +} + +var breakpoints = new Array(0); +var breakpoints2 = new Array(0); + +function setBreakpoint(o) { + var name = breakPointToName(o); + var fullName = breakPointToText(o); + breakpoints.push(name); + var name = breakPointToName(o); + // Do not add if we already have it. + for(var i = 0;i < breakpoints2.length;i++) { + // TODO: We could cache the JSON string inside the breakpoints + if (breakPointToName(breakpoints2[i]) == name) { + return; + } + } + breakpoints2.push(o); // Adding this to the bottom of the breakpoint list + + // showLog("set " + breakpoints.length); + var w = top.status.document.getElementById(name); + + if (w != undefined) { + // If this value is ticked, then do not display it in the + // Create Breakpoints list. + w.style.display = 'none'; + } + + // Now we look for this exception in the Active Breakpoints list. + var w = top.status.document.getElementById(name + '_active'); + if (w != undefined) { + var rows = w.parentNode; + rows.removeChild(w); + } + + var tab = top.status.document.getElementById('Breakpoints'); + var newRow = tab.insertRow(-1); // insert at bottom + if (breakpoints2.length % 2 == 0) { + newRow.setAttribute("style","background: #f0f0f0"); + } else { + newRow.setAttribute("style","background: #f8f8f8"); + } + newRow.setAttribute("id",name + '_active'); + + var newCell = newRow.insertCell(0); + + var newText = top.status.document.createTextNode(fullName); + newCell.setAttribute("align","right"); + newCell.appendChild(newText); + + var newCell = newRow.insertCell(1); + var newElem = top.status.document.createElement("input"); + newElem.setAttribute("type","checkbox"); + newElem.checked = true; + newElem.onchange = function () { + breakpoint(o,newElem.checked); + }; + newCell.appendChild(newElem); +} + +function clearBreakpoint(o) { + var name = breakPointToName(o); + for(var i = 0;i < breakpoints2.length;i++) { + if (breakPointToName(breakpoints2[i]) == name) { + breakpoints2.splice(i,1); + } + } + //showLog("clear " + breakpoints + " " + breakpoints.length); + var w = top.status.document.getElementById(name); + if (w != undefined) { + w.style.display = ''; + } + + var tb = top.status.document.getElementById(name + '_checkbox'); + if (tb != undefined) { + tb.checked = false; + } + + // Now we look for this exception in the Active Breakpoints list. + var w = top.status.document.getElementById(name + '_active'); + if (w != undefined) { + var rows = w.parentNode; + rows.removeChild(w); + } +} + +function breakPointToText(o) { + switch (o) { + case "AllExceptions": + return 'All Exceptions'; + break; + case "ThreadChange": + return 'All Thread Changes'; + break; + case "ThreadTermination": + return 'All Thread Terminations'; + break; + default: + switch(o.tag) { + case "CounterAt": + return 'Counter # ' + o.count; + break; + case "ThreadChangeTo": + return 'Thread Change To TID# ' + o.tid; + break; + case "TickBox": + var loc = o.tickInfo.location; + return o.tickInfo.module + " " + + loc.startLine + ":" + loc.startCol + "-" + + loc.endLine + ":" + loc.endCol; + break; + default: + alert("switch problem: breakPointToText" + o.toJSONString()); + } + } +} + +function breakPointToName(o) { + switch (o) { + case "AllExceptions": + case "ThreadChange": + case "ThreadTermination": + return(o); + break; + default: + switch(o.tag) { + case "CounterAt": + return 'CounterAt_' + o.count; + break; + case "ThreadChangeTo": + return 'ThreadChangeTo_' + o.tid; + break; + case "TickBox": + return 'TickBox_' + o.tickInfo.global; + break; + default: + alert("switch problem: breakPointToName" + o.toJSONString()); + } + } +} + +////////////////////////////////////////////////////////////////////////////// +// All the modules in this section have an entry in AjaxAPI.hs + + +function setEvent(event) { + switch(event) { + case "Raise": + setEvent2("Exception","
Exception!
"); + break; + case "Finished": + setEvent2("Finished","
Program Finished
"); + break; + case "ThreadFinished": + setEvent2("Finished","
Thread Finished
"); + break; + default: + switch(event.tag) { + case "Tick": + var tick = event.tick; + setEvent2(tick,"#" + tick); + break; + default: + alert("switch problem " + event.toJSONString()); + } + } +} + + +function setTicked(tickInfo) { + //alert(tickInfo.toJSONString()); + if (tickInfo == null) { + setModule("-"); + setLocation(null); + clearTickInfo(); + unmark(); + } else { + setLocation(tickInfo.location); + setModule(tickInfo.module); + setTickInfo(tickInfo.local,tickInfo.tickType,tickInfo.location.startLine); + addMarkings(); + } +} + +function setModules(modNames) { + for(var i = 0; i < modNames.length;i++) { + var modName = modNames[i]; + var w = top.status.document.getElementById("allmodules"); + var o = document.createElement("option"); + o.setAttribute("value",modName); + w.appendChild(o); + o.appendChild(document.createTextNode(modName)); + state.modNames["mod_" + modName] = o; + } +} + +function clearBreakPoints () { + // Simply remove all the breakpoints + while(breakpoints2.length > 0) { + clearBreakpoint(breakpoints2[0]); + } +} + +// TODO: rename this back +function setBreakPoint2(o) { + setBreakpoint(o); +} + +function setBreakPointLights(lights) { + for(var i = 0;i < breakpoints2.length;i++) { + var name = breakPointToName(breakpoints2[i]); + var w = top.status.document.getElementById(name + '_active'); + if (w != undefined) { + if (lights[i]) { + w.setAttribute("style","background: orange"); + } else { + w.setAttribute("style","background: "); + } + } + } +} + + +function setRunning(run) { + // Hmm, async issues, + switch(run) { + case "Stopped": + progressbar(false); + top.heading.document.getElementById("runbackbutton").disabled = false; + top.heading.document.getElementById("runbutton").disabled = false; + top.heading.document.getElementById("stopbutton").disabled = true; + break; + case "Forward": + case "Backward": + progressbar(true); + top.heading.document.getElementById("runbackbutton").disabled = true; + top.heading.document.getElementById("runbutton").disabled = true; + top.heading.document.getElementById("stopbutton").disabled = false; + please_continue(); + } +} + + +////////////////////////////////////////////////////////////////////////////// + +function running(count) { + setCounter(count); + // Check to see if the breakpoint has been found + // The result is either + // - (re)calling running + // - calling setState + // This is where any animation might live. + pleasecontinue(); +} + + +////////////////////////////////////////////////////////////////////////////// + +function showMessage(msg) { + top.footing.document.getElementById("global_message").innerHTML = msg; +} + + +function showLog(msg) { + var newText = top.status.document.createTextNode(msg); + top.status.document.getElementById("scratch").appendChild(newText); + var br = top.status.document.createElement("BR"); + top.status.document.getElementById("scratch").appendChild(br); +} + + +// Combine these below + +function drawStart(count) { + setEvent("Booting","booting..."); + clearTickInfo(); + unmark(); +} + +function drawRaise(count,tid) { + // Mark up the global tick count + setEvent("Exception","
Exception!
"); + clearTickInfo(); + unmark(); +} + +function drawThread(count,tid) { + // Mark up the global tick count + setEvent("ThreadChange","
Change to Thread # " + tid + "
"); + clearTickInfo(); + unmark(); +} + +function drawThreadFinished(count,tid) { + // Mark up the global tick count + setEvent("ThreadFinished","
Thread# " + tid + " finished
"); + clearTickInfo(); + unmark(); +} + +// This makes sure that the currently marked module is +// highlighted in yellow +function markModule(modName) { + // o.setAttribute("style","background: green"); +} + +function menu(m) { + if (m.value == 'Next Exception') { + send("/next_exception"); + } + m.value = '...'; +} + + +theLineSpacing = 16; + +// For some reason, when you ask for font size 12, you get 14, etc, etc. +// The argument is the font size you asked for, 'theLineSpacing' contains +// the real size of the font. Perhaps this is just spacing between lines? +function fontsize(fs) { + alert("font: " + fs); + if (fs == 12) { + theLineSpacing = 16; + } else if (fs == 10) { + theLineSpacing = 13; + } else { + alert("strange font size"); + } +} + + + +var mark_elem = null; + +function unmark() { + if (mark_elem != null) { + mark_elem.style.border = ''; + mark_elem.style.background = ''; + } +} + +var ps = null; +var oldScroll = 0; +var when = null; + +function mark(n,ty,lineno) { + unmark(); + mark_elem = top.code.document.getElementById("t_" + n); + if (mark_elem != null) { + switch (ty) { + case "ExpBox": + case "AltBox": + // mark_elem.style.border = '1px solid orange'; + mark_elem.style.background = '#f0f000'; + break; + default: + switch(ty.tag) { + case "TopLevelBox": + case "LocalBox": + mark_elem.style.background = '#f0f000'; + break; + case "GuardBinBox": + case "CondBinBox": + case "QualBinBox": + if (ty.value) { + mark_elem.style.borderBottom = '3px double green'; + } else { + mark_elem.style.borderBottom = '3px double red'; + } + break; + default: + alert("switch problem " + ty.toJSONString()); + } + + } + // var viewerHeight = top.code.window.innerHeight; + // window.status = top.code.window.innerHeight; + + var newScroll = (lineno - 10) * state.linespacing; + + // Dont scroll if your newScoll is on your viewer. + top.code.scroll(0,newScroll); + + } +} + +// Add any markup onto the current page. +// If we do not have the correct page loaded, then initiate the +// load of the correct page, which will eventually re-call addMarkings. + +// TODO: rename this function better. + +function addMarkings() { + if (state.module != state.viewedModule) { + viewModule(state.module); + return; + } + mark(state.tixboxNo,state.tixboxType,state.lineno); +} + + +////////////////////////////////////////////////////////////////////////////// + +// Called after every loading the code page. +// +// This is a chance to set the font, move the scroll bar, +// markup the text, restore callbacks, etc, etc. + +function codeloaded (modName) { + setViewedModule(modName); + top.code.document.body.style.fontSize = "" + state.fontsize + "pt"; + top.code.onmousedown = mousedownCode; + top.code.onmousemove = mousemoveCode; + top.code.onmouseup = mouseupCode; + if (state.module == state.viewedModule) { + // This module needs markup, because it contains the cursor + // We do not just call addMarkings, because it loaded + // the cursor page as a side-effect. + addMarkings(); + } +} + +////////////////////////////////////////////////////////////////////////////// +// Callbacks from Javascript buttons, etc, to perform actions. + +function viewModule(modName) { + // TODO: perhaps some sort of visual cue of action pending. + // top.code.document.body.innerHTML = "loading : " + modName; + top.code.location.href=modulecode(modName) +} + +////////////////////////////////////////////////////////////////////////////// + +function numberEnterFrom(myfield,e,name,field) { + var keycode; + if (window.event) { + keycode = window.event.keyCode; + } else { + if (e) { + keycode = e.which; + } else { + return true; + } + } + if (keycode == 13) { + // TODO: check for number value only + var obj = { "tag" : name }; + obj[field] = myfield.value; + breakpoint(obj,true); + myfield.value = ""; + return false; + } + return true; +} + +////////////////////////////////////////////////////////////////////////////// + +function getTextFromCodeNode(w) { + if (w.nodeType == Node.TEXT_NODE) { + if (w.nodeValue == undefined) { + return "{{*}}"; + } else { + return w.nodeValue; + } + } else { + var children = w.childNodes; + var text = ""; + for(var i = 0;i < children.length;i++) { + text += getTextFromCodeNode(children[i]); + } + return text; + } +} + + +function mousedownCode(mouseEvent) { + var x = mouseEvent.clientX; + var y = mouseEvent.clientY; + var x2 = mouseEvent.pageX; + var y2 = mouseEvent.pageY; + var target = mouseEvent.target; + var id = mouseEvent.target.id; + var t = ("" + x + " " + + y + " " + + x2 + " " + + y2 + " " + + target + " " + + target.id + " " + + ""); + +// alert("clicked: " + t); + +// target.style.background = 'pink'; + + var txtls = ""; + var re = /t_(\d+)/; + var w = target; + var menuItems = new Array(0); + while (w != null && w.parentNode != undefined) { + if (w.id != undefined) { + var o = re.exec(w.id); + if (o != null) { + var text = getTextFromCodeNode(w); + if (text.length > 30) { + text = text.substr(0,28) + " ..."; + } + menuItems.push({ id : o[1], text : text }); + } + } + w = w.parentNode; + } + + t += " " + txtls; + + if (menuItems.length > 0) { + var newElem = top.status.document.createElement("div"); + + newElem.setAttribute("id","codemenu"); + newElem.style.position='absolute'; + newElem.style.top = "" + (y2 - 5) + 'px'; + newElem.style.left = "" + (x2 - 5) + 'px'; + newElem.style.width = "200px"; + newElem.style.opacity = '0.95'; + newElem.style.backgroundColor = 'white'; + + var table = document.createElement("table"); + table.setAttribute("border", "1"); +// table.setAttribute("background", "white"); + var tbody = document.createElement("tbody"); + var tr = document.createElement("tr"); + var th = document.createElement("th"); + th.appendChild(document.createTextNode("Set Breakpoint")); + tr.appendChild(th); + tbody.appendChild(tr); + for(var i = 0;i < menuItems.length;i++) { + var tr = document.createElement("tr"); + var td = document.createElement("td"); + td.appendChild(document.createTextNode(menuItems[i].text)); + td.id = 'menu_' + i; + td.onmouseover = function(event) { + event.target.style.background = 'orange'; + } + td.onmouseout = function(event) { + event.target.style.background = 'white'; + } + td.onmouseup = function(event) { + var ix = /menu_(\d+)/.exec(event.target.id)[1]; +// alert(menuItems[ix].toJSONString()); + breakpoint({ tag : "ReqTickBox", + module : state.viewedModule, + id : parseInt(menuItems[ix].id) + },true); + return true; // so the widget above can remove the menu + } + tr.appendChild(td); + tbody.appendChild(tr); + } + table.appendChild(tbody); + + newElem.appendChild(table); + + top.code.document.body.appendChild(newElem); + } + return false; +} + +var bp_highlighted = null; + +function mousemoveCode(mouseEvent) { +/* + var x = mouseEvent.clientX; + var y = mouseEvent.clientY; + var x2 = mouseEvent.pageX; + var y2 = mouseEvent.pageY; + var target = mouseEvent.target; + if (mouseEvent.ctrlKey) { // For now, untill we debug it + var id = mouseEvent.target.id; + // Perhaps dig for the + if (id != undefined) { + + } else { + if (bp_highlighted = null; + } + mousedownCode(mouseEvent); + } +*/ + return true; +} + +function mouseupCode(mouseEvent) { + var o = top.code.document.getElementById('codemenu'); + if (o != undefined) { + var p = o.parentNode; + p.removeChild(o); + } + + return true; // someone else might want to see the mouseup button. +// value = modName; +} + + +////////////////////////////////////////////////////////////////////////////// + + +var progressTid = null; + +// Show progress bar +function progressbar(show) { + if (show == true) { + if (progressTid != null) { + return; + } + /* You could put this into a timeout */ + var d = top.status.document; + var w = d.getElementById("progress"); + w.style.visibility = ""; + progressTid = {}; +// progressTid = setTimeout(function () {},100); + } else { + if (progressTid == null) { + return; + } +// clearInterval(progressTid); + progressTid = null; + var d = top.status.document + var w = d.getElementById("progress"); + w.style.visibility = "hidden"; + } +} + +/* + + + if (w == null) { + var newElem = d.createElement("div"); + newElem.setAttribute("id","progress"); + newElem.style.position='absolute'; + newElem.style.top = "0px"; + newElem.style.left = "100px" + newElem.style.opacity = '0.95'; + newElem.style.backgroundColor = 'white'; + + var newImage = d.createElement("img"); + newImage.src = "progress.gif"; + newElem.appendChild(newImage); + d.body.appendChild(newElem); + w = newElem; + } + + if (show) { + w.style.visibility = ""; + } else { + w.style.visibility = "hidden"; + } +} +*/ + + +////////////////////////////////////////////////////////////////////////////// + + +setTimeout(function () { +// alert(escape(({ "Hello World": "This is a %32 Test", "World": 2.0 }).toString())); +// alert(true.toJSONString()); + init_please(); + send("/boot","") },500); + + +function init_please() { +// top.code.onclick = function () { alert("loaded"); } +// onclick = function () { alert("loaded2"); } +// top.onclick = function () { alert("loaded3"); } +} + +////////////////////////////////////////////////////////////////////////////// +/* AJG: from http://www.json.org/json.js + */ +/* + json.js + 2006-12-06 + + This file adds these methods to JavaScript: + + array.toJSONString() + boolean.toJSONString() + date.toJSONString() + number.toJSONString() + object.toJSONString() + string.toJSONString() + These methods produce a JSON text from a JavaScript value. + It must not contain any cyclical references. Illegal values + will be excluded. + + The default conversion for dates is to an ISO string. You can + add a toJSONString method to any date object to get a different + representation. + + string.parseJSON(hook) + This method parses a JSON text to produce an object or + array. It can throw a SyntaxError exception. + + The optional hook parameter is a function which can filter and + transform the results. It receives each of the values, and its + return value is used instead. If it returns what it received, then + structure is not modified. + + Example: + + // Parse the text. If it contains any "NaN" strings, replace them + // with the NaN value. All other values are left alone. + + myData = text.parseJSON(function (value) { + if (value === 'NaN') { + return NaN; + } + return value; + }); + + It is expected that these methods will formally become part of the + JavaScript Programming Language in the Fourth Edition of the + ECMAScript standard in 2007. +*/ +if (!Object.prototype.toJSONString) { + Array.prototype.toJSONString = function () { + var a = ['['], b, i, l = this.length, v; + + function p(s) { + if (b) { + a.push(','); + } + a.push(s); + b = true; + } + + for (i = 0; i < l; i += 1) { + v = this[i]; + switch (typeof v) { + case 'undefined': + case 'function': + case 'unknown': + break; + case 'object': + if (v) { + if (typeof v.toJSONString === 'function') { + p(v.toJSONString()); + } + } else { + p("null"); + } + break; + default: + p(v.toJSONString()); + } + } + a.push(']'); + return a.join(''); + }; + + Boolean.prototype.toJSONString = function () { + return String(this); + }; + + Date.prototype.toJSONString = function () { + + function f(n) { + return n < 10 ? '0' + n : n; + } + + return '"' + this.getFullYear() + '-' + + f(this.getMonth() + 1) + '-' + + f(this.getDate()) + 'T' + + f(this.getHours()) + ':' + + f(this.getMinutes()) + ':' + + f(this.getSeconds()) + '"'; + }; + + Number.prototype.toJSONString = function () { + return isFinite(this) ? String(this) : "null"; + }; + + Object.prototype.toJSONString = function () { + var a = ['{'], b, i, v; + + function p(s) { + if (b) { + a.push(','); + } + a.push(i.toJSONString(), ':', s); + b = true; + } + + for (i in this) { + if (this.hasOwnProperty(i)) { + v = this[i]; + switch (typeof v) { + case 'undefined': + case 'function': + case 'unknown': + break; + case 'object': + if (v) { + if (typeof v.toJSONString === 'function') { + p(v.toJSONString()); + } + } else { + p("null"); + } + break; + default: + p(v.toJSONString()); + } + } + } + a.push('}'); + return a.join(''); + }; + + + (function (s) { + var m = { + '\b': '\\b', + '\t': '\\t', + '\n': '\\n', + '\f': '\\f', + '\r': '\\r', + '"' : '\\"', + '\\': '\\\\' + }; + + s.parseJSON = function (hook) { + try { + if (/^("(\\.|[^"\\\n\r])*?"|[,:{}\[\]0-9.\-+Eaeflnr-u \n\r\t])+?$/. + test(this)) { + var j = eval('(' + this + ')'); + if (typeof hook === 'function') { + function walk(v) { + if (v && typeof v === 'object') { + for (var i in v) { + if (v.hasOwnProperty(i)) { + v[i] = walk(v[i]); + } + } + } + return hook(v); + } + return walk(j); + } + return j; + } + } catch (e) { + } + throw new SyntaxError("parseJSON"); + }; + + s.toJSONString = function () { + if (/["\\\x00-\x1f]/.test(this)) { + return '"' + this.replace(/([\x00-\x1f\\"])/g, function(a, b) { + var c = m[b]; + if (c) { + return c; + } + c = b.charCodeAt(); + return '\\u00' + + Math.floor(c / 16).toString(16) + + (c % 16).toString(16); + }) + '"'; + } + return '"' + this + '"'; + }; + })(String.prototype); +} + diff --git a/fs/favicon.ico b/fs/favicon.ico new file mode 100644 Binary files /dev/null and b/fs/favicon.ico differ diff --git a/fs/footer.html b/fs/footer.html new file mode 100644 --- /dev/null +++ b/fs/footer.html @@ -0,0 +1,15 @@ + + + + + + + + + +
booting... +   + +
+ + diff --git a/fs/header.html b/fs/header.html new file mode 100644 --- /dev/null +++ b/fs/header.html @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + + + + + + +
+ + + + + + + + + +
+ + + diff --git a/fs/progressbar_green.gif b/fs/progressbar_green.gif new file mode 100644 Binary files /dev/null and b/fs/progressbar_green.gif differ diff --git a/fs/root.html b/fs/root.html new file mode 100644 --- /dev/null +++ b/fs/root.html @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/fs/status.html b/fs/status.html new file mode 100644 --- /dev/null +++ b/fs/status.html @@ -0,0 +1,100 @@ + + + + + +
+ Status + + + + + + + + + + + + + + + + + + + + + + + + +
Module :
Location :
Event :
Counter :
Thread # : 
+
+
+
+ View Module + +
+
+
+ Breakpoints + +
+
+
+
+ Create Breakpoints + + + + + + + + + + + + + + + + + + + + + + + + + + \n" ++ + "" + return (wrap,state') + + +------------------------------------------------------------------------------ + +createHtml :: String -> String -> String -> IO String +createHtml hpcDir srcDir modName = do + + mix@(Mix origFile _ _ tabStop mix') <- readMix [srcDir ++ "/" ++ hpcDir] (Left modName) + +-- print mix + + let info = [ (pos,id) + | (id,(pos,boxLabel)) <- zip [0 ..] mix' +{- + , case boxLabel of + ExpBox {} -> True + AltBox {} -> True + TopLevelBox {} -> True + LocalBox {} -> True + _ -> False +-} + ] + + let tickLocs = [ (Loc ln1 c1,Loc ln2 c2,id) + | (pos,id) <- info + , let (ln1,c1,ln2,c2) = fromHpcPos pos + ] + + let sortedTickLocs = sortBy (\ (locA1,locZ1,_) (locA2,locZ2,_) -> + (locA1,locZ2) `compare` (locA2,locZ1)) tickLocs + +-- print sortedTickLocs + + content <- readFileFromPath origFile srcDir + + let content' = addMarkup 1 content (Loc 1 1) [] sortedTickLocs + let show' = reverse . take 5 . (++ " ") . reverse . show + let addLine n xs = "" ++ show' n ++ " " ++ xs + let addLines = unlines . map (uncurry addLine) . zip [1..] . lines + return ("
\n" ++ addLines content' ++ "\n
\n") + +type Markup = Int + +addMarkup :: Int -- tabStop + -> String -- text to mark up + -> Loc -- current location + -> [(Loc,Markup)] -- stack of open ticks, with closing location + -> [(Loc,Loc,Markup)] -- sorted list of tick location pairs + -> String + +-- check the pre-condition. +--addMarkup tabStop cs loc os ticks +-- | not (isSorted (map fst os)) = error $ "addMarkup: bad closing ordering: " ++ show os + +--addMarkup tabStop cs loc os@(_:_) ticks +-- | trace (show (loc,os,take 10 ticks)) False = undefined + +-- close all open ticks, if we have reached the end +addMarkup _ [] loc os [] = + concatMap (const closeTick) os +addMarkup tabStop cs loc ((o,_):os) ticks | loc > o = + closeTick ++ addMarkup tabStop cs loc os ticks + +--addMarkup tabStop cs loc os ((t1,t2,tik@(TopLevelDecl {})):ticks) | loc == t1 = +-- openTick tik ++ closeTick ++ addMarkup tabStop cs loc os ticks + +addMarkup tabStop cs loc os ((t1,t2,tik):ticks) | loc == t1 = + openTick tik ++ addMarkup tabStop cs loc (addTo (t2,tik) os) ticks + where + + addTo (t,tik) [] = [(t,tik)] + addTo (t,tik) ((t',tik'):xs) | t <= t' = (t,tik):(t',tik'):xs + | t > t' = (t',tik):(t',tik'):xs + +addMarkup tabStop cs loc os ((t1,t2,tik):ticks) | loc > t1 = + -- throw away this tick, because it is from a previous place ?? + addMarkup tabStop cs loc os ticks + +addMarkup tabStop ('\n':cs) loc@(Loc ln col) os@((Loc ln2 col2,_):_) ticks + | ln == ln2 && col < col2 + = addMarkup tabStop (' ':'\n':cs) loc os ticks +addMarkup tabStop (c:cs) loc@(Loc _ p) os ticks = + if c=='\n' && os/=[] then + c : "" ++ expand 1 w ++ "" ++ + addMarkup tabStop cs' loc' os ticks + else if c=='\t' then + expand p "\t" ++ addMarkup tabStop cs (incBy c loc) os ticks + else + escape c ++ addMarkup tabStop cs (incBy c loc) os ticks + where + (w,cs') = span (`elem` " \t") cs + loc' = foldl (flip incBy) loc (c:w) + escape '>' = ">" + escape '<' = "<" + escape '"' = """ + escape '&' = "&" + escape c = [c] + + expand :: Int -> String -> String + expand _ "" = "" + expand c ('\t':s) = replicate (c' - c) ' ' ++ expand c' s + where + c' = tabStopAfter 8 c + expand c (' ':s) = ' ' : expand (c+1) s + expand _ _ = error "bad character in string for expansion" + + incBy :: Char -> Loc -> Loc + incBy '\n' (Loc ln c) = Loc (succ ln) 1 + incBy '\t' (Loc ln c) = Loc ln (tabStopAfter tabStop c) + incBy _ (Loc ln c) = Loc ln (succ c) + + tabStopAfter :: Int -> Int -> Int + tabStopAfter tabStop c = fromJust (find (>c) [1,(tabStop + 1)..]) + +addMarkup tabStop cs loc os ticks = + "ERROR: " ++ show (take 10 cs,tabStop,loc,take 10 os,take 10 ticks) + +data Loc = Loc !Int !Int + deriving (Eq,Ord,Show) + +openTick :: Markup -> String +openTick n = "" + +closeTick = "" + + + +readFileFromPath :: String -> String -> IO String +readFileFromPath filename@('/':_) _ = readFile filename +readFileFromPath filename path = readTheFile (splitPath path) + where + splitPath path = case span (/= ':') path of + (dir,':':more) -> dir : splitPath more + (dir,[]) -> [dir] + + readTheFile :: [String] -> IO String + readTheFile [] = error $ "could not find " ++ show filename + ++ " in path " ++ show path + readTheFile (dir:dirs) = + Prelude.catch + (do str <- readFile (dir ++ "/" ++ filename) + return str) + (\ _ -> readTheFile dirs) + +------------------------------------------------------------------------------ diff --git a/src/Common.hs b/src/Common.hs new file mode 100644 --- /dev/null +++ b/src/Common.hs @@ -0,0 +1,109 @@ +module Common where + +import Trace.Hpc.Util (HpcPos) +import Trace.Hpc.Mix (BoxLabel) + +------------------------------------------------------------------------------ +-- |An @Event@ is an item in the stream from the debugged process. + +-- our debugging trail is a list of events. +data Event = Tick !Int -- The global tick number + | Raise -- Any Raised exception + | ThreadFinished -- last event in a Thread + | Finished -- final event + +------------------------------------------------------------------------------ +-- |@TracerRequest@ are requests made by the Ajax interface of the debuggger. + +data TracerRequest + = StepRequest Direction + | InitRequest -- ^called at initialization time, to set things up + | RunRequest Direction -- until a breakpointable event + | SetBreakPoint BreakPoint + | ClearBreakPoint BreakPoint + | ContinueRequest -- ^keep running (looking for a breakpoint) + | StopRequest -- ^stop please (looking for a breakpoint) + +data Direction = Forward | Backward + deriving Show + +------------------------------------------------------------------------------ +-- |The @TracerState@ is the micro-architecture of the debugger; what information +-- we hold onto from step to step. + +data TracerState = TracerState + { tracerCounter :: !Integer -- ^the cursor + , tracerThreadID :: !ThreadID -- ^what thread is currently active + , tracerEvent :: !Event -- ^The current event + , tracerBreakPoints :: !BreakPoints + , tracerRunning :: Maybe Direction -- ^looking for a breakpoint + } + deriving Show + +-- Consider include the global id as well as the local id here. +data TickBoxInfo = TickBoxInfo + { tbiModule :: !String -- ^what module is at this cursor + , tbiLocation :: !HpcPos -- ^where is the cursor in the source? + , tbiLocalTickNo :: !LocalTickId -- ^local tick number, for displaying + , tbiGlobalTickNo :: !GlobalTickId -- ^global tick number + , tbiTickType :: !BoxLabel -- ^possible style of highlight + } + deriving (Show, Eq, Ord) + +type BreakPoints = [BreakPoint] -- does not include any abrevited breakpoints. + +data BreakPoint + = AllExceptions + | ThreadChange + | ThreadTermination + | ThreadChangeTo ThreadID + | CounterAt Integer + | TickBox TickBoxInfo + +-- These are abreviated versions sent from the GUI, +-- which does not have access to things like tick box location information. + | ReqTickBox String LocalTickId + + deriving (Show, Eq, Ord) + +------------------------------------------------------------------------------ +-- This is basically the TracerState, with some derived infomation. + +data GUIState = GUIState + { guiTracerState :: TracerState + , guiTracerTicked :: Maybe TickBoxInfo -- which tick box to light up + , guiTracerBreakers :: [Bool] -- which breakpoints to light up + } + +------------------------------------------------------------------------------ +-- The @TracerResponse@ is what messages get sent back to the GUI about +-- changes in the TracerState. + +data TracerResponse + = TracerStateResponse !GUIState -- ^The brute force update; just update everything! + | MultiResponse [TracerResponse] -- ^For when you want to send several responses + | ModuleListResponse [String] -- ^A list of all possible modules in this program + | RunResponse !Integer -- ^The curent cursor when looking for a breakpoint + +type ThreadID = Int -- Threads later will be strings +type GlobalTickId = Int -- tick number inside a specific executable +type LocalTickId = Int -- tick number inside a specific module + +------------------------------------------------------------------------------ + +instance Show Event where + show (Tick n) = show n + show (Raise) = "Raise" + show (ThreadFinished) = "ThreadFinished" + show (Finished) = "Finished" + +instance Read Event where + readsPrec _p ('R':'a':'i':'s':'e':xs) + = [(Raise,xs)] + readsPrec _p ('T':'h':'r':'e':'a':'d':'F':'i':'n':'i':'s':'h':'e':'d':xs) + = [(ThreadFinished,xs)] + readsPrec _p ('F':'i':'n':'i':'s':'h':'e':'d':xs) + = [(Finished,xs)] + readsPrec p xs = [ (Tick n,ys) | (n,ys) <- readsPrec p xs ] + + diff --git a/src/Debug.hs b/src/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Debug.hs @@ -0,0 +1,9 @@ +module Main where + + +fib :: Int -> Int +fib n = if n < 2 then 1 else fib(n-1) + fib (n-2) + +main = print $ fib 30 + + diff --git a/src/Flags.hs b/src/Flags.hs new file mode 100644 --- /dev/null +++ b/src/Flags.hs @@ -0,0 +1,38 @@ +module Flags where + + +-- Where to get the debugging stream from +data Mode + = ExecMode String [String] + | FileMode String + | AddrMode String Int + +data Flags = Flags + { mode :: Mode + , hpcdir :: String + , srcdir :: String + , port :: Int -- ^which port to provide HTTP on for Ajax viewer + , woop :: Int -- ^window of opertunity + } + + +-- Hack for now + +parseFlags :: [String] -> Flags +parseFlags ("--port":num:args) + = (parseFlags args) + { port = read num } +parseFlags ("--hpcdir":dir:args) + = (parseFlags args) + { hpcdir = dir } +parseFlags ("--srcdir":dir:args) + = (parseFlags args) + { srcdir = dir } +parseFlags (arg:args) = Flags (ExecMode arg args) + (".hpc") + (".") + 8091 + 10000 + + + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,118 @@ +-- The Hpc tracer viewer/debugger + +module Main where + +import Trace.Hpc.Mix +import Trace.Hpc.Tix +import Trace.Hpc.Util + +import Control.Concurrent +import Control.Exception as Exc +import Control.Concurrent.MVar + +import Network.TrivialWebServer +import Network.AjaxServer + +import System.Environment (getArgs, withArgs) + + + +import Reactive +import Common + +import MixActor +import TixActor +import CodeRenderActor +import TixStreamActor +import TracerActor +import AjaxAPI + +import CachedFiles + +import Flags +import StreamHandle + +------------------------------------------------------------------------------ + +main = do + args <- getArgs + let flags = parseFlags args + + (d_h,c_h) <- openStream flags + + step <- tracerActor (hpcdir flags) (srcdir flags) d_h c_h + + let tracerActor :: TracerRequest -> IO [AjaxCallback] + tracerActor req = do resp <- step req + let respTxt = sendTracerResponse resp +-- print respTxt + return $ respTxt + + toScreenRender <- codeRenderActor (hpcdir flags) (srcdir flags) + + let mkPage ty body = return $ PageResponse 200 False ty body + + let rpc = alts $ + [ call "boot" (tracerActor InitRequest) +{- + , call "step" (\ (n :: Int) -> tracerActor (StepRequest Forward)) + <*> jsonArg "count" +-} + , call "step/forward" (tracerActor (StepRequest Forward)) + , call "step/backward" (tracerActor (StepRequest Backward)) + , call "run/forward" (tracerActor (RunRequest Forward)) + , call "run/backward" (tracerActor (RunRequest Backward)) + , call "run/backward" (tracerActor (RunRequest Backward)) + , call "please/continue" (tracerActor ContinueRequest) + , call "please/stop" (tracerActor StopRequest) + ] ++ + [ jsonArg "status" <*> + jsonArg "breakpoint" <*> + call ("breakpoint") + ( \ bp onOff -> tracerActor + $ (if onOff then SetBreakPoint + else ClearBreakPoint) + $ bp + ) + ] {- ++ + + [ jsonArg "name" <*> + call "usertext" (\ name value -> do print (name::String,value::String) + return []) + ] -} + -- later, implement http://..:8091/modules/Foo as the render engine + let pageRpc = alts + [ jsonArg "module" <*> + call "modulecode" (\ mod -> do + txt <- toScreenRender mod + mkPage "text/html" txt) + ] + + + mVar <- newEmptyMVar + + let pages :: String -> IO PageResponse + pages "/favicon.ico" = mkPage "text/ico" favicon + pages "/progress.gif" = mkPage "image/gif" progress + pages "/" = mkPage "text/html" root_html + pages "/code.html" = mkPage "text/html" code_html + pages "/header.html" = mkPage "text/html" header_html + pages "/status.html" = mkPage "text/html" status_html + pages "/footer.html" = mkPage "text/html" footer_html + pages "/default.css" = do + -- hack to improve compile cycle. +-- default_css <- readFile "/Users/andy/darcs/hpc/tools/tracer/fs/default.css" + mkPage "text/css" default_css + pages "/default.js" = do + -- hack to improve compile cycle. +-- default_js <- readFile "/Users/andy/darcs/hpc/tools/tracer/fs/default.js" + mkPage "text/js" default_js + pages "/quit" = do putMVar mVar () + mkPage "text/html" "aborting" + pages other = do print other + mkPage "text/html" other + + forkIO $ ajaxServer (port flags) rpc pageRpc pages + + takeMVar mVar + return () diff --git a/src/MixActor.hs b/src/MixActor.hs new file mode 100644 --- /dev/null +++ b/src/MixActor.hs @@ -0,0 +1,9 @@ +module MixActor where + +import Trace.Hpc.Mix +import Reactive + +-- Cache the Mix file inside here. +mixActor :: String -> String -> IO (String -> IO Mix) +mixActor hpcDir srcDir = return $ + \ file -> readMix [srcDir ++ "/" ++ hpcDir] (Left file) diff --git a/src/Reactive.hs b/src/Reactive.hs new file mode 100644 --- /dev/null +++ b/src/Reactive.hs @@ -0,0 +1,107 @@ +module Reactive where + +import Control.Concurrent +import Control.Exception as Exc +import Control.Concurrent.MVar + +type Method s d = ((s -> IO s) -> IO ()) -> d + +mkActor :: s -> Method s d -> IO d +mkActor initState body = do + chan <- newChan + + let loop state = do body <- readChan chan + state' <- body state + loop state' + + myForkIO $ loop initState + + return $ body (writeChan chan) + +request :: (a -> s -> IO (r,s)) -> Method s (a -> IO r) +request fn send arg = do + m <- newEmptyMVar + send (\ st -> do (rep,st') <- fn arg st + putMVar m rep + return st') + takeMVar m + +mkActor3 :: s + -> ( (forall r . (s -> IO (r,s)) -> IO r) + -> ( (s -> IO s) -> IO ()) + -> actor) + -> IO actor +mkActor3 initState body = do + state <- newMVar initState + + let reqs fn = do + s <- takeMVar state + (r,s') <- fn s + putMVar state s' + return r + + let acts = undefined + + return $ body reqs acts + +mkActor2 :: s + -> ( (forall r . (s -> IO (r,s)) -> IO r) + -> ( (s -> IO s) -> IO ()) + -> actor) + -> IO actor +mkActor2 initState body = do + chan <- newChan + + let loop state = do body <- readChan chan + state' <- body state + loop state' + + myForkIO $ loop initState + + let reqs fn = do + m <- newEmptyMVar + writeChan chan $ \ st -> do (rep,st') <- fn st + putMVar m rep + return st' + takeMVar m + + let acts fn = do + writeChan chan $ \ st -> fn st + + return $ body reqs acts + +request2 :: ((s -> IO s) -> IO ()) -> (s -> IO (r,s)) -> IO r +request2 send fn = do + m <- newEmptyMVar + send (\ st -> do (rep,st') <- fn st + putMVar m rep + return st') + takeMVar m + +action :: (a -> s -> IO s) -> Method s (a -> IO ()) +action fn send arg = send (fn arg) + +test = mkActor ((99 :: Int)) + $ request (\ _a s -> return (show s,s + 1)) + +myForkIO m = do + forkIO (m `Exc.catch` \ e -> do + print "thread problem: " + print e + return ()) + +------------------------------------------------------------------------------ + +liftMethod :: ((a1 -> IO r1) -> (a2 -> IO r2) -> r) + -> Method s (a1 -> IO r1) + -> Method s (a2 -> IO r2) + -> Method s r +liftMethod fn m1 m2 arg = fn (m1 arg) (m2 arg) + +lift3Method :: ((a1 -> IO r1) -> (a2 -> IO r2) -> (a3 -> IO r3) -> r) + -> Method s (a1 -> IO r1) + -> Method s (a2 -> IO r2) + -> Method s (a3 -> IO r3) + -> Method s r +lift3Method fn m1 m2 m3 arg = fn (m1 arg) (m2 arg) (m3 arg) + diff --git a/src/StreamHandle.hs b/src/StreamHandle.hs new file mode 100644 --- /dev/null +++ b/src/StreamHandle.hs @@ -0,0 +1,44 @@ +module StreamHandle where + +import System.Posix.Process +import System.Posix.IO +import System.Posix.Env +import System.IO +import System.Exit +import Control.Concurrent + +import System.Cmd + +import Flags + +openStream :: Flags -> IO (Handle,Handle) +openStream flags = + case mode flags of + ExecMode exec args -> do + + (cmd_rd,cmd_wt) <- createPipe + (event_rd,event_wt) <- createPipe + + pid <- getProcessID + + forkProcess $ do + closeFd cmd_wt + closeFd event_rd + t1 <- getEnv "HPCRIX" + unsetEnv "HPCRIX" + setEnv "HPCRIX" (show event_wt ++ ":" ++ show cmd_rd) True + t2 <- getEnv "HPCRIX" + executeFile exec False args Nothing + -- should never return + return () + + d_h <- fdToHandle event_rd + c_h <- fdToHandle cmd_wt + + closeFd cmd_rd + closeFd event_wt + + return (d_h,c_h) + FileMode filename -> + undefined + diff --git a/src/TixActor.hs b/src/TixActor.hs new file mode 100644 --- /dev/null +++ b/src/TixActor.hs @@ -0,0 +1,88 @@ +module TixActor where + +import Trace.Hpc.Mix + +import Data.Array.MArray +import Data.Array.IO + +import Reactive +import MixActor + +import Common + +data TixActor = TixActor + { lookupGlobalTickInfo :: GlobalTickId -> IO TickBoxInfo + , lookupLocalTickInfo :: String -> LocalTickId -> IO TickBoxInfo + } + +globalTixActor :: String + -> String + -> [(String,Int)] + -> IO TixActor +globalTixActor hpcDir srcDir modSizes = do + getMix <- mixActor hpcDir srcDir + + let modOffsets = 0 : zipWith (+) (map snd modSizes) modOffsets + + let modInfo = [ (mod,(sz,offset)) + | ((mod,sz),offset) <- zip modSizes modOffsets + ] + +-- print modInfo + + let maxTixId = sum (map snd modSizes) - 1 + + -- fill the array with module name initially + + arr <- newListArray (0::Int,maxTixId) $ + concat [ [ Left mod | _ <- take sz [0..] ] + | (mod,sz) <- modSizes + ] + + let _types = (arr :: IOArray Int (Either String TickBoxInfo)) + + let fillIn modName = do + case lookup modName modInfo of + Nothing -> print $ "can not find : " ++ show modName + + Just (sz,offset) -> do + mix@(Mix _ _ _ _ mix') <- getMix modName + -- assert length mix' == sz +-- print ("writing",offset,length mix' + offset - 1,sz,length mix',modName) + sequence_ [ do writeArray arr ix $ Right $ TickBoxInfo + modName + loc + lix + ix + ty + | (lix,ix,(loc,ty)) <- zip3 [0..] [offset..] mix' + ] + + let findVal :: GlobalTickId -> IO TickBoxInfo + findVal n = do + val <- readArray arr n + case val of + Left modName -> do + fillIn modName + val' <- readArray arr n + case val' of + Left modName' -> do + print ("problem with loading array" ++ show (val,val',n)) + error "" + Right val' -> return $ val' + Right val -> return $ val + + let initState = () + + mkActor2 initState (\ request action -> TixActor + { lookupGlobalTickInfo = \ globId -> request $ \ () -> do + -- print ("glob=",globId) + val <- findVal globId + -- print ("find:",val) + return (val,()) + , lookupLocalTickInfo = \ modName localId -> request $ \ () -> do + case lookup modName modInfo of + Just (_,offset) -> do val <- findVal (localId + offset) + return (val,()) + Nothing -> error $ "bad module" ++ modName + }) diff --git a/src/TixStreamActor.hs b/src/TixStreamActor.hs new file mode 100644 --- /dev/null +++ b/src/TixStreamActor.hs @@ -0,0 +1,174 @@ +-- TODO: renamed as RixStreamActor + +module TixStreamActor (readTickActor, StreamActorResult(..), finished) where + +import Data.List as List +import System.IO +import Reactive + +import Common + +import Debug.Trace +import Data.Set(Set) +import qualified Data.Set as Set + +data State = State + { cursor :: ThreadedEvent + , count :: !Integer -- where we are + , target :: !Integer -- where we are going to + , before :: ![ThreadedEvent] + , after :: ![ThreadedEvent] + , stopAtTicks :: Set GlobalTickId + , remoteStopAtTicks + :: Set GlobalTickId + } deriving (Show) + + +finished :: State -> Bool +finished state = case cursor state of + ThreadedEvent Finished _ -> True + _ -> False + +-- Move this into TixStream. +data ThreadedEvent = ThreadedEvent !Event !ThreadID + deriving (Show) + +addEvent :: Event -> State -> ThreadedEvent +addEvent ev (State { cursor = ThreadedEvent _ tid }) = ThreadedEvent ev tid + +data StreamActorResult + = StreamActorResult + { counter :: !Integer -- ^global tick counter + , event :: !Event -- ^event at the cursor + , threadId :: !ThreadID -- ^the current thread (before/at the event) + , live :: !Bool -- ^is this the live event (False == historical result) + } + +-- move forward or back, finding the tick number. +readTickActor :: Handle -> Handle -> IO (Integer -> Set GlobalTickId -> IO StreamActorResult) +readTickActor d_handle cmd_handle = do + -- Will this help +-- t <- hGetBuffering d_handle +-- print t + +-- hSetBuffering d_handle (LineBuffering) +-- hSetBuffering cmd_handle (LineBuffering) + + tixTxt <- hGetLine d_handle + let (0,threadId',event') = parseEvent tixTxt + + let initState = + State { cursor = ThreadedEvent event' threadId' + , count = 0 + , target = 0 + , before = [] + , after = [] + , stopAtTicks = Set.empty + , remoteStopAtTicks = Set.empty + } + + let pull' :: Integer -> Set GlobalTickId -> State -> IO State + pull' n ticks state = pull $ state { target = n + , stopAtTicks = ticks + } + + -- check for breakpoint + check :: State -> IO State + check state@State { stopAtTicks = stopTicks, cursor = ThreadedEvent (Tick tickid) _ } + | tickid `Set.member` stopTicks = return state + check state = pull state + + pull :: State -> IO State + pull state@State { target = n , count = c } +-- | trace (show state) False = undefined + + -- reached target + | n == c = return state + + | n > c && null (after state) && not (finished state) = do + -- We need to read a new entry from the remote process + -- set break at the target + hPutStrLn cmd_handle ("c" ++ show n) -- set counter bp + sequence [ do hPutStrLn cmd_handle ("u" ++ show x) +-- print ("unseting bp at ",x) + | x <- Set.elems $ remoteStopAtTicks state + ] + sequence [ do hPutStrLn cmd_handle ("s" ++ show x) +-- print ("seting bp at ",x) + | x <- Set.elems $ stopAtTicks state + ] + hPutStrLn cmd_handle ("") -- run + hFlush cmd_handle + +-- print ("waiting for message") + -- and wait for the breakpoint to activate + tixTxt <- hGetLine d_handle +-- print ("got : ",tixTxt) +-- print tixTxt + let (count',threadId',event') = parseEvent tixTxt + + let before' = if c == count' - 1 + then cursor state : before state + else [] + + -- something interesting happened so we return anyway. + + return $ state { cursor = ThreadedEvent event' threadId' + , count = count' + , before = before' + , remoteStopAtTicks = stopAtTicks state + } + + | n > c && not (null $ after state) = + check (state { cursor = head $! after state + , count = count state + 1 + , before = cursor state : before state + , after = tail $! after state + }) + + | n < c && (null $ before state) && (current_loc /= 0) = do + -- we want to rewind here, so we pull some history + hPutStrLn cmd_handle ("h") -- history + hFlush cmd_handle + + befores <- + sequence [ do tixTxt <- hGetLine d_handle +-- print ("got(h): ",tixTxt) + let (count',threadId',event') = parseEvent tixTxt + if count' /= ix + then error $ "strangeness" ++ show (ix,count') + else return $ ThreadedEvent event' threadId' + | ix <- [(max 0 (current_loc - 1024)) .. (current_loc - 1) ] + ] + + pull $ state { before = drop (length $ after state) $ reverse befores } + + | n < c && not (null $ before state) = + check (state { cursor = head $! before state + , count = count state - 1 + , before = tail $! before state + , after = cursor state : after state + }) + + | otherwise = return state + + where + current_loc = c + fromIntegral (length (after state)) + + + mkActor2 initState $ \ request action targetCount tickBreakPoints -> + request $ \ state -> do + state' <- pull' targetCount tickBreakPoints state + let (ThreadedEvent event tid) = cursor state' + let isLive = not (List.null $ after state') + return (StreamActorResult (count state') event tid isLive,state') + + +parseEvent :: String -> (Integer,ThreadID,Event) +parseEvent xs = case words xs of + ["Event",counter,tid,op] + -> (read counter, read tid, read op) + _ -> error $ "parseEvent failure: " ++ show xs + + + diff --git a/src/TracerActor.hs b/src/TracerActor.hs new file mode 100644 --- /dev/null +++ b/src/TracerActor.hs @@ -0,0 +1,188 @@ +module TracerActor where + +import Trace.Hpc.Mix +import Trace.Hpc.Util + +import System.IO +import qualified Data.Set as Set + +import TixActor +import TixStreamActor + +import Reactive +import Common +import BreakPoint + +import Control.Concurrent + +-- The main actor + +data State = State + { count :: Integer + } + +type TracerActorState = (Maybe TracerState,TracerState) + + +tracerActor :: String + -> String + -> Handle -> Handle -> IO (TracerRequest -> IO TracerResponse) +tracerActor hpcDir srcDir d_handle cmd_handle = do + starts <- hGetLine d_handle + mods <- hGetLine d_handle + + getTix <- readTickActor d_handle cmd_handle + + StreamActorResult { counter = count + , event = tixInfo + , threadId = tid + , live = isLive + } <- getTix 0 (Set.empty) + + -- We actually store a pair of states, + -- - the current state according to the GUI, + -- - and the current state. + + let initState = TracerState + { tracerCounter = count + , tracerThreadID = tid + , tracerEvent = tixInfo + , tracerBreakPoints = [] + , tracerRunning = Nothing + } + +-- print mods + + let send v = return (v,0) + + let modSizes :: [(String,Int)] + modSizes = read mods + + -- we will need to improve this in the future + tixActor <- globalTixActor hpcDir srcDir modSizes + + + let record Nothing newState = do + return ( MultiResponse + [ ModuleListResponse (map fst modSizes) + , TracerStateResponse (GUIState newState Nothing []) + ] + , (Just newState,newState) + ) + + record (Just oldState) newState = do + opt_ticked <- + case tracerRunning newState of + Nothing -> + case tracerEvent newState of + Tick tixNo -> do + tixInfo <- lookupGlobalTickInfo tixActor tixNo + return $ Just tixInfo + _ -> return $ Nothing + _ -> return $ Nothing +-- print (oldState,newState) + return ( TracerStateResponse $ + GUIState + { guiTracerState = newState + , guiTracerTicked = opt_ticked + , guiTracerBreakers = checkBreakPoints newState + } + , (Just newState,newState) + ) + + + let setBP bp state0 = do + bp' <- normalizeBreakPoint tixActor bp + let state1 = state0 { tracerBreakPoints = setBreakPoint bp' $ tracerBreakPoints state0 } +-- print $ tracerBreakPoints state1 + return state1 + + let clearBP bp state0 = do + bp' <- normalizeBreakPoint tixActor bp + let state1 = state0 { tracerBreakPoints = clearBreakPoint bp' $ tracerBreakPoints state0 } +-- print $ tracerBreakPoints state1 + return state1 + + let dir Forward = 1 + dir Backward = -1 + + let step d state0 = do +-- print "step(1)" + StreamActorResult { counter = count + , event = tixInfo + , threadId = tid + } <- getTix (fromIntegral d + tracerCounter state0) + (tickIdBreakPointSet state0) + +-- print "step(2)" +-- print ("284",count,tixInfo) + + let state1 = state0 { tracerCounter = count + , tracerThreadID = tid + , tracerEvent = tixInfo + } + return state1 + + searchForBP :: Direction + -> ((TracerActorState -> IO TracerActorState) -> IO ()) + -> TracerActorState + -> IO TracerActorState + searchForBP d action (oldState,state0 @ TracerState { tracerRunning = Nothing }) + = return $ (oldState,state0) + + searchForBP d action (oldState,state0) = do + let steps = 314159 -- large(ish) prime, also pi * 100,000 + let target = ((dir d * steps + tracerCounter state0) `div` steps) * steps + let next_bp = case nextCounterBreakPoint state0 of + Nothing -> target + Just target' -> min target' target + res <- getTix next_bp (tickIdBreakPointSet state0) + case res of + StreamActorResult + { counter = count + , event = tixInfo + , threadId = tid + } -> do + let state1 = state0 { tracerCounter = count + , tracerThreadID = tid + , tracerEvent = tixInfo + } + + case tixInfo of + _ | isBreakPoint state1 -> return $ (oldState, state1 { tracerRunning = Nothing }) + Finished -> return $ (oldState, state1 { tracerRunning = Nothing }) + _ | otherwise -> do + action (searchForBP d action) + return $ (oldState,state1) + _ -> error "bad actor" + + initRunToBP d action state0 = do + action (searchForBP d action) + let state1 = state0 { tracerRunning = Just $ d } + return state1 + + mkActor2 (Nothing,initState) $ \ request action req -> + request $ \ (state0,state1) -> do + state2 <- case req of + InitRequest -> return $ state1 + StepRequest Forward -> step 1 state1 + StepRequest Backward -> step (-1) state1 + RunRequest Forward -> initRunToBP Forward action state1 + RunRequest Backward -> initRunToBP Backward action state1 + (SetBreakPoint bp) -> setBP bp state1 + (ClearBreakPoint bp) -> clearBP bp state1 + ContinueRequest -> return $ state1 + StopRequest -> return $ state1 { tracerRunning = Nothing } + + record state0 state2 + +------------------------------------------------------------------------------ + +showUsingXml :: [(String,[(String,String)])] -> String +showUsingXml cmds = + "" ++ + "" ++ + unlines [ "<" ++ cmd ++ concatMap showArgs args ++ "/>" | (cmd,args) <- cmds ] ++ + "\n" + where showArgs (nm,val) = " " ++ nm ++ "=\"" ++ val ++ "\"" + diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,10 @@ +module Utils where + +showWithCommas :: Integer -> String +showWithCommas n = showBigNum n + where showBigNum n | n <= 9999 = show n + | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000) + showBigNum' n | n <= 999 = show n + | otherwise = showBigNum' (n `div` 1000) ++ "," ++ showWith (n `mod` 1000) + showWith n = take 3 $ (take (3 - length (show n)) "000" ++) $ show n +
Stop at ...
All Exceptions
All Thread Changes
All Thread Terminations
+ Thread # + +
+ Counter # + +