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 liftIO $ putStr $ showSDoc $ ppr expr
46 liftIO $ putStr "\n\n"
47 liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ getArchitecture bind
50 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
53 printBinds [] = putStr "done\n\n"
54 printBinds (b:bs) = do
59 printBind (NonRec b expr) = do
63 printBind (Rec binds) = do
65 foldl1 (>>) (map printBind' binds)
67 printBind' (b, expr) = do
68 putStr $ getOccString b
69 --putStr $ showSDoc $ ppr expr
72 findBind :: String -> [CoreBind] -> CoreBind
74 -- This ignores Recs and compares the name of the bind with lookfor,
75 -- disregarding any namespaces in OccName and extra attributes in Name and
77 Maybe.fromJust . find (\b -> case b of
79 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
82 -- Accepts a port name and an argument to map to it.
83 -- Returns the appropriate line for in the port map
84 getPortMapEntry binds portname (Var id) =
85 (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))
87 Port signalname = Maybe.fromMaybe
88 (error $ "Argument " ++ getOccString id ++ "is unknown")
91 getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
94 PortNameMap -- The arguments that need to be applied to the
95 -- expression. Should always be the Args
97 -> PortNameMap -- The output ports that the expression should generate.
98 -> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
99 -> CoreSyn.CoreExpr -- The expression to generate an architecture for
100 -> [AST.ConcSm] -- The resulting VHDL code
102 -- A lambda expression binds the first argument (a) to the binder b.
103 getInstantiations (Args (a:as)) outs binds (Lam b expr) =
104 getInstantiations (Args as) outs ((b, a):binds) expr
106 -- A case expression that checks a single variable and has a single
107 -- alternative, can be used to take tuples apart
108 getInstantiations args outs binds (Case (Var v) b _ [res]) =
111 if (DataCon.isTupleCon datacon) then
112 getInstantiations args outs binds' expr
114 error "Data constructors other than tuples not supported"
116 error "Case binders other than tuples not supported"
118 binds' = (zip bind_vars tuple_ports) ++ binds
119 (altcon, bind_vars, expr) = res
120 -- Find the portnamemaps for each of the tuple's elements
121 Tuple tuple_ports = Maybe.fromMaybe
122 (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
125 -- An application is an instantiation of a component
126 getInstantiations args outs binds app@(App expr arg) =
127 if isTupleConstructor f then
129 Tuple outports = outs
130 (tys, vals) = splitTupleConstructorArgs fargs
133 (\outs' expr' -> getInstantiations args outs' binds expr')
138 ((Var f), fargs) = collectArgs app
140 (AST.unsafeVHDLBasicId "app")
141 (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId compname)))
142 (AST.PMapAspect ports)
143 compname = getOccString f
145 zipWith (getPortMapEntry binds) ["portin0", "portin1"] fargs
146 ++ mapOutputPorts (Port "portout") outs
148 getInstantiations args outs binds expr =
149 error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
151 -- Is the given name a (binary) tuple constructor
152 isTupleConstructor :: Var.Var -> Bool
153 isTupleConstructor var =
154 Name.isWiredInName name
155 && Name.nameModule name == tuple_mod
156 && (Name.occNameString $ Name.nameOccName name) == "(,)"
158 name = Var.varName var
159 mod = nameModule name
160 tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
162 -- Split arguments into type arguments and value arguments This is probably
163 -- not really sufficient (not sure if Types can actually occur as value
165 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
166 splitTupleConstructorArgs (e:es) =
168 Type t -> (e:tys, vals)
169 otherwise -> (tys, e:vals)
171 (tys, vals) = splitTupleConstructorArgs es
174 PortNameMap -- The output portnames of the component
175 -> PortNameMap -- The output portnames and/or signals to map these to
176 -> [AST.AssocElem] -- The resulting output ports
178 -- Map the output port of a component to the output port of the containing
180 mapOutputPorts (Port portname) (Port signalname) =
181 [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
183 -- Map matching output ports in the tuple
184 mapOutputPorts (Tuple ports) (Tuple signals) =
185 concat (zipWith mapOutputPorts ports signals)
188 CoreBind -- The binder to expand into an architecture
189 -> AST.ArchBody -- The resulting architecture
191 getArchitecture (Rec _) = error "Recursive binders not supported"
193 getArchitecture (NonRec var expr) =
195 (AST.unsafeVHDLBasicId "structural")
196 -- Use unsafe for now, to prevent pulling in ForSyDe error handling
197 (AST.NSimple (AST.unsafeVHDLBasicId name))
199 (getInstantiations (Args inportnames) outport [] expr)
201 name = (getOccString var)
202 ty = CoreUtils.exprType expr
203 (fargs, res) = Type.splitFunTys ty
204 --state = if length fargs == 1 then () else (last fargs)
205 ports = if length fargs == 1 then fargs else (init fargs)
206 inportnames = case ports of
207 [port] -> [getPortNameMapForTy "portin" port]
208 ps -> getPortNameMapForTys "portin" 0 ps
209 outport = getPortNameMapForTy "portout" res
212 Args [PortNameMap] -- Each of the submaps represent an argument to the
213 -- function. Should only occur at top level.
214 | Tuple [PortNameMap]
217 -- Generate a port name map (or multiple for tuple types) in the given direction for
219 getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
220 getPortNameMapForTys prefix num [] = []
221 getPortNameMapForTys prefix num (t:ts) =
222 (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
224 getPortNameMapForTy :: String -> Type -> PortNameMap
225 getPortNameMapForTy name ty =
226 if (TyCon.isTupleTyCon tycon) then
227 -- Expand tuples we find
228 Tuple (getPortNameMapForTys name 0 args)
229 else -- Assume it's a type constructor application, ie simple data type
233 (tycon, args) = Type.splitTyConApp ty