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]) =
122 if (DataCon.isTupleCon datacon) then
123 getInstantiations args outs binds' expr
125 error "Data constructors other than tuples not supported"
127 error "Case binders other than tuples not supported"
129 binds' = (zip bind_vars tuple_ports) ++ binds
130 (altcon, bind_vars, expr) = res
131 -- Find the portnamemaps for each of the tuple's elements
132 Tuple tuple_ports = Maybe.fromMaybe
133 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
136 -- An application is an instantiation of a component
137 getInstantiations args outs binds app@(App expr arg) = do
138 let ((Var f), fargs) = collectArgs app
139 name = getOccString f
140 if isTupleConstructor f
142 let Tuple outports = outs
143 (tys, vals) = splitTupleConstructorArgs fargs
144 insts <- sequence $ zipWith
145 (\outs' expr' -> getInstantiations args outs' binds expr')
147 return $ concat insts
149 HWFunction inports outport <- getHWFunc name
150 appname <- uniqueName "app"
151 let comp = AST.CompInsSm
152 (AST.unsafeVHDLBasicId appname)
153 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
154 (AST.PMapAspect ports)
156 zipWith (getPortMapEntry binds) inports fargs
157 ++ mapOutputPorts outport outs
158 return [AST.CSISm comp]
160 getInstantiations args outs binds expr =
161 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
163 -- Is the given name a (binary) tuple constructor
164 isTupleConstructor :: Var.Var -> Bool
165 isTupleConstructor var =
166 Name.isWiredInName name
167 && Name.nameModule name == tuple_mod
168 && (Name.occNameString $ Name.nameOccName name) == "(,)"
170 name = Var.varName var
171 mod = nameModule name
172 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
174 -- Split arguments into type arguments and value arguments This is probably
175 -- not really sufficient (not sure if Types can actually occur as value
177 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
178 splitTupleConstructorArgs (e:es) =
180 Type t -> (e:tys, vals)
181 otherwise -> (tys, e:vals)
183 (tys, vals) = splitTupleConstructorArgs es
186 PortNameMap -- The output portnames of the component
187 -> PortNameMap -- The output portnames and/or signals to map these to
188 -> [AST.AssocElem] -- The resulting output ports
190 -- Map the output port of a component to the output port of the containing
192 mapOutputPorts (Port portname) (Port signalname) =
193 [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
195 -- Map matching output ports in the tuple
196 mapOutputPorts (Tuple ports) (Tuple signals) =
197 concat (zipWith mapOutputPorts ports signals)
200 CoreBind -- The binder to expand into an architecture
201 -> VHDLState AST.ArchBody -- The resulting architecture
203 getArchitecture (Rec _) = error "Recursive binders not supported"
205 getArchitecture (NonRec var expr) = do
206 let name = (getOccString var)
207 HWFunction inports outport <- getHWFunc name
209 insts <- getInstantiations inports outport [] expr
210 return $ AST.ArchBody
211 (AST.unsafeVHDLBasicId "structural")
212 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
213 (AST.NSimple (AST.unsafeVHDLBasicId name))
222 -- Generate a port name map (or multiple for tuple types) in the given direction for
224 getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
225 getPortNameMapForTys prefix num [] = []
226 getPortNameMapForTys prefix num (t:ts) =
227 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
229 getPortNameMapForTy :: String -> Type -> PortNameMap
230 getPortNameMapForTy name ty =
231 if (TyCon.isTupleTyCon tycon) then
232 -- Expand tuples we find
233 Tuple (getPortNameMapForTys name 0 args)
234 else -- Assume it's a type constructor application, ie simple data type
238 (tycon, args) = Type.splitTyConApp ty
240 data HWFunction = HWFunction { -- A function that is available in hardware
241 inPorts :: [PortNameMap],
242 outPort :: PortNameMap
243 --entity :: AST.EntityDec
246 -- Turns a CoreExpr describing a function into a description of its input and
249 CoreBind -- The core binder to generate the interface for
250 -> VHDLState (String, HWFunction) -- The name of the function and its interface
252 mkHWFunction (NonRec var expr) =
253 return (name, HWFunction inports outport)
255 name = (getOccString var)
256 ty = CoreUtils.exprType expr
257 (fargs, res) = Type.splitFunTys ty
258 args = if length fargs == 1 then fargs else (init fargs)
259 --state = if length fargs == 1 then () else (last fargs)
260 inports = case args of
261 -- Handle a single port specially, to prevent an extra 0 in the name
262 [port] -> [getPortNameMapForTy "portin" port]
263 ps -> getPortNameMapForTys "portin" 0 ps
264 outport = getPortNameMapForTy "portout" res
266 mkHWFunction (Rec _) =
267 error "Recursive binders not supported"
269 data VHDLSession = VHDLSession {
270 nameCount :: Int, -- A counter that can be used to generate unique names
271 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
274 type VHDLState = State.State VHDLSession
276 -- Add the function to the session
277 addFunc :: String -> HWFunction -> VHDLState ()
279 fs <- State.gets funcs -- Get the funcs element from the session
280 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
282 -- Lookup the function with the given name in the current session. Errors if
284 getHWFunc :: String -> VHDLState HWFunction
286 fs <- State.gets funcs -- Get the funcs element from the session
287 return $ Maybe.fromMaybe
288 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
291 -- Makes the given name unique by appending a unique number.
292 -- This does not do any checking against existing names, so it only guarantees
293 -- uniqueness with other names generated by uniqueName.
294 uniqueName :: String -> VHDLState String
296 count <- State.gets nameCount -- Get the funcs element from the session
297 State.modify (\s -> s {nameCount = count + 1})
298 return $ name ++ "-" ++ (show count)
302 ("hwxor", HWFunction [Port "a", Port "b"] (Port "o")),
303 ("hwand", HWFunction [Port "a", Port "b"] (Port "o"))
306 -- vim: set ts=8 sw=2 sts=2 expandtab: