Commit c7a5c9ac authored by Michael Hanus 's avatar Michael Hanus
Browse files

CPM imports updated

parent 1169979f
......@@ -23,9 +23,9 @@ module CPM.ErrorLogger
import Global
import IO ( hPutStrLn, stderr )
import Profile -- for show run-time
import System ( exitWith, system )
import Debug.Profile -- for show run-time
import Text.Pretty
infixl 0 |>=, |>, |>>, |->
......
......@@ -5,8 +5,6 @@
module CPM.PerformanceTest where
import Profile
import ReadShowTerm
import IO
import IOExts
......@@ -17,10 +15,15 @@ import List
import Maybe
import Function
import Either
import JSON.Pretty
import Read (readInt)
import System
import AbstractCurry.Build
import AbstractCurry.Types hiding (version)
import AbstractCurry.Pretty
import Debug.Profile
import JSON.Pretty
import CPM.LookupSet
import CPM.ErrorLogger
import CPM.FileUtil (recreateDirectory)
......@@ -32,8 +35,6 @@ import CPM.Config
import CPM.Repository (Repository, emptyRepository)
import qualified CPM.PackageCache.Global as GC
import OptParse
import Read (readInt)
import System
--- Possible performance tests.
data Command = BehaviorDiff | APIDiff | Resolution | CountDeps
......
Copyright (c) 2019, Michael Hanus
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the names of the copyright holders nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
profiling: Support for simple profiling
=======================================
This package contains a simple profiling library
containing operations to access run-time data.
--------------------------------------------------------------------------
-- Benchmarks for Curry systems
import Debug.Profile
-- Standard Prolog benchmark: naive reverse:
append :: [a] -> [a] -> [a]
append [] ys = ys
append (x:xs) ys = x : append xs ys
rev :: [a] -> [a]
rev [] = []
rev (x:xs) = append (rev xs) [x]
-- start naive reverse benchmark with a list of n elements and report
-- space usage:
nrev :: Int -> IO ()
nrev n = do
let xs = [1 .. n]
const done $!! xs
profileSpaceNF (rev xs)
-- LIPS = (n+1)*(n+2)/2/exec.time
-- compute LIPS with naive reverse benchmark:
nrevLIPS :: Int -> IO ()
nrevLIPS n = do
let xs = [1 .. n]
const done $!! xs
garbageCollect
garbageCollectorOff
pi1 <- getProcessInfos
const done $!! (rev xs)
pi2 <- getProcessInfos
garbageCollectorOn
let rtime = maybe 0 id (lookup RunTime pi2)
- maybe 0 id (lookup RunTime pi1)
-- LIPS = (n+1)*(n+2)/2/exec.time
putStrLn $ "LIPS: " ++ show ((n+1)*(n+2)*1000 `div` (2*rtime))
main :: IO ()
main = nrevLIPS 4000
-- Result on a Sun Ultra-10 (chevalblanc, with Sicstus/Fast code):
-- 2.5 MLIPS for (nrev 1000)
-- Result on a Linux-PC PIII/650Mhz (with Sicstus/Emulated code):
-- 0.94 MLIPS for (nrev 1000)
-- Result on a Linux-PC AMD Athlon/900Mhz (with Sicstus/Emulated code):
-- 1.12 MLIPS for (nrev 1000)
-- Result on a Linux-PC AMD Athlon/1.300Mhz (with Sicstus/Emulated code):
-- 1.43 MLIPS for (nrev 1000)
-- Result on a Linux-PC AMD Athlon XP 2600+/2.000Mhz (petrus, Sicstus/Emulated):
-- 2.95 MLIPS for (nrev 1000)
-- Result on a Linux-PC Intel Core i7-4790 / 3.6Ghz (belair, Sicstus 4.3/JIT):
-- 13.45 MLIPS for (nrev 4000)
-- as nrev but double evaluation
nrev2 :: Int -> IO ()
nrev2 n = do
let xs = [1 .. n]
const done $!! xs
profileSpaceNF (rev xs, rev xs)
-- as nrev2 but with test equality instead of unification:
nrev3 :: Int -> IO ()
nrev3 n = do
let xs = [1 .. n]
const done $!! xs
profileSpaceNF (rev xs == rev xs)
{
"name": "profiling",
"version": "1.0.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "Simple profiling library with operations to access run-time data",
"category": [ "Debugging" ],
"license": "BSD-3-Clause",
"licenseFile": "LICENSE",
"dependencies": {
"base" : ">= 1.0.0, < 2.0.0"
},
"compilerCompatibility": {
"pakcs": ">= 2.0.0",
"kics2": ">= 2.0.0"
},
"exportedModules": [ "Debug.Profile" ],
"source": {
"git": "https://git.ps.informatik.uni-kiel.de/curry-packages/profiling.git",
"tag": "$version"
}
}
------------------------------------------------------------------------------
--- Simple profiling library with operations to access run-time data.
---
--- @author Michael Hanus
--- @version January 2019
------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module Debug.Profile
( ProcessInfo(..), getProcessInfos, showMemInfo, printMemInfo
, garbageCollectorOff, garbageCollectorOn, garbageCollect
, profileTime, profileTimeNF, profileSpace, profileSpaceNF
#ifdef __PAKCS__
, evalTime, evalSpace
#endif
)
where
import List(intersperse)
--- The data type for representing information about the state
--- of a Curry process.
--- @cons RunTime - the run time in milliseconds
--- @cons ElapsedTime - the elapsed time in milliseconds
--- @cons Memory - the total memory in bytes
--- @cons Code - the size of the code area in bytes
--- @cons Stack - the size of the local stack for recursive functions in bytes
--- @cons Heap - the size of the heap to store term structures in bytes
--- @cons Choices - the size of the choicepoint stack
--- @cons GarbageCollections - the number of garbage collections performed
data ProcessInfo = RunTime | ElapsedTime | Memory | Code
| Stack | Heap | Choices | GarbageCollections
deriving (Eq,Show)
--- Returns various informations about the current state of the Curry process.
--- Note that the returned values are implementation dependent
--- so that one should interpret them with care!
---
--- Note for KiCS2 users:
--- Since GHC version 7.x, one has to set the run-time option `-T`
--- when this operation is used. This can be done by the kics2 command
---
--- :set rts -T
---
getProcessInfos :: IO [(ProcessInfo,Int)]
getProcessInfos external
--- Turns off the garbage collector of the run-time system (if possible).
--- This could be useful to get more precise data of memory usage.
garbageCollectorOff :: IO ()
garbageCollectorOff external
--- Turns on the garbage collector of the run-time system (if possible).
garbageCollectorOn :: IO ()
garbageCollectorOn external
--- Invoke the garbage collector (if possible).
--- This could be useful before run-time critical operations.
garbageCollect :: IO ()
garbageCollect external
--- Get a human readable version of the memory situation from the
--- process infos.
showMemInfo :: [(ProcessInfo,Int)] -> String
showMemInfo infos = concat $ intersperse ", " $
formatItem Memory "Memory: " ++
formatItem Code "Code: " ++
formatItem Stack "Stack: " ++
formatItem Choices"Choices: " ++
formatItem Heap "Heap: "
where
formatItem i s = maybe [] (\v -> [s ++ showBytes v]) (lookup i infos)
showBytes b = if b<10000 then show b
else show (b `div` 1000) ++ " kb"
--- Print a human readable version of the current memory situation
--- of the Curry process.
printMemInfo :: IO ()
printMemInfo = getProcessInfos >>= putStrLn . showMemInfo
--- Print the time needed to execute a given IO action.
profileTime :: IO a -> IO a
profileTime action = do
garbageCollect
pi1 <- getProcessInfos
result <- action
pi2 <- getProcessInfos
putStrLn $ "Run time: "
++ (showInfoDiff pi1 pi2 RunTime) ++ " msec."
putStrLn $ "Elapsed time: "
++ (showInfoDiff pi1 pi2 ElapsedTime) ++ " msec."
putStrLn $ "Garbage collections: "
++ (showInfoDiff pi1 pi2 GarbageCollections)
return result
--- Evaluates the argument to normal form
--- and print the time needed for this evaluation.
profileTimeNF :: a -> IO ()
profileTimeNF exp = profileTime (seq (id $!! exp) done)
--- Print the time and space needed to execute a given IO action.
--- During the executation, the garbage collector is turned off to get the
--- total space usage.
profileSpace :: IO a -> IO a
profileSpace action = do
garbageCollect
garbageCollectorOff
pi1 <- getProcessInfos
result <- action
pi2 <- getProcessInfos
garbageCollectorOn
putStrLn $ "Run time: "
++ (showInfoDiff pi1 pi2 RunTime) ++ " msec."
putStrLn $ "Elapsed time: "
++ (showInfoDiff pi1 pi2 ElapsedTime) ++ " msec."
putStrLn $ "Garbage collections: "
++ (showInfoDiff pi1 pi2 GarbageCollections)
putStrLn $ "Heap usage: "
++ (showInfoDiff pi1 pi2 Heap) ++ " bytes"
putStrLn $ "Stack usage: "
++ (showInfoDiff pi1 pi2 Stack) ++ " bytes"
return result
--- Evaluates the argument to normal form
--- and print the time and space needed for this evaluation.
--- During the evaluation, the garbage collector is turned off to get the
--- total space usage.
profileSpaceNF :: a -> IO ()
profileSpaceNF exp = profileSpace (seq (id $!! exp) done)
showInfoDiff :: [(ProcessInfo, Int)] -> [(ProcessInfo, Int)] -> ProcessInfo
-> String
showInfoDiff infos1 infos2 item =
show (maybe 0 id (lookup item infos2) - maybe 0 id (lookup item infos1))
#ifdef __PAKCS__
--- Evaluates the argument to normal form (and return the normal form)
--- and print the time needed for this evaluation on standard error.
--- Included for backward compatibility only, use profileTime!
evalTime :: a -> a
evalTime external
--- Evaluates the argument to normal form (and return the normal form)
--- and print the time and space needed for this evaluation on standard error.
--- During the evaluation, the garbage collector is turned off.
--- Included for backward compatibility only, use profileSpace!
evalSpace :: a -> a
evalSpace external
#endif
{-# LANGUAGE CPP, MultiParamTypeClasses #-}
import System.CPUTime
import System.Mem (performGC)
#if __GLASGOW_HASKELL__ > 702
import GHC.Stats
#endif
-- #endimport - do not remove this line!
instance ConvertCurryHaskell C_ProcessInfo C_ProcessInfo where
toCurry = id
fromCurry = id
getProcessInfos :: IO [(C_ProcessInfo, Int)]
#if __GLASGOW_HASKELL__ > 802
getProcessInfos = do
stats <- getRTSStats
return [ (C_RunTime , fromIntegral (mutator_cpu_ns stats * 1000))
, (C_ElapsedTime , fromIntegral (mutator_elapsed_ns stats * 1000))
, (C_Heap , fromIntegral (max_live_bytes stats))
, (C_Memory , fromIntegral (max_live_bytes stats))
, (C_GarbageCollections, fromIntegral (gcs stats))
]
#elif __GLASGOW_HASKELL__ > 702
getProcessInfos = do
stats <- getGCStats
return [ (C_RunTime , floor (mutatorCpuSeconds stats * 1000))
, (C_ElapsedTime , floor (mutatorWallSeconds stats * 1000))
, (C_Heap , fromIntegral (maxBytesUsed stats))
, (C_Memory , fromIntegral (maxBytesUsed stats))
, (C_GarbageCollections, fromIntegral (numGcs stats))
]
#else
getProcessInfos = do
t <- getCPUTime
return [(C_RunTime, t `div` (10^9)]
#endif
external_d_C_getProcessInfos :: Cover -> ConstStore ->
Curry_Prelude.C_IO (Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 C_ProcessInfo Curry_Prelude.C_Int))
external_d_C_getProcessInfos _ _ = toCurry getProcessInfos
external_d_C_garbageCollectorOff :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_garbageCollectorOff _ _ = toCurry (return () :: IO ()) -- not supported
external_d_C_garbageCollectorOn :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_garbageCollectorOn _ _ = toCurry (return () :: IO ()) -- not supported
external_d_C_garbageCollect :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit
external_d_C_garbageCollect _ _ = toCurry performGC
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="getProcessInfos" arity="0">
<library>prim_debug_profile</library>
<entry>prim_getProcessInfos</entry>
</primitive>
<primitive name="garbageCollectorOn" arity="0">
<library>prim_debug_profile</library>
<entry>prim_garbageCollectorOn</entry>
</primitive>
<primitive name="garbageCollectorOff" arity="0">
<library>prim_debug_profile</library>
<entry>prim_garbageCollectorOff</entry>
</primitive>
<primitive name="garbageCollect" arity="0">
<library>prim_debug_profile</library>
<entry>prim_garbageCollect</entry>
</primitive>
<primitive name="evalTime" arity="1">
<library>prim_debug_profile</library>
<entry>prim_evalTime[raw]</entry>
</primitive>
<primitive name="evalSpace" arity="1">
<library>prim_debug_profile</library>
<entry>prim_evalSpace[raw]</entry>
</primitive>
</primitives>
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment