heap profiler for linux using I/O 0.8

ShowHeapProfile08/Help.dcl

+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

ShowHeapProfile08/Help.icl

+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

ShowHeapProfile08/ShowHeapProfile.icl

+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);
+
+