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 let sess = State.execState (do {(name, f) <- mkHWFunction bind; addFunc name f}) (VHDLSession 0 builtin_funcs)
47 liftIO $ putStr $ showSDoc $ ppr expr
48 liftIO $ putStr "\n\n"
49 liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ getArchitecture sess bind
52 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
55 printBinds [] = putStr "done\n\n"
56 printBinds (b:bs) = do
61 printBind (NonRec b expr) = do
65 printBind (Rec binds) = do
67 foldl1 (>>) (map printBind' binds)
69 printBind' (b, expr) = do
70 putStr $ getOccString b
71 --putStr $ showSDoc $ ppr expr
74 findBind :: String -> [CoreBind] -> CoreBind
76 -- This ignores Recs and compares the name of the bind with lookfor,
77 -- disregarding any namespaces in OccName and extra attributes in Name and
79 Maybe.fromJust . find (\b -> case b of
81 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
84 -- Accepts a port name and an argument to map to it.
85 -- Returns the appropriate line for in the port map
86 getPortMapEntry binds (Port portname) (Var id) =
87 (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))
89 Port signalname = Maybe.fromMaybe
90 (error $ "Argument " ++ getOccString id ++ "is unknown")
93 getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
97 -> [PortNameMap] -- The arguments that need to be applied to the
99 -> PortNameMap -- The output ports that the expression should generate.
100 -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
101 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
102 -> [AST.ConcSm] -- The resulting VHDL code
104 -- A lambda expression binds the first argument (a) to the binder b.
105 getInstantiations sess (a:as) outs binds (Lam b expr) =
106 getInstantiations sess as outs ((b, a):binds) expr
108 -- A case expression that checks a single variable and has a single
109 -- alternative, can be used to take tuples apart
110 getInstantiations sess args outs binds (Case (Var v) b _ [res]) =
113 if (DataCon.isTupleCon datacon) then
114 getInstantiations sess args outs binds' expr
116 error "Data constructors other than tuples not supported"
118 error "Case binders other than tuples not supported"
120 binds' = (zip bind_vars tuple_ports) ++ binds
121 (altcon, bind_vars, expr) = res
122 -- Find the portnamemaps for each of the tuple's elements
123 Tuple tuple_ports = Maybe.fromMaybe
124 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
127 -- An application is an instantiation of a component
128 getInstantiations sess args outs binds app@(App expr arg) =
129 if isTupleConstructor f then
131 Tuple outports = outs
132 (tys, vals) = splitTupleConstructorArgs fargs
135 (\outs' expr' -> getInstantiations sess args outs' binds expr')
140 ((Var f), fargs) = collectArgs app
142 (AST.unsafeVHDLBasicId "app")
143 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId compname)))
144 (AST.PMapAspect ports)
145 compname = getOccString f
146 hwfunc = Maybe.fromMaybe
147 (error $ "Function " ++ compname ++ "is unknown")
148 (lookup compname (funcs sess))
149 HWFunction inports outport = hwfunc
151 zipWith (getPortMapEntry binds) inports fargs
152 ++ mapOutputPorts outport outs
154 getInstantiations sess args outs binds expr =
155 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
157 -- Is the given name a (binary) tuple constructor
158 isTupleConstructor :: Var.Var -> Bool
159 isTupleConstructor var =
160 Name.isWiredInName name
161 && Name.nameModule name == tuple_mod
162 && (Name.occNameString $ Name.nameOccName name) == "(,)"
164 name = Var.varName var
165 mod = nameModule name
166 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
168 -- Split arguments into type arguments and value arguments This is probably
169 -- not really sufficient (not sure if Types can actually occur as value
171 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
172 splitTupleConstructorArgs (e:es) =
174 Type t -> (e:tys, vals)
175 otherwise -> (tys, e:vals)
177 (tys, vals) = splitTupleConstructorArgs es
180 PortNameMap -- The output portnames of the component
181 -> PortNameMap -- The output portnames and/or signals to map these to
182 -> [AST.AssocElem] -- The resulting output ports
184 -- Map the output port of a component to the output port of the containing
186 mapOutputPorts (Port portname) (Port signalname) =
187 [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
189 -- Map matching output ports in the tuple
190 mapOutputPorts (Tuple ports) (Tuple signals) =
191 concat (zipWith mapOutputPorts ports signals)
195 -> CoreBind -- The binder to expand into an architecture
196 -> AST.ArchBody -- The resulting architecture
198 getArchitecture sess (Rec _) = error "Recursive binders not supported"
200 getArchitecture sess (NonRec var expr) =
202 (AST.unsafeVHDLBasicId "structural")
203 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
204 (AST.NSimple (AST.unsafeVHDLBasicId name))
206 (getInstantiations sess inports outport [] expr)
208 name = (getOccString var)
209 hwfunc = Maybe.fromMaybe
210 (error $ "Function " ++ name ++ "is unknown? This should not happen!")
211 (lookup name (funcs sess))
212 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
246 CoreBind -- The core binder to generate the interface for
247 -> VHDLState (String, HWFunction) -- The name of the function and its interface
249 mkHWFunction (NonRec var expr) =
250 return (name, HWFunction inports outport)
252 name = (getOccString var)
253 ty = CoreUtils.exprType expr
254 (fargs, res) = Type.splitFunTys ty
255 args = if length fargs == 1 then fargs else (init fargs)
256 --state = if length fargs == 1 then () else (last fargs)
257 inports = case args of
258 -- Handle a single port specially, to prevent an extra 0 in the name
259 [port] -> [getPortNameMapForTy "portin" port]
260 ps -> getPortNameMapForTys "portin" 0 ps
261 outport = getPortNameMapForTy "portout" res
263 mkHWFunction (Rec _) =
264 error "Recursive binders not supported"
266 data VHDLSession = VHDLSession {
267 nameCount :: Int, -- A counter that can be used to generate unique names
268 funcs :: [(String, HWFunction)] -- All functions available, indexed by name
271 type VHDLState = State.State VHDLSession
273 -- Add the function to the session
274 addFunc :: String -> HWFunction -> VHDLState ()
276 fs <- State.gets funcs -- Get the funcs element form the session
277 State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
281 ("hwxor", HWFunction [Port "a", Port "b"] (Port "o")),
282 ("hwand", HWFunction [Port "a", Port "b"] (Port "o"))