ghc/tests/programs/jtod_circint/Signal.hs

   1 module Signal where
   2
   3 import LogFun
   4
   5 class (Eq a, Show{-was:Text-} a, Num a) => Signal a where
   6   showSig :: a -> String
   7
   8   zerO, one, initial :: a
   9
  10   tt1 :: TT1 -> a -> a
  11   tt2 :: TT2 -> a -> a -> a
  12
  13   con10, buf, inv, con11 :: a -> a
  14
  15   con20, and2, nimp,  id21  :: a -> a -> a
  16   nimp', id22, xor,   or2   :: a -> a -> a
  17   nor2,  equ2, inv22, imp'  :: a -> a -> a
  18   inv21, imp,  nand2, con21 :: a -> a -> a
  19   and3,  or3,  nand3, nor3  :: a -> a -> a -> a
  20   and4,  or4,  nand4, nor4  :: a -> a -> a -> a -> a
  21
  22   con10 = tt1 tt_con10
  23   buf   = tt1 tt_id
  24   inv   = tt1 tt_inv
  25   con11 = tt1 tt_con11
  26
  27   con20 = tt2 tt_con20
  28   and2  = tt2 tt_and2
  29   nimp  = tt2 tt_nimp
  30   id21  = tt2 tt_id21
  31   nimp' = tt2 tt_nimp'
  32   id22  = tt2 tt_id22
  33   xor   = tt2 tt_xor
  34   or2   = tt2 tt_or2
  35   nor2  = tt2 tt_nor2
  36   equ2  = tt2 tt_equ2
  37   inv22 = tt2 tt_inv22
  38   imp'  = tt2 tt_imp'
  39   inv21 = tt2 tt_inv21
  40   imp   = tt2 tt_imp
  41   nand2 = tt2 tt_nand2
  42   con21 = tt2 tt_con21
  43
  44   and3  a b c = a*b*c
  45   or3   a b c = a+b+c
  46   nand3 a b c = nand2 a (nand2 b c)
  47   nor3  a b c = nor2 a (nor2 b c)
  48
  49   and4  a b c d = (a*b)*(c*d)
  50   or4   a b c d = (a+b)+(c+d)
  51   nand4 a b c d = nand2 (nand2 a b) (nand2 c d)
  52   nor4  a b c d = nor2 (nor2 a b) (nor2 c d)
  53
  54 class (Signal a) => Lattice a where
  55   bot, top, weakZero, weakOne :: a
  56   lub  :: a -> a -> a
  57   pass :: a -> a -> a
  58
  59 class (Signal a) => Static a where
  60   intToSig :: Int -> a
  61   sigToInt :: a -> Int
  62   showStaticSig :: a -> String
  63
  64 class (Signal a) => Dynamic a where
  65   latch, dff :: a -> a
  66
  67 class (Lattice a, Static a) => Log a where
  68   dumLog :: a
  69
  70 class (Lattice a, Dynamic a) => Sig a where
  71   dumSig :: a
  72
  73 data Stream a = Snil | Scons a (Stream a)  deriving (Eq,Show{-was:Text-})
  74
  75 shead :: Stream a -> a
  76 shead (Scons x xs) = x
  77
  78 stail :: Stream a -> Stream a
  79 stail (Scons x xs) = xs
  80
  81 snull :: Stream a -> Bool
  82 snull Snil = True
  83 snull (Scons x xs) = False
  84
  85 smap :: (a->b) -> Stream a -> Stream b
  86 smap f Snil = Snil
  87 smap f (Scons x xs) = Scons (f x) (smap f xs)
  88
  89 stake, sdrop :: Int -> Stream a -> Stream a
  90
  91 stake 0 xs = xs
  92 --should be: stake (i+1) (Scons x xs) = Scons x (stake i xs)
  93 stake i (Scons x xs) | i < 0     = error "Signal.stake: < 0"
  94                      | otherwise = Scons x (stake (i-1) xs)
  95
  96 sdrop 0 xs = xs
  97 --should be:sdrop (i+1) (Scons x xs) = sdrop i xs
  98 sdrop i (Scons x xs) | i < 0     = error "Signal.sdrop: < 0"
  99                      | otherwise = sdrop i xs
 100
 101 smap2 :: (a->b->c) -> Stream a -> Stream b -> Stream c
 102 smap2 f as bs =
 103   case as of
 104     Snil -> Snil
 105     Scons a as' ->
 106       case bs of
 107         Snil -> Snil
 108         Scons b bs' -> Scons (f a b) (smap2 f as' bs')
 109
 110 srepeat :: (Static a) => a -> Stream a
 111 srepeat x = xs where xs = Scons x xs
 112
 113 stream :: [a] -> Stream a
 114 stream [] = Snil
 115 stream (x:xs) = Scons x (stream xs)
 116
 117 instance (Signal a, Static a) => Dynamic (Stream a) where
 118   latch xs = Scons initial xs
 119   dff xs = Scons initial xs
 120
 121 instance (Lattice a, Static a) => Lattice (Stream a) where
 122   bot      = srepeat bot
 123   top      = srepeat top
 124   weakZero = srepeat weakZero
 125   weakOne  = srepeat weakOne
 126   lub      = smap2 lub
 127   pass     = smap2 pass
 128
 129 instance (Signal a, Static a) => Signal (Stream a) where
 130   zerO = srepeat zerO
 131   one  = srepeat one
 132   tt1  = smap . tt1
 133   tt2  = smap2 . tt2
 134
 135 instance (Lattice a, Static a) => Sig (Stream a) where
 136   dumSig = bot  -- ??? shouldn't be necessary, check compiler
 137
 138 instance (Static a) => Num (Stream a) where
 139   (+) = or2
 140   (*) = and2
 141   a - b  = xor a b
 142   negate = inv
 143   abs    = error "abs not defined for Signals"
 144   signum = error "signum not defined for Signals"
 145   fromInteger = error "fromInteger not defined for Signals"
 146