timeprofiler.icl 10.3 KB
Newer Older
Diederik van Arkel's avatar
Diederik van Arkel committed
1 2 3 4 5 6 7 8 9
module timeprofiler

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

import flexwin
import ExtNotice
import Help
import ShowProfile
10
import Platform
Diederik van Arkel's avatar
Diederik van Arkel committed
11 12 13 14 15 16

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

:: ProfileViewerState =
	{ mode		:: ViewMode
Diederik van Arkel's avatar
Diederik van Arkel committed
17 18
	, mods		:: [FormattedProfile]
	, funs		:: [FormattedProfile]
Diederik van Arkel's avatar
Diederik van Arkel committed
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
	, 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
75
		= installPlatformEventHandlers ps
Diederik van Arkel's avatar
Diederik van Arkel committed
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

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
133 134
	# (commandline,ps) = initPlatformCommandLine ps
	| length commandline <= 1
Diederik van Arkel's avatar
Diederik van Arkel committed
135
		= (([],[],""),ps)
136
		= open_file_function (commandline!!1) ps
Diederik van Arkel's avatar
Diederik van Arkel committed
137 138 139 140

openFiles _ _ _ _ [] ps = ps
openFiles winId closeId printId recId [h:t] ps
	# ((mods,funs,name),ps)
141
						= open_file_function h ps
Diederik van Arkel's avatar
Diederik van Arkel committed
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
	# (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
229 230 231
	# ((ok,printFont),ps)			= accPIO (accScreenPicture (openFont printFont)) ps 
//	| not ok
//		= ps
Diederik van Arkel's avatar
Diederik van Arkel committed
232 233 234
	# (printSetup,ps)				= printTable printFont printSetup functionData sumData ps
	# ps							= appPLoc (\vs -> {vs & pset = printSetup}) ps
	= ps
235 236 237 238
where
	printFont	= PlatformDependant
					{fName="Courier New",fStyles=[BoldStyle],fSize=8}
					{fName="Monaco",fStyles=[],fSize=8}
Diederik van Arkel's avatar
Diederik van Arkel committed
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

//-- 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)