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 "wire" (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 SignalNameMap AST.VHDLId -- 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 (Signal portname) signame =
102 (Just portname) AST.:=>: (AST.ADName signame)
105 [SignalNameMap AST.VHDLId] -- The arguments that need to be applied to the
107 -> SignalNameMap AST.VHDLId -- The output ports that the expression should generate.
108 -> [(CoreBndr, SignalNameMap AST.VHDLId)]
109 -- A list of bindings in effect
110 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
111 -> VHDLState ([AST.SigDec], [AST.ConcSm])
112 -- The resulting VHDL code
114 -- A lambda expression binds the first argument (a) to the binder b.
115 getInstantiations (a:as) outs binds (Lam b expr) =
116 getInstantiations as outs ((b, a):binds) expr
118 -- A case expression that checks a single variable and has a single
119 -- alternative, can be used to take tuples apart
120 getInstantiations args outs binds (Case (Var v) b _ [res]) =
121 -- Split out the type of alternative constructor, the variables it binds
122 -- and the expression to evaluate with the variables bound.
123 let (altcon, bind_vars, expr) = res in
126 if (DataCon.isTupleCon datacon) then
128 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
129 -- the existing bindings list and get the portname map for each of
131 Tuple tuple_ports = Maybe.fromMaybe
132 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
134 -- Merge our existing binds with the new binds.
135 binds' = (zip bind_vars tuple_ports) ++ binds
137 -- Evaluate the expression with the new binds list
138 getInstantiations args outs binds' expr
140 error "Data constructors other than tuples not supported"
142 error "Case binders other than tuples not supported"
144 -- An application is an instantiation of a component
145 getInstantiations args outs binds app@(App expr arg) = do
146 let ((Var f), fargs) = collectArgs app
147 name = getOccString f
148 if isTupleConstructor f
150 -- Get the signals we should bind our results to
151 let Tuple outports = outs
152 -- Split the tuple constructor arguments into types and actual values.
153 let (_, vals) = splitTupleConstructorArgs fargs
154 -- Bind each argument to each output signal
155 res <- sequence $ zipWith
156 (\outs' expr' -> getInstantiations args outs' binds expr')
158 -- res is a list of pairs of lists, so split out the signals and
159 -- components into separate lists of lists
160 let (sigs, comps) = unzip res
161 -- And join all the signals and component instantiations together
162 return $ (concat sigs, concat comps)
164 -- This is an normal function application, which maps to a component
166 -- Lookup the hwfunction to instantiate
167 HWFunction inports outport <- getHWFunc name
168 -- Generate a unique name for the application
169 appname <- uniqueName "app"
170 -- Expand each argument to a signal or port name, possibly generating
171 -- new signals and component instantiations
172 (sigs, comps, args) <- expandArgs binds fargs
173 -- Bind each of the input ports to the expanded signal or port
174 let inmaps = zipWith getPortMapEntry inports args
175 -- Bind each of the output ports to our output signals
176 let outmaps = mapOutputPorts outport outs
177 -- Build and return a component instantiation
178 let comp = AST.CompInsSm
179 (AST.unsafeVHDLBasicId appname)
180 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
181 (AST.PMapAspect (inmaps ++ outmaps))
182 return (sigs, (AST.CSISm comp) : comps)
184 getInstantiations args outs binds expr =
185 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
188 [(CoreBndr, SignalNameMap AST.VHDLName)]
189 -- A list of bindings in effect
190 -> CoreExpr -- The expression to expand
192 [AST.SigDec], -- Needed signal declarations
193 [AST.ConcSm], -- Needed component instantations and
194 -- signal assignments.
195 [SignalNameMap AST.VHDLId], -- The signal names corresponding to
196 -- the expression's arguments
197 SignalNameMap AST.VHDLId) -- The signal names corresponding to
198 -- the expression's result.
199 expandExpr binds (Lam b expr) = do
200 -- Generate a new signal to which we will expect this argument to be bound.
201 signal_name <- uniqueName ("arg-" ++ getOccString b)
202 let (signal_id, signal_decl) = mkSignal signal_name vhdl_bit_ty
203 -- Add the binder to the list of binds
204 let binds' = (b, Signal (AST.NSimple signal_id)) : binds
205 -- Expand the rest of the expression
206 (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds' expr
207 -- Properly merge the results
208 return (signal_decl : signal_decls,
210 (Signal signal_id) : arg_signals,
213 expandExpr binds (Var id) =
214 return ([], [], [], Signal signal_id)
216 -- Lookup the id in our binds map
217 Signal (AST.NSimple signal_id) = Maybe.fromMaybe
218 (error $ "Argument " ++ getOccString id ++ "is unknown")
221 -- Generate a signal declaration for a signal with the given name and the
222 -- given type and no value. Also returns the id of the signal.
223 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
225 (id, AST.SigDec id ty Nothing)
227 id = AST.unsafeVHDLBasicId name
230 [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
231 -> [CoreExpr] -- The arguments to expand
232 -> VHDLState ([AST.SigDec], [AST.ConcSm], [AST.VHDLName])
233 -- The resulting signal declarations,
234 -- component instantiations and a
235 -- VHDLName for each of the
236 -- expressions passed in.
237 expandArgs binds (e:exprs) = do
238 -- Expand the first expression
240 -- A simple variable reference should be in our binds map
241 Var id -> return $ let
242 -- Lookup the id in our binds map
243 Signal signalid = Maybe.fromMaybe
244 (error $ "Argument " ++ getOccString id ++ "is unknown")
247 -- Create a VHDL name from the signal name
249 -- Other expressions are unsupported
250 otherwise -> error ("Unsupported expression used as argument: " ++ (showSDoc $ ppr e))
252 (sigs, comps, args) <- expandArgs binds exprs
253 -- Return all results
254 return (sigs, comps, arg:args)
256 expandArgs _ [] = return ([], [], [])
258 -- Is the given name a (binary) tuple constructor
259 isTupleConstructor :: Var.Var -> Bool
260 isTupleConstructor var =
261 Name.isWiredInName name
262 && Name.nameModule name == tuple_mod
263 && (Name.occNameString $ Name.nameOccName name) == "(,)"
265 name = Var.varName var
266 mod = nameModule name
267 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
269 -- Split arguments into type arguments and value arguments This is probably
270 -- not really sufficient (not sure if Types can actually occur as value
272 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
273 splitTupleConstructorArgs (e:es) =
275 Type t -> (e:tys, vals)
276 otherwise -> (tys, e:vals)
278 (tys, vals) = splitTupleConstructorArgs es
281 SignalNameMap AST.VHDLId -- The output portnames of the component
282 -> SignalNameMap AST.VHDLId -- The output portnames and/or signals to map these to
283 -> [AST.AssocElem] -- The resulting output ports
285 -- Map the output port of a component to the output port of the containing
287 mapOutputPorts (Signal portname) (Signal signalname) =
288 [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
290 -- Map matching output ports in the tuple
291 mapOutputPorts (Tuple ports) (Tuple signals) =
292 concat (zipWith mapOutputPorts ports signals)
295 CoreBind -- The binder to expand into an architecture
296 -> VHDLState AST.ArchBody -- The resulting architecture
298 getArchitecture (Rec _) = error "Recursive binders not supported"
300 getArchitecture (NonRec var expr) = do
301 let name = (getOccString var)
302 HWFunction inports outport <- getHWFunc name
304 (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
305 let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
306 let outport_assigns = createSignalAssignments outport res_signal
307 return $ AST.ArchBody
308 (AST.unsafeVHDLBasicId "structural")
309 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
310 (AST.NSimple (AST.unsafeVHDLBasicId name))
311 (map AST.BDISD signal_decls)
312 (inport_assigns ++ outport_assigns ++ statements)
314 -- Create concurrent assignments of one map of signals to another. The maps
315 -- should have a similar form.
316 createSignalAssignments ::
317 SignalNameMap AST.VHDLId -- The signals to assign to
318 -> SignalNameMap AST.VHDLId -- The signals to assign
319 -> [AST.ConcSm] -- The resulting assignments
321 -- A simple assignment of one signal to another (greatly complicated because
322 -- signal assignments can be conditional with multiple conditions in VHDL).
323 createSignalAssignments (Signal dst) (Signal src) =
326 src_name = AST.NSimple src
327 src_expr = AST.PrimName src_name
328 src_wform = AST.Wform [AST.WformElem src_expr Nothing]
329 dst_name = (AST.NSimple dst)
330 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
332 createSignalAssignments (Tuple dsts) (Tuple srcs) =
333 concat $ zipWith createSignalAssignments dsts srcs
335 data SignalNameMap t =
336 Tuple [SignalNameMap t]
340 -- Generate a port name map (or multiple for tuple types) in the given direction for
342 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
343 getPortNameMapForTys prefix num [] = []
344 getPortNameMapForTys prefix num (t:ts) =
345 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
347 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
348 getPortNameMapForTy name ty =
349 if (TyCon.isTupleTyCon tycon) then
350 -- Expand tuples we find
351 Tuple (getPortNameMapForTys name 0 args)
352 else -- Assume it's a type constructor application, ie simple data type
354 Signal (AST.unsafeVHDLBasicId name)
356 (tycon, args) = Type.splitTyConApp ty
358 data HWFunction = HWFunction { -- A function that is available in hardware
359 inPorts :: [SignalNameMap AST.VHDLId],
360 outPort :: SignalNameMap AST.VHDLId
361 --entity :: AST.EntityDec
364 -- Turns a CoreExpr describing a function into a description of its input and
367 CoreBind -- The core binder to generate the interface for
368 -> VHDLState (String, HWFunction) -- The name of the function and its interface
370 mkHWFunction (NonRec var expr) =
371 return (name, HWFunction inports outport)
373 name = (getOccString var)
374 ty = CoreUtils.exprType expr
375 (fargs, res) = Type.splitFunTys ty
376 args = if length fargs == 1 then fargs else (init fargs)
377 --state = if length fargs == 1 then () else (last fargs)
378 inports = case args of
379 -- Handle a single port specially, to prevent an extra 0 in the name
380 [port] -> [getPortNameMapForTy "portin" port]
381 ps -> getPortNameMapForTys "portin" 0 ps
382 outport = getPortNameMapForTy "portout" res
384 mkHWFunction (Rec _) =
385 error "Recursive binders not supported"
387 data VHDLSession = VHDLSession {
388 nameCount :: Int, -- A counter that can be used to generate unique names
389 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
392 type VHDLState = State.State VHDLSession
394 -- Add the function to the session
395 addFunc :: String -> HWFunction -> VHDLState ()
397 fs <- State.gets funcs -- Get the funcs element from the session
398 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
400 -- Lookup the function with the given name in the current session. Errors if
402 getHWFunc :: String -> VHDLState HWFunction
404 fs <- State.gets funcs -- Get the funcs element from the session
405 return $ Maybe.fromMaybe
406 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
409 -- Makes the given name unique by appending a unique number.
410 -- This does not do any checking against existing names, so it only guarantees
411 -- uniqueness with other names generated by uniqueName.
412 uniqueName :: String -> VHDLState String
414 count <- State.gets nameCount -- Get the funcs element from the session
415 State.modify (\s -> s {nameCount = count + 1})
416 return $ name ++ "-" ++ (show count)
419 mkVHDLId :: String -> AST.VHDLId
420 mkVHDLId = AST.unsafeVHDLBasicId
424 ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
425 ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o"))
428 vhdl_bit_ty :: AST.TypeMark
429 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
431 -- vim: set ts=8 sw=2 sts=2 expandtab: