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)
95 PortNameMap -- The port name to bind to
96 -> AST.VHDLName -- The signal or port to bind to it
97 -> AST.AssocElem -- The resulting port map entry
99 -- Accepts a port name and an argument to map to it.
100 -- Returns the appropriate line for in the port map
101 getPortMapEntry (Port portname) signame =
102 (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName signame)
105 [PortNameMap] -- The arguments that need to be applied to the
107 -> PortNameMap -- The output ports that the expression should generate.
108 -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
109 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
110 -> VHDLState ([AST.SigDec], [AST.ConcSm]) -- The resulting VHDL code
112 -- A lambda expression binds the first argument (a) to the binder b.
113 getInstantiations (a:as) outs binds (Lam b expr) =
114 getInstantiations as outs ((b, a):binds) expr
116 -- A case expression that checks a single variable and has a single
117 -- alternative, can be used to take tuples apart
118 getInstantiations args outs binds (Case (Var v) b _ [res]) =
119 -- Split out the type of alternative constructor, the variables it binds
120 -- and the expression to evaluate with the variables bound.
121 let (altcon, bind_vars, expr) = res in
124 if (DataCon.isTupleCon datacon) then
126 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
127 -- the existing bindings list and get the portname map for each of
129 Tuple tuple_ports = Maybe.fromMaybe
130 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
132 -- Merge our existing binds with the new binds.
133 binds' = (zip bind_vars tuple_ports) ++ binds
135 -- Evaluate the expression with the new binds list
136 getInstantiations args outs binds' expr
138 error "Data constructors other than tuples not supported"
140 error "Case binders other than tuples not supported"
142 -- An application is an instantiation of a component
143 getInstantiations args outs binds app@(App expr arg) = do
144 let ((Var f), fargs) = collectArgs app
145 name = getOccString f
146 if isTupleConstructor f
148 -- Get the signals we should bind our results to
149 let Tuple outports = outs
150 -- Split the tuple constructor arguments into types and actual values.
151 let (_, vals) = splitTupleConstructorArgs fargs
152 -- Bind each argument to each output signal
153 res <- sequence $ zipWith
154 (\outs' expr' -> getInstantiations args outs' binds expr')
156 -- res is a list of pairs of lists, so split out the signals and
157 -- components into separate lists of lists
158 let (sigs, comps) = unzip res
159 -- And join all the signals and component instantiations together
160 return $ (concat sigs, concat comps)
162 -- This is an normal function application, which maps to a component
164 -- Lookup the hwfunction to instantiate
165 HWFunction inports outport <- getHWFunc name
166 -- Generate a unique name for the application
167 appname <- uniqueName "app"
168 -- Expand each argument to a signal or port name, possibly generating
169 -- new signals and component instantiations
170 (sigs, comps, args) <- expandArgs binds fargs
171 -- Bind each of the input ports to the expanded signal or port
172 let inmaps = zipWith getPortMapEntry inports args
173 -- Bind each of the output ports to our output signals
174 let outmaps = mapOutputPorts outport outs
175 -- Build and return a component instantiation
176 let comp = AST.CompInsSm
177 (AST.unsafeVHDLBasicId appname)
178 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
179 (AST.PMapAspect (inmaps ++ outmaps))
180 return (sigs, (AST.CSISm comp) : comps)
182 getInstantiations args outs binds expr =
183 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
186 [(CoreBndr, PortNameMap)] -- A list of bindings in effect
187 -> [CoreExpr] -- The arguments to expand
188 -> VHDLState ([AST.SigDec], [AST.ConcSm], [AST.VHDLName])
189 -- The resulting signal declarations,
190 -- component instantiations and a
191 -- VHDLName for each of the
192 -- expressions passed in.
193 expandArgs binds (e:exprs) = do
194 -- Expand the first expression
196 -- A simple variable reference should be in our binds map
197 Var id -> return $ let
198 -- Lookup the id in our binds map
199 Port signalname = Maybe.fromMaybe
200 (error $ "Argument " ++ getOccString id ++ "is unknown")
203 -- Create a VHDL name from the signal name
204 AST.NSimple (AST.unsafeVHDLBasicId signalname)
205 -- Other expressions are unsupported
206 otherwise -> error ("Unsupported expression used as argument: " ++ (showSDoc $ ppr e))
208 (sigs, comps, args) <- expandArgs binds exprs
209 -- Return all results
210 return (sigs, comps, arg:args)
212 expandArgs _ [] = return ([], [], [])
214 -- Is the given name a (binary) tuple constructor
215 isTupleConstructor :: Var.Var -> Bool
216 isTupleConstructor var =
217 Name.isWiredInName name
218 && Name.nameModule name == tuple_mod
219 && (Name.occNameString $ Name.nameOccName name) == "(,)"
221 name = Var.varName var
222 mod = nameModule name
223 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
225 -- Split arguments into type arguments and value arguments This is probably
226 -- not really sufficient (not sure if Types can actually occur as value
228 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
229 splitTupleConstructorArgs (e:es) =
231 Type t -> (e:tys, vals)
232 otherwise -> (tys, e:vals)
234 (tys, vals) = splitTupleConstructorArgs es
237 PortNameMap -- The output portnames of the component
238 -> PortNameMap -- The output portnames and/or signals to map these to
239 -> [AST.AssocElem] -- The resulting output ports
241 -- Map the output port of a component to the output port of the containing
243 mapOutputPorts (Port portname) (Port signalname) =
244 [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
246 -- Map matching output ports in the tuple
247 mapOutputPorts (Tuple ports) (Tuple signals) =
248 concat (zipWith mapOutputPorts ports signals)
251 CoreBind -- The binder to expand into an architecture
252 -> VHDLState AST.ArchBody -- The resulting architecture
254 getArchitecture (Rec _) = error "Recursive binders not supported"
256 getArchitecture (NonRec var expr) = do
257 let name = (getOccString var)
258 HWFunction inports outport <- getHWFunc name
260 (sigs, comps) <- getInstantiations inports outport [] expr
261 return $ AST.ArchBody
262 (AST.unsafeVHDLBasicId "structural")
263 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
264 (AST.NSimple (AST.unsafeVHDLBasicId name))
273 -- Generate a port name map (or multiple for tuple types) in the given direction for
275 getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
276 getPortNameMapForTys prefix num [] = []
277 getPortNameMapForTys prefix num (t:ts) =
278 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
280 getPortNameMapForTy :: String -> Type -> PortNameMap
281 getPortNameMapForTy name ty =
282 if (TyCon.isTupleTyCon tycon) then
283 -- Expand tuples we find
284 Tuple (getPortNameMapForTys name 0 args)
285 else -- Assume it's a type constructor application, ie simple data type
289 (tycon, args) = Type.splitTyConApp ty
291 data HWFunction = HWFunction { -- A function that is available in hardware
292 inPorts :: [PortNameMap],
293 outPort :: PortNameMap
294 --entity :: AST.EntityDec
297 -- Turns a CoreExpr describing a function into a description of its input and
300 CoreBind -- The core binder to generate the interface for
301 -> VHDLState (String, HWFunction) -- The name of the function and its interface
303 mkHWFunction (NonRec var expr) =
304 return (name, HWFunction inports outport)
306 name = (getOccString var)
307 ty = CoreUtils.exprType expr
308 (fargs, res) = Type.splitFunTys ty
309 args = if length fargs == 1 then fargs else (init fargs)
310 --state = if length fargs == 1 then () else (last fargs)
311 inports = case args of
312 -- Handle a single port specially, to prevent an extra 0 in the name
313 [port] -> [getPortNameMapForTy "portin" port]
314 ps -> getPortNameMapForTys "portin" 0 ps
315 outport = getPortNameMapForTy "portout" res
317 mkHWFunction (Rec _) =
318 error "Recursive binders not supported"
320 data VHDLSession = VHDLSession {
321 nameCount :: Int, -- A counter that can be used to generate unique names
322 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
325 type VHDLState = State.State VHDLSession
327 -- Add the function to the session
328 addFunc :: String -> HWFunction -> VHDLState ()
330 fs <- State.gets funcs -- Get the funcs element from the session
331 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
333 -- Lookup the function with the given name in the current session. Errors if
335 getHWFunc :: String -> VHDLState HWFunction
337 fs <- State.gets funcs -- Get the funcs element from the session
338 return $ Maybe.fromMaybe
339 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
342 -- Makes the given name unique by appending a unique number.
343 -- This does not do any checking against existing names, so it only guarantees
344 -- uniqueness with other names generated by uniqueName.
345 uniqueName :: String -> VHDLState String
347 count <- State.gets nameCount -- Get the funcs element from the session
348 State.modify (\s -> s {nameCount = count + 1})
349 return $ name ++ "-" ++ (show count)
353 ("hwxor", HWFunction [Port "a", Port "b"] (Port "o")),
354 ("hwand", HWFunction [Port "a", Port "b"] (Port "o"))
357 -- vim: set ts=8 sw=2 sts=2 expandtab: