Commit fa9774ee authored by John van Groningen's avatar John van Groningen
Browse files

heap profiler for linux using I/O 0.8

parent ea7ff7c4
definition module Help
import deltaIOSystem
from deltaEventIO import ::IOState
from StdFile import ::Files
/* General utility for handling the AboutDialog of a Clean application.
This module uses the 0.8 I/O library.
*/
MakeAboutDialog :: String String (*s -> *((IOState *s) -> (*s,IOState *s))) *Files
-> (DialogDef *s (IOState *s), *Files)
ShowHelp :: String (IOState s) -> IOState s
implementation module Help
import StdString, StdInt, StdChar, StdBool, StdFile, StdArray, StdTuple, StdList
import deltaSystem, deltaEventIO, deltaIOSystem, deltaWindow, deltaPicture, deltaFont, deltaIOState
:: InfoDef :== (Int,Int,[InfoLine])
:: InfoLine :== (InfoFontDef,Int,Int,String)
:: InfoFontDef = InfoFont Font Centred
| NoFont Centred
:: Centred :== Bool
:: Fonts :== (Font,Font,Font,Font)
:: Heights :== (Int,Int)
HelpWdID :== 30000
InfoFontName1 :== "Geneva"
InfoFontName2 :== "Helvetica"
InfoFontName3 :== "Times"
NormalSize1 :== 9
NormalSize2 :== 12
LargeSize1 :== 12
LargeSize2 :== 14
NormalStyle :== []
BoldStyle :== ["Bold"]
Margin :== 8
AboutBegin :== "\\About"
AboutEnd :== "\\EndAbout"
HelpBegin :== "\\Help"
HelpEnd :== "\\EndHelp"
About :== False
Help :== True
//
// General AboutDialog construction.
//
MakeAboutDialog :: String String (*s -> *((IOState *s) -> (*s,IOState *s))) *Files
-> (DialogDef *s (IOState *s), *Files)
MakeAboutDialog appname infofile helpf files
# ((xmax,ymax,text),files) = ReadInfo About fonts AboutBegin AboutEnd infofile files
picture = DrawAboutInfo nft (xmax,ymax,text)
aboutDialog = AboutDialog appname ((0,0),(xmax,ymax)) picture (AboutHelp "Help" helpf)
= (aboutDialog,files)
where
fonts = InfoFonts
(nft,_,_,_) = fonts
InfoFonts :: Fonts
InfoFonts
= ( selectfont [(InfoFontName1,NormalSize1),(InfoFontName2,NormalSize2)] NormalStyle
, selectfont [(InfoFontName1,LargeSize1 ),(InfoFontName2,LargeSize2 )] NormalStyle
, selectfont [(InfoFontName1,NormalSize1),(InfoFontName2,NormalSize2)] BoldStyle
, selectfont [(InfoFontName1,LargeSize1 ),(InfoFontName2,LargeSize2 )] BoldStyle
)
where
selectfont :: ![(String,Int)] ![FontStyle] -> Font
selectfont [(fontname,size):preffonts] style
# (found,font) = SelectFont fontname style size
| found
= font
| otherwise
= selectfont preffonts style
selectfont _ style
= snd (SelectFont InfoFontName3 style NormalSize2)
/* Reading and pre-processing of the file containing the about- and help-info. */
ReadInfo :: Bool Fonts String String String *Files -> ((Int,Int,[InfoLine]),*Files)
ReadInfo help fonts begin end filename files
# (succes,file,files) = fopen (ApplicationPath filename) FReadText files
| not succes && help
= ((x,y,lines),files)
with
(x,y,lines) = ProcessInfoStrings fonts [errpref+++"could not be found."]
| not succes
= ((defaultx,defaulty,defaultlines),files)
# (found,info,file) = ReadInfoFile begin end file
(_,files) = fclose file files
| not found && help
= ((x,y,lines),files)
with
(x,y,lines) = ProcessInfoStrings fonts [errpref+++"does not contain help information."]
| not found
= ((defaultx,defaulty,defaultlines),files)
| otherwise
= ((x,y,lines),files)
with
(x,y,lines) = ProcessInfoStrings fonts info
where
(defaultx,defaulty,defaultlines)
= ProcessInfoStrings fonts ["\\DThis is a Clean program."]
errpref = "The help file \'"+++filename+++"\' "
ProcessInfoStrings :: Fonts [String] -> InfoDef
ProcessInfoStrings fonts=:(nft,lft,_,_) lines
= (maxx1,maxy+Margin-lat,lines2)
where
heights = (nat+ndt+nld,lat+ldt+lld)
(maxx,maxy,lines1) = AddFontToInfoLines fonts heights 0 (Margin+lat) lines
maxx1 = Margin+maxx+Margin
lines2 = map (CenterInfoLine nft maxx1) lines1
(nat,ndt,_,nld) = FontMetrics nft
(lat,ldt,_,lld) = FontMetrics lft
AddFontToInfoLines :: Fonts Heights Int Int [String] -> InfoDef
AddFontToInfoLines fonts heights maxx maxy [line:rest]
= (maxx1,maxy1,[(font,Margin,maxy,line1):rest1])
where
(font,wid,hgt,line1)= ParseInfoLine fonts heights line
(maxx1,maxy1,rest1) = AddFontToInfoLines fonts heights (max maxx wid) (maxy+hgt) rest
ParseInfoLine :: Fonts Heights String -> (InfoFontDef,Int,Int,String)
ParseInfoLine fonts=:(nft,lft,bft,dft) heights=:(nhgt,lhgt) line
| linelen<2 || line.[0]<>'\\'
= (NoFont False, FontStringWidth line nft, nhgt,line )
| otherwise
= (infofont, FontStringWidth line1 font, height,line1)
with
line1 = line%(2,linelen-1)
(infofont,font,height) = case (line.[1]) of
'L' -> (InfoFont lft False, lft, lhgt)
'b' -> (InfoFont bft False, bft, nhgt)
'B' -> (InfoFont dft False, dft, lhgt)
'c' -> (NoFont True , nft, nhgt)
'C' -> (InfoFont lft True , lft, lhgt)
'd' -> (InfoFont bft True , bft, nhgt)
'D' -> (InfoFont dft True , dft, lhgt)
_ -> (NoFont False , nft, nhgt)
where
linelen = size line
AddFontToInfoLines _ _ maxx maxy _
= (maxx,maxy,[])
CenterInfoLine :: Font Int InfoLine -> InfoLine
CenterInfoLine nft maxx info=:(inft=:NoFont centered,x,y,line)
| centered = (inft,(maxx-FontStringWidth line nft)/2,y,line)
| otherwise = info
CenterInfoLine nft maxx info=:(inft=:InfoFont font centered,x,y,line)
| centered = (inft,(maxx-FontStringWidth line font)/2,y,line)
| otherwise = info
ReadInfoFile :: String String *File -> (Bool,[String],*File)
ReadInfoFile begin end file
# (begin_found,file)= FindInfoBegin begin file
| not begin_found
= (False,[],file)
# (lines,file) = ReadInfoUntil end file
| otherwise
= (True,lines,file)
FindInfoBegin :: String *File -> (Bool,*File)
FindInfoBegin begin file
| sfend file = (False,file)
# (line,file) = freadline file
| isPrefixOf begin line
= (True,file)
| otherwise
= FindInfoBegin begin file
ReadInfoUntil :: String *File -> ([String],*File)
ReadInfoUntil end file
| sfend file
= ([],file)
# (line,file) = freadline file
| isPrefixOf end line
= ([],file)
# (lines,file) = ReadInfoUntil end file
| otherwise
= ([StripNewline line:lines],file)
/* The drawing of the about/help info. */
DrawAboutInfo :: Font InfoDef -> [DrawFunction]
DrawAboutInfo nft (xmax,ymax,lines)
= [ SetFont nft
, DrawInfo nft 0 ymax lines
]
DrawInfo :: Font Int Int [InfoLine] Picture -> Picture
DrawInfo nft top bot [(InfoFont font c,x,y,line):rest] pic
| y>bot = pic
| y<top = DrawInfo nft top bot rest pic
| otherwise = DrawInfo nft top bot rest (SetFont nft (DrawString line (SetFont font (MovePenTo (x,y) pic))))
DrawInfo nft top bot [(NoFont c,x,y,line):rest] pic
| y>bot = pic
| y<top = DrawInfo nft top bot rest pic
| otherwise = DrawInfo nft top bot rest (DrawString line (MovePenTo (x,y) pic))
DrawInfo _ _ _ _ pic
= pic
//
// The Help function.
//
ShowHelp :: String (IOState s) -> IOState s
ShowHelp infofile io
# ((xmax,ymax,text),io) = accFiles (ReadInfo Help fonts HelpBegin HelpEnd infofile) io
window = FixedWindow HelpWdID (0,0) "Help" ((0,0),(xmax,ymax)) (UpdateHelpWd nft text) []
= OpenWindows [window] io
where
fonts = InfoFonts
(nft,_,_,_) = fonts
UpdateHelpWd :: Font [InfoLine] UpdateArea *s -> (*s,[DrawFunction])
UpdateHelpWd nft lines areas s
= ( s
, [ SetFont nft
, RedrawAreas nft lines areas
]
)
where
RedrawAreas :: Font [InfoLine] UpdateArea Picture -> Picture
RedrawAreas nft lines [area=:((l,t),(r,b)):rest] pic
= RedrawAreas nft lines rest (DrawInfo nft (t-1) (b+40) lines pic)
RedrawAreas _ _ _ pic
= pic
/* Support functions for the AboutDialog construction. */
isPrefixOf :: String String -> Bool
isPrefixOf prefix string
| prefixlen>size string = False
| otherwise = prefix==string%(0,prefixlen-1)
where
prefixlen = size prefix
StripNewline :: String -> String
StripNewline string
| string=="" = string
| string.[last]<>'\n' = string
| otherwise = string%(0,last-1)
where
last = size string-1
module ShowHeapProfile;
import StdInt,StdBool,StdReal,StdClass,StdArray,StdString,StdChar,StdFile,StdList,StdMisc,StdEnum,StdOrdList,StdFunc;
//import deltaPrint;
import Help;
ApplicationName :== "ShowHeapProfile";
HelpFileName :== ApplicationName +++ "Help";
:: Descriptors = {
int_descriptor :: !Int,
char_descriptor :: !Int,
real_descriptor :: !Int,
bool_descriptor :: !Int,
string_descriptor :: !Int,
array_descriptor :: !Int
};
:: Header = {
heap_begin :: !Int,
heap_end :: !Int,
heap2_begin :: !Int,
heap2_end :: !Int,
text_begin :: !Int, // for PowerPC
data_begin :: !Int,
small_integers :: !Int,
characters :: !Int,
text_addresses :: !{#Int} // for 68k
};
empty_descriptors :: Descriptors;
empty_descriptors = {
Descriptors |
int_descriptor = 0,
char_descriptor = 0,
real_descriptor = 0,
bool_descriptor = 0,
string_descriptor = 0,
array_descriptor = 0
};
empty_header :: Header;
empty_header = {
heap_begin = 0,
heap_end = 0,
heap2_begin = 0,
heap2_end = 0,
text_begin = 0, // for PowerPC
data_begin = 0,
small_integers = 0,
characters = 0,
text_addresses= {} // for 68k
};
FileExists :: !String -> Bool;
FileExists f = file_exists f;
file_exists :: !String -> Bool;
file_exists _ =
code {
ccall file_exists "S-I"
}
/* PC
PCorMac pc mac :== pc;
import code from "file_exists.obj";
FileExists :: !String -> Bool;
FileExists _ =
code {
ccall FileExists "S-I"
}
import expand_8_3_names_in_path,ArgEnv,handler;
system_dependent_initial_IO
=[InstallDDEHandler openDDE, open_heap_file_from_command_line];
where {
openDDE fileName s io
# (s,io) = file_close_function s io;
# expanded_file_name = expand_8_3_names_in_path fileName;
= open_file_function expanded_file_name {s & application_name = expanded_file_name} io;
}
open_heap_file_from_command_line s io
| size commandline == 1
= (s,io);
# expanded_file_name = expand_8_3_names_in_path commandline.[1];
= open_file_function expanded_file_name {s & application_name = expanded_file_name} io;
where {
commandline = getCommandLine;
}
*/
/* Mac
PCorMac pc mac :== mac;
from files import GetFInfo,NewToolbox,::Toolbox;
FileExists :: !String -> Bool;
FileExists name = result==0;
{
(result,_,_) = GetFInfo name NewToolbox;
};
system_dependent_initial_IO=[];
apple_event_open_function file_name s=:{node_size_sum} io
| node_size_sum<0
= open_file_function file_name s io;
# (_, s,io) = OpenNotice (Notice ["A file is already open"] (NoticeButton 0 "OK") []) s io;
= (s,io);
*/
// Linux
system_dependent_initial_IO=[];
/* for PowerPC
IF_BIG_ENDIAN big little :== big;
:: Text :== {#Char};
read_application_name file = freads file 32;
read_text_addresses file = ({},file);
read_application file_name application_file_name header files
# application_file_name=replace_file_name_in_path file_name application_file_name;
# (ok,file,files) = fopen application_file_name FReadData files;
| not ok
= abort ("cannot open application file: "+++toString application_file_name);
# (ok,xcoff_magic,file) = freadi file;
// | not ok || (xcoff_magic>>16)<>0x01DF
| not ok || xcoff_magic<>0x4A6F7921
= abort "not an application file";
// # (ok1,file) = fseek file 0x94 FSeekSet;
# (ok1,file) = fseek file 0x54 FSeekSet;
(ok2,data_section_size,file) = freadi file;
(ok3,data_section_offset,file) = freadi file;
| not ok1 || not ok2 || not ok3
= abort "error reading application file";
# (ok,file) = fseek file data_section_offset FSeekSet;
(data,file) = freads file data_section_size;
| not ok || size data<>data_section_size
= abort "error reading application file";
// # (ok1,file) = fseek file 0x6C FSeekSet;
# (ok1,file) = fseek file 0x38 FSeekSet;
(ok2,text_section_size,file) = freadi file;
(ok3,text_section_offset,file) = freadi file;
| not ok1 || not ok2 || not ok3
= abort "error reading application file";
# (ok,file) = fseek file text_section_offset FSeekSet;
(text,file) = freads file text_section_size;
| not ok || size text<>text_section_size
= abort "error reading application file";
# (ok,files) =fclose file files;
| not ok
= abort "error closing application file";
= (True,data,text,header,files);
PageNumberOffsetFromEndInFileName:==1;
get_text_resource_n address header text :== in_text_section address header.text_begin (size text);
in_text_section address text_begin size_text
| address>=text_begin && address<text_begin+size_text
= 0;
= -1;
long_in_text_resource _ /*text_resource_n*/ a header text
:== text LONG (a-header.text_begin);
relocate_descriptor descriptor header :== descriptor+header.data_begin;
is_closure descriptor :== (descriptor bitand 2)==0;
non_relocated_descriptor_to_data_offset descriptor _/*header*/ _/*data*/ :== descriptor-2;
relocated_descriptor_to_data_offset descriptor header _ /*data*/ :== descriptor-2-header.data_begin;
address_to_data_offset a data_begin _ /*data*/ :== a-data_begin;
non_record_arity arity=arity;
constructor_name data_begin data_offset arity data text :== constructor_name_ data_offset arity data text;
constructor_name_ data_offset arity data text
# descriptor_offset=data_offset-(data WORD (data_offset+2));
descriptor_arity=data WORD (descriptor_offset-2);
string_offset=descriptor_offset+4+(descriptor_arity<<3);
string_length=data LONG string_offset;
module_name_offset = data LONG (descriptor_offset-12);
module_name_length = data LONG module_name_offset;
= (data % (string_offset+4,string_offset+3+string_length),data % (module_name_offset+4,module_name_offset+3+module_name_length));
closure_text_offset descriptor _ /*text_resource_n*/ header
:== descriptor-header.text_begin-4;
get_closure_arity text_offset _ /*text_resource_n*/ text
:== text LONG text_offset;
is_selector arity :== arity<0 && arity>=(-4);
get_closure_name text_offset arity text_resource_n header text data
# descriptor_toc_offset = text SWORD (text_offset - 2);
| descriptor_toc_offset bitand 3<>0
= abort "get_closure_name";
# descriptor_offset = data LONG (descriptor_toc_offset+0x8000);
descriptor_arity=data WORD (descriptor_offset-2);
string_offset=descriptor_offset+4+(descriptor_arity<<3);
string_length=(data LONG string_offset);
module_name_offset = data LONG (descriptor_offset-12);
module_name_length = data LONG module_name_offset;
= (data % (string_offset+4,string_offset+3+string_length),data % (module_name_offset+4,module_name_offset+3+module_name_length));
record_name header data_offset data text
# string_offset=data LONG (data_offset-4);
string_length=(data LONG string_offset);
module_name_offset = data LONG (data_offset-8);
module_name_length = data LONG module_name_offset;
= (data % (string_offset+4,string_offset+3+string_length),data % (module_name_offset+4,module_name_offset+3+module_name_length));
record_type data_offset data text
# type_string_offset=data_offset+4;
end_type_string_offset=find_zero_char type_string_offset data;
= data % (type_string_offset,dec end_type_string_offset);
(SWORD) string i
| w<32768
= w;
= w-65536;
{}{
w = (string BYTE i<<8) bitor (string BYTE (i+1));
}
// end for PowerPC
*/
// for 68k
/*
IF_BIG_ENDIAN big little :== big;
:: Text :== {!{#Char}};
read_application_name file = freads file 32;
read_text_addresses file
# (text_address_list,file) = read_text_address_list file;
with {
read_text_address_list file
# (ok,text_address,file) = freadi file;
| not ok
= abort "error reading text addresses";
| text_address==0
= ([],file);
# (text_addresses,file) = read_text_address_list file;
= ([text_address:text_addresses],file);
}
= ({ i \\ i<-text_address_list},file);
read_application :: {#Char} {#Char} Header Files -> (!{#Char},!Text,Header,!Files);
read_application file_name application_file_name header files
# application_file_name=replace_file_name_in_path file_name application_file_name;
# (ref_num,t)=HOpenResFile 0 0 application_file_name 3 0;
| ref_num==(-1)
= abort "cannot open application file";
# (code_resource_list,t)=load_code_resources 0 t;
# (res_error,_)=ResError (CloseResFile ref_num t);
| res_error<>0
= abort "error closing application file";
# code_resources = createArray (length code_resource_list) "";
code_resources = fill_array 0 code_resource_list code_resources;
with {
fill_array i [] code_resources = code_resources;
fill_array i [e:l] code_resources = fill_array (inc i) l {code_resources & [i]=e};
}
last_code_resource_n = dec (size code_resources);
last_code_resource = code_resources.[last_code_resource_n];
data_section_size = ((toInt last_code_resource.[0xfc]-0x18)<<16)
+ (toInt last_code_resource.[0xfd]<<8)
+ toInt last_code_resource.[0xfe];
data = last_code_resource % (0x101,0x100+data_section_size);
= (True,data,code_resources,header,files);
PageNumberOffsetFromEndInFileName:==1;
load_code_resources n t
# (h,t)=Get1Resource "CODE" n t;
| h==0
= ([],t);
# (s,t)=GetHandleSize h t;
(code_resource,t)=handle_to_string h s t;
(code_resources,t)=load_code_resources (inc n) t;
= ([code_resource:code_resources],t);
handle_to_string :: !Handle !Int !Toolbox -> (!{#Char},!Toolbox);
handle_to_string handle size t0
= (string,t1);
{
t1=copy_handle_data_to_string string handle size t0;
string = createArray size ' ';
}
get_text_resource_n address header text :== find_text_resource_n address header.text_addresses text;
find_text_resource_n address text_addresses text
= find_text_resource_n 0;
{
find_text_resource_n resource_n
| resource_n>=size text_addresses
= -1;
# text_address=text_addresses.[resource_n];
| address>=text_address && address<text_address+size text.[resource_n]
= resource_n;
= find_text_resource_n (inc resource_n);
}
long_in_text_resource text_resource_n a header text
:== text.[text_resource_n] LONG (a-header.text_addresses.[text_resource_n]);
relocate_descriptor descriptor header :== descriptor;
is_closure descriptor :== descriptor>=0;
non_relocated_descriptor_to_data_offset descriptor _/*header*/ data :== size data+descriptor;
relocated_descriptor_to_data_offset descriptor header data :== size data+descriptor;
address_to_data_offset a data_begin data :== a-(data_begin-size data);
non_record_arity arity = arity>>2;
constructor_name data_begin data_offset arity data text :== constructor_name_ data_begin data_offset arity data text;
constructor_name_ data_offset arity data text
# descriptor_offset=data_offset-(arity<<2);
string_jump_table_offset=data WORD (descriptor_offset-2);
= string_from_jump_table_offset string_jump_table_offset text;
string_from_jump_table_offset string_jump_table_offset text
# string_offset=(text.[0] WORD (string_jump_table_offset-18))+6;
string_resource_n=text.[0] WORD (string_jump_table_offset-14);
string_length=text.[string_resource_n] LONG (string_offset+4);
= text.[string_resource_n] % (string_offset+8,string_offset+7+string_length);