diff --git a/profile2html.icl b/profile2html.icl index dfa300661b0fc0b9b618206517831004ac61a4ab..0e5cd67ebb8b189b6e975f04631fb21a5991859d 100644 --- a/profile2html.icl +++ b/profile2html.icl @@ -10,6 +10,8 @@ import System.CommandLine import System.File import System.FilePath import System.Options +import System.OS +import System._Pointer from Text import class Text(concat,join), instance Text String, <+ import qualified Text.HTML @@ -47,10 +49,18 @@ Start w | isError profile = exit ("Could not parse input: "+++fromError profile) w # profile = prepare args.min_cumulative_ticks args.exclude (fromOk profile) + # (css,w) = readFile (exec_directory "profile.css") w + | isError css + = exit ("Could not open supporting CSS: "+++toString (fromError css)) w + # css = fromOk css + # (js,w) = readFile (exec_directory "profile.js") w + | isError js + = exit ("Could not open supporting JavaScript: "+++toString (fromError js)) w + # js = fromOk js # (ok,f,w) = fopen args.output FWriteText w | not ok = exit "Could not open output file" w - # f = f <<< profile + # f = write_profile css js profile f # (_,w) = fclose f w = w where @@ -93,30 +103,29 @@ where # (_,w) = fclose (stderr <<< err <<< '\n') w = setReturnCode -1 w -instance <<< Profile -where - <<< f p - # f = f <<< "" - <<< "" - <<< "" - <<< "Profile" - <<< "" - <<< "" - <<< "" - <<< "" - <<< "
" - <<< "Function" - <<< "Words" - <<< "Ticks" - <<< "Curried calls" - <<< "Lazy calls" - <<< "Strict calls" - <<< "
" - # f = write_stack p p.profile f - = f - <<< "" - <<< "" - <<< "" +write_profile :: !String !String !Profile !*File -> *File +write_profile css js p f + # f = f <<< "" + <<< "" + <<< "" + <<< "Profile" + <<< "" + <<< "" + <<< "" + <<< "" + <<< "
" + <<< "Function" + <<< "Words" + <<< "Ticks" + <<< "Curried calls" + <<< "Lazy calls" + <<< "Strict calls" + <<< "
" + # f = write_stack p p.profile f + = f + <<< "" + <<< "" + <<< "" write_stack :: !Profile !ProfileStack !*File -> *File write_stack p s f = write s.cumulative_ticks s.cumulative_words s f @@ -169,3 +178,72 @@ where } where wi = toInt (w * 10000.0) + +exec_directory :: String +exec_directory =: takeDirectory (IF_LINUX get_linux (IF_WINDOWS get_windows get_macosx)) +where + get_linux + # buf = createArray 8192 '\0' + # n = readlink "/proc/self/exe\0" (get_string_pointer buf) 8192 + | n<0 || n>=8192 + = abort "exec_directory failed\n" + = buf % (0,n-1) + where + readlink :: !String !Pointer !Int -> Int + readlink _ _ _ = code { + ccall readlink "spI:I" + } + + get_windows + # buf = createArray 8192 '\0' + # n = GetModuleFileNameA 0 (get_string_pointer buf) 8192 + | n==0 + = abort "exec_directory failed" + = buf % (0,n-1) + where + GetModuleFileNameA :: !Int !Pointer !Int -> Int + GetModuleFileNameA _ _ _ = code { + ccall GetModuleFileNameA "IpI:I" + } + + get_macosx + # buf = createArray 8192 '\0' + # bufp = get_string_pointer buf + # sz = createArray 1 8192 + # n = get_executable_path bufp (get_array_pointer sz) + | n<>0 + = abort "exec_directory failed\n" + # buf2 = createArray 8192 '\0' + # buf2p = get_string_pointer buf2 + # r = realpath bufp buf2p + | r<>r || buf.[0]=='\0' || buf2.[0]=='\0' /* keep buf and buf2 in memory */ + = abort "exec_directory failed\n" + = derefString buf2p + where + get_executable_path :: !Pointer !Pointer -> Int + get_executable_path _ _ = code { + ccall _NSGetExecutablePath "pp:I" + } + + realpath :: !Pointer !Pointer -> Pointer + realpath _ _ = code { + ccall realpath "pp:p" + } + + get_string_pointer :: !String -> Pointer + get_string_pointer arr = get arr + IF_INT_64_OR_32 16 8 + where + get :: !String -> Pointer + get _ = code { + push_a_b 0 + pop_a 1 + } + + get_array_pointer :: !{#Int} -> Pointer + get_array_pointer arr = get arr + IF_INT_64_OR_32 24 12 + where + get :: !{#Int} -> Pointer + get _ = code { + push_a_b 0 + pop_a 1 + }