timeprofiler.icl 11.5 KB
Newer Older
Diederik van Arkel's avatar
Diederik van Arkel committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350
module timeprofiler

//import StdEnv
import StdArray, StdBool, StdList, StdFunc, StdTuple, StdOrdList
//import StdIO
import StdProcess, StdId, StdMenu, StdReceiver, StdMenuElement, StdFileSelect, StdPStClass

import flexwin
import ArgEnv
import ExtNotice
import Help
import ShowProfile

ApplicationName	:== "ShowTimeProfile"
HelpFileName	:== ApplicationName +++ "Help"

:: ProfileViewerState =
	{ mode		:: ViewMode
	, mods		:: .[FormattedProfile]
	, funs		:: .[FormattedProfile]
	, pset		:: PrintSetup
	, name		:: String
	}

:: ViewMode
	= ViewByModule
	| ViewByFunction

initialState pset =
	{ mode		= ViewByFunction
	, mods		= []
	, funs		= []
	, pset		= pset
	, name		= ""
	}

Start world
	# (r,_,_) = clock_speed_and_profile_overhead
	| r==1
		= error_notice_and_quit
			["Profiling does not work on this computer,",
			 "because the processor does not have a time stamp counter"
			] world
	| r==2
		= error_notice_and_quit
			["Profiling does not work on this computer,",
			 "because the Windows API function QueryPerformanceFrequency failed"
			] world
	# (dp,world)		= defaultPrintSetup world
	# (winId,world)		= openId world
	# (recId,world)		= openR2Id world
	# (closeId,world)	= openId world
	# (printId,world)	= openId world
	= startIO SDI (initialState dp) (init winId closeId printId recId) (atts winId closeId printId recId) world
where
	init winId closeId printId recId ps
		# ((mods,funs,name),ps)
					= open_time_file_from_command_line ps
		# hasClose	= not (isEmpty mods)
		# (viewer_mode,ps)
					= accPLoc (\vs=:{mode}-> (mode,{vs & mods = mods,funs = funs,name=name})) ps
		# info`		= case viewer_mode of
						ViewByModule	-> mods
						ViewByFunction	-> funs
		# title		= case name of
						""	-> ApplicationName
						nm	-> nm
		# (_,ps)	= openWindow Void (FlexBarWindow title info info` profileLook profileFuns recId
						[ WindowViewSize {w=400,h=400}
		//				, WindowKeyboard keyfilter Able (keyfunction (noLS(reopenfun closeId printId recId))) 
						, WindowId winId
						]) ps
		# (_,ps)	= openMenu Void (file_menu hasClose winId closeId printId recId) ps
		# (_,ps)	= openMenu Void (sort_menu recId) ps
		# (_,ps)	= openMenu Void (view_menu recId) ps
		# (_,ps)	= openMenu Void (help_menu) ps
		= ps

file_menu hasClose winId closeId printId recId =
	Menu "&File"
	(	MenuItem "&Open..."	[MenuFunction (noLS (openfun winId closeId printId recId)),MenuShortKey 'O']
	:+: MenuItem "&Refresh" [MenuFunction (noLS (reopenfun winId closeId printId recId)),MenuShortKey 'R']
	:+: MenuItem "&Close"	[MenuId closeId,MenuSelectState (if hasClose Able Unable),MenuFunction (noLS (closefun winId closeId printId recId)),MenuShortKey 'W']
	:+:	MenuSeparator		[]
	:+: MenuItem "&Print..."[MenuId printId,MenuSelectState (if hasClose Able Unable),MenuFunction (noLS (printfun recId)),MenuShortKey 'P']
	:+:	MenuSeparator		[]
	:+: MenuItem "&Help"	[MenuFunction (noLS (showHelp HelpFileName))]
	:+:	MenuSeparator		[]
	:+:	MenuItem "&Quit"	[MenuFunction (noLS closeProcess),MenuShortKey 'Q']
	)[]

sort_menu recId =
	Menu "&Sort"
	(	MenuItem "Sort by &Function"		[MenuShortKey 'F', MenuFunction (noLS (snd o (syncSend2 recId (FW_ApplyFunction 1))))]
	:+:	MenuItem "Sort by &Module"			[MenuShortKey 'M', MenuFunction (noLS (snd o (syncSend2 recId (FW_ApplyFunction 1))))]
	:+:	MenuItem "Sort by &Time"			[MenuShortKey 'T', MenuFunction (noLS (snd o (syncSend2 recId (FW_ApplyFunction 3))))]
	:+:	MenuItem "Sort by &Allocation"		[MenuShortKey 'A', MenuFunction (noLS (snd o (syncSend2 recId (FW_ApplyFunction 5))))]
	:+:	MenuItem "Sort by &Strict calls"	[MenuShortKey 'S', MenuFunction (noLS (snd o (syncSend2 recId (FW_ApplyFunction 6))))]
	:+:	MenuItem "Sort by &Lazy calls"		[MenuShortKey 'L', MenuFunction (noLS (snd o (syncSend2 recId (FW_ApplyFunction 7))))]
	:+:	MenuItem "Sort by &Curried calls"	[MenuShortKey 'C', MenuFunction (noLS (snd o (syncSend2 recId (FW_ApplyFunction 8))))]
	) []

view_menu recId =
	Menu "&View"
	(	MenuItem "View by &Function"	[MenuFunction (noLS (switchView recId ViewByFunction))]
	:+:	MenuItem "View by &Module"		[MenuFunction (noLS (switchView recId ViewByModule))]
	) []

help_menu =
	Menu "&Help"
	(	MenuItem "&About..."	[MenuFunction (noLS (showAbout ApplicationName HelpFileName))]
	:+:	MenuItem "&Help..."		[MenuFunction (noLS (showHelp HelpFileName))]
	) []
	
atts winId closeId printId recId =
	[ ProcessClose closeProcess
	, ProcessOpenFiles (openFiles winId closeId printId recId)
	]

info =
	[("Module"			,Just 160)
	,("Function"		,Just 160)
	,("Time(s)"			,Just 120)
	,("Time(%)"			,Just 90)
	,("Alloc(bytes)"	,Just 100)
	,("Alloc(%)"		,Just 100)
	,("Strict(n)"		,Just 80)
	,("Lazy(n)"			,Just 80)
	,("Curried(n)"		,Just 80)
	]

//-- Support functions...

open_time_file_from_command_line ps
	| size commandline == 1
		= (([],[],""),ps)
	# (ok,pathname)		= GetLongPathName commandline.[1]
	| not ok
		= (([],[],""),ps)
		= open_file_function pathname ps
where
	commandline
		= getCommandLine

openFiles _ _ _ _ [] ps = ps
openFiles winId closeId printId recId [h:t] ps
	# (ok,pathname)		= GetLongPathName h
	| not ok
		= ps
	# ((mods,funs,name),ps)
						= open_file_function pathname ps
	# (viewer_mode,ps)	= accPLoc (\vs=:{mode}-> (mode,{vs & mods = mods, funs = funs, name = name})) ps
	# info				= case viewer_mode of
							ViewByModule	-> mods
							ViewByFunction	-> funs
	# ((err,_),ps)		= syncSend2 recId (FW_SetContent info) ps
	| err <> SendOk
		= ps
	# ps				= appPIO (enableMenuElements [closeId,printId]) ps
	# title				= case name of
							""	-> ApplicationName
							nm	-> nm
	# ps				= appPIO (setWindowTitle winId title) ps
	= ps
	
switchView recId viewer_mode ps
	# (info,ps)		= accPLoc (\vs=:{mods,funs} -> ((mods,funs),{vs & mode = viewer_mode})) ps
	# info			= case viewer_mode of
						ViewByModule	-> fst info
						ViewByFunction	-> snd info
	// would be nice to hide function column in module view...
	# ((err,_),ps)	= syncSend2 recId (FW_SetContent info) ps
	| err <> SendOk
		= ps
	= ps
	
error_notice_and_quit :: [.String] *World -> .World;
error_notice_and_quit strings world
	= startIO NDI  0 (okNotice strings) [] world

openfun winId closeId printId recId ps
	# (name,ps)			= selectInputFile ps
	| isNothing name
		= ps
	# ((mods,funs,name),ps)	= open_file_function (fromJust name) ps
	# (view_mode,ps)	= accPLoc (\vs=:{mode} -> (mode,{vs & mods = mods, funs = funs, name = name})) ps
	# info				= case view_mode of
							ViewByModule	-> mods
							ViewByFunction	-> funs
	# ((err,_),ps)		= syncSend2 recId (FW_SetContent info) ps
	| err <> SendOk
		= ps
	# ps				= appPIO (enableMenuElements [closeId,printId]) ps
	# title				= case name of
							""	-> ApplicationName
							nm	-> nm
	# ps				= appPIO (setWindowTitle winId title) ps
	= ps

reopenfun winId closeId printId recId ps
	# (name,ps)				= accPLoc (\vs=:{name} -> (name,vs)) ps
	# ((mods,funs,_),ps)	= open_file_function name ps
	# (view_mode,ps)		= accPLoc (\vs=:{mode} -> (mode,{vs & mods = mods, funs = funs})) ps
	# info					= case view_mode of
								ViewByModule	-> mods
								ViewByFunction	-> funs
	# ((err,_),ps)			= syncSend2 recId (FW_SetContent info) ps
	| err <> SendOk
		= ps
	# ps					= appPIO (enableMenuElements [closeId,printId]) ps
	# title					= case name of
								""	-> ApplicationName
								nm	-> nm
	# ps					= appPIO (setWindowTitle winId title) ps
	= ps

closefun winId closeId printId recId ps
	# ps				= appPLoc (\vs=:{mode} -> {vs & mods = [], funs = [], name = ""}) ps
	# ((err,_),ps)		= syncSend2 recId (FW_SetContent []) ps
	| err <> SendOk
		= ps
	# ps				= appPIO (disableMenuElements [closeId,printId]) ps
	# title				= ApplicationName
	# ps				= appPIO (setWindowTitle winId title) ps
	= ps

printfun recId ps
	# ((printSetup),ps)				= accPLoc (\vs=:{pset} -> (pset,vs)) ps
	# ((err,info),ps)				= syncSend2 recId FW_GetContent ps
	| err <> SendOk || isNothing info
		= ps
	# info							= case fromJust info of
										FW_DummyOut		-> Nothing
										FW_ContentOut i	-> Just i
	| isNothing info
		= ps
	# info							= fromJust info
	# (functionData,[sumData:_])	= splitAt (dec (length info)) info
	# ((ok,printFont),ps)			= accPIO (accScreenPicture (openFont {fName="Courier New",fStyles=[BoldStyle],fSize=8})) ps 
	| not ok
		= ps
	# (printSetup,ps)				= printTable printFont printSetup functionData sumData ps
	# ps							= appPLoc (\vs -> {vs & pset = printSetup}) ps
	= ps

//-- Profile stuff...

open_file_function :: {#.Char} *a -> *((.[FormattedProfile],.[FormattedProfile],String),*a) | FileEnv a;
open_file_function file_name pst
	# ((open_ok,profile),pst)	= accFiles (open_profile file_name) pst
 	| not open_ok
		= /*trace_n "open_file_function failed"*/ (([],[],""),pst)
	# (total_strict_calls,total_lazy_calls,total_curried_calls,total_allocation,total_time)
								= sum_time_and_allocation profile

	# module_profile			= totals_per_module (sortBy le_module_name profile);
	# (formatted_module_profile,_)
								= format_profile total_strict_calls total_lazy_calls total_curried_calls total_allocation total_time module_profile;
	# formatted_module_profile	= sortBy ge_profile_time formatted_module_profile;

	# (formatted_profile,total_profile)
								= format_profile total_strict_calls total_lazy_calls total_curried_calls total_allocation total_time profile
	# formatted_profile			= sortBy ge_profile_time formatted_profile

	# info						= formatted_module_profile ++ [total_profile]
	# info`						= formatted_profile ++ [total_profile]

	= ((info,info`,file_name),pst)

profileFuns =
	[ appInfo (info_sort l_module_name)
	, appInfo (info_sort l_profile_name)
	, appInfo (info_sort g_profile_time)
	, appInfo (info_sort g_profile_time)
	, appInfo (info_sort g_profile_byte)
	, appInfo (info_sort g_profile_byte)
	, appInfo (info_sort g_profile_strict)
	, appInfo (info_sort g_profile_lazy)
	, appInfo (info_sort g_profile_curried)
	]
where	//--> needs to be param of HeaderWindow...
	info_sort sort info
		# (f,t) = splitAt (dec (length info)) info
		# f = sortBy sort f
		= f++t

//profileLook :: [.FormattedProfile] .Int .Int [.Int] -> v:(w:SelectState u:(.UpdateState -> .(*Picture -> .Picture))), [u <= w, u <= v];
profileLook lines top line_height cols = look
where
	look ss us=:{updArea,newFrame={corner2={x}}} pic
		# (met,pic) = getPenFontMetrics pic
		# delta_text = met.fDescent + 1
		= draw_profile_lines` delta_text (cols++[x]) lines top line_height updArea pic

instance content_size [a]
where
	content_size metrics lines
		# line_height = fontLineHeight metrics
		= line_height * (length lines)

//--
/*
keyfilter (CharKey _ _)	= False
keyfilter _				= True

keyfunction refresh (SpecialKey key state mods) ps
	| key == f5Key && state == KeyUp
		= refresh ps
	= ps
*/

//--

//import expand_8_3_names_in_path
import code from library "time_profiler_kernel_library"

GetLongPathName :: !String -> (!Bool,!String);
GetLongPathName short_path
//	= expand_8_3_names_in_path short_path;
// of analoog aan GetShortPathName kernelfunctie aanroepen...
	#! s_long_path
		= GetLongPathName_ short_path "\0" 0;
	#! long_path
		= createArray s_long_path '\0';
	#! result
		= GetLongPathName_ short_path long_path s_long_path;
	= (result <> 0,long_path);
where
	GetLongPathName_ :: !String !String !Int -> !Int;
	GetLongPathName_ short_path long_path s_long_path
		= code {
			ccall GetLongPathNameA@12 "PssI:I"
			}

GetShortPathName :: !String -> (!Bool,!String);
GetShortPathName long_path
	#! s_short_path
		= GetShortPathName_ long_path "\0" 0;
	#! short_path
		= createArray s_short_path '\0';
	#! result
		= GetShortPathName_ long_path short_path s_short_path;
	= (result <> 0,short_path);
where
	GetShortPathName_ :: !String !String !Int -> !Int;
	GetShortPathName_ long_path short_path s_short_path
		= code {
			ccall GetShortPathNameA@12 "PssI:I"
			}