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 "inv" (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 expandExpr binds expr =
222 error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
224 -- Generate a signal declaration for a signal with the given name and the
225 -- given type and no value. Also returns the id of the signal.
226 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
228 (id, AST.SigDec id ty Nothing)
230 id = AST.unsafeVHDLBasicId name
233 [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
234 -> [CoreExpr] -- The arguments to expand
235 -> VHDLState ([AST.SigDec], [AST.ConcSm], [AST.VHDLName])
236 -- The resulting signal declarations,
237 -- component instantiations and a
238 -- VHDLName for each of the
239 -- expressions passed in.
240 expandArgs binds (e:exprs) = do
241 -- Expand the first expression
243 -- A simple variable reference should be in our binds map
244 Var id -> return $ let
245 -- Lookup the id in our binds map
246 Signal signalid = Maybe.fromMaybe
247 (error $ "Argument " ++ getOccString id ++ "is unknown")
250 -- Create a VHDL name from the signal name
252 -- Other expressions are unsupported
253 otherwise -> error ("Unsupported expression used as argument: " ++ (showSDoc $ ppr e))
255 (sigs, comps, args) <- expandArgs binds exprs
256 -- Return all results
257 return (sigs, comps, arg:args)
259 expandArgs _ [] = return ([], [], [])
261 -- Is the given name a (binary) tuple constructor
262 isTupleConstructor :: Var.Var -> Bool
263 isTupleConstructor var =
264 Name.isWiredInName name
265 && Name.nameModule name == tuple_mod
266 && (Name.occNameString $ Name.nameOccName name) == "(,)"
268 name = Var.varName var
269 mod = nameModule name
270 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
272 -- Split arguments into type arguments and value arguments This is probably
273 -- not really sufficient (not sure if Types can actually occur as value
275 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
276 splitTupleConstructorArgs (e:es) =
278 Type t -> (e:tys, vals)
279 otherwise -> (tys, e:vals)
281 (tys, vals) = splitTupleConstructorArgs es
284 SignalNameMap AST.VHDLId -- The output portnames of the component
285 -> SignalNameMap AST.VHDLId -- The output portnames and/or signals to map these to
286 -> [AST.AssocElem] -- The resulting output ports
288 -- Map the output port of a component to the output port of the containing
290 mapOutputPorts (Signal portname) (Signal signalname) =
291 [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
293 -- Map matching output ports in the tuple
294 mapOutputPorts (Tuple ports) (Tuple signals) =
295 concat (zipWith mapOutputPorts ports signals)
298 CoreBind -- The binder to expand into an architecture
299 -> VHDLState AST.ArchBody -- The resulting architecture
301 getArchitecture (Rec _) = error "Recursive binders not supported"
303 getArchitecture (NonRec var expr) = do
304 let name = (getOccString var)
305 HWFunction inports outport <- getHWFunc name
307 (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
308 let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
309 let outport_assigns = createSignalAssignments outport res_signal
310 return $ AST.ArchBody
311 (AST.unsafeVHDLBasicId "structural")
312 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
313 (AST.NSimple (AST.unsafeVHDLBasicId name))
314 (map AST.BDISD signal_decls)
315 (inport_assigns ++ outport_assigns ++ statements)
317 -- Create concurrent assignments of one map of signals to another. The maps
318 -- should have a similar form.
319 createSignalAssignments ::
320 SignalNameMap AST.VHDLId -- The signals to assign to
321 -> SignalNameMap AST.VHDLId -- The signals to assign
322 -> [AST.ConcSm] -- The resulting assignments
324 -- A simple assignment of one signal to another (greatly complicated because
325 -- signal assignments can be conditional with multiple conditions in VHDL).
326 createSignalAssignments (Signal dst) (Signal src) =
329 src_name = AST.NSimple src
330 src_expr = AST.PrimName src_name
331 src_wform = AST.Wform [AST.WformElem src_expr Nothing]
332 dst_name = (AST.NSimple dst)
333 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
335 createSignalAssignments (Tuple dsts) (Tuple srcs) =
336 concat $ zipWith createSignalAssignments dsts srcs
338 data SignalNameMap t =
339 Tuple [SignalNameMap t]
343 -- Generate a port name map (or multiple for tuple types) in the given direction for
345 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
346 getPortNameMapForTys prefix num [] = []
347 getPortNameMapForTys prefix num (t:ts) =
348 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
350 getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
351 getPortNameMapForTy name ty =
352 if (TyCon.isTupleTyCon tycon) then
353 -- Expand tuples we find
354 Tuple (getPortNameMapForTys name 0 args)
355 else -- Assume it's a type constructor application, ie simple data type
357 Signal (AST.unsafeVHDLBasicId name)
359 (tycon, args) = Type.splitTyConApp ty
361 data HWFunction = HWFunction { -- A function that is available in hardware
362 inPorts :: [SignalNameMap AST.VHDLId],
363 outPort :: SignalNameMap AST.VHDLId
364 --entity :: AST.EntityDec
367 -- Turns a CoreExpr describing a function into a description of its input and
370 CoreBind -- The core binder to generate the interface for
371 -> VHDLState (String, HWFunction) -- The name of the function and its interface
373 mkHWFunction (NonRec var expr) =
374 return (name, HWFunction inports outport)
376 name = (getOccString var)
377 ty = CoreUtils.exprType expr
378 (fargs, res) = Type.splitFunTys ty
379 args = if length fargs == 1 then fargs else (init fargs)
380 --state = if length fargs == 1 then () else (last fargs)
381 inports = case args of
382 -- Handle a single port specially, to prevent an extra 0 in the name
383 [port] -> [getPortNameMapForTy "portin" port]
384 ps -> getPortNameMapForTys "portin" 0 ps
385 outport = getPortNameMapForTy "portout" res
387 mkHWFunction (Rec _) =
388 error "Recursive binders not supported"
390 data VHDLSession = VHDLSession {
391 nameCount :: Int, -- A counter that can be used to generate unique names
392 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
395 type VHDLState = State.State VHDLSession
397 -- Add the function to the session
398 addFunc :: String -> HWFunction -> VHDLState ()
400 fs <- State.gets funcs -- Get the funcs element from the session
401 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
403 -- Lookup the function with the given name in the current session. Errors if
405 getHWFunc :: String -> VHDLState HWFunction
407 fs <- State.gets funcs -- Get the funcs element from the session
408 return $ Maybe.fromMaybe
409 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
412 -- Makes the given name unique by appending a unique number.
413 -- This does not do any checking against existing names, so it only guarantees
414 -- uniqueness with other names generated by uniqueName.
415 uniqueName :: String -> VHDLState String
417 count <- State.gets nameCount -- Get the funcs element from the session
418 State.modify (\s -> s {nameCount = count + 1})
419 return $ name ++ "-" ++ (show count)
422 mkVHDLId :: String -> AST.VHDLId
423 mkVHDLId = AST.unsafeVHDLBasicId
427 ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
428 ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o"))
431 vhdl_bit_ty :: AST.TypeMark
432 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
434 -- vim: set ts=8 sw=2 sts=2 expandtab: