1 module Main(main) where
4 import qualified CoreUtils
8 import qualified DataCon
10 import qualified Module
13 import NameEnv ( lookupNameEnv )
14 import HscTypes ( cm_binds, cm_types )
15 import MonadUtils ( liftIO )
16 import Outputable ( showSDoc, ppr )
17 import GHC.Paths ( libdir )
18 import DynFlags ( defaultDynFlags )
20 -- The following modules come from the ForSyDe project. They are really
21 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
22 -- ForSyDe to get access to these modules.
23 import qualified ForSyDe.Backend.VHDL.AST as AST
24 import qualified ForSyDe.Backend.VHDL.Ppr
25 import qualified ForSyDe.Backend.Ppr
26 -- This is needed for rendering the pretty printed VHDL
27 import Text.PrettyPrint.HughesPJ (render)
31 defaultErrorHandler defaultDynFlags $ do
32 runGhc (Just libdir) $ do
33 dflags <- getSessionDynFlags
34 setSessionDynFlags dflags
35 --target <- guessTarget "adder.hs" Nothing
36 --liftIO (print (showSDoc (ppr (target))))
37 --liftIO $ printTarget target
40 --core <- GHC.compileToCoreSimplified "Adders.hs"
41 core <- GHC.compileToCoreSimplified "Adders.hs"
42 liftIO $ printBinds (cm_binds core)
43 let bind = findBind "half_adder" (cm_binds core)
44 let NonRec var expr = bind
45 let sess = VHDLSession 0 builtin_funcs
46 let (sess', name, f) = mkHWFunction sess bind
47 let sess = addFunc sess' name f
48 liftIO $ putStr $ showSDoc $ ppr expr
49 liftIO $ putStr "\n\n"
50 liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ getArchitecture sess bind
53 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
56 printBinds [] = putStr "done\n\n"
57 printBinds (b:bs) = do
62 printBind (NonRec b expr) = do
66 printBind (Rec binds) = do
68 foldl1 (>>) (map printBind' binds)
70 printBind' (b, expr) = do
71 putStr $ getOccString b
72 --putStr $ showSDoc $ ppr expr
75 findBind :: String -> [CoreBind] -> CoreBind
77 -- This ignores Recs and compares the name of the bind with lookfor,
78 -- disregarding any namespaces in OccName and extra attributes in Name and
80 Maybe.fromJust . find (\b -> case b of
82 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
85 -- Accepts a port name and an argument to map to it.
86 -- Returns the appropriate line for in the port map
87 getPortMapEntry binds (Port portname) (Var id) =
88 (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))
90 Port signalname = Maybe.fromMaybe
91 (error $ "Argument " ++ getOccString id ++ "is unknown")
94 getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
98 -> PortNameMap -- The arguments that need to be applied to the
99 -- expression. Should always be the Args
101 -> PortNameMap -- The output ports that the expression should generate.
102 -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
103 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
104 -> [AST.ConcSm] -- The resulting VHDL code
106 -- A lambda expression binds the first argument (a) to the binder b.
107 getInstantiations sess (Args (a:as)) outs binds (Lam b expr) =
108 getInstantiations sess (Args as) outs ((b, a):binds) expr
110 -- A case expression that checks a single variable and has a single
111 -- alternative, can be used to take tuples apart
112 getInstantiations sess args outs binds (Case (Var v) b _ [res]) =
115 if (DataCon.isTupleCon datacon) then
116 getInstantiations sess args outs binds' expr
118 error "Data constructors other than tuples not supported"
120 error "Case binders other than tuples not supported"
122 binds' = (zip bind_vars tuple_ports) ++ binds
123 (altcon, bind_vars, expr) = res
124 -- Find the portnamemaps for each of the tuple's elements
125 Tuple tuple_ports = Maybe.fromMaybe
126 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
129 -- An application is an instantiation of a component
130 getInstantiations sess args outs binds app@(App expr arg) =
131 if isTupleConstructor f then
133 Tuple outports = outs
134 (tys, vals) = splitTupleConstructorArgs fargs
137 (\outs' expr' -> getInstantiations sess args outs' binds expr')
142 ((Var f), fargs) = collectArgs app
144 (AST.unsafeVHDLBasicId "app")
145 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId compname)))
146 (AST.PMapAspect ports)
147 compname = getOccString f
148 hwfunc = Maybe.fromMaybe
149 (error $ "Function " ++ compname ++ "is unknown")
150 (lookup compname (funcs sess))
151 HWFunction (Args inports) outport = hwfunc
153 zipWith (getPortMapEntry binds) inports fargs
154 ++ mapOutputPorts outport outs
156 getInstantiations sess args outs binds expr =
157 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
159 -- Is the given name a (binary) tuple constructor
160 isTupleConstructor :: Var.Var -> Bool
161 isTupleConstructor var =
162 Name.isWiredInName name
163 && Name.nameModule name == tuple_mod
164 && (Name.occNameString $ Name.nameOccName name) == "(,)"
166 name = Var.varName var
167 mod = nameModule name
168 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
170 -- Split arguments into type arguments and value arguments This is probably
171 -- not really sufficient (not sure if Types can actually occur as value
173 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
174 splitTupleConstructorArgs (e:es) =
176 Type t -> (e:tys, vals)
177 otherwise -> (tys, e:vals)
179 (tys, vals) = splitTupleConstructorArgs es
182 PortNameMap -- The output portnames of the component
183 -> PortNameMap -- The output portnames and/or signals to map these to
184 -> [AST.AssocElem] -- The resulting output ports
186 -- Map the output port of a component to the output port of the containing
188 mapOutputPorts (Port portname) (Port signalname) =
189 [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
191 -- Map matching output ports in the tuple
192 mapOutputPorts (Tuple ports) (Tuple signals) =
193 concat (zipWith mapOutputPorts ports signals)
197 -> CoreBind -- The binder to expand into an architecture
198 -> AST.ArchBody -- The resulting architecture
200 getArchitecture sess (Rec _) = error "Recursive binders not supported"
202 getArchitecture sess (NonRec var expr) =
204 (AST.unsafeVHDLBasicId "structural")
205 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
206 (AST.NSimple (AST.unsafeVHDLBasicId name))
208 (getInstantiations sess (Args inportnames) outport [] expr)
210 name = (getOccString var)
211 ty = CoreUtils.exprType expr
212 (fargs, res) = Type.splitFunTys ty
213 --state = if length fargs == 1 then () else (last fargs)
214 ports = if length fargs == 1 then fargs else (init fargs)
215 inportnames = case ports of
216 [port] -> [getPortNameMapForTy "portin" port]
217 ps -> getPortNameMapForTys "portin" 0 ps
218 outport = getPortNameMapForTy "portout" res
221 Args [PortNameMap] -- Each of the submaps represent an argument to the
222 -- function. Should only occur at top level.
223 | Tuple [PortNameMap]
226 -- Generate a port name map (or multiple for tuple types) in the given direction for
228 getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
229 getPortNameMapForTys prefix num [] = []
230 getPortNameMapForTys prefix num (t:ts) =
231 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
233 getPortNameMapForTy :: String -> Type -> PortNameMap
234 getPortNameMapForTy name ty =
235 if (TyCon.isTupleTyCon tycon) then
236 -- Expand tuples we find
237 Tuple (getPortNameMapForTys name 0 args)
238 else -- Assume it's a type constructor application, ie simple data type
242 (tycon, args) = Type.splitTyConApp ty
244 data HWFunction = HWFunction { -- A function that is available in hardware
245 inPorts :: PortNameMap,
246 outPorts :: PortNameMap
247 --entity :: AST.EntityDec
250 -- Turns a CoreExpr describing a function into a description of its input and
254 -> CoreBind -- The core binder to generate the interface for
255 -> (VHDLSession, String, HWFunction) -- The name of the function and its interface
257 mkHWFunction sess (NonRec var expr) =
258 (sess, name, HWFunction (Args inports) outport)
260 name = (getOccString var)
261 ty = CoreUtils.exprType expr
262 (fargs, res) = Type.splitFunTys ty
263 args = if length fargs == 1 then fargs else (init fargs)
264 --state = if length fargs == 1 then () else (last fargs)
265 inports = case args of
266 -- Handle a single port specially, to prevent an extra 0 in the name
267 [port] -> [getPortNameMapForTy "portin" port]
268 ps -> getPortNameMapForTys "portin" 0 ps
269 outport = getPortNameMapForTy "portout" res
271 mkHWFunction sess (Rec _) =
272 error "Recursive binders not supported"
274 data VHDLSession = VHDLSession {
275 nameCount :: Int, -- A counter that can be used to generate unique names
276 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
279 -- Add the function to the session
280 addFunc :: VHDLSession -> String -> HWFunction -> VHDLSession
281 addFunc sess name f =
282 sess {funcs = (name, f) : (funcs sess) }
286 ("hwxor", HWFunction (Args [Port "a", Port "b"]) (Port "o")),
287 ("hwand", HWFunction (Args [Port "a", Port "b"]) (Port "o"))