home *** CD-ROM | disk | FTP | other *** search
/ PSION CD 2 / PsionCDVol2.iso / Programs / 876 / hugs.sis / CVHAssert.hs < prev    next >
Encoding:
Text File  |  2000-09-21  |  3.3 KB  |  131 lines
  1. ----------------------------------------------------------------
  2. -- This is a simple implementation of Cordy Hall's assertions
  3. -- (for performance debugging).
  4. --
  5. -- NB These primitives are an _experimental_ feature which may be
  6. --    removed in future versions of Hugs.
  7. --    They can only be used if hugs was configured with the
  8. --    "--enable-internal-prims" flag.
  9. --
  10. -- These primitives mostly break referential transparency - but you're
  11. -- only supposed to use them for debugging purposes.
  12. ----------------------------------------------------------------
  13.  
  14. module CVHAssert(
  15.     Test, Action, 
  16.     assert,
  17.     isEvaluated,
  18.     pointerEqual
  19.     ) where
  20.  
  21. import HugsInternals(
  22.     ptrEq,
  23.     Name,   nameInfo,
  24.     Cell,   getCell, cellPtrEq,
  25.     CellKind(..), classifyCell,
  26.     )
  27. import IOExts(
  28.     unsafePerformIO
  29.     )
  30.  
  31. ----------------------------------------------------------------
  32. -- High level operations
  33. ----------------------------------------------------------------
  34.  
  35. type Test a   = a -> Bool
  36. type Action a = a -> IO ()
  37.  
  38. assert :: Test a -> Action a -> a -> a
  39. assert test action x = 
  40.   unsafePerformIO (if test x then return () else action x)
  41.   `seq`
  42.   x 
  43.  
  44. isEvaluated :: a -> Bool
  45. isEvaluated x = unsafePerformIO (
  46.   isEvaluatedCell (getCell x)
  47.   )
  48.  
  49. representationSize :: a -> Int
  50. representationSize x = unsafePerformIO (do 
  51.   cells <- cellsOf (getCell x) []
  52.   return (cellSize * length cells)
  53.   )
  54.  
  55. pointerEqual :: a -> a -> Bool
  56. pointerEqual = ptrEq
  57.  
  58. ----------------------------------------------------------------
  59. -- Utilities
  60. ----------------------------------------------------------------
  61.  
  62. isEvaluatedCell :: Cell -> IO Bool
  63. isEvaluatedCell cell = do
  64.   kind <- classifyCell False cell
  65.  
  66.   case kind of
  67.     Apply fun args -> do 
  68.             funkind <- classifyCell False fun
  69.                     case funkind of
  70.                     Fun nm    -> return (nameArity nm > length args)
  71.                     _         -> return True
  72.     _            -> return True
  73.  
  74. arityOf :: Cell -> IO Int
  75. arityOf cell = do
  76.   kind <- classifyCell False cell
  77.  
  78.   case kind of
  79.     Apply fun args -> do 
  80.             funarity <- arityOf fun
  81.             return (funarity - length args)
  82.  
  83.     Fun   nm -> return (nameArity nm)
  84.     Con   nm -> return (nameArity nm)
  85.     Tuple i  -> return i
  86.     _            -> return 0
  87.  
  88.  
  89. nameArity :: Name -> Int
  90. nameArity nm = case nameInfo nm of (arity,_,_) -> arity
  91.  
  92. -- list cells occurring in Cell
  93. cellsOf :: Cell -> [Cell] -> IO [Cell]
  94.  
  95. cellsOf cell seen 
  96.   | cell `elemCell` seen 
  97.   = return seen
  98.   | otherwise
  99.   = do
  100.       let seen' = cell:seen
  101.  
  102.       kind <- classifyCell False cell
  103.  
  104.       case kind of
  105.     Apply f xs -> do
  106.                 seen'' <- cellsOf f seen'
  107.                 cellsOf' xs seen''
  108.     Fun     _  -> return seen'
  109.     Con     _  -> return seen'
  110.     Tuple   _  -> return seen'
  111.     Int     _  -> return seen'
  112.     Integer _  -> return seen'
  113.     Float   _  -> return seen'
  114.     Char    _  -> return seen'
  115.     Prim    _  -> return seen'
  116.     Error   _  -> return seen'    -- we could argue about this one
  117.  
  118. cellsOf' :: [Cell] -> [Cell] -> IO [Cell]
  119. cellsOf' []     seen = return seen
  120. cellsOf' (x:xs) seen = do seen' <- cellsOf x seen
  121.                           cellsOf' xs seen'
  122.  
  123. elemCell :: Cell -> [Cell] -> Bool
  124. x `elemCell` []     = False
  125. x `elemCell` (y:ys) = x `cellPtrEq` y || x `elemCell` ys
  126.  
  127. cellSize :: Int
  128. cellSize = 8
  129.  
  130. ----------------------------------------------------------------
  131.