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 SignalNameMap String -- 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 (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName signame)
105 [SignalNameMap String] -- The arguments that need to be applied to the
107 -> SignalNameMap String -- The output ports that the expression should generate.
108 -> [(CoreBndr, SignalNameMap String)]
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 String)] -- A list of bindings in effect
189 -> [CoreExpr] -- The arguments to expand
190 -> VHDLState ([AST.SigDec], [AST.ConcSm], [AST.VHDLName])
191 -- The resulting signal declarations,
192 -- component instantiations and a
193 -- VHDLName for each of the
194 -- expressions passed in.
195 expandArgs binds (e:exprs) = do
196 -- Expand the first expression
198 -- A simple variable reference should be in our binds map
199 Var id -> return $ let
200 -- Lookup the id in our binds map
201 Signal signalname = Maybe.fromMaybe
202 (error $ "Argument " ++ getOccString id ++ "is unknown")
205 -- Create a VHDL name from the signal name
206 AST.NSimple (AST.unsafeVHDLBasicId signalname)
207 -- Other expressions are unsupported
208 otherwise -> error ("Unsupported expression used as argument: " ++ (showSDoc $ ppr e))
210 (sigs, comps, args) <- expandArgs binds exprs
211 -- Return all results
212 return (sigs, comps, arg:args)
214 expandArgs _ [] = return ([], [], [])
216 -- Is the given name a (binary) tuple constructor
217 isTupleConstructor :: Var.Var -> Bool
218 isTupleConstructor var =
219 Name.isWiredInName name
220 && Name.nameModule name == tuple_mod
221 && (Name.occNameString $ Name.nameOccName name) == "(,)"
223 name = Var.varName var
224 mod = nameModule name
225 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
227 -- Split arguments into type arguments and value arguments This is probably
228 -- not really sufficient (not sure if Types can actually occur as value
230 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
231 splitTupleConstructorArgs (e:es) =
233 Type t -> (e:tys, vals)
234 otherwise -> (tys, e:vals)
236 (tys, vals) = splitTupleConstructorArgs es
239 SignalNameMap String -- The output portnames of the component
240 -> SignalNameMap String -- The output portnames and/or signals to map these to
241 -> [AST.AssocElem] -- The resulting output ports
243 -- Map the output port of a component to the output port of the containing
245 mapOutputPorts (Signal portname) (Signal signalname) =
246 [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
248 -- Map matching output ports in the tuple
249 mapOutputPorts (Tuple ports) (Tuple signals) =
250 concat (zipWith mapOutputPorts ports signals)
253 CoreBind -- The binder to expand into an architecture
254 -> VHDLState AST.ArchBody -- The resulting architecture
256 getArchitecture (Rec _) = error "Recursive binders not supported"
258 getArchitecture (NonRec var expr) = do
259 let name = (getOccString var)
260 HWFunction inports outport <- getHWFunc name
262 (sigs, comps) <- getInstantiations inports outport [] expr
263 return $ AST.ArchBody
264 (AST.unsafeVHDLBasicId "structural")
265 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
266 (AST.NSimple (AST.unsafeVHDLBasicId name))
270 data SignalNameMap t =
271 Tuple [SignalNameMap t]
275 -- Generate a port name map (or multiple for tuple types) in the given direction for
277 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap String]
278 getPortNameMapForTys prefix num [] = []
279 getPortNameMapForTys prefix num (t:ts) =
280 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
282 getPortNameMapForTy :: String -> Type -> SignalNameMap String
283 getPortNameMapForTy name ty =
284 if (TyCon.isTupleTyCon tycon) then
285 -- Expand tuples we find
286 Tuple (getPortNameMapForTys name 0 args)
287 else -- Assume it's a type constructor application, ie simple data type
291 (tycon, args) = Type.splitTyConApp ty
293 data HWFunction = HWFunction { -- A function that is available in hardware
294 inPorts :: [SignalNameMap String],
295 outPort :: SignalNameMap String
296 --entity :: AST.EntityDec
299 -- Turns a CoreExpr describing a function into a description of its input and
302 CoreBind -- The core binder to generate the interface for
303 -> VHDLState (String, HWFunction) -- The name of the function and its interface
305 mkHWFunction (NonRec var expr) =
306 return (name, HWFunction inports outport)
308 name = (getOccString var)
309 ty = CoreUtils.exprType expr
310 (fargs, res) = Type.splitFunTys ty
311 args = if length fargs == 1 then fargs else (init fargs)
312 --state = if length fargs == 1 then () else (last fargs)
313 inports = case args of
314 -- Handle a single port specially, to prevent an extra 0 in the name
315 [port] -> [getPortNameMapForTy "portin" port]
316 ps -> getPortNameMapForTys "portin" 0 ps
317 outport = getPortNameMapForTy "portout" res
319 mkHWFunction (Rec _) =
320 error "Recursive binders not supported"
322 data VHDLSession = VHDLSession {
323 nameCount :: Int, -- A counter that can be used to generate unique names
324 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
327 type VHDLState = State.State VHDLSession
329 -- Add the function to the session
330 addFunc :: String -> HWFunction -> VHDLState ()
332 fs <- State.gets funcs -- Get the funcs element from the session
333 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
335 -- Lookup the function with the given name in the current session. Errors if
337 getHWFunc :: String -> VHDLState HWFunction
339 fs <- State.gets funcs -- Get the funcs element from the session
340 return $ Maybe.fromMaybe
341 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
344 -- Makes the given name unique by appending a unique number.
345 -- This does not do any checking against existing names, so it only guarantees
346 -- uniqueness with other names generated by uniqueName.
347 uniqueName :: String -> VHDLState String
349 count <- State.gets nameCount -- Get the funcs element from the session
350 State.modify (\s -> s {nameCount = count + 1})
351 return $ name ++ "-" ++ (show count)
355 ("hwxor", HWFunction [Signal "a", Signal "b"] (Signal "o")),
356 ("hwand", HWFunction [Signal "a", Signal "b"] (Signal "o"))
359 -- vim: set ts=8 sw=2 sts=2 expandtab: