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
100 -> PortNameMap -- The output ports that the expression should generate.
101 -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
102 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
103 -> [AST.ConcSm] -- The resulting VHDL code
105 -- A lambda expression binds the first argument (a) to the binder b.
106 getInstantiations sess (a:as) outs binds (Lam b expr) =
107 getInstantiations sess as outs ((b, a):binds) expr
109 -- A case expression that checks a single variable and has a single
110 -- alternative, can be used to take tuples apart
111 getInstantiations sess args outs binds (Case (Var v) b _ [res]) =
114 if (DataCon.isTupleCon datacon) then
115 getInstantiations sess args outs binds' expr
117 error "Data constructors other than tuples not supported"
119 error "Case binders other than tuples not supported"
121 binds' = (zip bind_vars tuple_ports) ++ binds
122 (altcon, bind_vars, expr) = res
123 -- Find the portnamemaps for each of the tuple's elements
124 Tuple tuple_ports = Maybe.fromMaybe
125 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
128 -- An application is an instantiation of a component
129 getInstantiations sess args outs binds app@(App expr arg) =
130 if isTupleConstructor f then
132 Tuple outports = outs
133 (tys, vals) = splitTupleConstructorArgs fargs
136 (\outs' expr' -> getInstantiations sess args outs' binds expr')
141 ((Var f), fargs) = collectArgs app
143 (AST.unsafeVHDLBasicId "app")
144 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId compname)))
145 (AST.PMapAspect ports)
146 compname = getOccString f
147 hwfunc = Maybe.fromMaybe
148 (error $ "Function " ++ compname ++ "is unknown")
149 (lookup compname (funcs sess))
150 HWFunction inports outport = hwfunc
152 zipWith (getPortMapEntry binds) inports fargs
153 ++ mapOutputPorts outport outs
155 getInstantiations sess args outs binds expr =
156 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
158 -- Is the given name a (binary) tuple constructor
159 isTupleConstructor :: Var.Var -> Bool
160 isTupleConstructor var =
161 Name.isWiredInName name
162 && Name.nameModule name == tuple_mod
163 && (Name.occNameString $ Name.nameOccName name) == "(,)"
165 name = Var.varName var
166 mod = nameModule name
167 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
169 -- Split arguments into type arguments and value arguments This is probably
170 -- not really sufficient (not sure if Types can actually occur as value
172 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
173 splitTupleConstructorArgs (e:es) =
175 Type t -> (e:tys, vals)
176 otherwise -> (tys, e:vals)
178 (tys, vals) = splitTupleConstructorArgs es
181 PortNameMap -- The output portnames of the component
182 -> PortNameMap -- The output portnames and/or signals to map these to
183 -> [AST.AssocElem] -- The resulting output ports
185 -- Map the output port of a component to the output port of the containing
187 mapOutputPorts (Port portname) (Port signalname) =
188 [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
190 -- Map matching output ports in the tuple
191 mapOutputPorts (Tuple ports) (Tuple signals) =
192 concat (zipWith mapOutputPorts ports signals)
196 -> CoreBind -- The binder to expand into an architecture
197 -> AST.ArchBody -- The resulting architecture
199 getArchitecture sess (Rec _) = error "Recursive binders not supported"
201 getArchitecture sess (NonRec var expr) =
203 (AST.unsafeVHDLBasicId "structural")
204 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
205 (AST.NSimple (AST.unsafeVHDLBasicId name))
207 (getInstantiations sess inports outport [] expr)
209 name = (getOccString var)
210 hwfunc = Maybe.fromMaybe
211 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
212 (lookup name (funcs sess))
213 HWFunction inports outport = hwfunc
219 -- Generate a port name map (or multiple for tuple types) in the given direction for
221 getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
222 getPortNameMapForTys prefix num [] = []
223 getPortNameMapForTys prefix num (t:ts) =
224 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
226 getPortNameMapForTy :: String -> Type -> PortNameMap
227 getPortNameMapForTy name ty =
228 if (TyCon.isTupleTyCon tycon) then
229 -- Expand tuples we find
230 Tuple (getPortNameMapForTys name 0 args)
231 else -- Assume it's a type constructor application, ie simple data type
235 (tycon, args) = Type.splitTyConApp ty
237 data HWFunction = HWFunction { -- A function that is available in hardware
238 inPorts :: [PortNameMap],
239 outPort :: PortNameMap
240 --entity :: AST.EntityDec
243 -- Turns a CoreExpr describing a function into a description of its input and
247 -> CoreBind -- The core binder to generate the interface for
248 -> (VHDLSession, String, HWFunction) -- The name of the function and its interface
250 mkHWFunction sess (NonRec var expr) =
251 (sess, name, HWFunction inports outport)
253 name = (getOccString var)
254 ty = CoreUtils.exprType expr
255 (fargs, res) = Type.splitFunTys ty
256 args = if length fargs == 1 then fargs else (init fargs)
257 --state = if length fargs == 1 then () else (last fargs)
258 inports = case args of
259 -- Handle a single port specially, to prevent an extra 0 in the name
260 [port] -> [getPortNameMapForTy "portin" port]
261 ps -> getPortNameMapForTys "portin" 0 ps
262 outport = getPortNameMapForTy "portout" res
264 mkHWFunction sess (Rec _) =
265 error "Recursive binders not supported"
267 data VHDLSession = VHDLSession {
268 nameCount :: Int, -- A counter that can be used to generate unique names
269 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
272 -- Add the function to the session
273 addFunc :: VHDLSession -> String -> HWFunction -> VHDLSession
274 addFunc sess name f =
275 sess {funcs = (name, f) : (funcs sess) }
279 ("hwxor", HWFunction [Port "a", Port "b"] (Port "o")),
280 ("hwand", HWFunction [Port "a", Port "b"] (Port "o"))