Ticket #2045: Vhdl.hs

File Vhdl.hs, 4.6 KB (added by igloo, 7 years ago)
Line 
1
2{-# LANGUAGE EmptyDataDecls #-}
3{-# OPTIONS_GHC -fno-warn-type-defaults #-}
4
5-- ghc -fhpc --make Vhdl.hs -o gencirc -Wall
6
7module Main (main) where
8
9main :: IO ()
10main = writeVhdl
11
12writeVhdl :: IO ()
13writeVhdl = writeDefinitions (undefined :: Signal Bool)
14
15writeDefinitions :: Generic b
16                 => b -> IO ()
17writeDefinitions out =
18  do let define v s =
19           case s of
20             Bool True     -> port "vcc"  []
21             Bool False    -> port "gnd"  []
22             Inv x         -> port "inv"  [x]
23
24             And []        -> define v (Bool True)
25             And [x]       -> port "id"   [x]
26             And [x,y]     -> port "and2" [x,y]
27             And (x:xs)    -> define (w 0) (And xs)
28                           >> define v (And [x,w 0])
29
30             Or  []        -> define v (Bool False)
31             Or  [x]       -> port "id"   [x]
32             Or  [x,y]     -> port "or2"  [x,y]
33             Or  (x:xs)    -> define (w 0) (Or xs)
34                           >> define v (Or [x,w 0])
35
36             Xor  []       -> define v (Bool False)
37             Xor  [x]      -> port "id"   [x]
38             Xor  [x,y]    -> port "xor2" [x,y]
39             Xor  (x:xs)   -> define (w 0) (Or xs)
40                           >> define (w 1) (Inv (w 0))
41                           >> define (w 2) (And [x, w 1])
42
43                           >> define (w 3) (Inv x)
44                           >> define (w 4) (Xor xs)
45                           >> define (w 5) (And [w 3, w 4])
46                           >> define v     (Or [w 2, w 5])
47
48             Multi a1 a2 a3 a4 -> multi a1 a2 a3 a4
49           where
50            w i = v ++ "_" ++ show i
51
52            multi n "RAMB16_S18" opts args =
53              do putStr $
54                      "  "
55                   ++ " : "
56                   ++ "RAMB16_S18"
57                   ++ "\ngeneric map ("
58                   ++ opts
59                   ++ ")\n"
60                   ++ "port map ("
61                   ++ mapTo "DO" [0..15] (get 0 16 outs)
62                   ++ mapTo "DOP" [0,1] (get 16 2 outs)
63                   ++ mapTo "ADDR" [0..9] (get 0 10 args)
64                   ++ "CLK => clk,\n"
65                   ++ mapTo "DI" [0..15] (get 10 16 args)
66                   ++ mapTo "DIP" [0,1] (get 26 2 args)
67                   ++ "EN => '1',\n"
68                   ++ "WE => " ++ head (get 28 1 args) ++ ",\n"
69                   ++ "SSR => '0'\n"
70                   ++ ");\n"
71              where
72                outs = map (\i -> "o" ++ show i ++ "_" ++ v) [1..n]
73
74                get :: Int -> Int -> [a] -> [a]
75                get n' m xs = take m (drop n' xs)
76
77                mapTo s' (n':ns) (x:xs) = s' ++ "(" ++ show n' ++ ")"
78                                          ++ " => " ++ x ++ ",\n"
79                                          ++ mapTo s' ns xs
80                mapTo _ _ _ = ""
81
82
83
84            multi n "RAMB16_S18_S18" opts args =
85              do putStr $
86                      opts
87                   ++ mapTo "DOA" [0..15] (get 0 16 outs)
88                   ++ mapTo "DOB" [0..15] (get 18 16 outs)
89                   ++ mapTo "DOPA" [0,1] (get 16 2 outs)
90                   ++ mapTo "DOPB" [0,1] (get 34 2 outs)
91                   ++ mapTo "ADDRA" [0..9] (get 0 10 args)
92                   ++ mapTo "ADDRB" [0..9] (get 10 10 args)
93                   ++ mapTo "DIA" [0..15] (get 20 16 args)
94                   ++ mapTo "DIB" [0..15] (get 38 16 args)
95                   ++ mapTo "DIPA" [0,1] (get 36 2 args)
96                   ++ mapTo "DIPB" [0,1] (get 54 2 args)
97                   ++ head (get 56 1 args)
98                   ++ head (get 57 1 args)
99              where
100                outs = map (\i -> "o" ++ show i ++ "_" ++ v) [1..n]
101
102                get :: Int -> Int -> [a] -> [a]
103                get _ _ = id
104
105                mapTo s' (n':ns) (x:xs) = s' ++ "(" ++ show n' ++ ")"
106                                          ++ " => " ++ x ++ ",\n"
107                                          ++ mapTo s' ns xs
108                mapTo _ _ _ = ""
109            multi _ _ _ _ = undefined
110
111            port n args | n == "id" =
112              do putStr $
113                      "  "
114                   ++ v ++ " <= " ++ (head args) ++ ";\n"
115
116            port _ _ = undefined
117     netlistIO define (struct out)
118     return ()
119
120netlistIO :: (v -> S v -> IO ()) -> f Symbol -> IO (f v)
121netlistIO = undefined
122
123data Struct a
124
125class Generic a where
126  struct    :: a -> Struct Symbol
127  struct = undefined
128
129instance Generic (Signal a)
130
131data Signal a
132
133data Symbol
134
135data S s
136  = Bool      Bool
137  | Inv       s
138  | And       [s]
139  | Or        [s]
140  | Xor       [s]
141  | Multi    Int String String [s]
142