1 module Main(main) where
4 import qualified CoreUtils
8 import qualified DataCon
10 import qualified Module
11 import qualified Control.Monad.State as State
14 import NameEnv ( lookupNameEnv )
15 import HscTypes ( cm_binds, cm_types )
16 import MonadUtils ( liftIO )
17 import Outputable ( showSDoc, ppr )
18 import GHC.Paths ( libdir )
19 import DynFlags ( defaultDynFlags )
21 -- The following modules come from the ForSyDe project. They are really
22 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
23 -- ForSyDe to get access to these modules.
24 import qualified ForSyDe.Backend.VHDL.AST as AST
25 import qualified ForSyDe.Backend.VHDL.Ppr
26 import qualified ForSyDe.Backend.Ppr
27 -- This is needed for rendering the pretty printed VHDL
28 import Text.PrettyPrint.HughesPJ (render)
32 defaultErrorHandler defaultDynFlags $ do
33 runGhc (Just libdir) $ do
34 dflags <- getSessionDynFlags
35 setSessionDynFlags dflags
36 --target <- guessTarget "adder.hs" Nothing
37 --liftIO (print (showSDoc (ppr (target))))
38 --liftIO $ printTarget target
41 --core <- GHC.compileToCoreSimplified "Adders.hs"
42 core <- GHC.compileToCoreSimplified "Adders.hs"
43 liftIO $ printBinds (cm_binds core)
44 let bind = findBind "half_adder" (cm_binds core)
45 let NonRec var expr = bind
46 -- Turn bind into VHDL
47 let vhdl = State.evalState (mkVHDL bind) (VHDLSession 0 builtin_funcs)
48 liftIO $ putStr $ showSDoc $ ppr expr
49 liftIO $ putStr "\n\n"
50 liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ vhdl
53 -- Turns the given bind into VHDL
55 -- Get the function signature
56 (name, f) <- mkHWFunction bind
57 -- Add it to the session
59 arch <- getArchitecture bind
62 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
65 printBinds [] = putStr "done\n\n"
66 printBinds (b:bs) = do
71 printBind (NonRec b expr) = do
75 printBind (Rec binds) = do
77 foldl1 (>>) (map printBind' binds)
79 printBind' (b, expr) = do
80 putStr $ getOccString b
81 --putStr $ showSDoc $ ppr expr
84 findBind :: String -> [CoreBind] -> CoreBind
86 -- This ignores Recs and compares the name of the bind with lookfor,
87 -- disregarding any namespaces in OccName and extra attributes in Name and
89 Maybe.fromJust . find (\b -> case b of
91 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
94 -- Accepts a port name and an argument to map to it.
95 -- Returns the appropriate line for in the port map
96 getPortMapEntry binds (Port portname) (Var id) =
97 (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))
99 Port signalname = Maybe.fromMaybe
100 (error $ "Argument " ++ getOccString id ++ "is unknown")
103 getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
106 [PortNameMap] -- The arguments that need to be applied to the
108 -> PortNameMap -- The output ports that the expression should generate.
109 -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
110 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
111 -> VHDLState [AST.ConcSm] -- The resulting VHDL code
113 -- A lambda expression binds the first argument (a) to the binder b.
114 getInstantiations (a:as) outs binds (Lam b expr) =
115 getInstantiations as outs ((b, a):binds) expr
117 -- A case expression that checks a single variable and has a single
118 -- alternative, can be used to take tuples apart
119 getInstantiations args outs binds (Case (Var v) b _ [res]) =
120 -- Split out the type of alternative constructor, the variables it binds
121 -- and the expression to evaluate with the variables bound.
122 let (altcon, bind_vars, expr) = res in
125 if (DataCon.isTupleCon datacon) then
127 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
128 -- the existing bindings list and get the portname map for each of
130 Tuple tuple_ports = Maybe.fromMaybe
131 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
133 -- Merge our existing binds with the new binds.
134 binds' = (zip bind_vars tuple_ports) ++ binds
136 -- Evaluate the expression with the new binds list
137 getInstantiations args outs binds' expr
139 error "Data constructors other than tuples not supported"
141 error "Case binders other than tuples not supported"
143 -- An application is an instantiation of a component
144 getInstantiations args outs binds app@(App expr arg) = do
145 let ((Var f), fargs) = collectArgs app
146 name = getOccString f
147 if isTupleConstructor f
149 -- Get the signals we should bind our results to
150 let Tuple outports = outs
151 -- Split the tuple constructor arguments into types and actual values.
152 let (_, vals) = splitTupleConstructorArgs fargs
153 -- Bind each argument to each output signal
154 insts <- sequence $ zipWith
155 (\outs' expr' -> getInstantiations args outs' binds expr')
157 -- And join all the component instantiations together
158 return $ concat insts
160 -- This is an normal function application, which maps to a component
162 -- Lookup the hwfunction to instantiate
163 HWFunction inports outport <- getHWFunc name
164 -- Generate a unique name for the application
165 appname <- uniqueName "app"
166 -- Bind each of the input ports to an argument
167 let inmaps = zipWith (getPortMapEntry binds) inports fargs
168 -- Bind each of the output ports to our output signals
169 let outmaps = mapOutputPorts outport outs
170 -- Build and return a component instantiation
171 let comp = AST.CompInsSm
172 (AST.unsafeVHDLBasicId appname)
173 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
174 (AST.PMapAspect (inmaps ++ outmaps))
175 return [AST.CSISm comp]
177 getInstantiations args outs binds expr =
178 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
180 -- Is the given name a (binary) tuple constructor
181 isTupleConstructor :: Var.Var -> Bool
182 isTupleConstructor var =
183 Name.isWiredInName name
184 && Name.nameModule name == tuple_mod
185 && (Name.occNameString $ Name.nameOccName name) == "(,)"
187 name = Var.varName var
188 mod = nameModule name
189 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
191 -- Split arguments into type arguments and value arguments This is probably
192 -- not really sufficient (not sure if Types can actually occur as value
194 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
195 splitTupleConstructorArgs (e:es) =
197 Type t -> (e:tys, vals)
198 otherwise -> (tys, e:vals)
200 (tys, vals) = splitTupleConstructorArgs es
203 PortNameMap -- The output portnames of the component
204 -> PortNameMap -- The output portnames and/or signals to map these to
205 -> [AST.AssocElem] -- The resulting output ports
207 -- Map the output port of a component to the output port of the containing
209 mapOutputPorts (Port portname) (Port signalname) =
210 [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
212 -- Map matching output ports in the tuple
213 mapOutputPorts (Tuple ports) (Tuple signals) =
214 concat (zipWith mapOutputPorts ports signals)
217 CoreBind -- The binder to expand into an architecture
218 -> VHDLState AST.ArchBody -- The resulting architecture
220 getArchitecture (Rec _) = error "Recursive binders not supported"
222 getArchitecture (NonRec var expr) = do
223 let name = (getOccString var)
224 HWFunction inports outport <- getHWFunc name
226 insts <- getInstantiations inports outport [] expr
227 return $ AST.ArchBody
228 (AST.unsafeVHDLBasicId "structural")
229 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
230 (AST.NSimple (AST.unsafeVHDLBasicId name))
239 -- Generate a port name map (or multiple for tuple types) in the given direction for
241 getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
242 getPortNameMapForTys prefix num [] = []
243 getPortNameMapForTys prefix num (t:ts) =
244 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
246 getPortNameMapForTy :: String -> Type -> PortNameMap
247 getPortNameMapForTy name ty =
248 if (TyCon.isTupleTyCon tycon) then
249 -- Expand tuples we find
250 Tuple (getPortNameMapForTys name 0 args)
251 else -- Assume it's a type constructor application, ie simple data type
255 (tycon, args) = Type.splitTyConApp ty
257 data HWFunction = HWFunction { -- A function that is available in hardware
258 inPorts :: [PortNameMap],
259 outPort :: PortNameMap
260 --entity :: AST.EntityDec
263 -- Turns a CoreExpr describing a function into a description of its input and
266 CoreBind -- The core binder to generate the interface for
267 -> VHDLState (String, HWFunction) -- The name of the function and its interface
269 mkHWFunction (NonRec var expr) =
270 return (name, HWFunction inports outport)
272 name = (getOccString var)
273 ty = CoreUtils.exprType expr
274 (fargs, res) = Type.splitFunTys ty
275 args = if length fargs == 1 then fargs else (init fargs)
276 --state = if length fargs == 1 then () else (last fargs)
277 inports = case args of
278 -- Handle a single port specially, to prevent an extra 0 in the name
279 [port] -> [getPortNameMapForTy "portin" port]
280 ps -> getPortNameMapForTys "portin" 0 ps
281 outport = getPortNameMapForTy "portout" res
283 mkHWFunction (Rec _) =
284 error "Recursive binders not supported"
286 data VHDLSession = VHDLSession {
287 nameCount :: Int, -- A counter that can be used to generate unique names
288 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
291 type VHDLState = State.State VHDLSession
293 -- Add the function to the session
294 addFunc :: String -> HWFunction -> VHDLState ()
296 fs <- State.gets funcs -- Get the funcs element from the session
297 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
299 -- Lookup the function with the given name in the current session. Errors if
301 getHWFunc :: String -> VHDLState HWFunction
303 fs <- State.gets funcs -- Get the funcs element from the session
304 return $ Maybe.fromMaybe
305 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
308 -- Makes the given name unique by appending a unique number.
309 -- This does not do any checking against existing names, so it only guarantees
310 -- uniqueness with other names generated by uniqueName.
311 uniqueName :: String -> VHDLState String
313 count <- State.gets nameCount -- Get the funcs element from the session
314 State.modify (\s -> s {nameCount = count + 1})
315 return $ name ++ "-" ++ (show count)
319 ("hwxor", HWFunction [Port "a", Port "b"] (Port "o")),
320 ("hwand", HWFunction [Port "a", Port "b"] (Port "o"))
323 -- vim: set ts=8 sw=2 sts=2 expandtab: